mirror of
https://github.com/idris-lang/Idris2.git
synced 2024-12-25 20:51:43 +03:00
75032a7164
* Emit warning for fixities with no export modifiers This is to help update all the existing code to program with explicit fixity export directives in preparation for the behavioral change where they will become private by default.
468 lines
15 KiB
Idris
468 lines
15 KiB
Idris
-- The content of this module is based on the paper
|
|
-- Computing with Generic Trees in Agda
|
|
-- by Stephen Dolan
|
|
-- https://dl.acm.org/doi/abs/10.1145/3546196.3550165
|
|
|
|
module Data.W
|
|
|
|
import Data.Maybe
|
|
|
|
%default total
|
|
|
|
namespace Finitary
|
|
|
|
data Fin : Type where
|
|
AVoid : Fin
|
|
AUnit : (nm : String) -> Fin
|
|
(||) : (d, e : Fin) -> Fin
|
|
|
|
namespace Fin
|
|
|
|
public export
|
|
fromString : String -> Fin
|
|
fromString = AUnit
|
|
|
|
namespace Examples
|
|
|
|
fbb : Fin
|
|
fbb = "foo" || "bar" || "baz"
|
|
|
|
record NamedUnit (nm : String) where
|
|
constructor MkNamedUnit
|
|
|
|
Elem : Fin -> Type
|
|
Elem AVoid = Void
|
|
Elem (AUnit nm) = NamedUnit nm
|
|
Elem (d || e) = Either (Elem d) (Elem e)
|
|
|
|
lookup : (d : Fin) -> String -> Maybe (Elem d)
|
|
lookup AVoid s = Nothing
|
|
lookup (AUnit nm) s = MkNamedUnit <$ guard (nm == s)
|
|
lookup (d || e) s = Left <$> lookup d s <|> Right <$> lookup e s
|
|
|
|
-- using a record to help the unifier
|
|
record Shape (d : Fin) where
|
|
constructor MkShape
|
|
runShape : Elem d
|
|
|
|
namespace Shape
|
|
|
|
export
|
|
fromString : {d : Fin} -> (nm : String) ->
|
|
IsJust (lookup d nm) => Shape d
|
|
fromString {d} nm = MkShape (fromJust (lookup d nm))
|
|
|
|
namespace Examples
|
|
|
|
bar : Shape Examples.fbb
|
|
bar = "bar"
|
|
|
|
record One (nm : String) (s : Type) where
|
|
constructor MkOne
|
|
runOne : s
|
|
|
|
Arr : Fin -> Type -> Type
|
|
Arr AVoid r = ()
|
|
Arr (AUnit nm) r = One nm r
|
|
Arr (d || e) r = (Arr d r, Arr e r)
|
|
|
|
export infixr 0 ~>
|
|
record (~>) (d : Fin) (r : Type) where
|
|
constructor MkArr
|
|
runArr : Arr d r
|
|
|
|
export infix 5 .=
|
|
(.=) : (nm : String) -> s -> One nm s
|
|
nm .= v = MkOne v
|
|
|
|
namespace Examples
|
|
|
|
isBar : Examples.fbb ~> Bool
|
|
isBar = MkArr
|
|
( "foo" .= False
|
|
, "bar" .= True
|
|
, "baz" .= False
|
|
)
|
|
|
|
lamArr : (d : Fin) -> (Elem d -> r) -> Arr d r
|
|
lamArr AVoid f = ()
|
|
lamArr (AUnit nm) f = MkOne (f MkNamedUnit)
|
|
lamArr (d || e) f = (lamArr d (f . Left), lamArr e (f . Right))
|
|
|
|
lam : {d : Fin} -> (Elem d -> r) -> (d ~> r)
|
|
lam {d} = MkArr . lamArr d
|
|
|
|
appArr : (d : Fin) -> Arr d r -> (Elem d -> r)
|
|
appArr AVoid f t = absurd t
|
|
appArr (AUnit nm) f t = runOne f
|
|
appArr (d || e) f (Left x) = appArr d (fst f) x
|
|
appArr (d || e) f (Right x) = appArr e (snd f) x
|
|
|
|
export infixl 0 $$
|
|
($$) : {d : Fin} -> (d ~> r) -> (Elem d -> r)
|
|
MkArr f $$ x = appArr d f x
|
|
|
|
beta : {d : Fin} -> (f : Elem d -> r) -> (x : Elem d) ->
|
|
(lam {d} f $$ x) === f x
|
|
beta = go d where
|
|
|
|
go : (d : Fin) -> (f : Elem d -> r) -> (x : Elem d) ->
|
|
(appArr d (lamArr d f) x) === f x
|
|
go AVoid f x = absurd x
|
|
go (AUnit nm) f MkNamedUnit = Refl
|
|
go (d || e) f (Left x) = go d (f . Left) x
|
|
go (d || e) f (Right x) = go e (f . Right) x
|
|
|
|
eta : {d : Fin} -> (f : d ~> r) -> f === lam (\ x => f $$ x)
|
|
eta (MkArr f) = cong MkArr (go d f) where
|
|
|
|
go : (d : Fin) -> (f : Arr d r) ->
|
|
f === lamArr d (\ x => appArr {r} d f x)
|
|
go AVoid () = Refl
|
|
go (AUnit nm) (MkOne v) = Refl
|
|
go (d || e) (f, g) = cong2 MkPair (go d f) (go e g)
|
|
|
|
ext : {d : Fin} -> (f, g : Elem d -> r) ->
|
|
(eq : (x : Elem d) -> f x === g x) ->
|
|
lam f === lam {d} g
|
|
ext f g eq = cong MkArr (go d eq) where
|
|
|
|
go : (d : Fin) -> {f, g : Elem d -> r} ->
|
|
(eq : (x : Elem d) -> f x === g x) ->
|
|
lamArr d f === lamArr d g
|
|
go AVoid eq = Refl
|
|
go (AUnit nm) eq = cong MkOne (eq MkNamedUnit)
|
|
go (d || e) eq =
|
|
cong2 MkPair (go d (\ t => eq (Left t)))
|
|
(go e (\ t => eq (Right t)))
|
|
|
|
PiArr : (d : Fin) -> (b : Arr d Type) -> Type
|
|
PiArr AVoid b = ()
|
|
PiArr (AUnit nm) b = One nm (runOne b)
|
|
PiArr (d || e) b = (PiArr d (fst b), PiArr e (snd b))
|
|
|
|
record Pi (d : Fin) (b : d ~> Type) where
|
|
constructor MkPi
|
|
runPi : PiArr d (runArr b)
|
|
|
|
namespace Dependent
|
|
|
|
lamArr : (d : Fin) -> {0 b : Arr d Type} ->
|
|
((x : Elem d) -> appArr d b x) -> PiArr d b
|
|
lamArr AVoid f = ()
|
|
lamArr (AUnit nm) f = MkOne (f MkNamedUnit)
|
|
lamArr (d || e) f =
|
|
( Dependent.lamArr d (\ x => f (Left x))
|
|
, Dependent.lamArr e (\ x => f (Right x)))
|
|
|
|
export
|
|
lam : {d : Fin} -> {0 b : d ~> Type} ->
|
|
((x : Elem d) -> b $$ x) -> Pi d b
|
|
lam {b = MkArr b} f = MkPi (Dependent.lamArr d f)
|
|
|
|
public export
|
|
appArr : (d : Fin) -> {0 b : Arr d Type} ->
|
|
PiArr d b -> ((x : Elem d) -> appArr d b x)
|
|
appArr AVoid f x = absurd x
|
|
appArr (AUnit nm) f x = runOne f
|
|
appArr (d || e) (f, g) (Left x) = Dependent.appArr d f x
|
|
appArr (d || e) (f, g) (Right x) = Dependent.appArr e g x
|
|
|
|
export
|
|
($$) : {d : Fin} -> {0 b : d ~> Type} ->
|
|
Pi d b -> ((x : Elem d) -> b $$ x)
|
|
($$) {b = MkArr b} (MkPi f) x = Dependent.appArr d f x
|
|
|
|
export
|
|
beta : {d : Fin} -> {0 b : d ~> Type} ->
|
|
(f : (x : Elem d) -> b $$ x) ->
|
|
(x : Elem d) -> (lam {b} f $$ x) === f x
|
|
beta {b = MkArr b} f x = go d f x where
|
|
|
|
go : (d : Fin) -> {0 b : Arr d Type} ->
|
|
(f : (x : Elem d) -> appArr d b x) ->
|
|
(x : Elem d) -> appArr d {b} (lamArr d {b} f) x === f x
|
|
go AVoid f x = absurd x
|
|
go (AUnit nm) f MkNamedUnit = Refl
|
|
go (d || e) f (Left x) = go d (\ x => f (Left x)) x
|
|
go (d || e) f (Right x) = go e (\ x => f (Right x)) x
|
|
|
|
export
|
|
eta : {d : Fin} -> {0 b : d ~> Type} ->
|
|
(f : Pi d b) -> lam {b} (\ x => f $$ x) === f
|
|
eta {b = MkArr b} (MkPi f) = cong MkPi (go d f) where
|
|
|
|
go : (d : Fin) -> {0 b : Arr d Type} ->
|
|
(f : PiArr d b) -> (lamArr d {b} $ \ x => appArr d {b} f x) === f
|
|
go AVoid () = Refl
|
|
go (AUnit nm) (MkOne f) = Refl
|
|
go (d || e) (f, g) = cong2 MkPair (go d f) (go e g)
|
|
|
|
export
|
|
ext : {d : Fin} -> {0 b : d ~> Type} ->
|
|
(f, g : (x : Elem d) -> b $$ x) ->
|
|
(eq : (x : Elem d) -> f x === g x) ->
|
|
lam {b} f === lam g
|
|
ext {b = MkArr b} f g eq = cong MkPi (go d eq) where
|
|
|
|
go : (d : Fin) -> {0 b : Arr d Type} ->
|
|
{f, g : (x : Elem d) -> appArr d b x} ->
|
|
(eq : (x : Elem d) -> f x === g x) ->
|
|
lamArr d {b} f === lamArr d {b} g
|
|
go AVoid eq = Refl
|
|
go (AUnit nm) eq = cong MkOne (eq MkNamedUnit)
|
|
go (d || e) eq =
|
|
cong2 MkPair (go d (\x => eq (Left x)))
|
|
(go e (\x => eq (Right x)))
|
|
|
|
data W : (sh : Type) -> (pos : sh -> Fin) -> Type where
|
|
MkW : (s : sh) -> (pos s ~> W sh pos) -> W sh pos
|
|
|
|
mkW : (s : sh) -> Arr (pos s) (W sh pos) -> W sh pos
|
|
mkW s f = MkW s (MkArr f)
|
|
|
|
elim : {0 sh : Type} -> {pos : sh -> Fin} ->
|
|
(0 pred : W sh pos -> Type) ->
|
|
(step : (s : sh) -> (ts : pos s ~> W sh pos) ->
|
|
(Pi (pos s) (lam $ \ p => pred (ts $$ p))) ->
|
|
pred (MkW s ts)) ->
|
|
(w : W sh pos) -> pred w
|
|
elim pred step (MkW s (MkArr ts))
|
|
= step s (MkArr ts) (MkPi $ ih (pos s) ts) where
|
|
|
|
ih : (d : Fin) -> (ts : Arr d (W sh pos)) ->
|
|
PiArr d (lamArr d $ \ p => pred (appArr d ts p))
|
|
ih AVoid ts = ()
|
|
ih (AUnit nm) (MkOne ts) = MkOne (elim pred step ts)
|
|
ih (d || e) (ts, us) = (ih d ts, ih e us)
|
|
|
|
cases : {d : Fin} -> {0 b : Shape d -> Type} ->
|
|
PiArr d (lamArr d (b . MkShape)) -> (x : Shape d) -> b x
|
|
cases f (MkShape x) = go (b . MkShape) f x where
|
|
|
|
go : (0 b : Elem d -> Type) ->
|
|
PiArr d (lamArr d b) -> (x : Elem d) -> b x
|
|
go b f x = rewrite sym (Finitary.beta {d} b x) in Dependent.appArr d f x
|
|
|
|
namespace Examples
|
|
|
|
public export
|
|
NAT : Type
|
|
NAT = W (Shape ("zero" || "succ")) $ cases
|
|
( "zero" .= AVoid
|
|
, "succ" .= "x"
|
|
)
|
|
zero : NAT
|
|
zero = mkW "zero" ()
|
|
|
|
succ : NAT -> NAT
|
|
succ x = mkW "succ" ("x" .= x)
|
|
|
|
NATind : (0 pred : NAT -> Type) ->
|
|
pred Examples.zero ->
|
|
((n : NAT) -> pred n -> pred (succ n)) ->
|
|
(n : NAT) -> pred n
|
|
NATind pred pZ pS = elim pred $ cases ("zero" .= pZero, "succ" .= pSucc)
|
|
|
|
where
|
|
|
|
-- we're forced to do quite a bit of additional pattern matching
|
|
-- because of a lack of eta
|
|
|
|
pZero : (k : AVoid ~> ?) -> ? -> pred (MkW "zero" k)
|
|
pZero (MkArr ()) ih = pZ
|
|
|
|
pSucc : (k : "x" ~> ?) -> Pi "x" (lam (\ p => pred (k $$ p))) -> pred (MkW "succ" k)
|
|
pSucc (MkArr (MkOne k)) (MkPi (MkOne ih)) = pS k ih
|
|
|
|
NATindZ : {0 pred : NAT -> Type} -> {0 pZ, pS : ?} ->
|
|
NATind pred pZ pS Examples.zero === pZ
|
|
NATindZ = Refl
|
|
|
|
NATindS : {0 pred : NAT -> Type} -> {0 pZ : ?} ->
|
|
{pS : (n : NAT) -> pred n -> pred (succ n)} ->
|
|
{0 n : NAT} -> NATind pred pZ pS (succ n) === pS n (NATind pred pZ pS n)
|
|
NATindS = Refl
|
|
|
|
namespace PartitionedSets
|
|
|
|
record PSet where
|
|
constructor MkPSet
|
|
parts : Fin
|
|
elems : parts ~> Type
|
|
|
|
mkPSet : (d : Fin) -> Arr d Type -> PSet
|
|
mkPSet d e = MkPSet d (MkArr e)
|
|
|
|
ElemArr : (parts : Fin) -> Arr parts Type -> Type
|
|
ElemArr AVoid elt = Void
|
|
ElemArr (AUnit nm) (MkOne e) = One nm e
|
|
ElemArr (d || e) (f, g) = Either (ElemArr d f) (ElemArr e g)
|
|
|
|
Elem : PSet -> Type
|
|
Elem (MkPSet d (MkArr elt)) = ElemArr d elt
|
|
|
|
el : {d : Fin} -> {e : d ~> Type} -> (x : Elem d) -> e $$ x -> Elem (MkPSet d e)
|
|
el {e = MkArr e} x ex = go d e x ex where
|
|
|
|
go : (d : Fin) -> (e : Arr d Type) -> (x : Elem d) -> appArr d e x -> ElemArr d e
|
|
go AVoid e x ex = x
|
|
go (AUnit nm) (MkOne e) x ex = MkOne ex
|
|
go (d || e) (f, g) (Left x) ex = Left (go d f x ex)
|
|
go (d || e) (f, g) (Right x) ex = Right (go e g x ex)
|
|
|
|
Arr : (d : Fin) -> Arr d Type -> Type -> Type
|
|
Arr AVoid e r = ()
|
|
Arr (AUnit nm) (MkOne e) r = One nm (e -> r)
|
|
Arr (d || e) (f , g) r = (Arr d f r, Arr e g r)
|
|
|
|
record (~>) (p : PSet) (r : Type) where
|
|
constructor MkArr
|
|
runArr : Arr p.parts p.elems.runArr r
|
|
|
|
PiArr : (d : Fin) -> (e : Arr d Type) -> Arr d e Type -> Type
|
|
PiArr AVoid e r = ()
|
|
PiArr (AUnit nm) (MkOne e) (MkOne r) = One nm ((x : e) -> r x)
|
|
PiArr (d || e) (f, g) r = (PiArr d f (fst r), PiArr e g (snd r))
|
|
|
|
record Pi (p : PSet) (r : p ~> Type) where
|
|
constructor MkPi
|
|
runPi : PiArr p.parts p.elems.runArr r.runArr
|
|
|
|
lamArr : (d : Fin) -> (e : Arr d Type) ->
|
|
(ElemArr d e -> r) -> (Arr d e r)
|
|
lamArr AVoid f b = ()
|
|
lamArr (AUnit nm) (MkOne f) b = MkOne (b . MkOne)
|
|
lamArr (d || e) (f, g) b = (lamArr d f (b . Left), lamArr e g (b . Right))
|
|
|
|
lam : {p : PSet} -> (Elem p -> r) -> (p ~> r)
|
|
lam {p = MkPSet d (MkArr e)} f = MkArr (lamArr d e f)
|
|
|
|
appArr : (d : Fin) -> (e : Arr d Type) ->
|
|
(Arr d e r) -> (ElemArr d e -> r)
|
|
appArr AVoid e b x = absurd x
|
|
appArr (AUnit nm) (MkOne e) (MkOne b) (MkOne x) = b x
|
|
appArr (d || e) (f, g) (b , c) (Left x) = appArr d f b x
|
|
appArr (d || e) (f, g) (b , c) (Right x) = appArr e g c x
|
|
|
|
($$) : {p : PSet} -> (p ~> r) -> Elem p -> r
|
|
($$) {p = MkPSet d (MkArr e)} (MkArr b) = appArr d e b
|
|
|
|
namespace Dependent
|
|
|
|
public export
|
|
lamArr : (d : Fin) -> (e : Arr d Type) -> (k : Arr d e Type) ->
|
|
((x : ElemArr d e) -> appArr d e k x) ->
|
|
PiArr d e k
|
|
lamArr AVoid e k b = ()
|
|
lamArr (AUnit nm) (MkOne e) (MkOne k) b = MkOne (\ x => b (MkOne x))
|
|
lamArr (d || e) (f, g) (k, l) b
|
|
= ( lamArr d f k (\ x => b (Left x))
|
|
, lamArr e g l (\ x => b (Right x)))
|
|
|
|
public export
|
|
lam : {p : PSet} -> {k : p ~> Type} ->
|
|
((x : Elem p) -> k $$ x) -> Pi p k
|
|
lam {p = MkPSet d (MkArr e)} {k = MkArr k} b = MkPi (lamArr d e k b)
|
|
|
|
public export
|
|
appArr : (d : Fin) -> (e : Arr d Type) -> (k : Arr d e Type) ->
|
|
PiArr d e k ->
|
|
((x : ElemArr d e) -> appArr d e k x)
|
|
appArr AVoid e k b x = absurd x
|
|
appArr (AUnit nm) (MkOne e) (MkOne k) (MkOne b) (MkOne x) = b x
|
|
appArr (d || e) (f, g) (k, l) (b, c) (Left x) = appArr d f k b x
|
|
appArr (d || e) (f, g) (k, l) (b, c) (Right x) = appArr e g l c x
|
|
|
|
public export
|
|
($$) : {p : PSet} -> {k : p ~> Type} ->
|
|
Pi p k -> ((x : Elem p) -> k $$ x)
|
|
($$) {p = MkPSet d (MkArr e)} {k = MkArr k} (MkPi b) = appArr d e k b
|
|
|
|
data W : (sh : Type) -> (pos : sh -> PSet) -> Type where
|
|
MkW : (s : sh) -> (k : pos s ~> W sh pos) -> W sh pos
|
|
|
|
mkW : {pos : sh -> PSet} ->
|
|
(s : sh) -> Arr ((pos s).parts) ((pos s) .elems .runArr) (W sh pos) ->
|
|
W sh pos
|
|
mkW s f = MkW s (MkArr f)
|
|
|
|
elim : {0 sh : Type} -> {pos : sh -> PSet} ->
|
|
(0 pred : W sh pos -> Type) ->
|
|
(step : (s : sh) -> (ts : pos s ~> W sh pos) ->
|
|
(Pi (pos s) (lam $ \ p => pred (ts $$ p))) ->
|
|
pred (MkW s ts)) ->
|
|
(w : W sh pos) -> pred w
|
|
elim pred step (MkW s (MkArr ts)) with (step s) | (pos s)
|
|
_ | steps | MkPSet d (MkArr e) = steps (MkArr ts) (MkPi $ ih d e ts) where
|
|
|
|
ih : (d : Fin) -> (e : Arr d Type) -> (ts : Arr d e (W sh pos)) ->
|
|
PiArr d e (lamArr d e $ \ p => pred (appArr d e ts p))
|
|
ih AVoid e ts = ()
|
|
ih (AUnit nm) (MkOne e) (MkOne ts) = MkOne (\ x => elim pred step (ts x))
|
|
ih (d || e) (f, g) (ts, us) = (ih d f ts, ih e g us)
|
|
|
|
namespace Examples
|
|
|
|
-- proceed with the following assumption
|
|
parameters { auto etaUnit : forall a. (o : () -> a) -> o === (\ _ => o ()) }
|
|
|
|
ORD : Type
|
|
ORD = PartitionedSets.W (Shape ("zero" || "succ" || "lim")) $ cases
|
|
( "zero" .= mkPSet AVoid ()
|
|
, "succ" .= mkPSet "x" ("x" .= ())
|
|
, "lim" .= mkPSet "f" ("f" .= NAT)
|
|
)
|
|
|
|
zero : ORD
|
|
zero = mkW "zero" ()
|
|
|
|
succ : ORD -> ORD
|
|
succ o = mkW "succ" ("x" .= \ _ => o)
|
|
|
|
lim : (NAT -> ORD) -> ORD
|
|
lim f = mkW "lim" ("f" .= f)
|
|
|
|
ORDind : (0 pred : ORD -> Type) ->
|
|
pred Examples.zero ->
|
|
((n : ORD) -> pred n -> pred (succ n)) ->
|
|
((f : NAT -> ORD) -> ((n : NAT) -> pred (f n)) -> pred (lim f)) ->
|
|
(n : ORD) -> pred n
|
|
ORDind pred pZ pS pL
|
|
= elim pred
|
|
$ cases ("zero" .= pZero, "succ" .= pSucc, "lim" .= pLim)
|
|
|
|
where
|
|
|
|
-- we're forced to do quite a bit of additional pattern matching
|
|
-- because of a lack of eta
|
|
|
|
pZero : (o : mkPSet AVoid () ~> ORD) -> ? -> pred (MkW "zero" o)
|
|
pZero (MkArr ()) ih = pZ
|
|
|
|
pSucc : (o : mkPSet (AUnit "x") ("x" .= ()) ~> ORD) ->
|
|
Pi (mkPSet (AUnit "x") ("x" .= ())) (lam (\p => pred (o $$ p))) ->
|
|
pred (MkW "succ" o)
|
|
pSucc (MkArr (MkOne o)) (MkPi (MkOne po)) =
|
|
rewrite etaUnit o in pS (o ()) (po ())
|
|
|
|
pLim : (o : mkPSet (AUnit "f") ("f" .= ?A) ~> ORD) ->
|
|
Pi (mkPSet (AUnit "f") ("f" .= ?B)) (lam (\p => pred (o $$ p))) ->
|
|
pred (MkW "lim" o)
|
|
pLim (MkArr (MkOne o)) (MkPi (MkOne po)) = pL o po
|
|
|
|
|
|
ORDindZ : {0 pred : ORD -> Type} -> {0 pZ, pS, pL : ?} ->
|
|
ORDind pred pZ pS pL Examples.zero === pZ
|
|
ORDindZ = Refl
|
|
|
|
ORDindS : {0 pred : ORD -> Type} -> {0 pZ, pL : ?} ->
|
|
{pS : (n : ORD) -> pred n -> pred (succ n)} ->
|
|
{0 n : ORD} -> ORDind pred pZ pS pL (succ n) === pS n (ORDind pred pZ pS pL n)
|
|
ORDindS = Refl
|
|
|
|
ORDindL : {0 pred : ORD -> Type} -> {0 pZ, pS : ?} ->
|
|
{pL : (f : NAT -> ORD) -> ((n : NAT) -> pred (f n)) -> pred (lim f)} ->
|
|
{0 f : NAT -> ORD} -> ORDind pred pZ pS pL (lim f) === pL f (\ n => ORDind pred pZ pS pL (f n))
|
|
ORDindL = Refl
|