git.iko.soy/rowtype-yoga/purescript-native
on 6cb50ee help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/TypeChecker.hs
464 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 (Left alias))) = do
281 ty <- lookupVariable moduleName alias
282 addValue moduleName (Op name) ty Public
283 checkFixities (FixityDeclaration _ name (Just (Right alias))) = do
284 env <- getEnv
285 case M.lookup alias (dataConstructors env) of
286 Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing
287 Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public
288 checkFixities (FixityDeclaration _ name _) = do
289 env <- getEnv
290 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
291 checkFixities (PositionedDeclaration pos _ d) =
292 warnAndRethrowWithPosition pos $ checkFixities d
293 checkFixities _ = return ()
295 checkInstanceMembers :: [Declaration] -> m [Declaration]
296 checkInstanceMembers instDecls = do
297 let idents = sort . map head . group . map memberName $ instDecls
298 for_ (firstDuplicate idents) $ \ident ->
299 throwError . errorMessage $ DuplicateValueDeclaration ident
300 return instDecls
301 where
302 memberName :: Declaration -> Ident
303 memberName (ValueDeclaration ident _ _ _) = ident
304 memberName (PositionedDeclaration _ _ d) = memberName d
305 memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition"
307 firstDuplicate :: (Eq a) => [a] -> Maybe a
308 firstDuplicate (x : xs@(y : _))
309 | x == y = Just x
310 | otherwise = firstDuplicate xs
311 firstDuplicate _ = Nothing
313 checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()
314 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'
315 | moduleName == mn' || any checkType tys' = return ()
316 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
317 where
318 checkType :: Type -> Bool
319 checkType (TypeVar _) = False
320 checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''
321 checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"
322 checkType (TypeApp t1 _) = checkType t1
323 checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
324 checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
326 checkNewtype :: ProperName 'TypeName -> [(ProperName 'ConstructorName, [Type])] -> m ()
327 checkNewtype _ [(_, [_])] = return ()
328 checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name
330 -- |
331 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
332 -- extracted from the kind of the type constructor itself.
333 --
334 withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]
335 withKinds [] _ = []
336 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k
337 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
338 withKinds _ _ = internalError "Invalid arguments to peelKinds"
340-- |
341-- Type check an entire module and ensure all types and classes defined within the module that are
342-- required by exported members are also exported.
343--
344typeCheckModule
345 :: forall m
346 . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
347 => Module
348 -> m Module
349typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"
350typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do
351 modify (\s -> s { checkCurrentModule = Just mn })
352 decls' <- typeCheckAll mn exps decls
353 for_ exps $ \e -> do
354 checkTypesAreExported e
355 checkClassMembersAreExported e
356 checkClassesAreExported e
357 checkNonAliasesAreExported (exportedDataConstructors exps) e
358 return $ Module ss coms mn decls' (Just exps)
359 where
361 checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m ()
362 checkMemberExport extract dr@(TypeRef name dctors) = do
363 env <- getEnv
364 case M.lookup (Qualified (Just mn) name) (typeSynonyms env) of
365 Nothing -> return ()
366 Just (_, ty) -> checkExport dr extract ty
367 case dctors of
368 Nothing -> return ()
369 Just dctors' -> for_ dctors' $ \dctor ->
370 case M.lookup (Qualified (Just mn) dctor) (dataConstructors env) of
371 Nothing -> return ()
372 Just (_, _, ty, _) -> checkExport dr extract ty
373 return ()
374 checkMemberExport extract dr@(ValueRef name) = do
375 ty <- lookupVariable mn (Qualified (Just mn) name)
376 checkExport dr extract ty
377 checkMemberExport _ _ = return ()
379 checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m ()
380 checkExport dr extract ty = case filter (not . exported) (extract ty) of
381 [] -> return ()
382 hidden -> throwError . errorMessage $ TransitiveExportError dr (nubBy nubEq hidden)
383 where
384 exported e = any (exports e) exps
385 exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
386 exports (ValueRef id1) (ValueRef id2) = id1 == id2
387 exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2
388 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
389 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
390 exports _ _ = False
391 -- We avoid Eq for `nub`bing as the dctor part of `TypeRef` evaluates to
392 -- `error` for the values generated here (we don't need them anyway)
393 nubEq (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
394 nubEq r1 r2 = r1 == r2
397 -- Check that all the type constructors defined in the current module that appear in member types
398 -- have also been exported from the module
399 checkTypesAreExported :: DeclarationRef -> m ()
400 checkTypesAreExported = checkMemberExport findTcons
401 where
402 findTcons :: Type -> [DeclarationRef]
403 findTcons = everythingOnTypes (++) go
404 where
405 go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (internalError "Data constructors unused in checkTypesAreExported")]
406 go _ = []
408 -- Check that all the classes defined in the current module that appear in member types have also
409 -- been exported from the module
410 checkClassesAreExported :: DeclarationRef -> m ()
411 checkClassesAreExported = checkMemberExport findClasses
412 where
413 findClasses :: Type -> [DeclarationRef]
414 findClasses = everythingOnTypes (++) go
415 where
416 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs
417 go _ = []
418 extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName)
419 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
420 extractCurrentModuleClass _ = Nothing
422 checkClassMembersAreExported :: DeclarationRef -> m ()
423 checkClassMembersAreExported dr@(TypeClassRef name) = do
424 let members = ValueRef `map` head (mapMaybe findClassMembers decls)
425 let missingMembers = members \\ exps
426 unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
427 where
428 findClassMembers :: Declaration -> Maybe [Ident]
429 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
430 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
431 findClassMembers _ = Nothing
432 extractMemberName :: Declaration -> Ident
433 extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d
434 extractMemberName (TypeDeclaration memberName _) = memberName
435 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"
436 checkClassMembersAreExported _ = return ()
438 checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m ()
439 checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) =
440 case listToMaybe (mapMaybe getAlias decls) of
441 Just (Left ident) ->
442 unless (ValueRef ident `elem` exps) $
443 throwError . errorMessage $ TransitiveExportError dr [ValueRef ident]
444 Just (Right ctor) ->
445 unless (ctor `elem` exportedDctors) $
446 throwError . errorMessage $ TransitiveDctorExportError dr ctor
447 _ -> return ()
448 where
449 getAlias :: Declaration -> Maybe (Either Ident (ProperName 'ConstructorName))
450 getAlias (PositionedDeclaration _ _ d) = getAlias d
451 getAlias (FixityDeclaration _ name' (Just alias)) | name == name' =
452 case alias of
453 Left (Qualified (Just mn') ident) | mn == mn' -> Just (Left ident)
454 Right (Qualified (Just mn') ctor) | mn == mn' -> Just (Right ctor)
455 _ -> Nothing
456 getAlias _ = Nothing
457 checkNonAliasesAreExported _ _ = return ()
459 exportedDataConstructors :: [DeclarationRef] -> [ProperName 'ConstructorName]
460 exportedDataConstructors = foldMap extractCtor
461 where
462 extractCtor :: DeclarationRef -> [ProperName 'ConstructorName]
463 extractCtor (TypeRef _ (Just ctors)) = ctors
464 extractCtor _ = []