52796ae · rowtype-yoga/purescript-native

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

Type renaming mostly working

commit52796aed2a5d1a3ebb000e66d069eef1d5eddfe5 authorGary Burgess <gary.burgess@gmail.com> dateThu 27 Feb 2014, 15:09 (13 years ago) parent40338c8

8 files changed+89−100

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/Externs.hs+1−1 src/Language/PureScript/Sugar/Names.hs+26−20 src/Language/PureScript/Sugar/TypeClasses.hs+8−7 src/Language/PureScript/TypeChecker.hs+19−19 src/Language/PureScript/TypeChecker/Kinds.hs+2−2 src/Language/PureScript/TypeChecker/Monad.hs+17−28 src/Language/PureScript/TypeChecker/Synonyms.hs+6−6 src/Language/PureScript/TypeChecker/Types.hs+10−17

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 (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+26−20

@@ -28,16 +28,21 @@ import Language.PureScript.Values

2828import Debug.Trace

2929

3030data ExportEnvironment = ExportEnvironment

31− { exportedDataConstructors :: M.Map ModuleName (S.Set ProperName)

31+ { exportedTypes :: M.Map ModuleName (S.Set ProperName)

32+ , exportedDataConstructors :: M.Map ModuleName (S.Set ProperName)

3233 , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)

3334 } deriving (Show)

3435

3536data ImportEnvironment = ImportEnvironment

36− { importedDataConstructors :: M.Map ProperName (Qualified ProperName)

37+ { importedTypes :: M.Map ProperName (Qualified ProperName)

38+ , importedDataConstructors :: M.Map ProperName (Qualified ProperName)

3739 , importedTypeClasses :: M.Map ProperName (Qualified ProperName)

3840 } deriving (Show)

3941

40−nullEnv = ExportEnvironment M.empty M.empty

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

43+

44+addType :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment

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

4146

4247addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment

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

@@ -62,35 +67,35 @@ renameInModule imports (Module mn decls) =

6267 cs' <- updateConstraints cs

6368 return $ TypeInstanceDeclaration cs' cn' ts ds

6469 updateDecl d = return d

65− updateValue (Constructor (Qualified Nothing nm)) = do

66− nm' <- updateDataConstructorName nm

67− return $ Constructor nm'

70+ updateValue (Constructor (Qualified Nothing nm)) = updateDataConstructorName nm >>= return . Constructor

6871 updateValue v = return v

69− updateBinder (ConstructorBinder (Qualified Nothing nm) b) = do

70− nm' <- updateDataConstructorName nm

71− return $ ConstructorBinder nm' b

72+ updateBinder (ConstructorBinder (Qualified Nothing nm) b) = updateDataConstructorName nm >>= return . (`ConstructorBinder` b)

7273 updateBinder v = return v

73− updateType (ConstrainedType cs t) = do

74− cs' <- updateConstraints cs

75− return $ ConstrainedType cs' t

74+ updateType (TypeConstructor (Qualified Nothing nm)) = updateTypeName nm >>= return . TypeConstructor

75+ updateType (SaturatedTypeSynonym (Qualified Nothing nm) tys) = do

76+ nm' <- updateTypeName nm

77+ tys' <- mapM updateType tys

78+ return $ SaturatedTypeSynonym nm' tys'

79+ updateType (ConstrainedType cs t) = updateConstraints cs >>= return . (`ConstrainedType` t)

7680 updateType t = return t

7781 updateConstraints = mapM updateConstraint

7882 updateConstraint (Qualified Nothing nm, ts) = do

7983 nm' <- updateClassName nm

8084 return (nm', ts)

8185 updateConstraint other = return other

82− updateClassName nm =

83− maybe (err "typeclass" nm mn) return $ M.lookup nm (importedTypeClasses imports)

84− updateDataConstructorName nm =

85− maybe (err "data constructor" nm mn) return $ M.lookup nm (importedDataConstructors imports)

86− err t nm mn = Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'"

87−

86+ updateTypeName = update "type" importedTypes

87+ updateClassName = update "typeclass" importedTypeClasses

88+ updateDataConstructorName = update "data constructor" importedDataConstructors

89+ update t get nm = maybe (Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'") return $ M.lookup nm (get imports)

90+

8891findExports :: [Module] -> ExportEnvironment

8992findExports = foldl addModule nullEnv

9093 where

9194 addModule env (Module mn ds) = foldl (addDecl mn) env ds

9295 addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn

93− addDecl mn env (DataDeclaration tcn _ dcs) = foldl (`addDataConstructor` mn) env (map fst dcs)

96+ addDecl mn env (DataDeclaration tn _ dcs) = addType (foldl (`addDataConstructor` mn) env (map fst dcs)) mn tn

97+ addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn

98+ addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn

9499 addDecl _ env _ = env

95100

96101findImports :: [Declaration] -> [ModuleName]

@@ -98,9 +103,10 @@ findImports decls = [ mn | (ImportDeclaration mn Nothing) <- decls ]

98103

99104resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment

100105resolveImports env (Module currentModule decls) = do

106+ types <- resolve exportedTypes

101107 dataConstructors <- resolve exportedDataConstructors

102108 typeClasses <- resolve exportedTypeClasses

103− return $ ImportEnvironment dataConstructors typeClasses

109+ return $ ImportEnvironment types dataConstructors typeClasses

104110 where

105111 scope = currentModule : findImports decls

106112 resolve get = foldM resolveDefs M.empty (M.toList $ get env)

src/Language/PureScript/Sugar/TypeClasses.hs+8−7

@@ -92,7 +92,7 @@ desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]

9292desugarDecl mn d@(TypeClassDeclaration name args members) = do

9393 let tys = map memberToNameAndType members

9494 modify (M.insert (mn, name) (args, tys))

95− return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor name args) members

95+ return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members

9696desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do

9797 desugared <- lift $ desugarCases members

9898 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared

@@ -108,12 +108,12 @@ typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Dec

108108typeClassDictionaryDeclaration name args members =

109109 TypeSynonymDeclaration name args (Object $ rowFromList (map memberToNameAndType members, REmpty))

110110

111−typeClassMemberToDictionaryAccessor :: ProperName -> [String] -> Declaration -> Declaration

112−typeClassMemberToDictionaryAccessor name args (TypeDeclaration ident ty) =

111+typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration

112+typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

113113 ExternDeclaration TypeClassAccessorImport ident

114114 (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))

115− (quantify (ConstrainedType [(Qualified Nothing name, map TypeVar args)] ty))

116−typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"

115+ (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))

