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