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