git.iko.soy/rowtype-yoga/purescript-native
on 38034d2 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/TypeChecker.hs
338 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, (\\), 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.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 body)) = rethrow (addHint (ErrorInInstance className tys)) $ do
220 mapM_ (checkTypeClassInstance moduleName) tys
221 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
222 checkOrphanInstance dictName className tys
223 _ <- traverseTypeInstanceBody checkInstanceMembers body
224 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)
225 addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict
226 return d
227 go (PositionedDeclaration pos com d) =
228 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
230 checkOrphanFixities :: Declaration -> Check ()
231 checkOrphanFixities (FixityDeclaration _ name) = do
232 env <- getEnv
233 guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
234 checkOrphanFixities (PositionedDeclaration pos _ d) =
235 warnAndRethrowWithPosition pos $ checkOrphanFixities d
236 checkOrphanFixities _ = return ()
238 checkInstanceMembers :: [Declaration] -> Check [Declaration]
239 checkInstanceMembers instDecls = do
240 let idents = sort . map head . group . map memberName $ instDecls
241 for_ (firstDuplicate idents) $ \ident ->
242 throwError . errorMessage $ DuplicateValueDeclaration ident
243 return instDecls
244 where
245 memberName :: Declaration -> Ident
246 memberName (ValueDeclaration ident _ _ _) = ident
247 memberName (PositionedDeclaration _ _ d) = memberName d
248 memberName _ = error "checkInstanceMembers: Invalid declaration in type instance definition"
250 firstDuplicate :: (Eq a) => [a] -> Maybe a
251 firstDuplicate (x : xs@(y : _))
252 | x == y = Just x
253 | otherwise = firstDuplicate xs
254 firstDuplicate _ = Nothing
256 checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> Check ()
257 checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'
258 | moduleName == mn' || any checkType tys' = return ()
259 | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
260 where
261 checkType :: Type -> Bool
262 checkType (TypeVar _) = False
263 checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''
264 checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance"
265 checkType (TypeApp t1 _) = checkType t1
266 checkType _ = error "Invalid type in instance in checkOrphanInstance"
267 checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance"
269 -- |
270 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
271 -- extracted from the kind of the type constructor itself.
272 --
273 withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]
274 withKinds [] _ = []
275 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k
276 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
277 withKinds _ _ = error "Invalid arguments to peelKinds"
279-- |
280-- Type check an entire module and ensure all types and classes defined within the module that are
281-- required by exported members are also exported.
282--
283typeCheckModule :: Module -> Check Module
284typeCheckModule (Module _ _ _ _ Nothing) = error "exports should have been elaborated"
285typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do
286 modify (\s -> s { checkCurrentModule = Just mn })
287 decls' <- typeCheckAll mn exps decls
288 forM_ exps $ \e -> do
289 checkClassMembersAreExported e
290 checkClassesAreExported e
291 return $ Module ss coms mn decls' (Just exps)
292 where
294 checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check ()
295 checkMemberExport extract dr@(ValueRef name) = do
296 ty <- lookupVariable mn (Qualified (Just mn) name)
297 case filter (not . exported) (extract ty) of
298 [] -> return ()
299 hidden -> throwError . errorMessage $ TransitiveExportError dr hidden
300 where
301 exported e = any (exports e) exps
302 exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
303 exports (ValueRef id1) (ValueRef id2) = id1 == id2
304 exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2
305 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
306 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
307 exports _ _ = False
308 checkMemberExport _ _ = return ()
310 -- Check that all the classes defined in the current module that appear in member types have also
311 -- been exported from the module
312 checkClassesAreExported :: DeclarationRef -> Check ()
313 checkClassesAreExported = checkMemberExport findClasses
314 where
315 findClasses :: Type -> [DeclarationRef]
316 findClasses = everythingOnTypes (++) go
317 where
318 go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs
319 go _ = []
320 extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
321 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
322 extractCurrentModuleClass _ = Nothing
324 checkClassMembersAreExported :: DeclarationRef -> Check ()
325 checkClassMembersAreExported dr@(TypeClassRef name) = do
326 let members = ValueRef `map` head (mapMaybe findClassMembers decls)
327 let missingMembers = members \\ exps
328 unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
329 where
330 findClassMembers :: Declaration -> Maybe [Ident]
331 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
332 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
333 findClassMembers _ = Nothing
334 extractMemberName :: Declaration -> Ident
335 extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d
336 extractMemberName (TypeDeclaration memberName _) = memberName
337 extractMemberName _ = error "Unexpected declaration in typeclass member list"
338 checkClassMembersAreExported _ = return ()