@@ -42,13 +42,13 @@ import Language.PureScript.TypeClassDictionaries
4242import Language.PureScript.Environment
4343import Language.PureScript.Errors
4444
45−addDataType :: ModuleName -> DataDeclType -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
45+addDataType :: ModuleName -> DataDeclType -> ProperName -> [(String, Maybe Kind)] -> [(ProperName, [Type])] -> Kind -> Check ()
4646addDataType moduleName dtype name args dctors ctorKind = do
4747 env <- getEnv
4848 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
4949 forM_ dctors $ \(dctor, tys) ->
5050 rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $
51− addDataConstructor moduleName dtype name args dctor tys
51+ addDataConstructor moduleName dtype name (map fst args) dctor tys
5252
5353addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
5454addDataConstructor moduleName dtype name args dctor tys = do
@@ -58,7 +58,7 @@ addDataConstructor moduleName dtype name args dctor tys = do
5858 let polyType = mkForAll args dctorTy
5959 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) }
6060
61−addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
61+addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check ()
6262addTypeSynonym moduleName name args ty kind = do
6363 env <- getEnv
6464 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
@@ -76,7 +76,7 @@ addValue moduleName name ty nameKind = do
7676 env <- getEnv
7777 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
7878
79−addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()
79+addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()
8080addTypeClass moduleName pn args implies ds =
8181 let members = map toPair ds in
8282 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
@@ -124,14 +124,15 @@ typeCheckAll mainModuleName moduleName exps = go
124124 where
125125 go :: [Declaration] -> Check [Declaration]
126126 go [] = return []
127− go (d@(DataDeclaration dtype name args dctors) : rest) = do
127+ go (DataDeclaration dtype name args dctors : rest) = do
128128 rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do
129129 when (dtype == Newtype) $ checkNewtype dctors
130− checkDuplicateTypeArguments args
130+ checkDuplicateTypeArguments $ map fst args
131131 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
132− addDataType moduleName dtype name args dctors ctorKind
132+ let args' = args `withKinds` ctorKind
133+ addDataType moduleName dtype name args' dctors ctorKind
133134 ds <- go rest
134− return $ d : ds
135+ return $ DataDeclaration dtype name args dctors : ds
135136 where
136137 checkNewtype :: [(ProperName, [Type])] -> Check ()
137138 checkNewtype [(_, [_])] = return ()
@@ -143,11 +144,13 @@ typeCheckAll mainModuleName moduleName exps = go
143144 let dataDecls = mapMaybe toDataDecl tys
144145 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
145146 forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
146− checkDuplicateTypeArguments args
147− addDataType moduleName dtype name args dctors ctorKind
147+ checkDuplicateTypeArguments $ map fst args
148+ let args' = args `withKinds` ctorKind
149+ addDataType moduleName dtype name args' dctors ctorKind
148150 forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
149− checkDuplicateTypeArguments args
150− addTypeSynonym moduleName name args ty kind
151+ checkDuplicateTypeArguments $ map fst args
152+ let args' = args `withKinds` kind
153+ addTypeSynonym moduleName name args' ty kind
151154 ds <- go rest
152155 return $ d : ds
153156 where
@@ -157,13 +160,14 @@ typeCheckAll mainModuleName moduleName exps = go
157160 toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
158161 toDataDecl (PositionedDeclaration _ d') = toDataDecl d'
159162 toDataDecl _ = Nothing
160− go (d@(TypeSynonymDeclaration name args ty) : rest) = do
163+ go (TypeSynonymDeclaration name args ty : rest) = do
161164 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
162− checkDuplicateTypeArguments args
165+ checkDuplicateTypeArguments $ map fst args
163166 kind <- kindsOf False moduleName name args [ty]
164− addTypeSynonym moduleName name args ty kind
167+ let args' = args `withKinds` kind
168+ addTypeSynonym moduleName name args' ty kind
165169 ds <- go rest
166− return $ d : ds
170+ return $ TypeSynonymDeclaration name args ty : ds
167171 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
168172 go (ValueDeclaration name nameKind [] Nothing val : rest) = do
169173 d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do
@@ -240,6 +244,16 @@ typeCheckAll mainModuleName moduleName exps = go
240244 rethrowWithPosition pos $ do
241245 (d' : rest') <- go (d : rest)
242246 return (PositionedDeclaration pos d' : rest')
247+
248+ -- |
249+ -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
250+ -- extracted from the kind of the type constructor itself.
251+ --
252+ withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]
253+ withKinds [] _ = []
254+ withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k
255+ withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
256+ withKinds _ _ = error "Invalid arguments to peelKinds"
243257
244258-- |
245259-- Type check an entire module and ensure all types and classes defined within the module that are