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

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,

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)
 

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 Data.List(delete, union)
-import Text.PrettyPrint.Annotated(braces, punctuate, comma, hsep, space)
+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
 

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 }

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)
-                                      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(..))
 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
+  do let decls = concat (view moduleDeclarations mdl)
-     mdl' <- combineTypeValueDeclarations declTable mdl
+     declTable <- makeDeclarationTable decls
-     return (addFreeVarsToDecls mdl')
+     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 :: [Declaration] -> Compiler ps DeclarationTable
-makeDeclarationTable m = foldM combine Map.empty (view moduleDeclarations m)
+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 :: DeclarationTable ->
-combineTypeValueDeclarations table m =
+                                [Declaration] ->
-  do let decls = view moduleDeclarations m
+                                Compiler ps [Declaration]
-     decls' <- process decls
+combineTypeValueDeclarations table decls = process decls
-     return (set moduleDeclarations decls' m)
  where
   process [] = return []
   process (x:rest) =
@@ -113,14 +114,11 @@ combineTypeValueDeclarations table m =
 
 -- -----------------------------------------------------------------------------
 
-addFreeVarsToDecls :: Module -> Module
+orderDecls :: [Declaration] -> [[Declaration]]
-addFreeVarsToDecls = over moduleDeclarations (map process)
+orderDecls decls = map unSCC (stronglyConnComp nodes)
  where
-  process (DeclVal vd) =
+  unSCC (AcyclicSCC x) = [x]
-    let dtype = view vdDeclaredType vd
+  unSCC (CyclicSCC xs) = xs
-        dval  = view vdValue        vd
+  --
-    in DeclVal (set vdFreeTypeVariables  (freeVariables dtype) $
+  nodes = map tuplify decls
-                set vdFreeValueVariables (freeVariables dval)  vd)
+  tuplify d = (d, view declName d, freeVariables d)
-  process x = x
-
-