116+typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"

117117

118118typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

119119typeInstanceDictionaryDeclaration mn deps name tys decls = do

@@ -155,9 +155,10 @@ typeInstanceDictionaryEntryDeclaration mn deps name tys (ValueDeclaration ident

155155 lookupIdent members = maybe (Left $ "Type class " ++ show name ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members

156156typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"

157157

158+

158159qualifiedToString :: ModuleName -> Qualified ProperName -> String

159−qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)

160−qualifiedToString _ (Qualified (Just mn) pn) = moduleNameToJs mn ++ "_" ++ runProperName pn

160+qualifiedToString mn (Qualified _ pn) = moduleNameToJs mn ++ "_" ++ runProperName pn

161+

161162

162163-- |

163164-- Generate a name for a type class dictionary, based on the module name, class name and type name

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

@@ -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 (moduleName, name) (ctorKind, Data) (types env) }

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

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

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

4747 addDataConstructor moduleName name args dctor tys

@@ -52,19 +52,19 @@ addDataConstructor moduleName name args dctor tys = do

5252 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)

5353 let dctorTy = foldr function retTy tys

5454 let polyType = mkForAll args dctorTy

55− putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (qualifyAllUnqualifiedNames moduleName env polyType) (dataConstructors env) }

55+ putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) polyType (dataConstructors env) }

5656

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

5858addTypeSynonym moduleName name args ty kind = do

5959 env <- getEnv

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

61− , typeSynonyms = M.insert (moduleName, name) (args, qualifyAllUnqualifiedNames moduleName env ty) (typeSynonyms env) }

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

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

6262

6363typeIsNotDefined :: ModuleName -> ProperName -> Check ()

6464typeIsNotDefined moduleName name = do

6565 env <- getEnv

6666 guardWith (show name ++ " is already defined") $

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

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

6868

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

7070valueIsNotDefined moduleName name = do

@@ -76,7 +76,7 @@ valueIsNotDefined moduleName name = do

7676addValue :: ModuleName -> Ident -> Type -> Check ()

