git.iko.soy/rowtype-yoga/purescript-native
on 0c87efe help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/TypeChecker.hs
438 lines 19 kB history raw
1{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleContexts #-}
5-- |
6-- The top-level type checker, which checks all declarations in a module.
7--
8module Language.PureScript.TypeChecker (
9 module T,
10 typeCheckModule
11) where
13import Prelude ()
14import Prelude.Compat
16import Language.PureScript.TypeChecker.Monad as T
17import Language.PureScript.TypeChecker.Kinds as T
18import Language.PureScript.TypeChecker.Types as T
19import Language.PureScript.TypeChecker.Synonyms as T
21import Data.Maybe
22import Data.List (nub, (\\), sort, group)
23import Data.Foldable (for_, traverse_)
25import qualified Data.Map as M
27import Control.Monad (when, unless, void, forM, forM_)
28import Control.Monad.Supply.Class (MonadSupply)
29import Control.Monad.State.Class (MonadState(..), modify)
30import Control.Monad.Error.Class (MonadError(..))
31import Control.Monad.Writer.Class (MonadWriter(..))
33import Language.PureScript.Crash
34import Language.PureScript.Types
35import Language.PureScript.Names
36import Language.PureScript.Kinds
37import Language.PureScript.AST
38import Language.PureScript.TypeClassDictionaries
39import Language.PureScript.Environment
40import Language.PureScript.Errors
42addDataType ::
43 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
44 ModuleName ->
45 DataDeclType ->
46 ProperName ->
47 [(String, Maybe Kind)] ->
48 [(ProperName, [Type])] ->
49 Kind ->
50 m ()
51addDataType moduleName dtype name args dctors ctorKind = do
52 env <- getEnv
53 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
54 for_ dctors $ \(dctor, tys) ->
55 warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $
56 addDataConstructor moduleName dtype name (map fst args) dctor tys
58addDataConstructor ::
59 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
60 ModuleName ->
61 DataDeclType ->
62 ProperName ->
63 [String] ->
64 ProperName ->
65 [Type] ->
66 m ()
67addDataConstructor moduleName dtype name args dctor tys = do
68 env <- getEnv
69 traverse_ checkTypeSynonyms tys
70 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
71 let dctorTy = foldr function retTy tys
72 let polyType = mkForAll args dctorTy
73 let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]
74 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
76addTypeSynonym ::
77 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
78 ModuleName ->
79 ProperName ->
80 [(String, Maybe Kind)] ->
81 Type ->
82 Kind ->
83 m ()
84addTypeSynonym moduleName name args ty kind = do
85 env <- getEnv
86 checkTypeSynonyms ty
87 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
88 , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
90valueIsNotDefined ::
91 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
92 ModuleName ->
93 Ident ->
94 m ()
95valueIsNotDefined moduleName name = do
96 env <- getEnv
97 case M.lookup (moduleName, name) (names env) of
98 Just _ -> throwError . errorMessage $ RedefinedIdent name
99 Nothing -> return ()
101addValue ::
102 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
103 ModuleName ->
104 Ident ->
105 Type ->
106 NameKind ->
107 m ()
108addValue moduleName name ty nameKind = do
109 env <- getEnv
110 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
112addTypeClass ::
113 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
114 ModuleName ->
115 ProperName ->
116 [(String, Maybe Kind)] ->
117 [Constraint] ->
118 [Declaration] ->
119 m ()
120addTypeClass moduleName pn args implies ds =
121 let members = map toPair ds in
122 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
123 where
124 toPair (TypeDeclaration ident ty) = (ident, ty)
125 toPair (PositionedDeclaration _ _ d) = toPair d
126 toPair _ = internalError "Invalid declaration in TypeClassDeclaration"
128addTypeClassDictionaries ::
129 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
130 Maybe ModuleName ->
131 M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) ->
132 m ()
133addTypeClassDictionaries mn entries =
134 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }
135 where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st)
137checkDuplicateTypeArguments ::
138 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
139 [String] ->
140 m ()
141checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
142 throwError . errorMessage $ DuplicateTypeArgument dup
143 where
144 firstDup :: Maybe String
145 firstDup = listToMaybe $ args \\ nub args
147checkTypeClassInstance ::
148 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
149 ModuleName ->
150 Type ->
151 m ()
152checkTypeClassInstance _ (TypeVar _) = return ()
153checkTypeClassInstance _ (TypeConstructor ctor) = do
154 env <- getEnv
155 when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance
156 return ()
157checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
158checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty
160-- |
161-- Check that type synonyms are fully-applied in a type
162--
163checkTypeSynonyms ::
164 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
165 Type ->
166 m ()
167checkTypeSynonyms = void . replaceAllTypeSynonyms
169-- |
170-- Type check all declarations in a module
171--
172-- At this point, many declarations will have been desugared, but it is still necessary to
173--
174-- * Kind-check all types and add them to the @Environment@
175--
176-- * Type-check all values and add them to the @Environment@
177--
178-- * Bring type class instances into scope
179--
180-- * Process module imports
181--
182typeCheckAll :: forall m.
183 (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
184 ModuleName ->
185 [DeclarationRef] ->
186 [Declaration] ->
187 m [Declaration]
188typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
189 where
190 go :: Declaration -> m Declaration
191 go (DataDeclaration dtype name args dctors) = do
192 warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do
193 when (dtype == Newtype) $ checkNewtype dctors
194 checkDuplicateTypeArguments $ map fst args
195 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
196 let args' = args `withKinds` ctorKind
197 addDataType moduleName dtype name args' dctors ctorKind
198 return $ DataDeclaration dtype name args dctors
199 where
200 checkNewtype :: [(ProperName, [Type])] -> m ()
201 checkNewtype [(_, [_])] = return ()
202 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name
203 checkNewtype _ = throwError . errorMessage $ InvalidNewtype name
204 go (d@(DataBindingGroupDeclaration tys)) = do
205 warnAndRethrow (addHint ErrorInDataBindingGroup) $ do
206 let syns = mapMaybe toTypeSynonym tys
207 let dataDecls = mapMaybe toDataDecl tys
208 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
209 for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
210 checkDuplicateTypeArguments $ map fst args
211 let args' = args `withKinds` ctorKind
212 addDataType moduleName dtype name args' dctors ctorKind
213 for_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
214 checkDuplicateTypeArguments $ map fst args
215 let args' = args `withKinds` kind
216 addTypeSynonym moduleName name args' ty kind
217 return d
218 where
219 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
220 toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'
221 toTypeSynonym _ = Nothing
222 toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
223 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
224 toDataDecl _ = Nothing
225 go (TypeSynonymDeclaration name args ty) = do
226 warnAndRethrow (addHint (ErrorInTypeSynonym name)) $ do
227 checkDuplicateTypeArguments $ map fst args
228 kind <- kindsOf False moduleName name args [ty]
229 let args' = args `withKinds` kind
230 addTypeSynonym moduleName name args' ty kind
231 return $ TypeSynonymDeclaration name args ty
232 go (TypeDeclaration{}) = internalError "Type declarations should have been removed"
233 go (ValueDeclaration name nameKind [] (Right val)) =
234 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do
235 valueIsNotDefined moduleName name
236 [(_, (val', ty))] <- typesOf moduleName [(name, val)]
237 addValue moduleName name ty nameKind
238 return $ ValueDeclaration name nameKind [] $ Right val'
239 go (ValueDeclaration{}) = internalError "Binders were not desugared"
240 go (BindingGroupDeclaration vals) =
241 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
242 for_ (map (\(ident, _, _) -> ident) vals) $ \name ->
243 valueIsNotDefined moduleName name
244 tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
245 vals' <- forM [ (name, val, nameKind, ty)
246 | (name, nameKind, _) <- vals
247 , (name', (val, ty)) <- tys
248 , name == name'
249 ] $ \(name, val, nameKind, ty) -> do
250 addValue moduleName name ty nameKind
251 return (name, nameKind, val)
252 return $ BindingGroupDeclaration vals'
253 go (d@(ExternDataDeclaration name kind)) = do
254 env <- getEnv
255 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
256 return d
257 go (d@(ExternDeclaration name ty)) = do
258 warnAndRethrow (addHint (ErrorInForeignImport name)) $ do
259 env <- getEnv
260 kind <- kindOf ty
261 guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star
262 case M.lookup (moduleName, name) (names env) of
263 Just _ -> throwError . errorMessage $ RedefinedIdent name
264 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
265 return d
266 go (d@(FixityDeclaration{})) = return d
267 go (d@(ImportDeclaration{})) = return d
268 go (d@(TypeClassDeclaration pn args implies tys)) = do
269 addTypeClass moduleName pn args implies tys
270 return d
271 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do
272 traverse_ (checkTypeClassInstance moduleName) tys
273 forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . snd
274 checkOrphanInstance dictName className tys
275 _ <- traverseTypeInstanceBody checkInstanceMembers body
276 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)
277 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict
278 return d
279 go (PositionedDeclaration pos com d) =
280 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
282 checkFixities :: Declaration -> m ()
283 checkFixities (FixityDeclaration _ name (Just alias)) = do
284 ty <- lookupVariable moduleName (Qualified (Just moduleName) alias)
285 addValue moduleName (Op name) ty Public
286 checkFixities (FixityDeclaration _ name _) = do
287 env <- getEnv
288 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
289 checkFixities (PositionedDeclaration pos _ d) =
290 warnAndRethrowWithPosition pos $ checkFixities d
291 checkFixities _ = return ()
293 checkInstanceMembers :: [Declaration] -> m [Declaration]
294 checkInstanceMembers instDecls = do
295 let idents = sort . map head . group . map memberName $ instDecls
296 for_ (firstDuplicate idents) $ \ident ->
297 throwError . errorMessage $ DuplicateValueDeclaration ident
298 return instDecls
299 where
300 memberName :: Declaration -> Ident
301 memberName (ValueDeclaration ident _ _ _) = ident
302 memberName (PositionedDeclaration _ _ d) = memberName d
303 memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition"
305 firstDuplicate :: (Eq a) => [a] -> Maybe a
306 firstDuplicate (x : xs@(y : _))
307 | x == y = Just x
308 | otherwise = firstDuplicate xs
309 firstDuplicate _ = Nothing
311 checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m ()
312 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'
313 | moduleName == mn' || any checkType tys' = return ()
314 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
315 where
316 checkType :: Type -> Bool
317 checkType (TypeVar _) = False
318 checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''
319 checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"
320 checkType (TypeApp t1 _) = checkType t1
321 checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
322 checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
324 -- |
325 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
326 -- extracted from the kind of the type constructor itself.
327 --
328 withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]
329 withKinds [] _ = []
330 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k
331 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
332 withKinds _ _ = internalError "Invalid arguments to peelKinds"
334-- |
335-- Type check an entire module and ensure all types and classes defined within the module that are
336-- required by exported members are also exported.
337--
338typeCheckModule :: forall m.
339 (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
340 Module ->
341 m Module
342typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"
343typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do
344 modify (\s -> s { checkCurrentModule = Just mn })
345 decls' <- typeCheckAll mn exps decls
346 for_ exps $ \e -> do
347 checkTypesAreExported e
348 checkClassMembersAreExported e
349 checkClassesAreExported e
350 checkNonAliasesAreExported e
351 return $ Module ss coms mn decls' (Just exps)
352 where
354 checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m ()
355 checkMemberExport extract dr@(TypeRef name dctors) = do
356 env <- getEnv
357 case M.lookup (Qualified (Just mn) name) (typeSynonyms env) of
358 Nothing -> return ()
359 Just (_, ty) -> checkExport dr extract ty
360 case dctors of
361 Nothing -> return ()
362 Just dctors' -> for_ dctors' $ \dctor ->
363 case M.lookup (Qualified (Just mn) dctor) (dataConstructors env) of
364 Nothing -> return ()
365 Just (_, _, ty, _) -> checkExport dr extract ty
366 return ()
367 checkMemberExport extract dr@(ValueRef name) = do
368 ty <- lookupVariable mn (Qualified (Just mn) name)
369 checkExport dr extract ty
370 checkMemberExport _ _ = return ()
372 checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m ()
373 checkExport dr extract ty = case filter (not . exported) (extract ty) of
374 [] -> return ()
375 hidden -> throwError . errorMessage $ TransitiveExportError dr hidden
376 where
377 exported e = any (exports e) exps
378 exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
379 exports (ValueRef id1) (ValueRef id2) = id1 == id2
380 exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2
381 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
382 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
383 exports _ _ = False
385 -- Check that all the type constructors defined in the current module that appear in member types
386 -- have also been exported from the module
387 checkTypesAreExported :: DeclarationRef -> m ()
388 checkTypesAreExported = checkMemberExport findTcons
389 where
390 findTcons :: Type -> [DeclarationRef]
391 findTcons = everythingOnTypes (++) go
392 where
393 go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (internalError "Data constructors unused in checkTypesAreExported")]
394 go _ = []
396 -- Check that all the classes defined in the current module that appear in member types have also
397 -- been exported from the module
398 checkClassesAreExported :: DeclarationRef -> m ()
399 checkClassesAreExported = checkMemberExport findClasses
400 where
401 findClasses :: Type -> [DeclarationRef]
402 findClasses = everythingOnTypes (++) go
403 where
404 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs
405 go _ = []
406 extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
407 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
408 extractCurrentModuleClass _ = Nothing
410 checkClassMembersAreExported :: DeclarationRef -> m ()
411 checkClassMembersAreExported dr@(TypeClassRef name) = do
412 let members = ValueRef `map` head (mapMaybe findClassMembers decls)
413 let missingMembers = members \\ exps
414 unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
415 where
416 findClassMembers :: Declaration -> Maybe [Ident]
417 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
418 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
419 findClassMembers _ = Nothing
420 extractMemberName :: Declaration -> Ident
421 extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d
422 extractMemberName (TypeDeclaration memberName _) = memberName
423 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"
424 checkClassMembersAreExported _ = return ()
426 checkNonAliasesAreExported :: DeclarationRef -> m ()
427 checkNonAliasesAreExported dr@(ValueRef (Op name)) =
428 case listToMaybe (mapMaybe getAlias decls) of
429 Just alias ->
430 when (not $ any (== ValueRef alias) exps) $
431 throwError . errorMessage $ TransitiveExportError dr [ValueRef alias]
432 _ -> return ()
433 where
434 getAlias :: Declaration -> Maybe Ident
435 getAlias (PositionedDeclaration _ _ d) = getAlias d
436 getAlias (FixityDeclaration _ name' alias) | name == name' = alias
437 getAlias _ = Nothing
438 checkNonAliasesAreExported _ = return ()