├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── bidi.cabal ├── diff ├── AST.diff └── NameGen.diff ├── package.yaml ├── src ├── AST.hs ├── Context.hs ├── Lib.hs ├── NameGen.hs ├── Pretty.hs ├── Type.hs └── Worklist.hs ├── stack.yaml ├── stack.yaml.lock └── test ├── Spec.hs └── result.txt /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for bidi 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2020 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # The bidirectional type checking algorithms for higher-ranked polymorphism 2 | 3 | - Two bidirectional type checking algorithms for higer-ranked polymorphism. 4 | 5 | * One is proposed by [Jana Dunfield and Neelakantan R. Krishnaswami's ICFP 2013 paper, Complete and easy bidirectional typechecking for higer-order rank polymorphism](https://research.cs.queensu.ca/home/jana/papers/bidir/). 6 | 7 | * The other algorithm based on so called work list proposed by [Jinxu Zhao, Bruno C. d. S. Oliveira1 , and Tom Schrijvers's ICFP 2019 paper, A Mechanical Formalization of Higher-Ranked Polymorphic Type Inference](https://i.cs.hku.hk/~bruno/papers/icfp2019.pdf) where the original algorithm is simplified and so mechanically proved using Abella. 8 | 9 | 10 | - Haskell Implementation of the two algorithms 11 | 12 | * One is [Olle Fredriksson](https://ollef.github.io/blog/)'s 13 | [implementation](https://github.com/ollef/Bidirectional) of 14 | Dunfield and Krishnaswami's algorithm, which I have slightly 15 | revised just to correct some version mismatch error. 16 | 17 | * I myself have implemented Zhao et al's algorithm. 18 | 19 | 20 | ## How to build and run 21 | 22 | ``` 23 | $ git clone https://github.com/kwanghoon/bidi 24 | $ cd bidi 25 | $ stack build 26 | 27 | ``` 28 | 29 | - To run the original DK's algorithm, 30 | 31 | ``` 32 | $ stack exec -- bidi-exe 33 | ``` 34 | 35 | - To run the new Zhao et al's algorithm, 36 | 37 | ``` 38 | $ stack exec -- bidi-exe worklist 39 | ``` 40 | 41 | ## A polymorphic location inference algorithm for higher-ranked polymorphism 42 | 43 | - In [PolyRPC](https://github.com/kwanghoon/polyrpc), I have 44 | implemented a location inference algorithm for the predicative 45 | System F with locations. The algorithms is closely related with the 46 | two algorithms. 47 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import AST 4 | import Context 5 | import NameGen 6 | import Pretty 7 | import Type 8 | import Worklist 9 | 10 | import System.Environment (getArgs, withArgs) 11 | 12 | main :: IO () 13 | main = 14 | do args <- getArgs 15 | if "worklist" `elem` args 16 | then runAlty 17 | else runBidi 18 | 19 | benchmark = 20 | [ 21 | idnotype, 22 | idunitnotype, 23 | polyidunit, 24 | eid, 25 | idunit, -- Todo: alty bug?? 26 | idid, 27 | ididunit 28 | ] 29 | 30 | runBidi = mapM_ run benchmark 31 | where 32 | run prog = 33 | let (polytype, context) = typesynthClosed prog 34 | str_prog = pretty prog 35 | str_context = pretty context 36 | str_polytype = pretty polytype 37 | in do putStrLn $ "Expr: " ++ str_prog 38 | putStrLn $ "Type: " ++ str_polytype 39 | putStrLn $ "Context: " ++ str_context 40 | putStrLn "" 41 | 42 | runAlty = mapM_ run benchmark 43 | where 44 | run prog = 45 | do let ty = altyClosed prog 46 | putStrLn $ "Expr : " ++ pretty prog 47 | putStrLn $ "Type : " ++ pretty ty 48 | 49 | 50 | -------------------------------------------------------------------------------- /bidi.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.4. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 5b7ca23ef31a198f44afbc1e2861d5b28475fe4a7d21c543419807146c7377b7 8 | 9 | name: bidi 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/githubuser/bidi#readme 13 | bug-reports: https://github.com/githubuser/bidi/issues 14 | author: Author name here 15 | maintainer: example@example.com 16 | copyright: 2020 Author name here 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/githubuser/bidi 27 | 28 | library 29 | exposed-modules: 30 | AST 31 | Context 32 | Lib 33 | NameGen 34 | Pretty 35 | Type 36 | Worklist 37 | other-modules: 38 | Paths_bidi 39 | hs-source-dirs: 40 | src 41 | build-depends: 42 | base >=4.7 && <5 43 | , containers >=0.6.2.1 44 | , mtl >=2.2.2 45 | default-language: Haskell2010 46 | 47 | executable bidi-exe 48 | main-is: Main.hs 49 | other-modules: 50 | Paths_bidi 51 | hs-source-dirs: 52 | app 53 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 54 | build-depends: 55 | base >=4.7 && <5 56 | , bidi 57 | default-language: Haskell2010 58 | 59 | test-suite bidi-test 60 | type: exitcode-stdio-1.0 61 | main-is: Spec.hs 62 | other-modules: 63 | Paths_bidi 64 | hs-source-dirs: 65 | test 66 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 67 | build-depends: 68 | base >=4.7 && <5 69 | , bidi 70 | default-language: Haskell2010 71 | -------------------------------------------------------------------------------- /diff/AST.diff: -------------------------------------------------------------------------------- 1 | 6d5 2 | < import Data.Semigroup 3 | 158,160d156 4 | < 5 | < instance Semigroup (GContext a) where 6 | < (Context gamma) <> (Context delta) = Context (delta ++ gamma) 7 | -------------------------------------------------------------------------------- /diff/NameGen.diff: -------------------------------------------------------------------------------- 1 | 33,38c33,35 2 | < vvs <- gets varNames 3 | < case vvs of 4 | < (v:vs) -> do 5 | < modify $ \s -> s {varNames = vs} 6 | < return v 7 | < [] -> error "No fresh variable can be created." 8 | --- 9 | > v:vs <- gets varNames 10 | > modify $ \s -> s {varNames = vs} 11 | > return v 12 | 43,48c40,42 13 | < vvs <- gets tvarNames 14 | < case vvs of 15 | < (v:vs) -> do 16 | < modify $ \s -> s {tvarNames = vs} 17 | < return v 18 | < [] -> error "No fresh type variable can be created." 19 | --- 20 | > v:vs <- gets tvarNames 21 | > modify $ \s -> s {tvarNames = vs} 22 | > return v 23 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: bidi 2 | version: 0.1.0.0 3 | github: "githubuser/bidi" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2020 Author name here" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | dependencies: 28 | - containers >= 0.6.2.1 29 | - mtl >= 2.2.2 30 | 31 | executables: 32 | bidi-exe: 33 | main: Main.hs 34 | source-dirs: app 35 | ghc-options: 36 | - -threaded 37 | - -rtsopts 38 | - -with-rtsopts=-N 39 | dependencies: 40 | - bidi 41 | 42 | tests: 43 | bidi-test: 44 | main: Spec.hs 45 | source-dirs: test 46 | ghc-options: 47 | - -threaded 48 | - -rtsopts 49 | - -with-rtsopts=-N 50 | dependencies: 51 | - bidi 52 | -------------------------------------------------------------------------------- /src/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, StandaloneDeriving #-} 2 | -- | Abstract syntax 3 | module AST where 4 | import Control.Applicative 5 | import Data.Monoid 6 | import Data.Semigroup 7 | import Data.Set(Set) 8 | import qualified Data.Set as S 9 | 10 | -- | Expressions 11 | data Expr 12 | = EVar Var -- ^ x 13 | | EUnit -- ^ () 14 | | EAbs Var Expr -- ^ \x. e 15 | | EApp Expr Expr -- ^ e1 e2 16 | | EAnno Expr Polytype -- ^ e : A 17 | deriving (Eq, Show) 18 | 19 | -- | subst e' x e = [e'/x]e 20 | subst :: Expr -> Var -> Expr -> Expr 21 | subst e' x expr = case expr of 22 | EVar x' | x' == x -> e' 23 | | otherwise -> EVar x' 24 | EUnit -> EUnit 25 | EAbs x' e | x' == x -> EAbs x' e 26 | | otherwise -> EAbs x' (subst e' x e) 27 | EApp e1 e2 -> EApp (subst e' x e1) (subst e' x e2) 28 | EAnno e t -> EAnno (subst e' x e) t 29 | 30 | -- Smart constructors 31 | var :: String -> Expr 32 | var = EVar . Var 33 | eunit :: Expr 34 | eunit = EUnit 35 | eabs :: String -> Expr -> Expr 36 | eabs = EAbs . Var 37 | infixr 1 $$ 38 | ($$) :: Expr -> Expr -> Expr 39 | ($$) = EApp 40 | (-:) :: Expr -> Polytype -> Expr 41 | (-:) = EAnno 42 | 43 | newtype Var = Var String deriving (Eq, Ord, Show) 44 | newtype TVar = TypeVar String deriving (Eq, Ord, Show) 45 | 46 | data TypeKind = Mono | Poly 47 | 48 | -- | Types, indexed by their kind: Monotype or Polytype. 49 | -- Only Polytypes can have foralls. 50 | data Type :: TypeKind -> * where 51 | TUnit :: Type a -- ^ () 52 | TVar :: TVar -> Type a -- ^ alpha 53 | TExists :: TVar -> Type a -- ^ alpha^ 54 | TForall :: TVar -> Type Poly -> Type Poly -- ^ forall alpha. A 55 | TFun :: Type a -> Type a -> Type a -- ^ A -> B 56 | deriving instance Show (Type a) 57 | deriving instance Eq (Type a) 58 | 59 | -- Smart constructors 60 | tunit :: Type a 61 | tunit = TUnit 62 | tvar :: String -> Type a 63 | tvar = TVar . TypeVar 64 | exists :: String -> Type a 65 | exists = TExists . TypeVar 66 | tforall :: String -> Polytype -> Polytype 67 | tforall = TForall . TypeVar 68 | (-->) :: Type a -> Type a -> Type a 69 | (-->) = TFun 70 | infixr 1 --> 71 | 72 | tforalls :: [TVar] -> Polytype -> Polytype 73 | tforalls = flip (foldr TForall) 74 | 75 | type Polytype = Type Poly 76 | type Monotype = Type Mono 77 | 78 | -- | Is the type a Monotype? 79 | monotype :: Type a -> Maybe Monotype 80 | monotype typ = case typ of 81 | TUnit -> Just TUnit 82 | TVar v -> Just $ TVar v 83 | TForall _ _ -> Nothing 84 | TExists v -> Just $ TExists v 85 | TFun t1 t2 -> TFun <$> monotype t1 <*> monotype t2 86 | 87 | -- | Any type is a Polytype since Monotype is a subset of Polytype 88 | polytype :: Type a -> Polytype 89 | polytype typ = case typ of 90 | TUnit -> TUnit 91 | TVar v -> TVar v 92 | TForall v t -> TForall v t 93 | TExists v -> TExists v 94 | TFun t1 t2 -> TFun (polytype t1) (polytype t2) 95 | 96 | -- | The free type variables in a type 97 | freeTVars :: Type a -> Set TVar 98 | freeTVars typ = case typ of 99 | TUnit -> mempty 100 | TVar v -> S.singleton v 101 | TForall v t -> S.delete v $ freeTVars t 102 | TExists v -> S.singleton v 103 | TFun t1 t2 -> freeTVars t1 `mappend` freeTVars t2 104 | 105 | -- | typeSubst A α B = [A/α]B 106 | typeSubst :: Type a -> TVar -> Type a -> Type a 107 | typeSubst t' v typ = case typ of 108 | TUnit -> TUnit 109 | TVar v' | v' == v -> t' 110 | | otherwise -> TVar v' 111 | TForall v' t | v' == v -> TForall v' t 112 | | otherwise -> TForall v' (typeSubst t' v t) 113 | TExists v' | v' == v -> t' 114 | | otherwise -> TExists v' 115 | TFun t1 t2 -> TFun (typeSubst t' v t1) (typeSubst t' v t2) 116 | 117 | typeSubsts :: [(Type a, TVar)] -> Type a -> Type a 118 | typeSubsts = flip $ foldr $ uncurry typeSubst 119 | 120 | 121 | data ContextKind = Complete | Incomplete 122 | 123 | -- | Context elements, indexed by their kind: Complete or Incomplete. 124 | -- Only Incomplete contexts can have unsolved existentials. 125 | data ContextElem :: ContextKind -> * where 126 | CForall :: TVar -> ContextElem a -- ^ alpha 127 | CVar :: Var -> Polytype -> ContextElem a -- ^ x : A 128 | CExists :: TVar -> ContextElem Incomplete -- ^ alpha^ 129 | CExistsSolved :: TVar -> Monotype -> ContextElem a -- ^ alpha^ = tau 130 | CMarker :: TVar -> ContextElem a -- ^ |> alpha^ 131 | deriving instance Eq (ContextElem a) 132 | deriving instance Show (ContextElem a) 133 | 134 | newtype GContext a = Context [ContextElem a] 135 | type CompleteContext = GContext Complete 136 | type Context = GContext Incomplete 137 | 138 | -- | Snoc 139 | (>:) :: GContext a -> ContextElem a -> GContext a 140 | Context gamma >: x = Context $ x : gamma 141 | 142 | -- | Context & list of elems append 143 | (>++) :: GContext a -> [ContextElem a] -> GContext a 144 | gamma >++ elems = gamma <> context elems 145 | 146 | context :: [ContextElem a] -> GContext a 147 | context = Context . reverse 148 | 149 | dropMarker :: ContextElem a -> GContext a -> GContext a 150 | dropMarker m (Context gamma) = Context $ tail $ dropWhile (/= m) gamma 151 | 152 | breakMarker :: ContextElem a -> GContext a -> (GContext a, GContext a) 153 | breakMarker m (Context xs) = let (r, _:l) = break (== m) xs in (Context l, Context r) 154 | 155 | instance Monoid (GContext a) where 156 | mempty = Context [] 157 | mappend (Context gamma) (Context delta) = Context (delta ++ gamma) 158 | 159 | instance Semigroup (GContext a) where 160 | (Context gamma) <> (Context delta) = Context (delta ++ gamma) 161 | -------------------------------------------------------------------------------- /src/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, DataKinds #-} 2 | -- | Some helpers for workingw ith contexts 3 | module Context where 4 | import Data.Maybe 5 | import Data.Monoid 6 | 7 | import AST 8 | import Pretty 9 | 10 | existentials :: Context -> [TVar] 11 | existentials (Context gamma) = aux =<< gamma 12 | where aux (CExists alpha) = [alpha] 13 | aux (CExistsSolved alpha _) = [alpha] 14 | aux _ = [] 15 | 16 | unsolved :: Context -> [TVar] 17 | unsolved (Context gamma) = [alpha | CExists alpha <- gamma] 18 | 19 | vars :: Context -> [Var] 20 | vars (Context gamma) = [x | CVar x _ <- gamma] 21 | 22 | foralls :: Context -> [TVar] 23 | foralls (Context gamma) = [alpha | CForall alpha <- gamma] 24 | 25 | markers :: Context -> [TVar] 26 | markers (Context gamma) = [alpha | CMarker alpha <- gamma] 27 | 28 | -- | Well-formedness of contexts 29 | -- wf Γ <=> Γ ctx 30 | wf :: Context -> Bool 31 | wf (Context gamma) = case gamma of 32 | -- EmptyCtx 33 | [] -> True 34 | c:cs -> let gamma' = Context cs in wf gamma' && case c of 35 | -- UvarCtx 36 | CForall alpha -> alpha `notElem` foralls gamma' 37 | -- VarCtx 38 | CVar x a -> x `notElem` vars gamma' && typewf gamma' a 39 | -- EvarCtx 40 | CExists alpha -> alpha `notElem` existentials gamma' 41 | -- SolvedEvarCtx 42 | CExistsSolved alpha tau -> alpha `notElem` existentials gamma' 43 | && typewf gamma' tau 44 | -- MarkerCtx 45 | CMarker alpha -> alpha `notElem` markers gamma' 46 | && alpha `notElem` existentials gamma' 47 | 48 | -- | Well-formedness of types 49 | -- typewf Γ A <=> Γ |- A 50 | typewf :: Context -> Type a -> Bool 51 | typewf gamma typ = case typ of 52 | -- UvarWF 53 | TVar alpha -> alpha `elem` foralls gamma 54 | -- UnitWF 55 | TUnit -> True 56 | -- ArrowWF 57 | TFun a b -> typewf gamma a && typewf gamma b 58 | -- ForallWF 59 | TForall alpha a -> typewf (gamma >: CForall alpha) a 60 | -- EvarWF and SolvedEvarWF 61 | TExists alpha -> alpha `elem` existentials gamma 62 | 63 | -- Assert-like functionality to make sure that contexts and types are 64 | -- well-formed 65 | checkwf :: Context -> x -> x 66 | checkwf gamma x | wf gamma = x 67 | | otherwise = error $ "Malformed context: " ++ pretty gamma 68 | 69 | checkwftype :: Context -> Polytype -> x -> x 70 | checkwftype gamma a x | typewf gamma a = checkwf gamma x 71 | | otherwise = error $ "Malformed type: " 72 | ++ pretty (a, gamma) 73 | 74 | -- | findSolved (ΓL,α^ = τ,ΓR) α = Just τ 75 | findSolved :: Context -> TVar -> Maybe Monotype 76 | findSolved (Context gamma) v = listToMaybe [t | CExistsSolved v' t <- gamma, v == v'] 77 | 78 | -- | findVarType (ΓL,x : A,ΓR) x = Just A 79 | findVarType :: Context -> Var -> Maybe Polytype 80 | findVarType (Context gamma) v = listToMaybe [t | CVar v' t <- gamma, v == v'] 81 | 82 | -- | solve (ΓL,α^,ΓR) α τ = (ΓL,α = τ,ΓR) 83 | solve :: Context -> TVar -> Monotype -> Maybe Context 84 | solve gamma alpha tau | typewf gammaL tau = Just gamma' 85 | | otherwise = Nothing 86 | where (gammaL, gammaR) = breakMarker (CExists alpha) gamma 87 | gamma' = gammaL >++ [CExistsSolved alpha tau] <> gammaR 88 | 89 | -- | insertAt (ΓL,c,ΓR) c Θ = ΓL,Θ,ΓR 90 | insertAt :: Context -> ContextElem Incomplete -> Context -> Context 91 | insertAt gamma c theta = gammaL <> theta <> gammaR 92 | where (gammaL, gammaR) = breakMarker c gamma 93 | 94 | -- | apply Γ A = [Γ]A 95 | apply :: Context -> Polytype -> Polytype 96 | apply gamma typ = case typ of 97 | TUnit -> TUnit 98 | TVar v -> TVar v 99 | TForall v t -> TForall v (apply gamma t) 100 | TExists v -> maybe (TExists v) (apply gamma . polytype) $ findSolved gamma v 101 | TFun t1 t2 -> apply gamma t1 `TFun` apply gamma t2 102 | 103 | -- | ordered Γ α β = True <=> Γ[α^][β^] 104 | ordered :: Context -> TVar -> TVar -> Bool 105 | ordered gamma alpha beta = 106 | let gammaL = dropMarker (CExists beta) gamma 107 | in alpha `elem` existentials gammaL 108 | -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /src/NameGen.hs: -------------------------------------------------------------------------------- 1 | -- | Name generation 2 | module NameGen where 3 | import Control.Monad.State 4 | 5 | import AST 6 | import Pretty 7 | 8 | import Debug.Trace 9 | 10 | data NameState = NameState 11 | { varNames :: [Var] 12 | , tvarNames :: [TVar] 13 | , indent :: Int -- This has no place here, but useful for debugging 14 | } 15 | 16 | initialNameState :: NameState 17 | initialNameState = NameState 18 | { varNames = map (Var . ('$':)) namelist 19 | , tvarNames = map (TypeVar . ('\'':)) namelist 20 | , indent = 0 21 | } 22 | where 23 | namelist = [1..] >>= flip replicateM ['a'..'z'] 24 | 25 | type NameGen a = State NameState a 26 | 27 | evalNameGen :: NameGen a -> a 28 | evalNameGen = flip evalState initialNameState 29 | 30 | -- | Create a fresh variable 31 | freshVar :: NameGen Var 32 | freshVar = do 33 | vvs <- gets varNames 34 | case vvs of 35 | (v:vs) -> do 36 | modify $ \s -> s {varNames = vs} 37 | return v 38 | [] -> error "No fresh variable can be created." 39 | 40 | -- | Create a fresh type variable 41 | freshTVar :: NameGen TVar 42 | freshTVar = do 43 | vvs <- gets tvarNames 44 | case vvs of 45 | (v:vs) -> do 46 | modify $ \s -> s {tvarNames = vs} 47 | return v 48 | [] -> error "No fresh type variable can be created." 49 | 50 | -- | Print some debugging info 51 | traceNS :: (Pretty a, Pretty b) => String -> a -> NameGen b -> NameGen b 52 | traceNS f args x = do 53 | ilevel <- gets indent 54 | let ind = replicate (ilevel * 3) ' ' 55 | trace (ind ++ f ++ pretty args) $ do 56 | modify $ \s -> s {indent = ilevel + 1} 57 | res <- x 58 | modify $ \s -> s {indent = ilevel} 59 | trace (ind ++ "=" ++ pretty res) $ return res 60 | 61 | traceSeq :: (Pretty a, Pretty b) => String -> a -> NameGen b -> NameGen b 62 | traceSeq f args x = do 63 | trace (f ++ " " ++ pretty args) $ 64 | do res <- x 65 | return res 66 | -------------------------------------------------------------------------------- /src/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | -- | Pretty printing 3 | module Pretty where 4 | import AST 5 | 6 | pretty :: Pretty a => a -> String 7 | pretty x = bpretty 0 x "" 8 | 9 | class Pretty a where 10 | bpretty :: Int -> a -> ShowS 11 | 12 | instance Pretty a => Pretty [a] where 13 | bpretty _ list = showString "[" . go list 14 | where 15 | go [] = showString "]" 16 | go [x] = bpretty 0 x . go [] 17 | go (x:xs) = bpretty 0 x . showString ", " . go xs 18 | 19 | instance (Pretty a, Pretty b) => Pretty (a, b) where 20 | bpretty _ (x, y) = 21 | showString "(" . bpretty 0 x . 22 | showString ", " . bpretty 0 y . 23 | showString ")" 24 | 25 | instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where 26 | bpretty _ (x, y, z) = 27 | showString "(" . bpretty 0 x . 28 | showString ", " . bpretty 0 y . 29 | showString ", " . bpretty 0 z . 30 | showString ")" 31 | 32 | instance Pretty Var where 33 | bpretty _ (Var v) = showString v 34 | 35 | instance Pretty TVar where 36 | bpretty _ (TypeVar v) = showString v 37 | 38 | instance Pretty (Type a) where 39 | bpretty d typ = case typ of 40 | TUnit -> showString "()" 41 | TVar v -> bpretty d v 42 | TExists v -> showParen (d > exists_prec) $ 43 | showString "∃ " . bpretty exists_prec v 44 | TForall v t -> showParen (d > forall_prec) $ 45 | showString "∀ " . bpretty (forall_prec + 1) v . 46 | showString ". " . bpretty forall_prec t 47 | TFun t1 t2 -> showParen (d > fun_prec) $ 48 | bpretty (fun_prec + 1) t1 . showString " → " . 49 | bpretty fun_prec t2 50 | where 51 | exists_prec = 10 52 | forall_prec :: Int 53 | forall_prec = 1 54 | fun_prec = 1 55 | 56 | instance Pretty Expr where 57 | bpretty d expr = case expr of 58 | EVar v -> bpretty d v 59 | EUnit -> showString "()" 60 | EAbs v e -> showParen (d > abs_prec) $ 61 | showString "λ" . bpretty (abs_prec + 1) v . 62 | showString ". " . bpretty abs_prec e 63 | EApp e1 e2 -> showParen (d > app_prec) $ 64 | bpretty app_prec e1 . showString " " . bpretty (app_prec + 1) e2 65 | EAnno e t -> showParen (d > anno_prec) $ 66 | bpretty (anno_prec + 1) e . showString " : " . bpretty anno_prec t 67 | where 68 | abs_prec = 1 69 | app_prec = 10 70 | anno_prec = 1 71 | 72 | instance Pretty (GContext a) where 73 | bpretty d (Context xs) = bpretty d $ reverse xs 74 | 75 | instance Pretty (ContextElem a) where 76 | bpretty d cxte = case cxte of 77 | CForall v -> bpretty d v 78 | CVar v t -> showParen (d > hastype_prec) $ 79 | bpretty (hastype_prec + 1) v . showString " : " . bpretty hastype_prec t 80 | CExists v -> showParen (d > exists_prec) $ 81 | showString "∃ " . bpretty exists_prec v 82 | CExistsSolved v t -> showParen (d > exists_prec) $ 83 | showString "∃ " . bpretty exists_prec v . 84 | showString " = " . bpretty exists_prec t 85 | CMarker v -> showParen (d > app_prec) $ 86 | showString "▶ " . bpretty (app_prec + 1) v 87 | where 88 | exists_prec = 1 89 | hastype_prec = 1 90 | app_prec = 10 91 | -------------------------------------------------------------------------------- /src/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | -- | Bidirectional typechecking for higher-rank polymorphism 3 | -- Implementation of http://www.mpi-sws.org/~neelk/bidir.pdf 4 | module Type where 5 | 6 | import Control.Applicative 7 | import Control.Monad 8 | import Data.Maybe 9 | import Data.Monoid 10 | import qualified Data.Set as S 11 | 12 | import AST 13 | import Context 14 | import NameGen 15 | import Pretty 16 | 17 | -- | Algorithmic subtyping: 18 | -- subtype Γ A B = Δ <=> Γ |- A <: B -| Δ 19 | subtype :: Context -> Polytype -> Polytype -> NameGen Context 20 | subtype gamma typ1 typ2 = 21 | traceNS "subtype" (gamma, typ1, typ2) $ 22 | checkwftype gamma typ1 $ checkwftype gamma typ2 $ 23 | case (typ1, typ2) of 24 | -- <:Var 25 | (TVar alpha, TVar alpha') | alpha == alpha' -> return gamma 26 | -- <:Unit 27 | (TUnit, TUnit) -> return gamma 28 | -- <:Exvar 29 | (TExists alpha, TExists alpha') 30 | | alpha == alpha' && alpha `elem` existentials gamma -> return gamma 31 | -- <:-> 32 | (TFun a1 a2, TFun b1 b2) -> do 33 | theta <- subtype gamma b1 a1 34 | subtype theta (apply theta a2) (apply theta b2) 35 | 36 | -- <:forallR 37 | (a, TForall alpha b) -> do 38 | -- Do alpha conversion to avoid clashes 39 | alpha' <- freshTVar 40 | dropMarker (CForall alpha') <$> 41 | subtype (gamma >: CForall alpha') a (typeSubst (TVar alpha') alpha b) 42 | 43 | -- <:forallL 44 | (TForall alpha a, b) -> do 45 | -- Do alpha conversion to avoid clashes 46 | alpha' <- freshTVar 47 | dropMarker (CMarker alpha') <$> 48 | subtype (gamma >++ [CMarker alpha', CExists alpha']) 49 | (typeSubst (TExists alpha') alpha a) 50 | b 51 | 52 | -- <:InstantiateL 53 | (TExists alpha, a) | alpha `elem` existentials gamma 54 | && alpha `S.notMember` freeTVars a -> 55 | instantiateL gamma alpha a 56 | -- <:InstantiateR 57 | (a, TExists alpha) | alpha `elem` existentials gamma 58 | && alpha `S.notMember` freeTVars a -> 59 | instantiateR gamma a alpha 60 | _ -> error $ "subtype, don't know what to do with: " 61 | ++ pretty (gamma, typ1, typ2) 62 | 63 | -- | Algorithmic instantiation (left): 64 | -- instantiateL Γ α A = Δ <=> Γ |- α^ :=< A -| Δ 65 | instantiateL :: Context -> TVar -> Polytype -> NameGen Context 66 | instantiateL gamma alpha a = 67 | traceNS "instantiateL" (gamma, alpha, a) $ 68 | checkwftype gamma a $ checkwftype gamma (TExists alpha) $ 69 | case solve gamma alpha =<< monotype a of 70 | -- InstLSolve 71 | Just gamma' -> return gamma' 72 | Nothing -> case a of 73 | -- InstLReach 74 | TExists beta 75 | | ordered gamma alpha beta -> 76 | return $ fromJust $ solve gamma beta (TExists alpha) 77 | | otherwise -> 78 | return $ fromJust $ solve gamma alpha (TExists beta) 79 | -- InstLArr 80 | TFun a1 a2 -> do 81 | alpha1 <- freshTVar 82 | alpha2 <- freshTVar 83 | theta <- instantiateR (insertAt gamma (CExists alpha) $ context 84 | [ CExists alpha2 85 | , CExists alpha1 86 | , CExistsSolved alpha $ TFun (TExists alpha1) 87 | (TExists alpha2) 88 | ]) 89 | a1 alpha1 90 | instantiateL theta alpha2 (apply theta a2) 91 | -- InstLAIIR 92 | TForall beta b -> do 93 | -- Do alpha conversion to avoid clashes 94 | beta' <- freshTVar 95 | dropMarker (CForall beta') <$> 96 | instantiateL (gamma >++ [CForall beta']) 97 | alpha 98 | (typeSubst (TVar beta') beta b) 99 | _ -> error $ "The impossible happened! instantiateL: " 100 | ++ pretty (gamma, alpha, a) 101 | 102 | -- | Algorithmic instantiation (right): 103 | -- instantiateR Γ A α = Δ <=> Γ |- A =:< α -| Δ 104 | instantiateR :: Context -> Polytype -> TVar -> NameGen Context 105 | instantiateR gamma a alpha = 106 | traceNS "instantiateR" (gamma, a, alpha) $ 107 | checkwftype gamma a $ checkwftype gamma (TExists alpha) $ 108 | case solve gamma alpha =<< monotype a of 109 | Just gamma' -> return gamma' 110 | Nothing -> case a of 111 | -- InstRReach 112 | TExists beta 113 | | ordered gamma alpha beta -> 114 | return $ fromJust $ solve gamma beta (TExists alpha) 115 | | otherwise -> 116 | return $ fromJust $ solve gamma alpha (TExists beta) 117 | -- InstRArr 118 | TFun a1 a2 -> do 119 | alpha1 <- freshTVar 120 | alpha2 <- freshTVar 121 | theta <- instantiateL (insertAt gamma (CExists alpha) $ context 122 | [ CExists alpha2 123 | , CExists alpha1 124 | , CExistsSolved alpha $ TFun (TExists alpha1) 125 | (TExists alpha2) 126 | ]) 127 | alpha1 128 | a1 129 | instantiateR theta (apply theta a2) alpha2 130 | -- InstRAIIL 131 | TForall beta b -> do 132 | -- Do alpha conversion to avoid clashes 133 | beta' <- freshTVar 134 | dropMarker (CMarker beta') <$> 135 | instantiateR (gamma >++ [CMarker beta', CExists beta']) 136 | (typeSubst (TExists beta') beta b) 137 | alpha 138 | _ -> error $ "The impossible happened! instantiateR: " 139 | ++ pretty (gamma, a, alpha) 140 | 141 | -- | Type checking: 142 | -- typecheck Γ e A = Δ <=> Γ |- e <= A -| Δ 143 | typecheck :: Context -> Expr -> Polytype -> NameGen Context 144 | typecheck gamma expr typ = 145 | traceNS "typecheck" (gamma, expr, typ) $ 146 | checkwftype gamma typ $ case (expr, typ) of 147 | -- 1I 148 | (EUnit, TUnit) -> return gamma 149 | -- ForallI 150 | (e, TForall alpha a) -> do 151 | -- Do alpha conversion to avoid clashes 152 | alpha' <- freshTVar 153 | dropMarker (CForall alpha') <$> 154 | typecheck (gamma >: CForall alpha') e (typeSubst (TVar alpha') alpha a) 155 | -- ->I 156 | (EAbs x e, TFun a b) -> do 157 | x' <- freshVar 158 | dropMarker (CVar x' a) <$> 159 | typecheck (gamma >: CVar x' a) (subst (EVar x') x e) b 160 | -- Sub 161 | (e, b) -> do 162 | (a, theta) <- typesynth gamma e 163 | subtype theta (apply theta a) (apply theta b) 164 | 165 | -- | Type synthesising: 166 | -- typesynth Γ e = (A, Δ) <=> Γ |- e => A -| Δ 167 | typesynth :: Context -> Expr -> NameGen (Polytype, Context) 168 | typesynth gamma expr = traceNS "typesynth" (gamma, expr) $ checkwf gamma $ 169 | case expr of 170 | -- Var 171 | EVar x -> return 172 | ( fromMaybe (error $ "typesynth: not in scope " ++ pretty (expr, gamma)) 173 | (findVarType gamma x) 174 | , gamma 175 | ) 176 | -- Anno 177 | EAnno e a -> do 178 | delta <- typecheck gamma e a 179 | return (a, delta) 180 | -- 1I=> 181 | EUnit -> return (TUnit, gamma) 182 | -- {- 183 | -- ->I=> Original rule 184 | EAbs x e -> do 185 | x' <- freshVar 186 | alpha <- freshTVar 187 | beta <- freshTVar 188 | delta <- dropMarker (CVar x' (TExists alpha)) <$> 189 | typecheck (gamma >++ [ CExists alpha 190 | , CExists beta 191 | , CVar x' (TExists alpha) 192 | ]) 193 | (subst (EVar x') x e) 194 | (TExists beta) 195 | return (TFun (TExists alpha) (TExists beta), delta) 196 | -- -} 197 | {- 198 | -- ->I=> Full Damas-Milner type inference 199 | EAbs x e -> do 200 | x' <- freshVar 201 | alpha <- freshTVar 202 | beta <- freshTVar 203 | (delta, delta') <- breakMarker (CMarker alpha) <$> 204 | typecheck (gamma >++ [ CMarker alpha 205 | , CExists alpha 206 | , CExists beta 207 | , CVar x' (TExists alpha) 208 | ]) 209 | (subst (EVar x') x e) 210 | (TExists beta) 211 | let tau = apply delta' (TFun (TExists alpha) (TExists beta)) 212 | let evars = unsolved delta' 213 | uvars <- replicateM (length evars) freshTVar 214 | return ( tforalls uvars $ typeSubsts (zip (map TVar uvars) evars) tau 215 | , delta) 216 | -} 217 | -- ->E 218 | EApp e1 e2 -> do 219 | (a, theta) <- typesynth gamma e1 220 | typeapplysynth theta (apply theta a) e2 221 | 222 | -- | Type application synthesising 223 | -- typeapplysynth Γ A e = (C, Δ) <=> Γ |- A . e =>> C -| Δ 224 | typeapplysynth :: Context -> Polytype -> Expr -> NameGen (Polytype, Context) 225 | typeapplysynth gamma typ e = traceNS "typeapplysynth" (gamma, typ, e) $ 226 | checkwftype gamma typ $ 227 | case typ of 228 | -- ForallApp 229 | TForall alpha a -> do 230 | -- Do alpha conversion to avoid clashes 231 | alpha' <- freshTVar 232 | typeapplysynth (gamma >: CExists alpha') 233 | (typeSubst (TExists alpha') alpha a) 234 | e 235 | -- alpha^App 236 | TExists alpha -> do 237 | alpha1 <- freshTVar 238 | alpha2 <- freshTVar 239 | delta <- typecheck (insertAt gamma (CExists alpha) $ context 240 | [ CExists alpha2 241 | , CExists alpha1 242 | , CExistsSolved alpha $ TFun (TExists alpha1) 243 | (TExists alpha2) 244 | ]) 245 | e 246 | (TExists alpha1) 247 | return (TExists alpha2, delta) 248 | -- ->App 249 | TFun a c -> do 250 | delta <- typecheck gamma e a 251 | return (c, delta) 252 | 253 | _ -> error $ "typeapplysynth: don't know what to do with: " 254 | ++ pretty (gamma, typ, e) 255 | 256 | typesynthClosed :: Expr -> (Polytype, Context) 257 | typesynthClosed e = let (a, gamma) = evalNameGen $ typesynth mempty e 258 | in (apply gamma a, gamma) 259 | 260 | -- Examples 261 | eid :: Expr -- (λx. x) : ∀ t. t → t 262 | eid = eabs "x" (var "x") -: tforall "t" (tvar "t" --> tvar "t") 263 | -- Impredicative, so doesn't typecheck 264 | ididunit :: Expr -- (λid. id id ()) ((λx. x) : ∀ t. t → t) 265 | ididunit = eabs "id" (((var "id" -: tforall "t" (tvar "t" --> tvar "t")) $$ var "id") $$ eunit) $$ eid 266 | idunit :: Expr -- (λid. id ()) ((λx. x) : ∀ t. t → t) 267 | idunit = eabs "id" (var "id" $$ eunit) $$ eid 268 | idid :: Expr -- id id 269 | idid = (eid $$ eid) -: tforall "t" (tvar "t" --> tvar "t") 270 | 271 | idunitnotype :: Expr 272 | idunitnotype = eabs "x" (var "x") $$ eunit 273 | 274 | idnotype :: Expr 275 | idnotype = eabs "x" (var "x") 276 | 277 | polyidunit :: Expr 278 | polyidunit = eid $$ eunit 279 | -------------------------------------------------------------------------------- /src/Worklist.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | {- ICFP 2019 : A Mechanical Formalization of Higher-Ranked Polymorphic Type Inference 4 | (by JINXU ZHAO, BRUNO C. D. S. OLIVEIRA, TOM SCHRIJVERS) 5 | -} 6 | 7 | module Worklist where 8 | 9 | import AST 10 | import NameGen 11 | import Pretty 12 | 13 | import Data.Maybe 14 | import qualified Data.Set as S 15 | 16 | -- 17 | data JudgChain -- w (omega) 18 | = Subty Polytype Polytype -- A <: B 19 | | Check Expr Polytype -- e <= A 20 | | Synth Expr TVar JudgChain -- e =>a w 21 | | Typeapply Polytype Expr TVar JudgChain -- A . e =>> a w 22 | 23 | | TypeResult Polytype 24 | deriving (Eq, Show) 25 | 26 | type Worklist = [WorklistElem] -- Gamma 27 | 28 | data WorklistElem 29 | = WForall TVar -- alpha 30 | | WExists TVar -- alpha^ 31 | | WVar Var Polytype -- x : A 32 | | WJC JudgChain -- w 33 | deriving (Eq, Show) 34 | 35 | instance Pretty JudgChain where 36 | bpretty d jc = 37 | case jc of 38 | Subty ty1 ty2 -> bpretty d ty1 . showString " <: " . bpretty d ty2 39 | Check e ty -> bpretty d e . showString " <= " . bpretty d ty 40 | Synth e tvar jc -> bpretty d e . showString " =>_" 41 | . bpretty d (TVar tvar) . showString " " . bpretty d jc 42 | Typeapply ty e tvar jc -> bpretty d ty . showString " o " 43 | . bpretty d e . showString " =>>_" . bpretty d (TVar tvar) 44 | . showString " " . bpretty d jc 45 | TypeResult ty -> showString " result: " . bpretty d ty 46 | 47 | instance Pretty WorklistElem where 48 | bpretty d wl = 49 | case wl of 50 | WForall tvar -> bpretty d (TExists tvar) 51 | WExists tvar -> bpretty d (TVar tvar) 52 | WVar v ty -> bpretty d (EVar v) . showString " : " . bpretty d ty 53 | WJC jc -> bpretty d jc 54 | 55 | -- | algorithmic typing 56 | 57 | alty :: Worklist -> NameGen Polytype 58 | -- alty [] = return [] 59 | 60 | -- | (1) ~ (3) 61 | alty tr@(WForall tvar : wl) = -- (1) Gamma, a ---> Gamma 62 | traceSeq "(1)" tr $ 63 | alty wl 64 | 65 | alty tr@(WExists tvar : wl) = -- (2) Gamma, a^ ---> Gamma 66 | traceSeq "(2)" tr $ 67 | alty wl 68 | 69 | alty tr@(WVar var ty : wl) = -- (3) Gamma, x:A ---> Gamma 70 | traceSeq "(3)" tr $ 71 | alty wl 72 | 73 | -- (4) ~ (11) 74 | alty tr@(WJC (Subty TUnit TUnit) : wl) = -- (4) Gamma ||- 1 <: 1 ---> Gamma 75 | traceSeq "(4)" tr $ 76 | alty wl 77 | 78 | alty tr@(WJC (Subty (TVar v1) (TVar v2)) : wl) -- (5) Gamma ||- a <: a ---> Gamma 79 | | v1 == v2 = 80 | traceSeq "(5)" tr $ 81 | alty wl 82 | 83 | alty tr@(WJC (Subty (TExists v1) (TExists v2)) : wl) -- (6) Gamma ||- a^ <: a^ ---> Gamma 84 | | v1 == v2 = 85 | traceSeq "(6)" tr $ 86 | alty wl 87 | 88 | -- (7) Gamma ||- A1->A2 <: B1->B2 ---> Gamma ||- A2 <: B2 ||- B1 <: A1 89 | alty tr@(WJC (Subty (TFun a1 a2) (TFun b1 b2)) : wl) 90 | = traceSeq "(7)" tr $ 91 | alty (WJC (Subty b1 a1) : WJC (Subty a2 b2) : wl) 92 | 93 | -- (8) Gamma ||- forall a.A <: B ---> Gamma, a^ ||- [a^/a]A <: B (when B != forall a.B') 94 | alty tr@(WJC (Subty (TForall v a) b) : wl) 95 | | not (isTForall b) = 96 | traceSeq "(8)" tr $ 97 | do alpha <- freshTVar 98 | alty (WJC (Subty (typeSubst (TExists alpha) v a ) b) : WExists alpha : wl) 99 | 100 | -- (9) Gamma ||- a <: forall b.B ---> Gamma, b ||- A <: B 101 | alty tr@(WJC (Subty a (TForall v b)) : wl) = 102 | traceSeq "(9)" tr $ 103 | do alpha <- freshTVar 104 | alty (WJC (Subty a (typeSubst (TVar alpha) v b)) : WForall alpha : wl) 105 | 106 | -- (10) Gamma[a^] ||- a^ <: A->B ---> [a1^->a2^/a^](Gamma[a1^,a2^]) ||- a1^->a2^ <: A->B 107 | -- (when a^ not in FV(A) U FV (B)) 108 | alty tr@(WJC (Subty (TExists v) (TFun a b)) : wl) 109 | | v `elem` existentialsWL wl 110 | && v `S.notMember` freeTVars a 111 | && v `S.notMember` freeTVars b = 112 | 113 | traceSeq "(10)" tr $ 114 | do alpha1 <- freshTVar 115 | alpha2 <- freshTVar 116 | 117 | alty (typeSubstWL (TFun (TExists alpha1) (TExists alpha2)) v 118 | (WJC (Subty (TFun (TExists alpha1) (TExists alpha2)) (TFun a b)) 119 | : insertAtWL wl (WExists v) [WExists alpha1, WExists alpha2])) 120 | 121 | -- (11) Gamma[a^] ||- A->B <: a^ ---> [a1^->a2^/a^](Gamma[a1^,a2^]) ||- A->B <: a1^->a2^ 122 | -- (when a^ not in FV(A) U FV (B)) 123 | alty tr@(WJC (Subty (TFun a b) (TExists v)) : wl) 124 | | v `elem` existentialsWL wl 125 | && v `S.notMember` freeTVars a 126 | && v `S.notMember` freeTVars b = 127 | 128 | traceSeq "(11)" tr $ 129 | do alpha1 <- freshTVar 130 | alpha2 <- freshTVar 131 | 132 | alty (typeSubstWL (TFun (TExists alpha1) (TExists alpha2)) v 133 | (WJC (Subty (TFun a b) (TFun (TExists alpha1) (TExists alpha2))) 134 | : insertAtWL wl (WExists v) [WExists alpha1, WExists alpha2])) 135 | 136 | -- (12) Gamma[a^][b^] ||- a^ <: b^ ---> [a^/b^]( Gamma[a^][] ) 137 | -- (13) Gamma[a^][b^] ||- b^ <: a^ ---> [a^/b^]( Gamma[a^][] ) 138 | 139 | alty tr@(WJC (Subty (TExists alpha) (TExists beta)) : wl) 140 | | orderedWL wl alpha beta = 141 | traceSeq "(12)" tr $ 142 | alty (typeSubstWL (TExists alpha) beta 143 | (insertAtWL wl (WExists beta) [])) 144 | 145 | | orderedWL wl beta alpha = 146 | traceSeq "(13)" tr $ 147 | alty (typeSubstWL (TExists alpha) beta 148 | (insertAtWL wl (WExists beta) [])) 149 | 150 | -- (14) Gamma[a][b^] ||- a <: b^ ---> [a/b^]( Gamma[a][] ) 151 | -- (15) Gamma[a][b^] ||- b^ <: a ---> [a/b^]( Gamma[a][] ) 152 | 153 | alty tr@(WJC (Subty (TVar alpha) (TExists beta)) : wl) 154 | | WForall alpha `elem` dropMarkerWL (WExists beta) wl = 155 | traceSeq "(14)" tr $ 156 | alty (typeSubstWL (TVar alpha) beta 157 | (insertAtWL wl (WExists beta) [])) 158 | 159 | alty tr@(WJC (Subty (TExists beta) (TVar alpha)) : wl) 160 | | WForall alpha `elem` dropMarkerWL (WExists beta) wl = 161 | traceSeq "(15)" tr $ 162 | alty (typeSubstWL (TVar alpha) beta 163 | (insertAtWL wl (WExists beta) [])) 164 | 165 | -- (16) Gamma[b^] ||- 1 <: b^ ---> [1/b^]( Gamma[] ) 166 | -- (17) Gamma[b^] ||- b^ <: 1 ---> [1/b^]( Gamma[] ) 167 | 168 | alty tr@(WJC (Subty TUnit (TExists beta)) : wl) 169 | | beta `elem` existentialsWL wl = 170 | traceSeq "(16)" tr $ 171 | alty (typeSubstWL TUnit beta 172 | (insertAtWL wl (WExists beta) [])) 173 | 174 | alty tr@(WJC (Subty (TExists beta) TUnit) : wl) 175 | | beta `elem` existentialsWL wl = 176 | traceSeq "(17)" tr $ 177 | alty (typeSubstWL TUnit beta 178 | (insertAtWL wl (WExists beta) [])) 179 | 180 | -- (18) Gamma ||- e <= b ---> Gamma ||- e =>_a a <: B 181 | -- (when e not= lamx.e' and B not= forall a.B') 182 | alty tr@(WJC (Check e b) : wl) 183 | | isAbs e == False && isTForall b == False = 184 | traceSeq "(18)" tr $ 185 | do alpha <- freshTVar 186 | alty (WJC (Synth e alpha (Subty (TVar alpha) b)) : wl) 187 | 188 | -- (19) Gamma ||- e <= forall a.A ---> Gamma,a ||- e <= A 189 | alty tr@(WJC (Check e (TForall alpha a)) : wl) = 190 | traceSeq "(19)" tr $ 191 | do alpha' <- freshTVar 192 | let a' = typeSubst (TVar alpha') alpha a 193 | alty (WJC (Check e a') : WForall alpha' : wl) 194 | 195 | -- (20) Gamma ||- lam x.e <= A->B ---> Gamma, x:A ||- e <= B 196 | alty tr@(WJC (Check (EAbs x e) (TFun a b)) : wl) = 197 | traceSeq "(20)" tr $ 198 | alty (WJC (Check e b) : (WVar x a) : wl) 199 | 200 | -- (21) Gamma[a^] ||- lam x.e <= a^ ---> 201 | -- [a1^->a2^/a^](Gamma[a1^,a2^],x:a1^ ||- e <= a2^) 202 | alty tr@(WJC (Check (EAbs x e) (TExists alpha)) : wl) 203 | | alpha `elem` existentialsWL wl = 204 | traceSeq "(21)" tr $ 205 | do alpha1 <- freshTVar 206 | alpha2 <- freshTVar 207 | alty (typeSubstWL (TFun (TExists alpha1) (TExists alpha2)) alpha 208 | (WJC (Check e (TExists alpha2)) 209 | : WVar x (TExists alpha1) 210 | : insertAtWL wl (WExists alpha) [WExists alpha1, WExists alpha2])) 211 | 212 | -- (22) Gamma ||- x =>_a w ---> Gamma ||- [A/a]w (when x:A in Gamma) 213 | alty tr@(WJC (Synth (EVar x) alpha jc) : wl) = 214 | traceSeq "(22)" tr $ 215 | case findVarType wl x of 216 | Just ty -> alty (typeSubstWL ty alpha (WJC jc : wl)) 217 | Nothing -> error ("Var not found: " ++ show x) 218 | 219 | -- (23) Gamma ||- (e : A) =>_a w ---> Gamma ||- [A/a]w ||- e <= A 220 | alty tr@(WJC (Synth (EAnno e a) alpha jc) : wl) = 221 | traceSeq "(23)" tr $ 222 | alty (WJC (Check e a) : WJC (typeSubstJC a alpha jc) : wl) 223 | 224 | -- (24) Gamma ||- () =>_a w ---> Gamma ||- [1/a]w 225 | alty tr@(WJC (Synth EUnit alpha jc) : wl) = 226 | traceSeq "(24)" tr $ 227 | alty (WJC (typeSubstJC TUnit alpha jc) : wl) 228 | 229 | -- (25) Gamma ||- lam x.e =>_a w ---> 230 | -- Gamma,alpha^,beta^ ||- [alpha^->beta^/a]w, x:alpha^ ||- e <= beta^ 231 | alty tr@(WJC (Synth (EAbs x e) alpha jc) : wl) = 232 | traceSeq "(25)" tr $ 233 | do beta1 <- freshTVar 234 | beta2 <- freshTVar 235 | alty (WJC (Check e (TExists beta2)) : WVar x (TExists beta1) 236 | : WJC (typeSubstJC (TFun (TExists beta1) (TExists beta2)) alpha jc) 237 | : WExists beta2 : WExists beta1 : wl) 238 | 239 | 240 | -- (26) Gamma ||- e1 e2 =>_a w ---> Gamma ||- e1 =>_b (b dot e_2 =>>_a w) 241 | alty tr@(WJC (Synth (EApp e1 e2) alpha jc) : wl) = 242 | traceSeq "(26)" tr $ 243 | do beta <- freshTVar 244 | alty (WJC (Synth e1 beta (Typeapply (TVar beta) e2 alpha jc)) : wl) 245 | 246 | -- (27) Gamma ||- forall b.A dot e =>>_a w ---> 247 | -- Gamma, a^ ||- [a^/b]A dot e =>>_a w 248 | alty tr@(WJC (Typeapply (TForall beta ty) e alpha jc) : wl) = 249 | traceSeq "(27)" tr $ 250 | do beta1 <- freshTVar 251 | alty (WJC (Typeapply (typeSubst (TExists beta1) beta ty) e alpha jc) 252 | : WExists beta1 : wl) 253 | 254 | -- (28) Gamma ||- A->C dot e =>>_a w ---> Gamma ||- [C/a]w ||- e <= A 255 | alty tr@(WJC (Typeapply (TFun a c) e alpha jc) : wl) = 256 | traceSeq "(28)" tr $ 257 | alty (WJC (Check e a) : WJC (typeSubstJC c alpha jc) : wl) 258 | 259 | -- (29) Gamma[b^] ||- b^ dot e =>>_a w ---> 260 | -- [a1^->a2^/b^](Gamma[a1^,a2^] ||- a1^->a2^ dot e =>>_a w) 261 | alty tr@(WJC (Typeapply (TExists beta) e alpha jc) : wl) 262 | | beta `elem` existentialsWL wl = 263 | traceSeq "(29)" tr $ 264 | do alpha1 <- freshTVar 265 | alpha2 <- freshTVar 266 | alty (typeSubstWL (TFun (TExists alpha1) (TExists alpha2)) beta 267 | (WJC (Typeapply (TFun (TExists alpha1) (TExists alpha2)) e alpha jc) 268 | : insertAtWL wl (WExists beta) [WExists alpha1, WExists alpha2])) 269 | 270 | -- Extra 271 | alty tr@(WJC (TypeResult ty):wl) = 272 | traceSeq "(extra)" tr $ 273 | return ty 274 | 275 | -- alty tr@(WJC (TypeResult ty) : wl) = 276 | -- traceSeq "(move back)" tr $ 277 | -- alty (wl ++ [WJC (TypeResult ty)]) 278 | 279 | -- 280 | alty tr@wl = 281 | traceSeq "somethin worng: " tr $ 282 | error "Not implemented yet" 283 | 284 | 285 | -- 286 | altyClosed :: Expr -> Polytype 287 | altyClosed prog = evalNameGen $ 288 | do alpha <- freshTVar 289 | alty [ WJC (Synth prog alpha (TypeResult (TExists alpha))) ] 290 | 291 | 292 | -- isTForall a 293 | isTForall :: Polytype -> Bool 294 | isTForall (TForall _ _) = True 295 | isTForall _ = False 296 | 297 | isAbs (EAbs _ _) = True 298 | isAbs _ = False 299 | 300 | 301 | -- 302 | breakMarkerWL :: WorklistElem -> Worklist -> (Worklist, Worklist) 303 | breakMarkerWL m w = bwlist m [] w 304 | where 305 | bwlist m rev_prev [] = (reverse rev_prev, []) 306 | bwlist m rev_prev (elem : w) 307 | | m == elem = (reverse rev_prev, w) 308 | | otherwise = bwlist m (elem : rev_prev) w 309 | 310 | insertAtWL :: Worklist -> WorklistElem -> Worklist -> Worklist 311 | insertAtWL w m new = prev ++ new ++ next 312 | where 313 | (prev, next) = breakMarkerWL m w 314 | 315 | dropMarkerWL :: WorklistElem -> Worklist -> Worklist 316 | dropMarkerWL m w = tail $ dropWhile (/= m) w 317 | 318 | orderedWL :: Worklist -> TVar -> TVar -> Bool 319 | orderedWL w alpha beta = alpha `elem` existentialsWL wL 320 | where 321 | wL = dropMarkerWL (WExists beta) w 322 | 323 | existentialsWL :: Worklist -> [TVar] 324 | existentialsWL [] = [] 325 | existentialsWL (WExists v : wl) = v : existentialsWL wl 326 | existentialsWL (_ : wl) = existentialsWL wl 327 | 328 | typeSubstWL :: Polytype -> TVar -> Worklist -> Worklist 329 | typeSubstWL t' alpha w = 330 | case w of 331 | [] -> [] 332 | (WForall beta : w') -> WForall beta : typeSubstWL t' alpha w' 333 | (WExists beta : w') 334 | | alpha == beta -> typeSubstWL t' alpha w' -- Todo: ??? 335 | | otherwise -> WExists beta : typeSubstWL t' alpha w' 336 | (WVar x ty : w') -> WVar x (typeSubst t' alpha ty) : typeSubstWL t' alpha w' 337 | (WJC jc : w') -> WJC (typeSubstJC t' alpha jc) : typeSubstWL t' alpha w' 338 | 339 | typeSubstJC :: Polytype -> TVar -> JudgChain -> JudgChain 340 | typeSubstJC t' alpha jc = 341 | case jc of 342 | Subty a b -> Subty (typeSubst t' alpha a) (typeSubst t' alpha b) 343 | Check e ty -> Check e (typeSubst t' alpha ty) 344 | Synth e x jc -> Synth e x (typeSubstJC t' alpha jc) 345 | Typeapply a e x jc -> Typeapply (typeSubst t' alpha a) e x (typeSubstJC t' alpha jc) 346 | TypeResult ty -> TypeResult (typeSubst t' alpha ty) 347 | 348 | findVarType :: Worklist -> Var -> Maybe Polytype 349 | findVarType wl x = listToMaybe [t | WVar y t <- wl, x==y] 350 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-16.9 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 532380 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/9.yaml 11 | sha256: 14a7cec114424e4286adde73364438927a553ed248cc50f069a30a67e3ee1e69 12 | original: lts-16.9 13 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /test/result.txt: -------------------------------------------------------------------------------- 1 | Expr: (λx. x) : ∀ t. t → t 2 | typesynth([], (λx. x) : ∀ t. t → t) 3 | typecheck([], λx. x, ∀ t. t → t) 4 | typecheck(['a], λx. x, 'a → 'a) 5 | typecheck(['a, $a : 'a], $a, 'a) 6 | typesynth(['a, $a : 'a], $a) 7 | =('a, ['a, $a : 'a]) 8 | subtype(['a, $a : 'a], 'a, 'a) 9 | =['a, $a : 'a] 10 | =['a, $a : 'a] 11 | =['a] 12 | =[] 13 | =(∀ t. t → t, []) 14 | Type: ∀ t. t → t 15 | Context: [] 16 | 17 | Expr: (λid. id ()) ((λx. x) : ∀ t. t → t) 18 | typesynth([], (λid. id ()) ((λx. x) : ∀ t. t → t)) 19 | typesynth([], λid. id ()) 20 | typecheck([∃ 'a, ∃ 'b, $a : ∃ 'a], $a (), ∃ 'b) 21 | typesynth([∃ 'a, ∃ 'b, $a : ∃ 'a], $a ()) 22 | typesynth([∃ 'a, ∃ 'b, $a : ∃ 'a], $a) 23 | =(∃ 'a, [∃ 'a, ∃ 'b, $a : ∃ 'a]) 24 | typeapplysynth([∃ 'a, ∃ 'b, $a : ∃ 'a], ∃ 'a, ()) 25 | typecheck([∃ 'd, ∃ 'c, ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b, $a : ∃ 'a], (), ∃ 'c) 26 | typesynth([∃ 'd, ∃ 'c, ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b, $a : ∃ 'a], ()) 27 | =((), [∃ 'd, ∃ 'c, ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b, $a : ∃ 'a]) 28 | subtype([∃ 'd, ∃ 'c, ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b, $a : ∃ 'a], (), ∃ 'c) 29 | instantiateR([∃ 'd, ∃ 'c, ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b, $a : ∃ 'a], (), 'c) 30 | =[∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b, $a : ∃ 'a] 31 | =[∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b, $a : ∃ 'a] 32 | =[∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b, $a : ∃ 'a] 33 | =(∃ 'd, [∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b, $a : ∃ 'a]) 34 | =(∃ 'd, [∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b, $a : ∃ 'a]) 35 | subtype([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b, $a : ∃ 'a], ∃ 'd, ∃ 'b) 36 | instantiateL([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b, $a : ∃ 'a], 'd, ∃ 'b) 37 | =[∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, $a : ∃ 'a] 38 | =[∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, $a : ∃ 'a] 39 | =[∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, $a : ∃ 'a] 40 | =(∃ 'a → ∃ 'b, [∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd]) 41 | typeapplysynth([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd], (() → ∃ 'd) → ∃ 'd, (λx. x) : ∀ t. t → t) 42 | typecheck([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd], (λx. x) : ∀ t. t → t, () → ∃ 'd) 43 | typesynth([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd], (λx. x) : ∀ t. t → t) 44 | typecheck([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd], λx. x, ∀ t. t → t) 45 | typecheck([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, 'e], λx. x, 'e → 'e) 46 | typecheck([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, 'e, $b : 'e], $b, 'e) 47 | typesynth([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, 'e, $b : 'e], $b) 48 | =('e, [∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, 'e, $b : 'e]) 49 | subtype([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, 'e, $b : 'e], 'e, 'e) 50 | =[∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, 'e, $b : 'e] 51 | =[∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, 'e, $b : 'e] 52 | =[∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, 'e] 53 | =[∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd] 54 | =(∀ t. t → t, [∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd]) 55 | subtype([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd], ∀ t. t → t, () → ∃ 'd) 56 | subtype([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, ▶ 'f, ∃ 'f], ∃ 'f → ∃ 'f, () → ∃ 'd) 57 | subtype([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, ▶ 'f, ∃ 'f], (), ∃ 'f) 58 | instantiateR([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, ▶ 'f, ∃ 'f], (), 'f) 59 | =[∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, ▶ 'f, ∃ 'f = ()] 60 | =[∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, ▶ 'f, ∃ 'f = ()] 61 | subtype([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, ▶ 'f, ∃ 'f = ()], (), ∃ 'd) 62 | instantiateR([∃ 'd, ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, ▶ 'f, ∃ 'f = ()], (), 'd) 63 | =[∃ 'd = (), ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, ▶ 'f, ∃ 'f = ()] 64 | =[∃ 'd = (), ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, ▶ 'f, ∃ 'f = ()] 65 | =[∃ 'd = (), ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd, ▶ 'f, ∃ 'f = ()] 66 | =[∃ 'd = (), ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd] 67 | =[∃ 'd = (), ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd] 68 | =(∃ 'd, [∃ 'd = (), ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd]) 69 | =(∃ 'd, [∃ 'd = (), ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd]) 70 | Type: () 71 | Context: [∃ 'd = (), ∃ 'c = (), ∃ 'a = ∃ 'c → ∃ 'd, ∃ 'b = ∃ 'd] 72 | 73 | Expr: (λx. x) () 74 | typesynth([], (λx. x) ()) 75 | typesynth([], λx. x) 76 | typecheck([∃ 'a, ∃ 'b, $a : ∃ 'a], $a, ∃ 'b) 77 | typesynth([∃ 'a, ∃ 'b, $a : ∃ 'a], $a) 78 | =(∃ 'a, [∃ 'a, ∃ 'b, $a : ∃ 'a]) 79 | subtype([∃ 'a, ∃ 'b, $a : ∃ 'a], ∃ 'a, ∃ 'b) 80 | instantiateL([∃ 'a, ∃ 'b, $a : ∃ 'a], 'a, ∃ 'b) 81 | =[∃ 'a, ∃ 'b = ∃ 'a, $a : ∃ 'a] 82 | =[∃ 'a, ∃ 'b = ∃ 'a, $a : ∃ 'a] 83 | =[∃ 'a, ∃ 'b = ∃ 'a, $a : ∃ 'a] 84 | =(∃ 'a → ∃ 'b, [∃ 'a, ∃ 'b = ∃ 'a]) 85 | typeapplysynth([∃ 'a, ∃ 'b = ∃ 'a], ∃ 'a → ∃ 'a, ()) 86 | typecheck([∃ 'a, ∃ 'b = ∃ 'a], (), ∃ 'a) 87 | typesynth([∃ 'a, ∃ 'b = ∃ 'a], ()) 88 | =((), [∃ 'a, ∃ 'b = ∃ 'a]) 89 | subtype([∃ 'a, ∃ 'b = ∃ 'a], (), ∃ 'a) 90 | instantiateR([∃ 'a, ∃ 'b = ∃ 'a], (), 'a) 91 | =[∃ 'a = (), ∃ 'b = ∃ 'a] 92 | =[∃ 'a = (), ∃ 'b = ∃ 'a] 93 | =[∃ 'a = (), ∃ 'b = ∃ 'a] 94 | =(∃ 'a, [∃ 'a = (), ∃ 'b = ∃ 'a]) 95 | =(∃ 'a, [∃ 'a = (), ∃ 'b = ∃ 'a]) 96 | Type: () 97 | Context: [∃ 'a = (), ∃ 'b = ∃ 'a] 98 | 99 | Expr: ((λx. x) : ∀ t. t → t) ((λx. x) : ∀ t. t → t) : ∀ t. t → t 100 | typesynth([], ((λx. x) : ∀ t. t → t) ((λx. x) : ∀ t. t → t) : ∀ t. t → t) 101 | typecheck([], ((λx. x) : ∀ t. t → t) ((λx. x) : ∀ t. t → t), ∀ t. t → t) 102 | typecheck(['a], ((λx. x) : ∀ t. t → t) ((λx. x) : ∀ t. t → t), 'a → 'a) 103 | typesynth(['a], ((λx. x) : ∀ t. t → t) ((λx. x) : ∀ t. t → t)) 104 | typesynth(['a], (λx. x) : ∀ t. t → t) 105 | typecheck(['a], λx. x, ∀ t. t → t) 106 | typecheck(['a, 'b], λx. x, 'b → 'b) 107 | typecheck(['a, 'b, $a : 'b], $a, 'b) 108 | typesynth(['a, 'b, $a : 'b], $a) 109 | =('b, ['a, 'b, $a : 'b]) 110 | subtype(['a, 'b, $a : 'b], 'b, 'b) 111 | =['a, 'b, $a : 'b] 112 | =['a, 'b, $a : 'b] 113 | =['a, 'b] 114 | =['a] 115 | =(∀ t. t → t, ['a]) 116 | typeapplysynth(['a], ∀ t. t → t, (λx. x) : ∀ t. t → t) 117 | typeapplysynth(['a, ∃ 'c], ∃ 'c → ∃ 'c, (λx. x) : ∀ t. t → t) 118 | typecheck(['a, ∃ 'c], (λx. x) : ∀ t. t → t, ∃ 'c) 119 | typesynth(['a, ∃ 'c], (λx. x) : ∀ t. t → t) 120 | typecheck(['a, ∃ 'c], λx. x, ∀ t. t → t) 121 | typecheck(['a, ∃ 'c, 'd], λx. x, 'd → 'd) 122 | typecheck(['a, ∃ 'c, 'd, $b : 'd], $b, 'd) 123 | typesynth(['a, ∃ 'c, 'd, $b : 'd], $b) 124 | =('d, ['a, ∃ 'c, 'd, $b : 'd]) 125 | subtype(['a, ∃ 'c, 'd, $b : 'd], 'd, 'd) 126 | =['a, ∃ 'c, 'd, $b : 'd] 127 | =['a, ∃ 'c, 'd, $b : 'd] 128 | =['a, ∃ 'c, 'd] 129 | =['a, ∃ 'c] 130 | =(∀ t. t → t, ['a, ∃ 'c]) 131 | subtype(['a, ∃ 'c], ∀ t. t → t, ∃ 'c) 132 | subtype(['a, ∃ 'c, ▶ 'e, ∃ 'e], ∃ 'e → ∃ 'e, ∃ 'c) 133 | instantiateR(['a, ∃ 'c, ▶ 'e, ∃ 'e], ∃ 'e → ∃ 'e, 'c) 134 | instantiateL(['a, ∃ 'g, ∃ 'f, ∃ 'c = ∃ 'f → ∃ 'g, ▶ 'e, ∃ 'e], 'f, ∃ 'e) 135 | =['a, ∃ 'g, ∃ 'f, ∃ 'c = ∃ 'f → ∃ 'g, ▶ 'e, ∃ 'e = ∃ 'f] 136 | instantiateR(['a, ∃ 'g, ∃ 'f, ∃ 'c = ∃ 'f → ∃ 'g, ▶ 'e, ∃ 'e = ∃ 'f], ∃ 'f, 'g) 137 | =['a, ∃ 'g, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g, ▶ 'e, ∃ 'e = ∃ 'f] 138 | =['a, ∃ 'g, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g, ▶ 'e, ∃ 'e = ∃ 'f] 139 | =['a, ∃ 'g, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g, ▶ 'e, ∃ 'e = ∃ 'f] 140 | =['a, ∃ 'g, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g] 141 | =['a, ∃ 'g, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g] 142 | =(∃ 'c, ['a, ∃ 'g, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g]) 143 | =(∃ 'c, ['a, ∃ 'g, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g]) 144 | =(∃ 'c, ['a, ∃ 'g, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g]) 145 | subtype(['a, ∃ 'g, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g], ∃ 'g → ∃ 'g, 'a → 'a) 146 | subtype(['a, ∃ 'g, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g], 'a, ∃ 'g) 147 | instantiateR(['a, ∃ 'g, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g], 'a, 'g) 148 | =['a, ∃ 'g = 'a, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g] 149 | =['a, ∃ 'g = 'a, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g] 150 | subtype(['a, ∃ 'g = 'a, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g], 'a, 'a) 151 | =['a, ∃ 'g = 'a, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g] 152 | =['a, ∃ 'g = 'a, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g] 153 | =['a, ∃ 'g = 'a, ∃ 'f = ∃ 'g, ∃ 'c = ∃ 'f → ∃ 'g] 154 | =[] 155 | =(∀ t. t → t, []) 156 | Type: ∀ t. t → t 157 | Context: [] 158 | 159 | Expr: (λid. (id : ∀ t. t → t) id ()) ((λx. x) : ∀ t. t → t) 160 | typesynth([], (λid. (id : ∀ t. t → t) id ()) ((λx. x) : ∀ t. t → t)) 161 | typesynth([], λid. (id : ∀ t. t → t) id ()) 162 | typecheck([∃ 'a, ∃ 'b, $a : ∃ 'a], ($a : ∀ t. t → t) $a (), ∃ 'b) 163 | typesynth([∃ 'a, ∃ 'b, $a : ∃ 'a], ($a : ∀ t. t → t) $a ()) 164 | typesynth([∃ 'a, ∃ 'b, $a : ∃ 'a], ($a : ∀ t. t → t) $a) 165 | typesynth([∃ 'a, ∃ 'b, $a : ∃ 'a], $a : ∀ t. t → t) 166 | typecheck([∃ 'a, ∃ 'b, $a : ∃ 'a], $a, ∀ t. t → t) 167 | typecheck([∃ 'a, ∃ 'b, $a : ∃ 'a, 'c], $a, 'c → 'c) 168 | typesynth([∃ 'a, ∃ 'b, $a : ∃ 'a, 'c], $a) 169 | =(∃ 'a, [∃ 'a, ∃ 'b, $a : ∃ 'a, 'c]) 170 | subtype([∃ 'a, ∃ 'b, $a : ∃ 'a, 'c], ∃ 'a, 'c → 'c) 171 | instantiateL([∃ 'a, ∃ 'b, $a : ∃ 'a, 'c], 'a, 'c → 'c) 172 | instantiateR([∃ 'e, ∃ 'd, ∃ 'a = ∃ 'd → ∃ 'e, ∃ 'b, $a : ∃ 'a, 'c], 'c, 'd) 173 | bidi-exe: The impossible happened! instantiateR: ([∃ 'e, ∃ 'd, ∃ 'a = ∃ 'd → ∃ 'e, ∃ 'b, $a : ∃ 'a, 'c], 'c, 'd) 174 | CallStack (from HasCallStack): 175 | error, called at src/Type.hs:138:12 in bidi-0.1.0.0-2YE488XkexRCiPc9O4TXbA:Type 176 | --------------------------------------------------------------------------------