3b12e0b · rowtype-yoga/purescript-native

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

on golang help sign in

TypeDeclarationKind now unnecessary

3b12e0bGary Burgess13 years ago

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

compare with golang

unifiedsplit

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

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

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

44declToPs 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

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

47declToPs _ _ (ExternDataDeclaration name kind) =

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

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

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

42nullEnv = ExportEnvironment M.empty M.empty M.empty

44addType :: 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) }

47addDataConstructor :: 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) }

50addTypeclass :: 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

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

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

54rename modules = mapM renameInModule' modules

62rename modules = mapM renameInModule' modules

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

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

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

42addDataType moduleName name args dctors ctorKind = do

43 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) }

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

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

47 addDataConstructor moduleName name args dctor tys

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

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

58addTypeSynonym moduleName name args ty kind = do

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

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

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−

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

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

70valueIsNotDefined moduleName name = do

64valueIsNotDefined moduleName name = do

71 env <- getEnv

65 env <- getEnv

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

108typeCheckAll _ _ [] = return []

102typeCheckAll _ _ [] = return []

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

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

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

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

111− typeIsNotDefined moduleName name

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

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

113 addDataType moduleName name args dctors ctorKind

106 addDataType moduleName name args dctors ctorKind

114 ds <- typeCheckAll mainModuleName moduleName rest

107 ds <- typeCheckAll mainModuleName moduleName rest

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

119 let dataDecls = mapMaybe toDataDecl tys

112 let dataDecls = mapMaybe toDataDecl tys

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

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

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

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

122− typeIsNotDefined moduleName name

123 addDataType moduleName name args dctors ctorKind

115 addDataType moduleName name args dctors ctorKind

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

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

125− typeIsNotDefined moduleName name

126 addTypeSynonym moduleName name args ty kind

117 addTypeSynonym moduleName name args ty kind

127 ds <- typeCheckAll mainModuleName moduleName rest

118 ds <- typeCheckAll mainModuleName moduleName rest

128 return $ d : ds

119 return $ d : ds

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

133 toDataDecl _ = Nothing

124 toDataDecl _ = Nothing

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

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

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

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

136− typeIsNotDefined moduleName name

137 kind <- kindsOf moduleName name args [ty]

127 kind <- kindsOf moduleName name args [ty]

138 addTypeSynonym moduleName name args ty kind

128 addTypeSynonym moduleName name args ty kind

139 ds <- typeCheckAll mainModuleName moduleName rest

129 ds <- typeCheckAll mainModuleName moduleName rest

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

161 return $ d : ds

151 return $ d : ds

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

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

163 env <- getEnv

153 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) }

166 ds <- typeCheckAll mainModuleName moduleName rest

155 ds <- typeCheckAll mainModuleName moduleName rest

167 return $ d : ds

156 return $ d : ds

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

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

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

211 forM_ pns $ \pn ->

200 forM_ pns $ \pn ->

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

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

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

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

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

215− Just (k, _) -> do

203+ 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) })

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

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

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

219 forM_ keys $ \dctor ->

206 forM_ keys $ \dctor ->

220 case dctor `M.lookup` dataConstructors env of

207 case dctor `M.lookup` dataConstructors env of

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

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

135 Just moduleName <- checkCurrentModule <$> get

136 case M.lookup v (types env) of

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

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

138+ Just kind -> return kind

139infer (TypeApp t1 t2) = do

140 k0 <- fresh

141 k1 <- infer t1

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

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

61 --

62 | DataConstructor deriving Show

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−

89-- |

64-- |

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

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

91--

66--

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

97 -- |

72 -- |

98 -- Type names currently in scope

73 -- Type names currently in scope

99 --

74 --

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

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

101 -- |

76 -- |

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

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

103 --

78 --

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

115-- |

90-- |

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

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

117--

92--

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

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

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

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

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

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

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

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

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

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

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

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

124

125-- |

100-- |

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

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

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

142-- |

117-- |

143-- Temporarily bind a collection of names to types

118-- Temporarily bind a collection of names to types

144--

119--

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

146bindTypes newNames action = do

121bindTypes newNames action = do

147 orig <- get

122 orig <- get

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

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

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

179--

154--

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

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

181bindLocalTypeVariables moduleName bindings =

156bindLocalTypeVariables 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))

183

158

184-- |

159-- |

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

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

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

199 env <- getEnv

174 env <- getEnv

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

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

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

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

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

177+ Just k -> return k

203

178

204-- |

179-- |

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

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