rhi/quox
rhi
/
quox
1
0
Fork 0
Code Issues 16 Pull Requests 2 Releases Wiki Activity

"1.(x: A) → B" instead of "(1.x: A) → B" 

also "1.A → B"
This commit is contained in:
rhiannon morris 2023-03-18 23:27:27 +01:00
parent ebf6aefb1d
commit 8f0f0c1891
10 changed files with 101 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
lib/Quox/Parser/Parser.idr
View File

@ -151,31 +151,6 @@ toVect : List a -> (n ** Vect n a)
toVect [] = (_ ** [])
toVect (x :: xs) = (_ ** x :: snd (toVect xs))
private
0 MakeBinder : Nat -> Type
MakeBinder n = (String, PBinderHead n -> PTerm -> PTerm)
private
makePi : MakeBinder 1
makePi = ("→", \([pi], x, s) => Pi pi x s)
private
makeSig : MakeBinder 0
makeSig = ("×", \([], x, s) => Sig x s)
private
makeBinder : (m ** PBinderHead m) -> (n ** MakeBinder n) -> PTerm ->
Grammar False PTerm
makeBinder (m ** h) (n ** (str, f)) t =
case decEq m n of
Yes Refl => pure $ f h t
No _ =>
let q = if m == 1 then "quantity" else "quantities" in
fatalError "'\{str}' expects \{show m} \{q}, got \{show n}"
private
binderInfix : Grammar True (n ** MakeBinder n)
binderInfix = symbols [((1 ** makePi), "→"), ((0 ** makeSig), "×")]
private
lamIntro : Grammar True (BName -> PTerm -> PTerm)
@ -217,7 +192,21 @@ mutual
private covering
bindTerm : Grammar True PTerm
bindTerm = join [|makeBinder binderHead binderInfix term|]
bindTerm = pi <|> sigma
where
binderHead = parens {commit = False} [|MkPair bname (resC ":" *> term)|]
pi, sigma : Grammar True PTerm
pi = [|makePi (qty <* res ".") domain (resC "→" *> term)|]
where
makePi : Three -> (BName, PTerm) -> PTerm -> PTerm
makePi q (x, s) t = Pi q x s t
domain = binderHead <|> [|(Nothing,) aTerm|]
sigma = [|makeSigma binderHead (resC "×" *> annTerm)|]
where
makeSigma : (BName, PTerm) -> PTerm -> PTerm
makeSigma (x, s) t = Sig x s t
private covering
annTerm : Grammar True PTerm
@ -260,14 +249,6 @@ mutual
<|> [|Tag tag|]
<|> foldr1 Pair <$> parens (commaSep1 term)
private covering
binderHead : Grammar True (n ** PBinderHead n)
binderHead = parens {commit = False} $ do
qs <- [|toVect qtys|]
name <- bname
ty <- resC ":" *> term
pure (qs.fst ** (qs.snd, name, ty))
private covering
optBinderTerm : Grammar True (BName, PTerm)
optBinderTerm = [|MkPair optNameBinder term|]

21
lib/Quox/Syntax/Qty.idr
View File

@ -8,24 +8,6 @@ import Data.DPair
%default total
private
commas : List (Doc HL) -> List (Doc HL)
commas [] = []
commas [x] = [x]
commas (x::xs) = (x <+> hl Delim ",") :: commas xs
private %inline
dotD : Doc HL
dotD = hl Delim "."
export %inline
prettyQtyBinds : Pretty.HasEnv m => PrettyHL q => PrettyHL a =>
List q -> a -> m (Doc HL)
prettyQtyBinds [] x = pretty0M x
prettyQtyBinds qtys x = pure $
hcat [hseparate comma !(traverse pretty0M qtys), dotD, align !(pretty0M x)]
public export
interface Eq q => IsQty q where
zero, one : q
@ -57,6 +39,9 @@ interface Eq q => IsQty q where
isGlobal : Dec1 IsGlobal
zeroIsGlobal : forall pi. IsZero pi -> IsGlobal zero
||| prints in a form that can be a suffix of "case"
prettySuffix : Pretty.HasEnv m => q -> m (Doc HL)
public export
0 SQty : (q : Type) -> IsQty q => Type
SQty q = Subset q IsSubj