7777addValue moduleName name ty = do

7878 env <- getEnv

79− putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })

79+ putEnv (env { names = M.insert (moduleName, name) (ty, Value) (names env) })

8080

8181addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

8282addTypeClassDictionaries entries =

@@ -86,7 +86,7 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()

8686checkTypeClassInstance _ (TypeVar _) = return ()

8787checkTypeClassInstance m (TypeConstructor ctor) = do

8888 env <- getEnv

89− when (canonicalizeType m env ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"

89+ when (ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"

9090 return ()

9191checkTypeClassInstance m (TypeApp ty (TypeVar _)) = checkTypeClassInstance m ty

9292checkTypeClassInstance _ _ = throwError "Type class instance must be of the form T a1 ... an"

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

161161 return $ d : ds

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

163163 env <- getEnv

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

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

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

166166 ds <- typeCheckAll mainModuleName moduleName rest

167167 return $ d : ds

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

@@ -172,7 +172,7 @@ typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty)

172172 guardWith "Expected kind *" $ kind == Star

173173 case M.lookup (moduleName, name) (names env) of

174174 Just _ -> throwError $ show name ++ " is already defined"

175− Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern importTy) (names env) })

175+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy) (names env) })

176176 ds <- typeCheckAll mainModuleName moduleName rest

177177 return $ d : ds

178178typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do

@@ -187,7 +187,7 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

187187 case idents of

188188 Nothing -> do

189189 shadowIdents (map snd $ filterModule (names env)) env

190− shadowTypes (map snd $ filterModule (types env)) env

190+ shadowTypes (map (\(Qualified _ name) -> name) $ filterModuleQ (types env)) env

191191 Just idents' -> do

192192 shadowIdents (lefts idents') env

193193 shadowTypes (rights idents') env

@@ -197,7 +197,8 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

197197 where

198198 errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)

199199 filterModule = filter ((== moduleName) . fst) . M.keys

200− moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))

200+ filterModuleQ = filter (\(Qualified (Just mn) _) -> mn == moduleName) . M.keys

201+ moduleExists env = not (null (filterModule (names env))) || not (null (filterModuleQ (types env)))

201202 shadowIdents idents' env =

202203 forM_ idents' $ \ident ->

203204 case (moduleName, ident) `M.lookup` names env of

@@ -208,12 +209,12 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

208209 Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")

209210 shadowTypes pns env =

210211 forM_ pns $ \pn ->

211− case (moduleName, pn) `M.lookup` types env of

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

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

213214 Just (_, DataAlias _ _) -> return ()

214215 Just (k, _) -> do

215− guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env

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

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

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

218219 forM_ keys $ \dctor ->

219220 case dctor `M.lookup` dataConstructors env of

@@ -237,13 +238,12 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

237238typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do

238239 env <- getEnv

239240 ds <- typeCheckAll mainModuleName moduleName rest

240− return $ qualifyAllUnqualifiedNames moduleName env d : ds

241+ return $ d : ds

241242typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className tys _) : rest) = do

242243 env <- getEnv

243244 dictName <- Check . lift $ mkDictionaryValueName moduleName className tys

244245 mapM_ (checkTypeClassInstance moduleName) tys

245246 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

246− addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env

247− [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular])

247+ addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]

248248 ds <- typeCheckAll mainModuleName moduleName rest

249− return $ qualifyAllUnqualifiedNames moduleName env d : ds

249+ return $ d : ds

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

@@ -133,8 +133,8 @@ infer (TypeVar v) = do

133133infer (TypeConstructor v) = do

134134 env <- liftCheck getEnv

135135 Just moduleName <- checkCurrentModule <$> get

136− case M.lookup (qualify moduleName v) (types env) of

137− Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'"

136+ case M.lookup v (types env) of

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

138138 Just (kind, _) -> return kind

139139infer (TypeApp t1 t2) = do

140140 k0 <- fresh

src/Language/PureScript/TypeChecker/Monad.hs+17−28

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

9797 -- |

9898 -- Type names currently in scope

9999 --

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

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

101101 -- |

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

103103 --

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

105105 -- |

106106 -- Type synonyms currently in scope

107107 --

108− , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)

108+ , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)

109109 -- |

110110 -- Available type class dictionaries

111111 --

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

115115-- |

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

117117--

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

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

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

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

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

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

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

