The Lensening.

src/Bang/AST.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bang.AST
+       ( Module
+       , ppModule
+       , mkModule
+       , moduleName, moduleDeclarations
+       , module Bang.AST.Declaration
+       , module Bang.AST.Expression
+       , module Bang.AST.Name
+       , module Bang.AST.Type
+       )
+ where
+
+import Bang.AST.Declaration
+import Bang.AST.Expression
+import Bang.AST.Name
+import Bang.AST.Type
+import Control.Lens(view)
+import Control.Lens.TH(makeLenses)
+import Text.PrettyPrint.Annotated(Doc, empty, text, (<+>), ($+$))
+
+data Module = Module {
+       _moduleName         :: Name
+     , _moduleDeclarations :: [Declaration]
+     }
+
+mkModule :: Name -> [Declaration] -> Module
+mkModule = Module
+
+makeLenses ''Module
+
+ppModule :: Module -> Doc a
+ppModule m = text "module" <+> ppName (view moduleName m) $+$
+             dump (view moduleName m) (view moduleDeclarations m)
+ where
+  dump _    [] = empty
+  dump prev (x:rest)
+    | prev == view declName x =
+         ppDeclaration x $+$ dump prev rest
+    | otherwise = 
+         text "" $+$ dump (view declName x) (x:rest)
+

src/Bang/AST/Declaration.hs

