a3215ae · rowtype-yoga/purescript-native

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

Pass kind information through to externs file

commita3215ae12b3ac38cbe9b510c5f59939ce22aa3f4 authorPhil Freeman <paf31@cantab.net> dateSun 26 Oct 2014, 20:20 (12 years ago) parent4b08ade

4 files changed+30−18

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/Externs.hs+16−4 src/Language/PureScript/Environment.hs+3−3 src/Language/PureScript/TypeChecker.hs+9−9 src/Language/PureScript/TypeChecker/Types.hs+2−2

src/Language/PureScript/CodeGen/Externs.hs+16−4

@@ -29,6 +29,8 @@ import Language.PureScript.TypeClassDictionaries

2929import Language.PureScript.Declarations

3030import Language.PureScript.Pretty

3131import Language.PureScript.Names

32+import Language.PureScript.Kinds

33+import Language.PureScript.Types

3234import Language.PureScript.Environment

3335

3436-- |

@@ -64,12 +66,15 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

6466 let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')

6567 then "newtype"

6668 else "data"

67− tell [dtype ++ " " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]

69+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)

70+ tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]

6871 Just (_, TypeSynonym) ->

6972 case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of

7073 Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"

7174 Just (args, synTy) ->

72− tell ["type " ++ show pn ++ " " ++ unwords args ++ " = " ++ prettyPrintType synTy]

75+ let

76+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)

77+ in tell ["type " ++ typeName ++ " = " ++ prettyPrintType synTy]

7378 _ -> error "Invalid input in exportToPs"

7479

7580 exportToPs (ValueRef ident) =

@@ -82,8 +87,11 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

8287 case Qualified (Just moduleName) className `M.lookup` typeClasses env of

8388 Nothing -> error $ show className ++ " has no type class definition in exportToPs"

8489 Just (args, members, implies) -> do

85− let impliesString = if null implies then "" else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "

86− tell ["class " ++ impliesString ++ show className ++ " " ++ unwords args ++ " where"]

90+ let impliesString = if null implies

91+ then ""

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)

94+ tell ["class " ++ impliesString ++ typeName ++ " where"]

8795 forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->

8896 tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]

8997

@@ -95,6 +103,10 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

95103 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "

96104 tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]

97105

106+ toTypeVar :: (String, Maybe Kind) -> Type

107+ toTypeVar (s, Nothing) = TypeVar s

108+ toTypeVar (s, Just k) = KindedType (TypeVar s) k

109+

98110 isValueExported :: Ident -> Bool

99111 isValueExported ident = ValueRef ident `elem` exts

100112

src/Language/PureScript/Environment.hs+3−3

@@ -45,7 +45,7 @@ data Environment = Environment {

4545 -- |

4646 -- Type synonyms currently in scope

4747 --

48− , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)

48+ , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)

4949 -- |

5050 -- Available type class dictionaries

5151 --

@@ -53,7 +53,7 @@ data Environment = Environment {

5353 -- |

5454 -- Type classes

5555 --

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

5757 } deriving (Show)

5858

5959-- |

@@ -124,7 +124,7 @@ data TypeKind

124124 -- |

125125 -- Data type

126126 --

127− = DataType [String] [(ProperName, [Type])]

127+ = DataType [(String, Maybe Kind)] [(ProperName, [Type])]

128128 -- |

129129 -- Type synonym

130130 --

src/Language/PureScript/TypeChecker.hs+9−9

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

@@ -129,7 +129,7 @@ typeCheckAll mainModuleName moduleName exps = go

129129 when (dtype == Newtype) $ checkNewtype dctors

130130 checkDuplicateTypeArguments $ map fst args

131131 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

133133 ds <- go rest

134134 return $ d : ds

135135 where

@@ -144,10 +144,10 @@ typeCheckAll mainModuleName moduleName exps = go

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

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

146146 checkDuplicateTypeArguments $ map fst args

147− addDataType moduleName dtype name (map fst args) dctors ctorKind

147+ addDataType moduleName dtype name args dctors ctorKind

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

149149 checkDuplicateTypeArguments $ map fst args

150− addTypeSynonym moduleName name (map fst args) ty kind

150+ addTypeSynonym moduleName name args ty kind

151151 ds <- go rest

152152 return $ d : ds

153153 where

@@ -161,7 +161,7 @@ typeCheckAll mainModuleName moduleName exps = go

161161 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do

162162 checkDuplicateTypeArguments $ map fst args

163163 kind <- kindsOf False moduleName name args [ty]

164− addTypeSynonym moduleName name (map fst args) ty kind

164+ addTypeSynonym moduleName name args ty kind

165165 ds <- go rest

166166 return $ d : ds

167167 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

@@ -216,7 +216,7 @@ typeCheckAll mainModuleName moduleName exps = go

216216 ds <- go rest

217217 return $ d : ds

218218 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

220220 ds <- go rest

221221 return $ d : ds

222222 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

342342 -- Make sure the types unify with the types in the superclass implication

343343 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs

344344 -- Finally, satisfy the subclass constraint

345− , args' <- maybeToList $ mapM (flip lookup subst) args

345+ , args' <- maybeToList $ mapM (flip lookup subst) (map fst args)

346346 , suDict <- go True subclassName args' ]

347347

348348 -- 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

595595expandTypeSynonym' env name args =

596596 case M.lookup name (typeSynonyms env) of

597597 Just (synArgs, body) -> do

598− let repl = replaceAllTypeVars (zip synArgs args) body

598+ let repl = replaceAllTypeVars (zip (map fst synArgs) args) body

599599 replaceAllTypeSynonyms' env repl

600600 Nothing -> error "Type synonym was not defined"

601601