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