@@ -17,13 +17,15 @@ module Language.PureScript.BindingGroups (
1717 createBindingGroupsModule
1818) where
1919
20+import Data.Data
2021import Data.Graph
21−import Data.List (intersect)
22+import Data.Generics
23+import Data.List (nub, intersect)
2224
2325import Language.PureScript.Declarations
2426import Language.PureScript.Names
2527import Language.PureScript.Values
26−import Language.PureScript.Scope (usedNames)
28+import Language.PureScript.Types
2729
2830createBindingGroupsModule :: [Module] -> [Module]
2931createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)
@@ -32,27 +34,65 @@ createBindingGroups :: [Declaration] -> [Declaration]
3234createBindingGroups ds =
3335 let
3436 values = filter isValueDecl ds
35− nonValues = filter (not . isValueDecl) ds
37+ dataDecls = filter isDataDecl ds
38+ nonValues = filter (\d -> not (isValueDecl d) && not (isDataDecl d)) ds
39+ allProperNames = map getProperName dataDecls
40+ dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls
41+ dataBindingGroupDecls = map toDataBindingGroup $ stronglyConnComp dataVerts
3642 allIdents = map getIdent values
37− verts = map (\d -> (d, getIdent d, usedNames d `intersect` allIdents)) values
38− sorted = map toBindingGroup $ stronglyConnComp verts
43+ valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values
44+ bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts
3945 in
40− nonValues ++ sorted
46+ dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls
47+
48+usedIdents :: (Data d) => d -> [Ident]
49+usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS)
50+ where
51+ namesV :: Value -> [Ident]
52+ namesV (Var (Qualified Nothing name)) = [name]
53+ namesV _ = []
54+ namesS :: Statement -> [Ident]
55+ namesS (VariableIntroduction name _) = [name]
56+ namesS _ = []
57+
58+usedProperNames :: (Data d) => d -> [ProperName]
59+usedProperNames = nub . everything (++) (mkQ [] names)
60+ where
61+ names :: Type -> [ProperName]
62+ names (TypeConstructor (Qualified Nothing name)) = [name]
63+ names _ = []
4164
4265isValueDecl :: Declaration -> Bool
4366isValueDecl (ValueDeclaration _ _ _ _) = True
4467isValueDecl _ = False
4568
69+isDataDecl :: Declaration -> Bool
70+isDataDecl (DataDeclaration _ _ _) = True
71+isDataDecl _ = False
72+
4673getIdent :: Declaration -> Ident
4774getIdent (ValueDeclaration ident _ _ _) = ident
4875getIdent _ = error "Expected ValueDeclaration"
4976
77+getProperName :: Declaration -> ProperName
78+getProperName (DataDeclaration pn _ _) = pn
79+getProperName _ = error "Expected DataDeclaration"
80+
5081toBindingGroup :: SCC Declaration -> Declaration
5182toBindingGroup (AcyclicSCC d) = d
5283toBindingGroup (CyclicSCC [d]) = d
53−toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration (map fromValueDecl ds')
84+toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'
85+
86+toDataBindingGroup :: SCC Declaration -> Declaration
87+toDataBindingGroup (AcyclicSCC d) = d
88+toDataBindingGroup (CyclicSCC [d]) = d
89+toDataBindingGroup (CyclicSCC ds') = DataBindingGroupDeclaration $ map fromDataDecl ds'
5490
5591fromValueDecl :: Declaration -> (Ident, Value)
5692fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
5793fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
5894fromValueDecl _ = error "Expected ValueDeclaration"
95+
96+fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe PolyType)])
97+fromDataDecl (DataDeclaration pn args ctors) = (pn, args, ctors)
98+fromDataDecl _ = error "Expected DataDeclaration"