git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Pass kind information through to externs file
a3215aePhil Freeman
src/Language/PureScript/CodeGen/Externs.hs+16−4
compare with golang
unifiedsplit
@@ -29,6 +29,8 @@ import Language.PureScript.TypeClassDictionaries
29import Language.PureScript.Declarations
29import Language.PureScript.Declarations
30import Language.PureScript.Pretty
30import Language.PureScript.Pretty
31import Language.PureScript.Names
31import Language.PureScript.Names
32+import Language.PureScript.Kinds
33+import Language.PureScript.Types
32import Language.PureScript.Environment
34import Language.PureScript.Environment
33
35
34-- |
36-- |
@@ -64,12 +66,15 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
64 let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')
66 let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')
65 then "newtype"
67 then "newtype"
66 else "data"
68 else "data"
69+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
67− tell [dtype ++ " " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]
70+ tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]
68 Just (_, TypeSynonym) ->
71 Just (_, TypeSynonym) ->
69 case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of
72 case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of
70 Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
73 Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
71 Just (args, synTy) ->
74 Just (args, synTy) ->
75+ let
76+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
72− tell ["type " ++ show pn ++ " " ++ unwords args ++ " = " ++ prettyPrintType synTy]
77+ in tell ["type " ++ typeName ++ " = " ++ prettyPrintType synTy]
73 _ -> error "Invalid input in exportToPs"
78 _ -> error "Invalid input in exportToPs"
74
79
75 exportToPs (ValueRef ident) =
80 exportToPs (ValueRef ident) =
@@ -82,8 +87,11 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
82 case Qualified (Just moduleName) className `M.lookup` typeClasses env of
87 case Qualified (Just moduleName) className `M.lookup` typeClasses env of
83 Nothing -> error $ show className ++ " has no type class definition in exportToPs"
88 Nothing -> error $ show className ++ " has no type class definition in exportToPs"
84 Just (args, members, implies) -> do
89 Just (args, members, implies) -> do
90+ let impliesString = if null implies
91+ then ""
85− let impliesString = if null implies then "" else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
92+ else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
93+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args)
86− tell ["class " ++ impliesString ++ show className ++ " " ++ unwords args ++ " where"]
94+ tell ["class " ++ impliesString ++ typeName ++ " where"]
87 forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
95 forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
88 tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
96 tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
89
97
@@ -95,6 +103,10 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
95 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
103 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
96 tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]
104 tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]
97
105
106+ toTypeVar :: (String, Maybe Kind) -> Type
107+ toTypeVar (s, Nothing) = TypeVar s
108+ toTypeVar (s, Just k) = KindedType (TypeVar s) k
109+
98 isValueExported :: Ident -> Bool
110 isValueExported :: Ident -> Bool
99 isValueExported ident = ValueRef ident `elem` exts
111 isValueExported ident = ValueRef ident `elem` exts
100
112
src/Language/PureScript/Environment.hs+3−3
@@ -45,7 +45,7 @@ data Environment = Environment {
45 -- |
45 -- |
46 -- Type synonyms currently in scope
46 -- Type synonyms currently in scope
47 --
47 --
48− , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)
48+ , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)
49 -- |
49 -- |
50 -- Available type class dictionaries
50 -- Available type class dictionaries
51 --
51 --
@@ -53,7 +53,7 @@ data Environment = Environment {
53 -- |
53 -- |
54 -- Type classes
54 -- Type classes
55 --
55 --
56− , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)], [(Qualified ProperName, [Type])])
56+ , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [(Qualified ProperName, [Type])])
57 } deriving (Show)
57 } deriving (Show)
58
58
59-- |
59-- |
@@ -124,7 +124,7 @@ data TypeKind
124 -- |
124 -- |
125 -- Data type
125 -- Data type
126 --
126 --
127− = DataType [String] [(ProperName, [Type])]
127+ = DataType [(String, Maybe Kind)] [(ProperName, [Type])]
128 -- |
128 -- |
129 -- Type synonym
129 -- Type synonym
130 --
130 --
src/Language/PureScript/TypeChecker.hs+9−9
@@ -42,13 +42,13 @@ import Language.PureScript.TypeClassDictionaries
42import Language.PureScript.Environment
42import Language.PureScript.Environment
43import Language.PureScript.Errors
43import Language.PureScript.Errors
44
44
45−addDataType :: ModuleName -> DataDeclType -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
45+addDataType :: ModuleName -> DataDeclType -> ProperName -> [(String, Maybe Kind)] -> [(ProperName, [Type])] -> Kind -> Check ()
46addDataType moduleName dtype name args dctors ctorKind = do
46addDataType moduleName dtype name args dctors ctorKind = do
47 env <- getEnv
47 env <- getEnv
48 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
48 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
49 forM_ dctors $ \(dctor, tys) ->
49 forM_ dctors $ \(dctor, tys) ->
50 rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $
50 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
52
52
53addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
53addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
54addDataConstructor moduleName dtype name args dctor tys = do
54addDataConstructor moduleName dtype name args dctor tys = do
@@ -58,7 +58,7 @@ addDataConstructor moduleName dtype name args dctor tys = do
58 let polyType = mkForAll args dctorTy
58 let polyType = mkForAll args dctorTy
59 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) }
59 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) }
60
60
61−addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
61+addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check ()
62addTypeSynonym moduleName name args ty kind = do
62addTypeSynonym moduleName name args ty kind = do
63 env <- getEnv
63 env <- getEnv
64 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
64 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
@@ -76,7 +76,7 @@ addValue moduleName name ty nameKind = do
76 env <- getEnv
76 env <- getEnv
77 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
77 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
78
78
79−addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()
79+addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()
80addTypeClass moduleName pn args implies ds =
80addTypeClass moduleName pn args implies ds =
81 let members = map toPair ds in
81 let members = map toPair ds in
82 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
82 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
@@ -129,7 +129,7 @@ typeCheckAll mainModuleName moduleName exps = go
129 when (dtype == Newtype) $ checkNewtype dctors
129 when (dtype == Newtype) $ checkNewtype dctors
130 checkDuplicateTypeArguments $ map fst args
130 checkDuplicateTypeArguments $ map fst args
131 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
131 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
132− addDataType moduleName dtype name (map fst args) dctors ctorKind
132+ addDataType moduleName dtype name args dctors ctorKind
133 ds <- go rest
133 ds <- go rest
134 return $ d : ds
134 return $ d : ds
135 where
135 where
@@ -144,10 +144,10 @@ typeCheckAll mainModuleName moduleName exps = go
144 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
144 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
145 forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
145 forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
146 checkDuplicateTypeArguments $ map fst args
146 checkDuplicateTypeArguments $ map fst args
147− addDataType moduleName dtype name (map fst args) dctors ctorKind
147+ addDataType moduleName dtype name args dctors ctorKind
148 forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
148 forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
149 checkDuplicateTypeArguments $ map fst args
149 checkDuplicateTypeArguments $ map fst args
150− addTypeSynonym moduleName name (map fst args) ty kind
150+ addTypeSynonym moduleName name args ty kind
151 ds <- go rest
151 ds <- go rest
152 return $ d : ds
152 return $ d : ds
153 where
153 where
@@ -161,7 +161,7 @@ typeCheckAll mainModuleName moduleName exps = go
161 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
161 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
162 checkDuplicateTypeArguments $ map fst args
162 checkDuplicateTypeArguments $ map fst args
163 kind <- kindsOf False moduleName name args [ty]
163 kind <- kindsOf False moduleName name args [ty]
164− addTypeSynonym moduleName name (map fst args) ty kind
164+ addTypeSynonym moduleName name args ty kind
165 ds <- go rest
165 ds <- go rest
166 return $ d : ds
166 return $ d : ds
167 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
167 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
@@ -216,7 +216,7 @@ typeCheckAll mainModuleName moduleName exps = go
216 ds <- go rest
216 ds <- go rest
217 return $ d : ds
217 return $ d : ds
218 go (d@(TypeClassDeclaration pn args implies tys) : rest) = do
218 go (d@(TypeClassDeclaration pn args implies tys) : rest) = do
219− addTypeClass moduleName pn (map fst args) implies tys
219+ addTypeClass moduleName pn args implies tys
220 ds <- go rest
220 ds <- go rest
221 return $ d : ds
221 return $ d : ds
222 go (TypeInstanceDeclaration dictName deps className tys _ : rest) =
222 go (TypeInstanceDeclaration dictName deps className tys _ : rest) =
src/Language/PureScript/TypeChecker/Types.hs+2−2
@@ -342,7 +342,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
342 -- Make sure the types unify with the types in the superclass implication
342 -- Make sure the types unify with the types in the superclass implication
343 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
343 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
344 -- Finally, satisfy the subclass constraint
344 -- Finally, satisfy the subclass constraint
345− , args' <- maybeToList $ mapM (flip lookup subst) args
345+ , args' <- maybeToList $ mapM (flip lookup subst) (map fst args)
346 , suDict <- go True subclassName args' ]
346 , suDict <- go True subclassName args' ]
347
347
348 -- Create dictionaries for subgoals which still need to be solved by calling go recursively
348 -- Create dictionaries for subgoals which still need to be solved by calling go recursively
@@ -595,7 +595,7 @@ expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either St
595expandTypeSynonym' env name args =
595expandTypeSynonym' env name args =
596 case M.lookup name (typeSynonyms env) of
596 case M.lookup name (typeSynonyms env) of
597 Just (synArgs, body) -> do
597 Just (synArgs, body) -> do
598− let repl = replaceAllTypeVars (zip synArgs args) body
598+ let repl = replaceAllTypeVars (zip (map fst synArgs) args) body
599 replaceAllTypeSynonyms' env repl
599 replaceAllTypeSynonyms' env repl
600 Nothing -> error "Type synonym was not defined"
600 Nothing -> error "Type synonym was not defined"
601
601