3b12e0b · rowtype-yoga/purescript-native

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

TypeDeclarationKind now unnecessary

Although the handling of duplicate definitions within a module needs refining

commit3b12e0bb6dff52399525f78268f2d12c33706371 authorGary Burgess <gary.burgess@gmail.com> dateThu 27 Feb 2014, 16:03 (13 years ago) parent965df5c

5 files changed+28−58

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/Externs.hs+1−1 src/Language/PureScript/Sugar/Names.hs+11−3 src/Language/PureScript/TypeChecker.hs+5−18 src/Language/PureScript/TypeChecker/Kinds.hs+1−1 src/Language/PureScript/TypeChecker/Monad.hs+10−35

src/Language/PureScript/CodeGen/Externs.hs+1−1

@@ -42,7 +42,7 @@ declToPs path env (BindingGroupDeclaration vals) =

4242 (ty, _) <- M.lookup (path, name) $ names env

4343 return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

4444declToPs path env (DataDeclaration name _ _) = maybeToList $ do

45− (kind, _) <- M.lookup (Qualified (Just path) name) $ types env

45+ kind <- M.lookup (Qualified (Just path) name) $ types env

4646 return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

4747declToPs _ _ (ExternDataDeclaration name kind) =

4848 return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

src/Language/PureScript/Sugar/Names.hs+11−3

@@ -42,13 +42,21 @@ data ImportEnvironment = ImportEnvironment

4242nullEnv = ExportEnvironment M.empty M.empty M.empty

4343

4444addType :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment

45−addType env mn id = env { exportedTypes = M.insertWith S.union mn (S.singleton id) (exportedTypes env) }

45+addType env mn id = env { exportedTypes = M.insertWith addExport mn (S.singleton id) (exportedTypes env) }

4646

4747addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment

48−addDataConstructor env mn id = env { exportedDataConstructors = M.insertWith S.union mn (S.singleton id) (exportedDataConstructors env) }

48+addDataConstructor env mn id = env { exportedDataConstructors = M.insertWith addExport mn (S.singleton id) (exportedDataConstructors env) }

4949

5050addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment

51−addTypeclass env mn id = env { exportedTypeClasses = M.insertWith S.union mn (S.singleton id) (exportedTypeClasses env) }

51+addTypeclass env mn id = env { exportedTypeClasses = M.insertWith addExport mn (S.singleton id) (exportedTypeClasses env) }

52+

53+-- TODO: do this properly with Either

54+addExport :: (Ord s, Show s) => S.Set s -> S.Set s -> S.Set s

55+addExport new old =

56+ if null overlap

57+ then S.union new old

58+ else error $ (show $ head overlap) ++ " has already been defined"

59+ where overlap = S.toList $ S.intersection new old

5260

5361rename :: [Module] -> Either String [Module]

5462rename modules = mapM renameInModule' modules

src/Language/PureScript/TypeChecker.hs+5−18

@@ -41,7 +41,7 @@ import Language.PureScript.Sugar.TypeClasses

4141addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

4242addDataType moduleName name args dctors ctorKind = do

4343 env <- getEnv

44− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, Data) (types env) }

44+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) ctorKind (types env) }

4545 forM_ dctors $ \(dctor, tys) ->

4646 rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $

4747 addDataConstructor moduleName name args dctor tys

@@ -57,15 +57,9 @@ addDataConstructor moduleName name args dctor tys = do

5757addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()

5858addTypeSynonym moduleName name args ty kind = do

5959 env <- getEnv

60− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)

60+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) kind (types env)

6161 , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }

6262

63−typeIsNotDefined :: ModuleName -> ProperName -> Check ()

64−typeIsNotDefined moduleName name = do

65− env <- getEnv

66− guardWith (show name ++ " is already defined") $

67− not $ M.member (Qualified (Just moduleName) name) (types env)

68−

6963valueIsNotDefined :: ModuleName -> Ident -> Check ()

7064valueIsNotDefined moduleName name = do

7165 env <- getEnv

@@ -108,7 +102,6 @@ typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declar

108102typeCheckAll _ _ [] = return []

109103typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do

110104 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do

111− typeIsNotDefined moduleName name

112105 ctorKind <- kindsOf moduleName name args (concatMap snd dctors)

113106 addDataType moduleName name args dctors ctorKind

114107 ds <- typeCheckAll mainModuleName moduleName rest

@@ -119,10 +112,8 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re

119112 let dataDecls = mapMaybe toDataDecl tys

120113 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

121114 forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) -> do

122− typeIsNotDefined moduleName name

123115 addDataType moduleName name args dctors ctorKind

124116 forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do

125− typeIsNotDefined moduleName name

126117 addTypeSynonym moduleName name args ty kind

127118 ds <- typeCheckAll mainModuleName moduleName rest

128119 return $ d : ds

@@ -133,7 +124,6 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re

133124 toDataDecl _ = Nothing

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

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

136− typeIsNotDefined moduleName name

137127 kind <- kindsOf moduleName name args [ty]

