git.iko.soy/rowtype-yoga/purescript-native
on ab7e5f6 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/TypeChecker.hs
437 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.State.Class (MonadState(..), modify)
29import Control.Monad.Error.Class (MonadError(..))
30import Control.Monad.Writer.Class (MonadWriter(..))
32import Language.PureScript.Crash
33import Language.PureScript.Types
34import Language.PureScript.Names
35import Language.PureScript.Kinds
36import Language.PureScript.AST
37import Language.PureScript.TypeClassDictionaries
38import Language.PureScript.Environment
39import Language.PureScript.Errors
41addDataType ::
42 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
43 ModuleName ->
44 DataDeclType ->
45 ProperName ->
46 [(String, Maybe Kind)] ->
47 [(ProperName, [Type])] ->
48 Kind ->
49 m ()
50addDataType moduleName dtype name args dctors ctorKind = do
51 env <- getEnv
52 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
53 for_ dctors $ \(dctor, tys) ->
54 warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $
55 addDataConstructor moduleName dtype name (map fst args) dctor tys
57addDataConstructor ::
58 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
59 ModuleName ->
60 DataDeclType ->
61 ProperName ->
62 [String] ->
63 ProperName ->
64 [Type] ->
65 m ()
66addDataConstructor moduleName dtype name args dctor tys = do
67 env <- getEnv
68 traverse_ checkTypeSynonyms tys
69 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
70 let dctorTy = foldr function retTy tys
71 let polyType = mkForAll args dctorTy
72 let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]
73 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
75addTypeSynonym ::
76 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
77 ModuleName ->
78 ProperName ->
79 [(String, Maybe Kind)] ->
80 Type ->
81 Kind ->
82 m ()
83addTypeSynonym moduleName name args ty kind = do
84 env <- getEnv
85 checkTypeSynonyms ty
86 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
87 , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
89valueIsNotDefined ::
90 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
91 ModuleName ->
92 Ident ->
93 m ()
94valueIsNotDefined moduleName name = do
95 env <- getEnv
96 case M.lookup (moduleName, name) (names env) of
97 Just _ -> throwError . errorMessage $ RedefinedIdent name
98 Nothing -> return ()
100addValue ::
101 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
102 ModuleName ->
103 Ident ->
104 Type ->
105 NameKind ->
106 m ()
107addValue moduleName name ty nameKind = do
108 env <- getEnv
109 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
111addTypeClass ::
112 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
113 ModuleName ->
114 ProperName ->
115 [(String, Maybe Kind)] ->
116 [Constraint] ->
117 [Declaration] ->
118 m ()
119addTypeClass moduleName pn args implies ds =
120 let members = map toPair ds in
121 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
122 where
123 toPair (TypeDeclaration ident ty) = (ident, ty)
124 toPair (PositionedDeclaration _ _ d) = toPair d
125 toPair _ = internalError "Invalid declaration in TypeClassDeclaration"
127addTypeClassDictionaries ::
128 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
129 Maybe ModuleName ->
130 M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) ->
131 m ()
132addTypeClassDictionaries mn entries =
133 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } }
134 where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st)
136checkDuplicateTypeArguments ::
137 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
138 [String] ->
139 m ()
140checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
141 throwError . errorMessage $ DuplicateTypeArgument dup
142 where
143 firstDup :: Maybe String
144 firstDup = listToMaybe $ args \\ nub args
146checkTypeClassInstance ::
147 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
148 ModuleName ->
149 Type ->
150 m ()
151checkTypeClassInstance _ (TypeVar _) = return ()
152checkTypeClassInstance _ (TypeConstructor ctor) = do
153 env <- getEnv
154 when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance
155 return ()
156checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
157checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty
159-- |
160-- Check that type synonyms are fully-applied in a type
161--
162checkTypeSynonyms ::
163 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
164 Type ->
165 m ()
166checkTypeSynonyms = void . replaceAllTypeSynonyms
168-- |
169-- Type check all declarations in a module
170--
171-- At this point, many declarations will have been desugared, but it is still necessary to
172--
173-- * Kind-check all types and add them to the @Environment@
174--
175-- * Type-check all values and add them to the @Environment@
176--
177-- * Bring type class instances into scope
178--
179-- * Process module imports
180--
181typeCheckAll :: forall m.
182 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
183 ModuleName ->
184 [DeclarationRef] ->
185 [Declaration] ->
186 m [Declaration]
187typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds
188 where
189 go :: Declaration -> m Declaration
190 go (DataDeclaration dtype name args dctors) = do
191 warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do
192 when (dtype == Newtype) $ checkNewtype dctors
193 checkDuplicateTypeArguments $ map fst args
194 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
195 let args' = args `withKinds` ctorKind
196 addDataType moduleName dtype name args' dctors ctorKind
197 return $ DataDeclaration dtype name args dctors
198 where
199 checkNewtype :: [(ProperName, [Type])] -> m ()
200 checkNewtype [(_, [_])] = return ()
201 checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name
202 checkNewtype _ = throwError . errorMessage $ InvalidNewtype name
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 checkDuplicateTypeArguments $ map fst args
210 let args' = args `withKinds` ctorKind
211 addDataType moduleName dtype name args' dctors ctorKind
212 for_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
213 checkDuplicateTypeArguments $ map fst args
214 let args' = args `withKinds` kind
215 addTypeSynonym moduleName name args' ty kind
216 return d
217 where
218 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
219 toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'
220 toTypeSynonym _ = Nothing
221 toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
222 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
223 toDataDecl _ = Nothing
224 go (TypeSynonymDeclaration name args ty) = do
225 warnAndRethrow (addHint (ErrorInTypeSynonym name)) $ do
226 checkDuplicateTypeArguments $ map fst args
227 kind <- kindsOf False moduleName name args [ty]
228 let args' = args `withKinds` kind
229 addTypeSynonym moduleName name args' ty kind
230 return $ TypeSynonymDeclaration name args ty
231 go (TypeDeclaration{}) = internalError "Type declarations should have been removed"
232 go (ValueDeclaration name nameKind [] (Right val)) =
233 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do
234 valueIsNotDefined moduleName name
235 [(_, (val', ty))] <- typesOf moduleName [(name, val)]
236 addValue moduleName name ty nameKind
237 return $ ValueDeclaration name nameKind [] $ Right val'
238 go (ValueDeclaration{}) = internalError "Binders were not desugared"
239 go (BindingGroupDeclaration vals) =
240 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
241 for_ (map (\(ident, _, _) -> ident) vals) $ \name ->
242 valueIsNotDefined moduleName name
243 tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
244 vals' <- forM [ (name, val, nameKind, ty)
245 | (name, nameKind, _) <- vals
246 , (name', (val, ty)) <- tys
247 , name == name'
248 ] $ \(name, val, nameKind, ty) -> do
249 addValue moduleName name ty nameKind
250 return (name, nameKind, val)
251 return $ BindingGroupDeclaration vals'
252 go (d@(ExternDataDeclaration name kind)) = do
253 env <- getEnv
254 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
255 return d
256 go (d@(ExternDeclaration name ty)) = do
257 warnAndRethrow (addHint (ErrorInForeignImport name)) $ do
258 env <- getEnv
259 kind <- kindOf ty
260 guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star
261 case M.lookup (moduleName, name) (names env) of
262 Just _ -> throwError . errorMessage $ RedefinedIdent name
263 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
264 return d
265 go (d@(FixityDeclaration{})) = return d
266 go (d@(ImportDeclaration{})) = return d
267 go (d@(TypeClassDeclaration pn args implies tys)) = do
268 addTypeClass moduleName pn args implies tys
269 return d
270 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do
271 traverse_ (checkTypeClassInstance moduleName) tys
272 forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . snd
273 checkOrphanInstance dictName className tys
274 _ <- traverseTypeInstanceBody checkInstanceMembers body
275 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)
276 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict
277 return d
278 go (PositionedDeclaration pos com d) =
279 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
281 checkFixities :: Declaration -> m ()
282 checkFixities (FixityDeclaration _ name (Just alias)) = do
283 ty <- lookupVariable moduleName (Qualified (Just moduleName) alias)
284 addValue moduleName (Op name) ty Public
285 checkFixities (FixityDeclaration _ name _) = do
286 env <- getEnv
287 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
288 checkFixities (PositionedDeclaration pos _ d) =
289 warnAndRethrowWithPosition pos $ checkFixities d
290 checkFixities _ = return ()
292 checkInstanceMembers :: [Declaration] -> m [Declaration]
293 checkInstanceMembers instDecls = do
294 let idents = sort . map head . group . map memberName $ instDecls
295 for_ (firstDuplicate idents) $ \ident ->
296 throwError . errorMessage $ DuplicateValueDeclaration ident
297 return instDecls
298 where
299 memberName :: Declaration -> Ident
300 memberName (ValueDeclaration ident _ _ _) = ident
301 memberName (PositionedDeclaration _ _ d) = memberName d
302 memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition"
304 firstDuplicate :: (Eq a) => [a] -> Maybe a
305 firstDuplicate (x : xs@(y : _))
306 | x == y = Just x
307 | otherwise = firstDuplicate xs
308 firstDuplicate _ = Nothing
310 checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m ()
311 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'
312 | moduleName == mn' || any checkType tys' = return ()
313 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
314 where
315 checkType :: Type -> Bool
316 checkType (TypeVar _) = False
317 checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''
318 checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"
319 checkType (TypeApp t1 _) = checkType t1
320 checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
321 checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
323 -- |
324 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
325 -- extracted from the kind of the type constructor itself.
326 --
327 withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]
328 withKinds [] _ = []
329 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k
330 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
331 withKinds _ _ = internalError "Invalid arguments to peelKinds"
333-- |
334-- Type check an entire module and ensure all types and classes defined within the module that are
335-- required by exported members are also exported.
336--
337typeCheckModule :: forall m.
338 (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
339 Module ->
340 m Module
341typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"
342typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do
343 modify (\s -> s { checkCurrentModule = Just mn })
344 decls' <- typeCheckAll mn exps decls
345 for_ exps $ \e -> do
346 checkTypesAreExported e
347 checkClassMembersAreExported e
348 checkClassesAreExported e
349 checkNonAliasesAreExported e
350 return $ Module ss coms mn decls' (Just exps)
351 where
353 checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m ()
354 checkMemberExport extract dr@(TypeRef name dctors) = do
355 env <- getEnv
356 case M.lookup (Qualified (Just mn) name) (typeSynonyms env) of
357 Nothing -> return ()
358 Just (_, ty) -> checkExport dr extract ty
359 case dctors of
360 Nothing -> return ()
361 Just dctors' -> for_ dctors' $ \dctor ->
362 case M.lookup (Qualified (Just mn) dctor) (dataConstructors env) of
363 Nothing -> return ()
364 Just (_, _, ty, _) -> checkExport dr extract ty
365 return ()
366 checkMemberExport extract dr@(ValueRef name) = do
367 ty <- lookupVariable mn (Qualified (Just mn) name)
368 checkExport dr extract ty
369 checkMemberExport _ _ = return ()
371 checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m ()
372 checkExport dr extract ty = case filter (not . exported) (extract ty) of
373 [] -> return ()
374 hidden -> throwError . errorMessage $ TransitiveExportError dr hidden
375 where
376 exported e = any (exports e) exps
377 exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
378 exports (ValueRef id1) (ValueRef id2) = id1 == id2
379 exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2
380 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
381 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
382 exports _ _ = False
384 -- Check that all the type constructors defined in the current module that appear in member types
385 -- have also been exported from the module
386 checkTypesAreExported :: DeclarationRef -> m ()
387 checkTypesAreExported = checkMemberExport findTcons
388 where
389 findTcons :: Type -> [DeclarationRef]
390 findTcons = everythingOnTypes (++) go
391 where
392 go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (internalError "Data constructors unused in checkTypesAreExported")]
393 go _ = []
395 -- Check that all the classes defined in the current module that appear in member types have also
396 -- been exported from the module
397 checkClassesAreExported :: DeclarationRef -> m ()
398 checkClassesAreExported = checkMemberExport findClasses
399 where
400 findClasses :: Type -> [DeclarationRef]
401 findClasses = everythingOnTypes (++) go
402 where
403 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs
404 go _ = []
405 extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
406 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
407 extractCurrentModuleClass _ = Nothing
409 checkClassMembersAreExported :: DeclarationRef -> m ()
410 checkClassMembersAreExported dr@(TypeClassRef name) = do
411 let members = ValueRef `map` head (mapMaybe findClassMembers decls)
412 let missingMembers = members \\ exps
413 unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
414 where
415 findClassMembers :: Declaration -> Maybe [Ident]
416 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
417 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
418 findClassMembers _ = Nothing
419 extractMemberName :: Declaration -> Ident
420 extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d
421 extractMemberName (TypeDeclaration memberName _) = memberName
422 extractMemberName _ = internalError "Unexpected declaration in typeclass member list"
423 checkClassMembersAreExported _ = return ()
425 checkNonAliasesAreExported :: DeclarationRef -> m ()
426 checkNonAliasesAreExported dr@(ValueRef (Op name)) =
427 case listToMaybe (mapMaybe getAlias decls) of
428 Just alias ->
429 when (not $ any (== ValueRef alias) exps) $
430 throwError . errorMessage $ TransitiveExportError dr [ValueRef alias]
431 _ -> return ()
432 where
433 getAlias :: Declaration -> Maybe Ident
434 getAlias (PositionedDeclaration _ _ d) = getAlias d
435 getAlias (FixityDeclaration _ name' alias) | name == name' = alias
436 getAlias _ = Nothing
437 checkNonAliasesAreExported _ = return ()