@@ -0,0 +1,129 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bang.AST.Declaration
+       ( Declaration(..)
+       , ppDeclaration
+       , declName
+       -- * Type Declarations
+       , TypeDeclaration
+       , ppTypeDeclaration
+       , mkTypeDecl
+       , tdName, tdLocation, tdType
+       -- * Value Declarations
+       , ValueDeclaration
+       , ppValueDeclaration
+       , mkValueDecl
+       , vdName, vdLocation
+       , vdFreeTypeVariables, vdFreeValueVariables
+       , vdDeclaredType, vdValue
+       -- * Declarations of primitive types
+       , PrimitiveDeclaration
+       , ppPrimitiveDeclaration
+       , mkPrimDecl
+       , pdName, pdLocation, pdLLVMType
+       )
+ where
+
+import Bang.AST.Expression(Expression, ppExpression)
+import Bang.AST.Name(Name, ppName)
+import Bang.AST.Type(Type, ppType)
+import Bang.Syntax.Location(Location)
+import Bang.Utils.Pretty(text')
+import Data.Text.Lazy(Text)
+import Control.Lens(Lens', view, set, lens)
+import Control.Lens(makeLenses)
+import Text.PrettyPrint.Annotated(Doc, text, (<+>))
+
+data TypeDeclaration = TypeDeclaration
+     { _tdName     :: Name
+     , _tdLocation :: Location
+     , _tdType     :: Type
+     }
+ deriving (Show)
+
+class MkTypeDecl a where
+  mkTypeDecl :: Name -> Location -> Type -> a
+
+ppTypeDeclaration :: TypeDeclaration -> Doc a
+ppTypeDeclaration td =
+  ppName (_tdName td) <+> text "::" <+> ppType (_tdType td)
+
+instance MkTypeDecl TypeDeclaration where
+  mkTypeDecl = TypeDeclaration
+
+instance MkTypeDecl Declaration where
+  mkTypeDecl n l t = DeclType (TypeDeclaration n l t)
+
+-- -----------------------------------------------------------------------------
+
+data ValueDeclaration = ValueDeclaration
+     { _vdName               :: Name
+     , _vdLocation           :: Location
+     , _vdFreeTypeVariables  :: [Name]
+     , _vdFreeValueVariables :: [Name]
+     , _vdDeclaredType       :: Maybe Type
+     , _vdValue              :: Expression
+     }
+ deriving (Show)
+
+class MkValueDecl a where
+  mkValueDecl :: Name -> Location -> Expression -> a
+
+ppValueDeclaration :: ValueDeclaration -> Doc a
+ppValueDeclaration vd =
+  ppName (_vdName vd) <+> text "=" <+> ppExpression (_vdValue vd)
+
+instance MkValueDecl ValueDeclaration where
+  mkValueDecl n l e = ValueDeclaration n l [] [] Nothing e
+
+instance MkValueDecl Declaration where
+  mkValueDecl n l e = DeclVal (ValueDeclaration n l [] [] Nothing e)
+
+-- -----------------------------------------------------------------------------
+
+data PrimitiveDeclaration = PrimitiveDeclaration
+     { _pdName     :: Name
+     , _pdLocation :: Location
+     , _pdLLVMType :: Text
+     }
+ deriving (Show)
+
+class MkPrimDecl a where
+  mkPrimDecl :: Name -> Location -> Text -> a
+
+ppPrimitiveDeclaration :: PrimitiveDeclaration -> Doc a
+ppPrimitiveDeclaration pd =
+  text "primitive" <+> text "type" <+> ppName (_pdName pd) <+>
+  text "=" <+> text' (_pdLLVMType pd)
+
+instance MkPrimDecl PrimitiveDeclaration where
+  mkPrimDecl = PrimitiveDeclaration
+
+instance MkPrimDecl Declaration where
+  mkPrimDecl n l t = DeclPrim (PrimitiveDeclaration n l t)
+
+-- -----------------------------------------------------------------------------
+
+data Declaration = DeclType TypeDeclaration
+                 | DeclVal  ValueDeclaration
+                 | DeclPrim PrimitiveDeclaration
+ deriving (Show)
+
+ppDeclaration :: Declaration -> Doc a
+ppDeclaration (DeclType d) = ppTypeDeclaration d
+ppDeclaration (DeclVal  d) = ppValueDeclaration d
+ppDeclaration (DeclPrim d) = ppPrimitiveDeclaration d
+
+makeLenses ''TypeDeclaration
+makeLenses ''ValueDeclaration
+makeLenses ''PrimitiveDeclaration
+
+declName :: Lens' Declaration Name
+declName = lens getter setter
+ where
+  getter (DeclType d) = view tdName d
+  getter (DeclVal  d) = view vdName d
+  getter (DeclPrim d) = view pdName d
+  setter (DeclType d) x = DeclType (set tdName x d)
+  setter (DeclVal  d) x = DeclVal  (set vdName x d)
+  setter (DeclPrim d) x = DeclPrim (set pdName x d)
+

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
+

src/Bang/AST/Name.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bang.AST.Name(
+         NameEnvironment(..)
+       , Name
+       , mkName
+       , ppName
+       , nameText
+       , nameEnvironment
+       , nameLocation
+       , nameIndex
+       )
+ where
+
+import Control.Lens(view)
+import Control.Lens.TH(makeLenses)
+import Data.Text.Lazy(Text, unpack)
+import Data.Word(Word)
+import Bang.Syntax.Location(Location)
+import Bang.Utils.Pretty(text', word)
+import Text.PrettyPrint.Annotated(Doc, colon, (<>))
+
+data NameEnvironment = ModuleEnv | TypeEnv | VarEnv
+ deriving (Eq, Ord, Show)
+
+data Name = Name
+     { _nameText        :: Text
+     , _nameEnvironment :: NameEnvironment
+     , _nameLocation    :: Location
+     , _nameIndex       :: Word
+     }
+
+makeLenses ''Name
+
+mkName :: Text -> NameEnvironment -> Location -> Word -> Name
+mkName = Name
+
+ppName :: Name -> Doc a
+ppName n = text' (view nameText n) <> colon <> word (view nameIndex n)
+
+instance Eq Name where
+  a == b = view nameIndex a == view nameIndex b
+  a /= b = view nameIndex a /= view nameIndex b
+
+instance Ord Name where
+  compare a b = compare (view nameIndex a) (view nameIndex b)
+  max     a b = if a < b then b else a
+  min     a b = if a < b then a else b
+  (<)     a b = (<)     (view nameIndex a) (view nameIndex b)
+  (>)     a b = (>)     (view nameIndex a) (view nameIndex b)
+  (<=)    a b = (<=)    (view nameIndex a) (view nameIndex b)
+  (>=)    a b = (>=)    (view nameIndex a) (view nameIndex b)
+
+instance Show Name where
+  show n = unpack (view nameText n) ++ ":" ++ show (view nameIndex n)

src/Bang/AST/Type.hs

@@ -0,0 +1,190 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bang.AST.Type
+       ( Type(..)
+       , ppType
+       , Kind(..)
+       , ppKind
+       , Kinded(..)
+         -- * the unit time
+       , UnitType
+       , ppUnitType
+         -- * primitive types
+       , PrimitiveType
+       , ppPrimitiveType
+       , mkPrimType
+       , ptLocation, ptName
+         -- * reference types
+       , ReferenceType
+       , ppReferenceType
+       , mkTypeRef
+       , rtLocation, rtKind, rtName
+         -- * lambda types
+       , FunctionType
+       , ppFunctionType
+       , mkFunType
+       , ftLocation, ftKind, ftArgumentTypes, ftResultType
+         -- * type application
+       , TypeApplication
+       , ppTypeApplication
+       , mkTypeApp
+       , taLocation, taKind, taLeftType, taRightType
+       )
+ where
+
+import Bang.AST.Name(Name, ppName)
+import Bang.Syntax.Location(Location)
+import Control.Lens.TH(makeLenses)
+import Text.PrettyPrint.Annotated(Doc, (<+>), (<>), text, hsep)
+
+data Kind = Star
+          | Unknown
+          | KindArrow Kind Kind
+  deriving (Show, Eq)
+
+ppKind :: Kind -> Doc a
+ppKind Star            = text "*"
+ppKind Unknown         = text "?"
+ppKind (KindArrow a b) = ppKind a <+> text "->" <+> ppKind b
+
+class Kinded a where
+  kind :: a -> Kind
+
+-- -----------------------------------------------------------------------------
+
+data UnitType = UnitType
+ deriving (Show)
+
+instance Kinded UnitType where
+  kind _ = Star
+
+ppUnitType :: UnitType -> Doc a
+ppUnitType _ = text "()"
+
+-- -----------------------------------------------------------------------------
+
+data PrimitiveType = PrimitiveType
+     { _ptLocation :: Location
+     , _ptName     :: Name
+     }
+ deriving (Show)
+
+class MkPrimType a where
+  mkPrimType :: Location -> Name -> a
+
+instance Kinded PrimitiveType where
+  kind _ = Star
+
+instance MkPrimType PrimitiveType where
+  mkPrimType = PrimitiveType
+
+instance MkPrimType Type where
+  mkPrimType l n = TypePrim (PrimitiveType l n)
+
+ppPrimitiveType :: PrimitiveType -> Doc a
+ppPrimitiveType pt = text "llvm:" <> ppName (_ptName pt)
+
+-- -----------------------------------------------------------------------------
+
+data ReferenceType = ReferenceType
+     { _rtLocation :: Location
+     , _rtKind     :: Kind
+     , _rtName     :: Name
+     }
+ deriving (Show)
+
+instance Kinded ReferenceType where
+  kind = _rtKind
+
+ppReferenceType :: ReferenceType -> Doc a
+ppReferenceType = ppName . _rtName
+
+class MkTypeRef a where
+  mkTypeRef :: Location -> Kind -> Name -> a
+
+instance MkTypeRef ReferenceType where
+  mkTypeRef = ReferenceType
+
+instance MkTypeRef Type where
+  mkTypeRef l k n = TypeRef (ReferenceType l k n)
+
+-- -----------------------------------------------------------------------------
+
+data FunctionType = FunctionType
+     { _ftLocation      :: Location
+     , _ftKind          :: Kind
+     , _ftArgumentTypes :: [Type]
+     , _ftResultType    :: Type
+     }
+ deriving (Show)
+
+class MkFunType a where
+  mkFunType :: Location -> [Type] -> Type -> a
+
+instance MkFunType FunctionType where
+  mkFunType l a r = FunctionType l Star a r
+
+instance MkFunType Type where
+  mkFunType l a r = TypeFun (FunctionType l Star a r)
+
+ppFunctionType :: FunctionType -> Doc a
+ppFunctionType ft =
+  hsep (map ppType (_ftArgumentTypes ft)) <+> text "->" <+>
+  ppType (_ftResultType ft)
+
+instance Kinded FunctionType where
+  kind = _ftKind
+
+-- -----------------------------------------------------------------------------
+
+data TypeApplication = TypeApplication
+     { _taLocation  :: Location
+     , _taKind      :: Kind
+     , _taLeftType  :: Type
+     , _taRightType :: Type
+     }
+ deriving (Show)
+
+class MkTypeApp a where
+  mkTypeApp :: Location -> Type -> Type -> a
+
+instance MkTypeApp TypeApplication where
+  mkTypeApp l s t  = TypeApplication l Unknown s t
+
+instance MkTypeApp Type where
+  mkTypeApp l s t = TypeApp (TypeApplication l Unknown s t)
+
+instance Kinded TypeApplication where
+  kind = _taKind
+
+ppTypeApplication :: TypeApplication -> Doc a
+ppTypeApplication ta =
+  ppType (_taLeftType ta) <+> ppType (_taRightType ta)
+
+-- -----------------------------------------------------------------------------
+
+data Type = TypeUnit UnitType
+          | TypePrim PrimitiveType
+          | TypeRef  ReferenceType
+          | TypeFun  FunctionType
+          | TypeApp  TypeApplication
+ deriving (Show)
+
+ppType :: Type -> Doc a
+ppType (TypeUnit t) = ppUnitType        t
+ppType (TypePrim t) = ppPrimitiveType   t
+ppType (TypeRef  t) = ppReferenceType   t
+ppType (TypeFun  t) = ppFunctionType    t
+ppType (TypeApp  t) = ppTypeApplication t
+
+instance Kinded Type where
+  kind (TypeUnit x) = kind x
+  kind (TypePrim x) = kind x
+  kind (TypeRef  x) = kind x
+  kind (TypeFun  x) = kind x
+  kind (TypeApp  x) = kind x
+
+makeLenses ''PrimitiveType
+makeLenses ''ReferenceType
+makeLenses ''FunctionType
+makeLenses ''TypeApplication
+

src/Bang/Monad.hs

@@ -15,10 +15,11 @@ module Bang.Monad(
        )
  where
 
+import           Bang.AST.Expression(Expression, mkRefExp)
+import           Bang.AST.Name(NameEnvironment(..), Name, mkName)
+import           Bang.AST.Type(Kind(..), Type, mkTypeRef)
 import           Bang.CommandLine(BangCommand, CommandsWithInputFile(..))
 import           Bang.Error(exit)
-import           Bang.Syntax.AST(NameEnvironment(..), Name(..),
-                                 Kind(..), Type(..), Expression(..))
 import           Bang.Syntax.Location(Location(..), Origin(..),
                                       unknownLocation, ppLocation)
 import           Bang.Utils.Pretty(BangDoc)
@@ -110,21 +111,22 @@ registerNewName :: NameEnvironment -> Text -> Compiler s Name
 registerNewName env name =
   Compiler (\ st ->
               do let current = view csNextIdent st
-                     res     = Name unknownLocation env current name
+                     res     = mkName name env unknownLocation current
                  return (over csNextIdent (+1) st, res))
 
 genName :: NameEnvironment -> Compiler s Name
-genName env = Compiler (\ st ->
+genName env =
-                         do let current = view csNextIdent st
+  Compiler (\ st ->
-                                str = "gen:" ++ show current
+             do let current = view csNextIdent st
-                                res = Name unknownLocation env current (pack str)
+                    str = "gen:" ++ show current
-                            return (over csNextIdent (+1) st, res))
+                    res = mkName (pack str) env unknownLocation current
+                return (over csNextIdent (+1) st, res))
 
 genTypeRef :: Kind -> Compiler s Type
-genTypeRef k = TypeRef unknownLocation k `fmap` genName TypeEnv
+genTypeRef k = mkTypeRef unknownLocation k `fmap` genName TypeEnv
 
 genVarRef :: Compiler s Expression
-genVarRef = ReferenceExp unknownLocation `fmap` genName VarEnv
+genVarRef = mkRefExp unknownLocation `fmap` genName VarEnv
 
 -- -----------------------------------------------------------------------------
 

src/Bang/Syntax/AST.hs

@@ -1,71 +0,0 @@
-module Bang.Syntax.AST
- where
-
-import Data.Text.Lazy(Text)
-import Bang.Syntax.Location(Location)
-
-data NameEnvironment = ModuleEnv | TypeEnv | VarEnv
- deriving (Eq, Ord, Show)
-
-data Name = Name Location NameEnvironment Word Text
- deriving (Show)
-
-instance Eq Name where
-  (Name _ _ x _) == (Name _ _ y _) = x == y
-  (Name _ _ x _) /= (Name _ _ y _) = x /= y
-
-instance Ord Name where
-  compare (Name _ _ x _) (Name _ _ y _) = compare x y
-  --
-  max     n1@(Name _ _ x _) n2@(Name _ _ y _) = if x > y then n1 else n2
-  min     n1@(Name _ _ x _) n2@(Name _ _ y _) = if x > y then n2 else n1
-  --
-  (Name _ _ x _) <  (Name _ _ y _) = x <  y
-  (Name _ _ x _) <= (Name _ _ y _) = x <= y
-  (Name _ _ x _) >= (Name _ _ y _) = x >= y
-  (Name _ _ x _) >  (Name _ _ y _) = x >  y
-
-data Module = Module Name [Declaration]
- deriving (Show)
-
-data Declaration = TypeDeclaration     Name Type
-                 | ValueDeclaration    Name Expression
-                 | PrimTypeDeclaration Name Text
- deriving (Show)
-
-data Expression = ConstantExp  Location ConstantValue
-                | ReferenceExp Location Name
-                | LambdaExp    Location [Name] Expression
- deriving (Show)
-
-data ConstantValue = ConstantInt    Word Text
-                   | ConstantChar        Text
-                   | ConstantString      Text
-                   | ConstantFloat       Text
- deriving (Show)
-
-data Type = TypeUnit   Location Kind
-          | TypePrim   Location Kind Text
-          | TypeRef    Location Kind Name
-          | TypeLambda Location Kind [Type] Type
-          | TypeApp    Location Kind Type   Type
- deriving (Show)
-
-instance Eq Type where
-  (TypeUnit _ _)         == (TypeUnit _ _)         = True
-  (TypePrim _ _ a)       == (TypePrim _ _ b)       = a == b
-  (TypeRef  _ _ n)       == (TypeRef  _ _ m)       = n == m
-  (TypeLambda _ _ at et) == (TypeLambda _ _ bt ft) = (at == bt) && (et == ft)
-  (TypeApp    _ _ at bt) == (TypeApp    _ _ ct dt) = (at == ct) && (bt == dt)
-  _                      == _                      = False
-
-kind :: Type -> Kind
-kind (TypeUnit   _ k)     = k
-kind (TypePrim   _ k _)   = k
-kind (TypeRef    _ k _)   = k
-kind (TypeLambda _ k _ _) = k
-kind (TypeApp    _ k _ _) = k
-
-data Kind = Star
-          | KindArrow Kind Kind
-  deriving (Show, Eq)

src/Bang/Syntax/Parser.y

@@ -11,9 +11,10 @@ module Bang.Syntax.Parser(
  where
 
 import Bang.Monad(err)
-import Bang.Syntax.AST(Module(..), Name(..), NameEnvironment(..),
+import Bang.AST(Name, Module, NameEnvironment(..), mkModule)
-                       Declaration(..), Expression(..), Type(..), Kind(..),
+import Bang.AST.Declaration(Declaration, mkTypeDecl, mkPrimDecl, mkValueDecl)
-                       ConstantValue(..))
+import Bang.AST.Expression(ConstantValue(..), Expression, mkConstExp, mkRefExp, mkLambdaExp)
+import Bang.AST.Type(Type, Kind(..), mkTypeRef, mkFunType, mkTypeApp)
 import Bang.Syntax.Location(Located(..), Origin, Position)
 import Bang.Syntax.ParserError(ParserError(..))
 import Bang.Syntax.ParserMonad(Parser, addFixities, registerName,
@@ -119,7 +120,7 @@ top_module :: { Module }
     {%
        do let Located src (TypeIdent rawName) = $2
           name <- registerName False src ModuleEnv rawName
-          return (Module name $3) }
+          return (mkModule name $3) }
 
 Declaration :: { Maybe Declaration }
   : ValueDeclaration  { Just $1 }
@@ -142,12 +143,12 @@ ValueDeclLHS :: { (Expression -> Declaration, [Name]) }
             err (InternalError $2 "ValDeclLHS")
          [Located src (ValIdent rawName)] ->
            do name <- registerName True src VarEnv rawName
-              return (ValueDeclaration name, [name])
+              return (mkValueDecl name src , [name])
          ((Located src (ValIdent rawName)) : args) ->
            do name <- registerName True src VarEnv rawName
               argNames <- forM args $ \ (Located asrc (ValIdent argName)) ->
                             registerName True asrc VarEnv argName
-              let builder = ValueDeclaration name . LambdaExp $2 argNames
+              let builder = mkValueDecl name src . mkLambdaExp $2 argNames
               return (builder, argNames)
     }
 
@@ -164,13 +165,13 @@ TypeDeclaration :: { Declaration }
     {%
        do let Located src (ValIdent rawName) = $1
           name <- registerName True src VarEnv rawName
-          return (TypeDeclaration name $3) }
+          return (mkTypeDecl name src $3) }
   | 'primitive' 'type' TypeIdent '=' String
     {%
        do let Located src (TypeIdent rawName) = $3
               Located _   (StringTok rawText) = $5
           name <- registerName False src TypeEnv rawName
-          return (PrimTypeDeclaration name rawText) }
+          return (mkPrimDecl name src rawText) }
 
 -- -----------------------------------------------------------------------------
 
@@ -188,7 +189,7 @@ RawType :: { (Type, [Name]) }
   : RawType '->' BaseType {%
       do let (p1, names1) = $1
              (p2, names2) = $3
-         return (TypeLambda $2 (Star `KindArrow` Star) [p1] p2, union names1 names2)
+         return (mkFunType $2 [p1] p2, union names1 names2)
      }
   | BaseType           { $1 }
 
@@ -196,11 +197,11 @@ BaseType :: { (Type, [Name]) }
   : TypeIdent   {%
        do let Located src (TypeIdent rawName) = $1
           name <- lookupName src TypeEnv rawName
-          return (TypeRef src Star name, []) }
+          return (mkTypeRef src Unknown name, []) }
   | ValIdent    {%
        do let Located src (ValIdent rawName) = $1
           name <- registerName True src TypeEnv rawName
-          return (TypeRef src Star name, [name])
+          return (mkTypeRef src Unknown name, [name])
      }
 
 -- -----------------------------------------------------------------------------
