From 2d11a0ff9302523f13b1cc252e9e75df65bedc24 Mon Sep 17 00:00:00 2001 From: Adam Wick Date: Tue, 12 Jul 2016 18:11:00 -0700 Subject: [PATCH] Auto-attach type declarations to their values. --- src/Bang/AST/Declaration.hs | 11 ++-- src/Bang/Syntax/PostProcess.hs | 96 ++++++++++++++++++++++++++++++++-- src/Bang/TypeInfer.hs | 8 ++- src/Main.hs | 4 +- 4 files changed, 110 insertions(+), 9 deletions(-) diff --git a/src/Bang/AST/Declaration.hs b/src/Bang/AST/Declaration.hs index 44356f8..4384670 100644 --- a/src/Bang/AST/Declaration.hs +++ b/src/Bang/AST/Declaration.hs @@ -31,7 +31,7 @@ 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, (<+>)) +import Text.PrettyPrint.Annotated(Doc, text, (<+>), ($+$), empty) data TypeDeclaration = TypeDeclaration { _tdName :: Name @@ -69,8 +69,13 @@ class MkValueDecl a where mkValueDecl :: Name -> Location -> Expression -> a ppValueDeclaration :: ValueDeclaration -> Doc a -ppValueDeclaration vd = - ppName (_vdName vd) <+> text "=" <+> ppExpression (_vdValue vd) +ppValueDeclaration vd = typedecl $+$ valuedecl + where + typedecl + | Just dt <- _vdDeclaredType vd = + ppTypeDeclaration (TypeDeclaration (_vdName vd) (_vdLocation vd) dt) + | otherwise = empty + valuedecl = ppName (_vdName vd) <+> text "=" <+> ppExpression (_vdValue vd) instance MkValueDecl ValueDeclaration where mkValueDecl n l e = ValueDeclaration n l [] [] Nothing e diff --git a/src/Bang/Syntax/PostProcess.hs b/src/Bang/Syntax/PostProcess.hs index 76ee9e7..4511a0b 100644 --- a/src/Bang/Syntax/PostProcess.hs +++ b/src/Bang/Syntax/PostProcess.hs @@ -1,15 +1,105 @@ module Bang.Syntax.PostProcess( runPostProcessor ) + where -import Bang.Syntax.AST +import Bang.AST(Name, Module, moduleDeclarations, ppName) +import Bang.AST.Declaration(Declaration(..), declName, + TypeDeclaration, ValueDeclaration, + tdName, tdLocation, tdType, + vdName, vdLocation, vdDeclaredType) +import Bang.Monad(Compiler, BangError(..), err) +import Bang.Syntax.Location(Location, ppLocation) +import Bang.Utils.Pretty(BangDoc) +import Control.Lens(view, set) +import Control.Monad(foldM) +import Data.Map.Strict(Map) +import qualified Data.Map.Strict as Map +import Text.PrettyPrint.Annotated(text, ($+$), (<+>), nest) + +data PostProcessError = InternalError Name + | RedefinitionError Name Location Location + | TypeDeclWithoutValue Name Location + deriving (Show) + +instance BangError PostProcessError where + ppError = prettyError + +prettyError :: PostProcessError -> (Maybe Location, BangDoc) +prettyError e = + case e of + InternalError n -> + (Nothing, text "Serious post-processing error w.r.t. " <+> ppName n) + RedefinitionError n l1 l2 -> + (Just l1, text "Name" <+> ppName n <+> text "redefined." $+$ + nest 2 (text "original definiton at " <+> ppLocation l2)) + TypeDeclWithoutValue n l -> + (Just l, text "Type declaration provided, but no value provided." $+$ + nest 2 (text "variable name: " <+> ppName n)) runPostProcessor :: Module -> Compiler ps Module -runPostProcessor mod = undefined +runPostProcessor mdl = + do declTable <- makeDeclarationTable mdl + mdl' <- combineTypeValueDeclarations declTable mdl + return mdl' -- ----------------------------------------------------------------------------- type DeclarationTable = Map Name (Maybe TypeDeclaration, Maybe ValueDeclaration) -makeDeclarationTable :: Module -> DeclarationTable +makeDeclarationTable :: Module -> Compiler ps DeclarationTable +makeDeclarationTable m = foldM combine Map.empty (view moduleDeclarations m) + where + 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) + DeclVal vd -> + case Map.lookup name table of + Nothing -> + return (Map.insert name (Nothing, Just vd) table) + Just (td, Nothing) -> + return (Map.insert name (td, Just vd) table) + Just (_, Just vd') -> + do let newLoc = view vdLocation vd + origLoc = view vdLocation vd' + err (RedefinitionError name newLoc origLoc) + DeclPrim _ -> + return table +-- ----------------------------------------------------------------------------- + +combineTypeValueDeclarations :: DeclarationTable -> Module -> Compiler ps Module +combineTypeValueDeclarations table m = + do let decls = view moduleDeclarations m + decls' <- process decls + return (set moduleDeclarations decls' m) + where + 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 + 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 + (DeclVal vd' :) `fmap` process rest diff --git a/src/Bang/TypeInfer.hs b/src/Bang/TypeInfer.hs index 470a488..fa433c6 100644 --- a/src/Bang/TypeInfer.hs +++ b/src/Bang/TypeInfer.hs @@ -3,8 +3,12 @@ module Bang.TypeInfer(runTypeInference) where -runTypeInference :: a -runTypeInference = undefined +import Bang.AST(Module) +import Bang.Monad(Compiler) +import Bang.Syntax.ParserMonad(NameDatabase) + +runTypeInference :: NameDatabase -> Module -> Compiler ps Module +runTypeInference _ x = return x {- Better version import Bang.Monad(Compiler, BangError(..), err, diff --git a/src/Main.hs b/src/Main.hs index d27ef74..f5b67bc 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,6 +2,7 @@ import Bang.CommandLine(getCommand, BangCommand(..), helpString) import Bang.AST(ppModule) import Bang.Monad(runCompiler) import Bang.Syntax.Parser(runParser, parseModule) +import Bang.Syntax.PostProcess(runPostProcessor) import Bang.TypeInfer(runTypeInference) import Data.Version(showVersion) import Paths_bang(version) @@ -14,7 +15,8 @@ main = getCommand >>= \ cmd -> putStrLn (render (ppModule mdl)) TypeCheck o -> do mdl <- runCompiler cmd o (\ r t -> do (ndb, mdl) <- runParser r t parseModule - runTypeInference ndb mdl) + mdl' <- runPostProcessor mdl + runTypeInference ndb mdl') putStrLn (render (ppModule mdl)) Help -> putStrLn helpString Version -> putStrLn ("Bang tool, version " ++ showVersion version)