From 6649b190ac1d804daa926e924e639b4a410cbf4e Mon Sep 17 00:00:00 2001 From: Adam Wick Date: Tue, 19 Jul 2016 18:20:44 -0700 Subject: [PATCH] Switch to modules containing lists of ordered declarations, rather than just a list of declarations. --- bang.cabal | 1 + src/Bang/AST.hs | 11 +++++---- src/Bang/AST/Declaration.hs | 32 +++++++++++++++---------- src/Bang/Syntax/Parser.y | 2 +- src/Bang/Syntax/PostProcess.hs | 44 ++++++++++++++++------------------ 5 files changed, 48 insertions(+), 42 deletions(-) diff --git a/bang.cabal b/bang.cabal index e73307c..9ddb01d 100644 --- a/bang.cabal +++ b/bang.cabal @@ -19,6 +19,7 @@ executable bang base >= 4.7 && < 5.0, bytestring >= 0.10.6 && < 0.13, containers >= 0.5.4 && < 0.8, + GraphSCC >= 1.0.4 && < 1.4, lens >= 4.14 && < 4.16, llvm-pretty >= 0.4.0.1 && < 0.8, optparse-applicative >= 0.12.1.0 && < 0.15, diff --git a/src/Bang/AST.hs b/src/Bang/AST.hs index 29d6de5..9706456 100644 --- a/src/Bang/AST.hs +++ b/src/Bang/AST.hs @@ -21,10 +21,10 @@ import Text.PrettyPrint.Annotated(Doc, empty, text, (<+>), ($+$)) data Module = Module { _moduleName :: Name - , _moduleDeclarations :: [Declaration] + , _moduleDeclarations :: [[Declaration]] } -mkModule :: Name -> [Declaration] -> Module +mkModule :: Name -> [[Declaration]] -> Module mkModule = Module makeLenses ''Module @@ -34,9 +34,10 @@ ppModule m = text "module" <+> ppName (view moduleName m) $+$ dump (view moduleName m) (view moduleDeclarations m) where dump _ [] = empty - dump prev (x:rest) + dump prev ([]:rest) = dump prev rest + dump prev ((x:rest):lr) | prev == view declName x = - ppDeclaration x $+$ dump prev rest + ppDeclaration x $+$ dump prev (rest:lr) | otherwise = - text "" $+$ dump (view declName x) (x:rest) + text "" $+$ dump (view declName x) ((x:rest):lr) diff --git a/src/Bang/AST/Declaration.hs b/src/Bang/AST/Declaration.hs index 02d8c7a..3a750e9 100644 --- a/src/Bang/AST/Declaration.hs +++ b/src/Bang/AST/Declaration.hs @@ -13,7 +13,6 @@ module Bang.AST.Declaration , ppValueDeclaration , mkValueDecl , vdName, vdLocation - , vdFreeTypeVariables, vdFreeValueVariables , vdDeclaredType, vdValue ) where @@ -22,10 +21,11 @@ import Bang.AST.Expression(Expression, ppExpression) import Bang.AST.Name(Name, ppName) import Bang.AST.Type(Type(TypePrim), ppType) import Bang.Syntax.Location(Location) +import Bang.Utils.FreeVars(CanHaveFreeVars(..)) 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, space) +import Data.List(delete, union) +import Text.PrettyPrint.Annotated(Doc, text, (<+>), ($+$), (<>), empty, space) data TypeDeclaration = TypeDeclaration { _tdName :: Name @@ -50,13 +50,14 @@ instance MkTypeDecl TypeDeclaration where instance MkTypeDecl Declaration where mkTypeDecl n l t = DeclType (TypeDeclaration n l t) +instance CanHaveFreeVars TypeDeclaration where + freeVariables td = delete (_tdName td) (freeVariables (_tdType td)) + -- ----------------------------------------------------------------------------- data ValueDeclaration = ValueDeclaration { _vdName :: Name , _vdLocation :: Location - , _vdFreeTypeVariables :: [Name] - , _vdFreeValueVariables :: [Name] , _vdDeclaredType :: Maybe Type , _vdValue :: Expression } @@ -66,13 +67,8 @@ class MkValueDecl a where mkValueDecl :: Name -> Location -> Maybe Type -> Expression -> a ppValueDeclaration :: ValueDeclaration -> Doc a -ppValueDeclaration vd = frees $+$ typedecl $+$ valuedecl +ppValueDeclaration vd = typedecl $+$ valuedecl where - frees = - text "free type variables: " <+> - braces (hsep (punctuate comma (map ppName (_vdFreeTypeVariables vd)))) $+$ - text "free value variables: " <+> - braces (hsep (punctuate comma (map ppName (_vdFreeValueVariables vd)))) typedecl | Just t <- _vdDeclaredType vd = ppName (_vdName vd) <+> text "::" <+> ppType t @@ -80,10 +76,16 @@ ppValueDeclaration vd = frees $+$ typedecl $+$ valuedecl valuedecl = ppName (_vdName vd) <+> text "=" <+> ppExpression (_vdValue vd) instance MkValueDecl ValueDeclaration where - mkValueDecl n l mt e = ValueDeclaration n l [] [] mt e + mkValueDecl n l mt e = ValueDeclaration n l mt e instance MkValueDecl Declaration where - mkValueDecl n l mt e = DeclVal (ValueDeclaration n l [] [] mt e) + mkValueDecl n l mt e = DeclVal (ValueDeclaration n l mt e) + +instance CanHaveFreeVars ValueDeclaration where + freeVariables vd = delete (_vdName vd) (union valTypes typeTypes) + where + valTypes = freeVariables (_vdValue vd) + typeTypes = freeVariables (_vdDeclaredType vd) -- ----------------------------------------------------------------------------- @@ -95,6 +97,10 @@ ppDeclaration :: Declaration -> Doc a ppDeclaration (DeclType d) = ppTypeDeclaration d ppDeclaration (DeclVal d) = ppValueDeclaration d +instance CanHaveFreeVars Declaration where + freeVariables (DeclType td) = freeVariables td + freeVariables (DeclVal vd) = freeVariables vd + makeLenses ''TypeDeclaration makeLenses ''ValueDeclaration diff --git a/src/Bang/Syntax/Parser.y b/src/Bang/Syntax/Parser.y index ebdf6c8..0798e77 100644 --- a/src/Bang/Syntax/Parser.y +++ b/src/Bang/Syntax/Parser.y @@ -120,7 +120,7 @@ top_module :: { Module } {% do let Located src (TypeIdent rawName) = $2 name <- registerName False src ModuleEnv rawName - return (mkModule name $3) } + return (mkModule name [$3]) } Declaration :: { Maybe Declaration } : ValueDeclaration { Just $1 } diff --git a/src/Bang/Syntax/PostProcess.hs b/src/Bang/Syntax/PostProcess.hs index 31a6200..8a4683d 100644 --- a/src/Bang/Syntax/PostProcess.hs +++ b/src/Bang/Syntax/PostProcess.hs @@ -7,16 +7,17 @@ import Bang.AST(Name, Module, moduleDeclarations, ppName) import Bang.AST.Declaration(Declaration(..), declName, ValueDeclaration, vdName, vdLocation, vdDeclaredType, - vdFreeTypeVariables, - vdValue, vdFreeValueVariables) + vdValue) 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(..)) import Bang.Utils.Pretty(BangDoc) -import Control.Lens(view, set, over) +import Control.Lens(view, set) import Control.Monad(foldM) +import Data.Graph(SCC(..)) +import Data.Graph.SCC(stronglyConnComp) import Data.Map.Strict(Map) import qualified Data.Map.Strict as Map import Text.PrettyPrint.Annotated(text, ($+$), (<+>), nest) @@ -43,16 +44,17 @@ prettyError e = runPostProcessor :: Module -> Compiler ps Module runPostProcessor mdl = - do declTable <- makeDeclarationTable mdl - mdl' <- combineTypeValueDeclarations declTable mdl - return (addFreeVarsToDecls mdl') + do let decls = concat (view moduleDeclarations mdl) + declTable <- makeDeclarationTable decls + decls' <- combineTypeValueDeclarations declTable decls + return (set moduleDeclarations (orderDecls decls') mdl) -- ----------------------------------------------------------------------------- type DeclarationTable = Map Name (Maybe (Type, Location), Maybe ValueDeclaration) -makeDeclarationTable :: Module -> Compiler ps DeclarationTable -makeDeclarationTable m = foldM combine Map.empty (view moduleDeclarations m) +makeDeclarationTable :: [Declaration] -> Compiler ps DeclarationTable +makeDeclarationTable decls = foldM combine Map.empty decls where combine table d = do let name = view declName d @@ -87,11 +89,10 @@ makeDeclarationTable m = foldM combine Map.empty (view moduleDeclarations m) -- ----------------------------------------------------------------------------- -combineTypeValueDeclarations :: DeclarationTable -> Module -> Compiler ps Module -combineTypeValueDeclarations table m = - do let decls = view moduleDeclarations m - decls' <- process decls - return (set moduleDeclarations decls' m) +combineTypeValueDeclarations :: DeclarationTable -> + [Declaration] -> + Compiler ps [Declaration] +combineTypeValueDeclarations table decls = process decls where process [] = return [] process (x:rest) = @@ -113,14 +114,11 @@ combineTypeValueDeclarations table m = -- ----------------------------------------------------------------------------- -addFreeVarsToDecls :: Module -> Module -addFreeVarsToDecls = over moduleDeclarations (map process) +orderDecls :: [Declaration] -> [[Declaration]] +orderDecls decls = map unSCC (stronglyConnComp nodes) where - process (DeclVal vd) = - let dtype = view vdDeclaredType vd - dval = view vdValue vd - in DeclVal (set vdFreeTypeVariables (freeVariables dtype) $ - set vdFreeValueVariables (freeVariables dval) vd) - process x = x - - + unSCC (AcyclicSCC x) = [x] + unSCC (CyclicSCC xs) = xs + -- + nodes = map tuplify decls + tuplify d = (d, view declName d, freeVariables d)