git.iko.soy/rowtype-yoga/purescript-native
on fe44756 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/TypeChecker.hs
186 lines 9.2 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Language.PureScript.TypeChecker
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15{-# LANGUAGE FlexibleInstances #-}
17module Language.PureScript.TypeChecker (
18 module T,
19 typeCheckAll
20) where
22import Language.PureScript.TypeChecker.Monad as T
23import Language.PureScript.TypeChecker.Kinds as T
24import Language.PureScript.TypeChecker.Types as T
25import Language.PureScript.TypeChecker.Synonyms as T
27import Data.Maybe
28import qualified Data.Map as M
29import Control.Monad.State
30import Control.Monad.Error
31import Data.Either (rights, lefts)
33import Language.PureScript.Types
34import Language.PureScript.Names
35import Language.PureScript.Kinds
36import Language.PureScript.Declarations
38addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, Maybe Type)] -> Kind -> Check ()
39addDataType moduleName name args dctors ctorKind = do
40 env <- getEnv
41 putEnv $ env { types = M.insert (moduleName, name) (ctorKind, Data) (types env) }
42 forM_ dctors $ \(dctor, maybeTy) ->
43 rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $
44 addDataConstructor moduleName name args dctor maybeTy
46addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> Maybe Type -> Check ()
47addDataConstructor moduleName name args dctor maybeTy = do
48 env <- getEnv
49 dataConstructorIsNotDefined moduleName dctor
50 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
51 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
52 let polyType = mkForAll args dctorTy
53 putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (polyType, DataConstructor) (dataConstructors env) }
55addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
56addTypeSynonym moduleName name args ty kind = do
57 env <- getEnv
58 putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env)
59 , typeSynonyms = M.insert (moduleName, name) (args, ty) (typeSynonyms env) }
61typeIsNotDefined :: ModuleName -> ProperName -> Check ()
62typeIsNotDefined moduleName name = do
63 env <- getEnv
64 guardWith (show name ++ " is already defined") $
65 not $ M.member (moduleName, name) (types env)
67dataConstructorIsNotDefined :: ModuleName -> ProperName -> Check ()
68dataConstructorIsNotDefined moduleName dctor = do
69 env <- getEnv
70 guardWith (show dctor ++ " is already defined") $
71 not $ M.member (moduleName, dctor) (dataConstructors env)
73valueIsNotDefined :: ModuleName -> Ident -> Check ()
74valueIsNotDefined moduleName name = do
75 env <- getEnv
76 case M.lookup (moduleName, name) (names env) of
77 Just _ -> throwError $ show name ++ " is already defined"
78 Nothing -> return ()
80addValue :: ModuleName -> Ident -> Type -> Check ()
81addValue moduleName name ty = do
82 env <- getEnv
83 putEnv (env { names = M.insert (moduleName, name) (ty, Value) (names env) })
85typeCheckAll :: ModuleName -> [Declaration] -> Check ()
86typeCheckAll _ [] = return ()
87typeCheckAll moduleName (DataDeclaration name args dctors : rest) = do
88 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
89 typeIsNotDefined moduleName name
90 ctorKind <- kindsOf moduleName name args (mapMaybe snd dctors)
91 addDataType moduleName name args dctors ctorKind
92 typeCheckAll moduleName rest
93typeCheckAll moduleName (DataBindingGroupDeclaration tys : rest) = do
94 rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do
95 forM_ tys $ \(name, _, _) ->
96 typeIsNotDefined moduleName name
97 ks <- kindsOfAll moduleName (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) tys)
98 forM (zip tys ks) $ \((name, args, dctors), ctorKind) ->
99 addDataType moduleName name args dctors ctorKind
100 typeCheckAll moduleName rest
101typeCheckAll moduleName (TypeSynonymDeclaration name args ty : rest) = do
102 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
103 typeIsNotDefined moduleName name
104 kind <- kindsOf moduleName name args [ty]
105 addTypeSynonym moduleName name args ty kind
106 typeCheckAll moduleName rest
107typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
108typeCheckAll moduleName (ValueDeclaration name [] Nothing val : rest) = do
109 rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do
110 valueIsNotDefined moduleName name
111 [ty] <- typesOf moduleName [(name, val)]
112 addValue moduleName name ty
113 typeCheckAll moduleName rest
114typeCheckAll _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
115typeCheckAll moduleName (BindingGroupDeclaration vals : rest) = do
116 rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do
117 forM_ (map fst vals) $ \name ->
118 valueIsNotDefined moduleName name
119 tys <- typesOf moduleName vals
120 forM (zip (map fst vals) tys) $ \(name, ty) ->
121 addValue moduleName name ty
122 typeCheckAll moduleName rest
123typeCheckAll moduleName (ExternDataDeclaration name kind : rest) = do
124 env <- getEnv
125 guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)
126 putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }
127 typeCheckAll moduleName rest
128typeCheckAll moduleName (ExternDeclaration name _ ty : rest) = do
129 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
130 env <- getEnv
131 kind <- kindOf moduleName ty
132 guardWith "Expected kind *" $ kind == Star
133 case M.lookup (moduleName, name) (names env) of
134 Just _ -> throwError $ show name ++ " is already defined"
135 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env) })
136 typeCheckAll moduleName rest
137typeCheckAll moduleName (FixityDeclaration _ name : rest) = do
138 typeCheckAll moduleName rest
139 env <- getEnv
140 guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env
141typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do
142 env <- getEnv
143 rethrow errorMessage $ do
144 guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env
145 case idents of
146 Nothing -> do
147 shadowIdents (map snd $ filterModule (names env)) env
148 shadowTypes (map snd $ filterModule (types env)) env
149 Just idents' -> do
150 shadowIdents (lefts idents') env
151 shadowTypes (rights idents') env
152 typeCheckAll currentModule rest
153 where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
154 filterModule = filter ((== moduleName) . fst) . M.keys
155 moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
156 shadowIdents idents' env =
157 forM_ idents' $ \ident -> do
158 case (moduleName, ident) `M.lookup` names env of
159 Just (_, Alias _ _) -> return ()
160 Just (pt, _) -> do
161 guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
162 modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
163 Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
164 shadowTypes pns env =
165 forM_ pns $ \pn -> do
166 case (moduleName, pn) `M.lookup` types env of
167 Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
168 Just (_, DataAlias _ _) -> return ()
169 Just (k, _) -> do
170 guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
171 modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
172 let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env
173 forM_ keys $ \dctor -> do
174 case (moduleName, dctor) `M.lookup` dataConstructors env of
175 Just (_, Alias _ _) -> return ()
176 Just (ctorTy, _) -> do
177 guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
178 modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })
179 Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")
180 constructs (TypeConstructor (Qualified (Just mn) pn')) pn
181 = mn == moduleName && pn' == pn
182 constructs (ForAll _ ty) pn = ty `constructs` pn
183 constructs (Function _ ty) pn = ty `constructs` pn
184 constructs (TypeApp ty _) pn = ty `constructs` pn
185 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn