├── test-suite ├── Main.hs └── Language │ └── HigherRank │ ├── TH.hs │ └── TypecheckSpec.hs ├── executable └── Main.hs ├── stack.yaml ├── .gitignore ├── Setup.hs ├── LICENSE ├── library └── Language │ └── HigherRank │ ├── Main.hs │ ├── Print.hs │ ├── Types.hs │ ├── Interpret.hs │ ├── Parse.hs │ └── Typecheck.hs ├── package.yaml └── README.md /test-suite/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} -------------------------------------------------------------------------------- /executable/Main.hs: -------------------------------------------------------------------------------- 1 | import qualified Language.HigherRank.Main as Lib 2 | 3 | main :: IO () 4 | main = Lib.main 5 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.9 2 | 3 | packages: ['.'] 4 | extra-deps: [] 5 | 6 | flags: {} 7 | 8 | extra-package-dbs: [] 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Stack uses this directory as scratch space. 2 | /.stack-work/ 3 | # Stack generates the Cabal file from `package.yaml` through hpack. 4 | /*.cabal 5 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | -- This script is used to build and install your package. Typically you don't 2 | -- need to change it. The Cabal documentation has more information about this 3 | -- file: . 4 | import qualified Distribution.Simple 5 | 6 | main :: IO () 7 | main = Distribution.Simple.defaultMain 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017 Alexis King 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose 4 | with or without fee is hereby granted, provided that the above copyright notice 5 | and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 8 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 9 | FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 10 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS 11 | OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 12 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF 13 | THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /library/Language/HigherRank/Main.hs: -------------------------------------------------------------------------------- 1 | module Language.HigherRank.Main (main) where 2 | 3 | import System.Console.Haskeline 4 | 5 | import Language.HigherRank.Interpret (runInterpret) 6 | import Language.HigherRank.Parse (parseExpr) 7 | import Language.HigherRank.Print (printReducedExpr, printType) 8 | import Language.HigherRank.Typecheck (runInfer) 9 | 10 | fromEither :: Either a a -> a 11 | fromEither (Left x) = x 12 | fromEither (Right x) = x 13 | 14 | repl :: (String -> String) -> IO () 15 | repl f = runInputT defaultSettings loop 16 | where loop = getInputLine "> " >>= \case 17 | Nothing -> return () 18 | Just l -> outputStrLn (f l) >> loop 19 | 20 | main :: IO () 21 | main = repl $ \input -> fromEither $ do 22 | e <- parseExpr input 23 | t <- runInfer e 24 | r <- runInterpret e 25 | return $ printReducedExpr r ++ " : " ++ printType t 26 | -------------------------------------------------------------------------------- /library/Language/HigherRank/Print.hs: -------------------------------------------------------------------------------- 1 | module Language.HigherRank.Print (printExpr, printReducedExpr, printType) where 2 | 3 | import Language.HigherRank.Types 4 | 5 | printExpr :: Expr -> String 6 | printExpr EUnit = "()" 7 | printExpr (EVar (MkEVar x)) = x 8 | printExpr (EAnn e t) = "(" ++ printExpr e ++ " : " ++ printType t ++ ")" 9 | printExpr (ELam (MkEVar x) e) = "(\\" ++ x ++ " -> " ++ printExpr e ++ ")" 10 | printExpr (EApp a b) = "(" ++ printExpr a ++ " " ++ printExpr b ++ ")" 11 | 12 | printReducedExpr :: ReducedExpr -> String 13 | printReducedExpr REUnit = "()" 14 | printReducedExpr (RELam _ (MkEVar x) e) = "(\\" ++ x ++ " -> " ++ printExpr e ++ ")" 15 | 16 | printType :: Type -> String 17 | printType TUnit = "()" 18 | printType (TVar (MkTVar x)) = x 19 | printType (TEVar (MkTEVar x)) = x ++ "'" 20 | printType (TArr a b) = "(" ++ printType a ++ " -> " ++ printType b ++ ")" 21 | printType (TAll (MkTVar v) a) = "(forall " ++ v ++ ". " ++ printType a ++ ")" 22 | -------------------------------------------------------------------------------- /test-suite/Language/HigherRank/TH.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | 4 | module Language.HigherRank.TH (exprQ, typeQ) where 5 | 6 | import Language.Haskell.TH.Quote 7 | import Language.Haskell.TH.Syntax (Lift(..)) 8 | 9 | import Language.HigherRank.Parse 10 | import Language.HigherRank.Types 11 | 12 | deriving instance Lift EVar 13 | deriving instance Lift Expr 14 | deriving instance Lift TEVar 15 | deriving instance Lift TVar 16 | deriving instance Lift Type 17 | 18 | voidQ :: QuasiQuoter 19 | voidQ = QuasiQuoter 20 | { quoteExp = fail "cannot be used in expression position" 21 | , quotePat = fail "cannot be used in pattern position" 22 | , quoteType = fail "cannot be used in type position" 23 | , quoteDec = fail "cannot be used in declaration position" 24 | } 25 | 26 | exprQ :: QuasiQuoter 27 | exprQ = voidQ { quoteExp = either fail lift . parseExpr } 28 | 29 | typeQ :: QuasiQuoter 30 | typeQ = voidQ { quoteExp = either fail lift . parseType } 31 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: higher-rank 2 | version: '0.0.0' 3 | category: Other 4 | synopsis: A new Haskeleton package. 5 | description: higher-rank is a new Haskeleton package. 6 | maintainer: Alexis King 7 | 8 | extra-source-files: 9 | - package.yaml 10 | - README.md 11 | - stack.yaml 12 | 13 | ghc-options: -Wall 14 | default-extensions: 15 | - ApplicativeDo 16 | - GeneralizedNewtypeDeriving 17 | - LambdaCase 18 | - StandaloneDeriving 19 | 20 | library: 21 | dependencies: 22 | - base 23 | - containers 24 | - haskeline 25 | - megaparsec 26 | - mtl 27 | source-dirs: library 28 | 29 | executables: 30 | higher-rank: 31 | dependencies: 32 | - base 33 | - higher-rank 34 | ghc-options: 35 | - -rtsopts 36 | - -threaded 37 | - -with-rtsopts=-N 38 | main: Main.hs 39 | source-dirs: executable 40 | 41 | tests: 42 | higher-rank-test-suite: 43 | dependencies: 44 | - base 45 | - higher-rank 46 | - hspec 47 | - template-haskell 48 | ghc-options: 49 | - -rtsopts 50 | - -threaded 51 | - -with-rtsopts=-N 52 | main: Main.hs 53 | source-dirs: test-suite 54 | -------------------------------------------------------------------------------- /library/Language/HigherRank/Types.hs: -------------------------------------------------------------------------------- 1 | module Language.HigherRank.Types where 2 | 3 | import Data.Map (Map) 4 | 5 | -------------------------------------------------------------------------------- 6 | -- Expressions (interpreter & typechecker) 7 | 8 | newtype EVar = MkEVar { unEVar :: String } 9 | deriving (Eq, Ord, Show) 10 | 11 | data Expr 12 | = EUnit 13 | | EVar EVar 14 | | EAnn Expr Type 15 | | ELam EVar Expr 16 | | EApp Expr Expr 17 | deriving (Eq, Ord, Show) 18 | 19 | -------------------------------------------------------------------------------- 20 | -- Types (typechecker) 21 | 22 | newtype TVar = MkTVar { unTVar :: String } 23 | deriving (Eq, Ord, Show) 24 | 25 | newtype TEVar = MkTEVar { unTEVar :: String } 26 | deriving (Eq, Ord, Show) 27 | 28 | data Type 29 | = TUnit 30 | | TVar TVar 31 | | TEVar TEVar 32 | | TArr Type Type 33 | | TAll TVar Type 34 | deriving (Eq, Ord, Show) 35 | 36 | -------------------------------------------------------------------------------- 37 | -- Reduced expressions (interpreter) 38 | 39 | data ReducedExpr 40 | = REUnit 41 | | RELam Env EVar Expr 42 | deriving (Eq, Show) 43 | 44 | newtype Env = Env (Map EVar ReducedExpr) 45 | deriving (Eq, Show, Monoid) 46 | -------------------------------------------------------------------------------- /test-suite/Language/HigherRank/TypecheckSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module Language.HigherRank.TypecheckSpec (spec) where 4 | 5 | import Test.Hspec 6 | 7 | import Language.HigherRank.TH 8 | import Language.HigherRank.Typecheck 9 | 10 | spec :: Spec 11 | spec = describe "Typecheck" $ do 12 | describe "()" $ 13 | it "has type ()" $ 14 | runInfer [exprQ|()|] `shouldBe` Right [typeQ|()|] 15 | 16 | describe "function application" $ do 17 | it "has the type of its result" $ 18 | runInfer [exprQ|((\x -> x) ())|] `shouldBe` Right [typeQ|()|] 19 | 20 | it "supports higher-order functions" $ 21 | runInfer [exprQ|((\f -> (f ())) (\x -> x))|] 22 | `shouldBe` Right [typeQ|()|] 23 | 24 | it "produces a type error when applied with the wrong type" $ 25 | runInfer [exprQ|((\f -> (f ())) ())|] 26 | `shouldBe` Left "type mismatch: expected (() -> a4'), given ()" 27 | 28 | it "supports higher-rank polymorphism" $ 29 | runInfer [exprQ|(((\f -> ((f (\y -> y)) (f ()))) 30 | : ((forall a. (a -> a)) -> ())) 31 | (\x -> x))|] 32 | `shouldBe` Right [typeQ|()|] 33 | 34 | it "produces a type error when given a function of insufficient generality" $ 35 | runInfer [exprQ|(((\f -> ((f (\y -> y)) (f ()))) 36 | : ((forall a. (a -> a)) -> ())) 37 | ((\x -> x) : (() -> ())))|] 38 | `shouldBe` Left "type mismatch: expected (), given a" 39 | -------------------------------------------------------------------------------- /library/Language/HigherRank/Interpret.hs: -------------------------------------------------------------------------------- 1 | module Language.HigherRank.Interpret (runInterpret) where 2 | 3 | import qualified Data.Map as M 4 | 5 | import Control.Monad.Except (MonadError, Except, runExcept, throwError) 6 | import Control.Monad.Reader (MonadReader, ReaderT, ask, local, runReaderT) 7 | 8 | import Language.HigherRank.Print (printReducedExpr) 9 | import Language.HigherRank.Types 10 | 11 | newtype InterpretM a = InterpretM (ReaderT Env (Except String) a) 12 | deriving (Functor, Applicative, Monad, MonadReader Env, MonadError String) 13 | 14 | runInterpretM :: InterpretM a -> Either String a 15 | runInterpretM (InterpretM x) = runExcept $ runReaderT x mempty 16 | 17 | lookupVar :: EVar -> InterpretM ReducedExpr 18 | lookupVar x = do 19 | Env env <- ask 20 | maybe (throwError $ "unbound variable " ++ unEVar x) return $ M.lookup x env 21 | 22 | withBinding :: EVar -> ReducedExpr -> InterpretM a -> InterpretM a 23 | withBinding x e = local $ \(Env env) -> Env $ M.insert x e env 24 | 25 | close :: InterpretM Env 26 | close = ask 27 | 28 | open :: Env -> InterpretM a -> InterpretM a 29 | open env = local (const env) 30 | 31 | interpret :: Expr -> InterpretM ReducedExpr 32 | interpret EUnit = return REUnit 33 | interpret (EVar x) = lookupVar x 34 | interpret (EAnn e _) = interpret e 35 | interpret (ELam x e) = RELam <$> close <*> pure x <*> pure e 36 | interpret (EApp f a) = interpret f >>= \case 37 | RELam env x e -> interpret a >>= \b -> open env (withBinding x b (interpret e)) 38 | other -> throwError $ "cannot apply non-function value " ++ printReducedExpr other 39 | 40 | runInterpret :: Expr -> Either String ReducedExpr 41 | runInterpret = runInterpretM . interpret 42 | -------------------------------------------------------------------------------- /library/Language/HigherRank/Parse.hs: -------------------------------------------------------------------------------- 1 | module Language.HigherRank.Parse (parseExpr, parseType) where 2 | 3 | import Data.Functor (($>)) 4 | import Text.Megaparsec 5 | import Text.Megaparsec.String 6 | 7 | import Language.HigherRank.Types 8 | 9 | identifierP :: Parser String 10 | identifierP = (:) <$> letterChar <*> many alphaNumChar 11 | 12 | eunitP :: Parser Expr 13 | eunitP = string "()" $> EUnit "unit" 14 | 15 | evarP :: Parser EVar 16 | evarP = MkEVar <$> identifierP "variable" 17 | 18 | eannP :: Parser Expr 19 | eannP = EAnn <$> (char '(' *> space *> exprP <* space <* char ':') 20 | <*> (space *> typeP <* space <* char ')') 21 | "annotated expression" 22 | 23 | elamP :: Parser Expr 24 | elamP = ELam <$> (char '(' *> space *> char '\\' *> space *> evarP) 25 | <*> (space *> string "->" *> space *> exprP <* space <* char ')') 26 | "function" 27 | 28 | eappP :: Parser Expr 29 | eappP = EApp <$> (char '(' *> space *> exprP) 30 | <*> (space *> exprP <* space <* char ')') 31 | "function application" 32 | 33 | exprP :: Parser Expr 34 | exprP = (EVar <$> evarP) 35 | <|> try eunitP 36 | <|> try eannP 37 | <|> try elamP 38 | <|> eappP 39 | "expression" 40 | 41 | tunitP :: Parser Type 42 | tunitP = string "()" $> TUnit "unit" 43 | 44 | tvarP :: Parser TVar 45 | tvarP = MkTVar <$> identifierP "type variable" 46 | 47 | tarrP :: Parser Type 48 | tarrP = TArr <$> (char '(' *> space *> typeP <* space <* string "->") 49 | <*> (space *> typeP <* space <* char ')') 50 | "function type" 51 | 52 | tallP :: Parser Type 53 | tallP = TAll <$> (char '(' *> space *> string "forall" *> space *> tvarP <* space <* char '.') 54 | <*> (space *> typeP <* space <* char ')') 55 | "forall type" 56 | 57 | typeP :: Parser Type 58 | typeP = (TVar <$> tvarP) 59 | <|> try tunitP 60 | <|> try tarrP 61 | <|> try tallP 62 | "type" 63 | 64 | execParser :: Parser a -> String -> Either String a 65 | execParser p str = case parse (p <* eof) "" str of 66 | Right expr -> Right expr 67 | Left err -> Left $ parseErrorPretty err 68 | 69 | parseExpr :: String -> Either String Expr 70 | parseExpr = execParser exprP 71 | 72 | parseType :: String -> Either String Type 73 | parseType = execParser typeP 74 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # higher-rank 2 | 3 | A small Haskell implementation of [Complete and Easy Bidirectional Typechecking 4 | for Higher-Rank Polymorphism][complete-and-easy]. This is a sister project to [the Racket implementation][racket-higher-rank], which is adapted from this one. 5 | 6 | This implementation is designed to be both simple and relatively complete. Where the two conflict, it prefers simplicity. This means that there is no source location reporting for type errors, for example, which would considerably complicate the implementation, but it *does* attempt to provide good error messages with the information it has. 7 | 8 | The executable built by this project implements a simple REPL. You can run it from the command line with `stack`: 9 | 10 | ``` 11 | $ stack build 12 | $ stack exec higher-rank 13 | > () 14 | () : () 15 | > (\x -> x) 16 | (\x -> x) : (a1' -> a1') 17 | > ((\x -> x) ()) 18 | () : () 19 | ``` 20 | 21 | The implementation is divided among the following modules: 22 | 23 | - `Language.HigherRank.Types` — Holds type definitions used by other modules. This module mostly only exists to break module loading cycles between the printer and interpreter/typechecker. 24 | 25 | - `Language.HigherRank.Typecheck` — The core implementation of the typechecker, which contains all of the code that implements the actual paper. If you are only interested in the typechecking algorithm and aren’t interested in the interpreter or REPL, you can focus exclusively on this module and `Language.HigherRank.Types`. 26 | 27 | - `Language.HigherRank.Interpret` — Contains the implementation of a very simple interpreter, which evaluates expressions without doing any typechecking. 28 | 29 | - `Language.HigherRank.Parse` — Contains monadic parsers for parsing both types and expressions, the results of which may be fed to the typechecker or interpreter. 30 | 31 | - `Language.HigherRank.Print` — Implements pretty-printers for types, expressions, and reduced expressions, which are the results of the interpreter. This is used to print results in the REPL as well as format types and expressions in error messages. 32 | 33 | - `Language.HigherRank.Main` — This implements the actual REPL by combining all of the above pieces together. 34 | 35 | [complete-and-easy]: http://www.cs.cmu.edu/~joshuad/papers/bidir/ 36 | [racket-higher-rank]: https://github.com/lexi-lambda/racket-higher-rank 37 | -------------------------------------------------------------------------------- /library/Language/HigherRank/Typecheck.hs: -------------------------------------------------------------------------------- 1 | module Language.HigherRank.Typecheck (runInfer) where 2 | 3 | import qualified Data.Sequence as S 4 | 5 | import Control.Monad (unless) 6 | import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError) 7 | import Control.Monad.State (MonadState, State, evalState, get, gets, put, modify) 8 | import Data.Foldable (toList) 9 | import Data.Maybe (isJust) 10 | import Data.Monoid ((<>)) 11 | import Data.Sequence (Seq) 12 | 13 | import Language.HigherRank.Print (printExpr, printType) 14 | import Language.HigherRank.Types 15 | 16 | isMono :: Type -> Bool 17 | isMono TUnit = True 18 | isMono (TVar _) = True 19 | isMono (TEVar _) = True 20 | isMono (TArr a b) = isMono a && isMono b 21 | isMono (TAll _ _) = False 22 | 23 | data CtxMember 24 | = CtxVar TVar 25 | | CtxAssump EVar Type 26 | | CtxEVar TEVar 27 | | CtxSolved TEVar Type 28 | | CtxMarker TEVar 29 | deriving (Eq, Ord, Show) 30 | 31 | newtype Ctx = Ctx (Seq CtxMember) 32 | deriving (Eq, Show, Monoid) 33 | 34 | (|>) :: Ctx -> CtxMember -> Ctx 35 | (Ctx ctx) |> mem = Ctx (ctx S.|> mem) 36 | 37 | ctxElem :: CtxMember -> Ctx -> Bool 38 | ctxElem x (Ctx ctx) = x `elem` ctx 39 | 40 | ctxHole :: CtxMember -> Ctx -> Maybe (Ctx, Ctx) 41 | ctxHole mem (Ctx ctx) = if mem `elem` ctx then Just (Ctx a, Ctx (S.drop 1 b)) else Nothing 42 | where (a, b) = S.breakl (== mem) ctx 43 | 44 | ctxHole2 :: CtxMember -> CtxMember -> Ctx -> Maybe (Ctx, Ctx, Ctx) 45 | ctxHole2 mem mem' ctx = do 46 | (a, ctx') <- ctxHole mem ctx 47 | (b, c) <- ctxHole mem' ctx' 48 | return (a, b, c) 49 | 50 | ctxAssump :: Ctx -> EVar -> Maybe Type 51 | ctxAssump (Ctx ctx) x = case assumptions of 52 | [CtxAssump _ t] -> Just t 53 | [] -> Nothing 54 | other -> error $ "ctxSolution: internal error — multiple types for variable: " ++ show other 55 | where isAssump (CtxAssump y _) = x == y 56 | isAssump _ = False 57 | assumptions = filter isAssump $ toList ctx 58 | 59 | ctxSolution :: Ctx -> TEVar -> Maybe Type 60 | ctxSolution (Ctx ctx) v = case solutions of 61 | [CtxSolved _ t] -> Just t 62 | [] -> Nothing 63 | other -> error $ "ctxSolution: internal error — multiple solutions for variable: " ++ show other 64 | where isSolution (CtxSolved u _) = v == u 65 | isSolution _ = False 66 | solutions = filter isSolution $ toList ctx 67 | 68 | ctxUntil :: CtxMember -> Ctx -> Ctx 69 | ctxUntil m (Ctx ctx) = Ctx $ S.takeWhileL (/= m) ctx 70 | 71 | typeWF, (⊢) :: Ctx -> Type -> Either String () 72 | typeWF _ TUnit = return () 73 | typeWF ctx (TVar v) = unless (CtxVar v `ctxElem` ctx) $ Left $ "unbound type variable ‘" ++ unTVar v ++ "’" 74 | typeWF ctx (TEVar v) = unless (CtxEVar v `ctxElem` ctx || hasSolution) $ Left $ "unbound existential variable ‘" ++ unTEVar v ++ "’" 75 | where hasSolution = isJust (ctxSolution ctx v) 76 | typeWF ctx (TArr x y) = typeWF ctx x >> typeWF ctx y 77 | typeWF ctx (TAll v t) = typeWF (ctx |> CtxVar v) t 78 | 79 | (⊢) = typeWF 80 | 81 | freeVars :: Type -> [TEVar] 82 | freeVars TUnit = [] 83 | freeVars (TVar _) = [] 84 | freeVars (TEVar v) = [v] 85 | freeVars (TArr a b) = freeVars a <> freeVars b 86 | freeVars (TAll _ t) = freeVars t 87 | 88 | applySubst :: Ctx -> Type -> Type 89 | applySubst _ TUnit = TUnit 90 | applySubst _ t@(TVar _) = t 91 | applySubst ctx t@(TEVar v) = maybe t (applySubst ctx) (ctxSolution ctx v) 92 | applySubst ctx (TArr a b) = TArr (applySubst ctx a) (applySubst ctx b) 93 | applySubst ctx (TAll v t) = TAll v (applySubst ctx t) 94 | 95 | inst :: (TVar, Type) -> Type -> Type 96 | inst _ TUnit = TUnit 97 | inst (v, s) t@(TVar v') 98 | | v == v' = s 99 | | otherwise = t 100 | inst _ t@(TEVar _) = t 101 | inst s (TArr a b) = TArr (inst s a) (inst s b) 102 | inst s (TAll v t) = TAll v (inst s t) 103 | 104 | -------------------------------------------------------------------------------- 105 | 106 | data CheckState = CheckState 107 | { checkCtx :: Ctx 108 | , checkNextEVar :: Integer 109 | } deriving (Eq, Show) 110 | 111 | defCheckState :: CheckState 112 | defCheckState = CheckState mempty 1 113 | 114 | getCtx :: CheckM Ctx 115 | getCtx = gets checkCtx 116 | 117 | putCtx :: Ctx -> CheckM () 118 | putCtx ctx = get >>= \s -> put s { checkCtx = ctx } 119 | 120 | modifyCtx :: (Ctx -> Ctx) -> CheckM () 121 | modifyCtx f = putCtx . f =<< getCtx 122 | 123 | freshEVar :: CheckM TEVar 124 | freshEVar = MkTEVar . ("a" ++) . show <$> gets checkNextEVar 125 | <* modify (\s -> s { checkNextEVar = checkNextEVar s + 1 }) 126 | 127 | checkTypeWF :: Type -> CheckM () 128 | checkTypeWF t = getCtx >>= \ctx -> either throwError return (typeWF ctx t) 129 | 130 | newtype CheckM a = CheckM (ExceptT String (State CheckState) a) 131 | deriving (Functor, Applicative, Monad, MonadState CheckState, MonadError String) 132 | 133 | runCheckM :: CheckM a -> Either String a 134 | runCheckM (CheckM x) = evalState (runExceptT x) defCheckState 135 | 136 | tySub :: Type -> Type -> CheckM () 137 | tySub TUnit TUnit = return () 138 | tySub (TVar a) (TVar b) | a == b = return () 139 | tySub (TEVar a) (TEVar b) | a == b = return () 140 | tySub (TArr a b) (TArr a' b') = tySub a' a >> tySub b b' 141 | tySub (TAll v a) b = do 142 | â <- freshEVar 143 | let a' = inst (v, TEVar â) a 144 | modifyCtx (\c -> c |> CtxMarker â |> CtxEVar â) 145 | tySub a' b 146 | modifyCtx (ctxUntil (CtxMarker â)) 147 | tySub a (TAll v b) = do 148 | modifyCtx (|> CtxVar v) 149 | tySub a b 150 | modifyCtx (ctxUntil (CtxVar v)) 151 | tySub (TEVar â) a | â `notElem` freeVars a = instL â a 152 | tySub a (TEVar â) | â `notElem` freeVars a = instR a â 153 | tySub a b = throwError $ "type mismatch: expected " ++ printType b ++ ", given " ++ printType a 154 | 155 | instL :: TEVar -> Type -> CheckM () 156 | instL â t = getCtx >>= go where 157 | -- Defer to a helper function so we can pattern match/guard against the 158 | -- current context. 159 | go ctx -- InstLSolve 160 | | True <- isMono t 161 | , Just (l, r) <- ctxHole (CtxEVar â) ctx 162 | , Right _ <- l ⊢ t 163 | = putCtx $ l |> CtxSolved â t <> r 164 | go ctx -- InstLReach 165 | | TEVar â' <- t 166 | , Just (l, m, r) <- ctxHole2 (CtxEVar â) (CtxEVar â') ctx 167 | = putCtx $ l |> CtxEVar â <> m |> CtxSolved â' (TEVar â) <> r 168 | go ctx -- InstLArr 169 | | Just (l, r) <- ctxHole (CtxEVar â) ctx 170 | , TArr a b <- t 171 | = do â1 <- freshEVar 172 | â2 <- freshEVar 173 | putCtx $ l |> CtxEVar â2 |> CtxEVar â1 |> CtxSolved â (TArr (TEVar â1) (TEVar â2)) <> r 174 | instR a â1 175 | ctx' <- getCtx 176 | instL â2 (applySubst ctx' b) 177 | go ctx -- InstLArrR 178 | | TAll b s <- t 179 | = do putCtx $ ctx |> CtxVar b 180 | instL â s 181 | Just (ctx', _) <- ctxHole (CtxVar b) <$> getCtx 182 | putCtx ctx' 183 | go _ = error $ "instL: failed to instantiate " ++ show â ++ " to " ++ show t 184 | 185 | instR :: Type -> TEVar -> CheckM () 186 | instR t â = getCtx >>= go where 187 | -- Defer to a helper function so we can pattern match/guard against the 188 | -- current context. 189 | go ctx -- InstRSolve 190 | | True <- isMono t 191 | , Just (l, r) <- ctxHole (CtxEVar â) ctx 192 | , Right _ <- l ⊢ t 193 | = putCtx $ l |> CtxSolved â t <> r 194 | go ctx -- InstRReach 195 | | TEVar â' <- t 196 | , Just (l, m, r) <- ctxHole2 (CtxEVar â) (CtxEVar â') ctx 197 | = putCtx $ l |> CtxEVar â <> m |> CtxSolved â' (TEVar â) <> r 198 | go ctx -- InstRArr 199 | | Just (l, r) <- ctxHole (CtxEVar â) ctx 200 | , TArr a b <- t 201 | = do â1 <- freshEVar 202 | â2 <- freshEVar 203 | putCtx $ l |> CtxEVar â2 |> CtxEVar â1 |> CtxSolved â (TArr (TEVar â1) (TEVar â2)) <> r 204 | instL â1 a 205 | ctx' <- getCtx 206 | instR (applySubst ctx' b) â2 207 | go ctx -- InstRArrL 208 | | TAll b s <- t 209 | = do â' <- freshEVar 210 | putCtx $ ctx |> CtxMarker â' |> CtxEVar â' 211 | instR (inst (b, TEVar â') s) â 212 | Just (ctx', _) <- ctxHole (CtxMarker â') <$> getCtx 213 | putCtx ctx' 214 | go _ = error $ "instR: failed to instantiate " ++ show â ++ " to " ++ show t 215 | 216 | check :: Expr -> Type -> CheckM () 217 | check EUnit TUnit = return () 218 | check e (TAll v a) = do 219 | modifyCtx (|> CtxVar v) 220 | check e a 221 | modifyCtx (ctxUntil (CtxVar v)) 222 | check (ELam x e) (TArr a b) = do 223 | modifyCtx (|> CtxAssump x a) 224 | check e b 225 | modifyCtx (ctxUntil (CtxAssump x a)) 226 | check e b = do 227 | a <- infer e 228 | ctx <- getCtx 229 | tySub (applySubst ctx a) (applySubst ctx b) 230 | 231 | infer :: Expr -> CheckM Type 232 | infer EUnit = return TUnit 233 | infer (EVar x) = do 234 | ctx <- getCtx 235 | maybe (throwError $ "unbound variable " ++ unEVar x) return (ctxAssump ctx x) 236 | infer (EAnn e a) = checkTypeWF a >> check e a >> return a 237 | infer (ELam x e) = do 238 | â <- freshEVar 239 | â' <- freshEVar 240 | modifyCtx (\c -> c |> CtxEVar â |> CtxEVar â' |> CtxAssump x (TEVar â)) 241 | check e (TEVar â') 242 | modifyCtx (ctxUntil (CtxAssump x (TEVar â))) 243 | return $ TArr (TEVar â) (TEVar â') 244 | infer (EApp e1 e2) = do 245 | a <- infer e1 246 | ctx <- getCtx 247 | inferApp (applySubst ctx a) e2 248 | 249 | inferApp :: Type -> Expr -> CheckM Type 250 | inferApp (TAll v a) e = do 251 | â <- freshEVar 252 | modifyCtx (|> CtxEVar â) 253 | inferApp (inst (v, TEVar â) a) e 254 | inferApp (TEVar â) e = do 255 | â1 <- freshEVar 256 | â2 <- freshEVar 257 | ctx <- getCtx 258 | let Just (l, r) = ctxHole (CtxEVar â) ctx 259 | putCtx $ l |> CtxEVar â2 |> CtxEVar â1 |> CtxSolved â (TArr (TEVar â1) (TEVar â2)) <> r 260 | check e (TEVar â1) 261 | return $ TEVar â2 262 | inferApp (TArr a c) e = check e a >> return c 263 | inferApp t e = throwError $ "cannot apply expression of type " ++ printType t ++ " to expression " ++ printExpr e 264 | 265 | runInfer :: Expr -> Either String Type 266 | runInfer e = do 267 | (t, ctx) <- runCheckM ((,) <$> infer e <*> getCtx) 268 | return $ applySubst ctx t 269 | --------------------------------------------------------------------------------