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