From 15b4059163e28a8ac9f6c959f258c69ce0386648 Mon Sep 17 00:00:00 2001 From: Adam Wick Date: Sun, 17 Jul 2016 12:22:41 -0700 Subject: [PATCH] Clean up type declarations for most of the system, at the cost of some post-processing shenanigans. --- src/Bang/AST/Declaration.hs | 54 +++++++--------------------------- src/Bang/AST/Expression.hs | 18 ++++++++++-- src/Bang/AST/Name.hs | 9 ++++-- src/Bang/AST/Type.hs | 10 ++++--- src/Bang/Syntax/Location.hs | 6 ++++ src/Bang/Syntax/Parser.y | 25 +++++++++------- src/Bang/Syntax/PostProcess.hs | 52 +++++++++++++++++--------------- 7 files changed, 89 insertions(+), 85 deletions(-) diff --git a/src/Bang/AST/Declaration.hs b/src/Bang/AST/Declaration.hs index a2035e5..63e0013 100644 --- a/src/Bang/AST/Declaration.hs +++ b/src/Bang/AST/Declaration.hs @@ -15,24 +15,17 @@ module Bang.AST.Declaration , 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.AST.Type(Type(TypePrim), 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, (<+>), ($+$), empty) -import Text.PrettyPrint.Annotated(braces, punctuate, comma, hsep) +import Text.PrettyPrint.Annotated(Doc, text, (<+>), ($+$), (<>), empty) +import Text.PrettyPrint.Annotated(braces, punctuate, comma, hsep, space) data TypeDeclaration = TypeDeclaration { _tdName :: Name @@ -45,8 +38,11 @@ class MkTypeDecl a where mkTypeDecl :: Name -> Location -> Type -> a ppTypeDeclaration :: TypeDeclaration -> Doc a -ppTypeDeclaration td = - ppName (_tdName td) <+> text "::" <+> ppType (_tdType td) +ppTypeDeclaration td = prefix <> text "type" <+> ppName (_tdName td) <+> + text "=" <+> ppType (_tdType td) + where + prefix | TypePrim _ <- _tdType td = text "primitive" <> space + | otherwise = empty instance MkTypeDecl TypeDeclaration where mkTypeDecl = TypeDeclaration @@ -67,7 +63,7 @@ data ValueDeclaration = ValueDeclaration deriving (Show) class MkValueDecl a where - mkValueDecl :: Name -> Location -> Expression -> a + mkValueDecl :: Name -> Location -> Maybe Type -> Expression -> a ppValueDeclaration :: ValueDeclaration -> Doc a ppValueDeclaration vd = frees $+$ typedecl $+$ valuedecl @@ -84,57 +80,29 @@ ppValueDeclaration vd = frees $+$ typedecl $+$ valuedecl valuedecl = ppName (_vdName vd) <+> text "=" <+> ppExpression (_vdValue vd) instance MkValueDecl ValueDeclaration where - mkValueDecl n l e = ValueDeclaration n l [] [] Nothing e + mkValueDecl n l mt e = ValueDeclaration n l [] [] mt 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) + mkValueDecl n l mt e = DeclVal (ValueDeclaration n l [] [] mt e) -- ----------------------------------------------------------------------------- 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 index 66a5665..e1f0a76 100644 --- a/src/Bang/AST/Expression.hs +++ b/src/Bang/AST/Expression.hs @@ -23,13 +23,17 @@ module Bang.AST.Expression , lambdaLocation , lambdaArgumentNames , lambdaBody + -- * Empty Expressions + , emptyExpression + , isEmptyExpression ) where -import Bang.Syntax.Location(Location) -import Bang.AST.Name(Name, ppName) +import Bang.Syntax.Location(Location, fakeLocation) +import Bang.AST.Name(Name, ppName, nothingName) import Bang.Utils.FreeVars(CanHaveFreeVars(..)) import Bang.Utils.Pretty(text') +import Control.Lens(view) import Control.Lens.TH(makeLenses) import Data.Text.Lazy(Text) import Text.PrettyPrint.Annotated(Doc, text, hsep, (<>), (<+>)) @@ -146,3 +150,13 @@ makeLenses ''ConstantExpression makeLenses ''ReferenceExpression makeLenses ''LambdaExpression +emptyExpression :: Expression +emptyExpression = mkRefExp fakeLocation nothingName + +isEmptyExpression :: Expression -> Bool +isEmptyExpression (RefExp e) = view refLocation e == fakeLocation && + view refName e == nothingName +isEmptyExpression _ = False + + + diff --git a/src/Bang/AST/Name.hs b/src/Bang/AST/Name.hs index 732a221..193035a 100644 --- a/src/Bang/AST/Name.hs +++ b/src/Bang/AST/Name.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Bang.AST.Name( NameEnvironment(..) , Name + , nothingName , mkName , ppName , nameText @@ -15,7 +17,7 @@ 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.Syntax.Location(Location, fakeLocation) import Bang.Utils.Pretty(text', word) import Text.PrettyPrint.Annotated(Doc, colon, (<>)) @@ -31,6 +33,9 @@ data Name = Name makeLenses ''Name +nothingName :: Name +nothingName = Name "::" VarEnv fakeLocation 0 + mkName :: Text -> NameEnvironment -> Location -> Word -> Name mkName = Name diff --git a/src/Bang/AST/Type.hs b/src/Bang/AST/Type.hs index de59f8c..3ec331f 100644 --- a/src/Bang/AST/Type.hs +++ b/src/Bang/AST/Type.hs @@ -34,8 +34,10 @@ module Bang.AST.Type import Bang.AST.Name(Name, ppName) import Bang.Syntax.Location(Location) import Bang.Utils.FreeVars(CanHaveFreeVars(..)) +import Bang.Utils.Pretty(text') import Control.Lens.TH(makeLenses) import Data.List(foldl', union) +import Data.Text.Lazy(Text) import Text.PrettyPrint.Annotated(Doc, (<+>), (<>), text, hsep) data Kind = Star @@ -69,12 +71,12 @@ ppUnitType _ = text "()" data PrimitiveType = PrimitiveType { _ptLocation :: Location - , _ptName :: Name + , _ptName :: Text } deriving (Show) class MkPrimType a where - mkPrimType :: Location -> Name -> a + mkPrimType :: Location -> Text -> a instance Kinded PrimitiveType where kind _ = Star @@ -83,13 +85,13 @@ instance MkPrimType PrimitiveType where mkPrimType = PrimitiveType instance MkPrimType Type where - mkPrimType l n = TypePrim (PrimitiveType l n) + mkPrimType l t = TypePrim (PrimitiveType l t) instance CanHaveFreeVars PrimitiveType where freeVariables _ = [] ppPrimitiveType :: PrimitiveType -> Doc a -ppPrimitiveType pt = text "llvm:" <> ppName (_ptName pt) +ppPrimitiveType pt = text "llvm:" <> text' (_ptName pt) -- ----------------------------------------------------------------------------- diff --git a/src/Bang/Syntax/Location.hs b/src/Bang/Syntax/Location.hs index c2ddc8f..e8a7556 100644 --- a/src/Bang/Syntax/Location.hs +++ b/src/Bang/Syntax/Location.hs @@ -12,6 +12,7 @@ module Bang.Syntax.Location( , Located(..) , locatedAt , unknownLocation + , fakeLocation ) where @@ -53,6 +54,7 @@ advanceWith' pos txt = Just (c, rest) -> advanceWith' (pos `advanceWith` c) rest data Origin = Unknown + | Generated | Interactive | File FilePath deriving (Eq, Show) @@ -61,6 +63,7 @@ ppOrigin :: Origin -> BangDoc ppOrigin x = case x of Unknown -> text "" + Generated -> text "" Interactive -> text "" File f -> text f @@ -97,3 +100,6 @@ locatedAt a p = Located p a unknownLocation :: Location unknownLocation = Location Unknown initialPosition initialPosition + +fakeLocation :: Location +fakeLocation = Location Generated initialPosition initialPosition diff --git a/src/Bang/Syntax/Parser.y b/src/Bang/Syntax/Parser.y index 803425b..ebdf6c8 100644 --- a/src/Bang/Syntax/Parser.y +++ b/src/Bang/Syntax/Parser.y @@ -11,10 +11,10 @@ module Bang.Syntax.Parser( where import Bang.Monad(err) -import Bang.AST(Name, Module, NameEnvironment(..), mkModule) -import Bang.AST.Declaration(Declaration, mkTypeDecl, mkPrimDecl, mkValueDecl) +import Bang.AST(Name, Module, NameEnvironment(..), mkModule, emptyExpression) +import Bang.AST.Declaration(Declaration, mkTypeDecl, mkValueDecl) import Bang.AST.Expression(ConstantValue(..), Expression, mkConstExp, mkRefExp, mkLambdaExp) -import Bang.AST.Type(Type, Kind(..), mkTypeRef, mkFunType, mkTypeApp) +import Bang.AST.Type(Type, Kind(..), mkTypeRef, mkFunType, mkTypeApp, mkPrimType) import Bang.Syntax.Location(Located(..), Origin, Position) import Bang.Syntax.ParserError(ParserError(..)) import Bang.Syntax.ParserMonad(Parser, addFixities, registerName, @@ -143,12 +143,12 @@ ValueDeclLHS :: { (Expression -> Declaration, [Name]) } err (InternalError $2 "ValDeclLHS") [Located src (ValIdent rawName)] -> do name <- registerName True src VarEnv rawName - return (mkValueDecl name src , [name]) + return (mkValueDecl name src Nothing, [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 = mkValueDecl name src . mkLambdaExp $2 argNames + let builder = mkValueDecl name src Nothing . mkLambdaExp $2 argNames return (builder, argNames) } @@ -165,13 +165,18 @@ TypeDeclaration :: { Declaration } {% do let Located src (ValIdent rawName) = $1 name <- registerName True src VarEnv rawName - return (mkTypeDecl name src $3) } + return (mkValueDecl name src (Just $3) emptyExpression) } + | 'type' TypeIdent '=' Type + {% + do let Located src (TypeIdent rawName) = $2 + name <- registerName True src TypeEnv rawName + return (mkTypeDecl name src $4) } | 'primitive' 'type' TypeIdent '=' String {% - do let Located src (TypeIdent rawName) = $3 - Located _ (StringTok rawText) = $5 - name <- registerName False src TypeEnv rawName - return (mkPrimDecl name src rawText) } + do let Located nsrc (TypeIdent rawName) = $3 + Located tsrc (StringTok rawText) = $5 + name <- registerName False nsrc TypeEnv rawName + return (mkTypeDecl name $2 (mkPrimType tsrc rawText)) } -- ----------------------------------------------------------------------------- diff --git a/src/Bang/Syntax/PostProcess.hs b/src/Bang/Syntax/PostProcess.hs index 85d9210..31a6200 100644 --- a/src/Bang/Syntax/PostProcess.hs +++ b/src/Bang/Syntax/PostProcess.hs @@ -5,11 +5,12 @@ module Bang.Syntax.PostProcess( import Bang.AST(Name, Module, moduleDeclarations, ppName) import Bang.AST.Declaration(Declaration(..), declName, - TypeDeclaration, ValueDeclaration, - tdName, tdLocation, tdType, + ValueDeclaration, vdName, vdLocation, vdDeclaredType, vdFreeTypeVariables, vdValue, vdFreeValueVariables) +import Bang.AST.Expression(isEmptyExpression) +import Bang.AST.Type(Type) import Bang.Monad(Compiler, BangError(..), err) import Bang.Syntax.Location(Location, ppLocation) import Bang.Utils.FreeVars(CanHaveFreeVars(..)) @@ -48,7 +49,7 @@ runPostProcessor mdl = -- ----------------------------------------------------------------------------- -type DeclarationTable = Map Name (Maybe TypeDeclaration, Maybe ValueDeclaration) +type DeclarationTable = Map Name (Maybe (Type, Location), Maybe ValueDeclaration) makeDeclarationTable :: Module -> Compiler ps DeclarationTable makeDeclarationTable m = foldM combine Map.empty (view moduleDeclarations m) @@ -56,16 +57,23 @@ makeDeclarationTable m = foldM combine Map.empty (view moduleDeclarations m) combine table d = do let name = view declName d case d of - DeclType td -> - case Map.lookup name table of - Nothing -> - return (Map.insert name (Just td, Nothing) table) - Just (Nothing, vd) -> - return (Map.insert name (Just td, vd) table) - Just (Just td', _) -> - do let newLoc = view tdLocation td - origLoc = view tdLocation td' - err (RedefinitionError name newLoc origLoc) + DeclType _ -> + return table + DeclVal vd | Just t <- view vdDeclaredType vd, + isEmptyExpression (view vdValue vd) -> + do let myLoc = view vdLocation vd + myVal = Just (t, myLoc) + case Map.lookup name table of + Nothing -> + return (Map.insert name (myVal, Nothing) table) + Just (Nothing, vd') -> + return (Map.insert name (myVal, vd') table) + Just (Just (_, theirLoc), _) -> + err (RedefinitionError name myLoc theirLoc) + DeclVal vd | Just _ <- view vdDeclaredType vd -> + err (InternalError name) + DeclVal vd | isEmptyExpression (view vdValue vd) -> + err (InternalError name) DeclVal vd -> case Map.lookup name table of Nothing -> @@ -76,8 +84,6 @@ makeDeclarationTable m = foldM combine Map.empty (view moduleDeclarations m) do let newLoc = view vdLocation vd origLoc = view vdLocation vd' err (RedefinitionError name newLoc origLoc) - DeclPrim _ -> - return table -- ----------------------------------------------------------------------------- @@ -90,21 +96,19 @@ combineTypeValueDeclarations table m = process [] = return [] process (x:rest) = case x of - DeclPrim _ -> (x:) `fmap` process rest - DeclType td -> - case Map.lookup (view tdName td) table of - Just (_, Nothing) -> - err (TypeDeclWithoutValue (view tdName td) (view tdLocation td)) - _ -> - process rest + DeclType _ -> + (x:) `fmap` process rest + DeclVal vd | Just _ <- view vdDeclaredType vd, + isEmptyExpression (view vdValue vd) -> + process rest DeclVal vd -> case Map.lookup (view vdName vd) table of Nothing -> err (InternalError (view vdName vd)) Just (Nothing, _) -> (x:) `fmap` process rest - Just (Just td, _) -> - do let vd' = set vdDeclaredType (Just (view tdType td)) vd + Just (Just (t, _), _) -> + do let vd' = set vdDeclaredType (Just t) vd (DeclVal vd' :) `fmap` process rest -- -----------------------------------------------------------------------------