git.iko.soy/rowtype-yoga/purescript-native
on bcc7e77 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/TypeChecker.hs
198 lines 9.9 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 (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 (ExternMemberDeclaration member name ty : rest) = do
129 rethrow (("Error in foreign import member 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 -> case ty of
136 _ | isSingleArgumentFunction ty -> do
137 putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env)
138 , members = M.insert (moduleName, name) member (members env) })
139 | otherwise -> throwError "Foreign member declarations must have function types, with an single argument."
140 typeCheckAll moduleName rest
141 where
142 isSingleArgumentFunction (Function [_] _) = True
143 isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t
144 isSingleArgumentFunction _ = False
145typeCheckAll moduleName (ExternDeclaration name ty : rest) = do
146 rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
147 env <- getEnv
148 kind <- kindOf moduleName ty
149 guardWith "Expected kind *" $ kind == Star
150 case M.lookup (moduleName, name) (names env) of
151 Just _ -> throwError $ show name ++ " is already defined"
152 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env) })
153 typeCheckAll moduleName rest
154typeCheckAll moduleName (FixityDeclaration _ name : rest) = do
155 typeCheckAll moduleName rest
156 env <- getEnv
157 guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env
158typeCheckAll currentModule (ImportDeclaration moduleName idents : rest) = do
159 env <- getEnv
160 rethrow errorMessage $ do
161 guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env
162 case idents of
163 Nothing -> do
164 shadowIdents (map snd $ filterModule (names env)) env
165 shadowTypes (map snd $ filterModule (types env)) env
166 Just idents' -> do
167 shadowIdents (lefts idents') env
168 shadowTypes (rights idents') env
169 typeCheckAll currentModule rest
170 where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
171 filterModule = filter ((== moduleName) . fst) . M.keys
172 moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
173 shadowIdents idents' env =
174 forM_ idents' $ \ident -> do
175 guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
176 case (moduleName, ident) `M.lookup` names env of
177 Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
178 Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
179 shadowTypes pns env =
180 forM_ pns $ \pn -> do
181 guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
182 case (moduleName, pn) `M.lookup` types env of
183 Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
184 Just (k, _) -> do
185 modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
186 let keys = map (snd . fst) . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env
187 forM_ keys $ \dctor -> do
188 guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
189 case (moduleName, dctor) `M.lookup` dataConstructors env of
190 Just ctorTy -> modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) ctorTy (dataConstructors e) })
191 Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")
192 constructs (TypeConstructor (Qualified (Just mn) pn')) pn
193 = mn == moduleName && pn' == pn
194 constructs (ForAll _ ty) pn = ty `constructs` pn
195 constructs (Function _ ty) pn = ty `constructs` pn
196 constructs (TypeApp ty _) pn = ty `constructs` pn
197 constructs fn _ = error $ "Invalid arguments to construct" ++ show fn