git.iko.soy/rowtype-yoga/purescript-native
on 7e26d58 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/TypeChecker.hs
343 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 (onErrorMessages (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 :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
136typeCheckAll mainModuleName 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 (onErrorMessages (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 (onErrorMessages 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 (onErrorMessages (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 (onErrorMessages (ErrorInValueDeclaration name)) $ do
183 valueIsNotDefined moduleName name
184 [(_, (val', ty))] <- typesOf mainModuleName 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 (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
190 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
191 valueIsNotDefined moduleName name
192 tys <- typesOf mainModuleName 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 (onErrorMessages (ErrorInForeignImport name)) $ do
207 env <- getEnv
208 kind <- kindOf moduleName ty
209 guardWith (errorMessage (ExpectedType 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 importedModule _ _)) = do
216 instances <- lookupTypeClassDictionaries $ Just importedModule
217 addTypeClassDictionaries (Just moduleName) instances
218 return d
219 go (d@(TypeClassDeclaration pn args implies tys)) = do
220 addTypeClass moduleName pn args implies tys
221 return d
222 go (d@(TypeInstanceDeclaration dictName deps className tys _)) =
223 goInstance d dictName deps className tys
224 go (d@(ExternInstanceDeclaration dictName deps className tys)) =
225 goInstance d dictName deps className tys
226 go (PositionedDeclaration pos com d) =
227 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
229 checkOrphanFixities :: Declaration -> Check ()
230 checkOrphanFixities (FixityDeclaration _ name) = do
231 env <- getEnv
232 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
233 checkOrphanFixities (PositionedDeclaration pos _ d) =
234 warnAndRethrowWithPosition pos $ checkOrphanFixities d
235 checkOrphanFixities _ = return ()
237 goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> Check Declaration
238 goInstance d dictName deps className tys = do
239 mapM_ (checkTypeClassInstance moduleName) tys
240 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
241 checkOrphanInstance moduleName className tys
242 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) TCDRegular
243 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict
244 return d
246 where
248 checkOrphanInstance :: ModuleName -> Qualified ProperName -> [Type] -> Check ()
249 checkOrphanInstance mn (Qualified (Just mn') _) tys'
250 | mn == mn' || any checkType tys' = return ()
251 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
252 where
253 checkType :: Type -> Bool
254 checkType (TypeVar _) = False
255 checkType (TypeConstructor (Qualified (Just mn'') _)) = mn == mn''
256 checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance"
257 checkType (TypeApp t1 _) = checkType t1
258 checkType _ = error "Invalid type in instance in checkOrphanInstance"
259 checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance"
261 -- |
262 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
263 -- extracted from the kind of the type constructor itself.
264 --
265 withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]
266 withKinds [] _ = []
267 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k
268 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
269 withKinds _ _ = error "Invalid arguments to peelKinds"
271-- |
272-- Type check an entire module and ensure all types and classes defined within the module that are
273-- required by exported members are also exported.
274--
275typeCheckModule :: Maybe ModuleName -> Module -> Check Module
276typeCheckModule _ (Module _ _ _ _ Nothing) = error "exports should have been elaborated"
277typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRethrow (onErrorMessages (ErrorInModule mn)) $ do
278 modify (\s -> s { checkCurrentModule = Just mn })
279 decls' <- typeCheckAll mainModuleName mn exps decls
280 forM_ exps $ \e -> do
281 checkTypesAreExported e
282 checkClassMembersAreExported e
283 checkClassesAreExported e
284 return $ Module ss coms mn decls' (Just exps)
285 where
287 checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check ()
288 checkMemberExport extract dr@(ValueRef name) = do
289 ty <- lookupVariable mn (Qualified (Just mn) name)
290 case filter (not . exported) (extract ty) of
291 [] -> return ()
292 hidden -> throwError . errorMessage $ TransitiveExportError dr hidden
293 where
294 exported e = any (exports e) exps
295 exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
296 exports (ValueRef id1) (ValueRef id2) = id1 == id2
297 exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2
298 exports (TypeInstanceRef id1) (TypeInstanceRef id2) = id1 == id2
299 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
300 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
301 exports _ _ = False
302 checkMemberExport _ _ = return ()
304 -- Check that all the type constructors defined in the current module that appear in member types
305 -- have also been exported from the module
306 checkTypesAreExported :: DeclarationRef -> Check ()
307 checkTypesAreExported = checkMemberExport findTcons
308 where
309 findTcons :: Type -> [DeclarationRef]
310 findTcons = everythingOnTypes (++) go
311 where
312 go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (error "Data constructors unused in checkTypesAreExported")]
313 go _ = []
315 -- Check that all the classes defined in the current module that appear in member types have also
316 -- been exported from the module
317 checkClassesAreExported :: DeclarationRef -> Check ()
318 checkClassesAreExported = checkMemberExport findClasses
319 where
320 findClasses :: Type -> [DeclarationRef]
321 findClasses = everythingOnTypes (++) go
322 where
323 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs
324 go _ = []
325 extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
326 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
327 extractCurrentModuleClass _ = Nothing
329 checkClassMembersAreExported :: DeclarationRef -> Check ()
330 checkClassMembersAreExported dr@(TypeClassRef name) = do
331 let members = ValueRef `map` head (mapMaybe findClassMembers decls)
332 let missingMembers = members \\ exps
333 unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
334 where
335 findClassMembers :: Declaration -> Maybe [Ident]
336 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
337 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
338 findClassMembers _ = Nothing
339 extractMemberName :: Declaration -> Ident
340 extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d
341 extractMemberName (TypeDeclaration memberName _) = memberName
342 extractMemberName _ = error "Unexpected declaration in typeclass member list"
343 checkClassMembersAreExported _ = return ()