Work so far on binding groups

paf31 · paf31 · commit 37a94cd2c051 · 2013-12-29T13:18:12.000-08:00
diff --git a/examples/passing/MutRec.purs b/examples/passing/MutRec.purs
@@ -0,0 +1,4 @@
+f 0 = 0
+f x = g x + 1
+
+g x = f (x / 2)
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
@@ -27,6 +27,7 @@ import Language.PureScript.Optimize as P
 import Language.PureScript.Operators as P
 import Language.PureScript.CaseDeclarations as P
 import Language.PureScript.TypeDeclarations as P
+import Language.PureScript.BindingGroups as P
 
 import Data.List (intercalate)
 import Data.Maybe (mapMaybe)
@@ -35,7 +36,7 @@ import Control.Monad ((>=>))
 compile :: [Declaration] -> Either String (String, String, Environment)
 compile decls = do
   bracketted <- rebracket decls
-  desugared <- desugarCases >=> desugarTypeDeclarations $ bracketted
+  desugared <- desugarCases >=> desugarTypeDeclarations >=> (return . createBindingGroups) $ bracketted
   (_, env) <- runCheck (typeCheckAll desugared)
   let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ desugared
   let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ desugared
diff --git a/src/Language/PureScript/BindingGroups.hs b/src/Language/PureScript/BindingGroups.hs
@@ -13,10 +13,37 @@
 -----------------------------------------------------------------------------
 
 module Language.PureScript.BindingGroups (
-    bindingGroups
+    createBindingGroups
 ) where
 
+import Data.Graph
+import Data.List (intersect)
+
 import Language.PureScript.Declarations
+import Language.PureScript.Names
+import Language.PureScript.Scope (usedNames)
 
-bindingGroups :: [Declaration] -> [[Declaration]]
-bindingGroups = undefined
+createBindingGroups :: [Declaration] -> [Declaration]
+createBindingGroups ds =
+  let
+    values = filter isValueDecl ds
+    nonValues = filter (not . isValueDecl) ds
+    allIdents = map getIdent values
+    verts = map (\d -> (d, getIdent d, usedNames d `intersect` allIdents)) values
+    sorted = map toBindingGroup $ stronglyConnComp verts
+  in
+    map handleModuleDeclaration nonValues ++ sorted
+  where
+  isValueDecl :: Declaration -> Bool
+  isValueDecl (ValueDeclaration _ _ _ _) = True
+  isValueDecl _ = False
+  getIdent :: Declaration -> Ident
+  getIdent (ValueDeclaration ident _ _ _) = ident
+  getIdent _ = error "undefined"
+  toBindingGroup :: SCC Declaration -> Declaration
+  toBindingGroup (AcyclicSCC d) = d
+  toBindingGroup (CyclicSCC [d]) = d
+  toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration ds'
+  handleModuleDeclaration :: Declaration -> Declaration
+  handleModuleDeclaration (ModuleDeclaration name ds') = ModuleDeclaration name $ createBindingGroups ds'
+  handleModuleDeclaration other = other
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
@@ -34,6 +34,7 @@ data Declaration
   | TypeSynonymDeclaration ProperName [String] PolyType
   | TypeDeclaration Ident PolyType
   | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
+  | BindingGroupDeclaration [Declaration]
   | ExternDeclaration Ident PolyType
   | ExternMemberDeclaration String Ident PolyType
   | ExternDataDeclaration ProperName Kind
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
@@ -74,6 +74,7 @@ typeCheckAll (ValueDeclaration name [] Nothing val : rest) = do
         putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })
   typeCheckAll rest
 typeCheckAll (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
+typeCheckAll (BindingGroupDeclaration ds : rest) = error $ show ds
 typeCheckAll (ExternDataDeclaration name kind : rest) = do
   env <- getEnv
   modulePath <- checkModulePath `fmap` get

-Original file line number
+Diff line change
@@ @@ -0,0 +1,4 @@ @@
 +f 0 = 0
 +f x = g x + 1
++
 +g x = f (x / 2)