git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Type renaming mostly working
52796aeGary Burgess
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
42 (ty, _) <- M.lookup (path, name) $ names env
43 return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
43 return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
44declToPs path env (DataDeclaration name _ _) = maybeToList $ do
44declToPs path env (DataDeclaration name _ _) = maybeToList $ do
45− (kind, _) <- M.lookup (path, name) $ types env
45+ (kind, _) <- M.lookup (Qualified (Just path) name) $ types env
46 return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
46 return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
47declToPs _ _ (ExternDataDeclaration name kind) =
47declToPs _ _ (ExternDataDeclaration name kind) =
48 return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
48 return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
src/Language/PureScript/Sugar/Names.hs+26−20
@@ -28,16 +28,21 @@ import Language.PureScript.Values
28import Debug.Trace
28import Debug.Trace
29
29
30data ExportEnvironment = ExportEnvironment
30data ExportEnvironment = ExportEnvironment
31+ { exportedTypes :: M.Map ModuleName (S.Set ProperName)
31− { exportedDataConstructors :: M.Map ModuleName (S.Set ProperName)
32+ , exportedDataConstructors :: M.Map ModuleName (S.Set ProperName)
32 , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)
33 , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)
33 } deriving (Show)
34 } deriving (Show)
34
35
35data ImportEnvironment = ImportEnvironment
36data ImportEnvironment = ImportEnvironment
37+ { importedTypes :: M.Map ProperName (Qualified ProperName)
36− { importedDataConstructors :: M.Map ProperName (Qualified ProperName)
38+ , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
37 , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
39 , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
38 } deriving (Show)
40 } deriving (Show)
39
41
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) }
41
46
42addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment
47addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> ExportEnvironment
43addDataConstructor env mn id = env { exportedDataConstructors = M.insertWith S.union mn (S.singleton id) (exportedDataConstructors env) }
48addDataConstructor env mn id = env { exportedDataConstructors = M.insertWith S.union mn (S.singleton id) (exportedDataConstructors env) }
@@ -62,35 +67,35 @@ renameInModule imports (Module mn decls) =
62 cs' <- updateConstraints cs
67 cs' <- updateConstraints cs
63 return $ TypeInstanceDeclaration cs' cn' ts ds
68 return $ TypeInstanceDeclaration cs' cn' ts ds
64 updateDecl d = return d
69 updateDecl d = return d
65− updateValue (Constructor (Qualified Nothing nm)) = do
70+ updateValue (Constructor (Qualified Nothing nm)) = updateDataConstructorName nm >>= return . Constructor
66− nm' <- updateDataConstructorName nm
67− return $ Constructor nm'
68 updateValue v = return v
71 updateValue v = return v
69− updateBinder (ConstructorBinder (Qualified Nothing nm) b) = do
72+ updateBinder (ConstructorBinder (Qualified Nothing nm) b) = updateDataConstructorName nm >>= return . (`ConstructorBinder` b)
70− nm' <- updateDataConstructorName nm
71− return $ ConstructorBinder nm' b
72 updateBinder v = return v
73 updateBinder v = return v
73− updateType (ConstrainedType cs t) = do
74+ updateType (TypeConstructor (Qualified Nothing nm)) = updateTypeName nm >>= return . TypeConstructor
74− cs' <- updateConstraints cs
75+ updateType (SaturatedTypeSynonym (Qualified Nothing nm) tys) = do
75− return $ ConstrainedType cs' t
76+ nm' <- updateTypeName nm
77+ tys' <- mapM updateType tys
78+ return $ SaturatedTypeSynonym nm' tys'
79+ updateType (ConstrainedType cs t) = updateConstraints cs >>= return . (`ConstrainedType` t)
76 updateType t = return t
80 updateType t = return t
77 updateConstraints = mapM updateConstraint
81 updateConstraints = mapM updateConstraint
78 updateConstraint (Qualified Nothing nm, ts) = do
82 updateConstraint (Qualified Nothing nm, ts) = do
79 nm' <- updateClassName nm
83 nm' <- updateClassName nm
80 return (nm', ts)
84 return (nm', ts)
81 updateConstraint other = return other
85 updateConstraint other = return other
82− updateClassName nm =
86+ updateTypeName = update "type" importedTypes
83− maybe (err "typeclass" nm mn) return $ M.lookup nm (importedTypeClasses imports)
87+ updateClassName = update "typeclass" importedTypeClasses
84− updateDataConstructorName nm =
85− maybe (err "data constructor" nm mn) return $ M.lookup nm (importedDataConstructors imports)
88+ updateDataConstructorName = update "data constructor" importedDataConstructors
86− err t nm mn = Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'"
89+ update t get nm = maybe (Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'") return $ M.lookup nm (get imports)
87−
90+
88findExports :: [Module] -> ExportEnvironment
91findExports :: [Module] -> ExportEnvironment
89findExports = foldl addModule nullEnv
92findExports = foldl addModule nullEnv
90 where
93 where
91 addModule env (Module mn ds) = foldl (addDecl mn) env ds
94 addModule env (Module mn ds) = foldl (addDecl mn) env ds
92 addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn
95 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
94 addDecl _ env _ = env
99 addDecl _ env _ = env
95
100
96findImports :: [Declaration] -> [ModuleName]
101findImports :: [Declaration] -> [ModuleName]
@@ -98,9 +103,10 @@ findImports decls = [ mn | (ImportDeclaration mn Nothing) <- decls ]
98
103
99resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
104resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
100resolveImports env (Module currentModule decls) = do
105resolveImports env (Module currentModule decls) = do
106+ types <- resolve exportedTypes
101 dataConstructors <- resolve exportedDataConstructors
107 dataConstructors <- resolve exportedDataConstructors
102 typeClasses <- resolve exportedTypeClasses
108 typeClasses <- resolve exportedTypeClasses
103− return $ ImportEnvironment dataConstructors typeClasses
109+ return $ ImportEnvironment types dataConstructors typeClasses
104 where
110 where
105 scope = currentModule : findImports decls
111 scope = currentModule : findImports decls
106 resolve get = foldM resolveDefs M.empty (M.toList $ get env)
112 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]
92desugarDecl mn d@(TypeClassDeclaration name args members) = do
92desugarDecl mn d@(TypeClassDeclaration name args members) = do
93 let tys = map memberToNameAndType members
93 let tys = map memberToNameAndType members
94 modify (M.insert (mn, name) (args, tys))
94 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
96desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do
96desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do
97 desugared <- lift $ desugarCases members
97 desugared <- lift $ desugarCases members
98 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared
98 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared
@@ -108,12 +108,12 @@ typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Dec
108typeClassDictionaryDeclaration name args members =
108typeClassDictionaryDeclaration name args members =
109 TypeSynonymDeclaration name args (Object $ rowFromList (map memberToNameAndType members, REmpty))
109 TypeSynonymDeclaration name args (Object $ rowFromList (map memberToNameAndType members, REmpty))
110
110
111−typeClassMemberToDictionaryAccessor :: ProperName -> [String] -> Declaration -> Declaration
111+typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
112−typeClassMemberToDictionaryAccessor name args (TypeDeclaration ident ty) =
112+typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
113 ExternDeclaration TypeClassAccessorImport ident
113 ExternDeclaration TypeClassAccessorImport ident
114 (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))
114 (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))
115− (quantify (ConstrainedType [(Qualified Nothing name, map TypeVar args)] ty))
115+ (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))
116−typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
116+typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
117
117
118typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
118typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
119typeInstanceDictionaryDeclaration mn deps name tys decls = do
119typeInstanceDictionaryDeclaration mn deps name tys decls = do
@@ -155,9 +155,10 @@ typeInstanceDictionaryEntryDeclaration mn deps name tys (ValueDeclaration ident
155 lookupIdent members = maybe (Left $ "Type class " ++ show name ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members
155 lookupIdent members = maybe (Left $ "Type class " ++ show name ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members
156typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"
156typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"
157
157
158+
158qualifiedToString :: ModuleName -> Qualified ProperName -> String
159qualifiedToString :: 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+
161
162
162-- |
163-- |
163-- Generate a name for a type class dictionary, based on the module name, class name and type name
164-- 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
41addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
41addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
42addDataType moduleName name args dctors ctorKind = do
42addDataType moduleName name args dctors ctorKind = do
43 env <- getEnv
43 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) }
45 forM_ dctors $ \(dctor, tys) ->
45 forM_ dctors $ \(dctor, tys) ->
46 rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $
46 rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $
47 addDataConstructor moduleName name args dctor tys
47 addDataConstructor moduleName name args dctor tys
@@ -52,19 +52,19 @@ addDataConstructor moduleName name args dctor tys = do
52 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
52 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
53 let dctorTy = foldr function retTy tys
53 let dctorTy = foldr function retTy tys
54 let polyType = mkForAll args dctorTy
54 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) }
56
56
57addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
57addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
58addTypeSynonym moduleName name args ty kind = do
58addTypeSynonym moduleName name args ty kind = do
59 env <- getEnv
59 env <- getEnv
60− putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env)
60+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
61− , typeSynonyms = M.insert (moduleName, name) (args, qualifyAllUnqualifiedNames moduleName env ty) (typeSynonyms env) }
61+ , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
62
62
63typeIsNotDefined :: ModuleName -> ProperName -> Check ()
63typeIsNotDefined :: ModuleName -> ProperName -> Check ()
64typeIsNotDefined moduleName name = do
64typeIsNotDefined moduleName name = do
65 env <- getEnv
65 env <- getEnv
66 guardWith (show name ++ " is already defined") $
66 guardWith (show name ++ " is already defined") $
67− not $ M.member (moduleName, name) (types env)
67+ not $ M.member (Qualified (Just moduleName) name) (types env)
68
68
69valueIsNotDefined :: ModuleName -> Ident -> Check ()
69valueIsNotDefined :: ModuleName -> Ident -> Check ()
70valueIsNotDefined moduleName name = do
70valueIsNotDefined moduleName name = do
@@ -76,7 +76,7 @@ valueIsNotDefined moduleName name = do
76addValue :: ModuleName -> Ident -> Type -> Check ()
76addValue :: ModuleName -> Ident -> Type -> Check ()
77addValue moduleName name ty = do
77addValue moduleName name ty = do
78 env <- getEnv
78 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) })
80
80
81addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
81addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
82addTypeClassDictionaries entries =
82addTypeClassDictionaries entries =
@@ -86,7 +86,7 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()
86checkTypeClassInstance _ (TypeVar _) = return ()
86checkTypeClassInstance _ (TypeVar _) = return ()
87checkTypeClassInstance m (TypeConstructor ctor) = do
87checkTypeClassInstance m (TypeConstructor ctor) = do
88 env <- getEnv
88 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"
90 return ()
90 return ()
91checkTypeClassInstance m (TypeApp ty (TypeVar _)) = checkTypeClassInstance m ty
91checkTypeClassInstance m (TypeApp ty (TypeVar _)) = checkTypeClassInstance m ty
92checkTypeClassInstance _ _ = throwError "Type class instance must be of the form T a1 ... an"
92checkTypeClassInstance _ _ = throwError "Type class instance must be of the form T a1 ... an"
@@ -161,8 +161,8 @@ typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = d
161 return $ d : ds
161 return $ d : ds
162typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do
162typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do
163 env <- getEnv
163 env <- getEnv
164− guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)
164+ guardWith (show name ++ " is already defined") $ not $ M.member (Qualified (Just moduleName) name) (types env)
165− putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }
165+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env) }
166 ds <- typeCheckAll mainModuleName moduleName rest
166 ds <- typeCheckAll mainModuleName moduleName rest
167 return $ d : ds
167 return $ d : ds
168typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
168typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
@@ -172,7 +172,7 @@ typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty)
172 guardWith "Expected kind *" $ kind == Star
172 guardWith "Expected kind *" $ kind == Star
173 case M.lookup (moduleName, name) (names env) of
173 case M.lookup (moduleName, name) (names env) of
174 Just _ -> throwError $ show name ++ " is already defined"
174 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) })
176 ds <- typeCheckAll mainModuleName moduleName rest
176 ds <- typeCheckAll mainModuleName moduleName rest
177 return $ d : ds
177 return $ d : ds
178typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do
178typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do
@@ -187,7 +187,7 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident
187 case idents of
187 case idents of
188 Nothing -> do
188 Nothing -> do
189 shadowIdents (map snd $ filterModule (names env)) env
189 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
191 Just idents' -> do
191 Just idents' -> do
192 shadowIdents (lefts idents') env
192 shadowIdents (lefts idents') env
193 shadowTypes (rights idents') env
193 shadowTypes (rights idents') env
@@ -197,7 +197,8 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident
197 where
197 where
198 errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
198 errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
199 filterModule = filter ((== moduleName) . fst) . M.keys
199 filterModule = filter ((== moduleName) . fst) . M.keys
200+ filterModuleQ = filter (\(Qualified (Just mn) _) -> mn == moduleName) . M.keys
200− moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
201+ moduleExists env = not (null (filterModule (names env))) || not (null (filterModuleQ (types env)))
201 shadowIdents idents' env =
202 shadowIdents idents' env =
202 forM_ idents' $ \ident ->
203 forM_ idents' $ \ident ->
203 case (moduleName, ident) `M.lookup` names env of
204 case (moduleName, ident) `M.lookup` names env of
@@ -208,12 +209,12 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident
208 Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
209 Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
209 shadowTypes pns env =
210 shadowTypes pns env =
210 forM_ pns $ \pn ->
211 forM_ pns $ \pn ->
211− case (moduleName, pn) `M.lookup` types env of
212+ case (Qualified (Just moduleName) pn) `M.lookup` types env of
212 Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
213 Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
213 Just (_, DataAlias _ _) -> return ()
214 Just (_, DataAlias _ _) -> return ()
214 Just (k, _) -> do
215 Just (k, _) -> do
215− guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
216+ guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (Qualified (Just currentModule) pn) `M.notMember` types env
216− modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
217+ modifyEnv (\e -> e { types = M.insert (Qualified (Just currentModule) pn) (k, DataAlias moduleName pn) (types e) })
217 let keys = map fst . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env
218 let keys = map fst . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env
218 forM_ keys $ \dctor ->
219 forM_ keys $ \dctor ->
219 case dctor `M.lookup` dataConstructors env of
220 case dctor `M.lookup` dataConstructors env of
@@ -237,13 +238,12 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident
237typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do
238typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do
238 env <- getEnv
239 env <- getEnv
239 ds <- typeCheckAll mainModuleName moduleName rest
240 ds <- typeCheckAll mainModuleName moduleName rest
240− return $ qualifyAllUnqualifiedNames moduleName env d : ds
241+ return $ d : ds
241typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className tys _) : rest) = do
242typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className tys _) : rest) = do
242 env <- getEnv
243 env <- getEnv
243 dictName <- Check . lift $ mkDictionaryValueName moduleName className tys
244 dictName <- Check . lift $ mkDictionaryValueName moduleName className tys
244 mapM_ (checkTypeClassInstance moduleName) tys
245 mapM_ (checkTypeClassInstance moduleName) tys
245 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
246 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]
248 ds <- typeCheckAll mainModuleName moduleName rest
248 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
133infer (TypeConstructor v) = do
133infer (TypeConstructor v) = do
134 env <- liftCheck getEnv
134 env <- liftCheck getEnv
135 Just moduleName <- checkCurrentModule <$> get
135 Just moduleName <- checkCurrentModule <$> get
136− case M.lookup (qualify moduleName v) (types env) of
136+ case M.lookup v (types env) of
137− Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'"
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
139infer (TypeApp t1 t2) = do
140 k0 <- fresh
140 k0 <- fresh
src/Language/PureScript/TypeChecker/Monad.hs+17−28
@@ -97,7 +97,7 @@ data Environment = Environment {
97 -- |
97 -- |
98 -- Type names currently in scope
98 -- Type names currently in scope
99 --
99 --
100− , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
100+ , types :: M.Map (Qualified ProperName) (Kind, TypeDeclarationKind)
101 -- |
101 -- |
102 -- Data constructors currently in scope, along with their associated data type constructors
102 -- Data constructors currently in scope, along with their associated data type constructors
103 --
103 --
@@ -105,7 +105,7 @@ data Environment = Environment {
105 -- |
105 -- |
106 -- Type synonyms currently in scope
106 -- Type synonyms currently in scope
107 --
107 --
108− , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)
108+ , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)
109 -- |
109 -- |
110 -- Available type class dictionaries
110 -- Available type class dictionaries
111 --
111 --
@@ -115,12 +115,12 @@ data Environment = Environment {
115-- |
115-- |
116-- The basic types existing in the external javascript environment
116-- The basic types existing in the external javascript environment
117--
117--
118−jsTypes ::M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
118+jsTypes ::M.Map (Qualified ProperName) (Kind, TypeDeclarationKind)
119−jsTypes = M.fromList [ ((ModuleName [ProperName "Prim"], ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))
119+jsTypes = M.fromList [ (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))
120− , ((ModuleName [ProperName "Prim"], ProperName "Array"), (FunKind Star Star, ExternData))
120+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array"), (FunKind Star Star, ExternData))
121− , ((ModuleName [ProperName "Prim"], ProperName "String"), (Star, ExternData))
121+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "String"), (Star, ExternData))
122− , ((ModuleName [ProperName "Prim"], ProperName "Number"), (Star, ExternData))
122+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Number"), (Star, ExternData))
123− , ((ModuleName [ProperName "Prim"], ProperName "Boolean"), (Star, ExternData)) ]
123+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean"), (Star, ExternData)) ]
124
124
125-- |
125-- |
126-- The initial environment with no values and only the default javascript types defined
126-- The initial environment with no values and only the default javascript types defined
@@ -142,7 +142,7 @@ bindNames newNames action = do
142-- |
142-- |
143-- Temporarily bind a collection of names to types
143-- Temporarily bind a collection of names to types
144--
144--
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
146bindTypes newNames action = do
146bindTypes newNames action = do
147 orig <- get
147 orig <- get
148 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
148 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
@@ -179,7 +179,7 @@ bindLocalVariables moduleName bindings =
179--
179--
180bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
180bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
181bindLocalTypeVariables moduleName bindings =
181bindLocalTypeVariables 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)))
183
183
184-- |
184-- |
185-- Lookup the type of a value by name in the @Environment@
185-- Lookup the type of a value by name in the @Environment@
@@ -197,7 +197,7 @@ lookupVariable currentModule (Qualified moduleName var) = do
197lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind
197lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind
198lookupTypeVariable currentModule (Qualified moduleName name) = do
198lookupTypeVariable currentModule (Qualified moduleName name) = do
199 env <- getEnv
199 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
201 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
201 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
202 Just (k, _) -> return k
202 Just (k, _) -> return k
203
203
@@ -210,14 +210,17 @@ canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of
210 Just (_, Alias mn' i') -> (mn', i')
210 Just (_, Alias mn' i') -> (mn', i')
211 _ -> (mn, i)
211 _ -> (mn, i)
212
212
213+{-
213-- |
214-- |
214-- Canonicalize a type variable by resolving any aliases introduced by module imports
215-- Canonicalize a type variable by resolving any aliases introduced by module imports
215--
216--
216canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)
217canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)
217canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)
218canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)
218−canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of
219+canonicalizeType mn env (Qualified Nothing nm) = error $ "unqualified type " ++ (show nm) ++ " in " ++ show mn
220+ {-case (mn, nm) `M.lookup` types env of
219− Just (_, DataAlias mn' pn') -> (mn', pn')
221+ Just (_, DataAlias mn' pn') -> (mn', pn')
220− _ -> (mn, nm)
222+ _ -> (mn, nm)-}
223+ -}
221
224
222-- |
225-- |
223-- State required for type checking:
226-- State required for type checking:
@@ -313,17 +316,3 @@ liftUnify unify = do
313 Right (a, ust) -> do
316 Right (a, ust) -> do
314 modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
317 modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
315 return (a, unifyCurrentSubstitution ust)
318 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 (
20
20
21import Language.PureScript.Types
21import Language.PureScript.Types
22import Language.PureScript.Names
22import Language.PureScript.Names
23−import Language.PureScript.TypeChecker.Monad (Environment(..), canonicalizeType)
23+import Language.PureScript.TypeChecker.Monad (Environment(..))
24
24
25import Data.Maybe (fromMaybe)
25import Data.Maybe (fromMaybe)
26import Data.Data
26import Data.Data
@@ -32,19 +32,19 @@ import Control.Monad.Error
32-- |
32-- |
33-- Build a type substitution for a type synonym
33-- Build a type substitution for a type synonym
34--
34--
35−buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type)
35+buildTypeSubstitution :: Environment -> ModuleName -> (Qualified ProperName) -> Int -> Type -> Either String (Maybe Type)
36buildTypeSubstitution env moduleName name n = go n []
36buildTypeSubstitution env moduleName name n = go n []
37 where
37 where
38 go :: Int -> [Type] -> Type -> Either String (Maybe Type)
38 go :: Int -> [Type] -> Type -> Either String (Maybe Type)
39− go 0 args (TypeConstructor ctor) | name == canonicalizeType moduleName env ctor = return (Just $ SaturatedTypeSynonym ctor args)
39+ go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)
40− go m _ (TypeConstructor ctor) | m > 0 && name == qualify moduleName ctor = throwError $ "Partially applied type synonym " ++ show name
40+ go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
41 go m args (TypeApp f arg) = go (m - 1) (arg:args) f
41 go m args (TypeApp f arg) = go (m - 1) (arg:args) f
42 go _ _ _ = return Nothing
42 go _ _ _ = return Nothing
43
43
44-- |
44-- |
45-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor
45-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor
46--
46--
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
48saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)
48saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)
49 where
49 where
50 replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t
50 replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t
@@ -52,7 +52,7 @@ saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)
52-- |
52-- |
53-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
53-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
54--
54--
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
56saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns
56saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns
57
57
58
58
src/Language/PureScript/TypeChecker/Types.hs+10−17
@@ -109,7 +109,7 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
109 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
109 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
110 env <- getEnv
110 env <- getEnv
111 Just moduleName <- checkCurrentModule <$> get
111 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)
113 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
113 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
114 t3 `unifyTypes` t5
114 t3 `unifyTypes` t5
115 t4 `unifyTypes` t6
115 t4 `unifyTypes` t6
@@ -153,12 +153,6 @@ unifyRows r1 r2 =
153 unifyRows' [] (Skolem s1 _) [] (Skolem s2 _) | s1 == s2 = return ()
153 unifyRows' [] (Skolem s1 _) [] (Skolem s2 _) | s1 == s2 = return ()
154 unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")."
154 unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")."
155
155
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−
162-- |
156-- |
163-- Infer the types of multiple mutually-recursive values, and return elaborated values including
157-- Infer the types of multiple mutually-recursive values, and return elaborated values including
164-- type class dictionaries and type annotations.
158-- type class dictionaries and type annotations.
@@ -271,7 +265,7 @@ entails moduleName context goal@(className, tys) = do
271 -- Choose type class dictionaries in scope in the current module
265 -- Choose type class dictionaries in scope in the current module
272 , filterModule tcd
266 , filterModule tcd
273 -- Make sure the type class name matches the one we are trying to satisfy
267 -- 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)
275 -- Make sure the type unifies with the type in the type instance definition
269 -- Make sure the type unifies with the type in the type instance definition
276 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
270 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
277 -- Solve any necessary subgoals
271 -- Solve any necessary subgoals
@@ -314,7 +308,7 @@ typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String
314typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []
308typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []
315typeHeadsAreEqual _ _ (TypeVar v) t = Just [(v, t)]
309typeHeadsAreEqual _ _ (TypeVar v) t = Just [(v, t)]
316typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
310typeHeadsAreEqual _ _ 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 []
318typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
312typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
319typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
313typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
320typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of
314typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of
@@ -419,7 +413,7 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
419 Just moduleName <- checkCurrentModule <$> get
413 Just moduleName <- checkCurrentModule <$> get
420 dicts <- getTypeClassDictionaries
414 dicts <- getTypeClassDictionaries
421 (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty
415 (_, 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')
423instantiatePolyTypeWithUnknowns val ty = return (val, ty)
417instantiatePolyTypeWithUnknowns val ty = return (val, ty)
424
418
425-- |
419-- |
@@ -437,7 +431,7 @@ replaceVarWithUnknown ident ty = do
437replaceAllTypeSynonyms' :: (D.Data d) => Environment -> ModuleName -> d -> Either String d
431replaceAllTypeSynonyms' :: (D.Data d) => Environment -> ModuleName -> d -> Either String d
438replaceAllTypeSynonyms' env moduleName d =
432replaceAllTypeSynonyms' env moduleName d =
439 let
433 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
441 in
435 in
442 saturateAllTypeSynonyms env moduleName syns d
436 saturateAllTypeSynonyms env moduleName syns d
443
437
@@ -461,7 +455,7 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
461--
455--
462expandTypeSynonym' :: Environment -> ModuleName -> Qualified ProperName -> [Type] -> Either String Type
456expandTypeSynonym' :: Environment -> ModuleName -> Qualified ProperName -> [Type] -> Either String Type
463expandTypeSynonym' env moduleName name args =
457expandTypeSynonym' env moduleName name args =
464− case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of
458+ case M.lookup name (typeSynonyms env) of
465 Just (synArgs, body) -> do
459 Just (synArgs, body) -> do
466 let repl = replaceAllTypeVars (zip synArgs args) body
460 let repl = replaceAllTypeVars (zip synArgs args) body
467 replaceAllTypeSynonyms' env moduleName repl
461 replaceAllTypeSynonyms' env moduleName repl
@@ -540,7 +534,7 @@ infer' (Var var) = do
540 ConstrainedType constraints ty' -> do
534 ConstrainedType constraints ty' -> do
541 env <- getEnv
535 env <- getEnv
542 dicts <- getTypeClassDictionaries
536 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'
544 _ -> return $ TypedValue True (Var var) ty
538 _ -> return $ TypedValue True (Var var) ty
545infer' v@(Constructor c) = do
539infer' v@(Constructor c) = do
546 env <- getEnv
540 env <- getEnv
@@ -725,8 +719,7 @@ check' val t@(ConstrainedType constraints ty) = do
725 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
719 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
726 val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
720 val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
727 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
721 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
728− (qualifyAllUnqualifiedNames moduleName env constraints)) $
729− check val ty
722+ constraints) $ check val ty
730 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
723 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
731check' val (SaturatedTypeSynonym name args) = do
724check' val (SaturatedTypeSynonym name args) = do
732 ty <- introduceSkolemScope <=< expandTypeSynonym name $ args
725 ty <- introduceSkolemScope <=< expandTypeSynonym name $ args
@@ -886,7 +879,7 @@ checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do
886 env <- getEnv
879 env <- getEnv
887 dicts <- getTypeClassDictionaries
880 dicts <- getTypeClassDictionaries
888 Just moduleName <- checkCurrentModule <$> get
881 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
890checkFunctionApplication' _ fnTy arg = throwError $ "Cannot apply a function of type "
883checkFunctionApplication' _ fnTy arg = throwError $ "Cannot apply a function of type "
891 ++ prettyPrintType fnTy
884 ++ prettyPrintType fnTy
892 ++ " to argument " ++ prettyPrintValue arg
885 ++ " to argument " ++ prettyPrintValue arg
@@ -932,7 +925,7 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
932 dicts <- getTypeClassDictionaries
925 dicts <- getTypeClassDictionaries
933 Just moduleName <- checkCurrentModule <$> get
926 Just moduleName <- checkCurrentModule <$> get
934 _ <- subsumes' Nothing ty1 ty2
927 _ <- 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)
936subsumes' val (Object r1) (Object r2) = do
929subsumes' val (Object r1) (Object r2) = do
937 let
930 let
938 (ts1, r1') = rowToList r1
931 (ts1, r1') = rowToList r1