git.iko.soy/rowtype-yoga/purescript-native
on c996313 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/TypeChecker.hs
462 lines 20 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, nubBy, (\\), 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.AST
34import Language.PureScript.Crash
35import Language.PureScript.Environment
36import Language.PureScript.Errors
37import Language.PureScript.Kinds
38import Language.PureScript.Names
39import Language.PureScript.TypeClassDictionaries
40import Language.PureScript.Types
42addDataType
43 :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
44 => ModuleName
45 -> DataDeclType
46 -> ProperName 'TypeName
47 -> [(String, Maybe Kind)]
48 -> [(ProperName 'ConstructorName, [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 :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
60 => ModuleName
61 -> DataDeclType
62 -> ProperName 'TypeName
63 -> [String]
64 -> ProperName 'ConstructorName
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 :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
78 => ModuleName
79 -> ProperName 'TypeName
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 :: (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 :: (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 :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
114 => ModuleName
115 -> ProperName 'ClassName
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 :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
130 => Maybe ModuleName
131 -> M.Map (Qualified (ProperName 'ClassName)) (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 :: (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 :: (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 :: (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
183 :: forall m
184 . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
185 => ModuleName
186 -> [DeclarationRef]
187 -> [Declaration]
188 -> m [Declaration]
189typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
190 where
191 go :: Declaration -> m Declaration
192 go (DataDeclaration dtype name args dctors) = do
193 warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do
194 when (dtype == Newtype) $ checkNewtype name dctors
195 checkDuplicateTypeArguments $ map fst args
196 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
197 let args' = args `withKinds` ctorKind
198 addDataType moduleName dtype name args' dctors ctorKind
199 return $ DataDeclaration dtype name args dctors
200 go (d@(DataBindingGroupDeclaration tys)) = do
201 warnAndRethrow (addHint ErrorInDataBindingGroup) $ do
202 let syns = mapMaybe toTypeSynonym tys
203 let dataDecls = mapMaybe toDataDecl tys
204 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
205 for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
206 when (dtype == Newtype) $ checkNewtype name dctors
207 checkDuplicateTypeArguments $ map fst args
208 let args' = args `withKinds` ctorKind
209 addDataType moduleName dtype name args' dctors ctorKind
210 for_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
211 checkDuplicateTypeArguments $ map fst args
212 let args' = args `withKinds` kind
213 addTypeSynonym moduleName name args' ty kind
214 return d
215 where
216 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
217 toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'
218 toTypeSynonym _ = Nothing
219 toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
220 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
221 toDataDecl _ = Nothing
222 go (TypeSynonymDeclaration name args ty) = do
223 warnAndRethrow (addHint (ErrorInTypeSynonym name)) $ do
224 checkDuplicateTypeArguments $ map fst args
225 kind <- kindsOf False moduleName name args [ty]
226 let args' = args `withKinds` kind
227 addTypeSynonym moduleName name args' ty kind
228 return $ TypeSynonymDeclaration name args ty
229 go TypeDeclaration{} = internalError "Type declarations should have been removed"
230 go (ValueDeclaration name nameKind [] (Right val)) =
231 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do
232 valueIsNotDefined moduleName name
233 [(_, (val', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val)]
234 addValue moduleName name ty nameKind
235 return $ ValueDeclaration name nameKind [] $ Right val'
236 go ValueDeclaration{} = internalError "Binders were not desugared"
237 go (BindingGroupDeclaration vals) =
238 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
239 for_ (map (\(ident, _, _) -> ident) vals) $ \name ->
240 valueIsNotDefined moduleName name
241 tys <- typesOf RecursiveBindingGroup moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
242 vals' <- forM [ (name, val, nameKind, ty)
243 | (name, nameKind, _) <- vals
244 , (name', (val, ty)) <- tys
245 , name == name'
246 ] $ \(name, val, nameKind, ty) -> do
247 addValue moduleName name ty nameKind
248 return (name, nameKind, val)
249 return $ BindingGroupDeclaration vals'
250 go (d@(ExternDataDeclaration name kind)) = do
251 env <- getEnv
252 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
253 return d
254 go (d@(ExternDeclaration name ty)) = do
255 warnAndRethrow (addHint (ErrorInForeignImport name)) $ do
256 env <- getEnv
257 kind <- kindOf ty
258 guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star
259 case M.lookup (moduleName, name) (names env) of
260 Just _ -> throwError . errorMessage $ RedefinedIdent name
261 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
262 return d
263 go (d@FixityDeclaration{}) = return d
264 go (d@ImportDeclaration{}) = return d
265 go (d@(TypeClassDeclaration pn args implies tys)) = do
266 addTypeClass moduleName pn args implies tys
267 return d
268 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do
269 traverse_ (checkTypeClassInstance moduleName) tys
270 forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . snd
271 checkOrphanInstance dictName className tys
272 _ <- traverseTypeInstanceBody checkInstanceMembers body
273 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)
274 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict
275 return d
276 go (PositionedDeclaration pos com d) =
277 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
279 checkFixities :: Declaration -> m ()
280 checkFixities (FixityDeclaration _ name (Just (Qualified mn' (AliasValue ident)))) = do
281 ty <- lookupVariable moduleName (Qualified mn' ident)
282 addValue moduleName (Op name) ty Public
283 checkFixities (FixityDeclaration _ name (Just (Qualified mn' (AliasConstructor ctor)))) = do
284 env <- getEnv
285 let alias = Qualified mn' ctor
286 case M.lookup alias (dataConstructors env) of
287 Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing
288 Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public
289 checkFixities (FixityDeclaration _ name Nothing) = do
290 env <- getEnv
291 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
292 checkFixities (PositionedDeclaration pos _ d) =
293 warnAndRethrowWithPosition pos $ checkFixities d
294 checkFixities _ = return ()
296 checkInstanceMembers :: [Declaration] -> m [Declaration]
297 checkInstanceMembers instDecls = do
298 let idents = sort . map head . group . map memberName $ instDecls
299 for_ (firstDuplicate idents) $ \ident ->
300 throwError . errorMessage $ DuplicateValueDeclaration ident
301 return instDecls
302 where
303 memberName :: Declaration -> Ident
304 memberName (ValueDeclaration ident _ _ _) = ident
305 memberName (PositionedDeclaration _ _ d) = memberName d
306 memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition"
308 firstDuplicate :: (Eq a) => [a] -> Maybe a
309 firstDuplicate (x : xs@(y : _))
310 | x == y = Just x
311 | otherwise = firstDuplicate xs
312 firstDuplicate _ = Nothing
314 checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()
315 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'
316 | moduleName == mn' || any checkType tys' = return ()
317 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
318 where
319 checkType :: Type -> Bool
320 checkType (TypeVar _) = False
321 checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''
322 checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"
323 checkType (TypeApp t1 _) = checkType t1
324 checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
325 checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
327 checkNewtype :: ProperName 'TypeName -> [(ProperName 'ConstructorName, [Type])] -> m ()
328 checkNewtype _ [(_, [_])] = return ()
329 checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name
331 -- |
332 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
333 -- extracted from the kind of the type constructor itself.
334 --
335 withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]
336 withKinds [] _ = []
337 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k
338 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
339 withKinds _ _ = internalError "Invalid arguments to peelKinds"
341-- |
342-- Type check an entire module and ensure all types and classes defined within the module that are
343-- required by exported members are also exported.
344--
345typeCheckModule
346 :: forall m
347 . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
348 => Module
349 -> m Module
350typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"
351typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do
352 modify (\s -> s { checkCurrentModule = Just mn })
353 decls' <- typeCheckAll mn exps decls
354 for_ exps $ \e -> do
355 checkTypesAreExported e
356 checkClassMembersAreExported e
357 checkClassesAreExported e
358 checkNonAliasesAreExported (exportedDataConstructors exps) e
359 return $ Module ss coms mn decls' (Just exps)
360 where
362 checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m ()
363 checkMemberExport extract dr@(TypeRef name dctors) = do
364 env <- getEnv
365 case M.lookup (Qualified (Just mn) name) (typeSynonyms env) of
366 Nothing -> return ()
367 Just (_, ty) -> checkExport dr extract ty
368 case dctors of
369 Nothing -> return ()
370 Just dctors' -> for_ dctors' $ \dctor ->
371 case M.lookup (Qualified (Just mn) dctor) (dataConstructors env) of
372 Nothing -> return ()
373 Just (_, _, ty, _) -> checkExport dr extract ty
374 return ()
375 checkMemberExport extract dr@(ValueRef name) = do
376 ty <- lookupVariable mn (Qualified (Just mn) name)
377 checkExport dr extract ty
378 checkMemberExport _ _ = return ()
380 checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m ()
381 checkExport dr extract ty = case filter (not . exported) (extract ty) of
382 [] -> return ()
383 hidden -> throwError . errorMessage $ TransitiveExportError dr (nubBy nubEq hidden)
384 where
385 exported e = any (exports e) exps
386 exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
387 exports (ValueRef id1) (ValueRef id2) = id1 == id2
388 exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2
389 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
390 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
391 exports _ _ = False
392 -- We avoid Eq for `nub`bing as the dctor part of `TypeRef` evaluates to
393 -- `error` for the values generated here (we don't need them anyway)
394 nubEq (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
395 nubEq r1 r2 = r1 == r2
398 -- Check that all the type constructors defined in the current module that appear in member types
399 -- have also been exported from the module
400 checkTypesAreExported :: DeclarationRef -> m ()
401 checkTypesAreExported = checkMemberExport findTcons
402 where
403 findTcons :: Type -> [DeclarationRef]
404 findTcons = everythingOnTypes (++) go
405 where
406 go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (internalError "Data constructors unused in checkTypesAreExported")]
407 go _ = []
409 -- Check that all the classes defined in the current module that appear in member types have also
410 -- been exported from the module
411 checkClassesAreExported :: DeclarationRef -> m ()
412 checkClassesAreExported = checkMemberExport findClasses
413 where
414 findClasses :: Type -> [DeclarationRef]
415 findClasses = everythingOnTypes (++) go
416 where
417 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs
418 go _ = []
419 extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName)
420 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
421 extractCurrentModuleClass _ = Nothing
423 checkClassMembersAreExported :: DeclarationRef -> m ()
424 checkClassMembersAreExported dr@(TypeClassRef name) = do
425 let members = ValueRef `map` head (mapMaybe findClassMembers decls)
426 let missingMembers = members \\ exps
427 unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
428 where
429 findClassMembers :: Declaration -> Maybe [Ident]
430 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
431 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
432 findClassMembers _ = Nothing
433 extractMemberName :: Declaration -> Ident
434 extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d
435 extractMemberName (TypeDeclaration memberName _) = memberName
436 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"
437 checkClassMembersAreExported _ = return ()
439 checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m ()
440 checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) =
441 case listToMaybe (mapMaybe getAlias decls) of
442 Just (AliasValue ident) ->
443 unless (ValueRef ident `elem` exps) $
444 throwError . errorMessage $ TransitiveExportError dr [ValueRef ident]
445 Just (AliasConstructor ctor) ->
446 unless (ctor `elem` exportedDctors) $
447 throwError . errorMessage $ TransitiveDctorExportError dr ctor
448 _ -> return ()
449 where
450 getAlias :: Declaration -> Maybe FixityAlias
451 getAlias (PositionedDeclaration _ _ d) = getAlias d
452 getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias)))
453 | name == name' && mn == mn' = Just alias
454 getAlias _ = Nothing
455 checkNonAliasesAreExported _ _ = return ()
457 exportedDataConstructors :: [DeclarationRef] -> [ProperName 'ConstructorName]
458 exportedDataConstructors = foldMap extractCtor
459 where
460 extractCtor :: DeclarationRef -> [ProperName 'ConstructorName]
461 extractCtor (TypeRef _ (Just ctors)) = ctors
462 extractCtor _ = []