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