├── .gitignore ├── README.md ├── examples ├── Lemmas.ttie └── Prelude.ttie ├── src ├── EqZipper.hs ├── Eval.hs ├── Main.hs ├── Names.hs ├── Substitution.hs ├── SubstitutionQQ.hs ├── Syntax.hs ├── TcMonad.hs ├── Tests.hs ├── Tokenizer.hs ├── Typing.hs └── Util │ ├── MyPrelude.hs │ ├── Parser.hs │ ├── Pretty.hs │ ├── PrettyM.hs │ ├── Tagged │ ├── Internal.hs │ ├── Map.hs │ ├── Seq.hs │ └── Var.hs │ └── WLPPrint.hs └── ttie.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | /dist 2 | /src/old 3 | *.goutputstream-* 4 | 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | TTIE - Type Theory with Indexed Equality 2 | --------------------------------------- 3 | 4 | A demo interpreter and type checker of a type theory with interval indexed equality types. 5 | 6 | The indexed equality type looks like this (in Agda notation): 7 | 8 | data Interval : Type where 9 | 0 : Interval 10 | 1 : Interval 11 | 01 : 0 == 1 12 | 13 | data Eq (A : Interval -> Type) (A 0) (A 1) : Type where 14 | refl : (x : (i : Interval) -> A i) -> Eq A (x 0) (x 1) 15 | 16 | We write the binders for intervals as a subscript, so `Eq_i (A i) x y`. 17 | 18 | Syntax 19 | ------ 20 | 21 | The syntax is modeled after Agda and Haskell: 22 | 23 | -- a comment 24 | {- also a comment -} 25 | variable 26 | _ -- a hole, filled in by unification 27 | 28 | Type : Type1 -- the type of types 29 | 30 | tt : Unit -- built in unit type, with constructor tt 31 | 32 | Unit -> Unit -- function type 33 | Unit → Unit -- Unicode 34 | (A : Type) -> A -> A -- dependent function type 35 | {A : Type} -> A -> A -- implicit arguments 36 | forall x -> B x -- the same as (x : _) -> B x 37 | ∀ x. B x -- the same 38 | \x -> e -- lambdas / anonymous functions 39 | \(x : A) -> e -- with type annotation 40 | (x : A) => e -- same 41 | f x -- function application 42 | f {x} -- explicit application to an implicit argument 43 | 44 | (x : A) * B x -- dependent sums (pairs) 45 | {x : A} * B x -- with implicit arguments (to model existentials) 46 | exists x -> B x -- the same as (x : _) * B x 47 | ∃ x. B x -- the same 48 | x , y -- construct a pair 49 | proj1 x -- first projection of a pair 50 | proj2 x -- second projection 51 | {proj1} x -- projection of an implicit pair/existential 52 | {x} , y -- explicit construction of an implicit pair 53 | 54 | 0 55 | 1 : Interval -- The interval has values 0 and 1 56 | 01 : Eq _ 0 1 -- the path between 0 and 1 57 | refl_i i -- the same 58 | iflip i -- sends 0 to 1 and vice-versa 59 | ~i -- the same 60 | iand i j -- 1 if i and j are both 1 61 | i && j -- the same 62 | i || j -- 1 if i or j is 1 63 | 64 | Eq A x y -- type of equality proofs of x and y of type A 65 | Eq_i (A i) x y -- indexed equality between x : A 0 and y : A 1 66 | x == y -- sugar for equality type 67 | refl x -- reflexivity at x 68 | refl_i (x i) -- indexed version 69 | xy^i -- end point of a path, if xy : Eq _ x y, xy^0 = x, xy^1 = y, refl_i xy^i = xy 70 | iv x y xy i -- desugared version of xy^i 71 | 72 | cast_i (A i) u v x -- substitution: if (x : A u), the result has type (A v) 73 | fw_i (A i) x -- short hand notation for cast_i (A i) 0 1 74 | bw_i (A i) x -- short hand notation for cast_i (A i) 1 0 75 | 76 | data{left:A; right:B} -- A sum type, constructors have a single argument type 77 | value left x -- A value of the above data type, you may need a type signature 78 | case x of {left y -> ..; right y -> ..} -- case analysis of a sum type 79 | data{} -- The type with no constructors (bottom) 80 | 81 | Declarations and commands look like 82 | 83 | name : Type 84 | name arguments = expression 85 | 86 | :help 87 | :quit 88 | :type e 89 | :eval e 90 | :nf e 91 | :check e = e' 92 | 93 | Remarks: 94 | * Built in names like `Eq`, `proj1`, `cast`, etc. must always be fully applied. 95 | * Spaces around operators like `->` are usually required, because `-` can be part of a name. 96 | * There is no support for recursion yet. 97 | * Implicit projections have not yet been implemented. 98 | * Unification is often not very smart. 99 | 100 | Usage 101 | ----- 102 | 103 | The implementation comes with a REPL and an interpreter: 104 | 105 | $ cabal build 106 | $ dist/ttie examples/Lemmas 107 | 108 | The unit tests from Tests.hs are also instructive 109 | 110 | $ cabal test 111 | 112 | Examples 113 | -------- 114 | Here is a proof that `fw ∘ bw = id` 115 | 116 | A : Type 117 | B : Type 118 | AB : Eq _ A B 119 | lemma : forall x. fw_i (AB^i) (bw_i AB^i x) == x 120 | lemma = \x -> refl_j (cast_i AB^i j 1 (cast_i AB^i 1 j x)) 121 | 122 | Proof of function extensionality: 123 | 124 | ext : ∀ {A : Type} {B : A → Type} {f g : (x : A) → B x} → (∀ x. f x == g x) → f == g 125 | ext = \fg → refl_i \x → (fg x)^i 126 | 127 | -------------------------------------------------------------------------------- /examples/Lemmas.ttie: -------------------------------------------------------------------------------- 1 | import Prelude 2 | 3 | -- Some simple lemmas and checks 4 | 5 | left-right : forall {A B x y} -> Eq (Either A B) (left x) (right y) -> Bottom 6 | left-right = \eq -> fw_i (case eq^i of {left _ -> Unit; right _ -> Bottom}) tt 7 | 8 | maybe-zero : forall n -> Either (Eq _ n zero) ({pred-n : _} * Eq _ n (suc pred-n)) 9 | maybe-zero = Nat-elim {\n -> Either (Eq _ n zero) ({pred-n : _} * Eq _ n (suc pred-n))} 10 | (left (refl _)) 11 | (\_ -> value right ({_}, refl _)) 12 | 13 | ext : ∀ {A : Type} {B : A → Type} {f g : (x : A) → B x} → (∀ x. f x == g x) → f == g 14 | ext = \fg → refl_i \x → (fg x)^i 15 | 16 | transpose-transpose : ∀ {A a b c d ab cd ac bd} x → transpose (transpose {A} {a} {b} {c} {d} {ab} {cd} {ac} {bd} x) == x 17 | transpose-transpose = \x → refl x 18 | 19 | false≠true : false == true → data{} 20 | false≠true eq = cast_i (case eq^i of {false _ → data{}; true _ → Unit}) 1 0 tt 21 | -------------------------------------------------------------------------------- /examples/Prelude.ttie: -------------------------------------------------------------------------------- 1 | -- A very simple prelude 2 | 3 | Nat : Type 4 | zero : Nat 5 | suc : Nat -> Nat 6 | Nat-elim : {P : Nat -> Type} -> P zero -> ({x : Nat} -> P x -> P (suc x)) -> (x : _) -> P x 7 | 8 | Either : Type -> Type -> Type 9 | Either = \(A B : Type) -> data {left : A; right : B} 10 | left = \{A B} x -> value left x : Either A B 11 | right = \{A B} x -> value right x : Either A B 12 | 13 | Bottom = data {} 14 | Bottom-elim = \{A : Type} x -> case x of {} : A 15 | 16 | -- Empty type 17 | Empty : Type 18 | Empty = data{} 19 | 20 | not : Type → Type 21 | not A = A → Empty 22 | 23 | -- Booleans 24 | Bool : Type 25 | Bool = data {false : Unit; true : Unit} 26 | 27 | false : Bool 28 | false = value false tt 29 | 30 | true : Bool 31 | true = value true tt 32 | 33 | -- symmetry and transitivity 34 | sym : ∀ {A : Type} {x y} → Eq A x y → Eq A y x 35 | sym = \xy → refl_i xy^(iflip i) 36 | 37 | trans : ∀ {A : Type} {x y z : A} → x == y → y == z → x == z 38 | trans = \{A} {x} {y} {z} xy yz → bw_i (xy^i == z) yz 39 | 40 | -- tranpose a square 41 | transpose : ∀ {A : Type} {a b c d : A} {ab : a == b} {cd : c == d} {ac : a == c} {bd : b == d} 42 | → Eq_i (ac^i == bd^i) ab cd 43 | → Eq_i (ab^i == cd^i) ac bd 44 | transpose = \abcd → refl_j (refl_i abcd^i^j) 45 | 46 | -------------------------------------------------------------------------------- /src/EqZipper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | module EqZipper where 4 | 5 | import Prelude () 6 | import Data.List (inits) 7 | import Util.MyPrelude 8 | import Util.PrettyM 9 | import Names 10 | import Syntax 11 | import Substitution 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Values of Eq types 15 | -------------------------------------------------------------------------------- 16 | 17 | -- A value of an Eq type. 18 | -- The integer indicates the number of times it is to be unwrapped. 19 | -- The idea is that 20 | -- WrappedExp 0 x == WrappedExp 1 (Refl x) 21 | -- WrapepdExp 1 x == WrappedExp 0 (x^Var 0) 22 | data WrappedExp = WrappedExp !Int Exp 23 | 24 | wrappedExp :: Exp -> WrappedExp 25 | wrappedExp = WrappedExp 0 26 | 27 | weToUnwrap :: WrappedExp -> WrappedExp 28 | weToUnwrap (WrappedExp 0 (Refl x)) = WrappedExp 0 (boundBody x) 29 | weToUnwrap (WrappedExp i x) = WrappedExp (i+1) x 30 | 31 | {- 32 | weToWrap :: Name -> WrappedExp -> WrappedExp 33 | 34 | weWrapped :: Name -> WrappedExp -> WrappedExp 35 | weWrapped 36 | -} 37 | 38 | -------------------------------------------------------------------------------- 39 | -- Zipper for Eq values 40 | -------------------------------------------------------------------------------- 41 | 42 | -- A path through Eq's 43 | -- the type "Eq_i (Eq_j A a b) c d" is represented by path [EqStep j a b,EqStep i c d] and root type A 44 | -- note: that the path specifies extra variables that are free in the type A 45 | -- note2: the word 'path' refers to zipper terminology (a path up through the structure of the data type), 46 | -- not path in the homotopy sense (an equality type) 47 | -- 48 | -- notation: 49 | -- Γ |- a : Set 50 | -- ------------- 51 | -- Γ |- [] : path a 52 | -- 53 | -- Γ |- ps : path (Eq_j a u v) 54 | -- -------------------- 55 | -- Γ |- (EqStep j u v:ps) : path a 56 | type EqPath = [EqStep] 57 | data EqStep = EqStep Name Exp Exp 58 | deriving (Show) 59 | 60 | -- Names of the index variables 61 | ezNames :: EqPath -> [Name] 62 | ezNames = map (\(EqStep j _ _) -> j) 63 | 64 | -- reverse the zipper. 65 | -- notation: 66 | -- Γ,ezNames p |- a : Set 67 | -- ---------------------- 68 | -- Γ |- ezType a p : Set 69 | ezType :: Exp -> EqPath -> Exp 70 | ezType a0 ws = foldl step a0 ws 71 | where 72 | step a (EqStep j u v) = Eq (Bound j a) u v 73 | 74 | -- Find the 'largest' path p, such that 75 | -- (p,a) = ezFromType a0 ==> a0 = ezType a p 76 | ezFromType :: Exp -> (Exp,EqPath) 77 | ezFromType a0 = go a0 [] 78 | where 79 | go (Eq (Bound j a) u v) path = go a (EqStep j u v:path) 80 | go a path = (a,path) 81 | 82 | ezSubstPath :: Exp -> EqPath -> EqPath 83 | ezSubstPath x ws = zipWith step ws [0..] 84 | where 85 | n = length ws 86 | step (EqStep j u v) i = EqStep j (substRaiseAt (n-1-i) x u) (substRaiseAt (n-1-i) x v) 87 | 88 | ezRaisePathAtBy :: Int -> Int -> EqPath -> EqPath 89 | ezRaisePathAtBy a b ws = zipWith step ws [0..] 90 | where 91 | n = length ws 92 | step (EqStep j u v) i = EqStep j (raiseAtBy (n-1-i+a) b u) (raiseAtBy (n-1-i+a) b v) 93 | 94 | {- 95 | ezSubstExp :: Exp -> EqPath -> Exp -> Exp 96 | ezSubstExp x ws y = substAt (length ws) x y 97 | -} 98 | 99 | -- unwrap a boxed value into a larger context 100 | -- Γ,ezNames p,Δ |- a : Set 101 | -- Γ,Δ |- p : path a 102 | -- Γ,Δ |- x : ezType a p 103 | -- ------------------- 104 | -- Γ,ezNames p,Δ |- ezUnwrap |Δ| p x : a 105 | ezUnwrap :: Int -> EqPath -> Exp -> Exp 106 | ezUnwrap delta ws x0 = foldr step (raiseAtBy delta n x0) (zip ws [0..]) 107 | where 108 | n = length ws 109 | step (_, i) (Refl x) = substBound x (Var (i+delta)) 110 | step (EqStep _j u v, i) x = IV (raiseAtBy delta (i+1) u) (raiseAtBy delta (i+1) v) x (Var (i+delta)) 111 | 112 | -- wrap an expression in refls 113 | -- Γ, ezNames p |- x : a 114 | -- ------------------- 115 | -- Γ |- ezWrap p : ezType a p 116 | ezWrap :: EqPath -> Exp -> Exp 117 | ezWrap ws x0 = ezWrapNames (ezNames ws) x0 118 | 119 | -- wrap an expression in refls 120 | -- Γ,js |- x : a 121 | -- ------------------- 122 | -- Γ |- ezWrapNames js : ezType a p, where j = ezNames p 123 | ezWrapNames :: [Name] -> Exp -> Exp 124 | ezWrapNames js x0 = foldl step x0 js 125 | where 126 | step x j = Refl (Bound j x) 127 | 128 | ezWrapNamesPath :: [Name] -> Exp -> EqPath 129 | ezWrapNamesPath js0 x = zipWith3 step js0 (inits js0) [0..] 130 | where 131 | step j js i = EqStep j (ezWrapNames js (substAt i I0 x)) (ezWrapNames js (substAt i I1 x)) 132 | 133 | -- map inside refls 134 | -- ∀ Δ. Δ |- x : a ==> Δ |- f x : b 135 | -- Γ |- x : ezType a p 136 | -- -------------------- 137 | -- Γ |- ezMapExp f p x : ezType b (ezMapPath f p) 138 | ezMapExp :: (Exp -> Exp) -> EqPath -> Exp -> Exp 139 | ezMapExp f ws x = ezWrap ws (f (ezUnwrap 0 ws x)) 140 | 141 | ezMapPath :: (Exp -> Exp) -> EqPath -> EqPath 142 | ezMapPath f ws = zipWith step ws (inits ws) 143 | where 144 | step (EqStep j u v) inner = EqStep j (ezMapExp f (ezSubstPath I0 inner) u) (ezMapExp f (ezSubstPath I1 inner) v) 145 | 146 | ezZipExp :: (Exp -> Exp -> Exp) -> EqPath -> Exp -> EqPath -> Exp -> Exp 147 | ezZipExp f ws x ws' x' = ezWrap ws (f (ezUnwrap 0 ws x) (ezUnwrap 0 ws' x')) 148 | 149 | ezZipPath :: (Exp -> Exp -> Exp) -> EqPath -> EqPath -> EqPath 150 | ezZipPath f ws ws' = zipWith4 step ws (inits ws) ws' (inits ws') 151 | where 152 | step (EqStep j u v) inner (EqStep _j' u' v') inner' = 153 | EqStep j (ezZipExp f (ezSubstPath I0 inner) u (ezSubstPath I0 inner') u') 154 | (ezZipExp f (ezSubstPath I1 inner) v (ezSubstPath I1 inner') v') 155 | 156 | -------------------------------------------------------------------------------- 157 | -- Values, used for casting 158 | -------------------------------------------------------------------------------- 159 | 160 | -- A value of an Eq type 161 | -- Note that the value has no extra free variables 162 | -- On the other hand, the path has 1 extra free variable, namely the variable that is being cast along (Var 0) 163 | -- 164 | -- Γ |- idx : Interval 165 | -- Γ,i |- p : path a 166 | -- Γ,i,p |- a : Set 167 | -- Γ |- x : ezType a[i=idx] p[i=idx] 168 | -- --------------------------------- 169 | -- Γ |- castEqValue p x idx : CastEqValue a 170 | data CastEqValue = CastEqValue 171 | { cevPath :: EqPath 172 | , cevValue :: Exp 173 | , cevCurrentIdx :: Exp -- ^ current 'side' of the variable that we are casting along (e.g. I0 when casting forward) 174 | } 175 | deriving (Show) 176 | 177 | -- Γ |- cev : CastEqValue (Eq_j a u v) 178 | -- ----------------------------------- 179 | -- Γ |- cevPush j u v cev : CastEqValue a 180 | cevPush :: Name -> Exp -> Exp -> CastEqValue -> CastEqValue 181 | cevPush j u v cev = cev { cevPath = EqStep j u v : cevPath cev } 182 | 183 | cevDepth :: CastEqValue -> Int 184 | cevDepth = length . cevPath 185 | 186 | cevNames :: CastEqValue -> [Name] 187 | cevNames = ezNames . cevPath 188 | 189 | -- is the index used anywhere in the path? 190 | cevIndexIsFree :: CastEqValue -> Bool 191 | cevIndexIsFree cev = or $ zipWith step (cevPath cev) [0..] 192 | where 193 | n = cevDepth cev 194 | step (EqStep _ u v) i = isFree (n-1-i) u || isFree (n-1-i) v 195 | 196 | 197 | -- Γ,i,js |- a : Type 198 | -- Γ,js,Δ |- idx, idx' : Interval 199 | -- Γ,js,Δ |- x : a[i=idx,js=js] 200 | -- -------------------------- 201 | -- Γ,js,Δ |- cevConvertValue js |Δ| a idx idx' x : CastEqValue (raiseBy (n+delta) a) 202 | cevConvertValue :: [Name] -> Int -> Exp -> Exp -> Exp -> Exp -> CastEqValue 203 | cevConvertValue js delta a idx idx' x = 204 | cevSimpleValue js a'' idx idx' $ -- with Γ = Γ,js,Δ 205 | ezConvertValue js delta a' x -- Γ,js,Δ,js' : _ : a[i=idx,js=js'] 206 | where 207 | n = length js 208 | a' = substAt (n+delta) idx $ raiseBy delta a -- Γ,js,Δ |- a' = a[i=idx] 209 | a'' = raiseAtBy (n+1) (n+delta) a -- Γ,js,Δ,i,js' |- a'' = a[i=idx,js=js'] 210 | --idxD = raiseBy (n+delta) idx -- Γ,js,Δ |- idxD 211 | --idxD' = raiseBy (n+delta) idx' -- Γ,js,Δ |- idxD' 212 | 213 | -- Γ,js,Δ |- a : Type 214 | -- Γ,js,Δ |- x : a[js=js] 215 | -- -------------------------- 216 | -- Γ,js,Δ,js' |- ezConvertValue js |Δ| a x : a[js=js'] 217 | ezConvertValue :: [Name] -> Int -> Exp -> Exp -> Exp 218 | ezConvertValue js delta a x0 = foldl step (raiseBy n x0) (zip js [0..]) 219 | where 220 | n = length js 221 | step x (j,i) = Cast (Bound j a') (Var (n+delta+i)) (Var i) x 222 | where 223 | a' = mapExp go a -- Γ,js,Δ,js',ji |- a' 224 | go k | k < delta = var (k+n+1) -- Δ 225 | | k < delta + i = var (k-delta+1) -- ju with u Exp -> Exp -> Exp -> Exp -> CastEqValue 235 | cevSimpleValue js a idx idx' x = CastEqValue 236 | { cevPath = ezWrapNamesPath js xi 237 | , cevValue = ezWrapNames js x' 238 | , cevCurrentIdx = idx' 239 | } 240 | where 241 | n = length js 242 | ai = raiseToFront n a -- Γ,i',js,i |- ai 243 | a' = moveToFront n a -- Γ,js,i |- a' 244 | -- Γ,i,js |- xi : a[i=i,js=js] 245 | xi = Cast (Bound "i" ai) (raiseBy (n+1) idx) (Var n) (raiseAtBy n 1 x) 246 | -- Γ,js |- x' : a[i=idx',js=js] 247 | x' = Cast (Bound "i" a') (raiseBy n idx) (raiseBy n idx') x 248 | 249 | cevRaiseBy :: Int -> CastEqValue -> CastEqValue 250 | cevRaiseBy delta cev = CastEqValue 251 | { cevPath = ezRaisePathAtBy 1 delta (cevPath cev) 252 | , cevValue = raiseBy delta (cevValue cev) 253 | , cevCurrentIdx = raiseBy delta (cevCurrentIdx cev) 254 | } 255 | 256 | cevRaiseTypeBy :: Int -> CastEqValue -> Exp -> Exp 257 | cevRaiseTypeBy n cev = raiseAtBy (cevDepth cev + 1) n 258 | 259 | -- Γ |- cev : CastEqValue a 260 | -- ------------------------ 261 | -- Γ |- cevWrappedValue cev : cevType a cev 262 | cevType :: Exp -> CastEqValue -> Exp 263 | cevType a0 = ezType a0 . cevPath 264 | 265 | --cevSubstBound :: Bound Exp -> CastEqValue -> CastEqValue 266 | --cevSubstBound b cev = substBound b (cevUnwrappedValue cev) 267 | 268 | cevCurrentPath :: CastEqValue -> EqPath 269 | cevCurrentPath cev = ezSubstPath (cevCurrentIdx cev) (cevPath cev) 270 | 271 | cevMap :: (Exp -> Exp) -> CastEqValue -> CastEqValue 272 | cevMap f cev = CastEqValue 273 | { cevPath = ezMapPath f (cevPath cev) 274 | , cevValue = ezMapExp f (cevCurrentPath cev) (cevValue cev) 275 | , cevCurrentIdx = cevCurrentIdx cev 276 | } 277 | 278 | {- 279 | ezMapValue :: (Exp -> Exp) -> EqValue -> EqValue 280 | ezMapValue f (EqVal ws x) = EqVal (ezMapPath f ws) (ezMapExp f ws x) 281 | -} 282 | 283 | cevZipWith :: (Exp -> Exp -> Exp) -> CastEqValue -> CastEqValue -> CastEqValue 284 | cevZipWith f x y = CastEqValue 285 | { cevPath = ezZipPath f (cevPath x) (cevPath y) 286 | , cevValue = ezZipExp f (cevCurrentPath x) (cevValue x) (cevCurrentPath y) (cevValue y) 287 | , cevCurrentIdx = cevCurrentIdx x -- current idx should be the same (not checked) 288 | } 289 | 290 | cevWrappedValue :: CastEqValue -> Exp 291 | cevWrappedValue = cevValue 292 | 293 | -- Γ |- cev : CastEqValue a 294 | -- ------------------------ 295 | -- Γ,cevNames cev,Δ |- cevUnwrappedValue cev : a 296 | cevUnwrappedValue :: Int -> CastEqValue -> Exp 297 | cevUnwrappedValue delta cev = ezUnwrap delta (cevCurrentPath cev) (cevValue cev) 298 | 299 | -------------------------------------------------------------------------------- 300 | -- Debugging 301 | -------------------------------------------------------------------------------- 302 | 303 | instance (MonadBound Exp m, MonadBoundNames m) => Pretty m EqPath where 304 | ppr _ xs0 = semiBrackets $ reverse (go (reverse xs0)) 305 | where 306 | go :: (MonadBound Exp m, MonadBoundNames m) => EqPath -> [m Doc] 307 | go [] = [] 308 | go (EqStep j u v:xs) = 309 | align (text "EqStep" <+> ppr 11 j $/$ ppr 11 u $/$ ppr 11 v) : map (localBound (Named j Interval)) (go xs) 310 | instance (MonadBound Exp m, MonadBoundNames m) => Pretty m CastEqValue where 311 | ppr p cev = group $ parenAlignIf (p > 10) $ text "CastEqValue" 312 | $/$ localBound (Named "i" Interval) (ppr 11 (cevPath cev)) 313 | $/$ ppr 11 (cevValue cev) 314 | $/$ ppr 11 (cevCurrentIdx cev) 315 | 316 | -------------------------------------------------------------------------------- 317 | -- Tests 318 | -------------------------------------------------------------------------------- 319 | {- 320 | -- zero layers 321 | t0 :: Exp 322 | t0 = pe "(x:A #1 #0)*(B #1 #0 x)" 323 | t0p = snd $ ezFromType t0 324 | t0c = ezZipValue (\a b -> Pair (visible a) b (fst $ ezFromType t0)) 325 | (ezMapValue (Proj (visible Proj1)) $ EqVal t0p (AppV (Free "foo") (Var 0))) 326 | (ezMapValue (Proj (visible Proj2)) $ EqVal t0p (AppV (Free "foo") (Var 0))) 327 | 328 | -- one layer 329 | t1 :: Exp 330 | t1 = pe "Eq_i ((x:A #0)*(B #0 x)) (u #0) (v #0)" 331 | t1p = snd $ ezFromType t1 332 | t1c = ezZipValue (\a b -> Pair (visible a) b (fst $ ezFromType t1)) 333 | (ezMapValue (Proj (visible Proj1)) $ EqVal t1p (AppV (Free "foo") (Var 0))) 334 | (ezMapValue (Proj (visible Proj2)) $ EqVal t1p (AppV (Free "foo") (Var 0))) 335 | 336 | 337 | -- two layers 338 | t2e :: Exp 339 | t2e = pe "Eq_i (Eq_j (A #0 i j) (a #0 i) (b #0 i)) (c #0) (d #0)" 340 | t2p = snd $ ezFromType t2e 341 | t2 = ezMapExp (Proj (visible Proj1)) t2p (AppV (Free "foo") (Var 0)) 342 | t2a = ezUnwrap t2p (AppV (Free "foo") (Var 0)) 343 | t2b = ezMapValue (Proj (visible Proj1)) $ EqVal t2p (AppV (Free "foo") (Var 0)) 344 | t2b' = ezMapValue (Proj (visible Proj2)) $ EqVal t2p (AppV (Free "foo") (Var 0)) 345 | t2q = ezMapPath (Proj (visible Proj1)) t2p 346 | t2c = ezZipValue (\a b -> Pair (visible a) b (Free "AB" `AppV` Var 2 `AppV` Var 1 `AppV` Var 0)) t2b t2b' 347 | 348 | -- three layers 349 | t3 :: Exp 350 | t3 = pe "Eq_i (Eq_j (Eq_k (A #0 i j) (a #0 i j) (b #0 i j)) (c #0 i) (d #0 i)) (e #0) (f #0)" 351 | t3p = snd $ ezFromType t3 352 | t3q = ezMapPath (Proj (visible Proj1)) t3p 353 | -} 354 | 355 | {- 356 | 357 | evalCast s (Eq (Bound j a) x y) i1 i2 z = 358 | evalCast s a i1 i2 (consEqStep (EqStep j x y) z) 359 | evalCast s (Si (Visible v a) b) i1 i2 z = 360 | let z1 = ezMap (Proj (Visible v Proj1)) z 361 | z2 = 362 | let z1' = \i2' -> evalCast a i1 i2' z1 363 | z2' = ezCast b i1 i2 z2 364 | ezPair 365 | -} 366 | 367 | {- 368 | 369 | Cast (Eq (Bound j a) x y) p i1 i2 z = 370 | Cast a (EqStep j x y:p) i1 i2 z 371 | Cast (A*B) p i1 i2 z = 372 | z1 = ezMapExp (Proj (Visible v Proj1)) (ezSubstPath i1 p) z 373 | z2 = ezMapExp (Proj (Visible v Proj2)) (ezSubstPath i1 p) z 374 | z1' = Cast a (ezMapPath proj1 p) i1 i2 z1 375 | z1R = Cast (ezRaiseType p a) (ezRaisePath p) (ezRaiseExp p i1) (Var 0) (ezRaiseExp p z1) 376 | z1R = Cast a (ezMapPath proj1 p) i1 i2 z1 377 | b' = ezSubstType p z1R b 378 | z2' = Cast b' (ezMapPath proj2 p) i1 i2 z2 379 | z' = ezZipExp (\u v -> Pair u v (Si a b'')) z1' z2' 380 | in z' 381 | 382 | Cast (A->B) p i1 i2 z = 383 | -} 384 | {- 385 | -- with HOAS 386 | 387 | freeUp :: Exp -> (Exp -> Exp, (Exp -> Exp) -> Exp) 388 | 389 | Cast i (A*B) p i1 i2 z = 390 | z1 = ezMapExp (Proj (Visible v Proj1)) (p i1) z 391 | 392 | 393 | 394 | -} 395 | 396 | {- 397 | 398 | An Exp with n free variables, not necessarily (Var 0..Var (n-1)) 399 | 400 | data Nat = Zero | Suc Nat 401 | 402 | data FExp n where 403 | ExpZ :: Exp -> FExp Zero 404 | ExpS :: FExp n -> FExp 405 | 406 | 407 | -} 408 | 409 | 410 | {- 411 | 412 | 413 | -} 414 | -------------------------------------------------------------------------------- /src/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE QuasiQuotes, ViewPatterns, PatternGuards #-} 6 | {-# LANGUAGE DataKinds #-} 7 | module Eval where 8 | 9 | import Prelude () 10 | import Util.MyPrelude 11 | import Syntax 12 | import Substitution 13 | import SubstitutionQQ 14 | import Names 15 | import TcMonad 16 | import EqZipper 17 | 18 | -------------------------------------------------------------------------------- 19 | -- Evaluation 20 | -------------------------------------------------------------------------------- 21 | 22 | data EvalStrategy = WHNF | NF | MetaOnly | OneStep | NoEval 23 | deriving (Eq) 24 | 25 | data EvalEnv = EvalEnv 26 | { evalStrategy :: EvalStrategy 27 | , evalMetaValue :: MetaVar -> Seq Exp -> Maybe Exp 28 | , evalGlobal :: Name -> Maybe Exp 29 | --, evalGlobals 30 | } 31 | 32 | eval :: EvalEnv -> Exp -> Exp 33 | eval (evalStrategy->NoEval) x = x 34 | eval (evalStrategy->WHNF) x@(Pair _ _ _ _) = x 35 | eval (evalStrategy->WHNF) x@(Binder _ _ _) = x 36 | eval e (Meta x xs) = evalMeta e x xs 37 | eval (evalStrategy->MetaOnly) x = x 38 | eval e (TypeSig x _ty) = evalMore e x 39 | eval e x = evalHere e $ mapChildren (evalMore e) x 40 | 41 | evalHere :: EvalEnv -> Exp -> Exp 42 | evalHere e (TypeSig x _ty) = evalMore e x 43 | evalHere e (Free x) | Just val <- evalGlobal e x = evalMore e val 44 | evalHere e (App x y) = evalApp e x y 45 | evalHere e (Proj h p x) = evalProj e h p x 46 | evalHere e (SumElim x ys z) = evalCase e x ys z 47 | evalHere e (IFlip x) = evalIFlip e x 48 | evalHere e (IAnd x y) = evalIAnd e x y 49 | evalHere e (IV x y z w) = evalIV e x y z w 50 | evalHere e (Eq x y z) = evalEq e x y z 51 | evalHere e (Cast x y z w) = evalCast e x y z w 52 | evalHere (evalStrategy->NF) x = etaContract x 53 | evalHere _ x = x 54 | 55 | evalMore :: EvalEnv -> Exp -> Exp 56 | evalMore (evalStrategy->OneStep) x = x 57 | evalMore e x = eval e x 58 | 59 | evalMeta :: EvalEnv -> MetaVar -> Seq Exp -> Exp 60 | evalMeta e x xs = 61 | case evalMetaValue e x xs of 62 | Nothing -> Meta x (map (eval e) xs) 63 | Just m' -> eval e m' 64 | 65 | evalApp :: EvalEnv -> Exp -> Arg Exp -> Exp 66 | evalApp e (Lam _ x) y = evalMore e $ substBound x (argValue y) 67 | evalApp _ x y = App x y 68 | 69 | evalProj :: EvalEnv -> Hiding -> Proj -> Exp -> Exp 70 | evalProj e _ Proj1 (Pair _ x _y _) = evalMore e x 71 | evalProj e _ Proj2 (Pair _ _x y _) = evalMore e y 72 | evalProj _ h p x = Proj h p x 73 | 74 | evalCase :: EvalEnv -> Exp -> [SumCase] -> Exp -> Exp 75 | evalCase e (SumVal n x _) ys _ 76 | | Just (SumCase _ _ y) <- find ((n==) . caseName) ys 77 | = evalMore e $ substBound y x 78 | evalCase _ x ys a = SumElim x ys a 79 | 80 | evalIFlip :: EvalEnv -> Exp -> Exp 81 | evalIFlip _ I0 = I1 82 | evalIFlip _ I1 = I0 83 | evalIFlip _ (IFlip x) = x 84 | evalIFlip _ x = IFlip x 85 | 86 | evalIAnd :: EvalEnv -> Exp -> Exp -> Exp 87 | evalIAnd _ I0 _ = I0 88 | evalIAnd _ I1 y = y 89 | evalIAnd _ _ I0 = I0 90 | evalIAnd _ x I1 = x 91 | -- commutativity and idempotence? 92 | evalIAnd _ x y = IAnd x y 93 | 94 | evalIV :: EvalEnv -> Exp -> Exp -> Exp -> Exp -> Exp 95 | evalIV _ x _ _ I0 = x 96 | evalIV _ _ y _ I1 = y 97 | evalIV _ _ _ I01 w = w 98 | evalIV e _ _ (Refl z) w = evalMore e $ substBound z w 99 | evalIV _ x y z w = IV x y z w 100 | 101 | evalEq :: EvalEnv -> Bound Exp -> Exp -> Exp -> Exp 102 | evalEq _ x y z = Eq x y z 103 | 104 | --evalFw s [qq|Refl [$_n]x[] |] y = y 105 | evalCast :: EvalEnv -> Bound Exp -> Exp -> Exp -> Exp -> Exp 106 | evalCast e (Bound i a) i1 i2 x = 107 | cevWrappedValue $ evalCast' e i a i2 x' 108 | where 109 | x' = CastEqValue 110 | { cevValue = x 111 | , cevPath = [] 112 | , cevCurrentIdx = i1 113 | } 114 | 115 | -- reduction of "Cast (Bound i (ezType p a)) i1 i2 x" 116 | evalCast' :: EvalEnv -> Name -> Exp -> Exp -> CastEqValue -> CastEqValue 117 | --evalCast' _ _ _ i2 x | cevCurrentIdx x == i2 && i2 `elem` [I0,I1] = x 118 | evalCast' _ _ _ i2 x | cevCurrentIdx x == i2 = x 119 | evalCast' e i (Eq (Bound j a) u v) i2 x = 120 | evalCast' e i a i2 (cevPush j u v x) 121 | evalCast' _ _ a i2 x | not (cevIndexIsFree x) && not (isFree (cevDepth x) a) = x' -- We don't actually need this. 122 | where 123 | x' = x { cevCurrentIdx = i2 } 124 | evalCast' e i (Si (Arg h a) b) i2 x = x12'' 125 | where 126 | proj1 = evalProj e h Proj1 127 | proj2 = evalProj e h Proj2 128 | x1 = cevMap proj1 x 129 | x2 = cevMap proj2 x 130 | x1' = evalCast' e i a i2 x1 131 | x1i = evalCast' e i (raiseAtBy (cevDepth x+1) 1 a) (Var 0) (cevRaiseBy 1 x1) 132 | x2' = evalCast' e i (substBound b (cevUnwrappedValue 0 x1i)) i2 x2 133 | ab' = substRaiseAt (cevDepth x) i2 (Si (Arg h a) b) 134 | x12' = cevZipWith (\u v -> Pair h u v ab') x1' x2' 135 | x12'' = x12' { cevPath = cevPath x } 136 | evalCast' e i (Pi (Arg h a) b) i2 f {-| 137 | traced (" a = " ++ showWithNames (js++"i":gamma) a ++ "\n" ++ 138 | " b = " ++ showWithNames (js++"i":gamma) b ++ "\n" ++ 139 | " f = " ++ showWithNames gamma f ++ "\n" ++ 140 | " i2' = " ++ showWithNames (js++gamma) (raiseBy (cevDepth f) i2) ++ "\n" ++ 141 | " a' = " ++ showWithNames (js++gamma) a' ++ "\n" ++ 142 | --" x = " ++ showWithNames (js'++"x":js++gamma) xV ++ "\n" ++ 143 | " x = " ++ showWithNames ("x":js++gamma) x ++ "\n" ++ 144 | " xi = " ++ showWithNames ("i":"x":js++gamma) xi ++ "\n" ++ 145 | " xi' = " ++ showWithNames (js'++"i":"x":js++gamma) (cevUnwrappedValue 0 xi) ++ "\n" ++ 146 | --" f' = " ++ showWithNames ("x":js++gamma) f' ++ "\n" ++ 147 | " f x = " ++ showWithNames ("x":js++gamma) fx ++ "\n" ++ 148 | " b' = " ++ showWithNames (js'++"i":"x":js++gamma) b' ++ "\n" ++ 149 | " b'x = " ++ showWithNames (js'++"i":"x":js++gamma) b'x ++ "\n" ++ 150 | " fx' = " ++ showWithNames ("x":js++gamma) fx' ++ "\n" ++ 151 | " fxU = " ++ showWithNames (js'++"x":js++gamma) (cevUnwrappedValue 0 fx') ++ "\n" ++ 152 | " fxJ = " ++ showWithNames ("x":js++gamma) fx'' ++ "\n" ++ 153 | " f'' = " ++ showWithNames (gamma) f'' ++ "\n" ++ 154 | "" 155 | ) True-} 156 | = f'' 157 | where 158 | i1 = cevCurrentIdx f 159 | js = cevNames f 160 | x = cevConvertValue js 1 a (raiseBy (cevDepth f+1) i2) (raiseBy (cevDepth f+1) i1) (Var 0) 161 | xi = cevConvertValue js 2 a (raiseBy (cevDepth f+2) i2) (Var 0) (Var 1) 162 | f' = cevRaiseBy (cevDepth f + 1) f 163 | fx = cevZipWith (\u v -> App u (Arg h v)) f' x 164 | b' = raiseAtBy (cevDepth f+2) (cevDepth f+1) <$> b 165 | b'x = substBound b' (cevUnwrappedValue 0 xi) 166 | fx' = evalCast' e i b'x (raiseBy (cevDepth f+1) i2) fx 167 | fx'' = joinVariables 1 (cevDepth f) $ cevUnwrappedValue 0 fx' 168 | a' = substAt (cevDepth f) (raiseBy (cevDepth f) i2) a 169 | f'' = CastEqValue 170 | { cevValue = evalMore e $ ezWrapNames (cevNames f) $ Lam (Arg h a') $ Bound (boundName b) fx'' 171 | , cevPath = cevPath f 172 | , cevCurrentIdx = i2 173 | } 174 | evalCast' _ i a i2 x = x' 175 | where 176 | x' = x 177 | { cevValue = Cast (Bound i (cevType a x)) (cevCurrentIdx x) i2 (cevWrappedValue x) 178 | , cevCurrentIdx = i2 179 | } 180 | 181 | 182 | -- Eta contractions 183 | etaContract :: Exp -> Exp 184 | etaContract (Pair h1 (Proj h2 Proj1 x) (Proj h3 Proj2 y) _) -- Note: only valid if the types are right! 185 | | x == y && h1 == h2 && h1 == h3 = x 186 | etaContract [qq|Lam (Arg h _) [$_x](App f[] (Arg $h' _x))|] | h == h' = f 187 | etaContract [qq|Refl [$_i](IV _ _ x[] _i)|] = x 188 | etaContract x = x 189 | 190 | -------------------------------------------------------------------------------- 191 | -- Is an expression in WHNF? 192 | -------------------------------------------------------------------------------- 193 | 194 | isWHNF :: Exp -> Bool 195 | isWHNF (TypeSig _ _) = False 196 | isWHNF (App (Lam _ _) _) = False 197 | isWHNF (App x _) = isWHNF x 198 | isWHNF (Proj _ _ (Pair _ _ _ _)) = False 199 | isWHNF (Proj _ _ x) = isWHNF x 200 | isWHNF (IV _ _ _ I0) = False 201 | isWHNF (IV _ _ _ I1) = False 202 | isWHNF (IV _ _ _ i) = isWHNF i 203 | isWHNF _ = True 204 | 205 | -------------------------------------------------------------------------------- 206 | -- Evaluation in all possible locations 207 | -------------------------------------------------------------------------------- 208 | 209 | -- | Apply a function to x and all its children (independently), collect results 210 | everywhereM :: (MonadBound Exp f, Alternative g) => (Exp -> f (g Exp)) -> Exp -> f (g Exp) 211 | everywhereM f x = (<|>) <$> f x <*> getCompose (traverseChildren (Compose . everywhereM f) x) 212 | 213 | everywhere :: Alternative f => (Exp -> f Exp) -> Exp -> f Exp 214 | everywhere f = runIdentity . everywhereM (Identity . f) 215 | 216 | -- Track ways to change part of an expression 217 | data Change a = Change { changeOrig :: a, changeNew :: [a] } 218 | deriving (Functor) 219 | instance Applicative Change where 220 | pure x = Change x [] 221 | Change x xs <*> Change y ys = Change (x y) (map ($y) xs ++ map x ys) 222 | instance Alternative Change where 223 | empty = error "only (<|>)" 224 | Change x xs <|> Change _ ys = Change x (xs ++ ys) 225 | 226 | testChange :: Eq a => (a -> a) -> (a -> Change a) 227 | testChange f x = let x' = f x 228 | in Change x [x' | x' /= x ] 229 | 230 | tryEvalHere :: EvalEnv -> Exp -> Change Exp 231 | tryEvalHere e = testChange (eval e{evalStrategy = OneStep}) 232 | 233 | -- all possible ways to take a single evaluation step 234 | -- used to test confluence 235 | evalEverywhere :: EvalEnv -> Exp -> [Exp] 236 | evalEverywhere e x = changeNew $ everywhere (tryEvalHere e) x 237 | 238 | -------------------------------------------------------------------------------- 239 | -- Evaluation from Tc monad 240 | -------------------------------------------------------------------------------- 241 | 242 | tcEvalEnv :: EvalStrategy -> TcM EvalEnv 243 | tcEvalEnv s = do 244 | mv <- metaValues 245 | vals <- freeValues 246 | return $ EvalEnv 247 | { evalStrategy = s 248 | , evalMetaValue = mv 249 | , evalGlobal = vals 250 | } 251 | 252 | tcEval :: EvalStrategy -> Exp -> TcM Exp 253 | tcEval s x = flip eval x <$> tcEvalEnv s 254 | 255 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses #-} 2 | {-# LANGUAGE TemplateHaskell, RankNTypes #-} 3 | module Main where 4 | 5 | import Prelude () 6 | import Util.MyPrelude 7 | import Util.PrettyM hiding ((<.>)) 8 | import Util.Parser 9 | import Names 10 | import Tokenizer 11 | import Syntax 12 | import Typing 13 | import TcMonad 14 | import Eval 15 | 16 | import qualified Options.Applicative as O 17 | import qualified Data.Map as Map 18 | import Control.Monad.Trans 19 | import System.IO 20 | import System.Directory 21 | import System.FilePath 22 | import Lens.Simple 23 | 24 | -------------------------------------------------------------------------------- 25 | -- Statements 26 | -------------------------------------------------------------------------------- 27 | 28 | data Statement 29 | = TypeSignature Name Exp 30 | | FunBody Name Exp 31 | | PrintType EvalStrategy Exp 32 | | PrintEval EvalStrategy Exp 33 | | PrintEnv 34 | | CheckEqual Exp Exp 35 | | Import FilePath 36 | | Help 37 | | ClearEnv 38 | 39 | instance (MonadBoundNames m, MonadBound Exp m) => Pretty m Statement where 40 | ppr _ (TypeSignature n x) = text n <+> text ":" <+> ppr 0 x 41 | ppr _ (FunBody n x) = text n <+> text "=" <+> ppr 0 x 42 | ppr _ (PrintType _ x) = text ":type" <+> ppr 0 x 43 | ppr _ (PrintEval _ x) = text ":eval" <+> ppr 0 x 44 | ppr _ (PrintEnv) = text ":env" 45 | ppr _ (CheckEqual x y) = text ":check" <+> ppr 0 x <+> text "=" <+> ppr 0 y 46 | ppr _ (Import x) = text ":import" <+> ppr 0 x 47 | ppr _ (Help) = text ":help" 48 | ppr _ (ClearEnv) = text ":clear" 49 | 50 | parseStmt :: Parser Statement 51 | parseStmt 52 | = PrintType NoEval <$ (tokReservedName "type" <|> tokReservedName ":type" <|> tokReservedName ":t") <*> parseExp 0 53 | <|> PrintType NF <$ (tokReservedName ":nftype" <|> tokReservedName ":tnf") <*> parseExp 0 54 | <|> PrintEval WHNF <$ (tokReservedName "eval" <|> tokReservedName ":eval") <*> parseExp 0 55 | <|> PrintEval NF <$ tokReservedName ":nf" <*> parseExp 0 56 | <|> PrintEnv <$ tokReservedName ":env" 57 | <|> CheckEqual <$ (tokReservedName "check" <|> tokReservedName ":check") <*> parseExp 0 <* tokEquals <*> parseExp 0 58 | <|> Import <$ (tokReservedName "import" <|> tokReservedName ":l") <*> tokPath 59 | <|> Help <$ (tokReservedName ":help" <|> tokReservedName ":?") 60 | <|> ClearEnv <$ tokReservedName ":clear" 61 | <|> do 62 | n <- tokName 63 | id (TypeSignature n <$ tokColon <*> parseExp 0) <|> 64 | ((\b x -> FunBody n (mkBinders LamB b x)) <$> parseBinders <* tokEquals <*> parseExp 0) 65 | 66 | parseStmts :: Parser [Statement] 67 | parseStmts = withIndentation (many $ parseStmt0) <* tokWS <* eof 68 | where 69 | parseStmt0 = try (tokWS >> notIndented) >> withIndentation parseStmt 70 | 71 | -------------------------------------------------------------------------------- 72 | -- State/environment of the interpreter 73 | -------------------------------------------------------------------------------- 74 | 75 | data Env = Env 76 | { _envNames :: Map Name Decl 77 | , _envWorkingDir :: Maybe FilePath 78 | } 79 | $(makeLenses ''Env) 80 | 81 | emptyEnv :: Env 82 | emptyEnv = Env 83 | { _envNames = Map.empty 84 | , _envWorkingDir = Nothing 85 | } 86 | 87 | withWorkingDir :: FilePath -> StateT Env IO () -> StateT Env IO () 88 | withWorkingDir = withFieldValue envWorkingDir . Just 89 | 90 | withFieldValue :: Monad m => Lens' s a -> a -> StateT s m b -> StateT s m b 91 | withFieldValue field newValue action = do 92 | oldValue <- use field 93 | assign field newValue 94 | out <- action 95 | assign field oldValue 96 | return out 97 | 98 | -------------------------------------------------------------------------------- 99 | -- Running statements 100 | -------------------------------------------------------------------------------- 101 | 102 | reportErrors :: MonadIO m => ExceptT Doc m () -> m () 103 | reportErrors mx = do 104 | ex <- runExceptT mx 105 | case ex of 106 | Left e -> liftIO $ putStrLn $ show e 107 | Right x -> return x 108 | 109 | runTcMIO :: EvalAllMetas a => TcM a -> ExceptT Doc (StateT Env IO) a 110 | runTcMIO mx = do 111 | names <- use envNames 112 | let ctx = emptyCtx { ctxDecls = names } 113 | case runTcM ctx (mx >>= evalAllMetasThrow) of 114 | Left e -> throwError e 115 | Right x -> return x 116 | 117 | runStmt :: Statement -> StateT Env IO () 118 | runStmt (TypeSignature name typ) = reportErrors $ do 119 | (typ',_) <- runTcMIO (tcType typ) 120 | names <- use envNames 121 | case Map.lookup name names of 122 | Nothing -> envNames %= Map.insert name (Postulate typ') 123 | Just _ -> throwError =<< text "Name already defined:" <+> text name 124 | runStmt (FunBody name exp) = reportErrors $ do 125 | names <- use envNames 126 | ty <- case Map.lookup name names of 127 | Nothing -> return Nothing 128 | Just (Postulate ty) -> return $ Just ty 129 | Just _ -> throwError =<< text "Name already defined:" <+> text name 130 | (exp',ty') <- runTcMIO (tc ty exp) 131 | envNames %= Map.insert name (FunDecl ty' exp') 132 | runStmt (PrintType s exp) = reportErrors $ do 133 | ty' <- runTcMIO (tc Nothing exp >>= tcEval s . snd) 134 | liftIO $ putStrLn $ show ty' 135 | runStmt (PrintEval s exp) = reportErrors $ do 136 | exp' <- runTcMIO $ tcEval s . fst =<< tc Nothing exp 137 | liftIO $ putStrLn $ show exp' 138 | runStmt (PrintEnv) = do 139 | names <- use envNames 140 | forM_ (Map.toList names) $ \(n,t) -> 141 | lift . putStrLn . show $ runIdentity . runNamesT $ pprDecl n t 142 | runStmt (CheckEqual a b) = reportErrors $ do 143 | (a',b') <- runTcMIO $ do 144 | (a',ta) <- tc Nothing a 145 | (b',tb) <- tc Nothing b 146 | _ <- unify ta tb 147 | return (a',b') 148 | _ <- runTcMIO $ unify a' b' 149 | return () 150 | runStmt (Import file) = parseModule file 151 | runStmt (Help) = do 152 | lift $ putStrLn "x = e Add a definition" 153 | lift $ putStrLn "x : e Add a postulate" 154 | lift $ putStrLn ":check x = y Check that two expressions are equal" 155 | lift $ putStrLn ":type x Print the type of x" 156 | lift $ putStrLn ":eval x Print the WHNF evaluation of x" 157 | lift $ putStrLn ":nf x Print the NF evaluation of x" 158 | lift $ putStrLn ":env Print the current environment" 159 | lift $ putStrLn ":help Show help message" 160 | lift $ putStrLn ":clear Clear the environment" 161 | runStmt (ClearEnv) = do 162 | put emptyEnv 163 | 164 | -------------------------------------------------------------------------------- 165 | -- Main function 166 | -------------------------------------------------------------------------------- 167 | 168 | -- parse and run a bunch of statements from a file 169 | parseFile :: FilePath -> StateT Env IO () 170 | parseFile file = do 171 | contents <- lift $ readFile file 172 | case runParser parseStmts file contents of 173 | Left e -> lift $ putStrLn $ "Error: " ++ show e 174 | Right stmts -> 175 | withWorkingDir (takeDirectory file) $ 176 | mapM_ runStmt stmts 177 | 178 | parseModule :: String -> StateT Env IO () 179 | parseModule moduleName = do 180 | dir <- use envWorkingDir 181 | let files = [ prefix $ suffix $ moduleName 182 | | suffix <- [id, (<.> "ttie")] 183 | , prefix <- [id] ++ [(wdir ) | Just wdir <- [dir]] ] 184 | go (file:fs) = do 185 | exist <- lift $ doesFileExist file 186 | if exist then parseFile file else go fs 187 | go [] = lift $ putStrLn $ "Error: Module does not exist: " ++ moduleName 188 | go files 189 | 190 | repl :: StateT Env IO () 191 | repl = do 192 | lift $ putStr "> " 193 | lift $ hFlush stdout 194 | line <- lift getLine 195 | replCommand line 196 | 197 | replCommand :: String -> StateT Env IO () 198 | replCommand cmd | cmd `elem` [":q",":quit"] = return () 199 | replCommand "" = repl 200 | replCommand cmd 201 | | otherwise = do 202 | case runParser (parseStmt <* tokWS <* eof) "input" cmd of 203 | Left e -> lift $ putStrLn $ "Error: " ++ show e 204 | Right x -> runStmt x 205 | repl 206 | 207 | 208 | data Options = Options 209 | { optsFile :: Maybe String 210 | } 211 | 212 | main :: IO () 213 | main = O.execParser opts >>= mainWithOptions 214 | where 215 | opts = O.info (O.helper <*> options) 216 | (O.fullDesc 217 | <> O.header "ttie - A simple type checker/evaluator for a type theory with indexed equality" 218 | <> O.progDesc "REPL loading the given file") 219 | options = Options 220 | <$> O.argument (Just <$> O.str) 221 | ( O.metavar "FILE" 222 | <> O.help "File to open" 223 | <> O.value Nothing) 224 | 225 | mainWithOptions :: Options -> IO () 226 | mainWithOptions opts = do 227 | hSetBuffering stdout LineBuffering 228 | hSetBuffering stdin LineBuffering 229 | flip evalStateT emptyEnv $ do 230 | maybe (return ()) parseModule $ optsFile opts 231 | repl 232 | 233 | -------------------------------------------------------------------------------- /src/Names.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE DefaultSignatures #-} 5 | module Names where 6 | 7 | import Prelude () 8 | import Util.MyPrelude 9 | import Util.PrettyM 10 | 11 | import qualified Data.Set as Set 12 | import qualified Data.Sequence as Seq 13 | 14 | -------------------------------------------------------------------------------- 15 | -- Helper type: names are strings 16 | -------------------------------------------------------------------------------- 17 | 18 | type Name = String 19 | type Names = Set Name 20 | 21 | nameVariants :: Name -> [String] 22 | nameVariants "" = ["x" ++ show i | i <- [1::Int ..]] 23 | nameVariants name = [name,name++"'",name++"''"] ++ [name ++ show i | i <- [1::Int ..]] 24 | 25 | nameVariant :: Name -> String -> String 26 | nameVariant "" x = "x" ++ x 27 | nameVariant name x = name ++ x 28 | 29 | -- A variant of the given name that does not appear in the set ns 30 | freshNameVariants :: Names -> Name -> [Name] 31 | freshNameVariants ns n = filter (`Set.notMember` ns) (nameVariants n) 32 | 33 | freshNameVariant :: Names -> Name -> Name 34 | freshNameVariant ns n = head $ freshNameVariants ns n 35 | 36 | -- Some names are infix 37 | infixNames :: [(Name,(Int,Int,Int))] 38 | infixNames = 39 | [("_+_",(6,7,6)) --,("_*_",(7,8,7)) 40 | ,("_++_",(5,6,5)) 41 | ,("_==_",(4,5,5)),("_<_",(4,5,5)),("_>_",(4,5,5)),("_<=_",(4,5,5)),("_>=_",(4,5,5))] 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Helper type: binding names 45 | -------------------------------------------------------------------------------- 46 | 47 | data Bound a = Bound 48 | { boundName :: Name 49 | --, boundFree :: Names -- names free in the body 50 | , boundBody :: a 51 | } 52 | deriving (Functor) 53 | -- Note: Bound is not Traversible, to prevent mistakes wrt. keeping track of the bound values 54 | -- see TraverseBound class below 55 | 56 | instance Eq a => Eq (Bound a) where 57 | a == b = boundBody a == boundBody b 58 | 59 | -------------------------------------------------------------------------------- 60 | -- Helper type: named things 61 | -------------------------------------------------------------------------------- 62 | 63 | data Named a = Named 64 | { namedName :: Name -- irrelevant for Eq 65 | --, namedUsed :: Bool -- is the bound name used? if not, it can be replaced by an arbitrary name 66 | , namedValue :: a 67 | } 68 | deriving (Functor, Foldable, Traversable) 69 | 70 | named :: Name -> a -> Named a 71 | --named "" = unnamed 72 | named n = Named n 73 | 74 | unnamed :: a -> Named a 75 | unnamed = Named "" 76 | 77 | instance Eq a => Eq (Named a) where 78 | a == b = namedValue a == namedValue b 79 | 80 | instance Show a => Show (Named a) where 81 | showsPrec p (Named n ty) 82 | | null n = showsPrec p ty 83 | | otherwise = showParen (p > 0) $ showString n . showString " : " . shows ty 84 | 85 | -------------------------------------------------------------------------------- 86 | -- Helper type: hidden or visible 87 | -------------------------------------------------------------------------------- 88 | 89 | data Hiding = Hidden | Visible 90 | deriving (Eq,Ord,Show) 91 | 92 | data Arg a = Arg 93 | { argHiding :: Hiding 94 | , argValue :: a 95 | } 96 | deriving (Eq, Functor, Foldable, Traversable) 97 | 98 | visible, hidden :: a -> Arg a 99 | visible = Arg Visible 100 | hidden = Arg Hidden 101 | 102 | type NamedArg a = Arg (Named a) 103 | 104 | namedArgName :: NamedArg a -> Name 105 | namedArgName = namedName . argValue 106 | 107 | namedArgValue :: NamedArg a -> a-- 108 | namedArgValue = namedValue . argValue 109 | 110 | -------------------------------------------------------------------------------- 111 | -- Monads that can handle bound names 112 | -------------------------------------------------------------------------------- 113 | 114 | -- | Applicatives or monads that keep track of 115 | class Applicative f => MonadBound exp f where 116 | localBound :: Named exp -> f a -> f a 117 | 118 | traverseBound :: exp -> (a -> f b) -> Bound a -> f (Bound b) 119 | traverseBound ty f (Bound n x) = Bound n <$> localBound (named n ty) (f x) 120 | 121 | sequenceBound :: exp -> Bound (f a) -> f (Bound a) 122 | sequenceBound ty = traverseBound ty id 123 | 124 | -- traverse a binder, using the old exp for type information 125 | traverseBinder :: (exp -> Bound c -> d) -> (exp -> f exp) -> (a -> f c) -> exp -> Bound a -> f d 126 | traverseBinder = traverseBinderDefault 127 | 128 | -- traverse a binder, using the old exp for type information 129 | traverseBinderDefault :: MonadBound exp f => (b -> Bound c -> d) -> (exp -> f b) -> (a -> f c) -> exp -> Bound a -> f d 130 | traverseBinderDefault f g h x y = f <$> g x <*> traverseBound x h y 131 | 132 | class (Applicative f, Monad f) => MonadBoundNames f where 133 | boundNames :: f (Seq Name) 134 | boundNamesSet :: f (Set Name) 135 | boundNamesSet = Set.fromList . toList <$> boundNames 136 | boundDepth :: f Int 137 | boundDepth = Seq.length <$> boundNames 138 | 139 | class (MonadBoundNames f, MonadBound exp f) => MonadBoundTypes exp f | f -> exp where 140 | boundTypes :: f (Seq (Named exp)) 141 | 142 | -------------------------------------------------------------------------------- 143 | -- Some instances of MonadBound 144 | -------------------------------------------------------------------------------- 145 | 146 | instance Monoid a => MonadBound exp (Const a) where 147 | localBound _ = id 148 | instance MonadBound exp Identity where 149 | localBound _ = id 150 | instance MonadBound exp Maybe where 151 | localBound _ = id 152 | instance MonadBound exp [] where 153 | localBound _ = id 154 | instance (MonadBound exp f, Applicative g) => MonadBound exp (Compose f g) where 155 | localBound x (Compose y) = Compose (localBound x y) 156 | instance (MonadBound exp f, Monad f) => MonadBound exp (MaybeT f) where 157 | localBound x (MaybeT y) = MaybeT (localBound x y) 158 | 159 | newtype DepthT f a = DepthT { unDepthT :: ReaderT Int f a } 160 | deriving (Functor,Applicative,Monad) 161 | instance Applicative f => MonadBound exp (DepthT f) where 162 | localBound _ = DepthT . local' succ . unDepthT 163 | withDepth :: (Int -> f a) -> DepthT f a 164 | withDepth = DepthT . ReaderT 165 | runDepthT :: Int -> DepthT f a -> f a 166 | runDepthT d0 = flip runReaderT d0 . unDepthT 167 | 168 | newtype NamesT f a = NamesT { unNamesT :: ReaderT (Seq Name) f a } 169 | deriving (Functor,Applicative,Monad) 170 | instance Applicative f => MonadBound exp (NamesT f) where 171 | localBound x = NamesT . local' (namedName x <|) . unNamesT 172 | instance (Applicative f, Monad f) => MonadBoundNames (NamesT f) where 173 | boundNames = NamesT ask 174 | 175 | runNamesTWith :: Seq Name -> NamesT f a -> f a 176 | runNamesTWith names = flip runReaderT names . unNamesT 177 | 178 | runNamesT :: NamesT f a -> f a 179 | runNamesT = runNamesTWith Seq.empty 180 | 181 | -------------------------------------------------------------------------------- 182 | -- Traversing children of expressions 183 | -------------------------------------------------------------------------------- 184 | 185 | class TraverseChildren exp a where 186 | traverseChildren :: MonadBound exp f => (exp -> f exp) -> (a -> f a) 187 | traverseChildren_ :: MonadBound exp f => (exp -> f ()) -> (a -> f ()) 188 | traverseChildren_ f = fmap getConst . getCompose . traverseChildren (Compose . fmap Const . f) 189 | mapChildren :: (exp -> exp) -> (a -> a) 190 | mapChildren f = runIdentity . traverseChildren (Identity . f) 191 | 192 | instance TraverseChildren exp a => TraverseChildren exp (Arg a) where 193 | traverseChildren f x = traverse (traverseChildren f) x 194 | 195 | -------------------------------------------------------------------------------- 196 | -- Pretty Printing 197 | -------------------------------------------------------------------------------- 198 | 199 | namedBound :: Arg a -> Bound b -> (NamedArg a,b) 200 | namedBound x y = (named (boundName y) <$> x, boundBody y) 201 | 202 | instance Pretty m a => Pretty m (Named a) where 203 | ppr p (Named "" a) = ppr p a 204 | ppr p (Named n a) = group $ parenIf (p > 0) $ ppr 1 n $/$ text ":" <+> ppr 0 a 205 | 206 | instance (MonadBound () m, Pretty m a) => Pretty m (Bound a) where 207 | ppr p (Bound n a) = group $ parenIf (p > 0) $ brackets (ppr 0 n) <+> localBound (Named n ()) (ppr 0 a) 208 | 209 | instance Pretty m a => Pretty m (Arg a) where 210 | ppr p (Arg Visible a) = ppr p a 211 | ppr _ (Arg Hidden a) = braces $ ppr 0 a 212 | 213 | instance Pretty (NamesT Identity) a => Show (Bound a) where 214 | showsPrec p = showsDoc . runIdentity . runNamesT . ppr p 215 | 216 | -------------------------------------------------------------------------------- /src/Substitution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 2 | {-# LANGUAGE ViewPatterns, PatternSynonyms #-} 3 | {-# LANGUAGE DefaultSignatures, ConstraintKinds #-} 4 | module Substitution where 5 | 6 | import Prelude () 7 | import Util.MyPrelude 8 | import Names 9 | 10 | import qualified Data.IntMap as IM 11 | import qualified Data.Sequence as Seq 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Substitution and friends 15 | -------------------------------------------------------------------------------- 16 | 17 | class TraverseChildren a a => Subst a where 18 | var :: Int -> a 19 | unVar :: a -> Maybe Int 20 | 21 | -- traverse all variables 22 | mapExpM :: Applicative f => (Int -> f a) -> (a -> f a) 23 | mapExpM f = runDepthT 0 . go 24 | where 25 | go x = case unVar x of 26 | Just i -> withDepth $ \l -> 27 | if i < l 28 | then pure (var i) 29 | else raiseBy l <$> f (i-l) 30 | Nothing -> traverseChildren go x 31 | 32 | mapExp :: Subst a => (Int -> a) -> (a -> a) 33 | mapExp f = runIdentity . mapExpM (pure . f) 34 | 35 | -- Γ |- x 36 | -- --------- 37 | -- Γ,Δ |- raiseBy |Δ| x 38 | raiseBy :: Subst a => Int -> a -> a 39 | raiseBy 0 x = x 40 | raiseBy n (unVar -> Just x) = var (n + x) 41 | raiseBy n x = mapExp (\i -> var (n + i)) x 42 | 43 | -- Γ,E |- x 44 | -- --------- 45 | -- Γ,Δ,E |- raiseAtBy |E| |Δ| x 46 | -- raiseAtBy a b = raiseSubst b [var 0, var 1, var 2, .., var (a-1)] 47 | raiseAtBy :: Subst a => Int -> Int -> a -> a 48 | raiseAtBy m n = mapExp (\i -> if i < m then var i else var (n + i)) 49 | 50 | -- Γ,x2,x1,x0 |- y 51 | -- Γ,Δ |- xi 52 | -- --------- 53 | -- Γ,Δ |- substs [x0,x1,x2] y 54 | raiseSubsts :: Subst a => Int -> [a] -> (a -> a) 55 | raiseSubsts n = mapExp . substsVar 56 | where 57 | substsVar [] i = var (n + i) 58 | substsVar (x:_) 0 = x 59 | substsVar (_:xs) i = substsVar xs (i - 1) 60 | 61 | raiseSubstsM :: (Subst a, Applicative f) => Int -> [f a] -> a -> f a 62 | raiseSubstsM n = mapExpM . substsVarM 63 | where 64 | substsVarM [] i = pure $ var (n + i) 65 | substsVarM (x:_) 0 = x 66 | substsVarM (_:xs) i = substsVarM xs (i - 1) 67 | 68 | -- Γ,x2,x1,x0 |- y 69 | -- Γ |- xi 70 | -- --------- 71 | -- Γ |- substs [x0,x1,x2] y 72 | substs :: Subst a => [a] -> (a -> a) 73 | substs = raiseSubsts 0 74 | 75 | -- Γ,x |- y 76 | -- Γ |- x 77 | -- --------- 78 | -- Γ |- subst x y 79 | subst1 :: Subst a => a -> (a -> a) 80 | subst1 x = substs [x] 81 | 82 | -- Γ,x,Δ |- y 83 | -- Γ,Δ |- x 84 | -- --------- 85 | -- Γ,Δ |- substAt |Δ| x y 86 | substAt :: Subst a => Int -> a -> (a -> a) 87 | substAt n x = mapExp substVar 88 | where 89 | substVar i | i < n = var i 90 | | i == n = x 91 | | otherwise = var (i-1) 92 | 93 | -- Γ,x,Δ |- y 94 | -- Γ |- x 95 | -- --------- 96 | -- Γ,Δ |- substRaiseAt |Δ| x y 97 | substRaiseAt :: Subst a => Int -> a -> (a -> a) 98 | substRaiseAt n x = substAt n (raiseBy n x) 99 | 100 | substsN :: Subst a => Seq a -> (a -> a) 101 | substsN Empty = id 102 | substsN xs = mapExp $ \i -> if i < Seq.length xs 103 | then Seq.index xs i 104 | else var (i - Seq.length xs) 105 | 106 | -- Γ,x,Δ |- y 107 | -- --------- 108 | -- Γ,x',Δ,x |- raiseToFront |Δ| y 109 | raiseToFront :: Subst a => Int -> a -> a 110 | raiseToFront n = mapExp go 111 | where 112 | go i | i == n = var 0 113 | | otherwise = var (i+1) 114 | 115 | -- Γ,x,Δ |- y 116 | -- --------- 117 | -- Γ,Δ,x |- moveToFront |Δ| y 118 | moveToFront :: Subst a => Int -> a -> a 119 | moveToFront n = mapExp go 120 | where 121 | go i | i < n = var (i+1) 122 | | i == n = var 0 123 | | otherwise = var i 124 | 125 | -- Γ,x1..xn,Δ,x1'..xn' |- y 126 | -- ------------------------ 127 | -- Γ,x1..xn,Δ |- joinVariables delta n y = y[xi'=xi] 128 | -- = substs [var delta, var (delta+1), ..., var (delta+n-1)] y 129 | joinVariables :: Subst a => Int -> Int -> a -> a 130 | joinVariables delta n = mapExp go 131 | where 132 | go i | i < n = var (i + delta) 133 | | otherwise = var (i - n) 134 | 135 | -- does a variable occur free in the given expression 136 | varUsed :: Subst a => Int -> a -> Bool 137 | varUsed v = getAny . getConst . mapExpM (\i -> Const . Any $ i == v) 138 | 139 | -------------------------------------------------------------------------------- 140 | -- 'un'substitution 141 | -------------------------------------------------------------------------------- 142 | 143 | -- | Expressing each variable of the target as an expression of the source 144 | -- i.e. the type of meta arguments 145 | type InvCtxMap a = Seq a 146 | 147 | -- Expressing some variables of the source as an expression of the target 148 | type PartialCtxMap a = IntMap a 149 | 150 | -- Go from arguments that express each target var as a source expression 151 | invCtxMap :: Subst a => InvCtxMap a -> PartialCtxMap a 152 | invCtxMap xs = IM.fromList [ (v,var i) | (i, unVar -> Just v) <- zip [0..] (toList xs) ] 153 | 154 | unsubstN :: Subst a => InvCtxMap a -> a -> Maybe a 155 | unsubstN xs = mapExpM $ \i -> IM.lookup i vars 156 | where 157 | vars = invCtxMap xs 158 | 159 | -- replace all occurences of pat with (var 0) 160 | unsubst1 :: (Eq a, Subst a) => a -> a -> a 161 | unsubst1 pat = runIdentity . runDepthT 0 . go 162 | where 163 | go x = withDepth $ \l -> case unVar x of 164 | _ | x == raiseBy l pat -> pure (var l) 165 | Just i | i < l -> pure (var i) 166 | Just i | otherwise -> pure (var (i+1)) 167 | Nothing -> runDepthT l $ traverseChildren go x 168 | 169 | lowerBy :: Subst a => Int -> a -> Maybe a 170 | lowerBy 0 = pure 171 | lowerBy n = mapExpM $ \i -> if i < n then Nothing else Just $ var (i - n) 172 | 173 | {- 174 | lowerByN :: Subst a => Int -> Seq a -> a -> Maybe a 175 | lowerByN 0 _ = pure 176 | lowerByN n xs = mapExpM $ \i -> if i >= n then Just (var (i - n)) else IM.lookup i vars 177 | where 178 | vars = IM.fromList [ (v,var i) | (i, unVar -> Just v) <- zip [0..] (toList xs) ] 179 | -} 180 | 181 | pattern NotFree x <- (lowerBy 1 -> Just x) 182 | 183 | -- Is a given variable free in an expression? 184 | isFree :: Subst a => Int -> a -> Bool 185 | isFree i = getAny . getConst . mapExpM (\j -> Const . Any $ i == j) 186 | 187 | -------------------------------------------------------------------------------- 188 | -- Substitution and friends for Bound 189 | -------------------------------------------------------------------------------- 190 | 191 | substBound :: Subst a => Bound a -> a -> a 192 | substBound x y = subst1 y (boundBody x) 193 | 194 | -- Get the value from a bound where the name is not used 195 | lowerBound :: Subst a => Bound a -> Maybe a 196 | lowerBound = lowerBy 1 . boundBody 197 | 198 | -- A 'Bound' where the bound name is not used 199 | notBound :: Subst a => a -> Bound a 200 | notBound = Bound "" . raiseBy 1 201 | 202 | pattern NotBound x <- (Bound _ (lowerBy 1 -> Just x)) 203 | 204 | -------------------------------------------------------------------------------- /src/SubstitutionQQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 2 | {-# LANGUAGE ViewPatterns, PatternSynonyms, PatternGuards #-} 3 | {-# LANGUAGE DataKinds, KindSignatures #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | module SubstitutionQQ 6 | (Wrap(..),qq) 7 | where 8 | 9 | import Prelude () 10 | import Util.MyPrelude 11 | import Util.Parser 12 | import Tokenizer 13 | import Substitution 14 | 15 | import Data.Data (Data) 16 | import Data.List (findIndex) 17 | 18 | import qualified Text.Parsec as P 19 | import qualified Text.Parsec.Pos as P 20 | 21 | import GHC.TypeLits 22 | 23 | import Language.Haskell.TH as TH 24 | import Language.Haskell.TH.Quote as TH 25 | 26 | -------------------------------------------------------------------------------- 27 | -- Template haskell to improve safety 28 | -------------------------------------------------------------------------------- 29 | 30 | -- The idea is that you write [qq| Foo ([x] Bar y) |] 31 | -- to indicate that the variable "x" is bound inside (Bar y) 32 | -- the only way to get back to a normal expression is by [qq| Baz (x: y)] or [qq| y[x=..] ]. 33 | -- raising/substitution is then performed automatically. 34 | 35 | -- Desugaring: 36 | -- Foo ([x](Bar [y]z)) = Foo (Bar [x][y]z) 37 | -- [x1]..[xn] xi = var (n-i) 38 | -- [x1]..[xn] z = z[x1,...,xn] = z[x1=x1,...,xn=xn] 39 | -- [x1]..[xn] z[y1=u1,yn=un] = raiseSubst n (reverse [u1,..,un]) 40 | 41 | -- More sugar: 42 | -- [$x] y = Bound $x [x]y 43 | -- [~x] y = wrap "x" [x]y 44 | -- [%x:t] y = sequenceBound t (Bound $x [x]y) 45 | -- %x y z = x y z 46 | -- x `F` y = F x y 47 | -- More sugar (TODO): 48 | -- (x:a) -> b = Pi a [x]b 49 | -- (x:a) * b = Si a [x]b 50 | -- (x:a) => b = Lam a [x]b 51 | 52 | -------------------------------------------------------------------------------- 53 | -- Syntax and parsing 54 | -------------------------------------------------------------------------------- 55 | 56 | -- possible patterns 57 | type ConName = Name 58 | type VarName = String 59 | type BoundName = String 60 | data GenBind 61 | = Con ConName [GenBind] 62 | | Fun ExpQ [GenBind] 63 | | Var [BoundName] Bool VarName (Maybe [(BoundName,GenBind)]) 64 | deriving () 65 | 66 | bind :: BoundName -> GenBind -> GenBind 67 | bind b (Con x xs) = Con x (map (bind b) xs) 68 | bind b (Fun x xs) = Fun x (map (bind b) xs) 69 | bind b (Var bs True x xs) = Var (b:bs) True x (fmap (map (second (bind b))) xs) 70 | bind b (Var bs False x xs) = Var bs False x (fmap (map (second (bind b))) xs) 71 | 72 | bindBound :: BoundName -> GenBind -> GenBind 73 | bindBound n x = Con (mkName "Bound") [Var [] False n Nothing, bind n x] 74 | bindSequence :: BoundName -> GenBind -> GenBind -> GenBind 75 | bindSequence n t x = Fun (varE $ mkName "sequenceBound") [t,bindBound n x] 76 | bindWrap :: BoundName -> GenBind -> GenBind 77 | bindWrap n x = Fun (wrapQ n) [bind n x] 78 | 79 | isBoundVar :: GenBind -> Maybe Int 80 | isBoundVar (Var bs _ x Nothing) = findIndex (==x) (reverse bs) 81 | isBoundVar _ = Nothing 82 | pattern BoundVar i <- (isBoundVar -> Just i) 83 | 84 | -------------------------------------------------------------------------------- 85 | -- Parsing 86 | -------------------------------------------------------------------------------- 87 | 88 | parseGenBind :: Int -> Parser GenBind 89 | parseGenBind p = do 90 | x <- parseGenBindSimple p 91 | go x 92 | where 93 | go x = (do 94 | guard (p < 10) 95 | n <- tokBacktick *> tokUpperName <* tokBacktick 96 | y <- parseGenBindSimple 10 97 | go (Con (mkName n) [x,y]) 98 | ) <|> return x 99 | 100 | parseGenBindSimple :: Int -> Parser GenBind 101 | parseGenBindSimple p 102 | = tokLParen *> parseGenBind 0 <* tokRParen 103 | <|> (Con . mkName) <$> tokUpperName <*> 104 | (guard (p <= 10) *> many (parseGenBind 11) <|> return []) 105 | <|> (Fun . varE . mkName) <$ tokReservedOp "%" <*> tokName <*> 106 | (guard (p <= 10) *> many (parseGenBind 11) <|> return []) 107 | <|> tokLBracket *> (bindBound <$ tokDollar <*> tokLowerName 108 | <|> bindWrap <$ tokReservedOp "~" <*> tokLowerName 109 | <|> bindSequence <$ tokReservedOp "%" <*> tokLowerName <* tokColon <*> parseGenBindSimple 0 110 | <|> bind <$> tokLowerName) 111 | <* tokRBracket <*> parseGenBind p 112 | <|> Var [] <$> (False <$ tokDollar <|> pure True) 113 | <*> tokLowerNameNoWS <*> 114 | (Just <$ tokLBracket <*> (P.sepBy parseSubst tokComma) <* tokRBracket <|> 115 | Nothing <$ tokWS) 116 | 117 | parseSubst :: Parser (BoundName,GenBind) 118 | parseSubst = do 119 | n <- tokLowerName 120 | v <- tokEquals *> parseGenBind 0 <|> return (Var [] True n Nothing) 121 | return (n,v) 122 | 123 | -------------------------------------------------------------------------------- 124 | -- Template Haskell: utility 125 | -------------------------------------------------------------------------------- 126 | 127 | posFromTH :: TH.Loc -> P.SourcePos 128 | posFromTH loc = P.newPos (TH.loc_filename loc) (fst (TH.loc_start loc)) (snd (TH.loc_start loc)) 129 | 130 | -- run a parser with correct localitions 131 | parseTH :: Parser a -> String -> TH.Q a 132 | parseTH p s = do 133 | loc <- TH.location 134 | case P.runParser (P.setPosition (posFromTH loc) *> p <* P.eof) Nothing "" s of 135 | Left err -> fail $ show err ++ " in quasi quote" 136 | Right e -> return e 137 | 138 | dataP :: Data a => a -> PatQ 139 | dataP = dataToPatQ (\_ -> Nothing) 140 | 141 | dataE :: Data a => a -> ExpQ 142 | dataE = dataToExpQ (\_ -> Nothing) 143 | 144 | -------------------------------------------------------------------------------- 145 | -- Support functions/types 146 | -------------------------------------------------------------------------------- 147 | 148 | newtype Wrap (s :: Symbol) x = Wrap { unwrap :: x } 149 | deriving (Functor,Foldable,Traversable) 150 | 151 | -------------------------------------------------------------------------------- 152 | -- Template haskell 153 | -------------------------------------------------------------------------------- 154 | 155 | wrapQ :: String -> ExpQ 156 | wrapQ n = do 157 | -- [e|Wrap :: a -> Wrap "b" a|] 158 | wrapE <- [e|Wrap|] 159 | wrapT <- [t|Wrap|] 160 | a <- newName "a" 161 | let wrap_na = wrapT `AppT` LitT (StrTyLit n) `AppT` VarT a 162 | parensE $ return $ SigE wrapE (ForallT [PlainTV a] [] (ArrowT `AppT` VarT a `AppT` wrap_na)) 163 | 164 | unwrapQ :: String -> ExpQ 165 | unwrapQ n = do 166 | -- [e|unwrap :: Wrap "b" a -> a|] 167 | unwrapE <- [e|unwrap|] 168 | wrapT <- [t|Wrap|] 169 | a <- newName "a" 170 | let wrap_na = wrapT `AppT` LitT (StrTyLit n) `AppT` VarT a 171 | parensE $ return $ SigE unwrapE (ForallT [PlainTV a] [] (ArrowT `AppT` wrap_na `AppT` VarT a)) 172 | 173 | mkSubst' :: Int -> [ExpQ] -> ExpQ -> ExpQ 174 | mkSubst' 0 [] x = x 175 | mkSubst' n [] x = [| raiseBy |] `appE` dataE n `appE` x 176 | mkSubst' n xs x = [| raiseSubsts |] `appE` dataE n `appE` (listE xs) `appE` x 177 | 178 | mkSubst :: Int -> [ExpQ] -> ExpQ -> ExpQ 179 | mkSubst n xs y 180 | | n > 0 && length xs > 0 = do 181 | -- simplify the substitution: raiseSubst (n+1) [x1,x2,..,x{i-1},var n] = raiseSubst n [x1,x2,..,x{i-1}] 182 | -- testing whether last xs == var i requires that we evaluate the ExpQs to Exps 183 | lx <- last xs 184 | lx' <- appE [e|var|] (dataE (n - 1)) 185 | if lx == lx' 186 | then mkSubst (n-1) (init xs) y 187 | else mkSubst' n xs y 188 | | otherwise = mkSubst' n xs y 189 | 190 | mkUnsubst :: [Maybe Int] -> PatQ -> PatQ 191 | mkUnsubst [] = id 192 | mkUnsubst xs 193 | | last xs == Just (length xs - 1) = mkUnsubst (init xs) 194 | | all isNothing xs = viewP ([| lowerBy |] `appE` dataE (length xs)) . justP 195 | | otherwise = viewP ([| raiseSubstsM |] `appE` dataE (length $ filter isJust xs) `appE` listE xs') . justP 196 | where 197 | xs' = map (maybe [|Nothing|] (\x -> [|Just|] `appE` ([|var|] `appE` dataE x))) xs 198 | 199 | justP :: PatQ -> PatQ 200 | justP x = conP 'Just [x] --' 201 | 202 | toPat :: GenBind -> PatQ 203 | toPat (Con x xs) = conP x (map toPat xs) 204 | toPat (Fun _ _) = error "Functions not supported in patterns" 205 | toPat (BoundVar i) = viewP [e|unVar|] (dataP (Just i)) 206 | --toPat (Var bs _ x Nothing) = foldr (\b -> viewP (wrapQ b)) (varP (mkName x)) bs 207 | --toPat (Var bs _ x (Just [])) = error $ "Lower by " ++ show (length bs) 208 | --toPat (Var _ _ _ (Just _)) = error "Can't handle substitution in patterns" 209 | toPat (Var bs _ x ss) 210 | | any (`notElem` bs) ss' = error $ "Unknown variables: " ++ show (filter (`notElem` bs) ss') 211 | | otherwise = unsubst 212 | where 213 | ss' = maybe bs (map fst) ss -- names to wrap in 214 | -- mapping back 215 | namePat | x == "_" = wildP 216 | | otherwise = varP (mkName x) 217 | wrapped = foldr (\b -> viewP (wrapQ b)) namePat (reverse ss') 218 | unsubst = mkUnsubst [findIndex (b==) (reverse ss') | b <- reverse bs] wrapped 219 | 220 | toExp :: GenBind -> ExpQ 221 | toExp (Con x xs) = foldl appE (conE x) (map toExp xs) 222 | toExp (Fun x xs) = foldl appE x (map toExp xs) 223 | toExp (BoundVar i) = appE [e|var|] (dataE i) 224 | toExp (Var bs bb x ss) = mkSubst (length bs) (map (toExp . snd) (reverse ss')) (unwrapped) 225 | where 226 | -- if there is no substitution, then assume that all bound variables are to be substituted 227 | ss' = fromMaybe (map (\n -> (n,Var bs bb n Nothing)) bs) ss 228 | unwrapped = foldr (\(b,_) -> appE (unwrapQ b)) (varE (mkName x)) (reverse ss') 229 | 230 | qq :: QuasiQuoter 231 | qq = QuasiQuoter 232 | { quoteExp = toExp <=< parseTH (tokWS *> parseGenBind 0 <* P.eof) 233 | , quotePat = toPat <=< parseTH (tokWS *> parseGenBind 0 <* P.eof) 234 | , quoteType = fail "exp is not a Type quasi quoter" 235 | , quoteDec = fail "exp is not a Declaration quasi quoter" 236 | } 237 | 238 | 239 | -------------------------------------------------------------------------------- /src/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 2 | {-# LANGUAGE ViewPatterns, PatternSynonyms #-} 3 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | module Syntax where 9 | 10 | import Prelude () 11 | import Util.MyPrelude 12 | import Util.PrettyM 13 | import Util.Parser 14 | import Util.Tagged.Var 15 | import qualified Util.Tagged.Internal as TV 16 | import qualified Util.Tagged.Map as TM 17 | import Substitution 18 | import Names 19 | import Tokenizer 20 | 21 | import qualified Data.Set as Set 22 | import qualified Data.Sequence as Seq 23 | import Data.List (lookup) 24 | 25 | -------------------------------------------------------------------------------- 26 | -- Expressions 27 | -------------------------------------------------------------------------------- 28 | 29 | -- Expressions and types 30 | data Exp 31 | = Var Int 32 | | Free Name 33 | | Binder Binder (Arg Exp) (Bound Exp) 34 | | App Exp (Arg Exp) 35 | -- sets 36 | | Set Level 37 | -- pairs 38 | | Proj Hiding Proj Exp 39 | | Pair Hiding Exp Exp Exp -- (x , y) : t 40 | -- unit type 41 | | UnitTy 42 | | UnitVal 43 | -- sum types 44 | | SumTy [SumCtor] 45 | | SumVal Name Exp Exp 46 | | SumElim Exp [SumCase] Exp -- case x of {..} : (..) x 47 | -- equality 48 | | Eq (Bound Exp) Exp Exp 49 | | Refl (Bound Exp) 50 | | Cast (Bound Exp) Exp Exp Exp 51 | | Equiv Exp Exp Exp Exp Exp 52 | -- interval 53 | | Interval | I0 | I1 | I01 | I10 | IFlip Exp | IAnd Exp Exp 54 | | IV Exp Exp Exp Exp 55 | -- typing 56 | | TypeSig Exp Exp 57 | | Meta MetaVar (Seq Exp) 58 | | Blank 59 | deriving (Eq) 60 | 61 | -- Binders 62 | data Binder = PiB | SiB | LamB 63 | deriving (Eq) 64 | 65 | type MetaVar = TaggedVar "meta" 66 | 67 | -- | Fields in a pair 68 | data Proj = Proj1 | Proj2 69 | deriving (Eq, Ord, Show, Enum) 70 | 71 | -- | Sum constructors and cases 72 | data SumCtor = SumCtor { ctorName :: Name, ctorType :: Exp } -- n : a 73 | deriving (Eq) 74 | data SumCase = SumCase { caseName :: Name, caseType :: Exp, caseBody :: Bound Exp } -- n (x:a) -> b 75 | deriving (Eq) 76 | 77 | pattern Pi x y = Binder PiB x y 78 | pattern Si x y = Binder SiB x y 79 | pattern Lam x y = Binder LamB x y 80 | 81 | infixl 9 `App`, `AppV`, `AppH` 82 | pattern AppV x y = App x (Arg Visible y) 83 | pattern AppH x y = App x (Arg Hidden y) 84 | 85 | pattern PiV x y = Pi (Arg Visible x) y 86 | pattern PiH x y = Pi (Arg Hidden x) y 87 | 88 | pattern IOr x y = IFlip (IAnd (IFlip x) (IFlip y)) 89 | 90 | -------------------------------------------------------------------------------- 91 | -- Universe levels 92 | -------------------------------------------------------------------------------- 93 | 94 | -- level is of the form max x (maximum (?yi + zi)) 95 | -- invariant: x >= maximum zi 96 | data Level = Level Int (TM.TaggedMap "level-meta" Int) 97 | deriving (Eq) 98 | 99 | type LevelMetaVar = TaggedVar "level-meta" 100 | 101 | intLevel :: Int -> Level 102 | intLevel i = Level i TM.empty 103 | 104 | zeroLevel :: Level 105 | zeroLevel = intLevel 0 106 | 107 | metaLevel :: LevelMetaVar -> Level 108 | metaLevel mv = Level 0 $ TM.singleton mv 0 109 | 110 | pattern IntLevel i <- Level i (TM.null -> True) 111 | pattern ZeroLevel <- IntLevel 0 112 | pattern MetaLevel mv <- Level 0 (TM.toList -> [mv]) 113 | pattern MetaLevels mvs <- Level 0 (TM.toList -> mvs) 114 | 115 | addLevel :: Int -> Level -> Level 116 | addLevel x (Level i j) = Level (x + i) (map (x +) j) 117 | 118 | subtractLevel :: Int -> Level -> Maybe Level 119 | subtractLevel x (Level i j) = Level <$> trySubtract x i <*> traverse (trySubtract x) j 120 | 121 | sucLevel :: Level -> Level 122 | sucLevel = addLevel 1 123 | 124 | maxLevel :: Level -> Level -> Level 125 | maxLevel (Level i j) (Level i' j') = Level (max i i') (TM.unionWith max j j') 126 | 127 | maxLevels :: [Level] -> Level 128 | maxLevels = foldr maxLevel zeroLevel 129 | 130 | -------------------------------------------------------------------------------- 131 | -- Declarations 132 | -------------------------------------------------------------------------------- 133 | 134 | -- Declarations 135 | data Decl 136 | = Postulate 137 | { declType :: Exp } 138 | | FunDecl 139 | { declType :: Exp 140 | , declValue :: Exp } 141 | 142 | declTryValue :: Decl -> Maybe Exp 143 | declTryValue (Postulate _) = Nothing 144 | declTryValue (FunDecl _ x) = Just x 145 | 146 | -------------------------------------------------------------------------------- 147 | -- Constructors / combinators 148 | -------------------------------------------------------------------------------- 149 | 150 | mkNat :: Int -> Exp 151 | mkNat 0 = Free "zero" 152 | mkNat n = Free "suc" `AppV` mkNat (n-1) 153 | 154 | caseToCtor :: SumCase -> SumCtor 155 | caseToCtor (SumCase n u _) = SumCtor n u 156 | 157 | mkTypeSig :: Exp -> Exp -> Exp 158 | mkTypeSig (Pair h a b Blank) t = Pair h a b t 159 | mkTypeSig a b = TypeSig a b 160 | 161 | -------------------------------------------------------------------------------- 162 | -- Traversing expressions 163 | -------------------------------------------------------------------------------- 164 | 165 | instance TraverseChildren Exp Exp where 166 | traverseChildren _ (Var i) = pure $ Var i 167 | traverseChildren _ (Free c) = pure $ Free c 168 | traverseChildren _ (Set i) = pure $ Set i 169 | traverseChildren f (Binder u (Arg h x) y) = traverseBinder (Binder u . Arg h) f f x y 170 | traverseChildren f (App x y) = App <$> f x <*> traverse f y 171 | traverseChildren f (Proj h x y) = Proj h x <$> f y 172 | traverseChildren f (Pair h x y z) = Pair h <$> f x <*> f y <*> f z 173 | traverseChildren _ UnitTy = pure UnitTy 174 | traverseChildren _ UnitVal = pure UnitVal 175 | traverseChildren f (SumTy xs) = SumTy <$> traverse (traverseChildren f) xs 176 | traverseChildren f (SumVal x y z) = SumVal x <$> f y <*> f z 177 | traverseChildren f (SumElim x ys z) = SumElim <$> f x <*> traverse (traverseChildren f) ys <*> f z 178 | traverseChildren f (Eq x y z) = Eq <$> traverseBound Interval f x <*> f y <*> f z 179 | traverseChildren f (Refl x) = Refl <$> traverseBound Interval f x 180 | traverseChildren _ Interval = pure Interval 181 | traverseChildren _ I0 = pure I0 182 | traverseChildren _ I1 = pure I1 183 | traverseChildren _ I01 = pure I01 184 | traverseChildren _ I10 = pure I10 185 | traverseChildren f (IFlip x) = IFlip <$> f x 186 | traverseChildren f (IAnd x y) = IAnd <$> f x <*> f y 187 | traverseChildren f (IV x y z w) = IV <$> f x <*> f y <*> f z <*> f w 188 | traverseChildren f (Cast a b c d) = Cast <$> traverseBound Interval f a <*> f b <*> f c <*> f d 189 | traverseChildren f (Equiv a b c d e) = Equiv <$> f a <*> f b <*> f c <*> f d <*> f e 190 | traverseChildren f (TypeSig x y) = TypeSig <$> f x <*> f y 191 | traverseChildren f (Meta x y) = Meta x <$> traverse f y 192 | traverseChildren _ Blank = pure $ Blank 193 | 194 | instance TraverseChildren Exp SumCtor where 195 | traverseChildren f (SumCtor n x) = SumCtor n <$> f x 196 | instance TraverseChildren Exp SumCase where 197 | traverseChildren f (SumCase n x y) = traverseBinder (SumCase n) f f x y 198 | 199 | data ExpTraversal f = ExpTraversal 200 | { travVar :: Int -> f Exp 201 | , travFree :: Name -> f Exp 202 | } 203 | defExpTraversal :: Applicative f => ExpTraversal f 204 | defExpTraversal = ExpTraversal 205 | { travVar = \i -> pure $ Var i 206 | , travFree = \c -> pure $ Free c 207 | } 208 | 209 | traverseExp :: Applicative f => Int -> ExpTraversal f -> (Exp -> f Exp) 210 | traverseExp l f (Var i) 211 | | i < l = pure $ Var i 212 | | otherwise = raiseBy l <$> travVar f (i - l) 213 | traverseExp l f (Free c) = raiseBy l <$> travFree f c 214 | traverseExp l f x = runDepthT l $ traverseChildren (\x' -> withDepth $ \l' -> traverseExp l' f x') x 215 | 216 | foldExp :: Monoid m => Int -> (Int -> m) -> (Name -> m) -> (Exp -> m) 217 | foldExp l0 f g = getConst . traverseExp l0 ExpTraversal 218 | { travVar = Const . f 219 | , travFree = Const . g } 220 | 221 | instance Subst Exp where 222 | var = Var 223 | unVar (Var i) = Just i 224 | unVar _ = Nothing 225 | 226 | -------------------------------------------------------------------------------- 227 | -- Renaming for printing and parsing 228 | -------------------------------------------------------------------------------- 229 | 230 | -- free names 231 | nameUsed :: Name -> Exp -> Bool 232 | nameUsed v = getAny . foldExp 0 (\_ -> Any False) (\i -> Any $ i == v) 233 | 234 | freeNames :: Exp -> Set Name 235 | freeNames = foldExp 0 (\_ -> Set.empty) Set.singleton 236 | 237 | freshName :: Name -> Exp -> Name 238 | freshName n x = head $ dropWhile (`nameUsed` x) (nameVariants n) 239 | 240 | -- convert (Var i) to (Free _), for display 241 | renameForPrinting :: Bound Exp -> Bound Exp 242 | renameForPrinting (Bound n b) 243 | | varUsed 0 b = Bound n' (raiseSubsts 1 [Free n'] b) 244 | | otherwise = Bound "" b 245 | where 246 | n' = freshName n b 247 | 248 | -- convert all unbound names to Vars 249 | -- function specifies which Frees to keep 250 | 251 | {- 252 | -- precondition: the expression has no free variables 253 | captureAll :: (Name -> Bool) -> Exp -> (Exp, Map.Map Name Int) 254 | captureAll keep = flip runState Map.empty . traverseExp 0 ExpTraversal 255 | { travVar = \i -> error $ "captured: free variable " ++ show i 256 | , travFree = \n -> if keep n 257 | then return (Free n) 258 | else Var <$> lookupOrNew n 259 | } 260 | 261 | lookupOrNew :: Ord a => a -> State (Map.Map a Int) Int 262 | lookupOrNew x = state $ \s -> case Map.lookup x s of 263 | Just i -> (i, s) 264 | Nothing -> (i, Map.insert x i s) where i = Map.size s 265 | -} 266 | 267 | -- convert a single given name to Var 0 268 | capture :: Name -> Exp -> Bound Exp 269 | capture n = Bound n . runIdentity . traverseExp 0 ExpTraversal 270 | { travVar = \i -> Identity $ Var (i + 1) 271 | , travFree = \n' -> Identity $ if n == n' then Var 0 else Free n' 272 | } 273 | 274 | {- 275 | captureMany :: [Name] -> Exp -> Exp 276 | captureMany ns = runIdentity . traverseExp 0 ExpTraversal 277 | { travVar = \i -> Identity $ Var (i + nn) 278 | , travFree = \c -> Identity $ case findIndex (c ==) ns of 279 | Just i -> Var i 280 | Nothing -> Free c 281 | } 282 | where nn = length ns 283 | -} 284 | 285 | -------------------------------------------------------------------------------- 286 | -- Pretty Printing 287 | -------------------------------------------------------------------------------- 288 | 289 | instance (MonadBound Exp m, MonadBoundNames m) => Pretty m Exp where 290 | --ppr _ (Var i) = text "#" <.> ppr 0 i 291 | ppr _ (Var i) = do 292 | mname <- seqLookup i <$> boundNames 293 | case mname of 294 | Just n -> text n <.> text "#" <.> ppr 0 i 295 | Nothing -> text "#" <.> ppr 0 i 296 | ppr p (Free c) = ppr p c 297 | ppr _ (Set ZeroLevel) = text "Type" 298 | ppr _ (Set (IntLevel i)) = text "Type" <.> int i 299 | ppr _ (Set l) = text "Type" <.> ppr 11 l 300 | ppr p (App a b) = group $ parenAlignIf (p > 10) $ ppr 10 a $/$ ppr 11 b 301 | {-ppr p (Binder x a b) = do 302 | where (a',b') = namedBound a (renameForPrinting b) 303 | case x of 304 | PiB -> group $ parenIf (p > 1) $ ppr 2 a' $/$ text "->" <+> localBound (argValue a') (ppr 1 b') 305 | SiB -> group $ parenIf (p > 2) $ ppr 3 a' $/$ text "*" <+> localBound (argValue a') (ppr 2 b') 306 | LamB -> group $ parenIf (p > 1) $ ppr 10 a' $/$ text "=>" <+> localBound (argValue a') (ppr 1 b')-} 307 | ppr p (Binder x a b) = case x of 308 | --PiB -> group $ if (p > 1) then parens $ align $ nest 3 (ppr 2 a') $$ text "->" <+> localBound (argValue a') (ppr 1 b') 309 | -- else ppr 2 a' $$ text "->" <+> localBound (argValue a') (ppr 1 b') 310 | PiB -> group $ parenAlignIf (p > 1) $ ppr 2 a' $$ text "->" <+> localBound (argValue a') (ppr 1 b') 311 | SiB -> group $ parenAlignIf (p > 2) $ ppr 3 a' $$ text "*" <+> localBound (argValue a') (ppr 2 b') 312 | LamB -> group $ parenAlignIf (p > 3) $ ppr 4 a' $$ text "=>" <+> localBound (argValue a') (ppr 3 b') 313 | where (a',b') = namedBound a (renameForPrinting b) 314 | ppr _ (UnitTy) = text "Unit" 315 | ppr _ (UnitVal) = text "tt" 316 | ppr _ (SumTy xs) = group $ text "data" $/$ semiBraces (map (ppr 0) xs) 317 | ppr p (SumVal x y _) = group $ parenAlignIf (p > 10) $ text "value" <+> text x <+> ppr 11 y 318 | ppr _ (SumElim x ys _) = group $ text "case" <+> ppr 0 x <+> text "of" <+> semiBraces (map (ppr 0) ys) 319 | ppr p (Proj h x y) = group $ parenIf (p > 10) $ ppr p (Arg h x) <+> ppr 11 y 320 | --ppr p (Pair h x y _) = group $ parenIf (p > 2) $ align $ ppr 3 (Arg h x) <.> text "," $$ ppr 2 y 321 | ppr p (Pair h x y z) = group $ parenIf (p > 0) $ align $ ppr 3 (Arg h x) <.> text "," $$ ppr 2 y $/$ text ":" <+> ppr 0 z 322 | ppr p (Eq x y z) = group $ parenAlignIf (p > 10) $ case renameForPrinting x of 323 | Bound "" x' -> align $ text "Eq" $/$ localBound (unnamed Interval) (ppr 11 x') $/$ ppr 11 y $/$ ppr 11 z 324 | Bound n x' -> align $ text "Eq_" <.> text n $/$ localBound (named n Interval) (ppr 11 x') $/$ ppr 11 y $/$ ppr 11 z 325 | ppr p (Refl x) = group $ parenAlignIf (p > 10) $ case renameForPrinting x of 326 | Bound "" x' -> align $ text "refl" $/$ localBound (unnamed Interval) (ppr 11 x') 327 | Bound n x' -> align $ text "refl_" <.> text n $/$ localBound (named n Interval) (ppr 11 x') 328 | ppr _ Interval = text "Interval" 329 | ppr _ I0 = text "0" 330 | ppr _ I1 = text "1" 331 | ppr _ I01 = text "01" 332 | ppr _ I10 = text "10" 333 | ppr p (IFlip x) = group $ parenIf (p > 10) $ text "iflip" <+> ppr 11 x 334 | ppr p (IAnd x y) = group $ parenIf (p > 10) $ text "iand" <+> ppr 11 x <+> ppr 11 y 335 | --ppr p (IV _x _y z w) = group $ parenIf (p > 11) $ ppr 11 z <.> text "^" <.> ppr 12 w 336 | ppr p (IV x y z w) = group $ parenAlignIf (p > 10) $ align $ text "iv" $/$ ppr 11 x $/$ ppr 11 y $/$ ppr 11 z $/$ ppr 11 w 337 | ppr p (Cast a b c d) = group $ parenIf (p > 10) $ align $ case renameForPrinting a of 338 | Bound "" a' -> text "cast" $/$ localBound (unnamed Interval) (ppr 11 a') $/$ ppr 11 b $/$ ppr 11 c $/$ ppr 11 d 339 | Bound n a' -> text "cast_" <.> text n $/$ localBound (named n Interval) (ppr 11 a') $/$ ppr 11 b $/$ ppr 11 c $/$ ppr 11 d 340 | ppr p (Equiv a b c d e) = group $ parenIf (p > 10) $ align $ text "equiv" $/$ ppr 11 a $/$ ppr 11 b $/$ ppr 11 c $/$ ppr 11 d $/$ ppr 11 e 341 | ppr p (TypeSig a b) = group $ parenIf (p > 0) $ ppr 1 a $/$ text ":" <+> ppr 0 b 342 | ppr _ (Meta i args) 343 | | Seq.null args = ppr 0 i 344 | | otherwise = ppr 0 i <.> semiBrackets (map (ppr 0) (toList args)) 345 | ppr _ Blank = text "_" 346 | 347 | instance Applicative m => Pretty m Proj where 348 | ppr _ Proj1 = text "proj1" 349 | ppr _ Proj2 = text "proj2" 350 | 351 | instance (MonadBound Exp m, MonadBoundNames m) => Pretty m SumCtor where 352 | ppr _ (SumCtor n x) = text n <+> text ":" <+> ppr 0 x 353 | 354 | instance (MonadBound Exp m, MonadBoundNames m) => Pretty m SumCase where 355 | ppr _ (SumCase n x y) = text n <+> ppr 1 (Named yN x) <+> text "->" <+> ppr 0 (boundBody y') 356 | where 357 | y' = renameForPrinting y 358 | yN = if boundName y' == "" then "_" else boundName y' 359 | 360 | instance Applicative m => Pretty m Level where 361 | ppr _ (IntLevel i) = int i 362 | ppr _ (Level l ls) = semiBrackets $ [int l|l>0] ++ [ ppr 0 mv <.> if i == 0 then emptyDoc else text "+" <.> int i | (mv,i) <- TM.toList ls] 363 | 364 | instance Applicative m => Pretty m MetaVar where 365 | ppr _ (TV.TV i) = text "?" <.> ppr 0 i 366 | instance Applicative m => Pretty m LevelMetaVar where 367 | ppr _ (TV.TV i) = text "?l" <.> ppr 0 i 368 | 369 | pprDecl :: (MonadBound Exp m, MonadBoundNames m) => Name -> Decl -> m Doc 370 | pprDecl n (Postulate ty) = text n <+> text ":" <+> ppr 0 ty 371 | pprDecl n (FunDecl ty val) = text n <+> align (text ":" <+> align (ppr 0 ty) $$ text "=" <+> align (ppr 0 val)) 372 | 373 | instance Show Exp where 374 | showsPrec p = showsDoc . runIdentity . runNamesT . ppr p 375 | instance Show SumCtor where 376 | showsPrec p = showsDoc . runIdentity . runNamesT . ppr p 377 | instance Show SumCase where 378 | showsPrec p = showsDoc . runIdentity . runNamesT . ppr p 379 | instance Show Level where 380 | showsPrec p = showsDoc . runIdentity . runNamesT . ppr p 381 | instance Show Decl where 382 | showsPrec _ = showsDoc . runIdentity . runNamesT . pprDecl "_" 383 | 384 | showExp :: NamesT Identity Doc -> String 385 | showExp = showDoc . runIdentity . runNamesT 386 | 387 | -- for debugging: show assuming the given names 388 | showWithNames :: Pretty (NamesT Identity) a => [Name] -> a -> String 389 | showWithNames names = showDoc . runIdentity . runNamesTWith (Seq.fromList names) . ppr 0 390 | 391 | -------------------------------------------------------------------------------- 392 | -- Parsing 393 | -------------------------------------------------------------------------------- 394 | 395 | -- the parser needs to know which names are bound 396 | type ParserEnv = (Name -> Bool) 397 | 398 | parseExpPrim :: Int -> Parser Exp 399 | parseExpPrim p 400 | = tokLParen *> parseExp 0 <* tokRParen 401 | <|> mkBinders LamB <$ tokLambda <*> parseBinders <* (tokArrow <|> tokDot) <*> parseExp 0 402 | <|> mkBinders PiB <$ tokForall <*> parseBinders <* (tokArrow <|> tokDot) <*> parseExp 0 403 | <|> mkBinders SiB <$ tokExists <*> parseBinders <* (tokArrow <|> tokDot) <*> parseExp 0 404 | <|> Blank <$ tokUnderscore 405 | <|> Set . intLevel <$> tokType 406 | <|> Var <$> tokVar 407 | <|> Proj Visible Proj1 <$ guard (p <= 10) <* tokReservedName "proj1" <*> parseExp 11 408 | <|> Proj Visible Proj2 <$ guard (p <= 10) <* tokReservedName "proj2" <*> parseExp 11 409 | <|> Proj Hidden Proj1 <$ guard (p <= 10) <* try (tokLBrace *> tokReservedName "proj1" <* tokRBrace) <*> parseExp 11 410 | <|> Proj Hidden Proj2 <$ guard (p <= 10) <* try (tokLBrace *> tokReservedName "proj2" <* tokRBrace) <*> parseExp 11 411 | <|> UnitTy <$ tokReservedName "Unit" 412 | <|> UnitVal <$ tokReservedName "tt" 413 | <|> SumTy <$ tokReservedName "data" <* tokLBrace <*> parseSumCtor `sepBy` tokSemi <* tokRBrace 414 | <|> SumElim <$ tokReservedName "case" <*> parseExp 0 <* tokReservedName "of" <* tokLBrace <*> parseSumCase `sepBy` tokSemi <* tokRBrace <*> pure Blank 415 | <|> SumVal <$ tokReservedName "value" <*> tokName <*> parseExp 11 <*> pure Blank 416 | <|> Interval <$ tokReservedName "Interval" 417 | <|> I0 <$ tokReservedName "0" 418 | <|> I1 <$ tokReservedName "1" 419 | <|> I01 <$ tokReservedName "01" 420 | <|> I10 <$ tokReservedName "10" 421 | <|> IFlip <$ guard (p <= 10) <* tokReservedName "iflip" <*> parseExp 11 422 | <|> IFlip <$ guard (p <= 10) <* tokReservedName "inot" <*> parseExp 11 423 | <|> IFlip <$ guard (p <= 11) <* tokTilde <*> parseExp 11 424 | <|> IAnd <$ guard (p <= 10) <* tokReservedName "iand" <*> parseExp 11 <*> parseExp 11 425 | <|> IV <$ guard (p <= 10) <* tokReservedName "iv" <*> parseExp 11 <*> parseExp 11 <*> parseExp 11 <*> parseExp 11 426 | <|> (\n x -> Refl (capture n x)) <$ guard (p <= 10) <*> tokRefl <*> parseExp 11 427 | <|> (\n x -> Eq (capture n x)) <$ guard (p <= 10) <*> tokEq <*> parseExp 11 <*> parseExp 11 <*> parseExp 11 428 | <|> (\n x -> Cast (capture n x)) <$ guard (p <= 10) <*> tokCast <*> parseExp 11 <*> parseExp 11 <*> parseExp 11 <*> parseExp 11 429 | <|> (\n x -> Cast (capture n x) I0 I1) <$ guard (p <= 10) <*> tokFw <*> parseExp 11 <*> parseExp 11 430 | <|> (\n x -> Cast (capture n x) I1 I0) <$ guard (p <= 10) <*> tokBw <*> parseExp 11 <*> parseExp 11 431 | <|> Free <$> parseNonOpName 432 | <|> Meta . TV.TV <$> tokMeta <*> parseMetaArgs 433 | "expression" 434 | 435 | {- 436 | parseMetaArgs :: Parser (IntMap Exp) 437 | parseMetaArgs 438 | = IM.fromList <$ tokLBracket <*> (parseMetaArg `sepBy` tokSemi) <* tokRBracket 439 | <|> return IM.empty 440 | where 441 | parseMetaArg :: Parser (Int,Exp) 442 | parseMetaArg = (,) <$> tokInt <* tokEquals <*> parseExp 0 443 | -} 444 | parseMetaArgs :: Parser (Seq Exp) 445 | parseMetaArgs 446 | = Seq.fromList <$ tokLBracket <*> (parseExp 0 `sepBy` tokSemi) <* tokRBracket 447 | <|> return Seq.empty 448 | 449 | parseExp :: Int -> Parser Exp 450 | parseExp p = do 451 | lhs <- parseExpPrim p 452 | go 12 lhs 453 | <|> do 454 | -- "{x:a} -> b" 455 | x <- tokLBrace *> parseExp 0 <* tokRBrace 456 | (op,po,pr) <- parseBinderOp Hidden 12 p 457 | y <- parseExp pr 458 | go po =<< op x y 459 | where 460 | go pcur x 461 | = do guard $ pcur >= 10 && p <= 10 462 | y <- tokLBrace *> parseExp 0 <* tokRBrace 463 | go 10 (AppH x y) 464 | <|> do (op,po,pr) <- parseOp pcur p 465 | y <- parseExp pr 466 | go po =<< op x y 467 | <|> return x 468 | 469 | 470 | parseNonOpName :: Parser Name 471 | parseNonOpName = (try $ do 472 | n <- tokName 473 | let opname = "_" ++ n ++ "_" 474 | case lookup opname infixNames of 475 | Just _ -> unexpected "operator" 476 | _ -> return n) 477 | "name" 478 | 479 | -- return (operator, precedence of lhs, precedence of result) 480 | -- guard that precedence of result >= pmin 481 | parseOp :: Int -> Int -> Parser (Exp -> Exp -> Parser Exp, Int, Int) 482 | parseOp pcur pmin = (try $ do 483 | op <- tokName 484 | let opname = "_" ++ op ++ "_" 485 | case lookup opname infixNames of 486 | Just (po,pl,pr) | pcur >= pl && pmin <= po -> 487 | return (\x y -> pure $ Free opname `AppV` x `AppV` y,po,pr) 488 | _ -> unexpected $ "operator " ++ show op) 489 | <|> do 490 | guard $ pcur >= 1 && pmin <= 0 491 | tokColon 492 | return ((\x y -> pure (mkTypeSig x y)), 1,0) 493 | <|> 494 | parseBinderOp Visible pcur pmin 495 | <|> do 496 | guard $ pcur >= 11 && pmin <= 11 497 | tokHat 498 | return ((\x y -> pure (IV Blank Blank x y)), 11, 12) 499 | <|> do 500 | guard $ pcur >= 5 && pmin <= 4 501 | tokDEquals 502 | return ((\x y -> pure (Eq (Bound "" Blank) x y)), 5, 4) 503 | <|> do 504 | guard $ pcur >= 7 && pmin <= 7 505 | tokAnd 506 | return ((\x y -> pure (IAnd x y)), 7, 8) 507 | <|> do 508 | guard $ pcur >= 6 && pmin <= 6 509 | tokOr 510 | return ((\x y -> pure (IOr x y)), 6, 7) 511 | <|> do 512 | guard $ pcur >= 10 && pmin <= 10 513 | return ((\x y -> pure (AppV x y)), 10, 11) 514 | 515 | parseBinderOp :: Hiding -> Int -> Int -> Parser (Exp -> Exp -> Parser Exp, Int, Int) 516 | parseBinderOp h pcur pmin = do 517 | guard $ pcur >= 2 && pmin <= 1 518 | tokArrow 519 | return (mkOpBinder PiB h, 2,1) 520 | <|> do 521 | guard $ pcur >= 3 && pmin <= 2 522 | tokProduct 523 | return (mkOpBinder SiB h, 3,2) 524 | <|> do 525 | guard $ pcur >= 4 && pmin <= 3 526 | tokThickArrow 527 | return (mkOpBinder LamB h, 4,3) 528 | <|> do 529 | guard $ pcur >= 3 && pmin <= 2 530 | tokComma 531 | return ((\x y -> pure (Pair h x y Blank)), 3,2) 532 | 533 | parseBinders :: Parser [NamedArg Exp] 534 | parseBinders = concat <$> many parseBinder 535 | parseBinder :: Parser [NamedArg Exp] 536 | parseBinder 537 | = map hidden <$ tokLBrace <*> parsePrimBinder <* tokRBrace 538 | <|> map visible <$ tokLParen <*> parsePrimBinder <* tokRParen 539 | <|> (\n -> [visible (named n Blank)]) <$> tokName 540 | where 541 | parsePrimBinder :: Parser [Named Exp] 542 | parsePrimBinder = 543 | (\ns t -> map (flip named t) ns) <$> many1 tokName <*> (tokColon *> parseExp 1 <|> pure Blank) 544 | 545 | -- Build a pi/sigma/lambda from operator notation. 546 | -- note: this is not quite correct, since 547 | -- (a b : foo a) -> c 548 | -- is interpreted as 549 | -- (a' : foo a) (b : foo a') -> c 550 | -- so a is captured in the type of b 551 | mkOpBinder :: Binder -> Hiding -> Exp -> Exp -> Parser Exp 552 | mkOpBinder binder h (TypeSig a b) c = do 553 | ns <- toNames a 554 | return $ foldr (\n v -> Binder binder (Arg h b) (capture n v)) c ns 555 | mkOpBinder binder h a c = return $ Binder binder (Arg h a) (notBound c) 556 | 557 | mkBinders :: Binder -> [NamedArg Exp] -> Exp -> Exp 558 | mkBinders binder args c = foldr bind c args 559 | where 560 | bind :: NamedArg Exp -> Exp -> Exp 561 | bind (Arg h (Named n b)) v = Binder binder (Arg h b) (capture n v) 562 | 563 | -- interpret an expression as a list of names 564 | toNames :: Exp -> Parser [Name] 565 | toNames (toName -> Just x) = return [x] 566 | toNames (AppV xs (toName -> Just x)) = (++ [x]) <$> toNames xs 567 | toNames x = fail $ showExp $ text "Left hand side of ':' should be a list of names, found" $/$ ppr 0 x 568 | 569 | toName :: Exp -> Maybe Name 570 | toName (Free x) = Just x 571 | toName _ = Nothing 572 | 573 | {- 574 | -- interpret an expression as a list of binders (x:a) (y:b).. 575 | toBinders :: Exp -> Parser [Name] 576 | toBinders (Free x) = return [x] 577 | toBinders (App xs (Free x)) = (++ [x]) <$> toNames xs 578 | toBinders x = failDoc $ text "Left hand side of ':' should be a list of names, found" $/$ ppr 0 x 579 | -} 580 | 581 | parseSumCtor :: Parser SumCtor 582 | parseSumCtor = SumCtor <$> tokName <* tokColon <*> parseExp 0 583 | 584 | parseSumCase :: Parser SumCase 585 | parseSumCase = do 586 | n <- tokName 587 | (m,x) <- (,) <$> tokName <*> pure Blank 588 | <|> (,) <$ tokLParen <*> tokName <* tokColon <*> parseExp 0 <* tokRParen 589 | tokArrow 590 | y <- parseExp 0 591 | return $ SumCase n x (capture m y) 592 | 593 | {- 594 | parseDecl :: Parser Decl 595 | parseDecl = do 596 | lhs <- parseExp 1 597 | id $ do tokColon 598 | names <- toNames lhs 599 | typ <- parseExp 0 600 | return $ DeclType names typ 601 | <|> do tokEquals 602 | rhs <- parseExp 0 603 | return $ Rule lhs rhs 604 | 605 | parseDecls :: Parser [Decl] 606 | parseDecls = withIndentation (many $ parseDecl0) <* tokWS <* eof 607 | where 608 | parseDecl0 = try (tokWS >> notIndented) >> withIndentation parseDecl 609 | -} 610 | 611 | -------------------------------------------------------------------------------- 612 | -- Testing 613 | -------------------------------------------------------------------------------- 614 | 615 | parseExpTop :: Parser Exp 616 | parseExpTop = (tokWS *> parseExp 0 <* eof) 617 | 618 | pe :: String -> Exp 619 | pe = testParser parseExpTop 620 | --pd :: String -> [Decl] 621 | --pd = testParser parseDecls 622 | 623 | -------------------------------------------------------------------------------- /src/TcMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | module TcMonad where 7 | 8 | import Prelude () 9 | import Util.MyPrelude 10 | import Util.PrettyM 11 | import qualified Util.Tagged.Seq as TS 12 | import qualified Util.Tagged.Map as TM 13 | import Names 14 | import Substitution 15 | import Syntax 16 | 17 | import qualified Data.Sequence as Seq 18 | import qualified Data.Map as Map 19 | 20 | -------------------------------------------------------------------------------- 21 | -- Typechecking/evaluation context 22 | -------------------------------------------------------------------------------- 23 | 24 | -- types for all free variables 25 | data TcCtx = TcCtx 26 | { ctxVarType :: Seq (Named Exp) -- name and type of bound variables 27 | --, ctxFreeType :: Map Name Exp -- types of free values 28 | , ctxDecls :: Map Name Decl 29 | --, ctxUsedNames :: Set String -- all names of bound variables 30 | } 31 | 32 | emptyCtx :: TcCtx 33 | emptyCtx = TcCtx 34 | { ctxVarType = Seq.empty 35 | , ctxDecls = Map.empty 36 | } 37 | 38 | pushCtx :: Named Exp -> TcCtx -> TcCtx 39 | pushCtx typ ctx = ctx 40 | { ctxVarType = typ <| ctxVarType ctx 41 | } 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Unification state 45 | -------------------------------------------------------------------------------- 46 | 47 | data UnificationState = UnificationState 48 | { usMetas :: TS.TaggedSeq "meta" MetaValue 49 | , usLevelMetas :: TS.TaggedSeq "level-meta" (Maybe Level) 50 | } 51 | 52 | data MetaValue = MVExp 53 | { mvValue :: Maybe Exp 54 | , mvType :: Exp 55 | , mvArgs :: Seq (Named Exp) -- name and type of 'bound variables' 56 | } 57 | 58 | emptyUS :: UnificationState 59 | emptyUS = UnificationState 60 | { usMetas = TS.empty 61 | , usLevelMetas = TS.empty 62 | } 63 | 64 | modifyUsMetas :: (TS.TaggedSeq "meta" MetaValue -> TS.TaggedSeq "meta" MetaValue) 65 | -> UnificationState -> UnificationState 66 | modifyUsMetas f us = us { usMetas = f (usMetas us) } 67 | 68 | modifyUsLevelMetas :: (TS.TaggedSeq "level-meta" (Maybe Level) -> TS.TaggedSeq "level-meta" (Maybe Level)) 69 | -> UnificationState -> UnificationState 70 | modifyUsLevelMetas f us = us { usLevelMetas = f (usLevelMetas us) } 71 | 72 | metaUnresolved :: MetaValue -> Bool 73 | metaUnresolved = isNothing . mvValue 74 | 75 | -------------------------------------------------------------------------------- 76 | -- Monad 77 | -------------------------------------------------------------------------------- 78 | 79 | newtype TcM a = TcM { unTcM :: ReaderT TcCtx (ExceptT Doc (State UnificationState)) a } 80 | deriving (Functor, Applicative, Monad, MonadError Doc) 81 | 82 | instance MonadBound Exp TcM where 83 | localBound ty = TcM . local (pushCtx ty) . unTcM 84 | -- use the transformed type information in traverseBinder. 85 | traverseBinder f g h x y = g x >>= \x' -> f x' <$> traverseBound x' h y 86 | 87 | instance MonadBoundNames TcM where 88 | boundNames = map namedName <$> boundTypes 89 | 90 | instance MonadBoundTypes Exp TcM where 91 | boundTypes = TcM $ asks ctxVarType 92 | 93 | runTcM :: TcCtx -> TcM a -> Either Doc a 94 | runTcM ctx = flip evalState emptyUS . runExceptT . flip runReaderT ctx . unTcM 95 | 96 | -- | Replace the context of bound variables 97 | withCtx :: Seq (Named Exp) -> TcM a -> TcM a 98 | withCtx bound = TcM . local (\ctx -> ctx{ctxVarType = bound}) . unTcM 99 | 100 | -------------------------------------------------------------------------------- 101 | -- Variables 102 | -------------------------------------------------------------------------------- 103 | 104 | -- Name and type of bound variable 105 | boundType :: Int -> TcM (Named Exp) 106 | boundType i = do 107 | tys <- boundTypes 108 | if 0 <= i && i < Seq.length tys 109 | then return $ map (raiseBy (i+1)) $ Seq.index tys i 110 | else throwError =<< text "Variable not bound:" <+> int i 111 | 112 | freeType :: Name -> TcM Exp 113 | freeType n = do 114 | mty <- TcM $ asks $ Map.lookup n . ctxDecls 115 | case mty of 116 | Nothing -> throwError =<< text "Free variable has no type:" <+> text n 117 | Just ty -> return (declType ty) 118 | 119 | freeValues :: TcM (Name -> Maybe Exp) 120 | freeValues = do 121 | TcM $ asks $ \st n -> declTryValue =<< Map.lookup n (ctxDecls st) 122 | 123 | -------------------------------------------------------------------------------- 124 | -- Error utilities 125 | -------------------------------------------------------------------------------- 126 | 127 | tcError :: Doc -> TcM a 128 | tcError err = throwError =<< pure err $$ dumpCtx $$ dumpMetas 129 | 130 | dumpCtx :: TcM Doc 131 | dumpCtx = text "With variables:" $$ indent 2 (vcat . toList . Seq.mapWithIndex pvar =<< boundTypes) 132 | where 133 | pvar i (Named n ty) = text n <.> text "#" <.> int i <+> text ":" <+> tcPpr 0 (raiseBy (i+1) ty) 134 | 135 | dumpMetas :: TcM Doc 136 | dumpMetas = do 137 | metas <- filter (metaUnresolved . snd) <$> getAllMetas 138 | case metas of 139 | [] -> emptyDoc 140 | ms -> text "With metas:" $$ indent 2 (vcat $ map (uncurry pprMeta) ms) 141 | 142 | dumpAllMetas :: TcM Doc 143 | dumpAllMetas = 144 | text "With metas:" $$ indent 2 (vcat . map (uncurry pprMeta) =<< getAllMetas) $$ 145 | text "With level metas:" $$ indent 2 (vcat . map (uncurry pprLevelMeta) =<< getAllLevelMetas) 146 | 147 | infix 1 `annError` 148 | annError :: (Applicative m, MonadError Doc m) => m a -> m Doc -> m a 149 | annError x y = catchError x $ \err -> do 150 | ann <- catchError y (const $ throwError err) 151 | throwError =<< pure err $$ pure ann 152 | 153 | class EvalAllMetas a where 154 | evalAllMetas :: a -> TcM a 155 | evalAllMetasThrow :: a -> TcM a 156 | evalAllMetasWith :: (TcM Doc -> TcM ()) -> a -> TcM a 157 | evalAllMetas = evalAllMetasWith (\_ -> return ()) 158 | evalAllMetasThrow = evalAllMetasWith (\msg -> throwError =<< msg) 159 | 160 | instance (EvalAllMetas a) => EvalAllMetas [a] where 161 | evalAllMetasWith f = traverse (evalAllMetasWith f) 162 | instance (EvalAllMetas a, EvalAllMetas b) => EvalAllMetas (a,b) where 163 | evalAllMetasWith f = traversePair (evalAllMetasWith f) (evalAllMetasWith f) 164 | instance EvalAllMetas Doc where 165 | evalAllMetasWith _ = pure 166 | instance EvalAllMetas () where 167 | evalAllMetasWith _ = pure 168 | 169 | tcPpr :: (EvalAllMetas a, Pretty TcM a) => Int -> a -> TcM Doc 170 | tcPpr i x = ppr i =<< evalAllMetas x 171 | 172 | pprMeta :: MetaVar -> MetaValue -> TcM Doc 173 | pprMeta mv (MVExp val ty args) = ppr 0 mv <+> align (withCtx Seq.empty (go (toList $ Seq.reverse args))) 174 | where 175 | go [] = case val of 176 | Nothing -> text ":" <+> tcPpr 0 ty 177 | Just v -> text ":" <+> tcPpr 0 ty <+> text "=" <+> ppr 0 v 178 | go (x:xs) = group $ ppr 11 x $$ localBound x (go xs) 179 | 180 | pprLevelMeta :: LevelMetaVar -> Maybe Level -> TcM Doc 181 | pprLevelMeta mv (Nothing) = ppr 0 mv <+> text ": Level" 182 | pprLevelMeta mv (Just v) = ppr 0 mv <+> text "=" <+> ppr 0 v <+> text "=" <+> (ppr 0 =<< evalLevel v) 183 | 184 | -------------------------------------------------------------------------------- 185 | -- Getting/setting/adding MetaVars and LevelMetaVars 186 | -------------------------------------------------------------------------------- 187 | 188 | freshMetaVar :: MetaValue -> TcM MetaVar 189 | freshMetaVar value = TcM $ do 190 | (mv,usm') <- gets $ TS.insertNew value . usMetas 191 | modify $ modifyUsMetas $ const usm' 192 | return mv 193 | 194 | freshLevelMetaVar :: TcM LevelMetaVar 195 | freshLevelMetaVar = TcM $ do 196 | (mv,usm') <- gets $ TS.insertNew Nothing . usLevelMetas 197 | modify $ modifyUsLevelMetas $ const usm' 198 | return mv 199 | 200 | freshMeta :: Exp -> TcM Exp 201 | freshMeta ty = do 202 | boundTys <- TcM $ asks $ ctxVarType 203 | mv <- freshMetaVar (MVExp Nothing ty boundTys) 204 | let args = Seq.fromList $ map Var [0..Seq.length boundTys-1] 205 | return (Meta mv args) 206 | 207 | freshMetaLevel :: TcM Level 208 | freshMetaLevel = metaLevel <$> freshLevelMetaVar 209 | 210 | -- a fresh meta x : Set _ 211 | freshMetaSet :: TcM Exp 212 | freshMetaSet = freshMeta . Set =<< freshMetaLevel 213 | 214 | -- a fresh meta x : _ : Set _ 215 | freshMetaAny :: TcM Exp 216 | freshMetaAny = freshMeta =<< freshMetaSet 217 | 218 | getMetaVar :: MetaVar -> TcM MetaValue 219 | getMetaVar mv = TcM $ gets $ TS.get mv . usMetas 220 | 221 | modifyMetaVar :: MetaVar -> (MetaValue -> MetaValue) -> TcM () 222 | modifyMetaVar mv f = TcM $ modify $ modifyUsMetas $ TS.modify f mv 223 | 224 | putMetaVar :: MetaVar -> MetaValue -> TcM () 225 | putMetaVar mv x = modifyMetaVar mv (const x) 226 | 227 | getLevelMetaVar :: LevelMetaVar -> TcM (Maybe Level) 228 | getLevelMetaVar mv = TcM $ gets $ TS.get mv . usLevelMetas 229 | 230 | modifyLevelMetaVar :: LevelMetaVar -> (Maybe Level -> Maybe Level) -> TcM () 231 | modifyLevelMetaVar mv f = TcM $ modify $ modifyUsLevelMetas $ TS.modify f mv 232 | 233 | putLevelMetaVar :: LevelMetaVar -> Maybe Level -> TcM () 234 | putLevelMetaVar mv x = modifyLevelMetaVar mv (const x) 235 | 236 | getAllMetas :: TcM [(MetaVar,MetaValue)] 237 | getAllMetas = TcM $ gets $ TS.toList . usMetas 238 | 239 | getAllLevelMetas :: TcM [(LevelMetaVar,Maybe Level)] 240 | getAllLevelMetas = TcM $ gets $ TS.toList . usLevelMetas 241 | 242 | -- | Perform a function in the context of a metaValue 243 | withMetaContext :: MetaVar -> TcM a -> TcM a 244 | withMetaContext mv x = do 245 | args <- mvArgs <$> getMetaVar mv 246 | withCtx args x 247 | 248 | -------------------------------------------------------------------------------- 249 | -- Expanding metas 250 | -------------------------------------------------------------------------------- 251 | 252 | metaType :: MetaVar -> Seq Exp -> TcM Exp 253 | metaType mv args = substsN args . mvType <$> getMetaVar mv 254 | 255 | metaValue :: MetaVar -> Seq Exp -> TcM (Maybe Exp) 256 | metaValue mv args = fmap (substsN args) . mvValue <$> getMetaVar mv 257 | 258 | metaValues :: TcM (MetaVar -> Seq Exp -> Maybe Exp) 259 | metaValues = do 260 | TcM $ gets $ \st mv args -> fmap (substsN args) . mvValue $ TS.get mv (usMetas st) 261 | 262 | -- Evaluate metas at the top 263 | evalMetas :: Exp -> TcM Exp 264 | evalMetas x@(Meta mv args) = do 265 | mx' <- metaValue mv args 266 | case mx' of 267 | Nothing -> pure x 268 | Just x' -> evalMetas x' 269 | evalMetas x = pure x 270 | 271 | -- Evaluate all metas, give an error for unresolved ones 272 | evalAllExpMetas :: (TcM Doc -> TcM ()) -> Exp -> TcM Exp 273 | evalAllExpMetas err (Meta mv args) = do 274 | x' <- metaValue mv args 275 | case x' of 276 | Nothing -> do err (text "Unresolved meta:" <+> tcPpr 0 (Meta mv args) 277 | $$ text "of type" <+> (tcPpr 0 =<< metaType mv args)) 278 | Meta mv <$> traverse (evalAllExpMetas err) args 279 | Just x'' -> evalAllExpMetas err x'' 280 | evalAllExpMetas err (Set i) = Set <$> evalLevelWith err i 281 | evalAllExpMetas err x = traverseChildren (evalAllExpMetas err) x 282 | 283 | instance EvalAllMetas Exp where 284 | evalAllMetasWith = evalAllExpMetas 285 | 286 | -------------------------------------------------------------------------------- 287 | -- Expand metas in levels 288 | -------------------------------------------------------------------------------- 289 | 290 | evalLevel :: Level -> TcM Level 291 | evalLevel = evalLevelWith (const $ return ()) 292 | 293 | evalLevelWith :: (TcM Doc -> TcM ()) -> Level -> TcM Level 294 | evalLevelWith _ x@(IntLevel _) = pure x 295 | evalLevelWith err (Level i j) = do 296 | lvl'@(Level _ j') <- foldr maxLevel (intLevel i) <$> mapM evalLevelVar (TM.toList j) 297 | unless (TM.null j') $ do 298 | err (traceM "unresolved level" >> text "Unresolved level metas in" <+> ppr 0 lvl') 299 | return lvl' 300 | 301 | evalLevelVar :: (LevelMetaVar, Int) -> TcM Level 302 | evalLevelVar (mv,add) = do 303 | l <- getLevelMetaVar mv 304 | case l of 305 | Nothing -> return $ addLevel add (metaLevel mv) 306 | Just l' -> addLevel add <$> evalLevel l' 307 | 308 | instance EvalAllMetas Level where 309 | evalAllMetasWith = evalLevelWith 310 | 311 | -------------------------------------------------------------------------------- 312 | -- Expand metas in ctors and cases 313 | -------------------------------------------------------------------------------- 314 | 315 | instance EvalAllMetas SumCtor where 316 | evalAllMetasWith err (SumCtor n x) = SumCtor n <$> evalAllMetasWith err x 317 | 318 | -------------------------------------------------------------------------------- /src/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE DefaultSignatures, MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | module Main where 7 | 8 | import Prelude () 9 | import Util.MyPrelude 10 | import Util.PrettyM 11 | import Util.Parser 12 | import Syntax 13 | import Substitution 14 | import Names 15 | import TcMonad 16 | import Typing 17 | import Eval 18 | 19 | import qualified Data.Map as Map 20 | import Data.Typeable 21 | import Data.String 22 | import Data.List (isPrefixOf) 23 | 24 | import Test.Tasty 25 | import Test.Tasty.Providers 26 | import qualified Control.Exception as E 27 | import System.IO 28 | 29 | -------------------------------------------------------------------------------- 30 | -- Environment with some names 31 | -------------------------------------------------------------------------------- 32 | 33 | testDecls :: Map Name Decl 34 | testDecls = Map.fromList 35 | [("A", Postulate $ pe "Set") 36 | ,("B", Postulate $ pe "Set") 37 | ,("x", Postulate $ pe "A") 38 | ,("y", Postulate $ pe "A") 39 | ,("xy", Postulate $ pe "Eq A x y") 40 | ,("f", Postulate $ pe "A -> B") 41 | ,("B'", Postulate $ pe "A -> Set") 42 | ,("f'", Postulate $ pe "(x:A) -> B' x") 43 | ,("ab", Postulate $ pe "Eq Set A B") 44 | ,("Nat", Postulate $ pe "Set") 45 | ,("zero", Postulate $ pe "Nat") 46 | ,("suc", Postulate $ pe "Nat -> Nat") 47 | ] 48 | -- "Nat", pe "Set", pe "x:data{zero;suc} * case x of {zero -> data{unit}; suc -> Nat}" 49 | -- "Nat", pe "Set", pe "data{zero:Unit;suc:Nat}" 50 | -- "zero", , pe "con{zero}" 51 | 52 | testCtx :: TcCtx 53 | testCtx = emptyCtx 54 | { ctxDecls = testDecls 55 | } 56 | 57 | -------------------------------------------------------------------------------- 58 | -- Expressions to test 59 | -------------------------------------------------------------------------------- 60 | 61 | -- expressions that should typecheck 62 | goodExpressions :: [String] 63 | goodExpressions = 64 | ["\\(x:A). x" 65 | ,"proj1 (x,y)" 66 | ,"proj2 (x,y)" 67 | ,"f x" 68 | ,"{A B C : Set} -> (B -> C) -> (A -> B) -> (A -> C)" 69 | ,"(\\{A} x -> x) : {A : Set} -> (A -> A)" 70 | ,"(\\{A} {B} f x -> f x) : {A B : Set} -> (A -> B) -> (A -> B)" 71 | ,"(\\{A} {B} {C} f g x -> f (g x)) : {A B C : Set} -> (B -> C) -> (A -> B) -> (A -> C)" 72 | ,"(\\f g x -> f (g x)) : {A B C : Set} -> (B -> C) -> (A -> B) -> (A -> C)" 73 | ,"refl (x,x)" 74 | ,"01" 75 | ,"refl_i (\\(x:(refl Nat)^i) -> x)" 76 | ,"proj2 ({x} , x , f) x" 77 | -- sums 78 | ,"data{zero:Unit; suc:Nat}" 79 | ,"(\\x -> case x of {zero _ -> zero; suc x -> x}) : data{zero:Unit; suc:Nat} -> Nat" 80 | ,"refl _ : Eq _ x (case value left tt of {left _ -> x; right (_:Unit) -> y})" 81 | ,"(\\x -> case x of {}) : data{} -> {A : Set} -> A" 82 | ,"(\\ft -> fw_i (case ft^i of {false _ -> Unit; true _ -> data{}}) tt)" 83 | ++": Eq data{false:Unit;true:Unit} (value false tt) (value true tt) -> data{}" -- false /= true 84 | -- type inference 85 | ,"((\\{A:Type} (x : A) -> x) (tt,tt)) : Unit * Unit" 86 | ,"((\\{A:Type} x -> value wrap x : data{wrap:A}) (tt,tt)) : data {wrap : Unit * Unit}" 87 | ,"Unit : _ : _ : _ : _ : _ : _" 88 | -- OTT 89 | {- 90 | ,"proj1 (refl (x,y))" 91 | ,"(refl f') {_} {_} (refl x)" 92 | ,"(refl f') xy" 93 | ,"(\\x y -> tt) : (x y : Unit) -> Eq _ x y" 94 | -} 95 | ,"(\\xx' -> refl_i (f xx'^i)) : forall {x x'}. Eq A x x' -> Eq _ (f x) (f x')" 96 | -- and 97 | -- casts 98 | ,"{-subst-} (\\P xy px -> fw_i (P xy^i) px)" 99 | ++": {A : Set} -> (P : A -> Set) -> {x y : A} -> Eq _ x y -> P x -> P y" 100 | ,"{-bw-fw-} (\\x -> refl_i (cast_j ab^j i 0 (cast_j ab^j 0 i x)))" 101 | ++" : forall x. Eq _ x (bw_i ab^i (fw_i ab^i x))" 102 | ,"{-eq-fw-} (\\x -> refl_i (cast_j ab^j 0 i x))" 103 | ++" : forall x. Eq_i ab^i x (fw_i ab^i x)" 104 | --,"{-jay-} (\\{A} {x} P xy px -> fw_i (P xy^i (cast_j (Eq _ x xy^j) 0 i (refl x))) px)" 105 | -- ++" : {A : Set} -> {x : A} -> (P : (y : A) -> Eq A x y -> Set) -> {y : A} -> (xy : Eq A x y) -> P x (refl x) -> P y xy" 106 | --,"{-jay-inline-} \\{A : Set} {x} (P : (y : A) -> Eq A x y -> Set) {y} (xy : Eq A x y) px ->\ 107 | -- \ fw_i (P xy^i (cast_j (Eq A x xy^j) 0 i (refl x))) px : P y xy" 108 | --,"{-jay-alt-} \\{A : Set} {x} (P : (y : A) -> Eq A x y -> Set) {y} (xy : Eq A x y) px ->\ 109 | -- \ fw_i (P xy^i (cast_j (Eq A xy^j xy^i) i 0 (refl xy^i))) px : P y xy" 110 | ,"{-jay-and-} \\{A : Set} {x} (P : (y : A) -> Eq A x y -> Set) {y} (xy : Eq A x y) px ->\ 111 | \ fw_i (P xy^i (refl_j xy^(iand i j))) px : P y xy" 112 | --,"{-jay-and2-} \\{A : Set} {x} (P : (y : A) -> Eq A x y -> Set) {y} (xy : Eq A x y) px ->\ 113 | -- \ fw_i (P xy^i (refl_j xy^((cast_j (Eq Interval 0 j) 0 j (refl 0))^i))) px : P y xy" 114 | --,"{-jay-and2b-} \\{A : Set} {x} (P : (y : A) -> Eq A x y -> Set) {y} (xy : Eq A x y) px ->\ 115 | -- \ fw_i (P xy^i (refl_j xy^((cast_j (Eq Interval 0 j) 1 j (refl_j j))^i))) px : P y xy" 116 | --,"{-jay-and3-} \\{A : Set} {x} (P : (y : A) -> Eq A x y -> Set) {y} (xy : Eq A x y) px ->\ 117 | -- \ fw_i (P xy^i (refl_j xy^((cast_j (Eq Interval 0 j) 0 i (refl 0))^j))) px : P y xy" 118 | --,"{-jay-and3b-} \\{A : Set} {x} (P : (y : A) -> Eq A x y -> Set) {y} (xy : Eq A x y) px ->\ 119 | -- \ fw_i (P xy^i (refl_j xy^((cast_j (Eq Interval 0 j) 1 i (refl_i i))^j))) px : P y xy" 120 | -- equivalence to OTT style 121 | ,"{-ott-app-} \\{A : Interval -> Set} {B : forall i. A i -> Set} {f : (x : A 0) -> B 0 x} {g : (x : A 1) -> B 1 x} -> (\ 122 | \(\\fg x12 -> refl_i (fg^i x12^i))\ 123 | \: Eq_i ((x : A i) -> B i x) f g -> (forall {x1 x2} (x12 : Eq_i (A i) x1 x2) -> Eq_i (B i x12^i) (f x1) (g x2)))" 124 | ,"{-ott-lam-} \\{A : Interval -> Set} {B : forall i. A i -> Set} {f : (x : A 0) -> B 0 x} {g : (x : A 1) -> B 1 x} -> (\ 125 | \(\\fg -> refl_i (\\x -> (fg {cast_k (A k) i 0 x} {cast_k (A k) i 1 x} (refl_j (cast_k (A k) i j x)))^i))\ 126 | \: (forall {x1 x2} (x12 : Eq_i (A i) x1 x2) -> Eq_i (B i x12^i) (f x1) (g x2)) -> Eq_i ((x : A i) -> B i x) f g)" 127 | {-,"{-ott-lam2-} \\{A : Interval -> Set} {B : forall i. A i -> Set} {f : (x : A 0) -> B 0 x} {g : (x : A 1) -> B 1 x} -> (\ 128 | \(\\fg -> refl_i (\\x -> (fg {cast_k (A k) i 0 x} {cast_k (A k) i 1 x}\ 129 | \ (cast_k (Eq_i (A (iand i k)) (cast_l (A l) i 0 x) \ 130 | \ (cast_l (A l) i k x)) \ 131 | \ 0 1 (refl (cast_l (A l) i 0 x)) ) \ 132 | \)^i))\ 133 | \: (forall {x1 x2} (x12 : Eq_i (A i) x1 x2) -> Eq_i (B i x12^i) (f x1) (g x2)) -> Eq_i ((x : A i) -> B i x) f g)"-} 134 | -- type checking of evaluation steps 135 | ,"forall (A : _ -> Set) j x. Eq _ (cast_i (A i) j j x) x" 136 | ,"{-ty-cast-pair-} \\(A : _ -> Set) (B : ∀ {x}. A x -> Set) j1 j2 xy. \ 137 | \ (cast_i ((x:A i) * B x) j1 j2 xy : (x:A j2)*B x)" 138 | ,"{-ty-cast-fun-} \\(A : _ -> Set) (B : ∀ {x}. A x -> Set) j1 j2 xy. \ 139 | \ (cast_i ((x:A i) -> B x) j1 j2 xy : (x:A j2)->B x)" 140 | ,"{-ty-cast-eq-pair-} \ 141 | \\\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v j1 j2 (xy : Eq_j ((x:A j1 j)*B x) (u j1) (v j1)). \ 142 | \ (cast_i (Eq_j ((x:A i j)*B x) (u i) (v i)) j1 j2 xy : Eq_j ((x:A j2 j)*B x) (u j2) (v j2))" 143 | ,"{-ty-cast-eq-fun-} \ 144 | \\\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v j1 j2 (xy : Eq_j ((x:A j1 j)->B x) (u j1) (v j1)). \ 145 | \ (cast_i (Eq_j ((x:A i j)->B x) (u i) (v i)) j1 j2 xy : Eq_j ((x:A j2 j)->B x) (u j2) (v j2))" 146 | ,"{-ty-cast-eq-eq-pair-} \ 147 | \\\(A : _ -> _ -> _ -> Set) (B : ∀ {i j k}. A i j k -> Set) u v p q j1 j2 \ 148 | \ (xy : Eq_j (Eq_k ((x:A j1 j k)*B x) (u j1 j) (v j1 j)) (p j1) (q j1)). \ 149 | \ (cast_i (Eq_j (Eq_k ((x:A i j k)*B x) (u i j) (v i j)) (p i) (q i)) j1 j2 xy \ 150 | \ : Eq_j (Eq_k ((x:A j2 j k)*B x) (u j2 j) (v j2 j)) (p j2) (q j2))" 151 | ,"{-ty-cast-eq-eq-fun-} \ 152 | \\\(A : _ -> _ -> _ -> Set) (B : ∀ {i j k}. A i j k -> Set) u v p q j1 j2 \ 153 | \ (xy : Eq_j (Eq_k ((x:A j1 j k)->B x) (u j1 j) (v j1 j)) (p j1) (q j1)). \ 154 | \ (cast_i (Eq_j (Eq_k ((x:A i j k)->B x) (u i j) (v i j)) (p i) (q i)) j1 j2 xy \ 155 | \ : Eq_j (Eq_k ((x:A j2 j k)->B x) (u j2 j) (v j2 j)) (p j2) (q j2))" 156 | -- implementation of casts 157 | ,"{-cast-pair-} \\(A : _ -> Set) (B : ∀ {x}. A x -> Set) j1 j2 xy. \ 158 | \ refl _ : Eq ((x:A j2)*B x) \ 159 | \ (cast_i ((x:A i) * B x) j1 j2 xy) \ 160 | \ (cast_i (A i) j1 j2 (proj1 xy)\ 161 | \ ,cast_i (B {i} (cast_i' (A i') j1 i (proj1 xy))) j1 j2 (proj2 xy))" 162 | ,"{-cast-fun-} \\(A : _ -> Set) (B : ∀ {x}. A x -> Set) j1 j2 xy. \ 163 | \ refl _ : Eq ((x:A j2) -> B x) \ 164 | \ (cast_i ((x:A i) -> B x) j1 j2 xy) \ 165 | \ (\\(x:A j2) -> cast_i (B {i} (cast_i (A i) j2 i x)) j1 j2 (xy (cast_i (A i) j2 j1 x)) )" 166 | ,"{-cast-eq-pair-} \\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v j1 j2 (xy : Eq_j ((x:A j1 j)*B x) (u j1) (v j1)). \ 167 | \ refl _ : Eq (Eq_j ((x:A j2 j)*B x) (u j2) (v j2)) \ 168 | \ (cast_i (Eq_j ((x:A i j)*B x) (u i) (v i)) j1 j2 xy) \ 169 | \ (refl_j ((cast_i (Eq_j (A i j) (proj1 (u i)) (proj1 (v i))) j1 j2 (refl_j (proj1 xy^j)))^j \ 170 | \ ,(cast_i (Eq_j (B {i} {j} \ 171 | \ (cast_i (Eq_j (A i j) (proj1 (u i)) (proj1 (v i))) j1 i (refl_j (proj1 xy^j)))^j) \ 172 | \ (proj2 (u i)) (proj2 (v i))) j1 j2 (refl_j (proj2 xy^j)))^j : (x:A j2 j)*B x))" 173 | -- cast (Eq (A*B)) 174 | {-,"\\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v j1 j2 (xy : Eq_j ((x:A j1 j)*B x) (u j1) (v j1)). \ 175 | \refl_j (iv (proj1 (u j2)) (proj1 (v j2)) \ 176 | \ (cast_i (Eq_j (A i j) (proj1 (u i)) (proj1 (v i))) j1 j2 (refl_j (proj1 (iv (u j1) (v j1) xy j)))) \ 177 | \ j, \ 178 | \ iv _ _ (cast_i (Eq_j (B {i} {j} (iv _ _ (cast_i (Eq_j (A i j) (proj1 (u i)) (proj1 (v i))) j1 i (refl_j (proj1 (iv (u j1) (v j1) xy j)))) j)) (proj2 (u i)) (proj2 (v i))) j1 j2 (refl_j (proj2 (iv (u j1) (v j1) xy j)))) j : (x:A j2 j) * B x)"-} 179 | ,"\\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v j1 j2 (xy : Eq_j ((x:A j1 j)*B x) (u j1) (v j1)). \ 180 | \refl_j ((cast_i (Eq_j (A i j) (proj1 (u i)) (proj1 (v i))) j1 j2 (refl_j (proj1 xy^j)))^j \ 181 | \ ,(cast_i (Eq_j (B {i} {j} \ 182 | \ (cast_i (Eq_j (A i j) (proj1 (u i)) (proj1 (v i))) j1 i (refl_j (proj1 xy^j)))^j) \ 183 | \ (proj2 (u i)) (proj2 (v i))) j1 j2 (refl_j (proj2 xy^j)))^j : (x:A j2 j) * B x)" 184 | {-,"\\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v j1 j2 (xy : Eq_j ((x:A j1 j)*B x) (u j1) (v j1)). \ 185 | \refl_j (cast_i (A i j) j1 j2 (proj1 (iv (u j1) (v j1) xy j))), \ 186 | \refl_j (iv _ _ (cast_i (Eq_j (A i j) (proj1 (u i)) (proj1 (v i))) j1 j2 (refl_j (proj1 (iv (u j1) (v j1) xy j)))) j)" 187 | 188 | ,"{-si-eq-}\\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v j1 j2 (xy : Eq_j ((x:A j1 j)*B x) (u j1) (v j1)). \ 189 | \refl_j ((cast_i (Eq_j (A i j) (proj1 (u i)) (proj1 (v i))) j1 j2 (refl_j (proj1 xy^j)))^j),\ 190 | \refl_j (cast_i (A i j) j1 j2 (proj1 xy^j)),\ 191 | \refl_j (cast_i (Eq_k (A i k) (cast_i (A i 0) j1 i (cast_j (A j1 j) j 0 (proj1 xy^j))) \ 192 | \ (cast_i (A i 1) j1 i (cast_j (A j1 j) j 1 (proj1 xy^j)))) j1 j2 \ 193 | \ (refl_k (cast_j (A j1 j) j k (proj1 xy^j))))^j,\ 194 | \refl_j (cast_i (Eq_k (A i k) (proj1 (u i)) \ 195 | \ (proj1 (v i))) j1 j2 \ 196 | \ (refl_k (cast_j (A j1 j) j k (proj1 xy^j))))^j,\ 197 | \refl_j (cast_i (Eq_k (A i k) (cast_i (A i 0) j1 i (proj1 xy^0)) \ 198 | \ (cast_i (A i 1) j1 i (proj1 xy^1))) j1 j2 \ 199 | \ (refl_k (proj1 xy^k)) )^j" 200 | -} 201 | -- cast (Eq (A->B)) 202 | ,"{-ar-eq-}\\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v j1 j2 (xy : Eq_j ((x:A j1 j)->B x) (u j1) (v j1)). \ 203 | \ refl_j (\\(x:A j2 j) -> cast_i (B {i} {j} (cast_i (A i j) j2 i x)) j1 j2 (xy^j (cast_i (A i j) j2 j1 x)) ), \ 204 | \ refl_j (\\(x:A j2 j) -> xy^j (cast_i (A i j) j2 j1 x) ), \ 205 | \ refl_j (\\(x:A j2 j) -> refl_k (cast_j (A j2 j) j k x) ){-, \ 206 | \ refl_j (\\(x:A j2 j) -> cast_i (Eq_j (A i j) (cast_j (A i j) j2 0 x) (cast_j (A i j) j2 0 x)) j2 j1 (refl_k (cast_k (A j2 j) j k x)) )-}" 207 | {-,"{-ar-ty-} \\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) (j1 j2 j : Interval) x. \ 208 | \\\(y : B {j1} {j} (cast_i (A i j) j2 j1 x)) -> \ 209 | \ cast_i (B {i} {j} (cast_i (A i j) j2 i x)) j1 j2 y" 210 | ,"{-ar-ott1-} \\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v (j1 j2 : Interval) (xy : Eq_j ((x:A j1 j)->B x) (u j1) (v j1)). \ 211 | \\\{x1} {x2} (x12 : Eq_j (A j1 j) (cast_i (A i 0) j2 j1 x1) (cast_i (A i 1) j2 j1 x2)) -> refl_i (xy^i x12^i)" 212 | ,"{-ar-ott2-} \\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v (j1 j2 : Interval) (xy : Eq_j ((x:A j1 j)->B x) (u j1) (v j1)). \ 213 | \\\{x1 : A j2 0} {x2 : A j2 1} (x12 : Eq_j (A j2 j) (cast_i (A i 0) j2 j2 x1) (cast_i (A i 1) j2 j2 x2)) -> \ 214 | \ refl_i (xy^i (cast_i (Eq_j (A i j) (cast_i (A i 0) j2 i x1) (cast_i (A i 1) j2 i x2)) j2 j1 x12)^i)" 215 | ,"{-ar-ott3-} \\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v (j1 j2 : Interval) (xy : Eq_j ((x:A j1 j)->B x) (u j1) (v j1)). \ 216 | \\\{x1 : A j2 0} {x2 : A j2 1} (x12 : Eq_j (A j2 j) (cast_i (A i 0) j2 j2 x1) (cast_i (A i 1) j2 j2 x2)) -> \ 217 | \ cast_k (Eq_j \ 218 | \ (B {k} {j} \ 219 | \ (iv (cast_i (A i 0) j2 k x1) (cast_i (A i 1) j2 k x2) \ 220 | \ (cast_i (Eq_j (A i j) (cast_i (A i 0) j2 i x1) (cast_i (A i 1) j2 i x2)) j2 k x12) \ 221 | \ j)) \ 222 | \ (u k (cast_i (A i 0) j2 k x1)) \ 223 | \ (v k (cast_i (A i 1) j2 k x2))) \ 224 | \ j1 j2 \ 225 | \ (refl_j (xy^j (cast_i (Eq_j (A i j) (cast_i (A i 0) j2 i x1) (cast_i (A i 1) j2 i x2)) j2 j1 x12)^j))" 226 | ,"{-ar-ott4-} \\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v (j1 j2 : Interval) (xy : Eq_j ((x:A j1 j)->B x) (u j1) (v j1)). \ 227 | \ refl_0 (\\x -> \ 228 | \ ((\\{x1 : A j2 0} {x2 : A j2 1} (x12 : Eq_j (A j2 j) (cast_i (A i 0) j2 j2 x1) (cast_i (A i 1) j2 j2 x2)) -> \ 229 | \ cast_k (Eq_j \ 230 | \ (B {k} {j} \ 231 | \ (iv (cast_i (A i 0) j2 k x1) (cast_i (A i 1) j2 k x2) \ 232 | \ (cast_i (Eq_j (A i j) (cast_i (A i 0) j2 i x1) (cast_i (A i 1) j2 i x2)) j2 k x12) \ 233 | \ j)) \ 234 | \ (u k (cast_i (A i 0) j2 k x1)) \ 235 | \ (v k (cast_i (A i 1) j2 k x2))) \ 236 | \ j1 j2 \ 237 | \ (refl_j (xy^j (cast_i (Eq_j (A i j) (cast_i (A i 0) j2 i x1) (cast_i (A i 1) j2 i x2)) j2 j1 x12)^j))) \ 238 | \ {cast_k (A j2 k) 0 0 x} {cast_k (A j2 k) 0 1 x} (refl_j (cast_k (A j2 k) 0 j x)))^0) " 239 | ,"{-ar-ott5-} \\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v (j1 j2 : Interval) (xy : Eq_j ((x:A j1 j)->B x) (u j1) (v j1)). \ 240 | \ refl_j0 (\\x -> \ 241 | \ (cast_k (Eq_j \ 242 | \ (B {k} {j} \ 243 | \ (iv (cast_i (A i 0) j2 k (cast_k (A j2 k) j0 0 x)) \ 244 | \ (cast_i (A i 1) j2 k (cast_k (A j2 k) j0 1 x)) \ 245 | \ (cast_i (Eq_j (A i j) (cast_i (A i 0) j2 i (cast_k (A j2 k) j0 0 x)) \ 246 | \ (cast_i (A i 1) j2 i (cast_k (A j2 k) j0 1 x))) j2 k \ 247 | \ (refl_j (cast_k (A j2 k) j0 j x))) \ 248 | \ j)) \ 249 | \ (u k (cast_i (A i 0) j2 k (cast_k (A j2 k) j0 0 x))) \ 250 | \ (v k (cast_i (A i 1) j2 k (cast_k (A j2 k) j0 1 x)))) \ 251 | \ j1 j2 \ 252 | \ (refl_j (xy^j (cast_i (Eq_j (A i j) (cast_i (A i 0) j2 i (cast_k (A j2 k) j0 0 x)) \ 253 | \ (cast_i (A i 1) j2 i (cast_k (A j2 k) j0 1 x))) j2 j1 \ 254 | \ (refl_j (cast_k (A j2 k) j0 j x)) )^j)) \ 255 | \ )^j0) " 256 | ,"{-ar-ott6-} \\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v (j1 j2 : Interval) (xy : Eq_j ((x:A j1 j)->B x) (u j1) (v j1)). \ 257 | \ refl_j0 (\\x -> xy^j0 (cast_i (A i j0) j2 j1 x)),\ 258 | \ refl_j0 (\\x -> xy^j0 (cast_i (Eq_j (A i j) (cast_i (A i 0) j2 i (cast_k (A j2 k) j0 0 x)) \ 259 | \ (cast_i (A i 1) j2 i (cast_k (A j2 k) j0 1 x))) j2 j1 \ 260 | \ (refl_j (cast_k (A j2 k) j0 j x)) )^j0)" 261 | -} 262 | ,"{-ar-eq2-}\\(A : _ -> _ -> Set) (B : _ -> _ -> Set) u v j1 j2 (f : Eq_j (A j1 j -> B j1 j) (u j1) (v j1)). \ 263 | \ refl_j (\\(x : A j2 j) -> \ 264 | \ (cast_i (Eq_j' (B i j') (u i (cast_i (A i 0) j2 i (cast_j (A j2 j) j 0 x))) \ 265 | \ (v i (cast_i (A i 1) j2 i (cast_j (A j2 j) j 1 x))) ) j1 j2\ 266 | \ (refl_j' (f^j' (cast_i (A i j') j2 j1 (cast_j (A j2 j) j j' x))))) ^j )" 267 | ,"{-ar-deq-}\\(A : _ -> _ -> Set) (B : ∀ {i j}. A i j -> Set) u v j1 j2 (f : Eq_j ((x:A j1 j)->B x) (u j1) (v j1)). \ 268 | \ refl_j (\\(x : A j2 j) -> \ 269 | \ (cast_i (Eq_j' (B {i} {j'} (cast_i (A i j') j2 i (cast_j (A j2 j) j j' x))) \ 270 | \ (u i (cast_i (A i 0) j2 i (cast_j (A j2 j) j 0 x))) \ 271 | \ (v i (cast_i (A i 1) j2 i (cast_j (A j2 j) j 1 x))) ) j1 j2\ 272 | \ (refl_j' (f^j' (cast_i (A i j') j2 j1 (cast_j (A j2 j) j j' x))))) ^j )" 273 | ,"{-cast-eq-eq-pair-} \\(A B : _ -> _ -> _ -> Set) \ 274 | \ (u : forall i j. (A i j 0 * B i j 0)) \ 275 | \ (v : forall i j. (A i j 1 * B i j 1)) \ 276 | \ (p : (i:_) -> Eq_k (A i 0 k * B i 0 k) (u i 0) (v i 0)) \ 277 | \ (q : (i:_) -> Eq_k (A i 1 k * B i 1 k) (u i 1) (v i 1)) j1 j2 \ 278 | \ (xy : Eq_j (Eq_k (A j1 j k * B j1 j k) (u j1 j) (v j1 j)) (p j1) (q j1)). \ 279 | \ (refl_j (refl_k ((cast_i (Eq_j (Eq_k (A i j k) (proj1 (u i j)) (proj1 (v i j))) \ 280 | \ (refl_k (proj1 (p i)^k)) (refl_k (proj1 (q i)^k))) j1 j2 \ 281 | \ (refl_j (refl_k (proj1 (xy^j)^k))))^j^k \ 282 | \ ,(cast_i (Eq_j (Eq_k (B i j k) (proj2 (u i j)) (proj2 (v i j))) \ 283 | \ (refl_k (proj2 (p i)^k)) (refl_k (proj2 (q i)^k))) j1 j2 \ 284 | \ (refl_j (refl_k (proj2 (xy^j)^k))))^j^k)) \ 285 | \ : Eq_j (Eq_k (A j2 j k * B j2 j k) (u j2 j) (v j2 j)) (p j2) (q j2) )" 286 | ,"{-cast-eq-eq-fun-} \\(A B : _ -> _ -> _ -> Set) \ 287 | \ (u : forall i j. (A i j 0 -> B i j 0)) \ 288 | \ (v : forall i j. (A i j 1 -> B i j 1)) \ 289 | \ (p : (i:_) -> Eq_k (A i 0 k -> B i 0 k) (u i 0) (v i 0)) \ 290 | \ (q : (i:_) -> Eq_k (A i 1 k -> B i 1 k) (u i 1) (v i 1)) j1 j2 \ 291 | \ (f : Eq_j (Eq_k (A j1 j k -> B j1 j k) (u j1 j) (v j1 j)) (p j1) (q j1)). \ 292 | \ refl_j (refl_k (\\(x : A j2 j k) -> \ 293 | \ (cast_i (Eq_j' (Eq_k' (B i j' k') \ 294 | \ (u i j' (cast_i (A i j' 0) j2 i (cast_j (A j2 j 0) j j' (cast_k (A j2 j k) k 0 x)))) \ 295 | \ (v i j' (cast_i (A i j' 1) j2 i (cast_j (A j2 j 1) j j' (cast_k (A j2 j k) k 1 x)))) ) \ 296 | \ (refl_k' ((p i)^k' (cast_i (A i 0 k') j2 i (cast_j (A j2 j k') j 0 (cast_k (A j2 j k) k k' x))))) \ 297 | \ (refl_k' ((q i)^k' (cast_i (A i 1 k') j2 i (cast_j (A j2 j k') j 1 (cast_k (A j2 j k) k k' x))))) ) j1 j2 \ 298 | \ (refl_j' (refl_k' (f^j'^k' (cast_i (A i j' k') j2 j1 (cast_j (A j2 j k') j j' (cast_k (A j2 j k) k k' x)))))) )^j^k ))" 299 | ] 300 | {- 301 | cast A (proj1 x) becomes (cast (Eq A) (refl_i (proj1 x)))^i 302 | cast A x becomes cast (Eq A) (refl_i x^i) 303 | From (x : A i) You can go to (refl_i' (cast_i (A i) i' i x) : Eq_i A (cast_i A i 0 x) (cast_i A i 1 x)) 304 | -- can you do a two step thing? 305 | -} 306 | 307 | -- expressions that shouldn't typecheck 308 | badExpressions :: [String] 309 | badExpressions = 310 | ["Set : Set" 311 | ,"f (f x)" 312 | ,"notInScope" 313 | ,"\\x. x" 314 | ,"(refl f) x" 315 | ,"f (refl x)" 316 | ,"data{zero:Unit; zero:Nat}" 317 | ,"_" 318 | ] 319 | 320 | -------------------------------------------------------------------------------- 321 | -- Simple test framework 322 | -------------------------------------------------------------------------------- 323 | 324 | showError :: Show err => Either err a -> Either String a 325 | showError = either (Left . show) Right 326 | 327 | testPart :: String -> Either String a -> Either String a 328 | testPart part = either (Left . (part ++) . ("\n" ++)) Right 329 | 330 | type MyAssertion = Either String () 331 | 332 | assert :: String -> Bool -> MyAssertion 333 | assert msg False = Left $ msg 334 | assert _ True = return () 335 | 336 | assertEqual :: (Eq a, Show a) => String -> a -> a -> MyAssertion 337 | assertEqual msg x y = assert (unlines [msg," "++show x,"Not equal to"," "++show y]) (x == y) 338 | 339 | assertFailed :: Show a => String -> Either err a -> MyAssertion 340 | assertFailed _ (Left _) = Right () 341 | assertFailed msg (Right a) = Left (msg ++ "\n" ++ show a) 342 | 343 | newtype TestCase = TestCase (Either String String) 344 | deriving Typeable 345 | 346 | testCase :: TestName -> MyAssertion -> TestTree 347 | testCase name = testCaseInfo name . ("" <$) 348 | 349 | testCaseInfo :: TestName -> Either String String -> TestTree 350 | testCaseInfo name = singleTest name . TestCase 351 | 352 | instance IsTest TestCase where 353 | testOptions = return [] 354 | run _ (TestCase (Left e)) _ = return $ testFailed e 355 | run _ (TestCase (Right info)) _ = return $ testPassed info 356 | 357 | -------------------------------------------------------------------------------- 358 | -- Test of parser and typechecker 359 | -------------------------------------------------------------------------------- 360 | 361 | testTcM :: EvalAllMetas a => TcM a -> a 362 | testTcM x = case runTcM testCtx (x >>= evalAllMetasThrow) of 363 | Left e -> error (show e) 364 | Right y -> y 365 | 366 | testTcM' :: EvalAllMetas a => TcM a -> (a,Doc) 367 | testTcM' x = testTcM ((,) <$> x <*> dumpMetas) 368 | 369 | myTestTcM :: (EvalAllMetas a, Pretty TcM a) => TcM a -> Either String a 370 | myTestTcM mx = showError $ runTcM testCtx $ do 371 | x <- mx 372 | evalAllMetasThrow x `annError` (text "in" <+> tcPpr 0 x) 373 | 374 | testExp :: String -> Either String String 375 | testExp xStr = do 376 | -- we should be able to parse the expression 377 | x <- testPart "Parsing" $ 378 | showError $ runParser parseExpTop "input" xStr 379 | -- we should be able to pretty print and re-parse 380 | testPart "Pretty printer" $ do 381 | let xStr' = show x 382 | x' <- showError $ runParser parseExpTop "prety-printed" xStr' 383 | assertEqual "parse.ppr not identity" x x' 384 | -- we should be able to infer its type 385 | (x',ty) <- testPart "Type inference" $ 386 | myTestTcM $ tc Nothing x 387 | {--- we should still be able to pretty print and re-parse, after type inference 388 | -- but this doesn't hold because we don't pretty print the type information in SumElim. 389 | testPart "Pretty printer(typechecked)" $ do 390 | x'' <- showError $ runParser parseExpTop "prety-printed" (show x') 391 | assertEqual "parse.ppr not identity" x' x''-} 392 | -- and the modified expression should yield the same type 393 | testPart "Type inference of expanded expression" $ do 394 | (x'',ty') <- myTestTcM $ tc Nothing x' 395 | tyNf <- myTestTcM $ tcEval NF ty 396 | ty'Nf <- myTestTcM $ tcEval NF ty' 397 | assertEqual "Values should be equal" x' x'' 398 | assertEqual "Types should be equal" tyNf ty'Nf 399 | -- and we should also be able to typecheck it 400 | testPart "Type checking" $ do 401 | xty' <- myTestTcM $ tc (Just ty) x' 402 | assertEqual "Should be equal" (x',ty) xty' 403 | -- evaluation (to normal form) should preserve typing 404 | xnf <- testPart "Evaluation preserves typing" $ do 405 | xnf <- myTestTcM $ tcEval NF x' 406 | (_,ty') <- myTestTcM $ tc (Just ty) xnf 407 | `annError` text "Original expression: " $/$ (tcPpr 0 x') 408 | $$ text "Normal form expression: " $/$ (tcPpr 0 xnf) 409 | -- ty and ty' should have the same normal form (we already know that they unify) 410 | tyNf <- myTestTcM $ tcEval NF ty 411 | ty'Nf <- myTestTcM $ tcEval NF ty' 412 | assertEqual "Should have same type in normal form" tyNf ty'Nf 413 | return xnf 414 | -- eval NF should also give a normal form 415 | testPart "Normal form" $ do 416 | xnf' <- myTestTcM $ tcEval NF xnf 417 | assertEqual "eval NF should give normal form" xnf xnf' 418 | -- all the ways to evaluate x to normal form should give the same result 419 | testPart "Evaluation" $ do 420 | return () 421 | -- return some info 422 | --return "" 423 | tyNf <- myTestTcM $ tcEval NF ty 424 | return $ show tyNf 425 | 426 | testBadExp :: String -> Either String () 427 | testBadExp xStr = do 428 | x <- testPart "Parsing" $ 429 | showError $ runParser parseExpTop "input" xStr 430 | assertFailed "Type inference should fail" $ 431 | myTestTcM $ tc Nothing x 432 | 433 | -------------------------------------------------------------------------------- 434 | -- repl utilities 435 | -------------------------------------------------------------------------------- 436 | 437 | -- search for a goodExpression 438 | findExp :: String -> String 439 | findExp query = case filter (("{-"++query) `isPrefixOf`) goodExpressions of 440 | [x] -> x 441 | [] -> error $ "Query not found: " ++ query 442 | _ -> error $ "Multiple results for: " ++ query 443 | 444 | testExp' :: String -> IO () 445 | testExp' x = do 446 | putStrLn $ take 40 x 447 | putStrLn $ either ("FAIL\n"++) ("OK\n"++) $ testExp x 448 | 449 | -------------------------------------------------------------------------------- 450 | -- Main: testcases 451 | -------------------------------------------------------------------------------- 452 | 453 | -- 454 | --splitTest :: 455 | 456 | tests :: TestTree 457 | tests = testGroup "Tests" 458 | [ testGroup "Should pass" 459 | [ testCaseInfo (show i ++ " " ++ take 25 xStr) (testExp xStr) | (i,xStr) <- zip [0..] goodExpressions ] 460 | , testGroup "Should fail" 461 | [ testCase (show i ++ " " ++ take 20 xStr) (testBadExp xStr) | (i,xStr) <- zip [0..] badExpressions ] 462 | ] 463 | 464 | main :: IO () 465 | main = do 466 | hSetBuffering stdout LineBuffering 467 | defaultMain tests 468 | 469 | -------------------------------------------------------------------------------- /src/Tokenizer.hs: -------------------------------------------------------------------------------- 1 | module Tokenizer where 2 | 3 | import Prelude () 4 | import Util.MyPrelude 5 | import Util.Parser 6 | 7 | import Data.Char 8 | import qualified Text.Parsec as P 9 | 10 | -------------------------------------------------------------------------------- 11 | -- Tokenizer 12 | -------------------------------------------------------------------------------- 13 | 14 | data TokNameType = Reserved | User 15 | 16 | -- primitive parts of the tokenizer 17 | 18 | tokIntPart :: Parser Int 19 | tokIntPart = 20 | P.char '0' *> zeroInt 21 | <|> parseBase 10 <$> P.many1 P.digit 22 | "integer" 23 | where 24 | zeroInt = parseBase 16 <$ P.oneOf "xX" <*> P.many1 P.hexDigit 25 | <|> parseBase 8 <$ P.oneOf "oO" <*> P.many1 P.octDigit 26 | <|> parseBase 2 <$ P.oneOf "bB" <*> P.many1 (P.oneOf "01") 27 | <|> parseBase 10 <$> P.many P.digit 28 | parseBase :: Int -> String -> Int 29 | parseBase b = foldl' (\num x -> num * b + digitToInt x) 0 30 | 31 | tokWS :: Parser () 32 | tokWS = P.skipMany (() <$ P.space <|> lineComment <|> nestedComment "") 33 | where 34 | lineComment = P.try (P.string "--") *> lineCommentBody 35 | lineCommentBody = () <$ P.char '\n' 36 | <|> () <$ P.eof 37 | <|> P.anyChar *> lineCommentBody 38 | nestedComment = P.try (P.string "{-") *> nestedCommentBody 39 | nestedCommentBody = () <$ P.try (P.string "-}") 40 | <|> nestedComment <* nestedCommentBody 41 | <|> () <$ P.anyChar <* nestedCommentBody 42 | 43 | -- tokens 44 | 45 | tokNameEnd :: Parser () 46 | tokNameEnd = P.notFollowedBy $ P.satisfy isNameCont 47 | 48 | tokIntEnd :: Parser () 49 | tokIntEnd = P.notFollowedBy $ P.satisfy isAlphaNum 50 | 51 | tokAnyName :: Parser String 52 | tokAnyName = (:) <$> P.satisfy isNameStart <*> P.many (P.satisfy isNameCont) "name" 53 | 54 | isNameStart, isNameCont :: Char -> Bool 55 | --isNameStart x = isAlpha x || (isSymbol x) || x `elem` "_'*" 56 | --isNameCont x = isAlphaNum x || (isSymbol x) || x `elem` "_'*" 57 | isNameStart x = isAlpha x || (isSymbol x && x `notElem` "<=>^`$") || x `elem` "_'*" 58 | isNameCont x = isAlphaNum x || (isSymbol x && x `notElem` "<=>^`") || x `elem` "_'*-" 59 | 60 | -- a non-reserved name 61 | tokName :: Parser String 62 | tokName = P.try (do 63 | indented 64 | n <- tokAnyName 65 | when (isReservedName n) $ P.unexpected ("reserved name " ++ n) 66 | tokNameEnd 67 | tokWS 68 | return n 69 | "name") 70 | 71 | -- a path 72 | tokPath :: Parser String 73 | tokPath = P.try (do 74 | indented 75 | n <- tokString <|> P.many1 (P.satisfy (`notElem` " \t\n\r\"")) 76 | tokWS 77 | return n 78 | "path") 79 | 80 | tokLowerName :: Parser String 81 | tokLowerName = tokLowerNameNoWS <* tokWS "name" 82 | 83 | tokLowerNameNoWS :: Parser String 84 | tokLowerNameNoWS = P.try (do 85 | indented 86 | n <- (:) <$> P.satisfy (\x -> isLower x || x `elem` "_") <*> P.many (P.satisfy isNameCont) "name" 87 | tokNameEnd 88 | return n 89 | "name") 90 | 91 | tokUpperName :: Parser String 92 | tokUpperName = P.try (do 93 | indented 94 | n <- (:) <$> P.satisfy isUpper <*> P.many (P.satisfy isNameCont) "name" 95 | tokNameEnd 96 | tokWS 97 | return n 98 | "name") 99 | 100 | -- a non-reserved name 101 | tokAQName :: Parser String 102 | tokAQName = P.try (P.char '$' *> tokAnyName <* tokNameEnd) <* tokWS 103 | 104 | isReservedName :: String -> Bool 105 | isReservedName ('p':'r':'o':'j':(x:xs)) = all (`elem`"12") (x:xs) 106 | isReservedName xs = xs `elem` 107 | ["Pi","Sigma","W","Top","Bot","Set","Type","Fin","Eq","refl","Interval","0","1","01","10" 108 | ,"cast","fw","bw","equiv" 109 | ,"forall","exists","proj1","proj2" 110 | ,"->",":",",","\\","\\/","=","of" 111 | ,"×","→","⇒","∀","Π","Σ","≡"] 112 | 113 | 114 | tokReservedName :: String -> Parser () 115 | tokReservedName n = indented *> P.try (P.string n *> tokNameEnd) *> tokWS 116 | 117 | tokReservedOp :: String -> Parser () 118 | tokReservedOp n = indented *> P.try (P.string n) *> tokWS 119 | 120 | tokLParen, tokRParen, tokLBracket, tokRBracket, tokLBrace, tokRBrace, tokColon, tokSemi, tokComma, tokEquals, tokDEquals, tokArrow, tokThickArrow, tokProduct, tokHat, tokForall, tokExists, tokPi, tokSigma, tokLambda, tokBlank, tokCase, tokOf, tokEval, tokPostulate, tokDollar, tokDot, tokUnderscore, tokBacktick, tokAnd, tokOr, tokTilde :: Parser () 121 | tokLParen = tokReservedOp "(" 122 | tokRParen = tokReservedOp ")" 123 | tokLBracket = tokReservedOp "[" 124 | tokRBracket = tokReservedOp "]" 125 | tokLBrace = tokReservedOp "{" 126 | tokRBrace = tokReservedOp "}" 127 | tokColon = tokReservedOp ":" 128 | tokSemi = tokReservedOp ";" 129 | tokComma = tokReservedOp "," 130 | tokLambda = tokReservedOp "\\" 131 | tokEquals = tokReservedOp "=" 132 | tokDEquals = tokReservedOp "==" 133 | tokArrow = tokReservedOp "->" <|> tokReservedOp "→" 134 | tokThickArrow = tokReservedOp "=>" <|> tokReservedOp "⇒" 135 | tokProduct = tokReservedOp "*" <|> tokReservedOp "×" 136 | tokHat = tokReservedOp "^" 137 | tokForall = tokReservedName "forall" <|> tokReservedOp "\\/" <|> tokReservedOp "∀" 138 | tokExists = tokReservedName "exists" <|> tokReservedOp "∃" 139 | tokPi = tokReservedName "Pi" <|> tokReservedOp "Π" 140 | tokSigma = tokReservedName "Sigma" <|> tokReservedOp "Σ" 141 | tokBlank = tokReservedName "_" 142 | tokCase = tokReservedName "case" 143 | tokOf = tokReservedName "of" 144 | tokEval = tokReservedName "eval" 145 | tokPostulate = tokReservedName "postulate" 146 | tokDollar = tokReservedOp "$" 147 | tokDot = tokReservedOp "." 148 | tokUnderscore = tokReservedName "_" 149 | tokBacktick = tokReservedOp "`" 150 | tokAnd = tokReservedOp "&&" 151 | tokOr = tokReservedOp "||" 152 | tokTilde = tokReservedOp "~" 153 | 154 | tokType :: Parser Int 155 | tokType = indented *> P.try ((P.string "Type" <|> P.string "Set") *> (tokIntPart <|> return 0) <* tokNameEnd) <* tokWS 156 | 157 | tokEq :: Parser String 158 | tokEq = indented *> P.try (P.string "Eq" *> (tokNameEnd *> return "" <|> P.string "_" *> tokAnyName)) <* tokWS 159 | 160 | tokRefl :: Parser String 161 | tokRefl = indented *> P.try (P.string "refl" *> (tokNameEnd *> return "" <|> P.string "_" *> tokAnyName)) <* tokWS 162 | 163 | tokCast :: Parser String 164 | tokCast = indented *> P.try (P.string "cast" *> (tokNameEnd *> return "" <|> P.string "_" *> tokAnyName)) <* tokWS 165 | 166 | tokFw :: Parser String 167 | tokFw = indented *> P.try (P.string "fw" *> (tokNameEnd *> return "" <|> P.string "_" *> tokAnyName)) <* tokWS 168 | 169 | tokBw :: Parser String 170 | tokBw = indented *> P.try (P.string "bw" *> (tokNameEnd *> return "" <|> P.string "_" *> tokAnyName)) <* tokWS 171 | 172 | tokFin :: Parser Int 173 | tokFin = indented *> P.try (P.string "Fin" *> tokIntPart <* tokNameEnd) <* tokWS 174 | <|> 0 <$ (tokReservedName "⊥" <|> tokReservedName "Bot") 175 | <|> 1 <$ (tokReservedName "⊤" <|> tokReservedName "Top") 176 | <|> 2 <$ (tokReservedName "Bool") 177 | 178 | tokProj :: Parser [Int] 179 | tokProj = P.try (tokReservedOp "proj" *> P.many1 (pred . read . return <$> P.oneOf "12") <* tokNameEnd) <* tokWS 180 | 181 | tokInj :: Parser (Int,Maybe Int) 182 | tokInj = indented *> P.try (do 183 | _ <- tokReservedOp "inj" 184 | i <- tokIntPart 185 | tokNameEnd 186 | return (i,Nothing)) <* tokWS 187 | <|> (0,Just 1) <$ tokReservedName "tt" 188 | <|> (0,Just 2) <$ tokReservedName "true" 189 | <|> (1,Just 2) <$ tokReservedName "false" 190 | 191 | tokInt :: Parser Int 192 | tokInt = tokIntPart <* tokIntEnd <* tokWS "number" 193 | 194 | tokVar :: Parser Int 195 | tokVar = indented *> P.try (P.string "#" *> tokIntPart <* tokIntEnd) <* tokWS 196 | "de Bruijn variable" 197 | 198 | tokMeta :: Parser Int 199 | tokMeta = indented *> P.try (P.string "?" *> tokIntPart <* tokIntEnd) <* tokWS 200 | "meta variable" 201 | 202 | tokString :: Parser String 203 | tokString = indented *> P.try (P.char '"' *> P.many stringPart <* P.char '"') <* tokWS 204 | where 205 | stringPart = P.satisfy (`notElem` "\"\\\n") 206 | <|> '\\' <$ P.string "\\\\" 207 | <|> '\"' <$ P.string "\\\"" 208 | <|> '\n' <$ P.string "\\n" 209 | <|> '\r' <$ P.string "\\r" 210 | 211 | -------------------------------------------------------------------------------- /src/Typing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE DefaultSignatures, MultiParamTypeClasses #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ViewPatterns, PatternGuards #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE DataKinds #-} 10 | module Typing where 11 | 12 | import Prelude () 13 | import Util.MyPrelude 14 | import Util.PrettyM 15 | import Syntax 16 | import Substitution 17 | import SubstitutionQQ 18 | import Names 19 | import TcMonad 20 | import Eval 21 | 22 | import qualified Data.Sequence as Seq 23 | import qualified Data.IntMap as IM 24 | 25 | -------------------------------------------------------------------------------- 26 | -- Transfering expressions between contexts 27 | -------------------------------------------------------------------------------- 28 | 29 | -- | Transfer an expression to a different context, essentially the inverse of substitution. 30 | -- 31 | -- In particular, transfer an expression x0 to the current context, 32 | -- where the args specify how to represent the variables in x0 in the current context. 33 | -- 34 | -- This is a generalization of unsubstN. 35 | -- Can unsubst metas ?1[a,b,c] when b can not be represented in the target 36 | unsubst :: Seq Exp -> Exp -> TcM Exp 37 | unsubst xs x0 = do 38 | l0 <- boundDepth 39 | if l0 /= Seq.length xs 40 | then error "Internal error: depth doesn't match number of arguments" 41 | else unsubst' l0 (invCtxMap xs) x0 42 | 43 | unsubst' :: Int -> PartialCtxMap Exp -> Exp -> TcM Exp 44 | unsubst' l0 vars x0 = go x0 45 | where 46 | go x = do 47 | l <- subtract l0 <$> boundDepth -- depth of the source 48 | x' <- evalMetas x 49 | case x' of 50 | Var i 51 | | i < l -> return $ Var i 52 | | otherwise -> case IM.lookup (i-l) vars of 53 | Just v -> return $ raiseBy l v 54 | Nothing -> tcError =<< text "Variable not in scope of meta:" <+> ppr 0 (i-l) 55 | Meta mv args -> traverseMetaWithMaybeArgs go mv args 56 | _ -> traverseChildren go x' 57 | 58 | -- Traverse the arguments of a meta, but in case of failure, instead of giving up 59 | -- try to instantiate the meta with a simpler one. 60 | traverseMetaWithMaybeArgs :: (Exp -> TcM Exp) -> MetaVar -> Seq Exp -> TcM Exp 61 | traverseMetaWithMaybeArgs f mv oldArgs = do 62 | margs <- mapM (orElseNothing . f) oldArgs 63 | metaWithMaybeArgs mv margs 64 | 65 | metaWithMaybeArgs :: MetaVar -> Seq (Maybe Exp) -> TcM Exp 66 | metaWithMaybeArgs mv margs | Just args <- sequence margs = return $ Meta mv args 67 | metaWithMaybeArgs mv margs = do 68 | -- we might have instantiated mv in the process of evaluating the args 69 | mval <- getMetaVar mv 70 | when (isJust (mvValue mval)) $ 71 | tcError =<< text "Meta variable was instantiated while evaluating arguments to that meta variable" 72 | -- make a new meta with only a subset of the context 73 | (vars',args',tys',ty') <- filterCtx margs (mvArgs mval) (mvType mval) 74 | mv' <- freshMetaVar (MVExp Nothing ty' tys') 75 | -- let mv point to mv' (with a subset of the arguments) 76 | modifyMetaVar mv $ \val -> val { mvValue = Just $ Meta mv' vars' } 77 | return $ Meta mv' args' 78 | 79 | -- Suppose we are trying to abstract (?2[#0,#1,#2] -> bar) to assign it to ?1[#0,foo #0,#3] 80 | -- which means that we map #0->#0, #1->Nothing, #2->#3 81 | -- and we encounter a meta ?2[#0,#1,#2]. 82 | -- We have to replace this by a new meta ?3[#0,#2], and set ?2=?3[#0,#2], and ?1=?3[#0,#3]->bar 83 | -- this is only allowed if this new made would be have well-typed arguments. 84 | 85 | -- Make the type of a meta that takes just a subset of the arguments 86 | filterCtx :: Seq (Maybe a) -- ^ arguments to keep (those for which we have a representation in the target context) 87 | -> Seq (Named Exp) -- ^ Original argument types 88 | -> Exp -- ^ original result type 89 | -> TcM (Seq Exp, Seq a, Seq (Named Exp), Exp) 90 | filterCtx xs0 tys0 ty0 = withCtx Seq.empty $ go Seq.empty xs0 tys0 91 | where 92 | -- vars gives for each variable in the context the corresponding index in tys 93 | go vars (xs :> Just x) (tys :> Named n ty) = do 94 | mty' <- orElseNothing (unsubst vars ty) 95 | case mty' of 96 | Nothing -> go vars xs tys 97 | Just ty' -> do 98 | (vars',xs',tys',ty0') <- localBound (Named n ty') (go (Var 0 <| map (raiseBy 1) vars) xs tys) 99 | return (vars', xs' |> x, tys' |> Named n ty', ty0') 100 | go vars (xs :> Nothing) (tys :> _ty) = do 101 | go (map (raiseBy 1) vars) xs tys 102 | go vars _ _ = do 103 | ty0' <- unsubst vars ty0 104 | return (vars,Seq.empty,Seq.empty,ty0') 105 | 106 | -------------------------------------------------------------------------------- 107 | -- Unification 108 | -------------------------------------------------------------------------------- 109 | 110 | -- make sure actual/expected arguments stay in the right order 111 | type Swapped = (forall a b. (a -> a -> b) -> (a -> a -> b)) 112 | 113 | -- | Verify that a meta doesn't occur in an expression 114 | occursCheck :: MetaVar -> Exp -> TcM () 115 | occursCheck mv (Meta mv' _) | mv == mv' = throwError =<< text "Occurs check failed" 116 | occursCheck mv x = traverseChildren_ (occursCheck mv) x 117 | 118 | -- | Set a unification variable 119 | -- Doesn't verify types 120 | unifyMeta, unifyMeta' :: Swapped -> MetaVar -> Seq Exp -> Exp -> TcM Exp 121 | unifyMeta swapped mv args y = do 122 | mx <- metaValue mv args 123 | case mx of 124 | Just x -> swapped unify x y -- x already has a value, unify with that 125 | `annError` text "By instantiated meta" $/$ tcPpr 0 x $/$ tcPpr 0 y 126 | Nothing -> unifyMeta' swapped mv args =<< evalMetas y 127 | unifyMeta' _ mv args (Meta mv' args') | mv' == mv = do 128 | -- we are unifying ?mv[x,y,z] with ?mv[x',y',z'] 129 | -- this is easy if we can unify x with x', y with y', etc. 130 | -- but if one of these unifications fails, then instead of failing alltogether, 131 | -- ?mv should just not depend on that argument 132 | margs <- sequenceA $ map orElseNothing $ Seq.zipWith unify args args' 133 | metaWithMaybeArgs mv margs 134 | unifyMeta' swapped mv args (Meta mv' args') | Seq.length args < Seq.length args' = 135 | -- unify the other way around, otherwise unsubstN will fail 136 | unifyMeta' (flip . swapped) mv' args' (Meta mv args) 137 | unifyMeta' _swapped mv args y = do 138 | -- perform occurs check: y must not contain mv 139 | occursCheck mv y 140 | -- unify the type of the metavar 141 | mv_type <- metaType mv args 142 | (_,y_type) <- tc Nothing y 143 | _ <- unify mv_type y_type 144 | `annError` text "When checking that the type of a meta," <+> tcPpr 0 mv_type 145 | $$ text " matches that of the instantiation," <+> tcPpr 0 y_type 146 | -- y can only use variables that occur in args 147 | y' <- (withMetaContext mv $ unsubst args y) 148 | `annError` text "When trying to instantiate meta" 149 | $$ indent 2 (tcPpr 0 (Meta mv args)) 150 | $$ indent 2 (tcPpr 0 y) 151 | modifyMetaVar mv $ \val -> val { mvValue = Just y' } 152 | return y 153 | 154 | -- | Rexpress x in terms of the local context 155 | --(Int -> Maybe ) -> Exp -> TcM Exp 156 | 157 | unifyLevelMeta :: Swapped -> (LevelMetaVar,Int) -> Level -> TcM Level 158 | unifyLevelMeta _swapped (mv,x) lPLusX = 159 | case subtractLevel x lPLusX of 160 | Just l -> do 161 | lMv <- getLevelMetaVar mv 162 | if isJust lMv 163 | then error "unifyLevelMeta: meta var already has a value" 164 | else putLevelMetaVar mv (Just l) 165 | return l 166 | Nothing -> tcError =<< group (text "Failed to unify level meta") 167 | 168 | unifyLevels, unifyLevels' :: Level -> Level -> TcM Level 169 | unifyLevels x y = join $ unifyLevels' <$> evalLevel x <*> evalLevel y 170 | unifyLevels' x y | x == y = pure x 171 | unifyLevels' (MetaLevel x) y = unifyLevelMeta id x y 172 | unifyLevels' x (MetaLevel y) = unifyLevelMeta flip y x 173 | unifyLevels' (MetaLevels xs) y@(IntLevel 0) = mapM_ (flip (unifyLevelMeta id ) y) xs >> return y 174 | unifyLevels' x@(IntLevel 0) (MetaLevels ys) = mapM_ (flip (unifyLevelMeta flip) x) ys >> return x 175 | unifyLevels' x y = do 176 | tcError =<< group (text "Failed to unify" <+> tcPpr 11 (Set x) $/$ text "with" <+> tcPpr 11 (Set y)) 177 | 178 | -- | Unify two expressions. 179 | -- requires that the expressions have the same type 180 | -- does not assume that they are in normal form 181 | unify :: Exp -> Exp -> TcM Exp 182 | unify x y = 183 | unify' x y -- first try to unify without evaluation 184 | `catchError` \err -> do 185 | x' <- tcEval WHNF x 186 | y' <- tcEval WHNF y 187 | unless (isWHNF x') $ error $ "eval didn't produce WHNF: " ++ show x' 188 | unless (isWHNF y') $ error $ "eval didn't produce WHNF: " ++ show y' 189 | if x /= x' || y /= y' 190 | then unify' x' y' `catchError` \err' -> 191 | -- throw err', since in err we might have matched up wrong things 192 | throwError =<< pure err' $$ (text "When unifying" <+> tcPpr 11 x $/$ text "with" <+> tcPpr 11 y) 193 | $$ (text "Which simplifies to" <+> tcPpr 11 x' $/$ text "with" <+> tcPpr 11 y') 194 | else throwError =<< pure err $$ (text "When unifying" <+> tcPpr 11 x $/$ text "with" <+> tcPpr 11 y) 195 | 196 | -- | Unify two expressions that are in WHNF (or that we assume to have equal heads). 197 | -- The left is the 'actual' type (of an argument e.g.), 198 | -- the right is the 'expected' type (from a typesig, or applied function) 199 | -- Optionally a value of the actual type may be passed in. 200 | -- It will be applied to hidden arguments or wrapped in hidden lams/pairs as needed 201 | unify' :: Exp -> Exp -> TcM Exp 202 | --unify' x y | not (isWHNF x) || not (isWHNF y) = error $ "unify': arguments not in WHNF:" ++ show (x,y) 203 | --unify' x y | not (isWHNF x) || not (isWHNF y) = tcError =<< text "unify': arguments not in WHNF:" <+> tcPpr 0 (x,y) 204 | unify' (Var i) (Var i') | i == i' = pure $ Var i 205 | unify' (Free x) (Free x') | x == x' = pure $ Free x 206 | unify' (Set i) (Set i') = Set <$> unifyLevels i i' 207 | unify' (Proj h p x) (Proj h' p' x') | h == h' && p == p' = Proj h p <$> unify' x x' 208 | {-unify' (App x (Arg h y)) (App x' (Arg h' y')) | h == h' = App <$> unify' x x' <*> (Arg h <$> unify' y y') 209 | `annError` text "When unifying an application" $/$ tcPpr 0 x <+> text "applied to" <+> tcPpr 0 y 210 | $$ text " with" $/$ tcPpr 0 x' <+> text "applied to" <+> tcPpr 0 y'-} 211 | unify' (App x (Arg h y)) (App x' (Arg h' y')) | h == h' = App <$> (unify' x x' `ann` "function") <*> (Arg h <$> unify' y y' `ann` "argument of") 212 | where 213 | ann a b = a `annError` 214 | text "When unifying the" <+> text b $/$ tcPpr 0 x <+> text "applied to" <+> tcPpr 0 y 215 | $$ text " with" $/$ tcPpr 0 x' <+> text "applied to" <+> tcPpr 0 y' 216 | unify' (Binder b (Arg h x) y) (Binder b' (Arg h' x') y') | b == b' && h == h' = do 217 | x'' <- unify x x' 218 | Binder b (Arg h x'') <$> unifyBound x'' y y' 219 | unify' (Pair h x y z) (Pair h' x' y' z') | h == h' = 220 | Pair h <$> unify x x' <*> unify y y' <*> unify z z' 221 | unify' (SumTy xs) (SumTy xs') | length xs == length xs' = SumTy <$> zipWithM unifyCtor xs xs' 222 | unify' (SumVal x y z) (SumVal x' y' z') | x == x' = SumVal x <$> unify y y' <*> unify z z' 223 | unify' (SumElim x ys z) (SumElim x' ys' z') | length ys == length ys' = SumElim <$> unify x x' <*> zipWithM unifyCase ys ys' <*> unify z z' 224 | unify' (IFlip x) (IFlip x') = IFlip <$> unify' x x' 225 | unify' (IAnd x y) (IAnd x' y') = IAnd <$> unify' x x' <*> unify' y y' 226 | unify' (Eq x y z) (Eq x' y' z') = Eq <$> unifyBound Interval x x' <*> unify y y' <*> unify z z' 227 | unify' (Refl x) (Refl x') = Refl <$> unifyBound Interval x x' 228 | unify' (IV x y z w) (IV x' y' z' w') = IV <$> unify x x' <*> unify y y' <*> unify z z' <*> unify w w' 229 | unify' (Cast x y z w) (Cast x' y' z' w') = Cast <$> unifyBound Interval x x' <*> unify y y' <*> unify z z' <*> unify w w' 230 | unify' x@Interval Interval = pure x 231 | unify' x@I0 I0 = pure x 232 | unify' x@I1 I1 = pure x 233 | unify' x@I01 I01 = pure x 234 | unify' x@I10 I10 = pure x 235 | unify' x@UnitTy UnitTy = pure x 236 | unify' x@UnitVal UnitVal = pure x 237 | -- metas 238 | unify' (Meta x args) y = unifyMeta id x args y 239 | `annError` text "When trying to instantiate" <+> tcPpr 0 (Meta x args) <+> text "with" <+> tcPpr 0 y 240 | unify' y (Meta x args) = unifyMeta flip x args y 241 | `annError` text "When trying to instantiate" <+> tcPpr 0 (Meta x args) <+> text "with" <+> tcPpr 0 y 242 | unify' x y | x == y = ("Warning: fall through (==) case in unify for " ++ show x) `traced` return x 243 | -- eta expansion and surjective pairing? 244 | unify' (Pair h x y z) x' = 245 | Pair h <$> unify x (Proj h Proj1 x') <*> unify y (Proj h Proj2 x') <*> pure z 246 | unify' x (Pair h x' y' z') = 247 | Pair h <$> unify (Proj h Proj1 x) x' <*> unify (Proj h Proj2 x) y' <*> pure z' 248 | --unify' [qq| Lam (Arg h _x) [$u](App f[] (Arg $h' u))|] f' | h == h' = unify f f' 249 | --unify' (Lam (Arg h _) (Bound _ (App (NotFree f) (Arg h' (Var 0))))) f' | h == h' = unify f f' 250 | unify' (Lam (Arg h x) y) f = Lam (Arg h x) <$> unifyBound x y (Bound "" (App (raiseBy 1 f) (Arg h (Var 0)))) 251 | unify' f (Lam (Arg h x) y) = Lam (Arg h x) <$> unifyBound x (Bound "" (App (raiseBy 1 f) (Arg h (Var 0)))) y 252 | unify' [qq|Refl [$_i](IV _ _ x[] _i)|] x' = unify x x' 253 | unify' x [qq|Refl [$_i](IV _ _ x'[] _i)|] = unify x x' 254 | -- inside a refl_i we may have unevaluated things that cause i to be bound somewhere that is irrelevant in the end. 255 | unify' (Refl x) x' = do 256 | {- 257 | -- this is the correct typing, but since we don't do higher order unification yet, the type of v1:ty[i1] will cause ty to contain i1, instead of using a variable that is equal to v1. 258 | ty <- Bound "" <$> localBound (unnamed Interval) freshMetaSet 259 | v1 <- freshMeta (substBound ty I0) 260 | v2 <- freshMeta (substBound ty I1)-} 261 | v1 <- freshMetaAny 262 | v2 <- freshMetaAny 263 | Refl <$> unifyBound Interval x (Bound "" (IV (raiseBy 1 v1) (raiseBy 1 v2) (raiseBy 1 x') (Var 0))) 264 | unify' x (Refl x') = do 265 | {-ty <- Bound "" <$> localBound (unnamed Interval) freshMetaSet 266 | v1 <- freshMeta (substBound ty I0) 267 | v2 <- freshMeta (substBound ty I1)-} 268 | v1 <- freshMetaAny 269 | v2 <- freshMetaAny 270 | Refl <$> unifyBound Interval (Bound "" (IV (raiseBy 1 v1) (raiseBy 1 v2) (raiseBy 1 x) (Var 0))) x' 271 | 272 | unify' x y = do 273 | tcError =<< group (text "Failed to unify" $/$ tcPpr 11 x $$ text "with" $/$ tcPpr 11 y) 274 | 275 | unifyName :: Name -> Name -> Name 276 | unifyName "" n = n 277 | unifyName n _ = n 278 | 279 | unifyBound :: Exp -> Bound Exp -> Bound Exp -> TcM (Bound Exp) 280 | unifyBound ty (Bound n x) (Bound n' x') = Bound n'' <$> localBound (Named n'' ty) (unify x x') 281 | where n'' = unifyName n n' 282 | 283 | unifyCtor :: SumCtor -> SumCtor -> TcM SumCtor 284 | unifyCtor (SumCtor n x) (SumCtor n' x') | n == n' = SumCtor n <$> unify x x' 285 | unifyCtor _ _ = tcError =<< text "Failed to unify constructors" 286 | 287 | unifyCase :: SumCase -> SumCase -> TcM SumCase 288 | unifyCase (SumCase n x y) (SumCase n' x' y') | n == n' = SumCase n <$> unify x x' <*> unifyBound x y y' 289 | unifyCase _ _ = tcError =<< text "Failed to unify cases" 290 | 291 | 292 | --unify' (Just valX) x (Pi (Arg Hidden u) v) = 293 | 294 | -- | Unify x with (Set _) 295 | unifySet :: Exp -> TcM Level 296 | unifySet (Set i) = pure i 297 | unifySet x = do 298 | i <- freshMetaLevel 299 | _ <- unify x (Set i) 300 | evalLevel i 301 | 302 | -- | Unify x with (Binder b (Arg h _) _) 303 | unifyBinder, unifyBinder' :: Binder -> Hiding -> Exp -> TcM (Exp, Bound Exp) 304 | unifyBinder b h = unifyBinder' b h <=< tcEval WHNF 305 | unifyBinder' b h (Binder b' (Arg h' x) y) | b == b' && h == h' = return (x,y) 306 | unifyBinder' b h xy = do 307 | x <- freshMetaSet 308 | y <- Bound "" <$> localBound (unnamed x) freshMetaSet 309 | Binder _ (Arg _ x') y' <- unify xy (Binder b (Arg h x) y) 310 | return (x',y') 311 | 312 | -- | Unify x with (Eq _ _ _) 313 | unifyEq :: Exp -> TcM (Bound Exp, Exp, Exp) 314 | unifyEq (Eq x y z) = return (x,y,z) 315 | unifyEq xy = do 316 | x <- Bound "" <$> localBound (unnamed Interval) freshMetaSet 317 | y <- freshMeta (substBound x I0) 318 | z <- freshMeta (substBound x I1) 319 | Eq x' y' z' <- unify xy (Eq x y z) 320 | return (x',y',z') 321 | 322 | -- | Unify x with (SumTy _) 323 | unifySumTy, unifySumTy' :: Exp -> TcM [SumCtor] 324 | unifySumTy = unifySumTy' <=< tcEval WHNF 325 | unifySumTy' (SumTy xs) = return xs 326 | unifySumTy' ty = tcError =<< text "Expected a sum type instead of" $/$ tcPpr 0 ty 327 | 328 | 329 | 330 | -- To handle hidden arguments 331 | -- unify (Pi Hidden x y) (Set _) 332 | -- unify (Pi Hidden x y) (Pi Visible _ _) 333 | -- unify (Si Hidden x y) _ 334 | 335 | -- Apply x of type ty to all expected hidden arguments if hiding=Visible 336 | applyHidden :: Hiding -> Exp -> Exp -> TcM (Exp,Exp) 337 | applyHidden Visible x ty = applyHidden' x =<< tcEval WHNF ty 338 | applyHidden Hidden x ty = return (x,ty) 339 | 340 | applyHidden' :: Exp -> Exp -> TcM (Exp,Exp) 341 | applyHidden' x (Pi (Arg Hidden u) v) = do 342 | arg <- freshMeta u 343 | let x' = App x (hidden arg) 344 | let ty' = substBound v arg 345 | applyHidden' x' =<< tcEval WHNF ty' 346 | applyHidden' x (Si (Arg Hidden _) v) = do 347 | let x' = Proj Hidden Proj2 x 348 | let ty' = substBound v (Proj Hidden Proj1 x) 349 | applyHidden' x' =<< tcEval WHNF ty' 350 | applyHidden' x ty = return (x,ty) 351 | 352 | -- Ensure that x of type ty takes enough hidden arguments 353 | {- 354 | wrapHidden :: Hiding -> Exp -> Exp -> TcM (Exp,Exp) 355 | wrapHidden Visible x ty = wrapHidden' x =<< tcEval WHNF ty 356 | wrapHidden Hidden x ty = return (x,ty) 357 | 358 | wrapHidden' :: Exp -> Exp -> TcM (Exp,Exp) 359 | wrapHidden' x (Pi (Arg Hidden u) v) = do 360 | Lam (Arg Hidden u) 361 | let x' = App x (hidden arg) 362 | let ty' = substBound v arg 363 | (x' <- wrapHidden' x' =<< tcEval WHNF v 364 | wrapHidden' x ty = pure (x,ty) 365 | -} 366 | 367 | -------------------------------------------------------------------------------- 368 | -- Typing 369 | -------------------------------------------------------------------------------- 370 | 371 | -- Type checking and type inference 372 | -- returns (expression, its type) 373 | -- For typechecking, the argument must be well-typed, of type Set _ 374 | tc :: Maybe Exp -> Exp -> TcM (Exp,Exp) 375 | 376 | tc Nothing (Var i) = do 377 | ty <- boundType i 378 | return (Var i, namedValue ty) 379 | tc Nothing (Free x) = do 380 | ty <- freeType x 381 | return (Free x, ty) 382 | tc Nothing (Proj h p x) = do 383 | (x',x_ty) <- tc Nothing x 384 | (x'',x_ty') <- applyHidden h x' x_ty 385 | (ty1,ty2) <- unifyBinder SiB h x_ty' 386 | case p of 387 | Proj1 -> return (Proj h p x'', ty1) 388 | Proj2 -> return (Proj h p x'', substBound ty2 (Proj h Proj1 x'')) 389 | tc Nothing Blank = do 390 | ty <- freshMetaSet 391 | tc (Just ty) Blank 392 | tc (Just ty) Blank = do 393 | x' <- freshMeta ty 394 | return (x',ty) 395 | tc Nothing (Set i) = do 396 | i' <- evalLevel i 397 | return (Set i', Set (sucLevel i')) 398 | tc Nothing (App x (Arg h y)) = do 399 | (x',x_ty) <- tc Nothing x 400 | (x'',x_ty') <- applyHidden h x' x_ty 401 | (ty1,ty2) <- unifyBinder PiB h x_ty' 402 | (y',_) <- tc (Just ty1) y 403 | return (App x'' (Arg h y'), substBound ty2 y') 404 | tc Nothing (TypeSig x y) = do 405 | (y',_l) <- tcType y 406 | tc (Just y') x 407 | tc (Just (Pi (Arg Hidden x) (Bound n y))) z@(Lam (Arg Visible _) _) = do 408 | -- wrap in \{_} -> .. 409 | (z',y') <- localBound (named n x) $ do 410 | y' <- tcEval WHNF y 411 | tc (Just y') (raiseBy 1 z) 412 | return (Lam (Arg Hidden x) (Bound n z'), Pi (Arg Hidden x) (Bound n y')) 413 | tc (Just (Pi (Arg h x) (Bound n y))) (Lam (Arg h' x') (Bound n' z)) | h == h' = do 414 | -- propagate type information 415 | (x'',_) <- tcType x 416 | (x''',_) <- tcType x' 417 | xx <- unify x'' x''' 418 | let nn = unifyName n' n 419 | localBound (named nn xx) $ do 420 | (y',_) <- tcType y 421 | (z',_) <- tc (Just y') z 422 | return (Lam (Arg h xx) (Bound nn z'), Pi (Arg h xx) (Bound nn y')) 423 | tc Nothing (Lam (Arg h x) (Bound n y)) = do 424 | (x',_) <- tcType x 425 | (y',t) <- localBound (named n x') (tc Nothing y) 426 | return (Lam (Arg h x') (Bound n y'), Pi (Arg h x') (Bound n t)) 427 | tc Nothing (Binder b (Arg h x) y) = do -- Pi or Sigma 428 | (x',lx) <- tcType x 429 | (y',ly) <- tcBoundType x' y 430 | `annError` text "in the second argument of a binder" $/$ tcPpr 0 (Binder b (Arg h x') y) 431 | return (Binder b (Arg h x') y', Set (maxLevel lx ly)) 432 | tc mty (Pair h x y z) = do 433 | mty' <- tcMType mty z 434 | case mty' of 435 | Nothing -> do 436 | -- assume non-dependent pair 437 | (x',tx) <- tc Nothing x 438 | (y',ty) <- tc Nothing y 439 | let txy = Si (Arg h tx) (notBound ty) 440 | return (Pair h x' y' txy, txy) 441 | Just ty' -> do 442 | (ty1,ty2) <- unifyBinder SiB h ty' 443 | (x',_) <- tc (Just ty1) x 444 | (y',_) <- tc (Just $ substBound ty2 x') y 445 | return (Pair h x' y' ty', ty') 446 | tc Nothing (Eq x y z) = do 447 | (x',l) <- tcBoundType Interval x 448 | `annError` text "in the 'type' argument of" $/$ tcPpr 0 (Eq x y z) 449 | (y',_) <- tc (Just $ substBound x' I0) y 450 | `annError` text "in the 'i0 end' argument of" $/$ tcPpr 0 (Eq x y z) 451 | (z',_) <- tc (Just $ substBound x' I1) z 452 | `annError` text "in the 'i1 end' argument of" $/$ tcPpr 0 (Eq x y z) 453 | return (Eq x' y' z', Set l) 454 | tc Nothing (Refl (Bound n x)) = do 455 | (x',t) <- localBound (named n Interval) $ tc Nothing x 456 | return (Refl (Bound n x'), Eq (Bound n t) (subst1 I0 x') (subst1 I1 x')) 457 | tc Nothing UnitTy = return (UnitTy, Set zeroLevel) 458 | tc Nothing UnitVal = return (UnitVal, UnitTy) 459 | tc Nothing (SumTy xs) = do 460 | let tcCtor (SumCtor n x) = do 461 | (x',l) <- tcType x 462 | return (SumCtor n x', l) 463 | xsls <- traverse tcCtor xs 464 | let xs' = sortWith ctorName $ map fst xsls 465 | let l = maxLevels $ map snd xsls 466 | case findDuplicates (map ctorName xs') of 467 | [] -> return () 468 | ds -> tcError =<< text "Duplicate constructor names: " <+> hsep (map text ds) 469 | return (SumTy xs', Set l) 470 | tc mty (SumVal n x y) = do 471 | my <- tcMType mty y 472 | case my of 473 | Nothing -> tcError =<< text "Type signature required for sum values" 474 | Just y' -> do 475 | ys <- unifySumTy y' 476 | cTy <- case find ((n==) . ctorName) ys of 477 | Nothing -> tcError =<< text "Constructor not in this type:" <+> text n <+> text "in" <+> tcPpr 0 y' 478 | Just (SumCtor _ cTy) -> return cTy 479 | (x',_) <- tc (Just cTy) x 480 | return (SumVal n x' y', y') 481 | tc mty (SumElim x ys Blank) = do 482 | -- result type 483 | ty <- case mty of 484 | Nothing -> do 485 | -- assume non-dependent eliminator 486 | raiseBy 1 <$> freshMetaSet 487 | Just ty -> do 488 | -- ty is the type of the result, so with x instantiated. 489 | -- we can (try to) recover the pi type: 490 | -- if ty is of the form A[x], then the function type would be ((x:_) -> A[x]) 491 | return $ unsubst1 x ty 492 | -- argument type 493 | (xTy,_) <- tc Nothing (SumTy (map caseToCtor ys)) 494 | let z' = PiV xTy (Bound "" ty) 495 | tc Nothing (SumElim x ys z') 496 | tc Nothing (SumElim x ys ty) = do 497 | (ty',_) <- tcType ty 498 | (ty1,ty2) <- unifyBinder PiB Visible ty' 499 | -- check argument 500 | (x',_) <- tc (Just ty1) x 501 | -- check cases 502 | ctors <- unifySumTy ty1 503 | let tcCase (SumCase n u (Bound m v)) = do 504 | -- unify type with type from signature 505 | u' <- case find ((==n) . ctorName) ctors of 506 | Nothing -> tcError =<< text "Constructor not found:" <+> text n 507 | Just c -> return (ctorType c) 508 | (u'',_) <- tcType u 509 | u''' <- unify u'' u' 510 | -- typecheck body 511 | let bodyTy = raiseSubsts 1 [SumVal n u''' ty1] (boundBody ty2) 512 | (v',_) <- localBound (named m u''') $ tc (Just bodyTy) v 513 | return (SumCase n u''' (Bound m v')) 514 | ys' <- traverse tcCase ys 515 | let ys'' = sortWith caseName ys' 516 | -- duplicate cases? 517 | case findDuplicates (map caseName ys'') of 518 | [] -> return () 519 | ds -> tcError =<< text "Duplicate case names: " <+> hsep (map text ds) 520 | return (SumElim x' ys'' ty', substBound ty2 x') 521 | tc Nothing Interval = return (Interval, Set zeroLevel) 522 | tc Nothing I0 = return (I0, Interval) 523 | tc Nothing I1 = return (I1, Interval) 524 | tc Nothing I01 = return (I01, Eq (notBound Interval) I0 I1) 525 | tc Nothing I10 = return (I10, Eq (notBound Interval) I1 I0) 526 | tc Nothing (IFlip x) = do 527 | (x',_) <- tc (Just Interval) x 528 | return (IFlip x',Interval) 529 | tc Nothing (IAnd x y) = do 530 | (x',_) <- tc (Just Interval) x 531 | (y',_) <- tc (Just Interval) y 532 | return (IAnd x' y',Interval) 533 | tc Nothing (IV x y z w) = do 534 | (w',_) <- tc (Just Interval) w 535 | (z',t) <- tc Nothing z 536 | (ta,t1,t2) <- unifyEq t 537 | (x',_) <- tc (Just $ substBound ta I0) x 538 | (y',_) <- tc (Just $ substBound ta I1) y 539 | _ <- unify x' t1 540 | _ <- unify y' t2 541 | return (IV x' y' z' w', substBound ta w') 542 | tc Nothing (Cast x j1 j2 y) = do 543 | (x',_) <- tcBoundType Interval x 544 | `annError` text "in the 'type' argument of a cast" 545 | (j1',_) <- tc (Just Interval) j1 546 | `annError` text "in the 'source side' argument of a cast" 547 | (j2',_) <- tc (Just Interval) j2 548 | `annError` text "in the 'target side' argument of a cast" 549 | (y',_) <- tc (Just $ substBound x' j1') y 550 | `annError` text "in the 'value' argument of a cast" 551 | return (Cast x' j1' j2' y', substBound x' j2') 552 | tc Nothing (Equiv a b c d e) = do 553 | l <- freshMetaLevel 554 | ty1 <- freshMeta (Set l) 555 | ty2 <- freshMeta (Set l) 556 | let x = "x" 557 | (a',_) <- tc (Just [qq| PiV ty1 [$x]ty2[] |]) a 558 | (b',_) <- tc (Just [qq| PiV ty2 [$x]ty1[] |]) b 559 | (c',_) <- tc (Just [qq| PiV ty1 [$x](Eq [$x]ty1[] (AppV b'[] (AppV a'[] x)) x) |]) c 560 | (d',_) <- tc (Just [qq| PiV ty2 [$x](Eq [$x]ty2[] (AppV a'[] (AppV b'[] x)) x) |]) d 561 | --(e',_) <- tc (Just [qq| PiV ty1 [$x]ty1[] |]) e 562 | let e' = e 563 | return (Equiv a' b' c' d' e', Eq (notBound (Set l)) ty1 ty2) 564 | tc Nothing (Meta x args) = do 565 | val <- metaValue x args 566 | case val of 567 | Just x' -> tc Nothing x' -- eagerly get rid of known metas 568 | Nothing -> do 569 | ty <- metaType x args 570 | -- TODO: should I typecheck the args? 571 | return (Meta x args, ty) 572 | 573 | tc (Just ty) x = do 574 | (x',tx) <- tc Nothing x 575 | ty'' <- unify ty tx 576 | `annError` (text "When checkinging that" <+> tcPpr 0 x' $/$ (text "has type" <+> tcPpr 0 ty)) 577 | return (x',ty'') 578 | 579 | -- check that x is a type, return its level 580 | tcType :: Exp -> TcM (Exp, Level) 581 | tcType x = do 582 | (x',l) <- tc Nothing x 583 | l' <- unifySet l 584 | return (x',l') 585 | 586 | -- two possible sources of type signatures: inside the expression, and from the type argument to tc 587 | tcMType :: Maybe Exp -> Exp -> TcM (Maybe Exp) 588 | tcMType Nothing Blank = return Nothing 589 | tcMType Nothing ty = Just . fst <$> tcType ty 590 | tcMType (Just ty) Blank = return $ Just ty 591 | tcMType (Just ty) ty' = do 592 | ty'' <- fst <$> tcType ty' 593 | Just <$> unify ty ty'' 594 | 595 | tcBoundType :: Exp -> Bound Exp -> TcM (Bound Exp, Level) 596 | tcBoundType x (Bound n y) = do 597 | (y',l) <- localBound (named n x) $ tcType y 598 | return (Bound n y', l) 599 | 600 | -------------------------------------------------------------------------------- /src/Util/MyPrelude.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, FlexibleInstances, TypeSynonymInstances, RankNTypes #-} 2 | {-# LANGUAGE ViewPatterns, PatternSynonyms #-} 3 | {-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-orphans #-} 4 | 5 | -- | 6 | -- A more generic variant of the standard Prelude. 7 | -- Uses Functor, Foldable, Traversable instead of List specific functions where appropriate. 8 | -- Exports a lot of monad transformers. 9 | -- And contains some generic utility functions 10 | module Util.MyPrelude 11 | ( -- prelude stuff 12 | -- reexported, because I want to exclude list functions, 13 | -- instead use Foldable/Traversable 14 | Eq(..), Ord(..) 15 | , Show(..), ShowS, shows, showString, showParen 16 | , Num(..), Integral(..), fromIntegral, Real(..), Fractional(..), RealFrac(..), subtract 17 | , Enum(..) 18 | , Read(..), read 19 | , id, (.), ($), flip, const 20 | , fst, snd, curry, uncurry 21 | , first, second, (***) 22 | , seq 23 | , Int 24 | , Char, String, (++), (!!) 25 | , sort, sortBy 26 | , take, drop, takeWhile, dropWhile, reverse 27 | , zip, zipWith, zipWith3, zipWith4 28 | , iterate, head, tail, init, last, filter 29 | , Monad(..), join, when, unless, (=<<), (>=>), (<=<), ap, liftM, liftM2 30 | , zipWithM 31 | , MonadPlus(..), guard 32 | , error, undefined 33 | , MonadTrans(..) 34 | , module Data.Bool 35 | , module Data.Maybe 36 | , module Data.Either 37 | , module Data.Foldable 38 | , module Data.Traversable 39 | , module Data.Functor 40 | , module Control.Applicative 41 | , module Data.Monoid 42 | , module Data.Ord 43 | , module Data.Void 44 | -- io stuff 45 | , module System.IO 46 | -- more 47 | , module Util.MyPrelude 48 | , Seq, (|>), (<|) 49 | , Set 50 | , IM.IntMap 51 | , Map.Map 52 | , Identity(..) 53 | --, Constant(..) -- use Control.Applicative.Const 54 | , Compose(..) 55 | , MonadError(..), ExceptT(..), runExceptT, Except 56 | , ReaderT(..), MonadReader(..), Reader, runReader, asks 57 | , StateT(..), MonadState(..), State, evalState, execState, runState, evalStateT, execStateT, gets, modify 58 | , WriterT(..), MonadWriter(..), Writer, runWriter, execWriter, execWriterT 59 | , MonadFix(..) 60 | , module Control.Monad.Trans.Maybe 61 | , IdentityT(..) 62 | ) where 63 | 64 | import Prelude hiding (map,mapM,concat,foldr,foldl,any) 65 | import qualified Data.IntMap.Strict as IM 66 | import qualified Data.Set as Set 67 | import qualified Data.Map.Strict as Map 68 | import qualified Data.Sequence as Seq 69 | import Data.Sequence (Seq,ViewL(..),ViewR(..),(<|),(|>)) 70 | import Data.Set (Set) 71 | import Data.Graph (stronglyConnComp, SCC(..)) 72 | import Data.Foldable 73 | import Data.Traversable 74 | import Data.Functor 75 | import Control.Monad hiding (mapM,mapM_) 76 | import Control.Monad.Identity hiding (mapM,mapM_) 77 | import Data.Functor.Constant 78 | import Data.Functor.Compose 79 | import Control.Monad.Reader hiding (mapM,mapM_) 80 | import Control.Monad.State.Strict hiding (mapM,mapM_) 81 | import Control.Monad.Except hiding (mapM,mapM_) 82 | import Control.Monad.Writer hiding (mapM,mapM_) 83 | import Control.Monad.Trans 84 | import Control.Monad.Trans.Maybe 85 | import Control.Monad.Trans.Identity (IdentityT(..)) 86 | import Control.Applicative 87 | import Control.Arrow (first,second,(***)) 88 | import Data.Monoid 89 | import Data.Bool 90 | import Data.Maybe 91 | import Data.Either 92 | import Data.Function 93 | import Data.Ord 94 | import Data.List (intersperse,sort,sortBy,group,groupBy,zipWith3,zipWith4) 95 | import Data.Void 96 | 97 | import System.IO 98 | 99 | -- for debug code 100 | import Debug.Trace 101 | import Data.IORef 102 | import System.IO.Unsafe 103 | import Control.Exception 104 | 105 | -------------------------------------------------------------------------------- 106 | -- Prelude style utilities 107 | -------------------------------------------------------------------------------- 108 | 109 | map :: Functor f => (a -> b) -> f a -> f b 110 | map = fmap 111 | 112 | infixr 9 .: 113 | (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d 114 | (.:) f g x y = f (g x y) 115 | 116 | map2 :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) 117 | map2 = map . map 118 | 119 | traverse2 :: (Traversable t, Applicative f, Applicative g) => (a -> f (g b)) -> t a -> f (g (t b)) 120 | traverse2 f = getCompose . traverse (Compose . f) 121 | 122 | --snub :: Ord a => [a] -> [a] 123 | --snub = map head . group . sort 124 | 125 | nubOrd :: Ord a => [a] -> [a] 126 | nubOrd = nubOrdWith id 127 | 128 | nubOrdWith :: Ord b => (a -> b) -> [a] -> [a] 129 | nubOrdWith f = go Set.empty 130 | where 131 | go _ [] = [] 132 | go seen (x:xs) 133 | | f x `Set.member` seen = go seen xs 134 | | otherwise = x : go (Set.insert (f x) seen) xs 135 | 136 | sortWith :: Ord b => (a -> b) -> [a] -> [a] 137 | sortWith f = sortBy (comparing f) 138 | 139 | findDuplicates :: Ord a => [a] -> [a] 140 | findDuplicates = map head . filter (not . null . drop 1) . group . sort 141 | 142 | trySubtract :: Int -> Int -> Maybe Int 143 | trySubtract i j 144 | | i <= j = Just (j - i) 145 | | otherwise = Nothing 146 | 147 | -------------------------------------------------------------------------------- 148 | -- Tuples 149 | -------------------------------------------------------------------------------- 150 | 151 | fst3 :: (a,b,c) -> a 152 | fst3 (a,_,_) = a 153 | 154 | snd3 :: (a,b,c) -> b 155 | snd3 (_,b,_) = b 156 | 157 | thd3 :: (a,b,c) -> c 158 | thd3 (_,_,c) = c 159 | 160 | traversePair :: Applicative f => (a -> f c) -> (b -> f d) -> (a,b) -> f (c,d) 161 | traversePair f g (x,y) = (,) <$> f x <*> g y 162 | 163 | -------------------------------------------------------------------------------- 164 | -- Monad utilities 165 | -------------------------------------------------------------------------------- 166 | 167 | concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] 168 | concatMapM f xs = liftM concat (mapM f xs) 169 | 170 | infixr 2 <&&>, &&> 171 | 172 | local' :: (r -> r') -> ReaderT r' f a -> ReaderT r f a 173 | local' f x = ReaderT $ \r -> runReaderT x (f r) 174 | 175 | -- | Shortcutting version of @(&&)@ 176 | (&&>) :: Monad m => Bool -> m Bool -> m Bool 177 | False &&> _ = return False 178 | True &&> x = x 179 | 180 | -- | Shortcutting version of @(&&)@ 181 | (<&&>) :: Monad m => m Bool -> m Bool -> m Bool 182 | mx <&&> my = mx >>= (&&> my) 183 | 184 | -- | Shortcutting version of @and@ 185 | andM :: Monad m => [m Bool] -> m Bool 186 | andM = foldr (<&&>) (return True) 187 | 188 | orElseNothing :: (Applicative m, MonadError e m) => m a -> m (Maybe a) 189 | orElseNothing x = catchError (Just <$> x) (\_ -> pure Nothing) 190 | 191 | -------------------------------------------------------------------------------- 192 | -- Show utilities 193 | -------------------------------------------------------------------------------- 194 | 195 | catShows :: [ShowS] -> ShowS 196 | catShows = foldr (.) id 197 | 198 | showListWithSep :: String -> (a -> ShowS) -> [a] -> ShowS 199 | showListWithSep sep sh = catShows . intersperse (showString sep) . map sh 200 | 201 | -------------------------------------------------------------------------------- 202 | -- IntMap utilities 203 | -------------------------------------------------------------------------------- 204 | 205 | -- | Return a key that is not in the given map. 206 | freshKey :: IM.IntMap a -> Int 207 | freshKey xs 208 | | IM.null xs = 0 209 | | otherwise = fst (IM.findMax xs) + 1 210 | 211 | -------------------------------------------------------------------------------- 212 | -- Seq utilities 213 | -------------------------------------------------------------------------------- 214 | 215 | pattern Empty <- (Seq.viewl -> Seq.EmptyL) 216 | pattern x :< xs <- (Seq.viewl -> x Seq.:< xs) 217 | pattern xs :> x <- (Seq.viewr -> xs Seq.:> x) 218 | 219 | seqZipWithM :: Applicative m => (a -> b -> m c) -> Seq a -> Seq b -> m (Seq c) 220 | seqZipWithM f a b = sequenceA (Seq.zipWith f a b) 221 | 222 | seqZipWithM_ :: Applicative m => (a -> b -> m ()) -> Seq a -> Seq b -> m () 223 | seqZipWithM_ f a b = sequenceA_ (Seq.zipWith f a b) 224 | 225 | seqCatMaybes :: Seq (Maybe a) -> Seq a 226 | seqCatMaybes = foldl (\xs x -> maybe xs (xs |>) x) empty 227 | 228 | seqLookup :: Int -> Seq a -> Maybe a 229 | seqLookup i s 230 | | 0 <= i && i < Seq.length s = Just (Seq.index s i) 231 | | otherwise = Nothing 232 | 233 | -------------------------------------------------------------------------------- 234 | -- Graph 235 | -------------------------------------------------------------------------------- 236 | 237 | type Graph a = Map.Map a [a] 238 | 239 | isAcyclic :: (Show a, Ord a) => Graph a -> Bool 240 | isAcyclic = isNothing . findCycle 241 | 242 | data Line a =Line a 243 | instance Show a => Show (Line a) where show (Line x) = show x ++ "\n" 244 | 245 | -- | Find a cycle if one exists 246 | findCycle :: (Show a, Ord a) => Graph a -> Maybe [a] 247 | findCycle g = listToMaybe 248 | [ c | CyclicSCC c <- stronglyConnComp g' ] 249 | where 250 | g' = [(x,x,ys) | (x,ys) <- Map.toList g] 251 | 252 | graphSinks :: Graph a -> [a] 253 | graphSinks g = [ x | (x,ys) <- Map.toList g, null ys ] 254 | 255 | graphSources :: Ord a => Graph a -> [a] 256 | graphSources = graphSinks . reverseGraph 257 | 258 | reverseGraph :: Ord a => Graph a -> Graph a 259 | reverseGraph g = Map.fromListWith (++) ([ (x,[]) | x <- Map.keys g ] 260 | ++ [ (y,[x]) | (x,ys) <- Map.toList g, y <- ys ]) 261 | 262 | -------------------------------------------------------------------------------- 263 | -- Debug utilities 264 | -------------------------------------------------------------------------------- 265 | 266 | --debug :: Bool 267 | --debug = False 268 | 269 | -- use class to prevent CAF memoization 270 | class IsBool a where 271 | fromBool :: Bool -> a 272 | instance IsBool Bool where 273 | fromBool = id 274 | 275 | debugVar :: IORef Bool 276 | debugVar = unsafePerformIO $ newIORef True -- default debugging 277 | {-# NOINLINE debugVar #-} 278 | 279 | -- enable/disable trace messages at runtime (from GHCi) 280 | enableDebug :: Bool -> IO () 281 | enableDebug = writeIORef debugVar 282 | 283 | tracedIO :: String -> IO a -> IO a 284 | tracedIO msg mx = do 285 | debug <- readIORef debugVar 286 | if debug 287 | then bracket (readIORef traceLevel >>= \lvl -> writeIORef traceLevel (succ lvl) >> return lvl) 288 | (writeIORef traceLevel) $ \lvl -> do 289 | putStrLn (replicate (2*lvl) ' ' ++ msg) 290 | mx 291 | else mx 292 | 293 | traced :: String -> a -> a 294 | traced msg x = unsafePerformIO $ tracedIO msg (evaluate x) 295 | 296 | traceM :: Monad m => String -> m () 297 | traceM msg = traced msg (return ()) 298 | 299 | {- 300 | debug :: IsBool a => a 301 | debug = unsafePerformIO $ fromBool <$> readIORef debugVar 302 | {-# INLINE debug #-} 303 | 304 | traceM :: Monad m => String -> m () 305 | traceM x = tracedM x $ return () 306 | 307 | tracedM :: Monad m => String -> m a -> m a 308 | tracedM msg x = do 309 | foo1 <- unsafePerformIO $ do 310 | lvl <- readIORef traceLevel 311 | when debug $ putStrLn (replicate (2*lvl) ' ' ++ msg) 312 | return $ return () 313 | foo2 <- foo1 `seq` unsafePerformIO $ modifyIORef' traceLevel (+1) >> return (return ()) 314 | a <- foo2 `seq` x 315 | foo3 <- foo2 `seq` unsafePerformIO $ modifyIORef' traceLevel (subtract 1) >> return (return ()) -- doesn't work with exceptions 316 | foo3 `seq` return a 317 | 318 | traceBracket :: a -> a 319 | traceBracket x = unsafePerformIO $ 320 | bracket (readIORef traceLevel) (writeIORef traceLevel) (\_ -> evaluate x) 321 | 322 | tracedM' :: Monad m => m String -> m a -> m a 323 | tracedM' msg x = do 324 | m <- msg 325 | tracedM m x 326 | -} 327 | 328 | {-# NOINLINE traceLevel #-} 329 | traceLevel :: IORef Int 330 | traceLevel = unsafePerformIO $ newIORef 0 331 | 332 | traceLevel0 :: IO () 333 | traceLevel0 = writeIORef traceLevel 0 334 | 335 | fromLeft :: Show b => Either a b -> a 336 | fromLeft (Right x) = error $ "fromLeft: Right " ++ show x 337 | fromLeft (Left x) = x 338 | 339 | fromRight :: Show a => Either a b -> b 340 | fromRight (Right x) = x 341 | fromRight (Left x) = error $ "fromRight: Left " ++ show x 342 | 343 | -------------------------------------------------------------------------------- /src/Util/Parser.hs: -------------------------------------------------------------------------------- 1 | module Util.Parser 2 | ( module Util.Parser 3 | , (), P.many1, P.sepBy, P.try, P.eof, P.unexpected 4 | ) where 5 | 6 | import Prelude () 7 | import Util.MyPrelude 8 | 9 | import qualified Text.Parsec as P 10 | import Text.Parsec (()) 11 | 12 | -------------------------------------------------------------------------------- 13 | -- Running parsers 14 | -------------------------------------------------------------------------------- 15 | 16 | runParser :: Parser a -> FilePath -> String -> Either P.ParseError a 17 | runParser p = P.runParser p Nothing 18 | 19 | testParser :: Parser a -> String -> a 20 | testParser p = fromRight . runParser p "input" 21 | 22 | -------------------------------------------------------------------------------- 23 | -- Indentation handling 24 | -------------------------------------------------------------------------------- 25 | 26 | -- | A parser that understands indentation 27 | type Parser = P.Parsec String Indent 28 | type Indent = Maybe P.SourcePos 29 | 30 | noIndent :: Indent 31 | noIndent = Nothing 32 | 33 | -- succeed only if indentation is (>) reference, or token is on the same line 34 | indented :: Parser () 35 | indented = do 36 | mr <- P.getState 37 | p <- P.getPosition 38 | case mr of 39 | Nothing -> return () 40 | Just r 41 | | P.sourceColumn p > P.sourceColumn r 42 | || P.sourceLine p == P.sourceLine r -> return () 43 | _ -> fail $ "indentation expected: " ++ show mr ++ " got " ++ show p 44 | 45 | -- succeed only if indentation is (==) reference 46 | notIndented :: Parser () 47 | notIndented = do 48 | mr <- P.getState 49 | p <- P.getPosition 50 | case mr of 51 | Just r 52 | | P.sourceColumn p == P.sourceColumn r -> return () 53 | _ -> fail $ "no indentation expected: " ++ show mr ++ " got " ++ show p 54 | 55 | localState :: st -> P.Parsec s st a -> P.Parsec s st a 56 | localState stLocal p = do 57 | st <- P.getState 58 | P.putState stLocal 59 | a <- p 60 | P.putState st 61 | return a 62 | 63 | -- set reference indentation level 64 | withIndentation :: Parser a -> Parser a 65 | withIndentation x = do 66 | p <- P.getPosition 67 | localState (Just p) x 68 | 69 | withoutIndentation :: Parser a -> Parser a 70 | withoutIndentation = localState noIndent 71 | 72 | -------------------------------------------------------------------------------- 73 | -- Utility combinators 74 | -------------------------------------------------------------------------------- 75 | 76 | -- parse left associative operator 77 | parseChainL :: Parser (a -> b -> a) -> Parser a -> Parser b -> Parser a 78 | parseChainL psep px py = px `optFollowedByMany` \x -> psep <*> pure x <*> py 79 | 80 | parseChainL' :: (a -> Parser (b -> a)) -> Parser a -> Parser b -> Parser a 81 | parseChainL' psep px py = px `optFollowedByMany` \x -> psep x <*> py 82 | 83 | -- parse optional non-associative operator 84 | parseChainN :: Parser (a -> b -> a) -> Parser a -> Parser b -> Parser a 85 | parseChainN psep px py = px `optFollowedBy` \x -> psep <*> pure x <*> py 86 | 87 | optFollowedBy :: Parser a -> (a -> Parser a) -> Parser a 88 | optFollowedBy px py = px >>= (\x -> py x <|> return x) 89 | 90 | optFollowedByMany :: Parser a -> (a -> Parser a) -> Parser a 91 | optFollowedByMany px py = px >>= go 92 | where go x = (py x >>= go) <|> return x 93 | 94 | -------------------------------------------------------------------------------- /src/Util/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE CPP #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | #define USE_HUGHES_PJ 0 7 | 8 | module Util.Pretty 9 | ( module Util.Pretty 10 | #if USE_HUGHES_PJ 11 | , module Text.PrettyPrint.HughesPJ 12 | #elif USE_REAL_WL_PPRINT 13 | , module Text.PrettyPrint.Leijen 14 | #else 15 | , module Util.WLPPrint 16 | #endif 17 | ) where 18 | 19 | import Prelude () 20 | import Util.MyPrelude 21 | 22 | #if USE_HUGHES_PJ 23 | import Text.PrettyPrint.HughesPJ hiding ((<>),($$),(<+>),first) 24 | import qualified Text.PrettyPrint.HughesPJ as PP 25 | #elif USE_REAL_WL_PPRINT 26 | import Text.PrettyPrint.Leijen hiding (Pretty,empty,pretty,($$),(<$$>),(<>),(),()) 27 | import qualified Text.PrettyPrint.Leijen as PP 28 | #else 29 | import Util.WLPPrint hiding (Pretty,empty,pretty,($$),(<$$>),(<>)) 30 | import qualified Util.WLPPrint as PP 31 | #endif 32 | 33 | -------------------------------------------------------------------------------- 34 | -- Utilities 35 | -------------------------------------------------------------------------------- 36 | 37 | #if USE_HUGHES_PJ 38 | infixr 5 ,$$ 39 | infixr 6 <+> 40 | 41 | ($$) :: Doc -> Doc -> Doc 42 | ($$) = (PP.$+$) 43 | 44 | (<+>) :: Doc -> Doc -> Doc 45 | (<+>) = (PP.<+>) 46 | 47 | () :: Doc -> Doc -> Doc 48 | x y = PP.sep [x,y] 49 | 50 | indent :: Int -> Doc -> Doc 51 | indent = nest 52 | 53 | align :: Doc -> Doc 54 | align = id 55 | 56 | showDoc :: Doc -> String 57 | showDoc = render 58 | 59 | #else 60 | instance Monoid Doc where 61 | mempty = PP.empty 62 | mappend = (PP.<>) 63 | 64 | infixr 5 $$ 65 | 66 | showDoc :: Doc -> String 67 | showDoc = flip displayS "" . renderPretty 0.8 110 68 | 69 | ($$) :: Doc -> Doc -> Doc 70 | ($$) = (PP.$$) 71 | 72 | ($-$) :: Doc -> Doc -> Doc 73 | ($-$) = (PP.<$$>) 74 | #endif 75 | 76 | --instance Error Doc where 77 | -- noMsg = PP.empty 78 | -- strMsg = text 79 | 80 | failDoc :: Monad m => Doc -> m a 81 | failDoc = fail . showDoc 82 | 83 | -------------------------------------------------------------------------------- 84 | -- Monadic/applicative 85 | -------------------------------------------------------------------------------- 86 | 87 | (<$$>), (<<>>), (<<+>>), (<$/$>) :: Applicative m => m Doc -> m Doc -> m Doc 88 | (<$$>) = liftA2 ($$) 89 | (<<>>) = liftA2 (<>) 90 | (<<+>>) = liftA2 (<+>) 91 | (<$/$>) = liftA2 ($/$) 92 | 93 | textM :: Applicative m => String -> m Doc 94 | textM = pure . text 95 | 96 | nestM :: Functor m => Int -> m Doc -> m Doc 97 | nestM n = fmap (nest n) 98 | 99 | indentM :: Functor m => Int -> m Doc -> m Doc 100 | indentM n = fmap (indent n) 101 | 102 | groupM :: Functor m => m Doc -> m Doc 103 | groupM = fmap group 104 | 105 | groupsM :: Applicative m => [m Doc] -> m Doc 106 | groupsM = fmap groups . sequenceA 107 | 108 | -------------------------------------------------------------------------------- 109 | -- Pretty printing class 110 | -------------------------------------------------------------------------------- 111 | 112 | -- | Things that can be pretty printed 113 | class Pretty a where 114 | ppr :: Int -> a -> Doc 115 | pretty :: a -> String 116 | pretty = showDoc . ppr 0 117 | default ppr :: Show a => Int -> a -> Doc 118 | ppr p x = text (showsPrec p x "") 119 | 120 | instance Pretty String where 121 | ppr _ = text 122 | 123 | instance Pretty Doc where 124 | ppr _ = id 125 | 126 | instance Pretty Int where 127 | ppr _ = text . show 128 | 129 | instance Pretty () where 130 | instance Pretty Void where 131 | 132 | instance (Pretty a, Pretty b) => Pretty (a,b) where 133 | ppr _ (x,y) = parens (ppr 0 x <> comma <+> ppr 0 y) 134 | 135 | instance (Pretty a, Pretty b) => Pretty (Either a b) where 136 | ppr p (Left x) = parenIf (p>0) $ text "Left " <+> ppr 0 x 137 | ppr p (Right x) = parenIf (p>0) $ text "Right" <+> ppr 0 x 138 | 139 | class Pretty1 f where 140 | ppr1 :: Pretty a => Int -> f a -> Doc 141 | 142 | -------------------------------------------------------------------------------- 143 | -- Pretty printing utilities 144 | -------------------------------------------------------------------------------- 145 | 146 | parenIf :: Bool -> Doc -> Doc 147 | parenIf True = parens 148 | parenIf False = id 149 | 150 | alignIf :: Bool -> Doc -> Doc 151 | alignIf True = align 152 | alignIf False = id 153 | 154 | semiBrackets :: [Doc] -> Doc 155 | semiBrackets = encloseSep lbracket rbracket semi 156 | 157 | -------------------------------------------------------------------------------- /src/Util/PrettyM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module Util.PrettyM 7 | ( module Util.PrettyM 8 | , Doc 9 | ) where 10 | 11 | import Prelude () 12 | import Util.MyPrelude 13 | 14 | import Util.WLPPrint (Doc) 15 | import qualified Util.WLPPrint as PP 16 | 17 | -------------------------------------------------------------------------------- 18 | -- Utilities 19 | -------------------------------------------------------------------------------- 20 | 21 | instance Monoid Doc where 22 | mempty = PP.empty 23 | mappend = (PP.<>) 24 | 25 | infixr 4 $$,$-$ 26 | infixl 5 $/$ 27 | infixr 6 <.>,<+> 28 | 29 | showDoc :: Doc -> String 30 | showDoc = flip PP.displayS "" . PP.renderPretty 0.9 120 31 | 32 | showsDoc :: Doc -> ShowS 33 | showsDoc = showString . showDoc 34 | 35 | ($$),(<.>),(<+>),($/$),($-$) :: Applicative m => m Doc -> m Doc -> m Doc 36 | ($$) = liftA2 (PP.$$) 37 | (<.>) = liftA2 (PP.<>) 38 | (<+>) = liftA2 (PP.<+>) 39 | ($/$) = liftA2 (PP.$/$) 40 | ($-$) = liftA2 (PP.<$$>) 41 | 42 | -------------------------------------------------------------------------------- 43 | -- Monadic/applicative wrappers 44 | -------------------------------------------------------------------------------- 45 | 46 | emptyDoc :: Applicative m => m Doc 47 | emptyDoc = pure PP.empty 48 | 49 | text :: Applicative m => String -> m Doc 50 | text = pure . PP.text 51 | 52 | int :: Applicative m => Int -> m Doc 53 | int = pure . PP.int 54 | 55 | nest :: Functor m => Int -> m Doc -> m Doc 56 | nest n = fmap (PP.nest n) 57 | 58 | indent :: Functor m => Int -> m Doc -> m Doc 59 | indent n = fmap (PP.indent n) 60 | 61 | group, align, flatten, parens, angles, braces, brackets :: Functor m => m Doc -> m Doc 62 | group = fmap PP.group 63 | align = fmap PP.align 64 | flatten = fmap PP.flatten 65 | parens = fmap PP.parens 66 | angles = fmap PP.angles 67 | braces = fmap PP.braces 68 | brackets = fmap PP.brackets 69 | 70 | groups, hsep, hcat, vcat :: Applicative m => [m Doc] -> m Doc 71 | groups = fmap PP.groups . sequenceA 72 | hsep = fmap PP.hsep . sequenceA 73 | hcat = fmap PP.hcat . sequenceA 74 | vcat = fmap PP.vcat . sequenceA 75 | 76 | encloseSep :: Applicative m => m Doc -> m Doc -> m Doc -> [m Doc] -> m Doc 77 | encloseSep a b c d = PP.encloseSep <$> a <*> b <*> c <*> sequenceA d 78 | 79 | lbracket, rbracket, lparen, rparen, lbrace, rbrace, comma, semi :: Applicative m => m Doc 80 | lbracket = pure PP.lbracket 81 | rbracket = pure PP.rbracket 82 | lparen = pure PP.lparen 83 | rparen = pure PP.rparen 84 | lbrace = pure PP.lbrace 85 | rbrace = pure PP.rbrace 86 | comma = pure PP.comma 87 | semi = pure PP.semi 88 | 89 | -------------------------------------------------------------------------------- 90 | -- Pretty printing class 91 | -------------------------------------------------------------------------------- 92 | 93 | -- | Things that can be pretty printed 94 | class Applicative m => Pretty m a where 95 | ppr :: Int -> a -> m Doc 96 | default ppr :: Show a => Int -> a -> m Doc 97 | ppr p x = text (showsPrec p x "") 98 | 99 | ppr' :: Pretty Identity a => a -> Doc 100 | ppr' = runIdentity . ppr 0 101 | 102 | pretty :: Pretty Identity a => a -> String 103 | pretty = showDoc . ppr' 104 | 105 | instance Applicative m => Pretty m String where 106 | ppr _ = text 107 | 108 | instance Applicative m => Pretty m Doc where 109 | ppr _ = pure 110 | 111 | instance Applicative m => Pretty m Int where 112 | ppr _ = int 113 | 114 | instance Applicative m => Pretty m () where 115 | instance Applicative m => Pretty m Void where 116 | instance Applicative m => Pretty m Bool where 117 | 118 | instance (Pretty m a, Pretty m b) => Pretty m (a,b) where 119 | ppr _ (x,y) = parens (ppr 0 x <.> comma <+> ppr 0 y) 120 | 121 | instance (Pretty m a, Pretty m b, Pretty m c) => Pretty m (a,b,c) where 122 | ppr _ (x,y,z) = parens (ppr 0 x <.> comma <+> ppr 0 y <.> comma <+> ppr 0 z) 123 | 124 | instance (Pretty m a, Pretty m b) => Pretty m (Either a b) where 125 | ppr p (Left x) = parenIf (p>0) $ text "Left " <+> ppr 0 x 126 | ppr p (Right x) = parenIf (p>0) $ text "Right" <+> ppr 0 x 127 | 128 | class Pretty1 m f where 129 | ppr1 :: Pretty m a => Int -> f a -> m Doc 130 | 131 | -------------------------------------------------------------------------------- 132 | -- Pretty printing utilities 133 | -------------------------------------------------------------------------------- 134 | 135 | parenIf :: Functor m => Bool -> m Doc -> m Doc 136 | parenIf True = parens 137 | parenIf False = id 138 | 139 | alignIf :: Functor m => Bool -> m Doc -> m Doc 140 | alignIf True = align 141 | alignIf False = id 142 | 143 | parenAlignIf :: Functor m => Bool -> m Doc -> m Doc 144 | parenAlignIf True = parens . align 145 | parenAlignIf False = id 146 | 147 | semiBrackets, semiBraces, commaBrackets :: Applicative m => [m Doc] -> m Doc 148 | semiBrackets = encloseSep lbracket rbracket semi 149 | semiBraces = encloseSep lbrace rbrace semi 150 | commaBrackets = encloseSep lbracket rbracket comma 151 | 152 | -------------------------------------------------------------------------------- /src/Util/Tagged/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | -- | Tagged integers 3 | module Util.Tagged.Internal where 4 | 5 | -------------------------------------------------------------------------------- 6 | -- Wrapped Int 7 | -------------------------------------------------------------------------------- 8 | 9 | newtype TaggedVar tag = TV { tv :: Int } 10 | deriving (Eq) 11 | 12 | instance Show (TaggedVar tag) where 13 | show = showString "?" . show . tv 14 | 15 | -------------------------------------------------------------------------------- /src/Util/Tagged/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveTraversable #-} 3 | -- | Maps of tagged integers 4 | module Util.Tagged.Map where 5 | 6 | import Util.MyPrelude 7 | import Util.Tagged.Internal 8 | 9 | import Data.IntMap as IM 10 | 11 | -------------------------------------------------------------------------------- 12 | -- Wrapped IntMap 13 | -------------------------------------------------------------------------------- 14 | 15 | newtype TaggedMap tag a = TM { tm :: IntMap a } 16 | deriving (Functor,Foldable,Traversable,Eq) 17 | 18 | empty :: TaggedMap tag a 19 | empty = TM IM.empty 20 | 21 | null :: TaggedMap tag a -> Bool 22 | null = IM.null . tm 23 | 24 | singleton :: TaggedVar tag -> a -> TaggedMap tag a 25 | singleton (TV x) y = TM (IM.singleton x y) 26 | 27 | insert :: TaggedVar tag -> a -> TaggedMap tag a -> TaggedMap tag a 28 | insert (TV x) y (TM z) = TM (IM.insert x y z) 29 | 30 | unionWith :: (a -> a -> a) -> TaggedMap tag a -> TaggedMap tag a -> TaggedMap tag a 31 | unionWith f (TM x) (TM y) = TM (IM.unionWith f x y) 32 | 33 | toList :: TaggedMap tag a -> [(TaggedVar tag, a)] 34 | toList = Prelude.map (first TV) . IM.toList . tm 35 | 36 | mapMaybe :: (a -> Maybe b) -> TaggedMap tag a -> TaggedMap tag b 37 | mapMaybe f = TM . IM.mapMaybe f . tm 38 | -------------------------------------------------------------------------------- /src/Util/Tagged/Seq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveTraversable #-} 3 | -- | Dense maps of tagged integers 4 | module Util.Tagged.Seq where 5 | 6 | import Prelude () 7 | import Util.MyPrelude as P 8 | import Util.Tagged.Internal 9 | 10 | import qualified Data.Sequence as Seq 11 | 12 | -------------------------------------------------------------------------------- 13 | -- Wrapped Seq, used as a dense map 14 | -------------------------------------------------------------------------------- 15 | 16 | newtype TaggedSeq tag a = TS { ts :: Seq a } 17 | deriving (Functor,Foldable,Traversable,Eq) 18 | 19 | empty :: TaggedSeq tag a 20 | empty = TS Seq.empty 21 | 22 | null :: TaggedSeq tag a -> Bool 23 | null = Seq.null . ts 24 | 25 | -- insert a new variable at the end 26 | insertNew :: a -> TaggedSeq tag a -> (TaggedVar tag, TaggedSeq tag a) 27 | insertNew y (TS z) = (TV (Seq.length z), TS (z |> y)) 28 | 29 | get :: TaggedVar tag -> TaggedSeq tag a -> a 30 | get (TV x) (TS y) = Seq.index y x 31 | 32 | modify :: (a -> a) -> TaggedVar tag -> TaggedSeq tag a -> TaggedSeq tag a 33 | modify f (TV x) (TS y) = TS (Seq.adjust f x y) 34 | 35 | toList :: TaggedSeq tag a -> [(TaggedVar tag, a)] 36 | toList = zip (map TV [0..]) . P.toList . ts 37 | 38 | -------------------------------------------------------------------------------- /src/Util/Tagged/Var.hs: -------------------------------------------------------------------------------- 1 | -- | Tagged integers, constructor and destructor are hidden. 2 | -- This provides some type safety by making it impossible to mix different variable types. 3 | module Util.Tagged.Var (TaggedVar) where 4 | 5 | import Util.Tagged.Internal 6 | 7 | -------------------------------------------------------------------------------- /src/Util/WLPPrint.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-missing-signatures #-} 2 | 3 | 4 | -- | A copy of Text.PrettyPrint.Leijen 5 | -- 6 | -- Differences: 7 | -- * @union@ and @flatten@ are exposed 8 | -- * added @groups@, for grouping on multiple lines 9 | ----------------------------------------------------------- 10 | module Util.WLPPrint ( 11 | -- * Documents 12 | Doc, putDoc, hPutDoc, 13 | 14 | -- * Basic combinators 15 | empty, char, text, (<>), nest, line, linebreak, group, softline, 16 | softbreak, 17 | 18 | -- * Alignment 19 | -- 20 | -- The combinators in this section can not be described by Wadler's 21 | -- original combinators. They align their output relative to the 22 | -- current output position - in contrast to @nest@ which always 23 | -- aligns to the current nesting level. This deprives these 24 | -- combinators from being \`optimal\'. In practice however they 25 | -- prove to be very useful. The combinators in this section should 26 | -- be used with care, since they are more expensive than the other 27 | -- combinators. For example, @align@ shouldn't be used to pretty 28 | -- print all top-level declarations of a language, but using @hang@ 29 | -- for let expressions is fine. 30 | align, hang, indent, encloseSep, list, tupled, semiBraces, 31 | 32 | -- * Operators 33 | (<+>), ($$), (), (<$$>), (), 34 | 35 | -- * List combinators 36 | hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate, 37 | 38 | -- * Fillers 39 | fill, fillBreak, 40 | 41 | -- * Bracketing combinators 42 | enclose, squotes, dquotes, parens, angles, braces, brackets, 43 | 44 | -- * Character documents 45 | lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket, 46 | squote, dquote, semi, colon, comma, space, dot, backslash, equals, 47 | 48 | -- * Primitive type documents 49 | string, int, integer, float, double, rational, 50 | 51 | -- * Pretty class 52 | Pretty(..), 53 | 54 | -- * Rendering 55 | SimpleDoc(..), renderPretty, renderCompact, displayS, displayIO 56 | 57 | -- * Undocumented 58 | , bool 59 | 60 | , column, nesting, width 61 | 62 | -- * Extra 63 | , unionDoc, flatten 64 | , groups, ($/$) 65 | ) where 66 | 67 | import System.IO (Handle,hPutStr,hPutChar,stdout) 68 | 69 | infixr 5 ,,$$,<$$> 70 | infixr 6 <>,<+> 71 | 72 | 73 | ----------------------------------------------------------- 74 | -- list, tupled and semiBraces pretty print a list of 75 | -- documents either horizontally or vertically aligned. 76 | ----------------------------------------------------------- 77 | 78 | 79 | -- | The document @(list xs)@ comma separates the documents @xs@ and 80 | -- encloses them in square brackets. The documents are rendered 81 | -- horizontally if that fits the page. Otherwise they are aligned 82 | -- vertically. All comma separators are put in front of the elements. 83 | list :: [Doc] -> Doc 84 | list = encloseSep lbracket rbracket comma 85 | 86 | -- | The document @(tupled xs)@ comma separates the documents @xs@ and 87 | -- encloses them in parenthesis. The documents are rendered 88 | -- horizontally if that fits the page. Otherwise they are aligned 89 | -- vertically. All comma separators are put in front of the elements. 90 | tupled :: [Doc] -> Doc 91 | tupled = encloseSep lparen rparen comma 92 | 93 | 94 | -- | The document @(semiBraces xs)@ separates the documents @xs@ with 95 | -- semi colons and encloses them in braces. The documents are rendered 96 | -- horizontally if that fits the page. Otherwise they are aligned 97 | -- vertically. All semi colons are put in front of the elements. 98 | semiBraces :: [Doc] -> Doc 99 | semiBraces = encloseSep lbrace rbrace semi 100 | 101 | -- | The document @(encloseSep l r sep xs)@ concatenates the documents 102 | -- @xs@ separated by @sep@ and encloses the resulting document by @l@ 103 | -- and @r@. The documents are rendered horizontally if that fits the 104 | -- page. Otherwise they are aligned vertically. All separators are put 105 | -- in front of the elements. For example, the combinator 'list' can be 106 | -- defined with @encloseSep@: 107 | -- 108 | -- > list xs = encloseSep lbracket rbracket comma xs 109 | -- > test = text "list" <+> (list (map int [10,200,3000])) 110 | -- 111 | -- Which is layed out with a page width of 20 as: 112 | -- 113 | -- @ 114 | -- list [10,200,3000] 115 | -- @ 116 | -- 117 | -- But when the page width is 15, it is layed out as: 118 | -- 119 | -- @ 120 | -- list [10 121 | -- ,200 122 | -- ,3000] 123 | -- @ 124 | encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc 125 | encloseSep left right sep ds 126 | = case ds of 127 | [] -> left <> right 128 | [d] -> left <> d <> right 129 | _ -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right) 130 | 131 | 132 | ----------------------------------------------------------- 133 | -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn] 134 | ----------------------------------------------------------- 135 | 136 | 137 | -- | @(punctuate p xs)@ concatenates all documents in @xs@ with 138 | -- document @p@ except for the last document. 139 | -- 140 | -- > someText = map text ["words","in","a","tuple"] 141 | -- > test = parens (align (cat (punctuate comma someText))) 142 | -- 143 | -- This is layed out on a page width of 20 as: 144 | -- 145 | -- @ 146 | -- (words,in,a,tuple) 147 | -- @ 148 | -- 149 | -- But when the page width is 15, it is layed out as: 150 | -- 151 | -- @ 152 | -- (words, 153 | -- in, 154 | -- a, 155 | -- tuple) 156 | -- @ 157 | -- 158 | -- (If you want put the commas in front of their elements instead of 159 | -- at the end, you should use 'tupled' or, in general, 'encloseSep'.) 160 | punctuate :: Doc -> [Doc] -> [Doc] 161 | punctuate p [] = [] 162 | punctuate p [d] = [d] 163 | punctuate p (d:ds) = (d <> p) : punctuate p ds 164 | 165 | 166 | ----------------------------------------------------------- 167 | -- high-level combinators 168 | ----------------------------------------------------------- 169 | 170 | 171 | -- | The document @(sep xs)@ concatenates all documents @xs@ either 172 | -- horizontally with @(\<+\>)@, if it fits the page, or vertically with 173 | -- @(\<$\>)@. 174 | -- 175 | -- > sep xs = group (vsep xs) 176 | sep :: [Doc] -> Doc 177 | sep = group . vsep 178 | 179 | -- | The document @(fillSep xs)@ concatenates documents @xs@ 180 | -- horizontally with @(\<+\>)@ as long as its fits the page, than 181 | -- inserts a @line@ and continues doing that for all documents in 182 | -- @xs@. 183 | -- 184 | -- > fillSep xs = foldr (\<\/\>) empty xs 185 | fillSep :: [Doc] -> Doc 186 | fillSep = fold () 187 | 188 | -- | The document @(hsep xs)@ concatenates all documents @xs@ 189 | -- horizontally with @(\<+\>)@. 190 | hsep :: [Doc] -> Doc 191 | hsep = fold (<+>) 192 | 193 | 194 | -- | The document @(vsep xs)@ concatenates all documents @xs@ 195 | -- vertically with @(\<$\>)@. If a 'group' undoes the line breaks 196 | -- inserted by @vsep@, all documents are separated with a space. 197 | -- 198 | -- > someText = map text (words ("text to lay out")) 199 | -- > 200 | -- > test = text "some" <+> vsep someText 201 | -- 202 | -- This is layed out as: 203 | -- 204 | -- @ 205 | -- some text 206 | -- to 207 | -- lay 208 | -- out 209 | -- @ 210 | -- 211 | -- The 'align' combinator can be used to align the documents under 212 | -- their first element 213 | -- 214 | -- > test = text "some" <+> align (vsep someText) 215 | -- 216 | -- Which is printed as: 217 | -- 218 | -- @ 219 | -- some text 220 | -- to 221 | -- lay 222 | -- out 223 | -- @ 224 | vsep :: [Doc] -> Doc 225 | vsep = fold ($$) 226 | 227 | -- | The document @(cat xs)@ concatenates all documents @xs@ either 228 | -- horizontally with @(\<\>)@, if it fits the page, or vertically with 229 | -- @(\<$$\>)@. 230 | -- 231 | -- > cat xs = group (vcat xs) 232 | cat :: [Doc] -> Doc 233 | cat = group . vcat 234 | 235 | -- | The document @(fillCat xs)@ concatenates documents @xs@ 236 | -- horizontally with @(\<\>)@ as long as its fits the page, than inserts 237 | -- a @linebreak@ and continues doing that for all documents in @xs@. 238 | -- 239 | -- > fillCat xs = foldr (\<\/\/\>) empty xs 240 | fillCat :: [Doc] -> Doc 241 | fillCat = fold () 242 | 243 | -- | The document @(hcat xs)@ concatenates all documents @xs@ 244 | -- horizontally with @(\<\>)@. 245 | hcat :: [Doc] -> Doc 246 | hcat = fold (<>) 247 | 248 | -- | The document @(vcat xs)@ concatenates all documents @xs@ 249 | -- vertically with @(\<$$\>)@. If a 'group' undoes the line breaks 250 | -- inserted by @vcat@, all documents are directly concatenated. 251 | vcat :: [Doc] -> Doc 252 | vcat = fold (<$$>) 253 | 254 | fold f [] = empty 255 | fold f ds = foldr1 f ds 256 | 257 | -- | The document @(x \<\> y)@ concatenates document @x@ and document 258 | -- @y@. It is an associative operation having 'empty' as a left and 259 | -- right unit. (infixr 6) 260 | (<>) :: Doc -> Doc -> Doc 261 | x <> y = x `beside` y 262 | 263 | -- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with a 264 | -- @space@ in between. (infixr 6) 265 | (<+>) :: Doc -> Doc -> Doc 266 | x <+> y = x <> space <> y 267 | 268 | -- | The document @(x \<\/\> y)@ concatenates document @x@ and @y@ with a 269 | -- 'softline' in between. This effectively puts @x@ and @y@ either 270 | -- next to each other (with a @space@ in between) or underneath each 271 | -- other. (infixr 5) 272 | () :: Doc -> Doc -> Doc 273 | x y = x <> softline <> y 274 | 275 | -- | The document @(x \<\/\/\> y)@ concatenates document @x@ and @y@ with 276 | -- a 'softbreak' in between. This effectively puts @x@ and @y@ either 277 | -- right next to each other or underneath each other. (infixr 5) 278 | () :: Doc -> Doc -> Doc 279 | x y = x <> softbreak <> y 280 | 281 | -- | The document @(x \<$\> y)@ concatenates document @x@ and @y@ with a 282 | -- 'line' in between. (infixr 5) 283 | ($$) :: Doc -> Doc -> Doc 284 | x $$ y = x <> line <> y 285 | 286 | -- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ with 287 | -- a @linebreak@ in between. (infixr 5) 288 | (<$$>) :: Doc -> Doc -> Doc 289 | x <$$> y = x <> linebreak <> y 290 | 291 | -- | The document @softline@ behaves like 'space' if the resulting 292 | -- output fits the page, otherwise it behaves like 'line'. 293 | -- 294 | -- > softline = group line 295 | softline :: Doc 296 | softline = group line 297 | 298 | -- | The document @softbreak@ behaves like 'empty' if the resulting 299 | -- output fits the page, otherwise it behaves like 'line'. 300 | -- 301 | -- > softbreak = group linebreak 302 | softbreak :: Doc 303 | softbreak = group linebreak 304 | 305 | -- | Document @(squotes x)@ encloses document @x@ with single quotes 306 | -- \"'\". 307 | squotes :: Doc -> Doc 308 | squotes = enclose squote squote 309 | 310 | -- | Document @(dquotes x)@ encloses document @x@ with double quotes 311 | -- '\"'. 312 | dquotes :: Doc -> Doc 313 | dquotes = enclose dquote dquote 314 | 315 | -- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and 316 | -- \"}\". 317 | braces :: Doc -> Doc 318 | braces = enclose lbrace rbrace 319 | 320 | -- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\" 321 | -- and \")\". 322 | parens :: Doc -> Doc 323 | parens = enclose lparen rparen 324 | 325 | -- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and 326 | -- \"\>\". 327 | angles :: Doc -> Doc 328 | angles = enclose langle rangle 329 | 330 | -- | Document @(brackets x)@ encloses document @x@ in square brackets, 331 | -- \"[\" and \"]\". 332 | brackets :: Doc -> Doc 333 | brackets = enclose lbracket rbracket 334 | 335 | -- | The document @(enclose l r x)@ encloses document @x@ between 336 | -- documents @l@ and @r@ using @(\<\>)@. 337 | -- 338 | -- > enclose l r x = l <> x <> r 339 | enclose :: Doc -> Doc -> Doc -> Doc 340 | enclose l r x = l <> x <> r 341 | 342 | -- | The document @lparen@ contains a left parenthesis, \"(\". 343 | lparen :: Doc 344 | lparen = char '(' 345 | -- | The document @rparen@ contains a right parenthesis, \")\". 346 | rparen :: Doc 347 | rparen = char ')' 348 | -- | The document @langle@ contains a left angle, \"\<\". 349 | langle :: Doc 350 | langle = char '<' 351 | -- | The document @rangle@ contains a right angle, \">\". 352 | rangle :: Doc 353 | rangle = char '>' 354 | -- | The document @lbrace@ contains a left brace, \"{\". 355 | lbrace :: Doc 356 | lbrace = char '{' 357 | -- | The document @rbrace@ contains a right brace, \"}\". 358 | rbrace :: Doc 359 | rbrace = char '}' 360 | -- | The document @lbracket@ contains a left square bracket, \"[\". 361 | lbracket :: Doc 362 | lbracket = char '[' 363 | -- | The document @rbracket@ contains a right square bracket, \"]\". 364 | rbracket :: Doc 365 | rbracket = char ']' 366 | 367 | 368 | -- | The document @squote@ contains a single quote, \"'\". 369 | squote :: Doc 370 | squote = char '\'' 371 | -- | The document @dquote@ contains a double quote, '\"'. 372 | dquote :: Doc 373 | dquote = char '"' 374 | -- | The document @semi@ contains a semi colon, \";\". 375 | semi :: Doc 376 | semi = char ';' 377 | -- | The document @colon@ contains a colon, \":\". 378 | colon :: Doc 379 | colon = char ':' 380 | -- | The document @comma@ contains a comma, \",\". 381 | comma :: Doc 382 | comma = char ',' 383 | -- | The document @space@ contains a single space, \" \". 384 | -- 385 | -- > x <+> y = x <> space <> y 386 | space :: Doc 387 | space = char ' ' 388 | -- | The document @dot@ contains a single dot, \".\". 389 | dot :: Doc 390 | dot = char '.' 391 | -- | The document @backslash@ contains a back slash, \"\\\". 392 | backslash :: Doc 393 | backslash = char '\\' 394 | -- | The document @equals@ contains an equal sign, \"=\". 395 | equals :: Doc 396 | equals = char '=' 397 | 398 | 399 | ----------------------------------------------------------- 400 | -- Combinators for prelude types 401 | ----------------------------------------------------------- 402 | 403 | -- string is like "text" but replaces '\n' by "line" 404 | 405 | -- | The document @(string s)@ concatenates all characters in @s@ 406 | -- using @line@ for newline characters and @char@ for all other 407 | -- characters. It is used instead of 'text' whenever the text contains 408 | -- newline characters. 409 | string :: String -> Doc 410 | string "" = empty 411 | string ('\n':s) = line <> string s 412 | string s = case (span (/='\n') s) of 413 | (xs,ys) -> text xs <> string ys 414 | 415 | bool :: Bool -> Doc 416 | bool b = text (show b) 417 | 418 | -- | The document @(int i)@ shows the literal integer @i@ using 419 | -- 'text'. 420 | int :: Int -> Doc 421 | int i = text (show i) 422 | 423 | -- | The document @(integer i)@ shows the literal integer @i@ using 424 | -- 'text'. 425 | integer :: Integer -> Doc 426 | integer i = text (show i) 427 | 428 | -- | The document @(float f)@ shows the literal float @f@ using 429 | -- 'text'. 430 | float :: Float -> Doc 431 | float f = text (show f) 432 | 433 | -- | The document @(double d)@ shows the literal double @d@ using 434 | -- 'text'. 435 | double :: Double -> Doc 436 | double d = text (show d) 437 | 438 | -- | The document @(rational r)@ shows the literal rational @r@ using 439 | -- 'text'. 440 | rational :: Rational -> Doc 441 | rational r = text (show r) 442 | 443 | 444 | ----------------------------------------------------------- 445 | -- overloading "pretty" 446 | ----------------------------------------------------------- 447 | 448 | -- | The member @prettyList@ is only used to define the @instance Pretty 449 | -- a => Pretty [a]@. In normal circumstances only the @pretty@ function 450 | -- is used. 451 | class Pretty a where 452 | pretty :: a -> Doc 453 | prettyList :: [a] -> Doc 454 | prettyList = list . map pretty 455 | 456 | instance Pretty a => Pretty [a] where 457 | pretty = prettyList 458 | 459 | instance Pretty Doc where 460 | pretty = id 461 | 462 | instance Pretty () where 463 | pretty () = text "()" 464 | 465 | instance Pretty Bool where 466 | pretty b = bool b 467 | 468 | instance Pretty Char where 469 | pretty c = char c 470 | prettyList s = string s 471 | 472 | instance Pretty Int where 473 | pretty i = int i 474 | 475 | instance Pretty Integer where 476 | pretty i = integer i 477 | 478 | instance Pretty Float where 479 | pretty f = float f 480 | 481 | instance Pretty Double where 482 | pretty d = double d 483 | 484 | 485 | --instance Pretty Rational where 486 | -- pretty r = rational r 487 | 488 | instance (Pretty a,Pretty b) => Pretty (a,b) where 489 | pretty (x,y) = tupled [pretty x, pretty y] 490 | 491 | instance (Pretty a,Pretty b,Pretty c) => Pretty (a,b,c) where 492 | pretty (x,y,z)= tupled [pretty x, pretty y, pretty z] 493 | 494 | instance Pretty a => Pretty (Maybe a) where 495 | pretty Nothing = empty 496 | pretty (Just x) = pretty x 497 | 498 | 499 | 500 | ----------------------------------------------------------- 501 | -- semi primitive: fill and fillBreak 502 | ----------------------------------------------------------- 503 | 504 | -- | The document @(fillBreak i x)@ first renders document @x@. It 505 | -- than appends @space@s until the width is equal to @i@. If the 506 | -- width of @x@ is already larger than @i@, the nesting level is 507 | -- increased by @i@ and a @line@ is appended. When we redefine @ptype@ 508 | -- in the previous example to use @fillBreak@, we get a useful 509 | -- variation of the previous output: 510 | -- 511 | -- > ptype (name,tp) 512 | -- > = fillBreak 6 (text name) <+> text "::" <+> text tp 513 | -- 514 | -- The output will now be: 515 | -- 516 | -- @ 517 | -- let empty :: Doc 518 | -- nest :: Int -> Doc -> Doc 519 | -- linebreak 520 | -- :: Doc 521 | -- @ 522 | fillBreak :: Int -> Doc -> Doc 523 | fillBreak f x = width x (\w -> 524 | if (w > f) then nest f linebreak 525 | else text (spaces (f - w))) 526 | 527 | 528 | -- | The document @(fill i x)@ renders document @x@. It than appends 529 | -- @space@s until the width is equal to @i@. If the width of @x@ is 530 | -- already larger, nothing is appended. This combinator is quite 531 | -- useful in practice to output a list of bindings. The following 532 | -- example demonstrates this. 533 | -- 534 | -- > types = [("empty","Doc") 535 | -- > ,("nest","Int -> Doc -> Doc") 536 | -- > ,("linebreak","Doc")] 537 | -- > 538 | -- > ptype (name,tp) 539 | -- > = fill 6 (text name) <+> text "::" <+> text tp 540 | -- > 541 | -- > test = text "let" <+> align (vcat (map ptype types)) 542 | -- 543 | -- Which is layed out as: 544 | -- 545 | -- @ 546 | -- let empty :: Doc 547 | -- nest :: Int -> Doc -> Doc 548 | -- linebreak :: Doc 549 | -- @ 550 | fill :: Int -> Doc -> Doc 551 | fill f d = width d (\w -> 552 | if (w >= f) then empty 553 | else text (spaces (f - w))) 554 | 555 | width :: Doc -> (Int -> Doc) -> Doc 556 | width d f = column (\k1 -> d <> column (\k2 -> f (k2 - k1))) 557 | 558 | 559 | ----------------------------------------------------------- 560 | -- semi primitive: Alignment and indentation 561 | ----------------------------------------------------------- 562 | 563 | -- | The document @(indent i x)@ indents document @x@ with @i@ spaces. 564 | -- 565 | -- > test = indent 4 (fillSep (map text 566 | -- > (words "the indent combinator indents these words !"))) 567 | -- 568 | -- Which lays out with a page width of 20 as: 569 | -- 570 | -- @ 571 | -- the indent 572 | -- combinator 573 | -- indents these 574 | -- words ! 575 | -- @ 576 | indent :: Int -> Doc -> Doc 577 | indent i d = hang i (text (spaces i) <> d) 578 | 579 | -- | The hang combinator implements hanging indentation. The document 580 | -- @(hang i x)@ renders document @x@ with a nesting level set to the 581 | -- current column plus @i@. The following example uses hanging 582 | -- indentation for some text: 583 | -- 584 | -- > test = hang 4 (fillSep (map text 585 | -- > (words "the hang combinator indents these words !"))) 586 | -- 587 | -- Which lays out on a page with a width of 20 characters as: 588 | -- 589 | -- @ 590 | -- the hang combinator 591 | -- indents these 592 | -- words ! 593 | -- @ 594 | -- 595 | -- The @hang@ combinator is implemented as: 596 | -- 597 | -- > hang i x = align (nest i x) 598 | hang :: Int -> Doc -> Doc 599 | hang i d = align (nest i d) 600 | 601 | -- | The document @(align x)@ renders document @x@ with the nesting 602 | -- level set to the current column. It is used for example to 603 | -- implement 'hang'. 604 | -- 605 | -- As an example, we will put a document right above another one, 606 | -- regardless of the current nesting level: 607 | -- 608 | -- > x $$ y = align (x $$ y) 609 | -- 610 | -- > test = text "hi" <+> (text "nice" $$ text "world") 611 | -- 612 | -- which will be layed out as: 613 | -- 614 | -- @ 615 | -- hi nice 616 | -- world 617 | -- @ 618 | align :: Doc -> Doc 619 | align d = column (\k -> 620 | nesting (\i -> nest (k - i) d)) --nesting might be negative :-) 621 | 622 | 623 | 624 | ----------------------------------------------------------- 625 | -- Primitives 626 | ----------------------------------------------------------- 627 | 628 | -- | The abstract data type @Doc@ represents pretty documents. 629 | -- 630 | -- @Doc@ is an instance of the 'Show' class. @(show doc)@ pretty 631 | -- prints document @doc@ with a page width of 100 characters and a 632 | -- ribbon width of 40 characters. 633 | -- 634 | -- > show (text "hello" $$ text "world") 635 | -- 636 | -- Which would return the string \"hello\\nworld\", i.e. 637 | -- 638 | -- @ 639 | -- hello 640 | -- world 641 | -- @ 642 | data Doc = Empty 643 | | Char Char -- invariant: char is not '\n' 644 | | Text !Int String -- invariant: text doesn't contain '\n' 645 | | Line !Bool -- True <=> when undone by group, do not insert a space 646 | | Cat Doc Doc 647 | | Nest !Int Doc 648 | | Union Doc Doc -- invariant: first lines of first doc longer than the first lines of the second doc 649 | | Column (Int -> Doc) 650 | | Nesting (Int -> Doc) 651 | 652 | 653 | -- | The data type @SimpleDoc@ represents rendered documents and is 654 | -- used by the display functions. 655 | -- 656 | -- The @Int@ in @SText@ contains the length of the string. The @Int@ 657 | -- in @SLine@ contains the indentation for that line. The library 658 | -- provides two default display functions 'displayS' and 659 | -- 'displayIO'. You can provide your own display function by writing a 660 | -- function from a @SimpleDoc@ to your own output format. 661 | data SimpleDoc = SEmpty 662 | | SChar Char SimpleDoc 663 | | SText !Int String SimpleDoc 664 | | SLine !Int SimpleDoc 665 | 666 | 667 | -- | The empty document is, indeed, empty. Although @empty@ has no 668 | -- content, it does have a \'height\' of 1 and behaves exactly like 669 | -- @(text \"\")@ (and is therefore not a unit of @\<$\>@). 670 | empty :: Doc 671 | empty = Empty 672 | 673 | -- | The document @(char c)@ contains the literal character @c@. The 674 | -- character shouldn't be a newline (@'\n'@), the function 'line' 675 | -- should be used for line breaks. 676 | char :: Char -> Doc 677 | char '\n' = line 678 | char c = Char c 679 | 680 | -- | The document @(text s)@ contains the literal string @s@. The 681 | -- string shouldn't contain any newline (@'\n'@) characters. If the 682 | -- string contains newline characters, the function 'string' should be 683 | -- used. 684 | text :: String -> Doc 685 | text "" = Empty 686 | text s = Text (length s) s 687 | 688 | -- | The @line@ document advances to the next line and indents to the 689 | -- current nesting level. Document @line@ behaves like @(text \" \")@ 690 | -- if the line break is undone by 'group'. 691 | line :: Doc 692 | line = Line False 693 | 694 | -- | The @linebreak@ document advances to the next line and indents to 695 | -- the current nesting level. Document @linebreak@ behaves like 696 | -- 'empty' if the line break is undone by 'group'. 697 | linebreak :: Doc 698 | linebreak = Line True 699 | 700 | beside x y = Cat x y 701 | 702 | -- | The document @(nest i x)@ renders document @x@ with the current 703 | -- indentation level increased by i (See also 'hang', 'align' and 704 | -- 'indent'). 705 | -- 706 | -- > nest 2 (text "hello" $$ text "world") $$ text "!" 707 | -- 708 | -- outputs as: 709 | -- 710 | -- @ 711 | -- hello 712 | -- world 713 | -- ! 714 | -- @ 715 | nest :: Int -> Doc -> Doc 716 | nest i x = Nest i x 717 | 718 | column, nesting :: (Int -> Doc) -> Doc 719 | column f = Column f 720 | nesting f = Nesting f 721 | 722 | -- | The @group@ combinator is used to specify alternative 723 | -- layouts. The document @(group x)@ undoes all line breaks in 724 | -- document @x@. The resulting line is added to the current line if 725 | -- that fits the page. Otherwise, the document @x@ is rendered without 726 | -- any changes. 727 | group :: Doc -> Doc 728 | group x = Union (flatten x) x 729 | 730 | flatten :: Doc -> Doc 731 | flatten (Cat x y) = Cat (flatten x) (flatten y) 732 | flatten (Nest i x) = Nest i (flatten x) 733 | flatten (Line break) = if break then Empty else Text 1 " " 734 | flatten (Union x y) = flatten x 735 | flatten (Column f) = Column (flatten . f) 736 | flatten (Nesting f) = Nesting (flatten . f) 737 | flatten other = other --Empty,Char,Text 738 | 739 | 740 | 741 | ----------------------------------------------------------- 742 | -- Renderers 743 | ----------------------------------------------------------- 744 | 745 | ----------------------------------------------------------- 746 | -- renderPretty: the default pretty printing algorithm 747 | ----------------------------------------------------------- 748 | 749 | -- list of indentation/document pairs; saves an indirection over [(Int,Doc)] 750 | data Docs = Nil 751 | | Cons !Int Doc Docs 752 | 753 | 754 | -- | This is the default pretty printer which is used by 'show', 755 | -- 'putDoc' and 'hPutDoc'. @(renderPretty ribbonfrac width x)@ renders 756 | -- document @x@ with a page width of @width@ and a ribbon width of 757 | -- @(ribbonfrac * width)@ characters. The ribbon width is the maximal 758 | -- amount of non-indentation characters on a line. The parameter 759 | -- @ribbonfrac@ should be between @0.0@ and @1.0@. If it is lower or 760 | -- higher, the ribbon width will be 0 or @width@ respectively. 761 | renderPretty :: Float -> Int -> Doc -> SimpleDoc 762 | renderPretty rfrac w x 763 | = best 0 0 (Cons 0 x Nil) 764 | where 765 | -- r :: the ribbon width in characters 766 | r = max 0 (min w (round (fromIntegral w * rfrac))) 767 | 768 | -- best :: n = indentation of current line 769 | -- k = current column 770 | -- (ie. (k >= n) && (k - n == count of inserted characters) 771 | best n k Nil = SEmpty 772 | best n k (Cons i d ds) 773 | = case d of 774 | Empty -> best n k ds 775 | Char c -> let k' = k+1 in seq k' (SChar c (best n k' ds)) 776 | Text l s -> let k' = k+l in seq k' (SText l s (best n k' ds)) 777 | Line _ -> SLine i (best i i ds) 778 | Cat x y -> best n k (Cons i x (Cons i y ds)) 779 | Nest j x -> let i' = i+j in seq i' (best n k (Cons i' x ds)) 780 | Union x y -> nicest n k (best n k (Cons i x ds)) 781 | (best n k (Cons i y ds)) 782 | 783 | Column f -> best n k (Cons i (f k) ds) 784 | Nesting f -> best n k (Cons i (f i) ds) 785 | 786 | --nicest :: r = ribbon width, w = page width, 787 | -- n = indentation of current line, k = current column 788 | -- x and y, the (simple) documents to chose from. 789 | -- precondition: first lines of x are longer than the first lines of y. 790 | nicest n k x y | fits width x = x 791 | | otherwise = y 792 | where 793 | width = min (w - k) (r - k + n) 794 | 795 | 796 | fits w x | w < 0 = False 797 | fits w SEmpty = True 798 | fits w (SChar c x) = fits (w - 1) x 799 | fits w (SText l s x) = fits (w - l) x 800 | fits w (SLine i x) = True 801 | 802 | 803 | ----------------------------------------------------------- 804 | -- renderCompact: renders documents without indentation 805 | -- fast and fewer characters output, good for machines 806 | ----------------------------------------------------------- 807 | 808 | 809 | -- | @(renderCompact x)@ renders document @x@ without adding any 810 | -- indentation. Since no \'pretty\' printing is involved, this 811 | -- renderer is very fast. The resulting output contains fewer 812 | -- characters than a pretty printed version and can be used for output 813 | -- that is read by other programs. 814 | renderCompact :: Doc -> SimpleDoc 815 | renderCompact x 816 | = scan 0 [x] 817 | where 818 | scan k [] = SEmpty 819 | scan k (d:ds) = case d of 820 | Empty -> scan k ds 821 | Char c -> let k' = k+1 in seq k' (SChar c (scan k' ds)) 822 | Text l s -> let k' = k+l in seq k' (SText l s (scan k' ds)) 823 | Line _ -> SLine 0 (scan 0 ds) 824 | Cat x y -> scan k (x:y:ds) 825 | Nest j x -> scan k (x:ds) 826 | Union x y -> scan k (y:ds) 827 | Column f -> scan k (f k:ds) 828 | Nesting f -> scan k (f 0:ds) 829 | 830 | 831 | 832 | ----------------------------------------------------------- 833 | -- Displayers: displayS and displayIO 834 | ----------------------------------------------------------- 835 | 836 | 837 | -- | @(displayS simpleDoc)@ takes the output @simpleDoc@ from a 838 | -- rendering function and transforms it to a 'ShowS' type (for use in 839 | -- the 'Show' class). 840 | -- 841 | -- > showWidth :: Int -> Doc -> String 842 | -- > showWidth w x = displayS (renderPretty 0.4 w x) "" 843 | displayS :: SimpleDoc -> ShowS 844 | displayS SEmpty = id 845 | displayS (SChar c x) = showChar c . displayS x 846 | displayS (SText l s x) = showString s . displayS x 847 | displayS (SLine i x) = showString ('\n':indentation i) . displayS x 848 | 849 | 850 | -- | @(displayIO handle simpleDoc)@ writes @simpleDoc@ to the file 851 | -- handle @handle@. This function is used for example by 'hPutDoc': 852 | -- 853 | -- > hPutDoc handle doc = displayIO handle (renderPretty 0.4 100 doc) 854 | displayIO :: Handle -> SimpleDoc -> IO () 855 | displayIO handle simpleDoc 856 | = display simpleDoc 857 | where 858 | display SEmpty = return () 859 | display (SChar c x) = do{ hPutChar handle c; display x} 860 | display (SText l s x) = do{ hPutStr handle s; display x} 861 | display (SLine i x) = do{ hPutStr handle ('\n':indentation i); display x} 862 | 863 | 864 | ----------------------------------------------------------- 865 | -- default pretty printers: show, putDoc and hPutDoc 866 | ----------------------------------------------------------- 867 | instance Show Doc where 868 | --showsPrec d doc = displayS (renderPretty 0.4 80 doc) 869 | showsPrec d doc = displayS (renderPretty 0.8 120 doc) 870 | 871 | -- | The action @(putDoc doc)@ pretty prints document @doc@ to the 872 | -- standard output, with a page width of 100 characters and a ribbon 873 | -- width of 40 characters. 874 | -- 875 | -- > main :: IO () 876 | -- > main = do{ putDoc (text "hello" <+> text "world") } 877 | -- 878 | -- Which would output 879 | -- 880 | -- @ 881 | -- hello world 882 | -- @ 883 | putDoc :: Doc -> IO () 884 | putDoc doc = hPutDoc stdout doc 885 | 886 | -- | @(hPutDoc handle doc)@ pretty prints document @doc@ to the file 887 | -- handle @handle@ with a page width of 100 characters and a ribbon 888 | -- width of 40 characters. 889 | -- 890 | -- > main = do{ handle <- openFile "MyFile" WriteMode 891 | -- > ; hPutDoc handle (vcat (map text 892 | -- > ["vertical","text"])) 893 | -- > ; hClose handle 894 | -- > } 895 | hPutDoc :: Handle -> Doc -> IO () 896 | hPutDoc handle doc = displayIO handle (renderPretty 0.4 80 doc) 897 | 898 | 899 | 900 | ----------------------------------------------------------- 901 | -- insert spaces 902 | -- "indentation" used to insert tabs but tabs seem to cause 903 | -- more trouble than they solve :-) 904 | ----------------------------------------------------------- 905 | spaces n | n <= 0 = "" 906 | | otherwise = replicate n ' ' 907 | 908 | indentation n = spaces n 909 | 910 | --indentation n | n >= 8 = '\t' : indentation (n-8) 911 | -- | otherwise = spaces n 912 | 913 | -- LocalWords: PPrint combinators Wadler Wadler's encloseSep 914 | 915 | 916 | ----------------------------------------------------------- 917 | -- Extra stuff 918 | ----------------------------------------------------------- 919 | 920 | -- | Specify alternative layouts 921 | unionDoc :: Doc -> Doc -> Doc 922 | unionDoc = Union 923 | 924 | -- | Vertical concatenation of lines 925 | groups :: [Doc] -> Doc 926 | --groups xs = Union (vcat $ map flatten xs) (vcat xs) 927 | groups = vcat . map group 928 | 929 | -- | Indentation that goes away when flattened 930 | --softindent :: Int -> Doc -> Doc 931 | --softindent = undefined 932 | 933 | -- | Either (x <+> y) or (x $$ indent 2 y) 934 | -- aka. group (x $+$ softindent 2 y) 935 | ($/$) :: Doc -> Doc -> Doc 936 | x $/$ y = group $ x <> nest 2 (empty $$ y) 937 | --x $/$ y = group (x $+$ softindent 2 y) 938 | 939 | -------------------------------------------------------------------------------- /ttie.cabal: -------------------------------------------------------------------------------- 1 | name: ttie 2 | version: 0.1.0 3 | cabal-version: >=1.8 4 | build-type: Simple 5 | license: BSD3 6 | description: 7 | 8 | library 9 | ghc-options: -Wall 10 | build-depends: 11 | base >= 4.7, 12 | parsec >= 3, 13 | transformers, 14 | mtl >= 2.2, 15 | template-haskell >= 2.8, 16 | containers >= 0.5 17 | exposed-modules: 18 | Util.MyPrelude 19 | Util.Parser 20 | Util.PrettyM 21 | Util.WLPPrint 22 | Util.Tagged.Map 23 | Util.Tagged.Seq 24 | Util.Tagged.Var 25 | Names 26 | Substitution 27 | Tokenizer 28 | Syntax 29 | TcMonad 30 | EqZipper 31 | Eval 32 | Typing 33 | other-modules: 34 | Util.Tagged.Internal 35 | hs-source-dirs: src 36 | 37 | executable ttie 38 | main-is: src/Main.hs 39 | build-depends: 40 | ttie, 41 | optparse-applicative, 42 | base >= 4.7, 43 | transformers, 44 | mtl >= 2.2, 45 | containers >= 0.5, 46 | lens-simple >= 0.1, 47 | filepath >= 1.4, 48 | directory >= 1.2 49 | 50 | test-suite tests 51 | type: exitcode-stdio-1.0 52 | main-is: src/Tests.hs 53 | build-depends: 54 | ttie, 55 | tasty, 56 | base >= 4.7, 57 | parsec >= 3, 58 | transformers, 59 | mtl >= 2.2, 60 | containers >= 0.5 61 | 62 | --------------------------------------------------------------------------------