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