@@ -212,23 +213,23 @@ BaseExpression :: { Expression }
   : OpIdent  {%
                 do let Located src (OpIdent _ rawName) = $1
                    name <- lookupName src VarEnv rawName
-                   return (ReferenceExp src name) }
+                   return (mkRefExp src name) }
   | ValIdent {%
                 do let Located src (ValIdent rawName) = $1
                    name <- lookupName src VarEnv rawName
-                   return (ReferenceExp src name) }
+                   return (mkRefExp src name) }
   | Integer  {%
                 do let Located src (IntTok base val) = $1
-                   return (ConstantExp src (ConstantInt base val)) }
+                   return (mkConstExp src (ConstantInt base val)) }
   | String   {%
                 do let Located src (StringTok val) = $1
-                   return (ConstantExp src (ConstantString val)) }
+                   return (mkConstExp src (ConstantString val)) }
   | Float    {%
                 do let Located src (FloatTok val) = $1
-                   return (ConstantExp src (ConstantFloat val)) }
+                   return (mkConstExp src (ConstantFloat val)) }
   | Char     {%
                 do let Located src (CharTok val) = $1
-                   return (ConstantExp src (ConstantChar val)) }
+                   return (mkConstExp src (ConstantChar val)) }
 
 -- -----------------------------------------------------------------------------
 