138128 addTypeSynonym moduleName name args ty kind

139129 ds <- typeCheckAll mainModuleName moduleName rest

@@ -161,8 +151,7 @@ typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = d

161151 return $ d : ds

162152typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do

163153 env <- getEnv

164− guardWith (show name ++ " is already defined") $ not $ M.member (Qualified (Just moduleName) name) (types env)

165− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env) }

154+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) kind (types env) }

166155 ds <- typeCheckAll mainModuleName moduleName rest

167156 return $ d : ds

168157typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

@@ -211,10 +200,8 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

211200 forM_ pns $ \pn ->

212201 case Qualified (Just moduleName) pn `M.lookup` types env of

213202 Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")

214− Just (_, DataAlias _ _) -> return ()

215− Just (k, _) -> do

216− guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ Qualified (Just currentModule) pn `M.notMember` types env

217− modifyEnv (\e -> e { types = M.insert (Qualified (Just currentModule) pn) (k, DataAlias moduleName pn) (types e) })

203+ Just k -> do

204+ modifyEnv (\e -> e { types = M.insert (Qualified (Just currentModule) pn) k (types e) })

218205 let keys = map fst . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env

219206 forM_ keys $ \dctor ->

220207 case dctor `M.lookup` dataConstructors env of

src/Language/PureScript/TypeChecker/Kinds.hs+1−1

@@ -135,7 +135,7 @@ infer (TypeConstructor v) = do

135135 Just moduleName <- checkCurrentModule <$> get

136136 case M.lookup v (types env) of

137137 Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'" ++ show (M.keys (types env))

138− Just (kind, _) -> return kind

138+ Just kind -> return kind

139139infer (TypeApp t1 t2) = do

140140 k0 <- fresh

141141 k1 <- infer t1

src/Language/PureScript/TypeChecker/Monad.hs+10−35

@@ -61,31 +61,6 @@ data NameKind

6161 --

6262 | DataConstructor deriving Show

6363

64−-- |

65−-- The type of a type declaration

66−--

67−data TypeDeclarationKind

68− -- |

69− -- A data constructor

70− --

71− = Data

72− -- |

73− -- A data type foreign import

74− --

75− | ExternData

76− -- |

77− -- A type synonym

78− --

79− | TypeSynonym

80− -- |

81− -- An alias for a type in another module, introduced using an import declaration

82− --

83− | DataAlias ModuleName ProperName

84− -- |

85− -- A local type name introduced using a forall quantifier

86− --

87− | LocalTypeVariable deriving Show

88−

8964-- |

9065-- The @Environment@ defines all values and types which are currently in scope:

9166--

@@ -97,7 +72,7 @@ data Environment = Environment {

9772 -- |

9873 -- Type names currently in scope

9974 --

100− , types :: M.Map (Qualified ProperName) (Kind, TypeDeclarationKind)

75+ , types :: M.Map (Qualified ProperName) Kind

10176 -- |

10277 -- Data constructors currently in scope, along with their associated data type constructors

10378 --

@@ -115,12 +90,12 @@ data Environment = Environment {

11590-- |

11691-- The basic types existing in the external javascript environment

11792--

118−jsTypes ::M.Map (Qualified ProperName) (Kind, TypeDeclarationKind)

119−jsTypes = M.fromList [ (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))

120− , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array"), (FunKind Star Star, ExternData))

121− , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "String"), (Star, ExternData))

122− , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Number"), (Star, ExternData))

123− , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean"), (Star, ExternData)) ]

93+jsTypes ::M.Map (Qualified ProperName) Kind

94+jsTypes = M.fromList [ (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Function"), (FunKind Star (FunKind Star Star)))

95+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array"), (FunKind Star Star))

96+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "String"), (Star))

97+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Number"), (Star))

98+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean"), (Star)) ]

12499

125100-- |

126101-- The initial environment with no values and only the default javascript types defined

@@ -142,7 +117,7 @@ bindNames newNames action = do

142117-- |

143118-- Temporarily bind a collection of names to types

144119--

145−bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeDeclarationKind) -> m a -> m a

120+bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) Kind -> m a -> m a

146121bindTypes newNames action = do

147122 orig <- get

148123 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }

@@ -179,7 +154,7 @@ bindLocalVariables moduleName bindings =

179154--

180155bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

181156bindLocalTypeVariables moduleName bindings =

182− bindTypes (M.fromList $ flip map bindings $ \(name, k) -> (Qualified (Just moduleName) name, (k, LocalTypeVariable)))

157+ bindTypes (M.fromList $ flip map bindings $ \(name, k) -> (Qualified (Just moduleName) name, k))

183158

184159-- |

185160-- Lookup the type of a value by name in the @Environment@

@@ -199,7 +174,7 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do

199174 env <- getEnv

200175 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

201176 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"

202− Just (k, _) -> return k

177+ Just k -> return k

203178

204179-- |

205180-- Canonicalize an identifier by resolving any aliases introduced by module imports