├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── qtt.cabal ├── src ├── Bound │ └── Context.hs ├── Context.hs ├── Inductive.hs ├── Syntax.hs ├── Syntax │ └── Pretty.hs ├── TypeError.hs ├── Typecheck.hs └── Unify.hs └── test ├── Main.hs └── Test ├── Pretty.hs ├── Typecheck.hs ├── Unify.hs └── Utils.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .ghc.* 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for qtt 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, Isaac Elliott 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 Isaac Elliott 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 | # qtt 2 | 3 | 4 | A toy implementation of Quantitative Type Theory[^1][^2], with subusaging. 5 | 6 | [^1]: McBride, C. (2016). I got plenty o’nuttin’. In A List of Successes That Can Change the World (pp. 207-233). Springer, Cham. 7 | 8 | [^2]: Atkey, R. (2018, May). The syntax and semantics of quantitative type theory. In 33rd ACM/IEEE Symp. on Logic in Computer Science (LICS’18). 9 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /qtt.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | 3 | name: qtt 4 | version: 0.1.0.0 5 | license: BSD-3-Clause 6 | license-file: LICENSE 7 | author: Isaac Elliott 8 | maintainer: isaace71295@gmail.com 9 | category: Language 10 | extra-source-files: CHANGELOG.md 11 | 12 | library 13 | exposed-modules: Bound.Context 14 | , Context 15 | , Syntax 16 | , Syntax.Pretty 17 | , Inductive 18 | , TypeError 19 | , Typecheck 20 | , Unify 21 | build-depends: base >=4.12 && <5 22 | , ansi-wl-pprint 23 | , bound 24 | , comonad 25 | , containers 26 | , deriving-compat 27 | , lens 28 | , mtl 29 | , semirings 30 | , text >= 1.2 31 | , these 32 | , transformers >= 0.5 33 | ghc-options: -Wall -Werror -Wredundant-constraints 34 | hs-source-dirs: src 35 | default-language: Haskell2010 36 | 37 | test-suite qtt-tests 38 | type: exitcode-stdio-1.0 39 | other-modules: Test.Typecheck 40 | , Test.Pretty 41 | , Test.Unify 42 | , Test.Utils 43 | build-depends: base >=4.12 && <5 44 | , qtt 45 | , ansi-wl-pprint 46 | , bound 47 | , containers 48 | , hspec 49 | , transformers >= 0.5 50 | main-is: Main.hs 51 | ghc-options: -Wall -Werror 52 | hs-source-dirs: test 53 | default-language: Haskell2010 -------------------------------------------------------------------------------- /src/Bound/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | 7 | module Bound.Context ( 8 | Context, 9 | empty, 10 | fromList, 11 | lookup, 12 | insert, 13 | delete, 14 | shift, 15 | merge, 16 | split, 17 | zipWithKeyA, 18 | zipWithKey, 19 | ) where 20 | 21 | import Bound (Var (..)) 22 | import Control.Lens.Indexed (FoldableWithIndex (..)) 23 | import Data.Foldable (foldl') 24 | import Data.Functor.Identity (Identity (..)) 25 | import Data.Map (Map) 26 | import qualified Data.Map as Map 27 | import qualified Data.Map.Merge.Strict as Map.Merge 28 | import Data.These (These (..)) 29 | import Prelude hiding (lookup) 30 | 31 | data Context k v where 32 | Free :: Map k v -> Context k v 33 | Binder :: (Ord k, Ord k') => Map k v -> Context k' v -> Context (Var k k') v 34 | 35 | deriving instance Functor (Context k) 36 | deriving instance Foldable (Context k) 37 | deriving instance Traversable (Context k) 38 | 39 | instance FoldableWithIndex k (Context k) where 40 | ifoldMap f ctx = 41 | case ctx of 42 | Free frees -> ifoldMap f frees 43 | Binder bs ctx' -> ifoldMap (f . B) bs <> ifoldMap (f . F) ctx' 44 | 45 | instance Ord k => Semigroup (Context k v) where 46 | ctx1 <> ctx2 = 47 | case ctx1 of 48 | Free frees1 -> 49 | Map.foldlWithKey (\acc k v -> insert k v acc) ctx2 frees1 50 | Binder bs1 ctx1' -> 51 | let (bs2, ctx2') = split ctx2 52 | in Binder (bs1 <> bs2) (ctx1' <> ctx2') 53 | 54 | instance Ord k => Monoid (Context k v) where 55 | mempty = empty 56 | 57 | empty :: Ord k => Context k v 58 | empty = Free mempty 59 | 60 | fromList :: Ord k => [(k, v)] -> Context k v 61 | fromList = foldl' (\acc (k, v) -> insert k v acc) empty 62 | 63 | lookup :: Ord k => k -> Context k v -> Maybe v 64 | lookup k ctx = 65 | case ctx of 66 | Free frees -> Map.lookup k frees 67 | Binder bs ctx' -> 68 | case k of 69 | B k' -> Map.lookup k' bs 70 | F k' -> lookup k' ctx' 71 | 72 | insert :: Ord k => k -> v -> Context k v -> Context k v 73 | insert k v ctx = 74 | case ctx of 75 | Free frees -> Free (Map.insert k v frees) 76 | Binder bs ctx' -> 77 | case k of 78 | B k' -> Binder (Map.insert k' v bs) ctx' 79 | F k' -> Binder bs (insert k' v ctx') 80 | 81 | delete :: Ord k => k -> Context k v -> Context k v 82 | delete k ctx = 83 | case ctx of 84 | Free frees -> Free (Map.delete k frees) 85 | Binder bs ctx' -> 86 | case k of 87 | B k' -> Binder (Map.delete k' bs) ctx' 88 | F k' -> Binder bs (delete k' ctx') 89 | 90 | shift :: (Ord a, Ord b) => Context b v -> Context (Var a b) v 91 | shift = Binder mempty 92 | 93 | merge :: (Ord a, Ord b) => Map a v -> Context b v -> Context (Var a b) v 94 | merge a b = 95 | Map.foldlWithKey 96 | (\acc k v -> insert (B k) v acc) 97 | (shift b) 98 | a 99 | 100 | split :: (Ord a, Ord b) => Context (Var a b) v -> (Map a v, Context b v) 101 | split ctx = 102 | case ctx of 103 | Free frees -> 104 | Map.foldlWithKey' 105 | ( \(mav, cbc) k v -> 106 | case k of 107 | B k' -> (Map.insert k' v mav, cbc) 108 | F k' -> (mav, insert k' v cbc) 109 | ) 110 | (mempty, empty) 111 | frees 112 | Binder bs ctx' -> (bs, ctx') 113 | 114 | zipWithKeyA :: 115 | (Ord k, Applicative m) => 116 | (k -> These a b -> m (Maybe c)) -> 117 | Context k a -> 118 | Context k b -> 119 | m (Context k c) 120 | zipWithKeyA f ctx1 ctx2 = 121 | case ctx1 of 122 | Free frees1 -> 123 | case ctx2 of 124 | Free frees2 -> 125 | Free <$> ezpz f frees1 frees2 126 | Binder bs2 ctx2' -> 127 | let (bs1, ctx1') = split ctx1 128 | in Binder <$> ezpz (f . B) bs1 bs2 <*> zipWithKeyA (f . F) ctx1' ctx2' 129 | Binder bs1 ctx1' -> 130 | case ctx2 of 131 | Free{} -> 132 | let (bs2, ctx2') = split ctx2 133 | in Binder <$> ezpz (f . B) bs1 bs2 <*> zipWithKeyA (f . F) ctx1' ctx2' 134 | Binder bs2 ctx2' -> 135 | Binder <$> ezpz (f . B) bs1 bs2 <*> zipWithKeyA (f . F) ctx1' ctx2' 136 | where 137 | ezpz :: 138 | (Ord k, Applicative m) => 139 | (k -> These a b -> m (Maybe c)) -> 140 | Map k a -> 141 | Map k b -> 142 | m (Map k c) 143 | ezpz g = 144 | Map.Merge.mergeA 145 | (Map.Merge.traverseMaybeMissing $ \k a -> g k (This a)) 146 | (Map.Merge.traverseMaybeMissing $ \k b -> g k (That b)) 147 | (Map.Merge.zipWithMaybeAMatched $ \k a b -> g k (These a b)) 148 | 149 | zipWithKey :: 150 | Ord k => 151 | (k -> These a b -> Maybe c) -> 152 | Context k a -> 153 | Context k b -> 154 | Context k c 155 | zipWithKey f a b = runIdentity $ zipWithKeyA (\k -> Identity . f k) a b -------------------------------------------------------------------------------- /src/Context.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveFunctor #-} 2 | {-# language TemplateHaskell #-} 3 | module Context where 4 | 5 | import Control.Lens.TH (makeLenses) 6 | import Data.Map (Map) 7 | 8 | import Syntax 9 | 10 | data Entry n l a 11 | = InductiveEntry { _entryType :: Ty n l a, _entryCtors :: Map n (Term n l a) } 12 | | BindingEntry { _entryType :: Ty n l a } 13 | | CtorEntry { _entryType :: Ty n l a } 14 | deriving (Eq, Show, Functor) 15 | makeLenses ''Entry -------------------------------------------------------------------------------- /src/Inductive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Inductive where 5 | 6 | import Bound.Context (Context) 7 | import Bound.Scope (fromScope) 8 | import Bound.Var (Var (..)) 9 | import Control.Monad (unless) 10 | import Control.Monad.Writer.Strict (runWriter, tell) 11 | import Data.Map (Map) 12 | import qualified Data.Map as Map 13 | 14 | import Context 15 | import Syntax 16 | import TypeError 17 | import Typecheck 18 | 19 | data Inductive n l a = Inductive 20 | { _indTypeName :: a 21 | , _indTypeType :: Term n l a 22 | , _indConstructors :: Map a (Term n l a) 23 | } 24 | deriving (Eq, Show) 25 | 26 | data InductiveError l a 27 | = IndTypeError a (TypeError l a) 28 | | IndIncorrectType a 29 | | IndNotStrictlyPositive a 30 | deriving (Eq, Show) 31 | 32 | returnsCtor :: forall n l a. Eq a => Term n l a -> a -> Bool 33 | returnsCtor = go id 34 | where 35 | go :: forall x. Eq x => (a -> x) -> Term n l x -> a -> Bool 36 | go ctx (Pi _ _ _ rest) val = go (F . ctx) (fromScope rest) val 37 | go ctx (App a _) val = go ctx a val 38 | go ctx (Var a) val = a == ctx val 39 | go _ _ _ = False 40 | 41 | strictlyPositiveIn :: forall n l a. Eq a => a -> Term n l a -> Bool 42 | strictlyPositiveIn = go id 43 | where 44 | validArgPi :: forall x. Eq x => (a -> x) -> a -> Term n l x -> Bool 45 | validArgPi ctx val (Pi _ _ ty rest) = 46 | ctx val `notElem` ty 47 | && validArgPi (F . ctx) val (fromScope rest) 48 | validArgPi ctx val ty = validArgApp ctx val ty 49 | 50 | validArgApp ctx val (App a b) = 51 | ctx val `notElem` b 52 | && validArgApp ctx val a 53 | validArgApp _ _ _ = True 54 | 55 | go :: forall x. Eq x => (a -> x) -> a -> Term n l x -> Bool 56 | go ctx val (Pi _ _ ty rest) = 57 | validArgPi ctx val ty 58 | && go (F . ctx) val (fromScope rest) 59 | go _ _ _ = True 60 | 61 | checkInductive :: 62 | Ord a => 63 | Context a (Entry a l a) -> 64 | Context a Usage -> 65 | Inductive a l a -> 66 | [InductiveError l a] 67 | checkInductive ctx usages ind = snd $ runWriter go 68 | where 69 | go = do 70 | case checkType (Env id id ctx usages) (_indTypeType ind) Type of 71 | Left e -> tell [IndTypeError (_indTypeName ind) e] 72 | Right _ -> pure () 73 | Map.traverseWithKey checkCtor (_indConstructors ind) 74 | 75 | checkCtor n ty = do 76 | case checkType (Env id id ctx usages) ty Type of 77 | Left e -> tell [IndTypeError (_indTypeName ind) e] 78 | Right _ -> pure () 79 | unless (ty `returnsCtor` _indTypeName ind) $ 80 | tell [IndIncorrectType n] 81 | unless (_indTypeName ind `strictlyPositiveIn` ty) $ 82 | tell [IndNotStrictlyPositive n] -------------------------------------------------------------------------------- /src/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | module Syntax where 12 | 13 | import Bound.Class (Bound (..)) 14 | import Bound.Scope (Scope, abstract, abstract1) 15 | import Control.Monad (ap) 16 | import Control.Monad.Trans.Class (lift) 17 | import Data.Deriving (deriveShow1) 18 | import Data.Functor.Classes (Eq1 (..), Show1 (..), eq1, showsPrec1) 19 | import Data.List (elemIndex) 20 | import Data.List.NonEmpty (NonEmpty) 21 | import Data.Maybe (isJust) 22 | import Data.Semiring (Semiring (..)) 23 | import Data.Type.Equality ((:~:) (..)) 24 | import GHC.Exts (IsString) 25 | import Text.PrettyPrint.ANSI.Leijen (Pretty (..)) 26 | 27 | import qualified Text.PrettyPrint.ANSI.Leijen as Pretty 28 | 29 | data Usage = Zero | One | Many 30 | deriving (Eq, Show) 31 | 32 | instance Ord Usage where 33 | compare Zero Zero = EQ 34 | compare Zero _ = LT 35 | compare _ Zero = GT 36 | compare One One = EQ 37 | compare One _ = LT 38 | compare _ One = GT 39 | compare Many Many = EQ 40 | 41 | instance Pretty Usage where 42 | pretty Zero = Pretty.char '0' 43 | pretty One = Pretty.char '1' 44 | pretty Many = Pretty.char 'w' 45 | 46 | instance Semiring Usage where 47 | zero = Zero 48 | 49 | plus Zero m = m 50 | plus One Zero = One 51 | plus One One = Many 52 | plus One Many = Many 53 | plus Many _ = Many 54 | 55 | one = One 56 | 57 | times Zero _ = Zero 58 | times One m = m 59 | times Many Zero = Zero 60 | times Many One = Many 61 | times Many Many = Many 62 | 63 | data Pattern c p where 64 | PVar :: c -> Pattern c () 65 | PCtor :: c -> [c] -> Int -> Pattern c Int 66 | deriving instance Show c => Show (Pattern c p) 67 | 68 | eqPattern :: Eq c => Pattern c p -> Pattern c p' -> Maybe (p :~: p') 69 | eqPattern (PVar _) (PVar _) = Just Refl 70 | eqPattern (PCtor a _ b) (PCtor a' _ b') | a == a', b == b' = Just Refl 71 | eqPattern _ _ = Nothing 72 | 73 | data Path p where 74 | V :: Path () 75 | C :: Int -> Path Int 76 | deriving instance Eq (Path p) 77 | deriving instance Ord (Path p) 78 | deriving instance Show (Path p) 79 | 80 | pathVal :: Path p -> p 81 | pathVal V = () 82 | pathVal (C n) = n 83 | 84 | pathArgName :: Pattern c p -> Path p -> c 85 | pathArgName (PVar c) V = c 86 | pathArgName (PCtor _ cs _) (C ix) = cs !! ix 87 | 88 | data Branch n f a 89 | = forall p. Branch (Pattern n p) (Scope (Path p) f a) 90 | | forall p. BranchImpossible (Pattern n p) 91 | deriving instance Functor f => Functor (Branch n f) 92 | deriving instance Foldable f => Foldable (Branch n f) 93 | deriving instance Traversable f => Traversable (Branch n f) 94 | 95 | instance (Monad f, Eq1 f, Eq n) => Eq1 (Branch n f) where 96 | liftEq f (Branch a b) (Branch a' b') = 97 | case eqPattern a a' of 98 | Just Refl -> liftEq f b b' 99 | Nothing -> False 100 | liftEq _ (BranchImpossible a) (BranchImpossible a') = 101 | isJust $ eqPattern a a' 102 | liftEq _ _ _ = False 103 | 104 | instance (Monad f, Eq n, Eq1 f, Eq a) => Eq (Branch n f a) where 105 | (==) = eq1 106 | 107 | instance (Show n, Show1 f) => Show1 (Branch n f) where 108 | liftShowsPrec sp sl d (Branch a b) = 109 | showParen (d > 10) $ 110 | showString "Branch " 111 | . showsPrec 11 a 112 | . showString " " 113 | . liftShowsPrec sp sl 11 b 114 | liftShowsPrec _ _ d (BranchImpossible a) = 115 | showParen (d > 10) $ 116 | showString "Branch " 117 | . showsPrec 11 a 118 | 119 | instance (Show n, Show1 f, Show a) => Show (Branch n f a) where 120 | showsPrec = showsPrec1 121 | 122 | instance Bound (Branch n) where 123 | Branch a b >>>= f = Branch a (b >>>= f) 124 | BranchImpossible a >>>= _ = BranchImpossible a 125 | 126 | type Ty = Term 127 | data Term n l a 128 | = Var a 129 | | Ann (Term n l a) Usage (Term n l a) 130 | | Type 131 | | Lam n (Scope () (Term n l) a) 132 | | Pi Usage n (Term n l a) (Scope () (Term n l) a) 133 | | App (Term n l a) (Term n l a) 134 | | MkTensor (Term n l a) (Term n l a) 135 | | Tensor n Usage (Term n l a) (Scope () (Term n l) a) 136 | | UnpackTensor n n (Term n l a) (Scope Bool (Term n l) a) 137 | | MkWith (Term n l a) (Term n l a) 138 | | With (Term n l a) (Term n l a) 139 | | Fst (Term n l a) 140 | | Snd (Term n l a) 141 | | Unit 142 | | MkUnit 143 | | Case (Term n l a) (NonEmpty (Branch n (Term n l) a)) 144 | | Loc l (Term n l a) 145 | deriving (Functor, Foldable, Traversable) 146 | deriveShow1 ''Term 147 | 148 | instance (Show n, Show l, Show a) => Show (Term n l a) where 149 | showsPrec = showsPrec1 150 | 151 | instance Eq1 (Term n l) where 152 | liftEq _ Type Type = True 153 | liftEq f (Var a) (Var a') = f a a' 154 | liftEq f (Ann a b c) (Ann a' b' c') = 155 | liftEq f a a' && b == b' && liftEq f c c' 156 | liftEq f (Lam _ a) (Lam _ a') = liftEq f a a' 157 | liftEq f (Pi a _ b c) (Pi a' _ b' c') = 158 | a == a' && liftEq f b b' && liftEq f c c' 159 | liftEq f (App a b) (App a' b') = liftEq f a a' && liftEq f b b' 160 | liftEq f (MkTensor a b) (MkTensor a' b') = liftEq f a a' && liftEq f b b' 161 | liftEq f (Tensor _ u a b) (Tensor _ u' a' b') = u == u' && liftEq f a a' && liftEq f b b' 162 | liftEq f (UnpackTensor _ _ a b) (UnpackTensor _ _ a' b') = 163 | liftEq f a a' && liftEq f b b' 164 | liftEq f (MkWith a b) (MkWith a' b') = liftEq f a a' && liftEq f b b' 165 | liftEq f (With a b) (With a' b') = liftEq f a a' && liftEq f b b' 166 | liftEq f (Fst a) (Fst a') = liftEq f a a' 167 | liftEq f (Snd a) (Snd a') = liftEq f a a' 168 | liftEq _ Unit Unit = True 169 | liftEq _ MkUnit MkUnit = True 170 | liftEq f (Loc _ a) b = liftEq f a b 171 | liftEq f a (Loc _ b) = liftEq f a b 172 | liftEq _ _ _ = False 173 | 174 | instance Eq a => Eq (Term n l a) where 175 | (==) = eq1 176 | 177 | instance Applicative (Term n l) where pure = return; (<*>) = ap 178 | instance Monad (Term n l) where 179 | return = Var 180 | 181 | tm >>= f = 182 | case tm of 183 | Var a -> f a 184 | Ann a b c -> Ann (a >>= f) b (c >>= f) 185 | Type -> Type 186 | Lam n a -> Lam n (a >>>= f) 187 | Pi a n b c -> Pi a n (b >>= f) (c >>>= f) 188 | App a b -> App (a >>= f) (b >>= f) 189 | MkTensor a b -> MkTensor (a >>= f) (b >>= f) 190 | Tensor n u a b -> Tensor n u (a >>= f) (b >>>= f) 191 | UnpackTensor n1 n2 a b -> UnpackTensor n1 n2 (a >>= f) (b >>>= f) 192 | MkWith a b -> MkWith (a >>= f) (b >>= f) 193 | With a b -> With (a >>= f) (b >>= f) 194 | Fst a -> Fst (a >>= f) 195 | Snd a -> Snd (a >>= f) 196 | Unit -> Unit 197 | MkUnit -> MkUnit 198 | Case a b -> Case (a >>= f) (fmap (>>>= f) b) 199 | Loc a b -> Loc a (b >>= f) 200 | 201 | unfoldApps :: Term n l a -> (Term n l a, [Term n l a]) 202 | unfoldApps = go [] 203 | where 204 | go as (App a b) = go (b : as) a 205 | go as a = (a, as) 206 | 207 | lam :: Eq a => a -> Term a l a -> Term a l a 208 | lam a = Lam a . abstract1 a 209 | 210 | pi :: Eq a => (a, Ty a l a) -> Term a l a -> Term a l a 211 | pi (a, ty) = Pi Many a ty . abstract1 a 212 | 213 | lpi :: Eq a => (a, Ty a l a) -> Term a l a -> Term a l a 214 | lpi (a, ty) = Pi One a ty . abstract1 a 215 | 216 | forall_ :: Eq a => (a, Ty a l a) -> Term a l a -> Term a l a 217 | forall_ (a, ty) = Pi Zero a ty . abstract1 a 218 | 219 | arr :: IsString n => Term n l a -> Term n l a -> Term n l a 220 | arr a b = Pi Many "_" a $ lift b 221 | 222 | limp :: IsString n => Term n l a -> Term n l a -> Term n l a 223 | limp a b = Pi One "_" a $ lift b 224 | 225 | tensor :: Eq a => (a, Usage, Ty a l a) -> Ty a l a -> Ty a l a 226 | tensor (a, u, ty) = Tensor a u ty . abstract1 a 227 | 228 | with :: Ty a l a -> Ty a l a -> Ty a l a 229 | with = With 230 | 231 | unpackTensor :: Eq a => (a, a) -> Term a l a -> Term a l a -> Term a l a 232 | unpackTensor (x, y) m n = 233 | UnpackTensor x y m $ 234 | abstract 235 | ( \z -> 236 | if z == x 237 | then Just False 238 | else if z == y then Just True else Nothing 239 | ) 240 | n 241 | 242 | varb :: (Eq a, Monad f) => a -> f a -> Branch a f a 243 | varb a = Branch (PVar a) . abstract (\x -> if x == a then Just V else Nothing) 244 | 245 | ctorb :: (Eq a, Monad f) => a -> [a] -> f a -> Branch a f a 246 | ctorb a b = Branch (PCtor a b bl) . abstract (fmap C . (`elemIndex` b)) 247 | where 248 | bl = length b 249 | 250 | varb_imp :: a -> Branch a f a 251 | varb_imp a = BranchImpossible (PVar a) 252 | 253 | ctorb_imp :: a -> [a] -> Branch a f a 254 | ctorb_imp a b = BranchImpossible (PCtor a b (length b)) -------------------------------------------------------------------------------- /src/Syntax/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyCase #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | 5 | module Syntax.Pretty where 6 | 7 | import Bound.Scope (fromScope) 8 | import Bound.Var (unvar) 9 | import Control.Lens.Cons (_Snoc) 10 | import Control.Lens.Fold ((^?)) 11 | import Data.Bool (bool) 12 | import Data.List.NonEmpty (NonEmpty (..)) 13 | import Text.PrettyPrint.ANSI.Leijen (Doc, Pretty (..)) 14 | 15 | import qualified Text.PrettyPrint.ANSI.Leijen as Pretty 16 | 17 | import Syntax 18 | 19 | hangCase :: (Term n l a -> Doc) -> Term n l a -> Doc 20 | hangCase f a@Case{} = Pretty.line <> Pretty.indent 2 (f a) 21 | hangCase f a = f a 22 | 23 | prettyPattern :: Pretty n => Pattern n a -> Doc 24 | prettyPattern p = 25 | case p of 26 | PVar n -> pretty n 27 | PCtor s ns _ -> Pretty.hsep $ pretty s : fmap pretty ns 28 | 29 | prettyBranch :: Pretty n => (a -> Doc) -> Branch n (Term n l) a -> Doc 30 | prettyBranch _ (BranchImpossible a) = 31 | Pretty.hsep 32 | [ prettyPattern a 33 | , Pretty.text "impossible" 34 | ] 35 | prettyBranch pvar (Branch a b) = 36 | Pretty.hsep 37 | [ prettyPattern a 38 | , Pretty.text "=>" 39 | , hangCase 40 | (prettyTerm (unvar (pretty . pathArgName a) pvar)) 41 | (fromScope b) 42 | ] 43 | 44 | prettyTerm :: Pretty n => (a -> Doc) -> Term n l a -> Doc 45 | prettyTerm pvar tm = 46 | case tm of 47 | Loc _ a -> prettyTerm pvar a 48 | Var a -> pvar a 49 | Ann a b c -> 50 | Pretty.hsep 51 | [ ( case a of 52 | Lam{} -> Pretty.parens 53 | Pi{} -> Pretty.parens 54 | UnpackTensor{} -> Pretty.parens 55 | Case{} -> Pretty.parens 56 | _ -> id 57 | ) 58 | (prettyTerm pvar a) 59 | , Pretty.char ':' <> pretty b 60 | , prettyTerm pvar c 61 | ] 62 | Type -> Pretty.text "Type" 63 | Lam n s -> 64 | Pretty.hsep 65 | [ Pretty.char '\\' <> pretty n 66 | , Pretty.text "=>" 67 | , prettyTerm (unvar (const $ pretty n) pvar) (fromScope s) 68 | ] 69 | Pi a n b c -> 70 | Pretty.hsep 71 | [ Pretty.parens $ 72 | Pretty.hsep 73 | [ pretty n 74 | , Pretty.char ':' <> pretty a 75 | , prettyTerm pvar b 76 | ] 77 | , Pretty.text "->" 78 | , prettyTerm (unvar (const $ pretty n) pvar) (fromScope c) 79 | ] 80 | App a b -> 81 | Pretty.hsep 82 | [ ( case a of 83 | Lam{} -> Pretty.parens 84 | Pi{} -> Pretty.parens 85 | UnpackTensor{} -> Pretty.parens 86 | Case{} -> Pretty.parens 87 | _ -> id 88 | ) 89 | (prettyTerm pvar a) 90 | , ( case b of 91 | Lam{} -> Pretty.parens 92 | Pi{} -> Pretty.parens 93 | UnpackTensor{} -> Pretty.parens 94 | App{} -> Pretty.parens 95 | Fst{} -> Pretty.parens 96 | Snd{} -> Pretty.parens 97 | Case{} -> Pretty.parens 98 | _ -> id 99 | ) 100 | (prettyTerm pvar b) 101 | ] 102 | MkTensor a b -> 103 | Pretty.parens $ 104 | prettyTerm pvar a 105 | <> Pretty.comma 106 | <> Pretty.space 107 | <> prettyTerm pvar b 108 | Tensor n u a b -> 109 | Pretty.parens $ 110 | Pretty.hsep [pretty n, Pretty.char ':' <> pretty u, prettyTerm pvar a] 111 | <> Pretty.char '⨂' 112 | <> Pretty.space 113 | <> prettyTerm (unvar (const $ pretty n) pvar) (fromScope b) 114 | UnpackTensor n1 n2 a b -> 115 | Pretty.hsep 116 | [ Pretty.text "let" 117 | , Pretty.parens $ 118 | pretty n1 <> Pretty.comma <> Pretty.space <> pretty n2 119 | , Pretty.char '=' 120 | , ( case a of 121 | UnpackTensor{} -> Pretty.parens 122 | _ -> id 123 | ) 124 | (prettyTerm pvar a) 125 | , Pretty.text "in" 126 | , prettyTerm (unvar (pretty . bool n1 n2) pvar) (fromScope b) 127 | ] 128 | MkWith a b -> 129 | Pretty.parens $ 130 | prettyTerm pvar a 131 | <> Pretty.comma 132 | <> Pretty.space 133 | <> prettyTerm pvar b 134 | With a b -> 135 | Pretty.parens $ 136 | prettyTerm pvar a 137 | <> Pretty.space 138 | <> Pretty.char '&' 139 | <> Pretty.space 140 | <> prettyTerm pvar b 141 | Fst a -> 142 | Pretty.hsep 143 | [ Pretty.text "fst" 144 | , ( case a of 145 | App{} -> Pretty.parens 146 | Pi{} -> Pretty.parens 147 | Lam{} -> Pretty.parens 148 | Case{} -> Pretty.parens 149 | Fst{} -> Pretty.parens 150 | Snd{} -> Pretty.parens 151 | _ -> id 152 | ) 153 | (prettyTerm pvar a) 154 | ] 155 | Snd a -> 156 | Pretty.hsep 157 | [ Pretty.text "snd" 158 | , ( case a of 159 | App{} -> Pretty.parens 160 | Pi{} -> Pretty.parens 161 | Lam{} -> Pretty.parens 162 | Case{} -> Pretty.parens 163 | Fst{} -> Pretty.parens 164 | Snd{} -> Pretty.parens 165 | _ -> id 166 | ) 167 | (prettyTerm pvar a) 168 | ] 169 | Unit -> Pretty.text "Unit" 170 | MkUnit -> Pretty.text "unit" 171 | Case a (bh :| brest) -> 172 | Pretty.hsep 173 | [ Pretty.text "case" 174 | , ( case a of 175 | Case{} -> Pretty.parens 176 | Lam{} -> Pretty.parens 177 | Pi{} -> Pretty.parens 178 | _ -> id 179 | ) 180 | (prettyTerm pvar a) 181 | , Pretty.text "of" 182 | ] 183 | Pretty.<$> Pretty.indent 184 | 2 185 | ( Pretty.char '{' <> Pretty.space <> prettyBranch pvar bh 186 | Pretty.<$> case brest ^? _Snoc of 187 | Nothing -> Pretty.char '}' 188 | Just (bmiddle, blast) -> 189 | foldMap 190 | ( (\x -> Pretty.char ';' <> Pretty.space <> x <> Pretty.line) 191 | . prettyBranch pvar 192 | ) 193 | bmiddle 194 | <> Pretty.char ';' 195 | <> Pretty.space 196 | <> prettyBranch pvar blast 197 | Pretty.<$> Pretty.char '}' 198 | ) 199 | -------------------------------------------------------------------------------- /src/TypeError.hs: -------------------------------------------------------------------------------- 1 | module TypeError where 2 | 3 | import Data.Set (Set) 4 | 5 | import Syntax 6 | 7 | data TypeError l a 8 | = NotInScope a 9 | | UsingErased a 10 | | UnusedLinear a 11 | | OverusedLinear a 12 | | ExpectedType (Term a l a) 13 | | ExpectedPi (Term a l a) 14 | | ExpectedTensor (Term a l a) 15 | | ExpectedWith (Term a l a) 16 | | ExpectedUnit (Term a l a) 17 | | TypeMismatch (Term a l a) (Term a l a) 18 | | Can'tInfer (Term a l a) 19 | | NotConstructorFor a (Term a l a) 20 | | TooManyArguments a 21 | | NotEnoughArguments a 22 | | NotImpossible 23 | | UnmatchedCases (Set a) 24 | | UnknownSolution (Term a l a) (Term a l a) 25 | deriving (Eq, Show) 26 | -------------------------------------------------------------------------------- /src/Typecheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | 11 | module Typecheck ( 12 | Env (..), 13 | checkType, 14 | checkTerm, 15 | inferType, 16 | inferTerm, 17 | ) where 18 | 19 | import Bound.Context (Context) 20 | import qualified Bound.Context as Context 21 | import Bound.Scope (fromScope, instantiate, instantiate1, toScope) 22 | import Bound.Var (Var (..), unvar) 23 | import Control.Lens.Getter (to, view, (^.)) 24 | import Control.Lens.Setter (mapped, over, (.~)) 25 | import Control.Lens.TH (makeLenses) 26 | import Control.Lens.Tuple (_3) 27 | import Data.Bool (bool) 28 | import Data.Foldable (traverse_) 29 | import Data.Function ((&)) 30 | import Data.List.NonEmpty (NonEmpty (..)) 31 | import Data.Map (Map) 32 | import qualified Data.Map as Map 33 | import Data.Maybe (fromMaybe) 34 | import Data.Semiring (times) 35 | import Data.Set (Set) 36 | import qualified Data.Set as Set 37 | import Data.These (These (..)) 38 | import GHC.Stack (HasCallStack) 39 | 40 | import Context 41 | import Syntax 42 | import TypeError 43 | import Unify 44 | 45 | data Env a l x = Env 46 | { _envDepth :: a -> x 47 | , _envNames :: x -> a 48 | , _envTypes :: Context x (Entry a l x) 49 | , _envUsages :: Context x Usage 50 | } 51 | makeLenses ''Env 52 | 53 | pickBranch :: 54 | Eq x => 55 | (a -> x) -> 56 | Term a l x -> 57 | [Term a l x] -> 58 | NonEmpty (Branch a (Term a l) x) -> 59 | Term a l x 60 | pickBranch depth f xs (BranchImpossible _ :| bs) = 61 | case bs of 62 | [] -> error "pickBranch: no brach to take" 63 | bb : bbs -> pickBranch depth f xs (bb :| bbs) 64 | pickBranch depth f xs (Branch p v :| bs) = 65 | case p of 66 | PVar _ -> instantiate (\case V -> foldl App f xs) v 67 | PCtor n _ count -> 68 | case f of 69 | Var n' -> 70 | if n' == depth n 71 | then 72 | if count == length xs 73 | then instantiate (\case C x -> xs !! x) v 74 | else error "pickBranch: incorrect number of arguments to constructor" 75 | else case bs of 76 | [] -> error "pickBranch: no brach to take" 77 | bb : bbs -> pickBranch depth f xs (bb :| bbs) 78 | _ -> error "pickBranch: can't match on non-var" 79 | 80 | eval :: Eq x => (a -> x) -> Term a l x -> Term a l x 81 | eval depth tm = 82 | case tm of 83 | Loc _ a -> eval depth a 84 | Var a -> Var a 85 | Ann a _ _ -> a 86 | Type -> Type 87 | Lam n a -> Lam n $ evalScope depth a 88 | Pi u n a b -> Pi u n (eval depth a) (evalScope depth b) 89 | App a b -> 90 | case eval depth a of 91 | Lam _ s -> eval depth $ instantiate1 b s 92 | a' -> App a' $ eval depth b 93 | MkTensor a b -> MkTensor (eval depth a) (eval depth b) 94 | Tensor n u a b -> Tensor n u (eval depth a) (evalScope depth b) 95 | UnpackTensor m n a b -> 96 | case eval depth a of 97 | MkTensor x y -> eval depth $ instantiate (bool x y) b 98 | a' -> UnpackTensor m n a' $ evalScope depth b 99 | MkWith a b -> MkWith (eval depth a) (eval depth b) 100 | With a b -> With (eval depth a) (eval depth b) 101 | Fst a -> 102 | case eval depth a of 103 | MkWith x _ -> x 104 | a' -> Fst a' 105 | Snd a -> 106 | case eval depth a of 107 | MkWith _ y -> y 108 | a' -> Snd a' 109 | Unit -> Unit 110 | MkUnit -> MkUnit 111 | Case a bs -> let (f, xs) = unfoldApps (eval depth a) in pickBranch depth f xs bs 112 | where 113 | evalScope d = toScope . eval (F . d) . fromScope 114 | 115 | unsafeGetUsage :: Ord a => a -> Context a b -> b 116 | unsafeGetUsage a usages = 117 | case Context.lookup a usages of 118 | Nothing -> error "check: bound variable's usage was not found" 119 | Just u -> u 120 | 121 | unsafeCheckConsumed :: 122 | Ord x => 123 | -- | Variable names 124 | (x -> a) -> 125 | -- | Expected usage 126 | Usage -> 127 | -- | Variable 128 | x -> 129 | -- | Usages 130 | Context x Usage -> 131 | Either (TypeError l a) () 132 | unsafeCheckConsumed names u a usages = 133 | let u' = unsafeGetUsage a usages 134 | in case (u, u') of 135 | (One, One) -> Left $ UnusedLinear $ names a 136 | _ -> pure () 137 | 138 | {- | Apply a list of arguments to a function, throwing an error 139 | if the function cannot be fully applied 140 | -} 141 | applyCtorArgs :: 142 | forall a l x. 143 | -- | Depth 144 | (a -> x) -> 145 | -- | Constructor name 146 | a -> 147 | -- | Constructor type 148 | Ty a l x -> 149 | -- | Arg names 150 | [a] -> 151 | Either 152 | (TypeError l a) 153 | -- ([Ty a l (Var (Name a (Path Int)) x)], Ty a l (Var (Name a (Path Int)) x)) 154 | ([(Usage, Ty a l x)], Ty a l x) 155 | applyCtorArgs depth ctorName = go id 0 156 | where 157 | go :: 158 | forall y. 159 | -- (y -> Var (Name a (Path Int)) x) -> 160 | (y -> x) -> 161 | -- | Current arg 162 | Int -> 163 | -- | Constructor type 164 | Ty a l y -> 165 | -- | Arg names 166 | [a] -> 167 | Either 168 | (TypeError l a) 169 | ([(Usage, Ty a l x)], Ty a l x) 170 | go _ !_ Pi{} [] = Left $ NotEnoughArguments ctorName 171 | go f !_ ctorTy [] = Right ([], f <$> ctorTy) 172 | go f !count (Pi u _ s t) (a : as) = do 173 | (tys, ret) <- 174 | go 175 | (unvar (depth . const a) f) 176 | (count + 1) 177 | (fromScope t) 178 | as 179 | pure ((u, fmap f s) : tys, ret) 180 | go _ !_ _ (_ : _) = Left $ TooManyArguments ctorName 181 | 182 | matchSubst :: Eq a => Term n l a -> Term n l a -> a -> Term n l a 183 | matchSubst inTm t = 184 | case inTm of 185 | Var v -> \x -> if x == v then t else pure x 186 | _ -> pure 187 | 188 | deeperEnv :: 189 | (Ord b, Ord x) => 190 | (b -> a) -> 191 | Map b (Entry a l x) -> 192 | Map b Usage -> 193 | Env a l x -> 194 | Env a l (Var b x) 195 | deeperEnv names types usages env = 196 | Env 197 | { _envDepth = F . _envDepth env 198 | , _envNames = unvar names (_envNames env) 199 | , _envTypes = fmap F <$> Context.merge types (_envTypes env) 200 | , _envUsages = Context.merge usages (_envUsages env) 201 | } 202 | 203 | checkBranchesMatching :: 204 | (Ord x, Ord a) => 205 | Usage -> 206 | Env a l x -> 207 | (Term a l x, Usage, Ty a l x) -> 208 | NonEmpty (Branch a (Term a l) x) -> 209 | Usage -> 210 | Ty a l x -> 211 | Map a (Term a l x) -> 212 | Maybe (Set a) -> 213 | Either (TypeError l a) (Context x Usage) 214 | -- impossible branch for a non-inductive type is not allowed 215 | checkBranchesMatching _ _ _ (BranchImpossible _ :| _) _ _ _ Nothing = 216 | Left NotImpossible 217 | -- We are not matching on an inductive type 218 | checkBranchesMatching varCost env (inTm, inUsage, inTy) (Branch p v :| bs) u outTy ctors Nothing = 219 | case p of 220 | PVar n -> do 221 | usages' <- 222 | check 223 | varCost 224 | ( deeperEnv 225 | (\V -> n) 226 | (Map.singleton V $ BindingEntry inTy) 227 | (Map.singleton V inUsage) 228 | env 229 | ) 230 | (fromScope v) 231 | u 232 | (F <$> outTy) 233 | unsafeCheckConsumed 234 | (unvar (\V -> n) (env ^. envNames)) 235 | inUsage 236 | (B V) 237 | usages' 238 | case bs of 239 | [] -> 240 | let (_, usages'') = Context.split usages' 241 | in pure usages'' 242 | bb : bbs -> checkBranchesMatching varCost env (inTm, inUsage, inTy) (bb :| bbs) u outTy ctors Nothing 243 | PCtor s _ _ -> Left $ NotConstructorFor s $ env ^. envNames <$> inTy 244 | -- impossible branch for an inductive type. the match is impossible if the inductive type has no constructors, 245 | -- or if the type of the scrutinee is incompatible with with the constructor's output 246 | checkBranchesMatching varCost env (inTm, inUsage, inTy) (BranchImpossible p :| bs) u outTy allCtors (Just remaining) = 247 | case p of 248 | PVar _ -> 249 | if Map.null allCtors 250 | then case bs of 251 | [] -> pure $ env ^. envUsages 252 | bb : bbs -> 253 | checkBranchesMatching varCost env (inTm, inUsage, inTy) (bb :| bbs) u outTy allCtors (Just remaining) 254 | else Left NotImpossible 255 | PCtor ctorName ns _ -> do 256 | ctorTy <- 257 | case Map.lookup ctorName allCtors of 258 | Nothing -> 259 | Left . NotConstructorFor ctorName $ env ^. envNames <$> inTy 260 | Just res -> pure res 261 | (_, retTy) <- applyCtorArgs (env ^. envDepth) ctorName ctorTy ns 262 | case unifyInductive (env ^. envNames) (env ^. envNames) (env ^. envTypes) inTy retTy of 263 | Right{} -> Left NotImpossible 264 | Left{} -> 265 | case bs of 266 | [] -> pure $ env ^. envUsages 267 | bb : bbs -> 268 | checkBranchesMatching varCost env (inTm, inUsage, inTy) (bb :| bbs) u outTy allCtors (Just remaining) 269 | -- We are matching on an inductive type, and cases remain for `ctors` 270 | checkBranchesMatching varCost env (inTm, inUsage, inTy) (Branch p v :| bs) u outTy allCtors (Just remaining) = 271 | case p of 272 | PVar n -> do 273 | usages' <- 274 | check 275 | varCost 276 | ( deeperEnv 277 | (\V -> n) 278 | (Map.singleton V $ BindingEntry inTy) 279 | (Map.singleton V inUsage) 280 | env 281 | ) 282 | (fromScope v) 283 | u 284 | (fmap F $ outTy >>= matchSubst inTm (Var $ (env ^. envDepth) n)) 285 | unsafeCheckConsumed (unvar (\V -> n) $ env ^. envNames) inUsage (B V) usages' 286 | case bs of 287 | [] -> 288 | let (_, usages'') = Context.split usages' 289 | in pure usages'' 290 | bb : bbs -> 291 | -- The match is now total 292 | checkBranchesMatching varCost env (inTm, inUsage, inTy) (bb :| bbs) u outTy allCtors (Just mempty) 293 | PCtor ctorName ns _ -> do 294 | ctorTy <- 295 | case Map.lookup ctorName allCtors of 296 | Nothing -> Left . NotConstructorFor ctorName $ env ^. envNames <$> inTy 297 | Just res -> pure res 298 | (args, retTy) <- applyCtorArgs (env ^. envDepth) ctorName ctorTy ns 299 | let (argUsages, argTys) = unzip args 300 | subst <- unifyInductive (env ^. envNames) (env ^. envNames) (env ^. envTypes) inTy retTy 301 | usages' <- 302 | check 303 | varCost 304 | ( deeperEnv 305 | (\(C ix) -> ns !! ix) 306 | (Map.fromList $ zipWith (\ix argTy -> (C ix, BindingEntry argTy)) [0 ..] argTys) 307 | (Map.fromList $ zipWith (\ix argUsage -> (C ix, times inUsage argUsage)) [0 ..] argUsages) 308 | env 309 | ) 310 | (fromScope v) 311 | u 312 | ( fmap F . bindSubst subst $ 313 | outTy 314 | >>= matchSubst 315 | inTm 316 | ( foldl 317 | (\b a -> App b (Var $ (env ^. envDepth) a)) 318 | (Var $ (env ^. envDepth) ctorName) 319 | ns 320 | ) 321 | ) 322 | traverse_ 323 | ( \(_, ix) -> 324 | unsafeCheckConsumed 325 | (unvar (pathArgName p) $ env ^. envNames) 326 | (times inUsage $ argUsages !! ix) 327 | (B $ C ix) 328 | usages' 329 | ) 330 | (zip ns [0 ..]) 331 | let remaining' = Set.delete ctorName remaining 332 | case bs of 333 | [] -> 334 | if Set.null remaining' 335 | then 336 | let (_, usages'') = Context.split usages' 337 | in pure usages'' 338 | else Left $ UnmatchedCases remaining 339 | bb : bbs -> 340 | checkBranchesMatching 341 | varCost 342 | env 343 | (inTm, inUsage, inTy) 344 | (bb :| bbs) 345 | u 346 | outTy 347 | allCtors 348 | (Just remaining') 349 | 350 | checkBranches :: 351 | (Ord x, Ord a) => 352 | Usage -> 353 | Env a l x -> 354 | (Term a l x, Usage, Ty a l x) -> 355 | NonEmpty (Branch a (Term a l) x) -> 356 | Usage -> 357 | Ty a l x -> 358 | Either (TypeError l a) (Context x Usage) 359 | checkBranches varCost env (inTm, inUsage, inTy) bs u outTy = do 360 | mustMatch <- 361 | case inTyCon of 362 | Var c -> do 363 | cEntry <- 364 | maybe 365 | (Left $ NotInScope $ view envNames env c) 366 | pure 367 | (view (envTypes . to (flip Context.lookup)) env c) 368 | pure $ 369 | case cEntry of 370 | InductiveEntry _ ctors -> Just ctors 371 | _ -> Nothing 372 | _ -> Right Nothing 373 | checkBranchesMatching 374 | varCost 375 | env 376 | (inTm, inUsage, inTy) 377 | bs 378 | u 379 | outTy 380 | (fromMaybe mempty mustMatch) 381 | (Map.keysSet <$> mustMatch) 382 | where 383 | (inTyCon, _) = unfoldApps inTy 384 | 385 | check :: 386 | HasCallStack => 387 | (Ord x, Ord a) => 388 | Usage -> 389 | Env a l x -> 390 | Term a l x -> 391 | Usage -> 392 | Ty a l x -> 393 | Either (TypeError l a) (Context x Usage) 394 | check _ _ _ Many _ = error "check called with usage Many" 395 | check varCost env tm u ty_ = 396 | let ty = eval (env ^. envDepth) ty_ -- pre-compute 397 | in case tm of 398 | Type -> 399 | case ty of 400 | Type -> pure $ env ^. envUsages 401 | _ -> Left $ ExpectedType $ env ^. envNames <$> ty 402 | Pi _ n a b -> 403 | case ty of 404 | Type -> do 405 | _ <- checkType env a Type 406 | _ <- 407 | checkType 408 | ( deeperEnv 409 | (const n) 410 | (Map.singleton () $ BindingEntry a) 411 | (Map.singleton () Zero) 412 | env 413 | ) 414 | (fromScope b) 415 | Type 416 | pure $ env ^. envUsages 417 | _ -> Left $ ExpectedType $ env ^. envNames <$> ty 418 | Lam n a -> 419 | case ty of 420 | Pi u' _ s t -> do 421 | usages' <- 422 | check 423 | varCost 424 | ( deeperEnv 425 | (const n) 426 | (Map.singleton () $ BindingEntry s) 427 | (Map.singleton () (times u' u)) 428 | env 429 | ) 430 | (fromScope a) 431 | u 432 | (fromScope t) 433 | unsafeCheckConsumed 434 | (unvar (const n) $ env ^. envNames) 435 | (times u' u) 436 | (B ()) 437 | usages' 438 | let (_, usages'') = Context.split usages' 439 | pure usages'' 440 | _ -> Left $ ExpectedPi $ env ^. envNames <$> ty 441 | Tensor n _ a b -> 442 | case ty of 443 | Type -> do 444 | _ <- checkType env a Type 445 | _ <- 446 | checkType 447 | ( deeperEnv 448 | (const n) 449 | (Map.singleton () $ BindingEntry a) 450 | (Map.singleton () Zero) 451 | env 452 | ) 453 | (fromScope b) 454 | Type 455 | pure $ env ^. envUsages 456 | _ -> Left $ ExpectedType $ env ^. envNames <$> ty 457 | MkTensor a b -> 458 | case ty of 459 | Tensor _ u' s t -> do 460 | usages' <- check (times varCost u') env a u s 461 | check varCost (env & envUsages .~ usages') b u (instantiate1 (Ann a u s) t) 462 | _ -> Left $ ExpectedTensor $ env ^. envNames <$> ty 463 | UnpackTensor n1 n2 a b -> do 464 | (usages', _, aTy) <- infer varCost env a u 465 | case aTy of 466 | Tensor _ u' s t -> do 467 | let aUsage = times u u' 468 | usages'' <- 469 | check 470 | varCost 471 | ( deeperEnv 472 | (bool n1 n2) 473 | (Map.fromList [(False, BindingEntry s), (True, BindingEntry $ instantiate1 (Fst a) t)]) 474 | (Map.fromList [(False, aUsage), (True, u)]) 475 | (env & envUsages .~ usages') 476 | ) 477 | (fromScope b) 478 | u 479 | (F <$> ty) 480 | let names' = unvar (bool n1 n2) $ env ^. envNames 481 | unsafeCheckConsumed names' aUsage (B False) usages'' 482 | unsafeCheckConsumed names' u (B True) usages'' 483 | let (_, usages''') = Context.split usages'' 484 | pure usages''' 485 | _ -> Left $ ExpectedTensor $ env ^. envNames <$> aTy 486 | With a b -> 487 | case ty of 488 | Type -> do 489 | _ <- checkType env a Type 490 | _ <- checkType env b Type 491 | pure $ env ^. envUsages 492 | _ -> Left $ ExpectedType $ env ^. envNames <$> ty 493 | MkWith a b -> 494 | case ty of 495 | With s t -> do 496 | usagesA <- check varCost env a u s 497 | usagesB <- check varCost env b u t 498 | pure $ 499 | Context.zipWithKey 500 | ( \_ -> \case 501 | This u1 -> Just u1 502 | That u2 -> Just u2 503 | These u1 u2 -> Just $ max u1 u2 504 | ) 505 | usagesA 506 | usagesB 507 | _ -> Left $ ExpectedWith $ env ^. envNames <$> ty 508 | Unit -> 509 | case ty of 510 | Type -> pure $ env ^. envUsages 511 | _ -> Left $ ExpectedType $ env ^. envNames <$> ty 512 | MkUnit -> 513 | case ty of 514 | Unit -> pure $ env ^. envUsages 515 | _ -> Left $ ExpectedUnit $ env ^. envNames <$> ty 516 | Case a bs -> do 517 | (usages', usage, aTy) <- infer varCost env a u 518 | checkBranches varCost (env & envUsages .~ usages') (a, usage, aTy) bs u ty 519 | _ -> do 520 | (usages', _, tmTy) <- infer varCost env tm u 521 | if tmTy == ty 522 | then pure usages' 523 | else Left $ TypeMismatch (env ^. envNames <$> ty) (env ^. envNames <$> tmTy) 524 | 525 | checkType :: 526 | (Ord x, Ord a) => 527 | Env a l x -> 528 | Term a l x -> 529 | Ty a l x -> 530 | Either (TypeError l a) (Context x Usage) 531 | checkType env tm = 532 | check Zero (env & envUsages . mapped .~ Zero) tm Zero 533 | 534 | checkTerm :: 535 | (Ord x, Ord a) => 536 | Env a l x -> 537 | Term a l x -> 538 | Ty a l x -> 539 | Either (TypeError l a) (Context x Usage) 540 | checkTerm env tm = check One env tm One 541 | 542 | infer :: 543 | HasCallStack => 544 | (Ord x, Ord a) => 545 | Usage -> 546 | Env a l x -> 547 | Term a l x -> 548 | Usage -> 549 | Either (TypeError l a) (Context x Usage, Usage, Ty a l x) 550 | infer _ _ _ Many = error "infer called with usage Many" 551 | infer varCost env tm u = 552 | over (mapped . _3) (eval $ env ^. envDepth) $ -- post compute 553 | case tm of 554 | Var a -> do 555 | aTy <- 556 | maybe 557 | (Left . NotInScope $ view envNames env a) 558 | (pure . _entryType) 559 | (view (envTypes . to (flip Context.lookup)) env a) 560 | u' <- 561 | maybe 562 | (Left . NotInScope $ view envNames env a) 563 | pure 564 | (view (envUsages . to (flip Context.lookup)) env a) 565 | case (varCost, u') of 566 | (Zero, _) -> pure (env ^. envUsages, u', aTy) 567 | (One, Zero) -> Left $ UsingErased $ view envNames env a 568 | (One, One) -> 569 | pure (Context.insert a Zero (view envUsages env), u', aTy) 570 | (One, Many) -> pure (env ^. envUsages, u', aTy) 571 | (Many, Zero) -> Left $ UsingErased $ view envNames env a 572 | (Many, One) -> Left $ OverusedLinear $ view envNames env a 573 | (Many, Many) -> pure (env ^. envUsages, u', aTy) 574 | Ann a u' b -> do 575 | _ <- checkType env b Type 576 | usages' <- check varCost env a u' b 577 | pure (usages', u', b) 578 | App a b -> do 579 | (usages', _, aTy) <- infer varCost env a u 580 | case aTy of 581 | Pi u' _ s t -> do 582 | let u'' = if u == Zero || u' == Zero then Zero else One 583 | usages'' <- check (times varCost u') (env & envUsages .~ usages') b u'' s 584 | pure (usages'', u, instantiate1 (Ann b u'' s) t) 585 | _ -> Left $ ExpectedPi $ env ^. envNames <$> aTy 586 | Fst a -> do 587 | (usages', _, aTy) <- infer varCost env a u 588 | case aTy of 589 | With s _ -> pure (usages', u, s) 590 | _ -> Left $ ExpectedWith $ env ^. envNames <$> aTy 591 | Snd a -> do 592 | (usages', _, aTy) <- infer varCost env a u 593 | case aTy of 594 | With _ t -> pure (usages', u, t) 595 | _ -> Left $ ExpectedWith $ env ^. envNames <$> aTy 596 | _ -> Left $ Can'tInfer $ env ^. envNames <$> tm 597 | 598 | inferType :: 599 | HasCallStack => 600 | (Ord x, Ord a) => 601 | Env a l x -> 602 | Term a l x -> 603 | Either (TypeError l a) (Context x Usage, Usage, Ty a l x) 604 | inferType env tm = infer Zero (env & envUsages . mapped .~ Zero) tm Zero 605 | 606 | inferTerm :: 607 | HasCallStack => 608 | (Ord x, Ord a) => 609 | Env a l x -> 610 | Term a l x -> 611 | Either (TypeError l a) (Context x Usage, Usage, Ty a l x) 612 | inferTerm env tm = infer One env tm One -------------------------------------------------------------------------------- /src/Unify.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Unify where 4 | 5 | import Bound.Class (Bound (..)) 6 | import Bound.Context (Context) 7 | import qualified Bound.Context as Context 8 | import Bound.Scope (Scope, fromScope) 9 | import Bound.Var (Var (..), unvar, _F) 10 | import Control.Lens.Fold ((^?)) 11 | import Data.Bool (bool) 12 | import Data.Map (Map) 13 | import qualified Data.Map as Map 14 | import Data.Maybe (fromMaybe) 15 | 16 | import Context 17 | import Syntax 18 | import TypeError 19 | 20 | newtype Subst f a = Subst {unSubst :: Map a (f a)} 21 | deriving (Eq, Show) 22 | 23 | single :: a -> f a -> Subst f a 24 | single a b = Subst $ Map.singleton a b 25 | 26 | bindSubst :: (Ord a, Monad f) => Subst f a -> f a -> f a 27 | bindSubst (Subst m) t = t >>= \x -> fromMaybe (pure x) (Map.lookup x m) 28 | 29 | boundSubst :: (Ord a, Bound t, Monad f) => Subst f a -> t f a -> t f a 30 | boundSubst (Subst m) t = t >>>= \x -> fromMaybe (pure x) (Map.lookup x m) 31 | 32 | instance (Ord a, Monad f) => Semigroup (Subst f a) where 33 | s2 <> Subst s1 = Subst $ fmap (bindSubst s2) s1 <> unSubst s2 34 | 35 | instance (Ord a, Monad f) => Monoid (Subst f a) where 36 | mempty = Subst Map.empty 37 | 38 | unifyScopes :: 39 | (Ord a, Ord b) => 40 | (a -> n) -> 41 | (a -> n) -> 42 | Context a (Entry n l x) -> 43 | (b -> n, Scope b (Term n l) a) -> 44 | (b -> n, Scope b (Term n l) a) -> 45 | Either (TypeError l n) (Subst (Term n l) a) 46 | unifyScopes varNames1 varNames2 ctx (n1, tm1) (n2, tm2) = 47 | let varNames1' = unvar n1 varNames1 48 | varNames2' = unvar n2 varNames2 49 | in unifyTerms 50 | varNames1' 51 | varNames2' 52 | (Context.shift ctx) -- (unvar (const Nothing) ctx) 53 | (fromScope tm1) 54 | (fromScope tm2) 55 | >>= fmap Subst 56 | . Map.foldrWithKey 57 | ( \k a b -> 58 | unvar 59 | -- a mapping from bound variables to terms is valid if it 60 | -- maps bound variables to bound variables 61 | ( \x -> 62 | if Var (B x) == a 63 | then Right mempty 64 | else Left $ TypeMismatch (Var $ n1 x) (varNames2' <$> a) 65 | ) 66 | -- a mapping from free variables to terms is valid as long 67 | -- as it contains no bound variables 68 | ( \x -> 69 | Map.insert x 70 | <$> maybe 71 | ( Left $ 72 | TypeMismatch 73 | (varNames1' <$> fromScope tm1) 74 | (varNames2' <$> fromScope tm2) 75 | ) 76 | pure 77 | (traverse (^? _F) a) 78 | <*> b 79 | ) 80 | k 81 | ) 82 | (Right mempty) 83 | . unSubst 84 | 85 | unifyApps :: 86 | Ord a => 87 | (a -> n) -> 88 | (a -> n) -> 89 | Context a (Entry n l x) -> 90 | Term n l a -> 91 | Term n l a -> 92 | Either (TypeError l n) (Subst (Term n l) a) 93 | unifyApps varNames1 varNames2 ctx tm1 tm2 = 94 | let (f, xs) = unfoldApps tm1 95 | 96 | fvar = 97 | maybe True (\case CtorEntry{} -> False; _ -> True) $ 98 | case f of 99 | Var a -> Context.lookup a ctx 100 | _ -> Nothing 101 | 102 | unifyMany s [] [] = Right s 103 | unifyMany s (a : as) (b : bs) = do 104 | s1 <- unifyTerms varNames1 varNames2 ctx (bindSubst s a) (bindSubst s b) 105 | unifyMany (s1 <> s) as bs 106 | unifyMany _ _ _ = 107 | Left $ TypeMismatch (varNames1 <$> tm1) (varNames2 <$> tm2) 108 | in case (fvar, xs) of 109 | (True, _ : _) -> 110 | Left $ UnknownSolution (varNames1 <$> tm1) (varNames2 <$> tm2) 111 | _ -> do 112 | let (f', xs') = unfoldApps tm2 113 | s1 <- unifyTerms varNames1 varNames2 ctx f f' 114 | unifyMany s1 xs xs' 115 | 116 | unifyTerms :: 117 | Ord a => 118 | (a -> n) -> 119 | (a -> n) -> 120 | Context a (Entry n l x) -> 121 | Term n l a -> 122 | Term n l a -> 123 | Either (TypeError l n) (Subst (Term n l) a) 124 | unifyTerms varNames1 varNames2 ctx tm1 tm2 = 125 | case (tm1, tm2) of 126 | (Var a, Var b) -> 127 | case (Context.lookup a ctx, Context.lookup b ctx) of 128 | (Just CtorEntry{}, Just CtorEntry{}) -> 129 | if a == b 130 | then pure mempty 131 | else Left $ TypeMismatch (varNames1 <$> tm1) (varNames2 <$> tm2) 132 | _ -> pure $ if a == b then mempty else single a tm2 133 | (Var a, _) -> pure $ single a tm2 134 | (_, Var a) -> pure $ single a tm1 135 | (Lam n b, Lam n' b') -> unifyScopes varNames1 varNames2 ctx (const n, b) (const n', b') 136 | (Type, Type) -> pure mempty 137 | (Pi a n b c, Pi a' n' b' c') -> 138 | if a /= a' 139 | then Left $ TypeMismatch (varNames1 <$> tm1) (varNames2 <$> tm2) 140 | else do 141 | s1 <- unifyTerms varNames1 varNames2 ctx b b' 142 | s2 <- unifyScopes varNames1 varNames2 ctx (const n, boundSubst s1 c) (const n', boundSubst s1 c') 143 | pure (s2 <> s1) 144 | (Ann _ _ a, _) -> unifyTerms varNames1 varNames2 ctx a tm2 145 | (_, Ann _ _ a) -> unifyTerms varNames1 varNames2 ctx tm1 a 146 | (App{}, _) -> unifyApps varNames1 varNames2 ctx tm1 tm2 147 | (_, App{}) -> unifyApps varNames1 varNames2 ctx tm2 tm1 148 | (MkTensor a b, MkTensor a' b') -> do 149 | s1 <- unifyTerms varNames1 varNames2 ctx a a' 150 | s2 <- unifyTerms varNames1 varNames2 ctx (bindSubst s1 b) (bindSubst s1 b') 151 | pure (s2 <> s1) 152 | (Tensor n u a b, Tensor n' u' a' b') -> do 153 | if u /= u' 154 | then Left $ TypeMismatch (varNames1 <$> tm1) (varNames2 <$> tm2) 155 | else do 156 | s1 <- unifyTerms varNames1 varNames2 ctx a a' 157 | s2 <- unifyScopes varNames1 varNames2 ctx (const n, boundSubst s1 b) (const n', boundSubst s1 b') 158 | pure (s2 <> s1) 159 | (UnpackTensor n1 n2 a b, UnpackTensor n1' n2' a' b') -> do 160 | s1 <- unifyTerms varNames1 varNames2 ctx a a' 161 | s2 <- unifyScopes varNames1 varNames2 ctx (bool n1 n2, boundSubst s1 b) (bool n1' n2', boundSubst s1 b') 162 | pure (s2 <> s1) 163 | (MkWith a b, MkWith a' b') -> do 164 | s1 <- unifyTerms varNames1 varNames2 ctx a a' 165 | s2 <- unifyTerms varNames1 varNames2 ctx (bindSubst s1 b) (bindSubst s1 b') 166 | pure (s2 <> s1) 167 | (With a b, With a' b') -> do 168 | s1 <- unifyTerms varNames1 varNames2 ctx a a' 169 | s2 <- unifyTerms varNames1 varNames2 ctx b b' 170 | pure (s2 <> s1) 171 | (Fst a, Fst a') -> unifyTerms varNames1 varNames2 ctx a a' 172 | (Snd a, Snd a') -> unifyTerms varNames1 varNames2 ctx a a' 173 | (Unit, Unit) -> pure mempty 174 | (MkUnit, MkUnit) -> pure mempty 175 | (Loc _ a, _) -> unifyTerms varNames1 varNames2 ctx a tm2 176 | (_, Loc _ a) -> unifyTerms varNames1 varNames2 ctx tm1 a 177 | _ -> 178 | if tm1 == tm2 179 | then pure mempty 180 | else Left $ TypeMismatch (varNames1 <$> tm1) (varNames2 <$> tm2) 181 | 182 | unifyInductive :: 183 | Ord a => 184 | (a -> n) -> 185 | (a -> n) -> 186 | Context a (Entry n l x) -> 187 | Term n l a -> 188 | Term n l a -> 189 | Either (TypeError l n) (Subst (Term n l) a) 190 | unifyInductive varNames1 varNames2 ctx tm1 tm2 = 191 | let (f, xs) = unfoldApps tm1 192 | (f', xs') = unfoldApps tm2 193 | 194 | unifyMany s [] [] = Right s 195 | unifyMany s (a : as) (b : bs) = do 196 | s1 <- unifyTerms varNames1 varNames2 ctx (bindSubst s a) (bindSubst s b) 197 | unifyMany (s1 <> s) as bs 198 | unifyMany _ _ _ = 199 | Left $ TypeMismatch (varNames1 <$> tm1) (varNames2 <$> tm2) 200 | in case (f, f') of 201 | (Var a, Var a') 202 | | Just InductiveEntry{} <- Context.lookup a ctx 203 | , Just InductiveEntry{} <- Context.lookup a' ctx -> 204 | if a /= a' 205 | then Left $ TypeMismatch (varNames1 <$> tm1) (varNames2 <$> tm2) 206 | else unifyMany mempty xs xs' 207 | _ -> unifyTerms varNames1 varNames2 ctx tm1 tm2 -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language TypeApplications #-} 3 | module Main where 4 | 5 | import Test.Hspec 6 | 7 | import Test.Pretty 8 | import Test.Typecheck 9 | import Test.Unify 10 | 11 | main :: IO () 12 | main = 13 | hspec $ do 14 | prettySpec 15 | typecheckSpec 16 | unifySpec -------------------------------------------------------------------------------- /test/Test/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedLists #-} 2 | module Test.Pretty where 3 | 4 | import Text.PrettyPrint.ANSI.Leijen (Doc, pretty) 5 | import Test.Hspec 6 | 7 | import Syntax 8 | import Syntax.Pretty 9 | 10 | doPrettyTerm :: Term String String String -> Doc 11 | doPrettyTerm = prettyTerm pretty 12 | 13 | pretty1 :: Doc 14 | pretty1 = doPrettyTerm $ Case (pure "a") [varb "x" $ pure "x"] 15 | 16 | pretty2 :: Doc 17 | pretty2 = 18 | doPrettyTerm $ 19 | Case (pure "a") 20 | [ varb "x" $ pure "x" 21 | , varb "y" $ pure "y" 22 | ] 23 | 24 | pretty3 :: Doc 25 | pretty3 = 26 | doPrettyTerm $ 27 | Case (pure "a") 28 | [ ctorb "Nil" [] $ pure "Nil" 29 | , ctorb "Cons" ["a", "b"] $ App (App (pure "Cons") (pure "a")) (pure "b") 30 | ] 31 | 32 | pretty4 :: Doc 33 | pretty4 = 34 | doPrettyTerm $ 35 | Case (pure "a") 36 | [ ctorb "Nil" [] $ pure "Nil" 37 | , ctorb "Cons" ["a", "b"] $ 38 | Case (pure "b") 39 | [ ctorb "Nil" [] $ pure "Nil" 40 | , ctorb "Cons" ["c", "d"] $ App (App (pure "Cons") (pure "c")) (pure "d") 41 | ] 42 | ] 43 | 44 | prettySpec :: Spec 45 | prettySpec = 46 | describe "pretty" $ do 47 | it "1" $ do 48 | putStrLn $ show pretty1 49 | it "2" $ do 50 | putStrLn $ show pretty2 51 | it "3" $ do 52 | putStrLn $ show pretty3 53 | it "4" $ do 54 | putStrLn $ show pretty4 55 | -------------------------------------------------------------------------------- /test/Test/Typecheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Test.Typecheck where 6 | 7 | import Prelude hiding (pi) 8 | 9 | import Bound.Context (Context) 10 | import qualified Bound.Context as Context 11 | import qualified Data.Map as Map 12 | import Test.Hspec 13 | 14 | import Context 15 | import Syntax 16 | import TypeError 17 | import Typecheck 18 | 19 | import Test.Utils 20 | 21 | doCheckType :: 22 | [(String, Entry String String String)] -> 23 | [(String, Usage)] -> 24 | Term String String String -> 25 | Ty String String String -> 26 | Either (TypeError String String) (Context String Usage) 27 | doCheckType a b = checkType (Env id id (Context.fromList a) (Context.fromList b)) 28 | 29 | doCheckTerm :: 30 | [(String, Entry String String String)] -> 31 | [(String, Usage)] -> 32 | Term String String String -> 33 | Ty String String String -> 34 | Either (TypeError String String) (Context String Usage) 35 | doCheckTerm a b = checkTerm (Env id id (Context.fromList a) (Context.fromList b)) 36 | 37 | typecheckSpec :: Spec 38 | typecheckSpec = 39 | describe "typecheck" $ do 40 | it "(\\A => \\x => x) :0 (A :0 Type) -> (x :1 A) -> A" $ 41 | assertRight $ 42 | doCheckType 43 | [] 44 | [] 45 | (lam "A" $ lam "x" $ pure "x") 46 | (forall_ ("A", Type) $ lpi ("x", pure "A") $ pure "A") 47 | it "(\\A => \\x => x) :1 (A :0 Type) -> (x :1 A) -> A" $ 48 | assertRight $ 49 | doCheckTerm 50 | [] 51 | [] 52 | (lam "A" $ lam "x" $ pure "x") 53 | (forall_ ("A", Type) $ lpi ("x", pure "A") $ pure "A") 54 | it "(\\A => \\x => x) :0 (A :0 Type) -> (x :0 A) -> A" $ 55 | assertRight $ 56 | doCheckType 57 | [] 58 | [] 59 | (lam "A" $ lam "x" $ pure "x") 60 | (forall_ ("A", Type) $ forall_ ("x", pure "A") $ pure "A") 61 | it "(\\A => \\x => x) :1 (A :0 Type) -> (x :0 A) -> A invalid" $ 62 | assertLeft (UsingErased "x") $ 63 | doCheckTerm 64 | [] 65 | [] 66 | (lam "A" $ lam "x" $ pure "x") 67 | (forall_ ("A", Type) $ forall_ ("x", pure "A") $ pure "A") 68 | it "(\\A => \\x => \\y => y) :1 (A :0 Type) -> (x :1 A) -> (y :w A) -> A invalid" $ 69 | assertLeft 70 | (UnusedLinear "x") 71 | ( doCheckTerm 72 | [] 73 | [] 74 | (lam "A" $ lam "x" $ lam "y" $ pure "y") 75 | ( forall_ ("A", Type) $ 76 | lpi ("x", pure "A") $ 77 | pi ("y", pure "A") $ 78 | pure "A" 79 | ) 80 | ) 81 | it "(\\A => \\x => \\y => x) :1 (A :0 Type) -> (x :1 A) -> (y :w A) -> A" $ 82 | assertRight 83 | ( doCheckTerm 84 | [] 85 | [] 86 | (lam "A" $ lam "x" $ lam "y" $ pure "x") 87 | ( forall_ ("A", Type) $ 88 | lpi ("x", pure "A") $ 89 | pi ("y", pure "A") $ 90 | pure "A" 91 | ) 92 | ) 93 | it "(\\A => \\x => x) :1 (A :1 Type) -> (x :1 A) -> A invalid" $ 94 | assertLeft 95 | (UnusedLinear "A") 96 | ( doCheckTerm 97 | [] 98 | [] 99 | (lam "A" $ lam "x" $ pure "x") 100 | ( lpi ("A", Type) $ 101 | lpi ("x", pure "A") $ 102 | pure "A" 103 | ) 104 | ) 105 | it "(\\A => \\x => x) :1 (A :0 Type) -> (x :1 A) -> A" $ 106 | assertRight 107 | ( doCheckTerm 108 | [] 109 | [] 110 | (lam "A" $ lam "x" $ pure "x") 111 | ( forall_ ("A", Type) $ 112 | lpi ("x", pure "A") $ 113 | pure "A" 114 | ) 115 | ) 116 | it "(\\A => \\x => (x, x)) :1 (A :0 Type) -> (x :1 A) -> (_ : A ⨂ A) invalid" $ 117 | assertLeft 118 | (OverusedLinear "x") 119 | ( doCheckTerm 120 | [] 121 | [] 122 | (lam "A" $ lam "x" $ MkTensor (pure "x") (pure "x")) 123 | ( forall_ ("A", Type) $ 124 | lpi ("x", pure "A") $ 125 | tensor ("_", Many, pure "A") (pure "A") 126 | ) 127 | ) 128 | it "(\\A => \\x => (x, x)) :1 (A :0 Type) -> (x :w A) -> (_ : A ⨂ A)" $ 129 | assertRight 130 | ( doCheckTerm 131 | [] 132 | [] 133 | (lam "A" $ lam "x" $ MkTensor (pure "x") (pure "x")) 134 | ( forall_ ("A", Type) $ 135 | pi ("x", pure "A") $ 136 | tensor ("_", Many, pure "A") (pure "A") 137 | ) 138 | ) 139 | it "(\\x => let (a, b) = x in a b) :1 (x : (_ : A -> B ⨂ A)) -> B invalid" $ 140 | {- 141 | Why? In a relevant context (the :1 judgement), a tensor is always linear in its 142 | second component. The linear `b` is passed to a function with an unrestricted 143 | argument, which means `b` is used too many times. 144 | -} 145 | assertLeft 146 | (OverusedLinear "b") 147 | ( doCheckTerm 148 | [ ("A", BindingEntry Type) 149 | , ("B", BindingEntry Type) 150 | ] 151 | [ ("A", Zero) 152 | , ("B", Zero) 153 | ] 154 | (lam "x" $ unpackTensor ("a", "b") (pure "x") (App (pure "a") (pure "b"))) 155 | ( pi ("_", tensor ("_", Many, pure "A" `arr` pure "B") (pure "A")) $ 156 | pure "B" 157 | ) 158 | ) 159 | it "(\\x => let (a, b) = x in a b) :1 (x : (_ : A -o B ⨂ A)) -> B" $ 160 | -- The above to go through, the function in the first component must use its 161 | -- argument linearly or irrelevantly 162 | assertRight 163 | ( doCheckTerm 164 | [ ("A", BindingEntry Type) 165 | , ("B", BindingEntry Type) 166 | ] 167 | [ ("A", Zero) 168 | , ("B", Zero) 169 | ] 170 | (lam "x" $ unpackTensor ("a", "b") (pure "x") (App (pure "a") (pure "b"))) 171 | ( pi ("_", tensor ("_", Many, pure "A" `limp` pure "B") (pure "A")) $ 172 | pure "B" 173 | ) 174 | ) 175 | it "(\\x => let (a, b) = x in a) :1 (x : (_ : A ⨂ A)) -> A invalid" $ 176 | assertLeft 177 | (UnusedLinear "b") 178 | ( doCheckTerm 179 | [("A", BindingEntry Type)] 180 | [("A", Zero)] 181 | (lam "x" $ unpackTensor ("a", "b") (pure "x") (pure "a")) 182 | ( arr (tensor ("_", Many, pure "A") (pure "A")) $ 183 | pure "A" 184 | ) 185 | ) 186 | it "(\\x => let (a, b) = x in b) :1 (x : (_ : A ⨂ A)) -> A" $ 187 | assertRight 188 | ( doCheckTerm 189 | [("A", BindingEntry Type)] 190 | [("A", Zero)] 191 | (lam "x" $ unpackTensor ("a", "b") (pure "x") (pure "b")) 192 | ( arr (tensor ("_", Many, pure "A") (pure "A")) $ 193 | pure "A" 194 | ) 195 | ) 196 | it "(\\x => let (a, b) = x in b) :1 (x : (_ :0 A ⨂ A)) -> A" $ 197 | assertRight 198 | ( doCheckTerm 199 | [("A", BindingEntry Type)] 200 | [("A", Zero)] 201 | (lam "x" $ unpackTensor ("a", "b") (pure "x") (pure "b")) 202 | ( arr (tensor ("_", Zero, pure "A") (pure "A")) $ 203 | pure "A" 204 | ) 205 | ) 206 | it "(\\x => let (a, b) = x in b) :1 (x : (_ :1 A ⨂ A)) -> A invalid" $ 207 | assertLeft 208 | (UnusedLinear "a") 209 | ( doCheckTerm 210 | [("A", BindingEntry Type)] 211 | [("A", Zero)] 212 | (lam "x" $ unpackTensor ("a", "b") (pure "x") (pure "b")) 213 | ( arr (tensor ("_", One, pure "A") (pure "A")) $ 214 | pure "A" 215 | ) 216 | ) 217 | it "(\\x => fst x) :1 (x : (A & A)) -o A" $ 218 | assertRight 219 | ( doCheckTerm 220 | [("A", BindingEntry Type)] 221 | [("A", Zero)] 222 | (lam "x" $ Fst $ pure "x") 223 | ( limp (with (pure "A") (pure "A")) $ 224 | pure "A" 225 | ) 226 | ) 227 | it "(\\x => snd x) :1 (x : (A & A)) -o A" $ 228 | assertRight 229 | ( doCheckTerm 230 | [("A", BindingEntry Type)] 231 | [("A", Zero)] 232 | (lam "x" $ Snd $ pure "x") 233 | ( limp (with (pure "A") (pure "A")) $ 234 | pure "A" 235 | ) 236 | ) 237 | it "(\\x => (fst x, snd x)) :1 (x : (A & B)) -o (A & B)" $ 238 | assertRight 239 | ( doCheckTerm 240 | [ ("A", BindingEntry Type) 241 | , ("B", BindingEntry Type) 242 | ] 243 | [ ("A", Zero) 244 | , ("B", Zero) 245 | ] 246 | (lam "x" $ MkWith (Fst $ pure "x") (Snd $ pure "x")) 247 | ( limp (with (pure "A") (pure "B")) $ 248 | with (pure "A") (pure "B") 249 | ) 250 | ) 251 | it "(\\x => \\y => (fst x, y)) :1 (x : (A & B)) -o B -o (A & B)" $ 252 | assertLeft 253 | (UnusedLinear "y") 254 | ( doCheckTerm 255 | [ ("A", BindingEntry Type) 256 | , ("B", BindingEntry Type) 257 | ] 258 | [ ("A", Zero) 259 | , ("B", Zero) 260 | ] 261 | (lam "x" $ lam "y" $ MkWith (Fst $ pure "x") (pure "y")) 262 | ( limp (with (pure "A") (pure "B")) $ 263 | limp (pure "B") $ 264 | with (pure "A") (pure "B") 265 | ) 266 | ) 267 | it "(\\x => (x, x)) :1 (x : A) -o (A & A)" $ 268 | assertRight 269 | ( doCheckTerm 270 | [("A", BindingEntry Type)] 271 | [("A", Zero)] 272 | (lam "x" $ MkWith (pure "x") (pure "x")) 273 | ( limp (pure "A") $ 274 | with (pure "A") (pure "A") 275 | ) 276 | ) 277 | it "(\\x => let (a, b) = x in (a, b)) :1 (x : (_ : A ⨂ B)) -> (A & B)" $ 278 | {- 279 | Why? Consumption from each component is not summed when forming a `&`. Each component 280 | must consume all linear variables. The second component of the tensor is always linear, so it 281 | must be consumed, but it isn't consumed by the first component of the `&`. 282 | -} 283 | assertLeft 284 | (UnusedLinear "b") 285 | ( doCheckTerm 286 | [("A", BindingEntry Type)] 287 | [("A", Zero)] 288 | ( lam "x" $ 289 | unpackTensor ("a", "b") (pure "x") $ 290 | MkWith (pure "a") (pure "b") 291 | ) 292 | ( arr (tensor ("_", Many, pure "A") (pure "B")) $ 293 | with (pure "A") (pure "B") 294 | ) 295 | ) 296 | it "(\\x => let (a, b) = x in (a, b)) :1 (x : (_ : A ⨂ B)) -o (A & B)" $ 297 | assertLeft 298 | (UnusedLinear "b") 299 | ( doCheckTerm 300 | [("A", BindingEntry Type)] 301 | [("A", Zero)] 302 | ( lam "x" $ 303 | unpackTensor ("a", "b") (pure "x") $ 304 | MkWith (pure "a") (pure "b") 305 | ) 306 | ( limp (tensor ("_", Many, pure "A") (pure "B")) $ 307 | with (pure "A") (pure "B") 308 | ) 309 | ) 310 | it "(\\x => (fst x, snd x)) :1 (x : (A & B)) -> (_ : A ⨂ B)" $ 311 | assertRight 312 | ( doCheckTerm 313 | [("A", BindingEntry Type)] 314 | [("A", Zero)] 315 | ( lam "x" $ 316 | MkTensor (Fst $ pure "x") (Snd $ pure "x") 317 | ) 318 | ( arr (with (pure "A") (pure "B")) $ 319 | tensor ("_", Many, pure "A") (pure "B") 320 | ) 321 | ) 322 | it "(\\x => (fst x, snd x)) :1 (x : (A & B)) -o (_ : A ⨂ B) invalid" $ 323 | assertLeft 324 | (OverusedLinear "x") 325 | ( doCheckTerm 326 | [("A", BindingEntry Type)] 327 | [("A", Zero)] 328 | ( lam "x" $ 329 | MkTensor (Fst $ pure "x") (Snd $ pure "x") 330 | ) 331 | ( limp (with (pure "A") (pure "B")) $ 332 | tensor ("_", Many, pure "A") (pure "B") 333 | ) 334 | ) 335 | it "(\\x => \\f => f x) :1 ∀(x : A). (f : A -> B) -> B invalid" $ 336 | assertLeft 337 | (UsingErased "x") 338 | ( doCheckTerm 339 | [ ("A", BindingEntry Type) 340 | , ("B", BindingEntry Type) 341 | ] 342 | [ ("A", Zero) 343 | , ("B", Zero) 344 | ] 345 | ( lam "x" $ 346 | lam "f" $ 347 | App (pure "f") (pure "x") 348 | ) 349 | ( forall_ ("x", pure "A") $ 350 | arr (arr (pure "A") (pure "B")) $ 351 | pure "B" 352 | ) 353 | ) 354 | it "(\\x => \\f => f x) :1 A -> (b : ∀(a : A). B) -> B" $ 355 | assertRight 356 | ( doCheckTerm 357 | [ ("A", BindingEntry Type) 358 | , ("B", BindingEntry Type) 359 | ] 360 | [ ("A", Zero) 361 | , ("B", Zero) 362 | ] 363 | ( lam "x" $ 364 | lam "f" $ 365 | App (pure "f") (pure "x") 366 | ) 367 | ( arr (pure "A") $ 368 | pi ("b", forall_ ("a", pure "A") (pure "B")) $ 369 | pure "B" 370 | ) 371 | ) 372 | it "List : Type -> Type, Nil : ∀(a : Type) -> List a, A :0 Type |- Nil A :1 List A" $ do 373 | let nilType = 374 | forall_ ("a", Type) $ 375 | App (pure "List") (pure "a") 376 | consType = 377 | forall_ ("a", Type) $ 378 | arr (pure "a") $ 379 | arr (App (pure "List") (pure "a")) $ 380 | App (pure "List") (pure "a") 381 | 382 | assertRight 383 | ( doCheckTerm 384 | [ 385 | ( "List" 386 | , InductiveEntry 387 | (arr Type Type) 388 | ( Map.fromList 389 | [ ("Nil", nilType) 390 | , ("Cons", consType) 391 | ] 392 | ) 393 | ) 394 | , ("Nil", CtorEntry nilType) 395 | , ("Cons", CtorEntry consType) 396 | , ("A", BindingEntry Type) 397 | ] 398 | [ ("List", Many) 399 | , ("Nil", Many) 400 | , ("Cons", Many) 401 | , ("A", Zero) 402 | ] 403 | (App (pure "Nil") (pure "A")) 404 | (App (pure "List") (pure "A")) 405 | ) 406 | it "Bool : Type, True : Bool, False : Bool, x : Bool |- (case x of { True => False; False => True }) :1 Bool" $ do 407 | let falseType = pure "Bool" 408 | trueType = pure "Bool" 409 | 410 | assertRight 411 | ( doCheckTerm 412 | [ 413 | ( "Bool" 414 | , InductiveEntry 415 | Type 416 | ( Map.fromList 417 | [ ("False", falseType) 418 | , ("True", trueType) 419 | ] 420 | ) 421 | ) 422 | , ("False", CtorEntry falseType) 423 | , ("True", CtorEntry trueType) 424 | , ("x", BindingEntry $ pure "Bool") 425 | ] 426 | [ ("Bool", Many) 427 | , ("False", Many) 428 | , ("True", Many) 429 | , ("x", Many) 430 | ] 431 | ( Case 432 | (pure "x") 433 | [ ctorb "True" [] $ pure "False" 434 | , ctorb "False" [] $ pure "True" 435 | ] 436 | ) 437 | (pure "Bool") 438 | ) 439 | it "A :0 Type, B :0 Type, x : (A & B) |- (case x of { y => y }) :1 (A & B)" $ 440 | assertRight 441 | ( doCheckTerm 442 | [ ("A", BindingEntry Type) 443 | , ("B", BindingEntry Type) 444 | , ("x", BindingEntry $ with (pure "A") (pure "B")) 445 | ] 446 | [ ("A", Zero) 447 | , ("B", Zero) 448 | , ("x", Many) 449 | ] 450 | ( Case 451 | (pure "x") 452 | [ varb "y" $ pure "y" 453 | ] 454 | ) 455 | (with (pure "A") (pure "B")) 456 | ) 457 | it "..., BoolS : Bool -> Type, TrueS : BoolS True, FalseS : BoolS False, b :0 Bool, x : BoolS b |- (case x of { TrueS => TrueS; FalseS => FalseS }) :1 BoolS b" $ do 458 | let falseType = pure "Bool" 459 | trueType = pure "Bool" 460 | falseSType = App (pure "BoolS") (pure "False") 461 | trueSType = App (pure "BoolS") (pure "True") 462 | 463 | assertRight 464 | ( doCheckTerm 465 | [ 466 | ( "Bool" 467 | , InductiveEntry 468 | Type 469 | ( Map.fromList 470 | [ ("False", falseType) 471 | , ("True", trueType) 472 | ] 473 | ) 474 | ) 475 | , ("False", CtorEntry falseType) 476 | , ("True", CtorEntry trueType) 477 | , 478 | ( "BoolS" 479 | , InductiveEntry 480 | (arr (pure "Bool") Type) 481 | ( Map.fromList 482 | [ ("FalseS", falseSType) 483 | , ("TrueS", trueSType) 484 | ] 485 | ) 486 | ) 487 | , ("FalseS", CtorEntry falseSType) 488 | , ("TrueS", CtorEntry trueSType) 489 | , ("b", BindingEntry $ pure "Bool") 490 | , ("x", BindingEntry $ App (pure "BoolS") (pure "b")) 491 | ] 492 | [ ("Bool", Many) 493 | , ("False", Many) 494 | , ("True", Many) 495 | , ("BoolS", Many) 496 | , ("FalseS", Many) 497 | , ("TrueS", Many) 498 | , ("b", Zero) 499 | , ("x", Many) 500 | ] 501 | ( Case 502 | (pure "x") 503 | [ ctorb "TrueS" [] $ pure "TrueS" 504 | , ctorb "FalseS" [] $ pure "FalseS" 505 | ] 506 | ) 507 | (App (pure "BoolS") (pure "b")) 508 | ) 509 | it "..., BoolS : Bool -> Type, TrueS : BoolS True, FalseS : BoolS False, b :0 Bool, x : BoolS b |- (case x of { TrueS => TrueS; FalseS impossible }) :1 BoolS b invalid" $ do 510 | let falseType = pure "Bool" 511 | trueType = pure "Bool" 512 | falseSType = App (pure "BoolS") (pure "False") 513 | trueSType = App (pure "BoolS") (pure "True") 514 | 515 | assertLeft 516 | NotImpossible 517 | ( doCheckTerm 518 | [ 519 | ( "Bool" 520 | , InductiveEntry 521 | Type 522 | ( Map.fromList 523 | [ ("False", falseType) 524 | , ("True", trueType) 525 | ] 526 | ) 527 | ) 528 | , ("False", CtorEntry falseType) 529 | , ("True", CtorEntry trueType) 530 | , 531 | ( "BoolS" 532 | , InductiveEntry 533 | (arr (pure "Bool") Type) 534 | ( Map.fromList 535 | [ ("FalseS", falseSType) 536 | , ("TrueS", trueSType) 537 | ] 538 | ) 539 | ) 540 | , ("FalseS", CtorEntry falseSType) 541 | , ("TrueS", CtorEntry trueSType) 542 | , ("b", BindingEntry $ pure "Bool") 543 | , ("x", BindingEntry $ App (pure "BoolS") (pure "b")) 544 | ] 545 | [ ("Bool", Many) 546 | , ("False", Many) 547 | , ("True", Many) 548 | , ("BoolS", Many) 549 | , ("FalseS", Many) 550 | , ("TrueS", Many) 551 | , ("b", Zero) 552 | , ("x", Many) 553 | ] 554 | ( Case 555 | (pure "x") 556 | [ ctorb "TrueS" [] $ pure "TrueS" 557 | , ctorb_imp "FalseS" [] 558 | ] 559 | ) 560 | (App (pure "BoolS") (pure "b")) 561 | ) 562 | it "..., BoolS : Bool -> Type, TrueS : BoolS True, FalseS : BoolS False, b :0 Bool, x : BoolS b |- (case x of { TrueS => TrueS; FalseS => TrueS }) :1 BoolS b invalid" $ do 563 | let falseType = pure "Bool" 564 | trueType = pure "Bool" 565 | falseSType = App (pure "BoolS") (pure "False") 566 | trueSType = App (pure "BoolS") (pure "True") 567 | 568 | assertLeft 569 | ( TypeMismatch 570 | (App (pure "BoolS") (pure "False")) 571 | (App (pure "BoolS") (pure "True")) 572 | ) 573 | ( doCheckTerm 574 | [ 575 | ( "Bool" 576 | , InductiveEntry 577 | Type 578 | ( Map.fromList 579 | [ ("False", falseType) 580 | , ("True", trueType) 581 | ] 582 | ) 583 | ) 584 | , ("False", CtorEntry falseType) 585 | , ("True", CtorEntry trueType) 586 | , 587 | ( "BoolS" 588 | , InductiveEntry 589 | (arr (pure "Bool") Type) 590 | ( Map.fromList 591 | [ ("FalseS", falseSType) 592 | , ("TrueS", trueSType) 593 | ] 594 | ) 595 | ) 596 | , ("FalseS", CtorEntry falseSType) 597 | , ("TrueS", CtorEntry trueSType) 598 | , ("b", BindingEntry $ pure "Bool") 599 | , ("x", BindingEntry $ App (pure "BoolS") (pure "b")) 600 | ] 601 | [ ("Bool", Many) 602 | , ("False", Many) 603 | , ("True", Many) 604 | , ("BoolS", Many) 605 | , ("FalseS", Many) 606 | , ("TrueS", Many) 607 | , ("b", Zero) 608 | , ("x", Many) 609 | ] 610 | ( Case 611 | (pure "x") 612 | [ ctorb "TrueS" [] $ pure "TrueS" 613 | , ctorb "FalseS" [] $ pure "TrueS" 614 | ] 615 | ) 616 | (App (pure "BoolS") (pure "b")) 617 | ) 618 | it "..., BoolS : Bool -> Type, TrueS : BoolS True, FalseS : BoolS False, x : BoolS True |- (case x of { TrueS => TrueS; FalseS impossible }) :1 BoolS b" $ do 619 | let falseType = pure "Bool" 620 | trueType = pure "Bool" 621 | falseSType = App (pure "BoolS") (pure "False") 622 | trueSType = App (pure "BoolS") (pure "True") 623 | 624 | assertRight 625 | ( doCheckTerm 626 | [ 627 | ( "Bool" 628 | , InductiveEntry 629 | Type 630 | ( Map.fromList 631 | [ ("False", falseType) 632 | , ("True", trueType) 633 | ] 634 | ) 635 | ) 636 | , ("False", CtorEntry falseType) 637 | , ("True", CtorEntry trueType) 638 | , 639 | ( "BoolS" 640 | , InductiveEntry 641 | (arr (pure "Bool") Type) 642 | ( Map.fromList 643 | [ ("FalseS", falseSType) 644 | , ("TrueS", trueSType) 645 | ] 646 | ) 647 | ) 648 | , ("FalseS", CtorEntry falseSType) 649 | , ("TrueS", CtorEntry trueSType) 650 | , ("x", BindingEntry $ App (pure "BoolS") (pure "True")) 651 | ] 652 | [ ("Bool", Many) 653 | , ("False", Many) 654 | , ("True", Many) 655 | , ("BoolS", Many) 656 | , ("FalseS", Many) 657 | , ("TrueS", Many) 658 | , ("x", Many) 659 | ] 660 | ( Case 661 | (pure "x") 662 | [ ctorb "TrueS" [] $ pure "TrueS" 663 | , ctorb_imp "FalseS" [] 664 | ] 665 | ) 666 | (App (pure "BoolS") (pure "True")) 667 | ) 668 | it "Pair : Type -> Type -> Type, MkPair : (A : Type) -> (B : Type) -> (x : A) -> (y : B) -> Pair A B, A :0 Type, B :0 Type, x :1 Pair A B |- (case x of { MkPair A B a b => a }) :1 A" $ do 669 | let mkPairType = 670 | forall_ ("A", Type) $ 671 | forall_ ("B", Type) $ 672 | pi ("x", pure "A") $ 673 | pi ("y", pure "B") $ 674 | App (App (pure "Pair") (pure "A")) (pure "B") 675 | 676 | assertRight 677 | ( doCheckTerm 678 | [ 679 | ( "Pair" 680 | , InductiveEntry 681 | (arr Type $ arr Type Type) 682 | ( Map.fromList 683 | [ ("MkPair", mkPairType) 684 | ] 685 | ) 686 | ) 687 | , ("MkPair", CtorEntry mkPairType) 688 | , ("A", BindingEntry Type) 689 | , ("B", BindingEntry Type) 690 | , ("x", BindingEntry $ App (App (pure "Pair") (pure "A")) (pure "B")) 691 | ] 692 | [ ("Pair", Many) 693 | , ("MkPair", Many) 694 | , ("A", Zero) 695 | , ("B", Zero) 696 | , ("x", One) 697 | ] 698 | ( Case 699 | (pure "x") 700 | [ ctorb "MkPair" ["A", "B", "x", "y"] $ pure "x" 701 | ] 702 | ) 703 | (pure "A") 704 | ) 705 | it "Pair : Type -> Type -> Type, MkPair : (A : Type) -> (B : Type) -> (x : A) -o (y : B) -o Pair A B, A :0 Type, B :0 Type, x :1 Pair A B |- (case x of { MkPair A B a b => a }) :1 A invalid" $ do 706 | let mkPairType = 707 | forall_ ("A", Type) $ 708 | forall_ ("B", Type) $ 709 | limp (pure "A") $ 710 | limp (pure "B") $ 711 | App (App (pure "Pair") (pure "A")) (pure "B") 712 | 713 | assertLeft 714 | (UnusedLinear "y") 715 | ( doCheckTerm 716 | [ 717 | ( "Pair" 718 | , InductiveEntry 719 | (arr Type $ arr Type Type) 720 | ( Map.fromList 721 | [ ("MkPair", mkPairType) 722 | ] 723 | ) 724 | ) 725 | , ("MkPair", CtorEntry mkPairType) 726 | , ("A", BindingEntry Type) 727 | , ("B", BindingEntry Type) 728 | , ("x", BindingEntry $ App (App (pure "Pair") (pure "A")) (pure "B")) 729 | ] 730 | [ ("Pair", Many) 731 | , ("MkPair", Many) 732 | , ("A", Zero) 733 | , ("B", Zero) 734 | , ("x", One) 735 | ] 736 | ( Case 737 | (pure "x") 738 | [ ctorb "MkPair" ["A", "B", "x", "y"] $ pure "x" 739 | ] 740 | ) 741 | (pure "A") 742 | ) 743 | it "Pair : Type -> Type -> Type, MkPair : (A : Type) -> (B : Type) -> (x : A) -> (y : B) -> Pair A B, A :0 Type, B :0 Type, a :1 A, b :1 B |- MkPair A B a b :1 Pair A B invalid" $ do 744 | let mkPairType = 745 | forall_ ("A", Type) $ 746 | forall_ ("B", Type) $ 747 | pi ("x", pure "A") $ 748 | pi ("y", pure "B") $ 749 | App (App (pure "Pair") (pure "A")) (pure "B") 750 | 751 | assertLeft 752 | (OverusedLinear "a") 753 | ( doCheckTerm 754 | [ 755 | ( "Pair" 756 | , InductiveEntry 757 | (arr Type $ arr Type Type) 758 | ( Map.fromList 759 | [ ("MkPair", mkPairType) 760 | ] 761 | ) 762 | ) 763 | , ("MkPair", CtorEntry mkPairType) 764 | , ("A", BindingEntry Type) 765 | , ("B", BindingEntry Type) 766 | , ("a", BindingEntry $ pure "A") 767 | , ("b", BindingEntry $ pure "B") 768 | ] 769 | [ ("Pair", Many) 770 | , ("MkPair", Many) 771 | , ("A", Zero) 772 | , ("B", Zero) 773 | , ("a", One) 774 | , ("b", One) 775 | ] 776 | (App (App (App (App (pure "MkPair") (pure "A")) (pure "B")) (pure "a")) (pure "b")) 777 | (App (App (pure "Pair") (pure "A")) (pure "B")) 778 | ) 779 | it "Pair : Type -> Type -> Type, MkPair : (A :0 Type) -> (B :0 Type) -> (x : A) -> (y : B) -> Pair A B, A :0 Type, B :0 Type, x :1 Pair A B |- (case x of { MkPair A B a b => A }) :1 Type invalid" $ do 780 | let mkPairType = 781 | forall_ ("A", Type) $ 782 | forall_ ("B", Type) $ 783 | pi ("x", pure "A") $ 784 | pi ("y", pure "B") $ 785 | App (App (pure "Pair") (pure "A")) (pure "B") 786 | 787 | assertLeft 788 | (UsingErased "A") 789 | ( doCheckTerm 790 | [ 791 | ( "Pair" 792 | , InductiveEntry 793 | (arr Type $ arr Type Type) 794 | ( Map.fromList 795 | [ ("MkPair", mkPairType) 796 | ] 797 | ) 798 | ) 799 | , ("MkPair", CtorEntry mkPairType) 800 | , ("A", BindingEntry Type) 801 | , ("B", BindingEntry Type) 802 | , ("x", BindingEntry $ App (App (pure "Pair") (pure "A")) (pure "B")) 803 | ] 804 | [ ("Pair", Many) 805 | , ("MkPair", Many) 806 | , ("A", Zero) 807 | , ("B", Zero) 808 | , ("x", One) 809 | ] 810 | ( Case 811 | (pure "x") 812 | [ ctorb "MkPair" ["A", "B", "x", "y"] $ pure "A" 813 | ] 814 | ) 815 | Type 816 | ) 817 | it "Pair : Type -> Type -> Type, MkPair : (A : Type) -> (B : Type) -> (x : A) -> (y : B) -> Pair A B, A :0 Type, B :0 Type, x :w Pair A B |- (case x of { MkPair A B a b => a }) :1 A" $ do 818 | let mkPairType = 819 | forall_ ("A", Type) $ 820 | forall_ ("B", Type) $ 821 | pi ("x", pure "A") $ 822 | pi ("y", pure "B") $ 823 | App (App (pure "Pair") (pure "A")) (pure "B") 824 | 825 | assertRight 826 | ( doCheckTerm 827 | [ 828 | ( "Pair" 829 | , InductiveEntry 830 | (arr Type $ arr Type Type) 831 | ( Map.fromList 832 | [ ("MkPair", mkPairType) 833 | ] 834 | ) 835 | ) 836 | , ("MkPair", CtorEntry mkPairType) 837 | , ("A", BindingEntry Type) 838 | , ("B", BindingEntry Type) 839 | , ("x", BindingEntry $ App (App (pure "Pair") (pure "A")) (pure "B")) 840 | ] 841 | [ ("Pair", Many) 842 | , ("MkPair", Many) 843 | , ("A", Zero) 844 | , ("B", Zero) 845 | , ("x", Many) 846 | ] 847 | ( Case 848 | (pure "x") 849 | [ ctorb "MkPair" ["A", "B", "x", "y"] $ pure "x" 850 | ] 851 | ) 852 | (pure "A") 853 | ) 854 | -------------------------------------------------------------------------------- /test/Test/Unify.hs: -------------------------------------------------------------------------------- 1 | module Test.Unify (unifySpec) where 2 | 3 | import Prelude hiding (pi) 4 | 5 | import Test.Hspec 6 | 7 | import qualified Data.Map as Map 8 | 9 | import Syntax 10 | import TypeError 11 | import Unify 12 | 13 | doUnify :: 14 | Term String String String -> 15 | Term String String String -> 16 | Either 17 | (TypeError String String) 18 | (Subst (Term String String) String) 19 | doUnify = unifyTerms id id mempty 20 | 21 | unifySpec :: Spec 22 | unifySpec = 23 | describe "unify" $ do 24 | it "(\\x => x) ~ (\\x -> x) succeeds with {}" $ 25 | doUnify (lam "x" $ pure "x") (lam "x" $ pure "x") 26 | `shouldBe` Right mempty 27 | it "(\\x => x) ~ (\\x -> y) fails" $ 28 | doUnify (lam "x" $ pure "x") (lam "x" $ pure "y") 29 | `shouldBe` Left (TypeMismatch (Var "x") (Var "y")) 30 | it "(\\x => x) ~ (\\x -> (y, z)) fails" $ 31 | doUnify (lam "x" $ pure "x") (lam "x" $ MkTensor (pure "y") (pure "z")) 32 | `shouldBe` Left (TypeMismatch (Var "x") (MkTensor (pure "y") (pure "z"))) 33 | it "(\\x => x) ~ (\\x -> MkUnit) fails" $ 34 | doUnify (lam "x" $ pure "x") (lam "x" MkUnit) 35 | `shouldBe` Left (TypeMismatch (Var "x") MkUnit) 36 | it "(\\x => a) ~ (\\x -> (b, c)) succeeds with {a -> (b, c)}" $ 37 | doUnify (lam "x" $ pure "a") (lam "x" $ MkTensor (pure "b") (pure "c")) 38 | `shouldBe` Right (Subst $ Map.fromList [("a", MkTensor (pure "b") (pure "c"))]) 39 | it "f x ~ Unit fails" $ 40 | doUnify (App (pure "f") (pure "x")) MkUnit 41 | `shouldBe` Left (UnknownSolution (App (pure "f") (pure "x")) MkUnit) 42 | it "(a, b) ~ (c, d) succeeds with {a -> c, b -> d}" $ 43 | doUnify 44 | (MkTensor (pure "a") (pure "b")) 45 | (MkTensor (pure "c") (pure "d")) 46 | `shouldBe` Right (Subst $ Map.fromList [("a", pure "c"), ("b", pure "d")]) 47 | -------------------------------------------------------------------------------- /test/Test/Utils.hs: -------------------------------------------------------------------------------- 1 | module Test.Utils where 2 | 3 | import Test.Hspec 4 | 5 | assertRight :: HasCallStack => Show a => Either a b -> Expectation 6 | assertRight a = 7 | case a of 8 | Right{} -> pure () 9 | Left e -> expectationFailure $ show e 10 | 11 | assertLeft :: HasCallStack => (Eq a, Show a) => a -> Either a b -> Expectation 12 | assertLeft e a = 13 | case a of 14 | Right{} -> 15 | expectationFailure $ 16 | "expected:\n\n" <> show e <> "\n\nbut got Right" 17 | Left e' -> e' `shouldBe` e --------------------------------------------------------------------------------