290 lines
8.2 KiB
Idris
290 lines
8.2 KiB
Idris
module Quox.Context
|
|
|
|
import Quox.Syntax.Shift
|
|
import Quox.Pretty
|
|
import public Quox.NatExtra
|
|
|
|
import Data.DPair
|
|
import Data.Nat
|
|
import Data.SnocList
|
|
import Control.Monad.Identity
|
|
|
|
%default total
|
|
|
|
|
|
infixl 5 :<
|
|
||| a sequence of bindings under an existing context. each successive element
|
|
||| has one more bound variable, which correspond to all previous elements
|
|
||| as well as the surrounding context.
|
|
public export
|
|
data Telescope : (tm : Nat -> Type) -> (from, to : Nat) -> Type where
|
|
Lin : Telescope tm from from
|
|
(:<) : Telescope tm from to -> tm to -> Telescope tm from (S to)
|
|
%name Telescope tel
|
|
|
|
public export
|
|
Telescope' : (a : Type) -> (from, to : Nat) -> Type
|
|
Telescope' a = Telescope (\_ => a)
|
|
|
|
||| a top level context is actually just a telescope over no existing bindings
|
|
public export
|
|
Context : (tm : Nat -> Type) -> (len : Nat) -> Type
|
|
Context tm len = Telescope tm 0 len
|
|
|
|
public export
|
|
Context' : (a : Type) -> (len : Nat) -> Type
|
|
Context' a = Context (\_ => a)
|
|
|
|
|
|
public export
|
|
tail : Context tm (S n) -> Context tm n
|
|
tail (tel :< _) = tel
|
|
|
|
export
|
|
toSnocList : Telescope tm _ _ -> SnocList (Exists tm)
|
|
toSnocList [<] = [<]
|
|
toSnocList (tel :< t) = toSnocList tel :< Evidence _ t
|
|
|
|
private
|
|
toListAcc : Telescope tm _ _ -> List (Exists tm) -> List (Exists tm)
|
|
toListAcc [<] acc = acc
|
|
toListAcc (tel :< t) acc = toListAcc tel (Evidence _ t :: acc)
|
|
|
|
export %inline
|
|
toList : Telescope tm _ _ -> List (Exists tm)
|
|
toList tel = toListAcc tel []
|
|
|
|
export %inline
|
|
toSnocList' : Telescope' a _ _ -> SnocList a
|
|
toSnocList' = map snd . toSnocList
|
|
|
|
export %inline
|
|
toList' : Telescope' a _ _ -> List a
|
|
toList' = map snd . toList
|
|
|
|
|
|
infixl 9 .
|
|
public export
|
|
(.) : Telescope tm from mid -> Telescope tm mid to -> Telescope tm from to
|
|
tel1 . [<] = tel1
|
|
tel1 . (tel2 :< s) = (tel1 . tel2) :< s
|
|
|
|
|
|
public export
|
|
getShiftWith : (forall from, to. tm from -> Shift from to -> tm to) ->
|
|
Shift len out -> Context tm len -> Var len -> tm out
|
|
getShiftWith shft by (ctx :< t) VZ = t `shft` ssDown by
|
|
getShiftWith shft by (ctx :< t) (VS i) = getShiftWith shft (ssDown by) ctx i
|
|
|
|
public export %inline
|
|
getShift : CanShift tm => Shift len out -> Context tm len -> Var len -> tm out
|
|
getShift = getShiftWith (//)
|
|
|
|
public export %inline
|
|
getWith : (forall from, to. tm from -> Shift from to -> tm to) ->
|
|
Context tm len -> Var len -> tm len
|
|
getWith shft = getShiftWith shft SZ
|
|
|
|
infixl 8 !!
|
|
(!!) : CanShift tm => Context tm len -> Var len -> tm len
|
|
(!!) = getWith (//)
|
|
|
|
infixl 8 !!!
|
|
public export %inline
|
|
(!!!) : Context' tm len -> Var len -> tm
|
|
(!!!) = getWith const
|
|
|
|
|
|
||| a triangle of bindings. each type binding in a context counts the ues of
|
|
||| others in its type, and all of these together form a triangle.
|
|
public export
|
|
Triangle : (tm : Nat -> Type) -> (len : Nat) -> Type
|
|
Triangle = Context . Context
|
|
|
|
public export
|
|
Triangle' : Type -> (len : Nat) -> Type
|
|
Triangle' a = Context $ Context (\_ => a)
|
|
|
|
export
|
|
0 telescopeLTE : Telescope _ from to -> from `LTE` to
|
|
telescopeLTE [<] = reflexive
|
|
telescopeLTE (tel :< _) = lteSuccRight $ telescopeLTE tel
|
|
|
|
export
|
|
(gt : from `GT` to) => Uninhabited (Telescope _ from to) where
|
|
uninhabited tel = void $ LTEImpliesNotGT (telescopeLTE tel) gt
|
|
|
|
export %hint
|
|
0 succGT : S n `GT` n
|
|
succGT = LTESucc reflexive
|
|
|
|
|
|
parameters {auto _ : Applicative f}
|
|
export
|
|
traverse : (forall n. tm1 n -> f (tm2 n)) ->
|
|
Telescope tm1 from to -> f (Telescope tm2 from to)
|
|
traverse f [<] = pure [<]
|
|
traverse f (tel :< x) = [|traverse f tel :< f x|]
|
|
|
|
infixl 3 `app`
|
|
||| like `(<*>)` but with effects
|
|
export
|
|
app : Telescope (\n => tm1 n -> f (tm2 n)) from to ->
|
|
Telescope tm1 from to -> f (Telescope tm2 from to)
|
|
app [<] [<] = pure [<]
|
|
app (ftel :< f) (xtel :< x) = [|app ftel xtel :< f x|]
|
|
app [<] (xtel :< _) = void $ uninhabited xtel
|
|
app (ftel :< _) [<] = void $ uninhabited ftel
|
|
|
|
export %inline
|
|
sequence : Telescope (f . tm) from to -> f (Telescope tm from to)
|
|
sequence = traverse id
|
|
|
|
parameters {0 tm1, tm2 : Nat -> Type}
|
|
(f : forall n. tm1 n -> tm2 n)
|
|
export %inline
|
|
map : Telescope tm1 from to -> Telescope tm2 from to
|
|
map = runIdentity . traverse (pure . f)
|
|
|
|
export %inline
|
|
(<$>) : Telescope tm1 from to -> Telescope tm2 from to
|
|
(<$>) = map
|
|
|
|
export %inline
|
|
(<*>) : Telescope (\n => tm1 n -> tm2 n) from to ->
|
|
Telescope tm1 from to -> Telescope tm2 from to
|
|
ftel <*> xtel = runIdentity $ (pure .) <$> ftel `app` xtel
|
|
-- ...but can't write pure without `from,to` being ω, so no idiom brackets ☹
|
|
|
|
export
|
|
teleLte' : Telescope tm from to -> from `LTE'` to
|
|
teleLte' [<] = LTERefl
|
|
teleLte' (tel :< _) = LTESuccR (teleLte' tel)
|
|
|
|
|
|
export
|
|
tabulate : ((n : Nat) -> tm n) ->
|
|
(from, to : Nat) -> from `LTE'` to => Telescope tm from to
|
|
tabulate f from from @{LTERefl} = [<]
|
|
tabulate f from (S to) @{LTESuccR _} = tabulate f from to :< f to
|
|
|
|
export
|
|
tabulate0 : ((n : Nat) -> tm n) -> (n : Nat) -> Context tm n
|
|
tabulate0 f n = tabulate f 0 n
|
|
|
|
|
|
export
|
|
pure : from `LTE'` to => a -> Telescope' a from to
|
|
pure @{LTERefl} x = [<]
|
|
pure @{LTESuccR _} x = pure x :< x
|
|
|
|
|
|
export %inline
|
|
zipWith : (forall n. tm1 n -> tm2 n -> tm3 n) ->
|
|
Telescope tm1 from to -> Telescope tm2 from to ->
|
|
Telescope tm3 from to
|
|
zipWith f tel1 tel2 = f <$> tel1 <*> tel2
|
|
|
|
export %inline
|
|
zipWith3 : (forall n. tm1 n -> tm2 n -> tm3 n -> tm4 n) ->
|
|
Telescope tm1 from to ->
|
|
Telescope tm2 from to ->
|
|
Telescope tm3 from to ->
|
|
Telescope tm4 from to
|
|
zipWith3 f tel1 tel2 tel3 = f <$> tel1 <*> tel2 <*> tel3
|
|
|
|
export %inline
|
|
zipWithLazy : forall tm1, tm2, tm3.
|
|
(forall n. tm1 n -> tm2 n -> tm3 n) ->
|
|
Telescope tm1 from to -> Telescope tm2 from to ->
|
|
Telescope (\n => Lazy (tm3 n)) from to
|
|
zipWithLazy f = zipWith $ delay .: f
|
|
|
|
export %inline
|
|
zipWith3Lazy : forall tm1, tm2, tm3, tm4.
|
|
(forall n. tm1 n -> tm2 n -> tm3 n -> tm4 n) ->
|
|
Telescope tm1 from to ->
|
|
Telescope tm2 from to ->
|
|
Telescope tm3 from to ->
|
|
Telescope (\n => Lazy (tm4 n)) from to
|
|
zipWith3Lazy f = zipWith3 $ \x, y, z => delay $ f x y z
|
|
|
|
|
|
export
|
|
lengthPrf : Telescope _ from to -> Subset Nat (\len => len + from = to)
|
|
lengthPrf [<] = Element 0 Refl
|
|
lengthPrf (tel :< _) =
|
|
let len = lengthPrf tel in Element (S len.fst) (cong S len.snd)
|
|
|
|
export
|
|
lengthPrf0 : Context _ to -> Subset Nat (\len => len = to)
|
|
lengthPrf0 ctx =
|
|
let len = lengthPrf ctx in
|
|
Element len.fst (rewrite sym $ plusZeroRightNeutral len.fst in len.snd)
|
|
|
|
public export %inline
|
|
length : Telescope {} -> Nat
|
|
length = fst . lengthPrf
|
|
|
|
|
|
export
|
|
foldl : {0 acc : Nat -> Type} ->
|
|
(f : forall n. acc n -> tm (n + from) -> acc (S n)) ->
|
|
(z : acc 0) -> (tel : Telescope tm from to) -> acc (length tel)
|
|
foldl f z [<] = z
|
|
foldl f z (tel :< t) = f (foldl f z tel) (rewrite (lengthPrf tel).snd in t)
|
|
|
|
export %inline
|
|
foldMap : Monoid a => (forall n. tm n -> a) -> Telescope tm from to -> a
|
|
foldMap f = foldl (\acc, tm => acc <+> f tm) neutral
|
|
|
|
export %inline
|
|
fold : Monoid a => Telescope' a from to -> a
|
|
fold = foldMap id
|
|
|
|
||| like `fold` but calculate the elements only when actually appending
|
|
export %inline
|
|
foldLazy : Monoid a => Telescope' (Lazy a) from to -> a
|
|
foldLazy = foldMap force
|
|
|
|
|
|
export %inline
|
|
and : Telescope' (Lazy Bool) _ _ -> Bool
|
|
and = force . fold @{All}
|
|
|
|
export %inline
|
|
all : (forall n. tm n -> Bool) -> Telescope tm _ _ -> Bool
|
|
all p = and . map (delay . p)
|
|
|
|
export %inline
|
|
all2 : (forall n. tm n -> tm2 n -> Bool) ->
|
|
Telescope tm from to -> Telescope tm2 from to -> Bool
|
|
all2 p = and .: zipWithLazy p
|
|
|
|
|
|
export %inline
|
|
or : Telescope' (Lazy Bool) _ _ -> Bool
|
|
or = force . fold @{Any}
|
|
|
|
export %inline
|
|
any : (forall n. tm n -> Bool) -> Telescope tm _ _ -> Bool
|
|
any p = or . map (delay . p)
|
|
|
|
export %inline
|
|
any2 : (forall n. tm1 n -> tm2 n -> Bool) ->
|
|
Telescope tm1 from to -> Telescope tm2 from to -> Bool
|
|
any2 p = or .: zipWithLazy p
|
|
|
|
|
|
export %inline
|
|
(forall n. Eq (tm n)) => Eq (Telescope tm from to) where
|
|
(==) = all2 (==)
|
|
|
|
export %inline
|
|
(forall n. Ord (tm n)) => Ord (Telescope tm from to) where
|
|
compare = foldLazy .: zipWithLazy compare
|
|
|
|
export %inline
|
|
(forall n. PrettyHL (tm n)) => PrettyHL (Telescope tm from to) where
|
|
prettyM tel = separate (hl Delim ";") <$> traverse prettyM (toList tel)
|