124124

125125-- |

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

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

142142-- |

143143-- Temporarily bind a collection of names to types

144144--

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

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

146146bindTypes newNames action = do

147147 orig <- get

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

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

179179--

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

181181bindLocalTypeVariables moduleName bindings =

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

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

183183

184184-- |

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

@@ -197,7 +197,7 @@ lookupVariable currentModule (Qualified moduleName var) = do

197197lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind

198198lookupTypeVariable currentModule (Qualified moduleName name) = do

199199 env <- getEnv

200− case M.lookup (fromMaybe currentModule moduleName, name) (types env) of

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

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

202202 Just (k, _) -> return k

203203

@@ -210,14 +210,17 @@ canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of

210210 Just (_, Alias mn' i') -> (mn', i')

211211 _ -> (mn, i)

212212

213+{-

213214-- |

214215-- Canonicalize a type variable by resolving any aliases introduced by module imports

215216--

216217canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)

217218canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)

218−canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of

219− Just (_, DataAlias mn' pn') -> (mn', pn')

220− _ -> (mn, nm)

219+canonicalizeType mn env (Qualified Nothing nm) = error $ "unqualified type " ++ (show nm) ++ " in " ++ show mn

220+ {-case (mn, nm) `M.lookup` types env of

221+ Just (_, DataAlias mn' pn') -> (mn', pn')

222+ _ -> (mn, nm)-}

223+ -}

221224

222225-- |

223226-- State required for type checking:

@@ -313,17 +316,3 @@ liftUnify unify = do

313316 Right (a, ust) -> do

314317 modify $ \st' -> st' { checkNextVar = unifyNextVar ust }

315318 return (a, unifyCurrentSubstitution ust)

316−

317−-- |

318−-- Replace any unqualified names in a type with their qualified versions

319−--

320−qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d

321−qualifyAllUnqualifiedNames mn env = everywhere (mkT go)

322− where

323− go :: Type -> Type

324− go (TypeConstructor nm) = TypeConstructor $ qualify' nm

325− go (SaturatedTypeSynonym nm args) = SaturatedTypeSynonym (qualify' nm) args

326− go (ConstrainedType constraints ty) = ConstrainedType (map (first qualify') constraints) ty

327− go other = other

328− qualify' qual = let (mn', pn') = canonicalizeType mn env qual

329− in Qualified (Just mn') pn'

src/Language/PureScript/TypeChecker/Synonyms.hs+6−6

@@ -20,7 +20,7 @@ module Language.PureScript.TypeChecker.Synonyms (

2020

2121import Language.PureScript.Types

2222import Language.PureScript.Names

23−import Language.PureScript.TypeChecker.Monad (Environment(..), canonicalizeType)

23+import Language.PureScript.TypeChecker.Monad (Environment(..))

2424

2525import Data.Maybe (fromMaybe)

2626import Data.Data

@@ -32,19 +32,19 @@ import Control.Monad.Error

3232-- |

3333-- Build a type substitution for a type synonym

3434--

35−buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type)

35+buildTypeSubstitution :: Environment -> ModuleName -> (Qualified ProperName) -> Int -> Type -> Either String (Maybe Type)

3636buildTypeSubstitution env moduleName name n = go n []

3737 where

3838 go :: Int -> [Type] -> Type -> Either String (Maybe Type)

39− go 0 args (TypeConstructor ctor) | name == canonicalizeType moduleName env ctor = return (Just $ SaturatedTypeSynonym ctor args)

40− go m _ (TypeConstructor ctor) | m > 0 && name == qualify moduleName ctor = throwError $ "Partially applied type synonym " ++ show name

39+ go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)

40+ go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name

4141 go m args (TypeApp f arg) = go (m - 1) (arg:args) f

4242 go _ _ _ = return Nothing

4343

4444-- |

4545-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor

4646--

47−saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> d -> Either String d

47+saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (Qualified ProperName) -> Int -> d -> Either String d

4848saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)

4949 where

5050 replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t

@@ -52,7 +52,7 @@ saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)

5252-- |

5353-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor

5454--

55−saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((ModuleName, ProperName), Int)] -> d -> Either String d

55+saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((Qualified ProperName), Int)] -> d -> Either String d

5656saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns

5757

5858

src/Language/PureScript/TypeChecker/Types.hs+10−17

