git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Type synonyms and data type declarations can now depend on each other.
4aca4c1Phil Freeman
examples/failing/TypeSynonyms.pursnew file+5
compare with golang
unifiedsplit
@@ -0,0 +1,5 @@
1+module TypeSynonyms where
2+
3+type T1 = [T2]
4+
5+type T2 = T1
examples/passing/DataAndType.pursnew file+5
@@ -0,0 +1,5 @@
1+module DataAndType where
2+
3+data A = A B
4+
5+type B = A
src/Language/PureScript.hs+1−1
@@ -35,7 +35,7 @@ compile :: Options -> [Module] -> Either String (String, String, Environment)
35compile opts ms = do
35compile opts ms = do
36 desugared <- desugar ms
36 desugared <- desugar ms
37 (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> Module moduleName <$> typeCheckAll (ModuleName moduleName) decls
37 (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> Module moduleName <$> typeCheckAll (ModuleName moduleName) decls
38− let regrouped = createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
38+ regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
39 let js = concatMap (flip (moduleToJs opts) env) $ regrouped
39 let js = concatMap (flip (moduleToJs opts) env) $ regrouped
40 let exts = intercalate "\n" . map (flip moduleToPs env) $ regrouped
40 let exts = intercalate "\n" . map (flip moduleToPs env) $ regrouped
41 js' <- case () of
41 js' <- case () of
src/Language/PureScript/Declarations.hs+31−1
@@ -39,7 +39,7 @@ data ForeignImportType
39
39
40data Declaration
40data Declaration
41 = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
41 = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
42− | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe Type)])]
42+ | DataBindingGroupDeclaration [Declaration]
43 | TypeSynonymDeclaration ProperName [String] Type
43 | TypeSynonymDeclaration ProperName [String] Type
44 | TypeDeclaration Ident Type
44 | TypeDeclaration Ident Type
45 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
45 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
@@ -51,3 +51,33 @@ data Declaration
51 | TypeClassDeclaration ProperName String [Declaration]
51 | TypeClassDeclaration ProperName String [Declaration]
52 | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]
52 | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]
53 deriving (Show, D.Data, D.Typeable)
53 deriving (Show, D.Data, D.Typeable)
54+
55+isValueDecl :: Declaration -> Bool
56+isValueDecl (ValueDeclaration _ _ _ _) = True
57+isValueDecl _ = False
58+
59+isDataDecl :: Declaration -> Bool
60+isDataDecl (DataDeclaration _ _ _) = True
61+isDataDecl (TypeSynonymDeclaration _ _ _) = True
62+isDataDecl _ = False
63+
64+isImportDecl :: Declaration -> Bool
65+isImportDecl (ImportDeclaration _ _) = True
66+isImportDecl _ = False
67+
68+isExternDataDecl :: Declaration -> Bool
69+isExternDataDecl (ExternDataDeclaration _ _) = True
70+isExternDataDecl _ = False
71+
72+isFixityDecl :: Declaration -> Bool
73+isFixityDecl (FixityDeclaration _ _) = True
74+isFixityDecl _ = False
75+
76+isExternDecl :: Declaration -> Bool
77+isExternDecl (ExternDeclaration _ _ _ _) = True
78+isExternDecl _ = False
79+
80+isTypeClassDeclaration :: Declaration -> Bool
81+isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True
82+isTypeClassDeclaration (TypeInstanceDeclaration _ _ _ _) = True
83+isTypeClassDeclaration _ = False
src/Language/PureScript/Sugar.hs+1−1
@@ -31,4 +31,4 @@ desugar = desugarTypeClasses
31 >=> desugarDo
31 >=> desugarDo
32 >=> desugarCasesModule
32 >=> desugarCasesModule
33 >=> desugarTypeDeclarationsModule
33 >=> desugarTypeDeclarationsModule
34− >=> return . createBindingGroupsModule
34+ >=> createBindingGroupsModule
src/Language/PureScript/Sugar/BindingGroups.hs+37−40
@@ -23,49 +23,51 @@ import Data.Data
23import Data.Graph
23import Data.Graph
24import Data.Generics
24import Data.Generics
25import Data.List (nub, intersect)
25import Data.List (nub, intersect)
26+import Control.Applicative ((<$>))
26
27
27import Language.PureScript.Declarations
28import Language.PureScript.Declarations
28import Language.PureScript.Names
29import Language.PureScript.Names
29import Language.PureScript.Values
30import Language.PureScript.Values
30import Language.PureScript.Types
31import Language.PureScript.Types
32+import Debug.Trace (trace)
31
33
32−createBindingGroupsModule :: [Module] -> [Module]
34+createBindingGroupsModule :: [Module] -> Either String [Module]
33−createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)
35+createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups ds
34
36
35collapseBindingGroupsModule :: [Module] -> [Module]
37collapseBindingGroupsModule :: [Module] -> [Module]
36collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBindingGroups ds)
38collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBindingGroups ds)
37
39
38−createBindingGroups :: [Declaration] -> [Declaration]
40+createBindingGroups :: [Declaration] -> Either String [Declaration]
39−createBindingGroups ds =
41+createBindingGroups ds = do
40− let
41− values = filter isValueDecl ds
42+ let values = filter isValueDecl ds
42− dataDecls = filter isDataDecl ds
43+ dataDecls = filter isDataDecl ds
43− nonValues = filter (\d -> not (isValueDecl d) && not (isDataDecl d)) ds
44− allProperNames = map getProperName dataDecls
44+ allProperNames = map getProperName dataDecls
45− dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls
45+ dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls
46− dataBindingGroupDecls = map toDataBindingGroup $ stronglyConnComp dataVerts
46+ dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts
47− allIdents = map getIdent values
47+ let allIdents = map getIdent values
48− valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values
48+ valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values
49− bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts
49+ bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts
50− in
50+ return $ filter isImportDecl ds ++
51+ filter isExternDataDecl ds ++
51− dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls
52+ dataBindingGroupDecls ++
53+ filter isTypeClassDeclaration ds ++
54+ filter isFixityDecl ds ++
55+ filter isExternDecl ds ++
56+ bindingGroupDecls
52
57
53collapseBindingGroups :: [Declaration] -> [Declaration]
58collapseBindingGroups :: [Declaration] -> [Declaration]
54collapseBindingGroups ds = concatMap go ds
59collapseBindingGroups ds = concatMap go ds
55 where
60 where
56− go (DataBindingGroupDeclaration ds) = map (\(name, args, dctors) -> DataDeclaration name args dctors) ds
61+ go (DataBindingGroupDeclaration ds) = ds
57 go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds
62 go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds
58 go other = [other]
63 go other = [other]
59
64
60usedIdents :: (Data d) => d -> [Ident]
65usedIdents :: (Data d) => d -> [Ident]
61−usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS)
66+usedIdents = nub . everything (++) (mkQ [] names)
62 where
67 where
63− namesV :: Value -> [Ident]
68+ names :: Value -> [Ident]
64− namesV (Var (Qualified Nothing name)) = [name]
69+ names (Var (Qualified Nothing name)) = [name]
65− namesV _ = []
70+ names _ = []
66− namesS :: Statement -> [Ident]
67− namesS (VariableIntroduction name _) = [name]
68− namesS _ = []
69
71
70usedProperNames :: (Data d) => d -> [ProperName]
72usedProperNames :: (Data d) => d -> [ProperName]
71usedProperNames = nub . everything (++) (mkQ [] names)
73usedProperNames = nub . everything (++) (mkQ [] names)
@@ -74,20 +76,13 @@ usedProperNames = nub . everything (++) (mkQ [] names)
74 names (TypeConstructor (Qualified Nothing name)) = [name]
76 names (TypeConstructor (Qualified Nothing name)) = [name]
75 names _ = []
77 names _ = []
76
78
77−isValueDecl :: Declaration -> Bool
78−isValueDecl (ValueDeclaration _ _ _ _) = True
79−isValueDecl _ = False
80−
81−isDataDecl :: Declaration -> Bool
82−isDataDecl (DataDeclaration _ _ _) = True
83−isDataDecl _ = False
84−
85getIdent :: Declaration -> Ident
79getIdent :: Declaration -> Ident
86getIdent (ValueDeclaration ident _ _ _) = ident
80getIdent (ValueDeclaration ident _ _ _) = ident
87getIdent _ = error "Expected ValueDeclaration"
81getIdent _ = error "Expected ValueDeclaration"
88
82
89getProperName :: Declaration -> ProperName
83getProperName :: Declaration -> ProperName
90getProperName (DataDeclaration pn _ _) = pn
84getProperName (DataDeclaration pn _ _) = pn
85+getProperName (TypeSynonymDeclaration pn _ _) = pn
91getProperName _ = error "Expected DataDeclaration"
86getProperName _ = error "Expected DataDeclaration"
92
87
93toBindingGroup :: SCC Declaration -> Declaration
88toBindingGroup :: SCC Declaration -> Declaration
@@ -95,16 +90,18 @@ toBindingGroup (AcyclicSCC d) = d
95toBindingGroup (CyclicSCC [d]) = d
90toBindingGroup (CyclicSCC [d]) = d
96toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'
91toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'
97
92
98−toDataBindingGroup :: SCC Declaration -> Declaration
93+toDataBindingGroup :: SCC Declaration -> Either String Declaration
99−toDataBindingGroup (AcyclicSCC d) = d
94+toDataBindingGroup (AcyclicSCC d) = return d
100−toDataBindingGroup (CyclicSCC [d]) = d
95+toDataBindingGroup (CyclicSCC [TypeSynonymDeclaration pn _ _]) = Left $ "Cycle in type synonym " ++ show pn
96+toDataBindingGroup (CyclicSCC [d]) = return d
101−toDataBindingGroup (CyclicSCC ds') = DataBindingGroupDeclaration $ map fromDataDecl ds'
97+toDataBindingGroup (CyclicSCC ds')
98+ | all isTypeSynonym ds' = Left "Cycle in type synonyms"
99+ | otherwise = return $ DataBindingGroupDeclaration ds'
100+ where
101+ isTypeSynonym (TypeSynonymDeclaration _ _ _) = True
102+ isTypeSynonym _ = False
102
103
103fromValueDecl :: Declaration -> (Ident, Value)
104fromValueDecl :: Declaration -> (Ident, Value)
104fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
105fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
105fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
106fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
106fromValueDecl _ = error "Expected ValueDeclaration"
107fromValueDecl _ = error "Expected ValueDeclaration"
107−
108−fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe Type)])
109−fromDataDecl (DataDeclaration pn args ctors) = (pn, args, ctors)
110−fromDataDecl _ = error "Expected DataDeclaration"
src/Language/PureScript/TypeChecker.hs+13−4
@@ -98,14 +98,23 @@ typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do
98 ds <- typeCheckAll moduleName rest
98 ds <- typeCheckAll moduleName rest
99 return $ d : ds
99 return $ d : ds
100typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
100typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
101− rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do
101+ rethrow ("Error in data binding group:\n" ++) $ do
102− forM_ tys $ \(name, _, _) ->
102+ let syns = mapMaybe toTypeSynonym tys
103+ let dataDecls = mapMaybe toDataDecl tys
104+ (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) dataDecls)
105+ forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) -> do
103 typeIsNotDefined moduleName name
106 typeIsNotDefined moduleName name
104− ks <- kindsOfAll moduleName (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) tys)
105− forM_ (zip tys ks) $ \((name, args, dctors), ctorKind) ->
106 addDataType moduleName name args dctors ctorKind
107 addDataType moduleName name args dctors ctorKind
108+ forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
109+ typeIsNotDefined moduleName name
110+ addTypeSynonym moduleName name args ty kind
107 ds <- typeCheckAll moduleName rest
111 ds <- typeCheckAll moduleName rest
108 return $ d : ds
112 return $ d : ds
113+ where
114+ toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
115+ toTypeSynonym _ = Nothing
116+ toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)
117+ toDataDecl _ = Nothing
109typeCheckAll moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
118typeCheckAll moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
110 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
119 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
111 typeIsNotDefined moduleName name
120 typeIsNotDefined moduleName name
src/Language/PureScript/TypeChecker/Kinds.hs+21−10
@@ -68,16 +68,27 @@ kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k))
68 bindLocalTypeVariables moduleName dict $
68 bindLocalTypeVariables moduleName dict $
69 solveTypes ts kargs tyCon
69 solveTypes ts kargs tyCon
70
70
71−kindsOfAll :: ModuleName -> [(ProperName, [String], [Type])] -> Check [Kind]
71+kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind])
72−kindsOfAll moduleName tys = fmap (map starIfUnknown . (\(ks, s) -> apply s ks)) . runSubst (SubstContext moduleName) $ do
72+kindsOfAll moduleName syns tys = fmap tidyUp . runSubst (SubstContext moduleName) $ do
73+ synVars <- replicateM (length syns) fresh
74+ let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
75+ bindLocalTypeVariables moduleName dict $ do
73− tyCons <- replicateM (length tys) fresh
76+ tyCons <- replicateM (length tys) fresh
74− let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
77+ let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
75− bindLocalTypeVariables moduleName dict $
78+ bindLocalTypeVariables moduleName dict $ do
76− zipWithM (\tyCon (_, args, ts) -> do
79+ data_ks <- zipWithM (\tyCon (_, args, ts) -> do
77− kargs <- replicateM (length args) fresh
80+ kargs <- replicateM (length args) fresh
78− let argDict = zip (map ProperName args) kargs
81+ let argDict = zip (map ProperName args) kargs
79− bindLocalTypeVariables moduleName argDict $
82+ bindLocalTypeVariables moduleName argDict $
80− solveTypes ts kargs tyCon) tyCons tys
83+ solveTypes ts kargs tyCon) tyCons tys
84+ syn_ks <- zipWithM (\synVar (_, args, ty) -> do
85+ kargs <- replicateM (length args) fresh
86+ let argDict = zip (map ProperName args) kargs
87+ bindLocalTypeVariables moduleName argDict $
88+ solveTypes [ty] kargs synVar) synVars syns
89+ return (syn_ks, data_ks)
90+ where
91+ tidyUp ((ks1, ks2), s) = (map starIfUnknown $ apply s ks1, map starIfUnknown $ apply s ks2)
81
92
82solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind
93solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind
83solveTypes ts kargs tyCon = do
94solveTypes ts kargs tyCon = do