From 82c260fec3b7df5ee69d26bcbabe902e6f4ac591 Mon Sep 17 00:00:00 2001 From: Adam Wick Date: Thu, 7 Jul 2016 22:22:27 -0700 Subject: [PATCH] The Lensening. --- src/Bang/AST.hs | 42 ++++++++ src/Bang/AST/Declaration.hs | 129 ++++++++++++++++++++++ src/Bang/AST/Expression.hs | 132 +++++++++++++++++++++++ src/Bang/AST/Name.hs | 54 ++++++++++ src/Bang/AST/Type.hs | 190 +++++++++++++++++++++++++++++++++ src/Bang/Monad.hs | 22 ++-- src/Bang/Syntax/AST.hs | 71 ------------ src/Bang/Syntax/Parser.y | 35 +++--- src/Bang/Syntax/ParserMonad.hs | 11 +- src/Bang/Syntax/PostProcess.hs | 15 +++ src/Bang/Syntax/Pretty.hs | 64 ----------- src/Bang/TypeInfer.hs | 8 +- src/Main.hs | 7 +- 13 files changed, 606 insertions(+), 174 deletions(-) create mode 100644 src/Bang/AST.hs create mode 100644 src/Bang/AST/Declaration.hs create mode 100644 src/Bang/AST/Expression.hs create mode 100644 src/Bang/AST/Name.hs create mode 100644 src/Bang/AST/Type.hs delete mode 100644 src/Bang/Syntax/AST.hs create mode 100644 src/Bang/Syntax/PostProcess.hs delete mode 100644 src/Bang/Syntax/Pretty.hs diff --git a/src/Bang/AST.hs b/src/Bang/AST.hs new file mode 100644 index 0000000..29d6de5 --- /dev/null +++ b/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) + diff --git a/src/Bang/AST/Declaration.hs b/src/Bang/AST/Declaration.hs new file mode 100644 index 0000000..44356f8 --- /dev/null +++ b/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) + diff --git a/src/Bang/AST/Expression.hs b/src/Bang/AST/Expression.hs new file mode 100644 index 0000000..39b980f --- /dev/null +++ b/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 + diff --git a/src/Bang/AST/Name.hs b/src/Bang/AST/Name.hs new file mode 100644 index 0000000..732a221 --- /dev/null +++ b/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) diff --git a/src/Bang/AST/Type.hs b/src/Bang/AST/Type.hs new file mode 100644 index 0000000..5ff3c62 --- /dev/null +++ b/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 + diff --git a/src/Bang/Monad.hs b/src/Bang/Monad.hs index 5dca725..5a3449a 100644 --- a/src/Bang/Monad.hs +++ b/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 -> - do let current = view csNextIdent st - str = "gen:" ++ show current - res = Name unknownLocation env current (pack str) - return (over csNextIdent (+1) st, res)) +genName env = + Compiler (\ st -> + do let current = view csNextIdent st + str = "gen:" ++ show current + 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 -- ----------------------------------------------------------------------------- diff --git a/src/Bang/Syntax/AST.hs b/src/Bang/Syntax/AST.hs deleted file mode 100644 index f5e7b1d..0000000 --- a/src/Bang/Syntax/AST.hs +++ /dev/null @@ -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) diff --git a/src/Bang/Syntax/Parser.y b/src/Bang/Syntax/Parser.y index 5be79fe..803425b 100644 --- a/src/Bang/Syntax/Parser.y +++ b/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(..), - Declaration(..), Expression(..), Type(..), Kind(..), - ConstantValue(..)) +import Bang.AST(Name, Module, NameEnvironment(..), mkModule) +import Bang.AST.Declaration(Declaration, mkTypeDecl, mkPrimDecl, mkValueDecl) +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)) } -- ----------------------------------------------------------------------------- diff --git a/src/Bang/Syntax/ParserMonad.hs b/src/Bang/Syntax/ParserMonad.hs index 0704c96..b54ee35 100644 --- a/src/Bang/Syntax/ParserMonad.hs +++ b/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 _ _ _) -> - err (RedefinitionError loc origLoc name) + Just 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 diff --git a/src/Bang/Syntax/PostProcess.hs b/src/Bang/Syntax/PostProcess.hs new file mode 100644 index 0000000..76ee9e7 --- /dev/null +++ b/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 + diff --git a/src/Bang/Syntax/Pretty.hs b/src/Bang/Syntax/Pretty.hs deleted file mode 100644 index 5b896e9..0000000 --- a/src/Bang/Syntax/Pretty.hs +++ /dev/null @@ -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 diff --git a/src/Bang/TypeInfer.hs b/src/Bang/TypeInfer.hs index 875edd0..470a488 100644 --- a/src/Bang/TypeInfer.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 65fccb1..d27ef74 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,8 +1,7 @@ -import Bang.CommandLine -import Bang.Monad -import Bang.Syntax.Lexer() +import Bang.CommandLine(getCommand, BangCommand(..), helpString) +import Bang.AST(ppModule) +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)