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