2
lib/Quox/Syntax/Qty/Three.idr
View File

@ -120,6 +120,8 @@ IsQty Three where
isGlobal = isGlobal3
zeroIsGlobal = \Refl => GZero
prettySuffix = pretty0M
export Uninhabited (IsGlobal3 One) where uninhabited _ impossible

69
lib/Quox/Syntax/Term/Pretty.idr
View File

@ -24,13 +24,14 @@ dlamD = hlF Syntax $ ifUnicode "δ" "dfun"
annD = hlF Syntax $ ifUnicode "∷" "::"
private %inline
eqD, colonD, commaD, caseD, returnD, ofD : Doc HL
eqD, colonD, commaD, caseD, returnD, ofD, dotD : Doc HL
eqD = hl Syntax "Eq"
colonD = hl Syntax ":"
commaD = hl Syntax ","
caseD = hl Syntax "case"
ofD = hl Syntax "of"
returnD = hl Syntax "return"
dotD = hl Delim "."
export
@ -47,22 +48,39 @@ export
prettyUniverse : Universe -> Doc HL
prettyUniverse = hl Syntax . pretty
public export
data WithQty q a = MkWithQty q a
export
prettyBind : PrettyHL a => PrettyHL q => Pretty.HasEnv m =>
List q -> BaseName -> a -> m (Doc HL)
prettyBind qtys x s = do
var <- prettyQtyBinds qtys $ TV x
s <- withPrec Outer $ prettyM s
pure $ var <++> colonD <%%> hang 2 s
PrettyHL q => PrettyHL a => PrettyHL (WithQty q a) where
prettyM (MkWithQty q x) = do
q <- pretty0M q
x <- withPrec Arg $ prettyM x
pure $ hcat [q, dotD, x]
public export
data Binder a = MkBinder BaseName a
export
PrettyHL a => PrettyHL (Binder a) where
prettyM (MkBinder x ty) = do
x <- pretty0M $ TV x
ty <- align <$> pretty0M ty
pure $ parens $ sep [hsep [x, colonD], ty]
export
prettyBindType : PrettyHL a => PrettyHL b => PrettyHL q =>
Pretty.HasEnv m =>
List q -> BaseName -> a -> Doc HL -> b -> m (Doc HL)
prettyBindType qtys x s arr t = do
bind <- prettyBind qtys x s
t <- withPrec AnnR $ under T x $ prettyM t
parensIfM AnnR $ hang 2 $ parens bind <++> arr <%%> t
Maybe q -> BaseName -> a -> Doc HL -> b -> m (Doc HL)
prettyBindType q x s arr t = do
bind <- case q of
Nothing => pretty0M $ MkBinder x s
Just q => pretty0M $ MkWithQty q $ MkBinder x s
t <- withPrec AnnR $ under T x $ prettyM t
parensIfM AnnR $ hang 2 $ bind <++> arr <%%> t
export
prettyArm : PrettyHL a => Pretty.HasEnv m =>
@ -105,15 +123,16 @@ prettyArms =
map (braces . asep) . traverse (\(xs, l, r) => prettyArm T xs l r)
export
prettyCase : PrettyHL a => PrettyHL b => PrettyHL c => PrettyHL q =>
prettyCase : PrettyHL a => PrettyHL b => PrettyHL c => IsQty q =>
Pretty.HasEnv m =>
q -> a -> BaseName -> b -> List (SnocList BaseName, Doc HL, c) ->
m (Doc HL)
prettyCase pi elim r ret arms = do
elim <- prettyQtyBinds [pi] elim
ret <- prettyLams Nothing T [< r] ret
arms <- prettyArms arms
pure $ asep [caseD <++> elim, returnD <++> ret, ofD <++> arms]
caseq <- (caseD <+>) <$> prettySuffix pi
elim <- pretty0M elim
ret <- prettyLams Nothing T [< r] ret
arms <- prettyArms arms
pure $ asep [caseq <++> elim, returnD <++> ret, ofD <++> arms]
export
escapeString : String -> String
@ -142,12 +161,12 @@ prettyTagBare t = hl Tag $ quoteTag t
parameters (showSubsts : Bool)
mutual
export covering
[TermSubst] PrettyHL q => PrettyHL (Term q d n) using TermSubst ElimSubst
[TermSubst] IsQty q => PrettyHL q => PrettyHL (Term q d n) using ElimSubst
where
prettyM (TYPE l) =
parensIfM App $ !typeD <+> hl Syntax !(prettyUnivSuffix l)
prettyM (Pi qty s (S [< x] t)) =
prettyBindType [qty] x s !arrowD t.term
prettyBindType (Just qty) x s !arrowD t.term
prettyM (Lam (S x t)) =
let GotLams {names, body, _} = getLams' x t.term Refl in
prettyLams (Just !lamD) T (toSnocList' names) body
@ -156,7 +175,7 @@ parameters (showSubsts : Bool)
t <- withPrec Times $ prettyM t
parensIfM Times $ asep [s <++> !timesD, t]
prettyM (Sig s (S [< x] (Y t))) =
prettyBindType {q} [] x s !timesD t
prettyBindType {q} Nothing x s !timesD t
prettyM (Pair s t) =
let GotPairs {init, last, _} = getPairs' [< s] t in
prettyTuple $ toList $ init :< last
@ -193,7 +212,7 @@ parameters (showSubsts : Bool)
prettyM $ pushSubstsWith' th id s
export covering
[ElimSubst] PrettyHL q => PrettyHL (Elim q d n) using TermSubst ElimSubst
[ElimSubst] IsQty q => PrettyHL q => PrettyHL (Elim q d n) using TermSubst
where
prettyM (F x) =
hl' Free <$> prettyM x
@ -229,22 +248,22 @@ parameters (showSubsts : Bool)
prettyM $ pushSubstsWith' th id e
export covering
prettyTSubst : Pretty.HasEnv m => PrettyHL q =>
prettyTSubst : Pretty.HasEnv m => IsQty q => PrettyHL q =>
TSubst q d from to -> m (Doc HL)
prettyTSubst s =
prettySubstM (prettyM @{ElimSubst}) (!ask).tnames TVar "[" "]" s
export covering %inline
PrettyHL q => PrettyHL (Term q d n) where
IsQty q => PrettyHL q => PrettyHL (Term q d n) where
prettyM = prettyM @{TermSubst False}
export covering %inline
PrettyHL q => PrettyHL (Elim q d n) where
IsQty q => PrettyHL q => PrettyHL (Elim q d n) where
prettyM = prettyM @{ElimSubst False}
export covering
prettyTerm : PrettyHL q => (unicode : Bool) ->
prettyTerm : IsQty q => PrettyHL q => (unicode : Bool) ->
(dnames : NContext d) -> (tnames : NContext n) ->
Term q d n -> Doc HL
prettyTerm unicode dnames tnames term =

5
lib/Quox/Typing/Context.idr
View File

@ -150,14 +150,15 @@ namespace EqContext
}
parameters {auto _ : (Eq q, PrettyHL q)} (unicode : Bool)
parameters {auto _ : (Eq q, PrettyHL q, IsQty q)} (unicode : Bool)
export covering
prettyTContext : QContext q n -> NContext n -> TContext q d n -> Doc HL
prettyTContext qs ns ctx = separate comma $ toList $ go qs ns ctx where
go : QContext q m -> NContext m -> TContext q d m -> SnocList (Doc HL)
go [<] [<] [<] = [<]
go (qs :< q) (xs :< x) (ctx :< t) =
go qs xs ctx :< runPretty unicode (prettyBind [q] x t)
let bind = MkWithQty q $ MkBinder x t in
go qs xs ctx :< runPretty unicode (pretty0M bind)
private
prettyDVars : NContext d -> Doc HL

