git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Mutually recursive data types, part 1
9994812Phil Freeman
examples/passing/MutRec.purs+11
compare with golang
unifiedsplit
@@ -4,3 +4,14 @@ module MutRec where
4 f x = g x + 1
4 f x = g x + 1
5
5
6 g x = f (x / 2)
6 g x = f (x / 2)
7+
8+ data Even = Zero | Even Odd
9+
10+ data Odd = Odd Even
11+
12+ evenToNumber :: Even -> Number
13+ evenToNumber Zero = 0
14+ evenToNumber (Even n) = oddToNumber n + 1
15+
16+ oddToNumber :: Odd -> Number
17+ oddToNumber (Odd n) = evenToNumber n + 1
src/Language/PureScript/BindingGroups.hs+47−7
@@ -17,13 +17,15 @@ module Language.PureScript.BindingGroups (
17 createBindingGroupsModule
17 createBindingGroupsModule
18) where
18) where
19
19
20+import Data.Data
20import Data.Graph
21import Data.Graph
22+import Data.Generics
21−import Data.List (intersect)
23+import Data.List (nub, intersect)
22
24
23import Language.PureScript.Declarations
25import Language.PureScript.Declarations
24import Language.PureScript.Names
26import Language.PureScript.Names
25import Language.PureScript.Values
27import Language.PureScript.Values
26−import Language.PureScript.Scope (usedNames)
28+import Language.PureScript.Types
27
29
28createBindingGroupsModule :: [Module] -> [Module]
30createBindingGroupsModule :: [Module] -> [Module]
29createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)
31createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)
@@ -32,27 +34,65 @@ createBindingGroups :: [Declaration] -> [Declaration]
32createBindingGroups ds =
34createBindingGroups ds =
33 let
35 let
34 values = filter isValueDecl ds
36 values = filter isValueDecl ds
37+ dataDecls = filter isDataDecl ds
35− nonValues = filter (not . isValueDecl) 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
36 allIdents = map getIdent values
42 allIdents = map getIdent values
37− verts = map (\d -> (d, getIdent d, usedNames d `intersect` allIdents)) values
43+ valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values
38− sorted = map toBindingGroup $ stronglyConnComp verts
44+ bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts
39 in
45 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 _ = []
41
64
42isValueDecl :: Declaration -> Bool
65isValueDecl :: Declaration -> Bool
43isValueDecl (ValueDeclaration _ _ _ _) = True
66isValueDecl (ValueDeclaration _ _ _ _) = True
44isValueDecl _ = False
67isValueDecl _ = False
45
68
69+isDataDecl :: Declaration -> Bool
70+isDataDecl (DataDeclaration _ _ _) = True
71+isDataDecl _ = False
72+
46getIdent :: Declaration -> Ident
73getIdent :: Declaration -> Ident
47getIdent (ValueDeclaration ident _ _ _) = ident
74getIdent (ValueDeclaration ident _ _ _) = ident
48getIdent _ = error "Expected ValueDeclaration"
75getIdent _ = error "Expected ValueDeclaration"
49
76
77+getProperName :: Declaration -> ProperName
78+getProperName (DataDeclaration pn _ _) = pn
79+getProperName _ = error "Expected DataDeclaration"
80+
50toBindingGroup :: SCC Declaration -> Declaration
81toBindingGroup :: SCC Declaration -> Declaration
51toBindingGroup (AcyclicSCC d) = d
82toBindingGroup (AcyclicSCC d) = d
52toBindingGroup (CyclicSCC [d]) = d
83toBindingGroup (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'
54
90
55fromValueDecl :: Declaration -> (Ident, Value)
91fromValueDecl :: Declaration -> (Ident, Value)
56fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
92fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
57fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
93fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
58fromValueDecl _ = error "Expected ValueDeclaration"
94fromValueDecl _ = 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"
src/Language/PureScript/Declarations.hs+1
@@ -33,6 +33,7 @@ data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable
33
33
34data Declaration
34data Declaration
35 = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]
35 = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]
36+ | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe PolyType)])]
36 | TypeSynonymDeclaration ProperName [String] PolyType
37 | TypeSynonymDeclaration ProperName [String] PolyType
37 | TypeDeclaration Ident PolyType
38 | TypeDeclaration Ident PolyType
38 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
39 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
src/Language/PureScript/TypeChecker.hs+1
@@ -52,6 +52,7 @@ typeCheckAll moduleName (DataDeclaration name args dctors : rest) = do
52 let polyType = mkForAll args dctorTy
52 let polyType = mkForAll args dctorTy
53 putEnv $ env' { dataConstructors = M.insert (moduleName, dctor) polyType (dataConstructors env') }
53 putEnv $ env' { dataConstructors = M.insert (moduleName, dctor) polyType (dataConstructors env') }
54 typeCheckAll moduleName rest
54 typeCheckAll moduleName rest
55+typeCheckAll moduleName (DataBindingGroupDeclaration tys : rest) = error (show tys)
55typeCheckAll moduleName (TypeSynonymDeclaration name args ty : rest) = do
56typeCheckAll moduleName (TypeSynonymDeclaration name args ty : rest) = do
56 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
57 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
57 env <- getEnv
58 env <- getEnv