4aca4c1 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Type synonyms and data type declarations can now depend on each other.

commit4aca4c1323ecd0d19a2325bb2472cdf970707f73 authorPhil Freeman <paf31@cantab.net> dateThu 23 Jan 2014, 18:02 (13 years ago) parent17d8ee4

8 files changed+114−57

compare with golang

unifiedsplit

examples/failing/TypeSynonyms.purs+5 examples/passing/DataAndType.purs+5 src/Language/PureScript.hs+1−1 src/Language/PureScript/Declarations.hs+31−1 src/Language/PureScript/Sugar.hs+1−1 src/Language/PureScript/Sugar/BindingGroups.hs+37−40 src/Language/PureScript/TypeChecker.hs+13−4 src/Language/PureScript/TypeChecker/Kinds.hs+21−10

examples/failing/TypeSynonyms.pursnew file+5

@@ -0,0 +1,5 @@

1+module TypeSynonyms where

3+type T1 = [T2]

5+type T2 = T1

examples/passing/DataAndType.pursnew file+5

@@ -0,0 +1,5 @@

1+module DataAndType where

3+data A = A B

5+type B = A

src/Language/PureScript.hs+1−1

@@ -35,7 +35,7 @@ compile :: Options -> [Module] -> Either String (String, String, Environment)

3535compile opts ms = do

3636 desugared <- desugar ms

3737 (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

3939 let js = concatMap (flip (moduleToJs opts) env) $ regrouped

4040 let exts = intercalate "\n" . map (flip moduleToPs env) $ regrouped

4141 js' <- case () of

src/Language/PureScript/Declarations.hs+31−1

@@ -39,7 +39,7 @@ data ForeignImportType

3939

4040data Declaration

4141 = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]

42− | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe Type)])]

42+ | DataBindingGroupDeclaration [Declaration]

4343 | TypeSynonymDeclaration ProperName [String] Type

4444 | TypeDeclaration Ident Type

4545 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value

@@ -51,3 +51,33 @@ data Declaration

5151 | TypeClassDeclaration ProperName String [Declaration]

5252 | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]

5353 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

3131 >=> desugarDo

3232 >=> desugarCasesModule

3333 >=> desugarTypeDeclarationsModule

34− >=> return . createBindingGroupsModule

34+ >=> createBindingGroupsModule

src/Language/PureScript/Sugar/BindingGroups.hs+37−40

@@ -23,49 +23,51 @@ import Data.Data

2323import Data.Graph

2424import Data.Generics

2525import Data.List (nub, intersect)

26+import Control.Applicative ((<$>))

2627

2728import Language.PureScript.Declarations

2829import Language.PureScript.Names

2930import Language.PureScript.Values

3031import Language.PureScript.Types

32+import Debug.Trace (trace)

3133

32−createBindingGroupsModule :: [Module] -> [Module]

33−createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)

34+createBindingGroupsModule :: [Module] -> Either String [Module]

35+createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups ds

3436

3537collapseBindingGroupsModule :: [Module] -> [Module]

3638collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBindingGroups ds)

3739

38−createBindingGroups :: [Declaration] -> [Declaration]

39−createBindingGroups ds =

40− let

41− values = filter isValueDecl ds

42− dataDecls = filter isDataDecl ds

43− nonValues = filter (\d -> not (isValueDecl d) && not (isDataDecl d)) ds

44− allProperNames = map getProperName dataDecls

45− dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls

46− dataBindingGroupDecls = map toDataBindingGroup $ stronglyConnComp dataVerts

47− allIdents = map getIdent values

48− valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values

49− bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts

50− in

51− dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls

40+createBindingGroups :: [Declaration] -> Either String [Declaration]

41+createBindingGroups ds = do

42+ let values = filter isValueDecl ds

43+ dataDecls = filter isDataDecl ds

44+ allProperNames = map getProperName dataDecls

45+ dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls

46+ dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts

47+ let allIdents = map getIdent values

48+ valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values

49+ bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts

50+ return $ filter isImportDecl ds ++

51+ filter isExternDataDecl ds ++

52+ dataBindingGroupDecls ++

53+ filter isTypeClassDeclaration ds ++

54+ filter isFixityDecl ds ++

55+ filter isExternDecl ds ++

56+ bindingGroupDecls

5257

5358collapseBindingGroups :: [Declaration] -> [Declaration]

5459collapseBindingGroups ds = concatMap go ds

5560 where

56− go (DataBindingGroupDeclaration ds) = map (\(name, args, dctors) -> DataDeclaration name args dctors) ds