@@ -109,7 +109,7 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

109109 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do

110110 env <- getEnv

111111 Just moduleName <- checkCurrentModule <$> get

112− guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (typeConstructorsAreEqual env moduleName c1 c2)

112+ guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (c1 == c2)

113113 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

114114 t3 `unifyTypes` t5

115115 t4 `unifyTypes` t6

@@ -153,12 +153,6 @@ unifyRows r1 r2 =

153153 unifyRows' [] (Skolem s1 _) [] (Skolem s2 _) | s1 == s2 = return ()

154154 unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")."

155155

156−-- |

157−-- Ensure type constructors are equal after canonicalization

158−--

159−typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool

160−typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env

161−

162156-- |

163157-- Infer the types of multiple mutually-recursive values, and return elaborated values including

164158-- type class dictionaries and type annotations.

@@ -271,7 +265,7 @@ entails moduleName context goal@(className, tys) = do

271265 -- Choose type class dictionaries in scope in the current module

272266 , filterModule tcd

273267 -- Make sure the type class name matches the one we are trying to satisfy

274− , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)

268+ , className' == (tcdClassName tcd)

275269 -- Make sure the type unifies with the type in the type instance definition

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

277271 -- Solve any necessary subgoals

@@ -314,7 +308,7 @@ typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String

314308typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []

315309typeHeadsAreEqual _ _ (TypeVar v) t = Just [(v, t)]

316310typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]

317−typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []

311+typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

318312typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2

319313typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1

320314typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of

@@ -419,7 +413,7 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

419413 Just moduleName <- checkCurrentModule <$> get

420414 dicts <- getTypeClassDictionaries

421415 (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty

422− return (foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints)), ty')

416+ return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')

423417instantiatePolyTypeWithUnknowns val ty = return (val, ty)

424418

425419-- |

@@ -437,7 +431,7 @@ replaceVarWithUnknown ident ty = do

437431replaceAllTypeSynonyms' :: (D.Data d) => Environment -> ModuleName -> d -> Either String d

438432replaceAllTypeSynonyms' env moduleName d =

439433 let

440− syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env

434+ syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env

441435 in

442436 saturateAllTypeSynonyms env moduleName syns d

443437

@@ -461,7 +455,7 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)

461455--

462456expandTypeSynonym' :: Environment -> ModuleName -> Qualified ProperName -> [Type] -> Either String Type

463457expandTypeSynonym' env moduleName name args =

464− case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of

458+ case M.lookup name (typeSynonyms env) of

465459 Just (synArgs, body) -> do

466460 let repl = replaceAllTypeVars (zip synArgs args) body

467461 replaceAllTypeSynonyms' env moduleName repl

@@ -540,7 +534,7 @@ infer' (Var var) = do

540534 ConstrainedType constraints ty' -> do

541535 env <- getEnv

542536 dicts <- getTypeClassDictionaries

543− return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'

537+ return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'

544538 _ -> return $ TypedValue True (Var var) ty

545539infer' v@(Constructor c) = do

546540 env <- getEnv

@@ -725,8 +719,7 @@ check' val t@(ConstrainedType constraints ty) = do

725719 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

726720 val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->

727721 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)

728− (qualifyAllUnqualifiedNames moduleName env constraints)) $

729− check val ty

722+ constraints) $ check val ty

730723 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

731724check' val (SaturatedTypeSynonym name args) = do

732725 ty <- introduceSkolemScope <=< expandTypeSynonym name $ args

@@ -886,7 +879,7 @@ checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do

886879 env <- getEnv

887880 dicts <- getTypeClassDictionaries

888881 Just moduleName <- checkCurrentModule <$> get

889− checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy arg

882+ checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg

890883checkFunctionApplication' _ fnTy arg = throwError $ "Cannot apply a function of type "

891884 ++ prettyPrintType fnTy

892885 ++ " to argument " ++ prettyPrintValue arg

@@ -932,7 +925,7 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

932925 dicts <- getTypeClassDictionaries

933926 Just moduleName <- checkCurrentModule <$> get

934927 _ <- subsumes' Nothing ty1 ty2

935− return . Just $ foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))

928+ return . Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)

936929subsumes' val (Object r1) (Object r2) = do

937930 let

938931 (ts1, r1') = rowToList r1