git.iko.soy/rowtype-yoga/purescript-native
on f1dfe1e 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 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 where
201 checkNewtype :: [(ProperName 'ConstructorName, [Type])] -> m ()
202 checkNewtype [(_, [_])] = return ()
203 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name
204 checkNewtype _ = throwError . errorMessage $ InvalidNewtype name
205 go (d@(DataBindingGroupDeclaration tys)) = do
206 warnAndRethrow (addHint ErrorInDataBindingGroup) $ do
207 let syns = mapMaybe toTypeSynonym tys
208 let dataDecls = mapMaybe toDataDecl tys
209 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
210 for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
211 checkDuplicateTypeArguments $ map fst args
212 let args' = args `withKinds` ctorKind
213 addDataType moduleName dtype name args' dctors ctorKind
214 for_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
215 checkDuplicateTypeArguments $ map fst args
216 let args' = args `withKinds` kind
217 addTypeSynonym moduleName name args' ty kind
218 return d
219 where
220 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
221 toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'
222 toTypeSynonym _ = Nothing
223 toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
224 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
225 toDataDecl _ = Nothing
226 go (TypeSynonymDeclaration name args ty) = do
227 warnAndRethrow (addHint (ErrorInTypeSynonym name)) $ do
228 checkDuplicateTypeArguments $ map fst args
229 kind <- kindsOf False moduleName name args [ty]
230 let args' = args `withKinds` kind
231 addTypeSynonym moduleName name args' ty kind
232 return $ TypeSynonymDeclaration name args ty
233 go TypeDeclaration{} = internalError "Type declarations should have been removed"
234 go (ValueDeclaration name nameKind [] (Right val)) =
235 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do
236 valueIsNotDefined moduleName name
237 [(_, (val', ty))] <- typesOf moduleName [(name, val)]
238 addValue moduleName name ty nameKind
239 return $ ValueDeclaration name nameKind [] $ Right val'
240 go ValueDeclaration{} = internalError "Binders were not desugared"
241 go (BindingGroupDeclaration vals) =
242 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
243 for_ (map (\(ident, _, _) -> ident) vals) $ \name ->
244 valueIsNotDefined moduleName name
245 tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
246 vals' <- forM [ (name, val, nameKind, ty)
247 | (name, nameKind, _) <- vals
248 , (name', (val, ty)) <- tys
249 , name == name'
250 ] $ \(name, val, nameKind, ty) -> do
251 addValue moduleName name ty nameKind
252 return (name, nameKind, val)
253 return $ BindingGroupDeclaration vals'
254 go (d@(ExternDataDeclaration name kind)) = do
255 env <- getEnv
256 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
257 return d
258 go (d@(ExternDeclaration name ty)) = do
259 warnAndRethrow (addHint (ErrorInForeignImport name)) $ do
260 env <- getEnv
261 kind <- kindOf ty
262 guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star
263 case M.lookup (moduleName, name) (names env) of
264 Just _ -> throwError . errorMessage $ RedefinedIdent name
265 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
266 return d
267 go (d@FixityDeclaration{}) = return d
268 go (d@ImportDeclaration{}) = return d
269 go (d@(TypeClassDeclaration pn args implies tys)) = do
270 addTypeClass moduleName pn args implies tys
271 return d
272 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do
273 traverse_ (checkTypeClassInstance moduleName) tys
274 forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . snd
275 checkOrphanInstance dictName className tys
276 _ <- traverseTypeInstanceBody checkInstanceMembers body
277 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)
278 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict
279 return d
280 go (PositionedDeclaration pos com d) =
281 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
283 checkFixities :: Declaration -> m ()
284 checkFixities (FixityDeclaration _ name (Just (Left alias))) = do
285 ty <- lookupVariable moduleName alias
286 addValue moduleName (Op name) ty Public
287 checkFixities (FixityDeclaration _ name (Just (Right alias))) = do
288 env <- getEnv
289 case M.lookup alias (dataConstructors env) of
290 Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing
291 Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public
292 checkFixities (FixityDeclaration _ name _) = do
293 env <- getEnv
294 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
295 checkFixities (PositionedDeclaration pos _ d) =
296 warnAndRethrowWithPosition pos $ checkFixities d
297 checkFixities _ = return ()
299 checkInstanceMembers :: [Declaration] -> m [Declaration]
300 checkInstanceMembers instDecls = do
301 let idents = sort . map head . group . map memberName $ instDecls
302 for_ (firstDuplicate idents) $ \ident ->
303 throwError . errorMessage $ DuplicateValueDeclaration ident
304 return instDecls
305 where
306 memberName :: Declaration -> Ident
307 memberName (ValueDeclaration ident _ _ _) = ident
308 memberName (PositionedDeclaration _ _ d) = memberName d
309 memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition"
311 firstDuplicate :: (Eq a) => [a] -> Maybe a
312 firstDuplicate (x : xs@(y : _))
313 | x == y = Just x
314 | otherwise = firstDuplicate xs
315 firstDuplicate _ = Nothing
317 checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m ()
318 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'
319 | moduleName == mn' || any checkType tys' = return ()
320 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
321 where
322 checkType :: Type -> Bool
323 checkType (TypeVar _) = False
324 checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''
325 checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"
326 checkType (TypeApp t1 _) = checkType t1
327 checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
328 checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
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 _ = []