61+ go (DataBindingGroupDeclaration ds) = ds

5762 go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds

5863 go other = [other]

5964

6065usedIdents :: (Data d) => d -> [Ident]

61−usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS)

66+usedIdents = nub . everything (++) (mkQ [] names)

6267 where

63− namesV :: Value -> [Ident]

64− namesV (Var (Qualified Nothing name)) = [name]

65− namesV _ = []

66− namesS :: Statement -> [Ident]

67− namesS (VariableIntroduction name _) = [name]

68− namesS _ = []

68+ names :: Value -> [Ident]

69+ names (Var (Qualified Nothing name)) = [name]

70+ names _ = []

6971

7072usedProperNames :: (Data d) => d -> [ProperName]

7173usedProperNames = nub . everything (++) (mkQ [] names)

@@ -74,20 +76,13 @@ usedProperNames = nub . everything (++) (mkQ [] names)

7476 names (TypeConstructor (Qualified Nothing name)) = [name]

7577 names _ = []

7678

77−isValueDecl :: Declaration -> Bool

78−isValueDecl (ValueDeclaration _ _ _ _) = True

79−isValueDecl _ = False

80−

81−isDataDecl :: Declaration -> Bool

82−isDataDecl (DataDeclaration _ _ _) = True

83−isDataDecl _ = False

84−

8579getIdent :: Declaration -> Ident

8680getIdent (ValueDeclaration ident _ _ _) = ident

8781getIdent _ = error "Expected ValueDeclaration"

8882

8983getProperName :: Declaration -> ProperName

9084getProperName (DataDeclaration pn _ _) = pn

85+getProperName (TypeSynonymDeclaration pn _ _) = pn

9186getProperName _ = error "Expected DataDeclaration"

9287

9388toBindingGroup :: SCC Declaration -> Declaration

@@ -95,16 +90,18 @@ toBindingGroup (AcyclicSCC d) = d

9590toBindingGroup (CyclicSCC [d]) = d

9691toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'

9792

98−toDataBindingGroup :: SCC Declaration -> Declaration

99−toDataBindingGroup (AcyclicSCC d) = d

100−toDataBindingGroup (CyclicSCC [d]) = d

101−toDataBindingGroup (CyclicSCC ds') = DataBindingGroupDeclaration $ map fromDataDecl ds'

93+toDataBindingGroup :: SCC Declaration -> Either String Declaration

94+toDataBindingGroup (AcyclicSCC d) = return d

95+toDataBindingGroup (CyclicSCC [TypeSynonymDeclaration pn _ _]) = Left $ "Cycle in type synonym " ++ show pn

96+toDataBindingGroup (CyclicSCC [d]) = return d

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

102103

103104fromValueDecl :: Declaration -> (Ident, Value)

104105fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)

105106fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"

106107fromValueDecl _ = 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

9898 ds <- typeCheckAll moduleName rest

9999 return $ d : ds

100100typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

101− rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do

102− forM_ tys $ \(name, _, _) ->

101+ rethrow ("Error in data binding group:\n" ++) $ do

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

103106 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) ->

106107 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

107111 ds <- typeCheckAll moduleName rest

108112 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

109118typeCheckAll moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

110119 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do

111120 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))

6868 bindLocalTypeVariables moduleName dict $

6969 solveTypes ts kargs tyCon

7070

71−kindsOfAll :: ModuleName -> [(ProperName, [String], [Type])] -> Check [Kind]

72−kindsOfAll moduleName tys = fmap (map starIfUnknown . (\(ks, s) -> apply s ks)) . runSubst (SubstContext moduleName) $ do

73− tyCons <- replicateM (length tys) fresh

74− let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons

75− bindLocalTypeVariables moduleName dict $

76− zipWithM (\tyCon (_, args, ts) -> do

77− kargs <- replicateM (length args) fresh

78− let argDict = zip (map ProperName args) kargs

79− bindLocalTypeVariables moduleName argDict $

80− solveTypes ts kargs tyCon) tyCons tys

71+kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind])

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

76+ tyCons <- replicateM (length tys) fresh

77+ let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons

78+ bindLocalTypeVariables moduleName dict $ do

79+ data_ks <- zipWithM (\tyCon (_, args, ts) -> do

80+ kargs <- replicateM (length args) fresh

81+ let argDict = zip (map ProperName args) kargs

82+ bindLocalTypeVariables moduleName argDict $

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)

8192

8293solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind

8394solveTypes ts kargs tyCon = do