acw/bang
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Switch to modules containing lists of ordered declarations, rather than just a list of declarations.

Browse Source
This commit is contained in:
Adam Wick
2016-07-19 18:20:44 -07:00
parent c542476365
commit 6649b190ac
5 changed files with 48 additions and 42 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
bang.cabal
View File

@@ -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,

11
src/Bang/AST.hs
View File

@@ -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)

32
src/Bang/AST/Declaration.hs
View File

@@ -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

2
src/Bang/Syntax/Parser.y
View File

@@ -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 }

44
src/Bang/Syntax/PostProcess.hs
View File

@@ -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)