git.iko.soy/rowtype-yoga/purescript-native
on f98236e help sign in
rowtype-yoga/purescript-native/src/PureScript/TypeChecker.hs
96 lines 3.8 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : 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 PureScript.TypeChecker (
18module T,
19 typeCheckAll
20) where
22import PureScript.TypeChecker.Monad as T
23import PureScript.TypeChecker.Kinds as T
24import PureScript.TypeChecker.Types as T
25import PureScript.TypeChecker.Synonyms as T
27import Data.List
28import Data.Maybe
29import Data.Function
30import qualified Data.Map as M
32import PureScript.Values
33import PureScript.Types
34import PureScript.Names
35import PureScript.Kinds
36import PureScript.Declarations
38import Control.Monad (forM_)
39import Control.Monad.State
40import Control.Monad.Error
42typeCheckAll :: [Declaration] -> Check ()
43typeCheckAll [] = return ()
44typeCheckAll (DataDeclaration name args dctors : rest) = do
45 rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do
46 env <- getEnv
47 guardWith (name ++ " is already defined") $ not $ M.member name (types env)
48 ctorKind <- kindsOf (Just name) args (mapMaybe snd dctors)
49 putEnv $ env { types = M.insert name (ctorKind, Data) (types env) }
50 forM_ dctors $ \(dctor, maybeTy) ->
51 rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do
52 env' <- getEnv
53 guardWith (dctor ++ " is already defined") $ not $ M.member dctor (dataConstructors env')
54 let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)
55 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
56 let polyType = PolyType args dctorTy
57 putEnv $ env' { dataConstructors = M.insert dctor polyType (dataConstructors env') }
58 typeCheckAll rest
59typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
60 rethrow (("Error in type synonym " ++ name ++ ": ") ++) $ do
61 env <- getEnv
62 guardWith (name ++ " is already defined") $ not $ M.member name (types env)
63 kind <- kindsOf (Just name) args [ty]
64 putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env)
65 , typeSynonyms = M.insert name (args, ty) (typeSynonyms env) }
66 typeCheckAll rest
67typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =
68 typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
69typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name
70typeCheckAll (ValueDeclaration name val : rest) = do
71 rethrow (("Error in declaration " ++ show name ++ ": ") ++) $ do
72 env <- getEnv
73 case M.lookup name (names env) of
74 Just ty -> throwError $ show name ++ " is already defined"
75 Nothing -> do
76 ty <- typeOf name val
77 putEnv (env { names = M.insert name (ty, Value) (names env) })
78 typeCheckAll rest
79typeCheckAll (ExternDataDeclaration name kind : rest) = do
80 env <- getEnv
81 guardWith (name ++ " is already defined") $ not $ M.member name (types env)
82 putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env) }
83 typeCheckAll rest
84typeCheckAll (ExternDeclaration name ty : rest) = do
85 rethrow (("Error in extern declaration " ++ show name ++ ": ") ++) $ do
86 env <- getEnv
87 kind <- kindOf ty
88 guardWith "Expected kind *" $ kind == Star
89 case M.lookup name (names env) of
90 Just _ -> throwError $ show name ++ " is already defined"
91 Nothing -> putEnv (env { names = M.insert name (ty, Extern) (names env) })
92 typeCheckAll rest
93typeCheckAll (FixityDeclaration _ name : rest) = do
94 typeCheckAll rest
95 env <- getEnv
96 guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (Op name) $ names env