git.iko.soy/rowtype-yoga/purescript-native
on f96c9a1 help sign in
rowtype-yoga/purescript-native/src/PureScript/TypeChecker.hs
88 lines 3.5 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
33import PureScript.Values
34import PureScript.Types
35import PureScript.Kinds
36import PureScript.Declarations
38import Control.Monad.State
39import Control.Monad.Error
41import qualified Data.Map as M
43typeCheckAll :: [Declaration] -> Check ()
44typeCheckAll [] = return ()
45typeCheckAll (DataDeclaration name args ctors : rest) = do
46 rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do
47 env <- getEnv
48 guardWith (name ++ " is already defined") $ not $ M.member name (types env)
49 ctorKind <- kindsOf (Just name) args (catMaybes $ map snd ctors)
50 putEnv $ env { types = M.insert name (ctorKind, Data) (types env) }
51 flip mapM_ ctors $ \(dctor, maybeTy) ->
52 rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do
53 env' <- getEnv
54 guardWith (dctor ++ " is already defined") $ not $ flip M.member (names env') dctor
55 let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)
56 let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
57 let quantified = ForAll args dctorTy
58 putEnv $ env' { names = M.insert dctor (quantified, DataConstructor) (names env') }
59 typeCheckAll rest
60typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
61 rethrow (("Error in type synonym " ++ name ++ ": ") ++) $ do
62 env <- getEnv
63 guardWith (name ++ " is already defined") $ not $ M.member name (types env)
64 kind <- kindsOf (Just name) args [ty]
65 putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env)
66 , typeSynonyms = M.insert name (args, ty) (typeSynonyms env) }
67 typeCheckAll rest
68typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =
69 typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
70typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ name
71typeCheckAll (ValueDeclaration name val : rest) = do
72 rethrow (("Error in declaration " ++ name ++ ": ") ++) $ do
73 env <- getEnv
74 case M.lookup name (names env) of
75 Just ty -> throwError $ name ++ " is already defined"
76 Nothing -> do
77 ty <- typeOf name val
78 putEnv (env { names = M.insert name (ty, Value) (names env) })
79 typeCheckAll rest
80typeCheckAll (ExternDeclaration name ty : rest) = do
81 rethrow (("Error in extern declaration " ++ name ++ ": ") ++) $ do
82 env <- getEnv
83 kind <- kindOf ty
84 guardWith "Expected kind *" $ kind == Star
85 case M.lookup name (names env) of
86 Just _ -> throwError $ name ++ " is already defined"
87 Nothing -> putEnv (env { names = M.insert name (ty, Extern) (names env) })
88 typeCheckAll rest