2
lib/Quox/Typing/Error.idr
View File

@ -154,7 +154,7 @@ isTypeInUniverse : Maybe Universe -> Doc HL
isTypeInUniverse Nothing = "is a type"
isTypeInUniverse (Just k) = "is a type in universe" <++> prettyUniverse k
parameters {auto _ : (Eq q, PrettyHL q)} (unicode : Bool)
parameters {auto _ : (Eq q, IsQty q, PrettyHL q)} (unicode : Bool)
private
termt : TyContext q d n -> Term q d n -> Doc HL
termt ctx = hang 4 . prettyTerm unicode ctx.dnames ctx.tnames

4
tests/TermImpls.idr
View File

@ -104,9 +104,9 @@ mutual
DCloE {} == _ = False
export covering
PrettyHL q => Show (Term q d n) where
IsQty q => PrettyHL q => Show (Term q d n) where
showPrec d t = showParens (d /= Open) $ prettyStr True t
export covering
PrettyHL q => Show (Elim q d n) where
IsQty q => PrettyHL q => Show (Elim q d n) where
showPrec d e = showParens (d /= Open) $ prettyStr True e

18
tests/Tests/Parser.idr
View File

@ -140,21 +140,25 @@ tests = "parser" :- [
],
"binders" :- [
parsesAs term "(1.x : A) → B x" $
parsesAs term "1.(x : A) → B x" $
Pi One (Just "x") (V "A") (V "B" :@ V "x"),
parsesAs term "(1.x : A) -> B x" $
parsesAs term "1.(x : A) -> B x" $
Pi One (Just "x") (V "A") (V "B" :@ V "x"),
parsesAs term "(ω.x : A) → B x" $
parsesAs term "ω.(x : A) → B x" $
Pi Any (Just "x") (V "A") (V "B" :@ V "x"),
parsesAs term "(#.x : A) -> B x" $
parsesAs term "#.(x : A) -> B x" $
Pi Any (Just "x") (V "A") (V "B" :@ V "x"),
parseFails term "(x : A) → B x",
parseFails term "(1 ω.x : A) → B x",
parsesAs term "1.A → B"
(Pi One Nothing (V "A") (V "B")),
parsesAs term "1.(List A) → List B"
(Pi One Nothing (V "List" :@ V "A") (V "List" :@ V "B")),
parseFails term "1.List A → List B",
parsesAs term "(x : A) × B x" $
Sig (Just "x") (V "A") (V "B" :@ V "x"),
parsesAs term "(x : A) ** B x" $
Sig (Just "x") (V "A") (V "B" :@ V "x"),
parseFails term "(1.x : A) × B x",
parseFails term "1.(x : A) × B x",
parsesAs term "A × B" $
Sig Nothing (V "A") (V "B"),
parsesAs term "A ** B" $
@ -185,7 +189,7 @@ tests = "parser" :- [
Pair (Pair (V "x") (V "y")) (V "z"),
parsesAs term "(f x, g @y)" $
Pair (V "f" :@ V "x") (V "g" :% V "y"),
parsesAs term "((x : A) × B, (0.x : C) → D)" $
parsesAs term "((x : A) × B, 0.(x : C) → D)" $
Pair (Sig (Just "x") (V "A") (V "B"))
(Pi Zero (Just "x") (V "C") (V "D")),
parsesAs term "(λ x ⇒ x, δ i ⇒ e @i)" $

33
tests/Tests/PrettyTerm.idr
View File

@ -93,17 +93,17 @@ tests = "pretty printing terms" :- [
testPrettyT [<] [<] (Arr One (FT "A") (FT "B")) "A ⊸ B" "A -o B",
testPrettyT [<] [<]
(Pi_ One "x" (FT "A") (E $ F "B" :@ BVT 0))
"(1.x : A) → B x"
"(1.x : A) -> B x",
"1.(x : A) → B x"
"1.(x : A) -> B x",
testPrettyT [<] [<]
(Pi_ Zero "A" (TYPE 0) $ Arr Any (BVT 0) (BVT 0))
"(0.A : ★₀) → (ω._ : A) → A"
"(0.A : Type0) -> (#._ : A) -> A",
"0.(A : ★₀) → ω.(_ : A) → A"
"0.(A : Type0) -> #.(_ : A) -> A",
todo #"print (and parse) the below as "(A ↠ A) ↠ A""#,
testPrettyT [<] [<]
(Arr Any (Arr Any (FT "A") (FT "A")) (FT "A"))
"(ω._ : (ω._ : A) → A) → A"
"(#._ : (#._ : A) -> A) -> A",
"ω.(_ : ω.(_ : A) → A) → A"
"#.(_ : #.(_ : A) -> A) -> A",
todo "non-dependent, left and right nested"
],
@ -128,8 +128,8 @@ tests = "pretty printing terms" :- [
testPrettyT1 [<] [<] (Pair (Pair (FT "A") (FT "B")) (FT "C")) "((A, B), C)",
testPrettyT [<] [<]
(Pair ([< "x"] :\\ BVT 0) (Arr One (FT "B₁") (FT "B₂")))
"(λ x ⇒ x, (1._ : B₁) → B₂)"
"(fun x => x, (1._ : B₁) -> B₂)"
"(λ x ⇒ x, 1.(_ : B₁) → B₂)"
"(fun x => x, 1.(_ : B₁) -> B₂)"
],
"enum types" :- [
@ -152,20 +152,19 @@ tests = "pretty printing terms" :- [
todo "equality types",
"case" :- [
note "todo: print using case1 and caseω???",
testPrettyE [<] [<]
(CasePair One (F "a") (SN $ TYPE 1) (SN $ TYPE 0))
"case 1.a return _ ⇒ ★₁ of { (_, _) ⇒ ★₀ }"
"case 1.a return _ => Type1 of { (_, _) => Type0 }",
"case1 a return _ ⇒ ★₁ of { (_, _) ⇒ ★₀ }"
"case1 a return _ => Type1 of { (_, _) => Type0 }",
testPrettyT [<] [<]
([< "u"] :\\
E (CaseEnum One (F "u")
(SY [< "x"] $ Eq0 (enum ["tt"]) (BVT 0) (Tag "tt"))
(fromList [("tt", [< Unused] :\\% Tag "tt")])))
"λ u ⇒ case 1.u return x ⇒ x ≡ 'tt : {tt} of { 'tt ⇒ δ _ ⇒ 'tt }"
"λ u ⇒ case1 u return x ⇒ x ≡ 'tt : {tt} of { 'tt ⇒ δ _ ⇒ 'tt }"
"""
fun u =>
case 1.u return x => x == 'tt : {tt} of { 'tt => dfun _ => 'tt }
case1 u return x => x == 'tt : {tt} of { 'tt => dfun _ => 'tt }
"""
],
@ -181,11 +180,11 @@ tests = "pretty printing terms" :- [
"(α :: a) :: A",
testPrettyE [<] [<]
(([< "x"] :\\ BVT 0) :# Arr One (FT "A") (FT "A"))
"(λ x ⇒ x) ∷ (1._ : A) → A"
"(fun x => x) :: (1._ : A) -> A",
"(λ x ⇒ x) ∷ 1.(_ : A) → A"
"(fun x => x) :: 1.(_ : A) -> A",
testPrettyE [<] [<]
(Arr One (FT "A") (FT "A") :# TYPE 7)
"((1._ : A) → A) ∷ ★₇"
"((1._ : A) -> A) :: Type7"
"(1.(_ : A) → A) ∷ ★₇"
"(1.(_ : A) -> A) :: Type7"
]
]

8
tests/TypingImpls.idr
View File

@ -14,15 +14,15 @@ import Derive.Prelude
%runElab deriveIndexed "DimEq" [Show]
export %hint
showTyContext : (PrettyHL q, Show q) => Show (TyContext q d n)
showTyContext : (IsQty q, PrettyHL q, Show q) => Show (TyContext q d n)
showTyContext = deriveShow
export %hint
showEqContext : (PrettyHL q, Show q) => Show (EqContext q n)
showEqContext : (IsQty q, PrettyHL q, Show q) => Show (EqContext q n)
showEqContext = deriveShow
export %hint
showTypingError : (PrettyHL q, Show q) => Show (Error q)
showTypingError : (IsQty q, PrettyHL q, Show q) => Show (Error q)
showTypingError = deriveShow
export
@ -33,5 +33,5 @@ ToInfo WhnfError where
("list", show ts)]
export
(Eq q, PrettyHL q) => ToInfo (Error q) where
(IsQty q, PrettyHL q) => ToInfo (Error q) where
toInfo err = [("err", show $ prettyError True True err)]