src/Bang/Syntax/ParserMonad.hs

@@ -13,9 +13,10 @@ module Bang.Syntax.ParserMonad(
        )
  where
 
+import           Bang.AST.Name(Name, NameEnvironment(..), mkName,
+                               nameLocation, nameText)
 import           Bang.Monad(Compiler, err, runPass,
                             getPassState, overPassState, viewPassState)
-import           Bang.Syntax.AST(Name(..), NameEnvironment(..))
 import           Bang.Syntax.Lexer(AlexReturn(..), AlexInput(..), alexScan)
 import           Bang.Syntax.Location(Location(..), Located(..),
                                       Origin(..), initialPosition,
@@ -107,19 +108,19 @@ registerName redefOk loc env name =
      let key = (env, name)
      case Map.lookup key (view psNameDatabase state) of
        Nothing ->
-         do let res = Name loc env (view psNextIdent state) name
+         do let res = mkName name env loc (view psNextIdent state)
             overPassState (over psNameDatabase (Map.insert key res) .
                            over psNextIdent (+1))
             return res
        Just res | redefOk ->
          return res
-       Just (Name origLoc _ _ _) ->
+       Just name' ->
-         err (RedefinitionError loc origLoc name)
+         err (RedefinitionError loc (view nameLocation name') name)
 
 unregisterNames :: NameEnvironment -> [Name] -> Parser ()
 unregisterNames env names =
   do db <- viewPassState psNameDatabase
-     let db' = foldr (\ (Name _ _ _ n) m -> Map.delete (env, n) m) db names
+     let db' = foldr (\ n m -> Map.delete (env, view nameText n) m) db names
      overPassState (set psNameDatabase db')
 
 lookupName :: Location -> NameEnvironment -> Text -> Parser Name

src/Bang/Syntax/PostProcess.hs

@@ -0,0 +1,15 @@
+module Bang.Syntax.PostProcess(
+         runPostProcessor
+       )
+
+import Bang.Syntax.AST
+
+runPostProcessor :: Module -> Compiler ps Module
+runPostProcessor mod = undefined
+
+-- -----------------------------------------------------------------------------
+
+type DeclarationTable = Map Name (Maybe TypeDeclaration, Maybe ValueDeclaration)
+
+makeDeclarationTable :: Module -> DeclarationTable
+

src/Bang/Syntax/Pretty.hs

@@ -1,64 +0,0 @@
-module Bang.Syntax.Pretty(
-         ppModule
-       , ppDeclaration
-       , ppExpression
-       , ppType
-       , ppName
-       )
- where
-
-import Bang.Syntax.AST
-import Data.Text.Lazy(Text, unpack)
-import Text.PrettyPrint.Annotated
-
-ppName :: Name -> Doc a
-ppName (Name _ _ w t) = text' t <> colon <> integer (fromIntegral w)
-
-ppModule :: Module -> Doc a
-ppModule (Module name decls) =
-  vcat ([text "module" <> space <> ppName name, text ""] ++
-        map ppDeclaration decls)
-
-ppDeclaration :: Declaration -> Doc a
-ppDeclaration d =
-  case d of
-    TypeDeclaration n t ->
-      ppName n <> space <> text "::" <> space <> ppType t
-    ValueDeclaration n e ->
-      ppName n <> space <> text "=" <> space <> ppExpression e
-    PrimTypeDeclaration n t ->
-      text "primitive" <> space <> text "type" <> space <>
-      ppName n <> space <> text "=" <> space <> text' t
-
-ppExpression :: Expression -> Doc a
-ppExpression x =
-  case x of
-    ConstantExp  _ v    -> ppConstantValue v
-    ReferenceExp _ n    -> ppName n
-    LambdaExp    _ ns e ->
-      text "λ" <> space <> hsep (map ppName ns) <> space <> text "->" <>
-      space <> ppExpression e
-
-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
-
-ppType :: Type -> Doc a
-ppType t =
-  case t of
-    TypeUnit   _ _      -> text "()"
-    TypePrim   _ _ n    -> text (unpack n)
-    TypeRef    _ _ n    -> ppName n
-    TypeLambda _ _ as b -> hsep (map ppType as) <> space <> text "->" <> space <> ppType b
-    TypeApp    _ _ a  b -> ppType a <> space <> ppType b
-
-text' :: Text -> Doc a
-text' = text . unpack

src/Bang/TypeInfer.hs

@@ -3,14 +3,16 @@
 module Bang.TypeInfer(runTypeInference)
  where
 
+runTypeInference :: a
+runTypeInference = undefined
+
+{- Better version 
 import           Bang.Monad(Compiler, BangError(..), err,
                             runPass, getPassState, setPassState,
                             viewPassState, overPassState,
                             registerNewName, genName)
-import           Bang.Syntax.AST
 import           Bang.Syntax.Location(Location, unknownLocation)
 import           Bang.Syntax.ParserMonad(NameDatabase(..))
-import           Bang.Syntax.Pretty(ppName)
 import           Bang.Utils.Pretty(BangDoc)
 import           Control.Lens(set, view, over)
 import           Control.Lens.TH(makeLenses)
@@ -91,7 +93,7 @@ inferModule = undefined
 
 runTypeInference :: NameDatabase -> Module -> Compiler ps Module
 runTypeInference ndb mod = runInfer ndb (inferModule mod)
-
+-}
 -- data Scheme = Scheme [Name] Type
 -- 
 -- getName :: NameEnvironment -> Text -> Infer Name

src/Main.hs

@@ -1,8 +1,7 @@
-import           Bang.CommandLine
+import           Bang.CommandLine(getCommand, BangCommand(..), helpString)
-import           Bang.Monad
+import           Bang.AST(ppModule)
-import           Bang.Syntax.Lexer()
+import           Bang.Monad(runCompiler)
 import           Bang.Syntax.Parser(runParser, parseModule)
-import           Bang.Syntax.Pretty(ppModule)
 import           Bang.TypeInfer(runTypeInference)
 import           Data.Version(showVersion)
 import           Paths_bang(version)