The Lensening.

src/Bang/AST/Expression.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bang.AST.Expression
+       ( Expression
+       , ppExpression
+       -- * Constant Expressions
+       , ConstantExpression
+       , ppConstantExpression
+       , mkConstExp
+       , constLocation
+       , constValue
+       , ConstantValue(..)
+       , ppConstantValue
+       -- * References
+       , ReferenceExpression
+       , ppReferenceExpression
+       , mkRefExp
+       , refLocation
+       , refName
+       -- * Lambdas
+       , LambdaExpression
+       , ppLambdaExpression
+       , mkLambdaExp
+       , lambdaLocation
+       , lambdaArgumentNames
+       , lambdaBody
+       )
+ where
+
+import Bang.Syntax.Location(Location)
+import Bang.AST.Name(Name, ppName)
+import Bang.Utils.Pretty(text')
+import Control.Lens.TH(makeLenses)
+import Data.Text.Lazy(Text)
+import Text.PrettyPrint.Annotated(Doc, text, hsep, (<>), (<+>))
+
+-- -----------------------------------------------------------------------------
+
+data ConstantValue = ConstantInt    Word Text
+                   | ConstantChar        Text
+                   | ConstantString      Text
+                   | ConstantFloat       Text
+ deriving (Show)
+
+ppConstantValue :: ConstantValue -> Doc a
+ppConstantValue cv =
+  case cv of
+    ConstantInt    2  t -> text "0b" <> text' t
+    ConstantInt    8  t -> text "0o" <> text' t
+    ConstantInt    10 t ->              text' t
+    ConstantInt    16 t -> text "0x" <> text' t
+    ConstantInt    _  _ -> error "Internal error: bad base for constant"
+    ConstantChar      c -> text' c
+    ConstantString    s -> text' s
+    ConstantFloat     f -> text' f
+
+data ConstantExpression = ConstantExpression
+     { _constLocation :: Location
+     , _constValue    :: ConstantValue
+     }
+ deriving (Show)
+
+class MkConstExp a where
+  mkConstExp :: Location -> ConstantValue -> a
+
+instance MkConstExp ConstantExpression where
+  mkConstExp = ConstantExpression
+
+instance MkConstExp Expression where
+  mkConstExp l v = ConstExp (mkConstExp l v)
+
+ppConstantExpression :: ConstantExpression -> Doc a
+ppConstantExpression = ppConstantValue . _constValue
+
+-- -----------------------------------------------------------------------------
+
+data ReferenceExpression = ReferenceExpression
+     { _refLocation :: Location
+     , _refName     :: Name
+     }
+ deriving (Show)
+
+ppReferenceExpression :: ReferenceExpression -> Doc a
+ppReferenceExpression = ppName . _refName
+
+class MkRefExp a where
+  mkRefExp :: Location -> Name -> a
+
+instance MkRefExp ReferenceExpression where
+  mkRefExp = ReferenceExpression
+
+instance MkRefExp Expression where
+  mkRefExp l n = RefExp (ReferenceExpression l n)
+
+-- -----------------------------------------------------------------------------
+
+data LambdaExpression = LambdaExpression
+     { _lambdaLocation      :: Location
+     , _lambdaArgumentNames :: [Name]
+     , _lambdaBody          :: Expression
+     }
+ deriving (Show)
+
+class MkLambdaExp a where
+  mkLambdaExp :: Location -> [Name] -> Expression -> a
+
+ppLambdaExpression :: LambdaExpression -> Doc a
+ppLambdaExpression le =
+  text "λ" <+> hsep (map ppName (_lambdaArgumentNames le)) <+> text "->" <+>
+  ppExpression (_lambdaBody le)
+
+instance MkLambdaExp LambdaExpression where
+  mkLambdaExp = LambdaExpression
+
+instance MkLambdaExp Expression where
+  mkLambdaExp l a b = LambdaExp (LambdaExpression l a b)
+
+-- -----------------------------------------------------------------------------
+
+data Expression = ConstExp  ConstantExpression
+                | RefExp    ReferenceExpression
+                | LambdaExp LambdaExpression
+ deriving (Show)
+
+ppExpression :: Expression -> Doc a
+ppExpression (ConstExp  e) = ppConstantExpression  e
+ppExpression (RefExp    e) = ppReferenceExpression e
+ppExpression (LambdaExp e) = ppLambdaExpression    e
+
+makeLenses ''ConstantExpression
+makeLenses ''ReferenceExpression
+makeLenses ''LambdaExpression
+