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