remove src directories
This commit is contained in:
parent
79211cff84
commit
804f1e3638
36 changed files with 0 additions and 3 deletions
289
lib/Quox/Context.idr
Normal file
289
lib/Quox/Context.idr
Normal file
|
|
@ -0,0 +1,289 @@
|
|||
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 global 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 global 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` drop1 by
|
||||
getShiftWith shft by (ctx :< t) (VS i) = getShiftWith shft (drop1 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)
|
||||
161
lib/Quox/Equal.idr
Normal file
161
lib/Quox/Equal.idr
Normal file
|
|
@ -0,0 +1,161 @@
|
|||
module Quox.Equal
|
||||
|
||||
import public Quox.Syntax
|
||||
import public Quox.Reduce
|
||||
import Control.Monad.Either
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
data Mode = Equal | Sub
|
||||
|
||||
export %inline Show Mode where show Equal = "Equal"; show Sub = "Sub"
|
||||
|
||||
public export
|
||||
data Error
|
||||
= ClashT Mode (Term d n) (Term d n)
|
||||
| ClashU Mode Universe Universe
|
||||
| ClashQ Qty Qty
|
||||
|
||||
private %inline
|
||||
ClashE : Mode -> Elim d n -> Elim d n -> Error
|
||||
ClashE mode = ClashT mode `on` E
|
||||
|
||||
parameters {auto _ : MonadError Error m}
|
||||
private %inline
|
||||
clashT : Mode -> Term d n -> Term d n -> m a
|
||||
clashT mode = throwError .: ClashT mode
|
||||
|
||||
private %inline
|
||||
clashE : Mode -> Elim d n -> Elim d n -> m a
|
||||
clashE mode = throwError .: ClashE mode
|
||||
|
||||
mutual
|
||||
private covering
|
||||
compareTN' : Mode ->
|
||||
(s, t : Term 0 n) ->
|
||||
(0 _ : NotRedexT s) -> (0 _ : NotRedexT t) -> m ()
|
||||
|
||||
compareTN' mode (TYPE k) (TYPE l) _ _ =
|
||||
case mode of
|
||||
Equal => unless (k == l) $ throwError $ ClashU Equal k l
|
||||
Sub => unless (k <= l) $ throwError $ ClashU Sub k l
|
||||
compareTN' mode s@(TYPE _) t _ _ = clashT mode s t
|
||||
|
||||
compareTN' mode (Pi qty1 _ arg1 res1) (Pi qty2 _ arg2 res2) _ _ = do
|
||||
-- [todo] this should probably always be ==, right..?
|
||||
unless (qty1 == qty2) $ throwError $ ClashQ qty1 qty2
|
||||
compareT0 mode arg2 arg1 -- reversed for contravariant Sub
|
||||
compareTS0 mode res1 res2
|
||||
compareTN' mode s@(Pi {}) t _ _ = clashT mode s t
|
||||
|
||||
-- [todo] eta
|
||||
compareTN' _ (Lam _ body1) (Lam _ body2) _ _ =
|
||||
compareTS0 Equal body1 body2
|
||||
compareTN' mode s@(Lam {}) t _ _ = clashT mode s t
|
||||
|
||||
compareTN' mode (E e) (E f) ps pt = compareE0 mode e f
|
||||
compareTN' mode s@(E _) t _ _ = clashT mode s t
|
||||
|
||||
compareTN' _ (CloT {}) _ ps _ = void $ ps IsCloT
|
||||
compareTN' _ (DCloT {}) _ ps _ = void $ ps IsDCloT
|
||||
|
||||
private covering
|
||||
compareEN' : Mode ->
|
||||
(e, f : Elim 0 n) ->
|
||||
(0 _ : NotRedexE e) -> (0 _ : NotRedexE f) -> m ()
|
||||
|
||||
compareEN' mode e@(F x) f@(F y) _ _ =
|
||||
unless (x == y) $ clashE mode e f
|
||||
compareEN' mode e@(F _) f _ _ = clashE mode e f
|
||||
|
||||
compareEN' mode e@(B i) f@(B j) _ _ =
|
||||
unless (i == j) $ clashE mode e f
|
||||
compareEN' mode e@(B _) f _ _ = clashE mode e f
|
||||
|
||||
-- [todo] tracking variance of functions? maybe???
|
||||
-- probably not
|
||||
compareEN' _ (fun1 :@ arg1) (fun2 :@ arg2) _ _ = do
|
||||
compareE0 Equal fun1 fun2
|
||||
compareT0 Equal arg1 arg2
|
||||
compareEN' mode e@(_ :@ _) f _ _ = clashE mode e f
|
||||
|
||||
-- [todo] is always checking the types are equal correct?
|
||||
compareEN' mode (tm1 :# ty1) (tm2 :# ty2) _ _ = do
|
||||
compareT0 mode tm1 tm2
|
||||
compareT0 Equal ty1 ty2
|
||||
compareEN' mode e@(_ :# _) f _ _ = clashE mode e f
|
||||
|
||||
compareEN' _ (CloE {}) _ pe _ = void $ pe IsCloE
|
||||
compareEN' _ (DCloE {}) _ pe _ = void $ pe IsDCloE
|
||||
|
||||
|
||||
private covering %inline
|
||||
compareTN : Mode -> NonRedexTerm 0 n -> NonRedexTerm 0 n -> m ()
|
||||
compareTN mode s t = compareTN' mode s.fst t.fst s.snd t.snd
|
||||
|
||||
private covering %inline
|
||||
compareEN : Mode -> NonRedexElim 0 n -> NonRedexElim 0 n -> m ()
|
||||
compareEN mode e f = compareEN' mode e.fst f.fst e.snd f.snd
|
||||
|
||||
|
||||
export covering %inline
|
||||
compareT : Mode -> DimEq d -> Term d n -> Term d n -> m ()
|
||||
compareT mode eqs s t =
|
||||
for_ (splits eqs) $ \th => compareT0 mode (s /// th) (t /// th)
|
||||
|
||||
export covering %inline
|
||||
compareE : Mode -> DimEq d -> Elim d n -> Elim d n -> m ()
|
||||
compareE mode eqs e f =
|
||||
for_ (splits eqs) $ \th => compareE0 mode (e /// th) (f /// th)
|
||||
|
||||
|
||||
export covering %inline
|
||||
compareT0 : Mode -> Term 0 n -> Term 0 n -> m ()
|
||||
compareT0 mode s t = compareTN mode (whnfT s) (whnfT t)
|
||||
|
||||
export covering %inline
|
||||
compareE0 : Mode -> Elim 0 n -> Elim 0 n -> m ()
|
||||
compareE0 mode e f = compareEN mode (whnfE e) (whnfE f)
|
||||
|
||||
export covering %inline
|
||||
compareTS0 : Mode -> ScopeTerm 0 n -> ScopeTerm 0 n -> m ()
|
||||
compareTS0 mode (TUnused body1) (TUnused body2) =
|
||||
compareT0 mode body1 body2
|
||||
compareTS0 mode body1 body2 =
|
||||
compareT0 mode (fromScopeTerm body1) (fromScopeTerm body2)
|
||||
|
||||
|
||||
export covering %inline
|
||||
equalTWith : DimEq d -> Term d n -> Term d n -> m ()
|
||||
equalTWith = compareT Equal
|
||||
|
||||
export covering %inline
|
||||
equalEWith : DimEq d -> Elim d n -> Elim d n -> m ()
|
||||
equalEWith = compareE Equal
|
||||
|
||||
export covering %inline
|
||||
subTWith : DimEq d -> Term d n -> Term d n -> m ()
|
||||
subTWith = compareT Sub
|
||||
|
||||
export covering %inline
|
||||
subEWith : DimEq d -> Elim d n -> Elim d n -> m ()
|
||||
subEWith = compareE Sub
|
||||
|
||||
|
||||
export covering %inline
|
||||
equalT : {d : Nat} -> Term d n -> Term d n -> m ()
|
||||
equalT = equalTWith DimEq.new
|
||||
|
||||
export covering %inline
|
||||
equalE : {d : Nat} -> Elim d n -> Elim d n -> m ()
|
||||
equalE = equalEWith DimEq.new
|
||||
|
||||
export covering %inline
|
||||
subT : {d : Nat} -> Term d n -> Term d n -> m ()
|
||||
subT = subTWith DimEq.new
|
||||
|
||||
export covering %inline
|
||||
subE : {d : Nat} -> Elim d n -> Elim d n -> m ()
|
||||
subE = subEWith DimEq.new
|
||||
128
lib/Quox/Lexer.idr
Normal file
128
lib/Quox/Lexer.idr
Normal file
|
|
@ -0,0 +1,128 @@
|
|||
module Quox.Lexer
|
||||
|
||||
import public Quox.Token
|
||||
|
||||
import Data.String
|
||||
import Data.String.Extra
|
||||
import public Text.Lexer
|
||||
import public Text.Lexer.Tokenizer
|
||||
import Control.Monad.Either
|
||||
import Generics.Derive
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
||||
|
||||
public export
|
||||
record Error where
|
||||
constructor Err
|
||||
reason : StopReason
|
||||
line, col : Int
|
||||
char : Char
|
||||
|
||||
|
||||
|
||||
nameStart = pred $ \c => isAlpha c || c == '_'
|
||||
nameCont = pred $ \c => isAlphaNum c || c == '_' || c == '\''
|
||||
|
||||
name = nameStart <+> many nameCont <+> reject nameCont
|
||||
|
||||
wild = exact "_" <+> reject nameCont
|
||||
|
||||
%hide Text.Lexer.symbol
|
||||
symbol = exact "'" <+> name
|
||||
|
||||
number : Lexer -> Lexer
|
||||
number char = char <+> many (opt (is '_') <+> char) <+> reject nameCont
|
||||
|
||||
octal = approx "0o" <+> number octDigit
|
||||
decimal = number digit
|
||||
hexadecimal = approx "0x" <+> number hexDigit
|
||||
|
||||
|
||||
natToNumber : Nat -> Number
|
||||
natToNumber 0 = Zero
|
||||
natToNumber 1 = One
|
||||
natToNumber k = Other k
|
||||
|
||||
|
||||
toHexit : Char -> Nat
|
||||
toHexit c = cast $
|
||||
if '0' <= c && c <= '9' then
|
||||
ord c - ord '0'
|
||||
else if 'a' <= c && c <= 'f' then
|
||||
ord c - ord 'a' + 10
|
||||
else if 'A' <= c && c <= 'F' then
|
||||
ord c - ord 'A' + 10
|
||||
else 0
|
||||
|
||||
parameters (base : Nat) (single : Char -> Nat)
|
||||
makeNat : Nat -> List Char -> Nat
|
||||
makeNat acc [] = acc
|
||||
makeNat acc ('_' :: lst) = makeNat acc lst
|
||||
makeNat acc (d :: lst) = makeNat (acc * base + single d) lst
|
||||
|
||||
makeOct = makeNat 8 toHexit 0 . unpack
|
||||
makeDec = makeNat 10 toHexit 0 . unpack
|
||||
makeHex = makeNat 16 toHexit 0 . unpack
|
||||
|
||||
|
||||
skip : Lexer -> Tokenizer (Maybe a)
|
||||
skip lex = match lex $ const Nothing
|
||||
|
||||
simple : List String -> a -> Tokenizer (Maybe a)
|
||||
simple strs = match (choice $ map exact strs) . const . Just
|
||||
|
||||
keyword : String -> Keyword -> Tokenizer (Maybe Token)
|
||||
keyword str = match (exact str <+> reject nameCont) . const . Just . K
|
||||
|
||||
choice : (xs : List (Tokenizer a)) -> {auto 0 _ : NonEmpty xs} -> Tokenizer a
|
||||
choice (t :: ts) = foldl (\a, b => a <|> b) t ts
|
||||
|
||||
match : Lexer -> (String -> a) -> Tokenizer (Maybe a)
|
||||
match lex f = Tokenizer.match lex (Just . f)
|
||||
%hide Tokenizer.match
|
||||
|
||||
|
||||
tokens : Tokenizer (Maybe Token)
|
||||
tokens = choice [
|
||||
skip $ lineComment $ exact "--",
|
||||
skip $ blockComment (exact "{-") (exact "-}"),
|
||||
skip spaces,
|
||||
|
||||
simple ["("] $ P LParen, simple [")"] $ P RParen,
|
||||
simple ["["] $ P LSquare, simple ["]"] $ P RSquare,
|
||||
simple ["{"] $ P LBrace, simple ["}"] $ P RBrace,
|
||||
simple [","] $ P Comma,
|
||||
simple ["::", "∷"] $ P DblColon,
|
||||
simple [":"] $ P Colon, -- needs to be after "::"
|
||||
simple ["."] $ P Dot,
|
||||
|
||||
simple ["->", "→"] $ P Arrow,
|
||||
simple ["=>", "⇒"] $ P DblArrow,
|
||||
simple ["**", "×"] $ P Times,
|
||||
simple ["<<", "⊲"] $ P Triangle,
|
||||
match wild $ const $ P Wild,
|
||||
|
||||
keyword "fun" Fun, keyword "λ" Fun,
|
||||
keyword "let" Let, keyword "in" In,
|
||||
keyword "case" Case, keyword "of" Of,
|
||||
keyword "ω" Omega, simple ["#"] $ K Omega,
|
||||
|
||||
match name $ Name,
|
||||
match symbol $ Symbol . assert_total strTail,
|
||||
|
||||
match decimal $ N . natToNumber . makeDec,
|
||||
match hexadecimal $ N . natToNumber . makeHex . drop 2,
|
||||
match octal $ N . natToNumber . makeOct . drop 2
|
||||
]
|
||||
|
||||
|
||||
export
|
||||
lex : String -> Either Error (List BToken)
|
||||
lex str =
|
||||
let (res, (reason, line, col, str)) = lex tokens str in
|
||||
case reason of
|
||||
EndInput => Right $ mapMaybe sequence res
|
||||
_ => let char = assert_total strIndex str 0 in
|
||||
Left $ Err {reason, line, col, char}
|
||||
52
lib/Quox/Name.idr
Normal file
52
lib/Quox/Name.idr
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
module Quox.Name
|
||||
|
||||
import public Data.SnocList
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
data BaseName =
|
||||
UN String -- user-given name
|
||||
|
||||
private BRepr : Type
|
||||
BRepr = String
|
||||
|
||||
private %inline brepr : BaseName -> BRepr
|
||||
brepr (UN x) = x
|
||||
|
||||
export Eq BaseName where (==) = (==) `on` brepr
|
||||
export Ord BaseName where compare = compare `on` brepr
|
||||
|
||||
export
|
||||
baseStr : BaseName -> String
|
||||
baseStr (UN x) = x
|
||||
|
||||
export
|
||||
FromString BaseName where
|
||||
fromString = UN
|
||||
|
||||
|
||||
public export
|
||||
record Name where
|
||||
constructor MakeName
|
||||
mods : SnocList String
|
||||
base : BaseName
|
||||
|
||||
private Repr : Type
|
||||
Repr = (SnocList String, BRepr)
|
||||
|
||||
private %inline repr : Name -> Repr
|
||||
repr x = (x.mods, brepr x.base)
|
||||
|
||||
export Eq Name where (==) = (==) `on` repr
|
||||
export Ord Name where compare = compare `on` repr
|
||||
|
||||
export
|
||||
FromString Name where
|
||||
fromString x = MakeName [<] (fromString x)
|
||||
|
||||
|
||||
export
|
||||
toDots : Name -> String
|
||||
toDots x = fastConcat $ cast $ map (<+> ".") x.mods :< baseStr x.base
|
||||
32
lib/Quox/NatExtra.idr
Normal file
32
lib/Quox/NatExtra.idr
Normal file
|
|
@ -0,0 +1,32 @@
|
|||
module Quox.NatExtra
|
||||
|
||||
import public Data.Nat
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
data LTE' : Nat -> Nat -> Type where
|
||||
LTERefl : LTE' n n
|
||||
LTESuccR : LTE' m n -> LTE' m (S n)
|
||||
%builtin Natural LTE'
|
||||
|
||||
public export %hint
|
||||
lteZero' : {n : Nat} -> LTE' 0 n
|
||||
lteZero' {n = 0} = LTERefl
|
||||
lteZero' {n = S n} = LTESuccR lteZero'
|
||||
|
||||
public export %hint
|
||||
lteSucc' : LTE' m n -> LTE' (S m) (S n)
|
||||
lteSucc' LTERefl = LTERefl
|
||||
lteSucc' (LTESuccR p) = LTESuccR $ lteSucc' p
|
||||
|
||||
public export
|
||||
fromLte : {n : Nat} -> LTE m n -> LTE' m n
|
||||
fromLte LTEZero = lteZero'
|
||||
fromLte (LTESucc p) = lteSucc' $ fromLte p
|
||||
|
||||
public export
|
||||
toLte : {n : Nat} -> m `LTE'` n -> m `LTE` n
|
||||
toLte LTERefl = reflexive
|
||||
toLte (LTESuccR p) = lteSuccRight (toLte p)
|
||||
196
lib/Quox/OPE.idr
Normal file
196
lib/Quox/OPE.idr
Normal file
|
|
@ -0,0 +1,196 @@
|
|||
||| "order preserving embeddings", for recording a correspondence between
|
||||
||| a smaller scope and part of a larger one.
|
||||
module Quox.OPE
|
||||
|
||||
import Quox.NatExtra
|
||||
|
||||
import Data.Nat
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
data OPE : Nat -> Nat -> Type where
|
||||
Id : OPE n n
|
||||
Drop : OPE m n -> OPE m (S n)
|
||||
Keep : OPE m n -> OPE (S m) (S n)
|
||||
%name OPE p, q
|
||||
|
||||
public export %inline Injective Drop where injective Refl = Refl
|
||||
public export %inline Injective Keep where injective Refl = Refl
|
||||
|
||||
public export
|
||||
opeZero : {n : Nat} -> OPE 0 n
|
||||
opeZero {n = 0} = Id
|
||||
opeZero {n = S n} = Drop opeZero
|
||||
|
||||
public export
|
||||
(.) : OPE m n -> OPE n p -> OPE m p
|
||||
p . Id = p
|
||||
Id . q = q
|
||||
p . Drop q = Drop $ p . q
|
||||
Drop p . Keep q = Drop $ p . q
|
||||
Keep p . Keep q = Keep $ p . q
|
||||
|
||||
public export
|
||||
toLTE : {m : Nat} -> OPE m n -> m `LTE` n
|
||||
toLTE Id = reflexive
|
||||
toLTE (Drop p) = lteSuccRight $ toLTE p
|
||||
toLTE (Keep p) = LTESucc $ toLTE p
|
||||
|
||||
|
||||
public export
|
||||
dropInner' : LTE' m n -> OPE m n
|
||||
dropInner' LTERefl = Id
|
||||
dropInner' (LTESuccR p) = Drop $ dropInner' $ force p
|
||||
|
||||
public export
|
||||
dropInner : {n : Nat} -> LTE m n -> OPE m n
|
||||
dropInner = dropInner' . fromLte
|
||||
|
||||
public export
|
||||
dropInnerN : (m : Nat) -> OPE n (m + n)
|
||||
dropInnerN 0 = Id
|
||||
dropInnerN (S m) = Drop $ dropInnerN m
|
||||
|
||||
|
||||
public export
|
||||
interface Tighten t where
|
||||
tighten : Alternative f => OPE m n -> t n -> f (t m)
|
||||
|
||||
parameters {auto _ : Tighten t} {auto _ : Alternative f}
|
||||
export
|
||||
tightenInner : {n : Nat} -> m `LTE` n -> t n -> f (t m)
|
||||
tightenInner = tighten . dropInner
|
||||
|
||||
export
|
||||
tightenN : (m : Nat) -> t (m + n) -> f (t n)
|
||||
tightenN m = tighten $ dropInnerN m
|
||||
|
||||
export
|
||||
tighten1 : t (S n) -> f (t n)
|
||||
tighten1 = tightenN 1
|
||||
|
||||
|
||||
|
||||
-- [todo] can this be done with fancy nats too?
|
||||
-- with bitmasks sure but that might not be worth the effort
|
||||
-- [the next day] it probably isn't
|
||||
|
||||
-- public export
|
||||
-- data OPE' : Nat -> Nat -> Type where
|
||||
-- None : OPE' 0 0
|
||||
-- Drop : OPE' m n -> OPE' m (S n)
|
||||
-- Keep : OPE' m n -> OPE' (S m) (S n)
|
||||
-- %name OPE' q
|
||||
|
||||
|
||||
-- public export %inline
|
||||
-- drop' : Integer -> Integer
|
||||
-- drop' n = n * 2
|
||||
|
||||
-- public export %inline
|
||||
-- keep' : Integer -> Integer
|
||||
-- keep' n = 1 + 2 * n
|
||||
|
||||
-- public export
|
||||
-- data IsOPE : Integer -> (OPE' m n) -> Type where
|
||||
-- IsNone : 0 `IsOPE` None
|
||||
-- IsDrop : (0 _ : m `IsOPE` q) -> drop' m `IsOPE` Drop q
|
||||
-- IsKeep : (0 _ : m `IsOPE` q) -> keep' m `IsOPE` Keep q
|
||||
-- %name IsOPE p
|
||||
|
||||
|
||||
-- public export
|
||||
-- record OPE m n where
|
||||
-- constructor MkOPE
|
||||
-- value : Integer
|
||||
-- 0 spec : OPE' m n
|
||||
-- 0 prf : value `IsOPE` spec
|
||||
-- 0 pos : So (value >= 0)
|
||||
|
||||
|
||||
-- private
|
||||
-- 0 idrisPleaseLearnAboutIntegers : {x, y : Integer} -> x = y
|
||||
-- idrisPleaseLearnAboutIntegers {x, y} = believe_me $ Refl {x}
|
||||
|
||||
-- private
|
||||
-- 0 natIntPlus : (m, n : Nat) ->
|
||||
-- natToInteger (m + n) = natToInteger m + natToInteger n
|
||||
-- natIntPlus m n = idrisPleaseLearnAboutIntegers
|
||||
|
||||
-- private
|
||||
-- 0 shiftTwice : (x : Integer) -> (m, n : Nat) ->
|
||||
-- x `shiftL` (m + n) = (x `shiftL` m) `shiftL` n
|
||||
-- shiftTwice x m n = idrisPleaseLearnAboutIntegers
|
||||
|
||||
-- private
|
||||
-- 0 shift1 : (x : Integer) -> (x `shiftL` 1) = 2 * x
|
||||
-- shift1 x = idrisPleaseLearnAboutIntegers
|
||||
|
||||
-- private
|
||||
-- 0 intPlusComm : (x, y : Integer) -> (x + y) = (y + x)
|
||||
-- intPlusComm x y = idrisPleaseLearnAboutIntegers
|
||||
|
||||
-- private
|
||||
-- 0 intTimes2Minus1 : (x : Integer) -> 2 * x - 1 = 2 * (x - 1) + 1
|
||||
-- intTimes2Minus1 x = idrisPleaseLearnAboutIntegers
|
||||
|
||||
-- private
|
||||
-- 0 intPosShift : So (x > 0) -> So (x `shiftL` i > 0)
|
||||
-- intPosShift p = believe_me Oh
|
||||
|
||||
-- private
|
||||
-- 0 intNonnegDec : {x : Integer} -> So (x > 0) -> So (x - 1 >= 0)
|
||||
-- intNonnegDec p = believe_me Oh
|
||||
|
||||
|
||||
-- private
|
||||
-- 0 shiftSucc : (x : Integer) -> (n : Nat) ->
|
||||
-- x `shiftL` S n = 2 * (x `shiftL` n)
|
||||
-- shiftSucc x n = Calc $
|
||||
-- |~ x `shiftL` S n
|
||||
-- ~~ x `shiftL` (n + 1)
|
||||
-- ...(cong (x `shiftL`) $ sym $ plusCommutative {})
|
||||
-- ~~ (x `shiftL` n) `shiftL` 1
|
||||
-- ...(shiftTwice {})
|
||||
-- ~~ 2 * (x `shiftL` n)
|
||||
-- ...(shift1 {})
|
||||
|
||||
|
||||
-- private
|
||||
-- opeIdVal : (n : Nat) -> Integer
|
||||
-- opeIdVal n = (1 `shiftL` n) - 1
|
||||
|
||||
-- private
|
||||
-- 0 opeIdValSpec : (n : Nat) -> Integer
|
||||
-- opeIdValSpec 0 = 0
|
||||
-- opeIdValSpec (S n) = keep' $ opeIdValSpec n
|
||||
|
||||
-- private
|
||||
-- 0 opeIdValOk : (n : Nat) -> opeIdVal n = opeIdValSpec n
|
||||
-- opeIdValOk 0 = Refl
|
||||
-- opeIdValOk (S n) = Calc $
|
||||
-- |~ (1 `shiftL` S n) - 1
|
||||
-- ~~ 2 * (1 `shiftL` n) - 1 ...(cong (\x => x - 1) $ shiftSucc {})
|
||||
-- ~~ 2 * (1 `shiftL` n - 1) + 1 ...(intTimes2Minus1 {})
|
||||
-- ~~ 1 + 2 * (1 `shiftL` n - 1) ...(intPlusComm {})
|
||||
-- ~~ 1 + 2 * opeIdValSpec n ...(cong (\x => 1 + 2 * x) $ opeIdValOk {})
|
||||
|
||||
-- private
|
||||
-- 0 opeIdSpec : (n : Nat) -> OPE' n n
|
||||
-- opeIdSpec 0 = None
|
||||
-- opeIdSpec (S n) = Keep $ opeIdSpec n
|
||||
|
||||
-- private
|
||||
-- 0 opeIdProof' : (n : Nat) -> opeIdValSpec n `IsOPE` opeIdSpec n
|
||||
-- opeIdProof' 0 = IsNone
|
||||
-- opeIdProof' (S n) = IsKeep (opeIdProof' n)
|
||||
|
||||
-- private
|
||||
-- 0 opeIdProof : (n : Nat) -> opeIdVal n `IsOPE` opeIdSpec n
|
||||
-- opeIdProof n = rewrite opeIdValOk n in opeIdProof' n
|
||||
|
||||
-- export
|
||||
-- opeId : {n : Nat} -> OPE n n
|
||||
-- opeId {n} = MkOPE {prf = opeIdProof n, pos = intNonnegDec $ intPosShift Oh, _}
|
||||
115
lib/Quox/Parser.idr
Normal file
115
lib/Quox/Parser.idr
Normal file
|
|
@ -0,0 +1,115 @@
|
|||
module Quox.Parser
|
||||
|
||||
import Quox.Syntax
|
||||
import Quox.Token
|
||||
import Quox.Lexer
|
||||
|
||||
import Data.SnocVect
|
||||
import Data.SnocList
|
||||
import Text.Parser
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
Vars : Nat -> Type
|
||||
Vars n = SnocVect n String
|
||||
|
||||
public export
|
||||
Grammar : Bool -> Type -> Type
|
||||
Grammar = Core.Grammar () Token
|
||||
%hide Core.Grammar
|
||||
|
||||
public export
|
||||
data Error
|
||||
= Lex (Lexer.Error)
|
||||
| Parse (List1 (ParsingError Token))
|
||||
| Leftover (List BToken)
|
||||
%hide Lexer.Error
|
||||
|
||||
|
||||
public export
|
||||
parseAll : {c : Bool} -> Grammar c a -> List BToken -> Either Error a
|
||||
parseAll grm input =
|
||||
case parse grm input of
|
||||
Right (x, []) => Right x
|
||||
Right (x, rest) => Left $ Leftover rest
|
||||
Left errs => Left $ Parse errs
|
||||
|
||||
public export
|
||||
lexParseAll : {c : Bool} -> Grammar c a -> String -> Either Error a
|
||||
lexParseAll grm = lex' >=> parseAll grm
|
||||
where lex' : String -> Either Error (List BToken)
|
||||
lex' = bimap Lex id . lex
|
||||
|
||||
|
||||
|
||||
punc : Punc -> Grammar True ()
|
||||
punc p = terminal (show p) $ \case
|
||||
P p' => if p == p' then Just () else Nothing
|
||||
_ => Nothing
|
||||
|
||||
between : Punc -> Punc -> Grammar True a -> Grammar True a
|
||||
between opener closer inner = punc opener *> inner <* punc closer
|
||||
|
||||
parens, squares, braces : Grammar True a -> Grammar True a
|
||||
parens = between LParen RParen
|
||||
squares = between LSquare RSquare
|
||||
braces = between LBrace RBrace
|
||||
|
||||
|
||||
export
|
||||
number : Grammar True Nat
|
||||
number = terminal "number" $ \case
|
||||
N Zero => Just 0
|
||||
N One => Just 1
|
||||
N (Other k) => Just k
|
||||
_ => Nothing
|
||||
|
||||
zero, one, omega : Grammar True ()
|
||||
zero = terminal "0" $ \case N Zero => Just (); _ => Nothing
|
||||
one = terminal "1" $ \case N One => Just (); _ => Nothing
|
||||
omega = terminal "ω" $ \case K Omega => Just (); _ => Nothing
|
||||
|
||||
export
|
||||
quantity : Grammar True Qty
|
||||
quantity = Zero <$ zero <|> One <$ one <|> Any <$ omega
|
||||
|
||||
|
||||
find1 : Eq a => SnocVect k a -> a -> Maybe (Var k)
|
||||
find1 [<] y = Nothing
|
||||
find1 (sx :< x) y = if x == y then Just VZ else VS <$> find1 sx y
|
||||
|
||||
find : Vars k -> Name -> Maybe (Var k)
|
||||
find vs (MakeName [<] (UN y)) = find1 vs y
|
||||
find _ _ = Nothing
|
||||
|
||||
|
||||
export
|
||||
bound : Vars k -> Grammar True (Var k)
|
||||
bound vs =
|
||||
terminal "bound variable" $ \case Name x => find1 vs x; _ => Nothing
|
||||
|
||||
export
|
||||
sname : Grammar True String
|
||||
sname = terminal "simple name" $ \case Name x => pure x; _ => Nothing
|
||||
|
||||
export
|
||||
qname : Grammar True Name
|
||||
qname = do
|
||||
parts <- sepBy1 (punc Dot) sname
|
||||
pure $ MakeName {mods = cast $ init parts, base = UN $ last parts}
|
||||
|
||||
export
|
||||
nameWith : Vars k -> Grammar True (Either (Var k) Name)
|
||||
nameWith vs = do
|
||||
y <- qname
|
||||
pure $ maybe (Right y) Left $ find vs y
|
||||
|
||||
|
||||
export
|
||||
dimension : Vars d -> Grammar True (Dim d)
|
||||
dimension vs =
|
||||
K Zero <$ zero
|
||||
<|> K One <$ one
|
||||
<|> B <$> bound vs
|
||||
230
lib/Quox/Pretty.idr
Normal file
230
lib/Quox/Pretty.idr
Normal file
|
|
@ -0,0 +1,230 @@
|
|||
module Quox.Pretty
|
||||
|
||||
import Quox.Name
|
||||
|
||||
import public Text.PrettyPrint.Prettyprinter.Doc
|
||||
import Text.PrettyPrint.Prettyprinter.Render.String
|
||||
import Text.PrettyPrint.Prettyprinter.Render.Terminal
|
||||
import public Data.String
|
||||
import Data.DPair
|
||||
|
||||
import public Control.Monad.Identity
|
||||
import public Control.Monad.Reader
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
record PrettyOpts where
|
||||
constructor MakePrettyOpts
|
||||
unicode, color : Bool
|
||||
|
||||
public export
|
||||
defPrettyOpts : PrettyOpts
|
||||
defPrettyOpts = MakePrettyOpts {unicode = True, color = True}
|
||||
|
||||
|
||||
public export
|
||||
data HL
|
||||
= Delim
|
||||
| TVar
|
||||
| TVarErr
|
||||
| Dim
|
||||
| DVar
|
||||
| DVarErr
|
||||
| Qty
|
||||
| Free
|
||||
| Syntax
|
||||
|
||||
private HLRepr : Type
|
||||
HLRepr = Nat
|
||||
|
||||
private %inline hlRepr : HL -> Nat
|
||||
hlRepr Delim = 0
|
||||
hlRepr TVar = 1
|
||||
hlRepr TVarErr = 2
|
||||
hlRepr Dim = 3
|
||||
hlRepr DVar = 4
|
||||
hlRepr DVarErr = 5
|
||||
hlRepr Qty = 6
|
||||
hlRepr Free = 7
|
||||
hlRepr Syntax = 8
|
||||
|
||||
export %inline Eq HL where (==) = (==) `on` hlRepr
|
||||
export %inline Ord HL where compare = compare `on` hlRepr
|
||||
|
||||
|
||||
public export
|
||||
data PPrec
|
||||
= Outer
|
||||
| Ann -- right of "::"
|
||||
| AnnL -- left of "::"
|
||||
-- ...
|
||||
| App -- term/dimension application
|
||||
| SApp -- substitution application
|
||||
| Arg -- argument to nonfix function
|
||||
|
||||
private PrecRepr : Type
|
||||
PrecRepr = Nat
|
||||
|
||||
private %inline precRepr : PPrec -> PrecRepr
|
||||
precRepr Outer = 0
|
||||
precRepr Ann = 1
|
||||
precRepr AnnL = 2
|
||||
-- ...
|
||||
precRepr App = 98
|
||||
precRepr SApp = 99
|
||||
precRepr Arg = 100
|
||||
|
||||
export %inline Eq PPrec where (==) = (==) `on` precRepr
|
||||
export %inline Ord PPrec where compare = compare `on` precRepr
|
||||
|
||||
|
||||
export %inline
|
||||
hl : HL -> Doc HL -> Doc HL
|
||||
hl = annotate
|
||||
|
||||
export %inline
|
||||
hl' : HL -> Doc HL -> Doc HL
|
||||
hl' h = hl h . unAnnotate
|
||||
|
||||
export %inline
|
||||
hlF : Functor f => HL -> f (Doc HL) -> f (Doc HL)
|
||||
hlF = map . hl
|
||||
|
||||
export %inline
|
||||
hlF' : Functor f => HL -> f (Doc HL) -> f (Doc HL)
|
||||
hlF' = map . hl'
|
||||
|
||||
|
||||
export %inline
|
||||
parens : Doc HL -> Doc HL
|
||||
parens doc = hl Delim "(" <+> doc <+> hl Delim ")"
|
||||
|
||||
export %inline
|
||||
parensIf : Bool -> Doc HL -> Doc HL
|
||||
parensIf True = parens
|
||||
parensIf False = id
|
||||
|
||||
|
||||
export
|
||||
separate' : Doc a -> List (Doc a) -> List (Doc a)
|
||||
separate' s [] = []
|
||||
separate' s [x] = [x]
|
||||
separate' s (x :: xs) = x <+> s :: separate' s xs
|
||||
|
||||
export %inline
|
||||
separate : Doc a -> List (Doc a) -> Doc a
|
||||
separate s = sep . separate' s
|
||||
|
||||
export %inline
|
||||
hseparate : Doc a -> List (Doc a) -> Doc a
|
||||
hseparate s = hsep . separate' s
|
||||
|
||||
export %inline
|
||||
vseparate : Doc a -> List (Doc a) -> Doc a
|
||||
vseparate s = vsep . separate' s
|
||||
|
||||
|
||||
public export
|
||||
record PrettyEnv where
|
||||
constructor MakePrettyEnv
|
||||
||| names of bound dimension variables
|
||||
dnames : List Name
|
||||
||| names of bound term variables
|
||||
tnames : List Name
|
||||
||| use non-ascii characters for syntax
|
||||
unicode : Bool
|
||||
||| surrounding precedence level
|
||||
prec : PPrec
|
||||
|
||||
public export HasEnv : (Type -> Type) -> Type
|
||||
HasEnv = MonadReader PrettyEnv
|
||||
|
||||
export %inline
|
||||
ifUnicode : HasEnv m => (uni, asc : Lazy a) -> m a
|
||||
ifUnicode uni asc = if (!ask).unicode then [|uni|] else [|asc|]
|
||||
|
||||
export %inline
|
||||
parensIfM : HasEnv m => PPrec -> Doc HL -> m (Doc HL)
|
||||
parensIfM d doc = pure $ parensIf ((!ask).prec > d) doc
|
||||
|
||||
export %inline
|
||||
withPrec : HasEnv m => PPrec -> m a -> m a
|
||||
withPrec d = local {prec := d}
|
||||
|
||||
public export data BinderSort = T | D
|
||||
|
||||
export %inline
|
||||
under : HasEnv m => BinderSort -> Name -> m a -> m a
|
||||
under T x = local {prec := Outer, tnames $= (x ::)}
|
||||
under D x = local {prec := Outer, dnames $= (x ::)}
|
||||
|
||||
|
||||
public export
|
||||
interface PrettyHL a where
|
||||
prettyM : HasEnv m => a -> m (Doc HL)
|
||||
|
||||
export %inline
|
||||
pretty0M : (PrettyHL a, HasEnv m) => a -> m (Doc HL)
|
||||
pretty0M = local {prec := Outer} . prettyM
|
||||
|
||||
export %inline
|
||||
pretty0 : PrettyHL a => (unicode : Bool) -> a -> Doc HL
|
||||
pretty0 unicode x =
|
||||
let env = MakePrettyEnv {dnames = [], tnames = [], unicode, prec = Outer} in
|
||||
runReader env $ prettyM x
|
||||
|
||||
|
||||
export
|
||||
(forall a. PrettyHL (f a)) => PrettyHL (Exists f) where
|
||||
prettyM x = prettyM x.snd
|
||||
|
||||
export
|
||||
PrettyHL a => PrettyHL (Subset a b) where
|
||||
prettyM x = prettyM x.fst
|
||||
|
||||
|
||||
export PrettyHL BaseName where prettyM = pure . pretty . baseStr
|
||||
export PrettyHL Name where prettyM = pure . pretty . toDots
|
||||
|
||||
|
||||
export %inline
|
||||
prettyStr : PrettyHL a => (unicode : Bool) -> a -> String
|
||||
prettyStr unicode =
|
||||
let layout = layoutSmart (MkLayoutOptions (AvailablePerLine 80 0.8)) in
|
||||
renderString . layout . pretty0 unicode
|
||||
|
||||
|
||||
export
|
||||
termHL : HL -> AnsiStyle
|
||||
termHL Delim = color BrightBlack
|
||||
termHL TVar = color BrightYellow
|
||||
termHL TVarErr = color BrightYellow <+> underline
|
||||
termHL Dim = color BrightGreen <+> bold
|
||||
termHL DVar = color BrightGreen
|
||||
termHL DVarErr = color BrightGreen <+> underline
|
||||
termHL Qty = color BrightMagenta <+> bold
|
||||
termHL Free = color BrightWhite
|
||||
termHL Syntax = color BrightCyan
|
||||
|
||||
export %inline
|
||||
prettyTerm : PrettyOpts -> PrettyHL a => a -> IO Unit
|
||||
prettyTerm opts x =
|
||||
let reann = if opts.color then map termHL else unAnnotate in
|
||||
Terminal.putDoc $ reann $ pretty0 opts.unicode x
|
||||
|
||||
export %inline
|
||||
prettyTermDef : PrettyHL a => a -> IO Unit
|
||||
prettyTermDef = prettyTerm defPrettyOpts
|
||||
|
||||
|
||||
infixr 6 <//>
|
||||
export %inline
|
||||
(<//>) : Doc a -> Doc a -> Doc a
|
||||
a <//> b = sep [a, b]
|
||||
|
||||
infixr 6 </>
|
||||
export %inline
|
||||
(</>) : Doc a -> Doc a -> Doc a
|
||||
a </> b = cat [a, b]
|
||||
130
lib/Quox/Reduce.idr
Normal file
130
lib/Quox/Reduce.idr
Normal file
|
|
@ -0,0 +1,130 @@
|
|||
module Quox.Reduce
|
||||
|
||||
import public Quox.Syntax
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
data IsRedexT : Term d n -> Type where
|
||||
IsUpsilonT : IsRedexT $ E (_ :# _)
|
||||
IsCloT : IsRedexT $ CloT {}
|
||||
IsDCloT : IsRedexT $ DCloT {}
|
||||
|
||||
public export %inline
|
||||
NotRedexT : Term d n -> Type
|
||||
NotRedexT = Not . IsRedexT
|
||||
|
||||
public export
|
||||
data IsRedexE : Elim d n -> Type where
|
||||
IsUpsilonE : IsRedexE $ E _ :# _
|
||||
IsBetaLam : IsRedexE $ (Lam {} :# Pi {}) :@ _
|
||||
IsCloE : IsRedexE $ CloE {}
|
||||
IsDCloE : IsRedexE $ DCloE {}
|
||||
|
||||
public export %inline
|
||||
NotRedexE : Elim d n -> Type
|
||||
NotRedexE = Not . IsRedexE
|
||||
|
||||
|
||||
export %inline
|
||||
isRedexT : (t : Term d n) -> Dec (IsRedexT t)
|
||||
isRedexT (E (_ :# _)) = Yes IsUpsilonT
|
||||
isRedexT (CloT {}) = Yes IsCloT
|
||||
isRedexT (DCloT {}) = Yes IsDCloT
|
||||
isRedexT (TYPE _) = No $ \x => case x of {}
|
||||
isRedexT (Pi {}) = No $ \x => case x of {}
|
||||
isRedexT (Lam {}) = No $ \x => case x of {}
|
||||
isRedexT (E (F _)) = No $ \x => case x of {}
|
||||
isRedexT (E (B _)) = No $ \x => case x of {}
|
||||
isRedexT (E (_ :@ _)) = No $ \x => case x of {}
|
||||
isRedexT (E (CloE {})) = No $ \x => case x of {}
|
||||
isRedexT (E (DCloE {})) = No $ \x => case x of {}
|
||||
|
||||
export %inline
|
||||
isRedexE : (e : Elim d n) -> Dec (IsRedexE e)
|
||||
isRedexE (E _ :# _) = Yes IsUpsilonE
|
||||
isRedexE ((Lam {} :# Pi {}) :@ _) = Yes IsBetaLam
|
||||
isRedexE (CloE {}) = Yes IsCloE
|
||||
isRedexE (DCloE {}) = Yes IsDCloE
|
||||
isRedexE (F x) = No $ \x => case x of {}
|
||||
isRedexE (B i) = No $ \x => case x of {}
|
||||
isRedexE (F _ :@ _) = No $ \x => case x of {}
|
||||
isRedexE (B _ :@ _) = No $ \x => case x of {}
|
||||
isRedexE (_ :@ _ :@ _) = No $ \x => case x of {}
|
||||
isRedexE ((TYPE _ :# _) :@ _) = No $ \x => case x of {}
|
||||
isRedexE ((Pi {} :# _) :@ _) = No $ \x => case x of {}
|
||||
isRedexE ((Lam {} :# TYPE _) :@ _) = No $ \x => case x of {}
|
||||
isRedexE ((Lam {} :# Lam {}) :@ _) = No $ \x => case x of {}
|
||||
isRedexE ((Lam {} :# E _) :@ _) = No $ \x => case x of {}
|
||||
isRedexE ((Lam {} :# CloT {}) :@ _) = No $ \x => case x of {}
|
||||
isRedexE ((Lam {} :# DCloT {}) :@ _) = No $ \x => case x of {}
|
||||
isRedexE ((E _ :# _) :@ _) = No $ \x => case x of {}
|
||||
isRedexE ((CloT {} :# _) :@ _) = No $ \x => case x of {}
|
||||
isRedexE ((DCloT {} :# _) :@ _) = No $ \x => case x of {}
|
||||
isRedexE (CloE {} :@ _) = No $ \x => case x of {}
|
||||
isRedexE (DCloE {} :@ _) = No $ \x => case x of {}
|
||||
isRedexE (TYPE _ :# _) = No $ \x => case x of {}
|
||||
isRedexE (Pi {} :# _) = No $ \x => case x of {}
|
||||
isRedexE (Lam {} :# _) = No $ \x => case x of {}
|
||||
isRedexE (CloT {} :# _) = No $ \x => case x of {}
|
||||
isRedexE (DCloT {} :# _) = No $ \x => case x of {}
|
||||
|
||||
|
||||
public export %inline
|
||||
RedexTerm : Nat -> Nat -> Type
|
||||
RedexTerm d n = Subset (Term d n) IsRedexT
|
||||
|
||||
public export %inline
|
||||
NonRedexTerm : Nat -> Nat -> Type
|
||||
NonRedexTerm d n = Subset (Term d n) NotRedexT
|
||||
|
||||
|
||||
public export %inline
|
||||
RedexElim : Nat -> Nat -> Type
|
||||
RedexElim d n = Subset (Elim d n) IsRedexE
|
||||
|
||||
public export %inline
|
||||
NonRedexElim : Nat -> Nat -> Type
|
||||
NonRedexElim d n = Subset (Elim d n) NotRedexE
|
||||
|
||||
|
||||
||| substitute a term with annotation for the bound variable of a `ScopeTerm`
|
||||
export %inline
|
||||
substScope : (arg, argTy : Term d n) -> (body : ScopeTerm d n) -> Term d n
|
||||
substScope arg argTy (TUsed body) = body // one (arg :# argTy)
|
||||
substScope arg argTy (TUnused body) = body
|
||||
|
||||
export %inline
|
||||
stepT' : (s : Term d n) -> IsRedexT s -> Term d n
|
||||
stepT' (E (s :# _)) IsUpsilonT = s
|
||||
stepT' (CloT s th) IsCloT = pushSubstsTWith' id th s
|
||||
stepT' (DCloT s th) IsDCloT = pushSubstsTWith' th id s
|
||||
|
||||
export %inline
|
||||
stepT : (s : Term d n) -> Either (NotRedexT s) (Term d n)
|
||||
stepT s = case isRedexT s of Yes y => Right $ stepT' s y; No n => Left n
|
||||
|
||||
export %inline
|
||||
stepE' : (e : Elim d n) -> IsRedexE e -> Elim d n
|
||||
stepE' (E e :# _) IsUpsilonE = e
|
||||
stepE' ((Lam {body, _} :# Pi {arg, res, _}) :@ s) IsBetaLam =
|
||||
substScope s arg body :# substScope s arg res
|
||||
stepE' (CloE e th) IsCloE = pushSubstsEWith' id th e
|
||||
stepE' (DCloE e th) IsDCloE = pushSubstsEWith' th id e
|
||||
|
||||
export %inline
|
||||
stepE : (e : Elim d n) -> Either (NotRedexE e) (Elim d n)
|
||||
stepE e = case isRedexE e of Yes y => Right $ stepE' e y; No n => Left n
|
||||
|
||||
export covering
|
||||
whnfT : Term d n -> NonRedexTerm d n
|
||||
whnfT s = case stepT s of
|
||||
Right s' => whnfT s'
|
||||
Left done => Element s done
|
||||
|
||||
export covering
|
||||
whnfE : Elim d n -> NonRedexElim d n
|
||||
whnfE e = case stepE e of
|
||||
Right e' => whnfE e'
|
||||
Left done => Element e done
|
||||
10
lib/Quox/Syntax.idr
Normal file
10
lib/Quox/Syntax.idr
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
module Quox.Syntax
|
||||
|
||||
import public Quox.Syntax.Dim
|
||||
import public Quox.Syntax.DimEq
|
||||
import public Quox.Syntax.Qty
|
||||
import public Quox.Syntax.Shift
|
||||
import public Quox.Syntax.Subst
|
||||
import public Quox.Syntax.Term
|
||||
import public Quox.Syntax.Universe
|
||||
import public Quox.Syntax.Var
|
||||
106
lib/Quox/Syntax/Dim.idr
Normal file
106
lib/Quox/Syntax/Dim.idr
Normal file
|
|
@ -0,0 +1,106 @@
|
|||
module Quox.Syntax.Dim
|
||||
|
||||
import Quox.Syntax.Var
|
||||
import Quox.Syntax.Subst
|
||||
import Quox.Pretty
|
||||
|
||||
import Decidable.Equality
|
||||
import Control.Function
|
||||
import Generics.Derive
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
%hide SOP.from; %hide SOP.to
|
||||
|
||||
|
||||
public export
|
||||
data DimConst = Zero | One
|
||||
%name DimConst e
|
||||
|
||||
private DCRepr : Type
|
||||
DCRepr = Nat
|
||||
|
||||
%runElab derive "DimConst" [Generic, Meta, Eq, Ord, DecEq, Show]
|
||||
|
||||
|
||||
public export
|
||||
data Dim : Nat -> Type where
|
||||
K : DimConst -> Dim d
|
||||
B : Var d -> Dim d
|
||||
%name Dim.Dim p, q
|
||||
|
||||
private %inline
|
||||
drepr : Dim n -> Either DimConst (Var n)
|
||||
drepr (K k) = Left k
|
||||
drepr (B x) = Right x
|
||||
|
||||
export Eq (Dim n) where (==) = (==) `on` drepr
|
||||
export Ord (Dim n) where compare = compare `on` drepr
|
||||
|
||||
export
|
||||
PrettyHL DimConst where
|
||||
prettyM Zero = hl Dim <$> ifUnicode "𝟬" "0"
|
||||
prettyM One = hl Dim <$> ifUnicode "𝟭" "1"
|
||||
|
||||
export
|
||||
PrettyHL (Dim n) where
|
||||
prettyM (K e) = prettyM e
|
||||
prettyM (B i) = prettyVar DVar DVarErr (!ask).dnames i
|
||||
|
||||
|
||||
public export %inline
|
||||
toConst : Dim 0 -> DimConst
|
||||
toConst (K e) = e
|
||||
|
||||
|
||||
public export
|
||||
DSubst : Nat -> Nat -> Type
|
||||
DSubst = Subst Dim
|
||||
|
||||
|
||||
export %inline
|
||||
prettyDSubst : Pretty.HasEnv m => DSubst from to -> m (Doc HL)
|
||||
prettyDSubst th =
|
||||
prettySubstM prettyM (!ask).dnames DVar
|
||||
!(ifUnicode "⟨" "<") !(ifUnicode "⟩" ">") th
|
||||
|
||||
|
||||
export FromVar Dim where fromVar = B
|
||||
|
||||
export
|
||||
CanShift Dim where
|
||||
K e // _ = K e
|
||||
B i // by = B (i // by)
|
||||
|
||||
export
|
||||
CanSubst Dim Dim where
|
||||
K e // _ = K e
|
||||
B i // th = th !! i
|
||||
|
||||
|
||||
export Uninhabited (Zero = One) where uninhabited _ impossible
|
||||
export Uninhabited (One = Zero) where uninhabited _ impossible
|
||||
|
||||
export Uninhabited (B i = K e) where uninhabited _ impossible
|
||||
export Uninhabited (K e = B i) where uninhabited _ impossible
|
||||
|
||||
public export %inline Injective Dim.B where injective Refl = Refl
|
||||
public export %inline Injective Dim.K where injective Refl = Refl
|
||||
|
||||
public export
|
||||
DecEq DimConst where
|
||||
decEq Zero Zero = Yes Refl
|
||||
decEq Zero One = No absurd
|
||||
decEq One Zero = No absurd
|
||||
decEq One One = Yes Refl
|
||||
|
||||
public export
|
||||
DecEq (Dim d) where
|
||||
decEq (K e) (K f) with (decEq e f)
|
||||
_ | Yes prf = Yes $ cong K prf
|
||||
_ | No contra = No $ contra . injective
|
||||
decEq (K e) (B j) = No absurd
|
||||
decEq (B i) (K f) = No absurd
|
||||
decEq (B i) (B j) with (decEq i j)
|
||||
_ | Yes prf = Yes $ cong B prf
|
||||
_ | No contra = No $ contra . injective
|
||||
175
lib/Quox/Syntax/DimEq.idr
Normal file
175
lib/Quox/Syntax/DimEq.idr
Normal file
|
|
@ -0,0 +1,175 @@
|
|||
module Quox.Syntax.DimEq
|
||||
|
||||
import public Quox.Syntax.Var
|
||||
import public Quox.Syntax.Dim
|
||||
import public Quox.Syntax.Subst
|
||||
import public Quox.Context
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Nat
|
||||
import Data.DPair
|
||||
import Data.Fun.Graph
|
||||
import Decidable.Decidable
|
||||
import Decidable.Equality
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
DimEq' : Nat -> Type
|
||||
DimEq' = Context (Maybe . Dim)
|
||||
|
||||
|
||||
public export
|
||||
data DimEq : Nat -> Type where
|
||||
ZeroIsOne : DimEq d
|
||||
C : (eqs : DimEq' d) -> DimEq d
|
||||
|
||||
%name DimEq eqs
|
||||
|
||||
|
||||
export
|
||||
zeroEq : DimEq 0
|
||||
zeroEq = C [<]
|
||||
|
||||
export
|
||||
new' : {d : Nat} -> DimEq' d
|
||||
new' {d = 0} = [<]
|
||||
new' {d = S d} = new' :< Nothing
|
||||
|
||||
export %inline
|
||||
new : {d : Nat} -> DimEq d
|
||||
new = C new'
|
||||
|
||||
|
||||
private %inline
|
||||
shiftMay : Maybe (Dim from) -> Shift from to -> Maybe (Dim to)
|
||||
shiftMay p by = map (// by) p
|
||||
|
||||
export %inline
|
||||
get' : DimEq' d -> Var d -> Maybe (Dim d)
|
||||
get' = getWith shiftMay
|
||||
|
||||
private %inline
|
||||
getShift' : Shift len out -> DimEq' len -> Var len -> Maybe (Dim out)
|
||||
getShift' = getShiftWith shiftMay
|
||||
|
||||
export %inline
|
||||
get : DimEq' d -> Dim d -> Dim d
|
||||
get _ (K e) = K e
|
||||
get eqs (B i) = fromMaybe (B i) $ get' eqs i
|
||||
|
||||
|
||||
export %inline
|
||||
equal : DimEq d -> (p, q : Dim d) -> Bool
|
||||
equal ZeroIsOne p q = True
|
||||
equal (C eqs) p q = get eqs p == get eqs q
|
||||
|
||||
|
||||
infixl 5 :<?
|
||||
export %inline
|
||||
(:<?) : DimEq d -> Maybe (Dim d) -> DimEq (S d)
|
||||
ZeroIsOne :<? d = ZeroIsOne
|
||||
C eqs :<? d = C $ eqs :< d
|
||||
|
||||
|
||||
private %inline
|
||||
ifVar : Var d -> Dim d -> Maybe (Dim d) -> Maybe (Dim d)
|
||||
ifVar i p = map $ \q => if isYes $ q `decEq` B i then p else q
|
||||
|
||||
private %inline
|
||||
checkConst : (e, f : DimConst) -> (eqs : Lazy (DimEq' d)) -> DimEq d
|
||||
checkConst Zero Zero eqs = C eqs
|
||||
checkConst One One eqs = C eqs
|
||||
checkConst _ _ _ = ZeroIsOne
|
||||
|
||||
export
|
||||
setConst : Var d -> DimConst -> DimEq' d -> DimEq d
|
||||
setConst VZ e (eqs :< Nothing) = C $ eqs :< Just (K e)
|
||||
setConst VZ e (eqs :< Just (K f)) = checkConst e f $ eqs :< Just (K f)
|
||||
setConst VZ e (eqs :< Just (B i)) = setConst i e eqs :<? Just (K e)
|
||||
setConst (VS i) e (eqs :< p) = setConst i e eqs :<? ifVar i (K e) p
|
||||
|
||||
mutual
|
||||
private
|
||||
setVar' : (i, j : Var d) -> i `LT` j -> DimEq' d -> DimEq d
|
||||
setVar' VZ (VS i) LTZ (eqs :< Nothing) =
|
||||
C $ eqs :< Just (B i)
|
||||
setVar' VZ (VS i) LTZ (eqs :< Just (K e)) =
|
||||
setConst i e eqs :<? Just (K e)
|
||||
setVar' VZ (VS i) LTZ (eqs :< Just (B j)) =
|
||||
setVar i j eqs :<? Just (B (max i j))
|
||||
setVar' (VS i) (VS j) (LTS lt) (eqs :< p) =
|
||||
setVar' i j lt eqs :<? ifVar i (B j) p
|
||||
|
||||
export %inline
|
||||
setVar : (i, j : Var d) -> DimEq' d -> DimEq d
|
||||
setVar i j eqs with (compareP i j)
|
||||
_ | IsLT lt = setVar' i j lt eqs
|
||||
setVar i i eqs | IsEQ = C eqs
|
||||
_ | IsGT gt = setVar' j i gt eqs
|
||||
|
||||
|
||||
export %inline
|
||||
set : (p, q : Dim d) -> DimEq d -> DimEq d
|
||||
set _ _ ZeroIsOne = ZeroIsOne
|
||||
set (K e) (K f) (C eqs) = checkConst e f eqs
|
||||
set (K e) (B i) (C eqs) = setConst i e eqs
|
||||
set (B i) (K e) (C eqs) = setConst i e eqs
|
||||
set (B i) (B j) (C eqs) = setVar i j eqs
|
||||
|
||||
|
||||
public export %inline
|
||||
Split : Nat -> Type
|
||||
Split d = (DimEq' d, DSubst (S d) d)
|
||||
|
||||
export %inline
|
||||
split1 : DimConst -> DimEq' (S d) -> Maybe (Split d)
|
||||
split1 e eqs = case setConst VZ e eqs of
|
||||
ZeroIsOne => Nothing
|
||||
C (eqs :< _) => Just (eqs, K e ::: id)
|
||||
|
||||
export %inline
|
||||
split : DimEq' (S d) -> List (Split d)
|
||||
split eqs = toList (split1 Zero eqs) <+> toList (split1 One eqs)
|
||||
|
||||
|
||||
export
|
||||
splits' : DimEq' d -> List (DSubst d 0)
|
||||
splits' [<] = [id]
|
||||
splits' eqs@(_ :< _) = [th . ph | (eqs', th) <- split eqs, ph <- splits' eqs']
|
||||
|
||||
export %inline
|
||||
splits : DimEq d -> List (DSubst d 0)
|
||||
splits ZeroIsOne = []
|
||||
splits (C eqs) = splits' eqs
|
||||
|
||||
|
||||
private
|
||||
0 newGetShift : (d : Nat) -> (i : Var d) -> (by : Shift d d') ->
|
||||
getShift' by (new' {d}) i = Nothing
|
||||
newGetShift (S d) VZ by = Refl
|
||||
newGetShift (S d) (VS i) by = newGetShift d i (drop1 by)
|
||||
|
||||
export
|
||||
0 newGet' : (d : Nat) -> (i : Var d) -> get' (new' {d}) i = Nothing
|
||||
newGet' d i = newGetShift d i SZ
|
||||
|
||||
export
|
||||
0 newGet : (d : Nat) -> (p : Dim d) -> get (new' {d}) p = p
|
||||
newGet d (K e) = Refl
|
||||
newGet d (B i) = rewrite newGet' d i in Refl
|
||||
|
||||
|
||||
export
|
||||
0 setSelf : (p : Dim d) -> (eqs : DimEq d) -> set p p eqs = eqs
|
||||
setSelf p ZeroIsOne = Refl
|
||||
setSelf (K Zero) (C eqs) = Refl
|
||||
setSelf (K One) (C eqs) = Refl
|
||||
setSelf (B i) (C eqs) = rewrite comparePSelf i in Refl
|
||||
|
||||
|
||||
-- [todo] "well formed" dimeqs
|
||||
-- [todo] operations maintain well-formedness
|
||||
-- [todo] if 'Wf eqs' then 'equal eqs' is an equivalence
|
||||
-- [todo] 'set' never breaks existing equalities
|
||||
80
lib/Quox/Syntax/Qty.idr
Normal file
80
lib/Quox/Syntax/Qty.idr
Normal file
|
|
@ -0,0 +1,80 @@
|
|||
module Quox.Syntax.Qty
|
||||
|
||||
import Quox.Pretty
|
||||
|
||||
import Data.Fin
|
||||
import Generics.Derive
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
||||
|
||||
public export
|
||||
data Qty = Zero | One | Any
|
||||
%name Qty.Qty pi, rh
|
||||
|
||||
%runElab derive "Qty" [Generic, Meta, Eq, Ord, DecEq, Show]
|
||||
|
||||
|
||||
export
|
||||
PrettyHL Qty where
|
||||
prettyM pi = hl Qty <$>
|
||||
case pi of
|
||||
Zero => ifUnicode "𝟬" "0"
|
||||
One => ifUnicode "𝟭" "1"
|
||||
Any => ifUnicode "𝛚" "*"
|
||||
|
||||
private
|
||||
commas : List (Doc HL) -> List (Doc HL)
|
||||
commas [] = []
|
||||
commas [x] = [x]
|
||||
commas (x::xs) = (x <+> hl Delim ",") :: commas xs
|
||||
|
||||
export %inline
|
||||
prettyQtyBinds : Pretty.HasEnv m => List Qty -> m (Doc HL)
|
||||
prettyQtyBinds =
|
||||
map ((hl Delim "@" <++>) . align . sep . commas) . traverse pretty0M
|
||||
|
||||
|
||||
public export
|
||||
plus : Qty -> Qty -> Qty
|
||||
plus Zero rh = rh
|
||||
plus pi Zero = pi
|
||||
plus _ _ = Any
|
||||
|
||||
public export
|
||||
times : Qty -> Qty -> Qty
|
||||
times Zero _ = Zero
|
||||
times _ Zero = Zero
|
||||
times One rh = rh
|
||||
times pi One = pi
|
||||
times Any Any = Any
|
||||
|
||||
infix 6 <=.
|
||||
public export
|
||||
compat : Qty -> Qty -> Bool
|
||||
compat pi rh = rh == Any || pi == rh
|
||||
|
||||
|
||||
public export
|
||||
interface IsQty q where
|
||||
zero, one : q
|
||||
(+), (*) : q -> q -> q
|
||||
(<=.) : q -> q -> Bool
|
||||
|
||||
public export
|
||||
IsQty Qty where
|
||||
zero = Zero; one = One
|
||||
(+) = plus; (*) = times
|
||||
(<=.) = compat
|
||||
|
||||
|
||||
public export
|
||||
data IsSubj : Qty -> Type where
|
||||
SZero : IsSubj Zero
|
||||
SOne : IsSubj One
|
||||
|
||||
public export
|
||||
data IsGlobal : Qty -> Type where
|
||||
GZero : IsGlobal Zero
|
||||
GAny : IsGlobal Any
|
||||
235
lib/Quox/Syntax/Shift.idr
Normal file
235
lib/Quox/Syntax/Shift.idr
Normal file
|
|
@ -0,0 +1,235 @@
|
|||
module Quox.Syntax.Shift
|
||||
|
||||
import public Quox.Syntax.Var
|
||||
import Quox.Pretty
|
||||
|
||||
import Data.Nat
|
||||
import Data.So
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
||| represents the difference between a smaller scope and a larger one.
|
||||
public export
|
||||
data Shift : (0 from, to : Nat) -> Type where
|
||||
SZ : Shift from from
|
||||
SS : Shift from to -> Shift from (S to)
|
||||
%name Shift by, bz
|
||||
%builtin Natural Shift
|
||||
|
||||
public export
|
||||
(.nat) : Shift from to -> Nat
|
||||
(SZ).nat = Z
|
||||
(SS by).nat = S by.nat
|
||||
%transform "Shift.(.nat)" Shift.(.nat) = believe_me
|
||||
|
||||
public export Cast (Shift from to) Nat where cast = (.nat)
|
||||
public export Cast (Shift from to) Integer where cast = cast . cast {to = Nat}
|
||||
|
||||
export Eq (Shift from to) where (==) = (==) `on` (.nat)
|
||||
export Ord (Shift from to) where compare = compare `on` (.nat)
|
||||
|
||||
|
||||
||| shift equivalence, ignoring indices
|
||||
public export
|
||||
data Eqv : Shift from1 to1 -> Shift from2 to2 -> Type where
|
||||
EqSZ : SZ `Eqv` SZ
|
||||
EqSS : by `Eqv` bz -> SS by `Eqv` SS bz
|
||||
%name Eqv e
|
||||
|
||||
||| two equivalent shifts are equal if they have the same indices.
|
||||
export
|
||||
0 fromEqv : by `Eqv` bz -> by = bz
|
||||
fromEqv EqSZ = Refl
|
||||
fromEqv (EqSS e) = cong SS $ fromEqv e
|
||||
|
||||
||| two equal shifts are equivalent.
|
||||
export
|
||||
0 toEqv : by = bz -> by `Eqv` bz
|
||||
toEqv Refl {by = SZ} = EqSZ
|
||||
toEqv Refl {by = (SS by)} = EqSS $ toEqv Refl
|
||||
|
||||
|
||||
export
|
||||
0 shiftDiff : (by : Shift from to) -> to = by.nat + from
|
||||
shiftDiff SZ = Refl
|
||||
shiftDiff (SS by) = cong S $ shiftDiff by
|
||||
|
||||
export
|
||||
0 shiftVarLT : (by : Shift from to) -> (i : Var from) ->
|
||||
by.nat + i.nat `LT` to
|
||||
shiftVarLT by i =
|
||||
rewrite plusSuccRightSucc by.nat i.nat in
|
||||
transitive
|
||||
(plusLteMonotoneLeft by.nat (S i.nat) from (toNatLT i))
|
||||
(replace {p=(`LTE` to)} (shiftDiff by) reflexive)
|
||||
|
||||
|
||||
public export
|
||||
fromNat : (by : Nat) -> Shift from (by + from)
|
||||
fromNat Z = SZ
|
||||
fromNat (S by) = SS $ fromNat by
|
||||
%transform "Shift.fromNat" Shift.fromNat x = believe_me x
|
||||
|
||||
public export
|
||||
fromNat0 : (by : Nat) -> Shift 0 by
|
||||
fromNat0 by = rewrite sym $ plusZeroRightNeutral by in fromNat by
|
||||
|
||||
export
|
||||
0 fromToNat : (by : Shift from to) -> by `Eqv` fromNat by.nat {from}
|
||||
fromToNat SZ = EqSZ
|
||||
fromToNat (SS by) = EqSS $ fromToNat by
|
||||
|
||||
export
|
||||
0 toFromNat : (from, by : Nat) -> by = (fromNat by {from}).nat
|
||||
toFromNat from 0 = Refl
|
||||
toFromNat from (S k) = cong S $ toFromNat from k
|
||||
|
||||
export
|
||||
0 toNatInj' : (by : Shift from1 to1) -> (bz : Shift from2 to2) ->
|
||||
by.nat = bz.nat -> by `Eqv` bz
|
||||
toNatInj' SZ SZ prf = EqSZ
|
||||
toNatInj' (SS by) (SS bz) prf = EqSS $ toNatInj' by bz $ injective prf
|
||||
toNatInj' (SS by) SZ Refl impossible
|
||||
|
||||
export
|
||||
0 toNatInj : {by, bz : Shift from to} -> by.nat = bz.nat -> by = bz
|
||||
toNatInj {by, bz} e = fromEqv $ toNatInj' by bz e
|
||||
|
||||
export %inline
|
||||
Injective Shift.(.nat) where injective eq = irrelevantEq $ toNatInj eq
|
||||
|
||||
|
||||
public export
|
||||
ssDown : Shift (S from) to -> Shift from to
|
||||
ssDown SZ = SS SZ
|
||||
ssDown (SS by) = SS (ssDown by)
|
||||
|
||||
export
|
||||
0 ssDownEqv : (by : Shift (S from) to) -> ssDown by `Eqv` SS by
|
||||
ssDownEqv SZ = EqSS EqSZ
|
||||
ssDownEqv (SS by) = EqSS $ ssDownEqv by
|
||||
|
||||
%transform "Shift.ssDown" ssDown by = believe_me (SS by)
|
||||
|
||||
|
||||
public export
|
||||
shift : Shift from to -> Var from -> Var to
|
||||
shift SZ i = i
|
||||
shift (SS by) i = VS $ shift by i
|
||||
|
||||
private
|
||||
shiftViaNat' : (by : Shift from to) -> (i : Var from) ->
|
||||
(0 p : by.nat + i.nat `LT` to) -> Var to
|
||||
shiftViaNat' by i p = V $ by.nat + i.nat
|
||||
|
||||
private
|
||||
shiftViaNat : Shift from to -> Var from -> Var to
|
||||
shiftViaNat by i = shiftViaNat' by i $ shiftVarLT by i
|
||||
|
||||
private
|
||||
0 shiftViaNatCorrect : (by : Shift from to) -> (i : Var from) ->
|
||||
(0 p : by.nat + i.nat `LT` to) ->
|
||||
shiftViaNat' by i p = shift by i
|
||||
shiftViaNatCorrect SZ i (LTESucc p) = fromToNat i _
|
||||
shiftViaNatCorrect (SS by) i (LTESucc p) = cong VS $ shiftViaNatCorrect by i p
|
||||
|
||||
%transform "Shift.shift" shift = shiftViaNat
|
||||
|
||||
|
||||
infixl 9 .
|
||||
public export
|
||||
(.) : Shift from mid -> Shift mid to -> Shift from to
|
||||
by . SZ = by
|
||||
by . SS bz = SS $ by . bz
|
||||
|
||||
private
|
||||
0 compNatProof : (by : Shift from mid) -> (bz : Shift mid to) ->
|
||||
to = by.nat + bz.nat + from
|
||||
compNatProof by bz =
|
||||
shiftDiff bz >>>
|
||||
cong (bz.nat +) (shiftDiff by) >>>
|
||||
plusAssociative bz.nat by.nat from >>>
|
||||
cong (+ from) (plusCommutative bz.nat by.nat)
|
||||
where
|
||||
infixr 0 >>>
|
||||
0 (>>>) : a = b -> b = c -> a = c
|
||||
x >>> y = trans x y
|
||||
|
||||
private
|
||||
compViaNat' : (by : Shift from mid) -> (bz : Shift mid to) ->
|
||||
Shift from (by.nat + bz.nat + from)
|
||||
compViaNat' by bz = fromNat $ by.nat + bz.nat
|
||||
|
||||
private
|
||||
compViaNat : (by : Shift from mid) -> (bz : Shift mid to) -> Shift from to
|
||||
compViaNat by bz = rewrite compNatProof by bz in compViaNat' by bz
|
||||
|
||||
private
|
||||
0 compViaNatCorrect : (by : Shift from mid) -> (bz : Shift mid to) ->
|
||||
by . bz `Eqv` compViaNat' by bz
|
||||
compViaNatCorrect by SZ =
|
||||
rewrite plusZeroRightNeutral by.nat in fromToNat by
|
||||
compViaNatCorrect by (SS bz) =
|
||||
rewrite sym $ plusSuccRightSucc by.nat bz.nat in
|
||||
EqSS $ compViaNatCorrect by bz
|
||||
|
||||
%transform "Shift.(.)" Shift.(.) = compViaNat
|
||||
|
||||
|
||||
||| `prettyShift bnd unicode prec by` pretty-prints the shift `by`, with the
|
||||
||| following arguments:
|
||||
|||
|
||||
||| * `by : Shift from to`
|
||||
||| * `bnd : HL` is the highlight used for bound variables of this kind
|
||||
||| * `unicode : Bool` is whether to use unicode characters in the output
|
||||
||| * `prec : PPrec` is the surrounding precedence level
|
||||
export
|
||||
prettyShift : Pretty.HasEnv m => (bnd : HL) -> Shift from to -> m (Doc HL)
|
||||
prettyShift bnd by =
|
||||
parensIfM Outer $ hsep $
|
||||
[hl bnd !(ifUnicode "𝑖" "i"), hl Delim !(ifUnicode "≔" ":="),
|
||||
hl bnd $ !(ifUnicode "𝑖+" "i+") <+> pretty by.nat]
|
||||
|
||||
||| prints using the `TVar` highlight for variables
|
||||
export PrettyHL (Shift from to) where prettyM = prettyShift TVar
|
||||
|
||||
|
||||
||| Drops the innermost variable from the input scope.
|
||||
public export
|
||||
drop1 : Shift (S from) to -> Shift from to
|
||||
drop1 SZ = SS SZ
|
||||
drop1 (SS by) = SS (drop1 by)
|
||||
|
||||
private
|
||||
drop1ViaNat : Shift (S from) to -> Shift from to
|
||||
drop1ViaNat by =
|
||||
rewrite shiftDiff by in
|
||||
rewrite sym $ plusSuccRightSucc by.nat from in
|
||||
fromNat (S by.nat)
|
||||
|
||||
private
|
||||
0 drop1ViaNatCorrect : (by : Shift (S from) to) -> drop1ViaNat by = drop1 by
|
||||
drop1ViaNatCorrect SZ = Refl
|
||||
drop1ViaNatCorrect (SS by) =
|
||||
rewrite plusSuccRightSucc by.nat from in
|
||||
rewrite sym $ shiftDiff by in
|
||||
cong SS $ drop1ViaNatCorrect by
|
||||
|
||||
%transform "Shift.drop1" drop1 by = drop1ViaNat by
|
||||
|
||||
|
||||
infixl 8 //
|
||||
public export
|
||||
interface CanShift f where
|
||||
(//) : f from -> Shift from to -> f to
|
||||
|
||||
export CanShift Var where i // by = shift by i
|
||||
|
||||
namespace CanShift
|
||||
public export
|
||||
[Map] (Functor f, CanShift tm) => CanShift (f . tm) where
|
||||
x // by = map (// by) x
|
||||
|
||||
public export
|
||||
[Const] CanShift (\_ => a) where x // _ = x
|
||||
129
lib/Quox/Syntax/Subst.idr
Normal file
129
lib/Quox/Syntax/Subst.idr
Normal file
|
|
@ -0,0 +1,129 @@
|
|||
module Quox.Syntax.Subst
|
||||
|
||||
import public Quox.Syntax.Shift
|
||||
import Quox.Syntax.Var
|
||||
import Quox.Name
|
||||
import Quox.Pretty
|
||||
|
||||
import Data.List
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
infixr 5 :::
|
||||
public export
|
||||
data Subst : (Nat -> Type) -> Nat -> Nat -> Type where
|
||||
Shift : Shift from to -> Subst env from to
|
||||
(:::) : (t : Lazy (env to)) -> Subst env from to -> Subst env (S from) to
|
||||
%name Subst th, ph, ps
|
||||
|
||||
|
||||
private
|
||||
Repr : (Nat -> Type) -> Nat -> Type
|
||||
Repr f to = (List (f to), Nat)
|
||||
|
||||
private
|
||||
repr : Subst f from to -> Repr f to
|
||||
repr (Shift by) = ([], by.nat)
|
||||
repr (t ::: th) = let (ts, i) = repr th in (t::ts, i)
|
||||
|
||||
|
||||
export Eq (f to) => Eq (Subst f from to) where (==) = (==) `on` repr
|
||||
export Ord (f to) => Ord (Subst f from to) where compare = compare `on` repr
|
||||
|
||||
|
||||
infixl 8 //
|
||||
public export
|
||||
interface FromVar env => CanSubst env term where
|
||||
(//) : term from -> Lazy (Subst env from to) -> term to
|
||||
|
||||
public export
|
||||
CanSubst1 : (Nat -> Type) -> Type
|
||||
CanSubst1 f = CanSubst f f
|
||||
|
||||
|
||||
infixl 8 !!
|
||||
public export
|
||||
(!!) : FromVar term => Subst term from to -> Var from -> term to
|
||||
(Shift by) !! i = fromVar $ shift by i
|
||||
(t ::: th) !! VZ = t
|
||||
(t ::: th) !! (VS i) = th !! i
|
||||
|
||||
|
||||
public export
|
||||
CanSubst Var Var where
|
||||
i // Shift by = shift by i
|
||||
VZ // (t ::: th) = t
|
||||
VS i // (t ::: th) = i // th
|
||||
|
||||
|
||||
public export %inline
|
||||
shift : (by : Nat) -> Subst env from (by + from)
|
||||
shift by = Shift $ fromNat by
|
||||
|
||||
|
||||
infixl 9 .
|
||||
public export
|
||||
(.) : CanSubst1 f => Subst f from mid -> Subst f mid to -> Subst f from to
|
||||
Shift by . Shift bz = Shift $ by . bz
|
||||
Shift SZ . ph = ph
|
||||
Shift (SS by) . (t ::: th) = Shift by . th
|
||||
(t ::: th) . ph = (t // ph) ::: (th . ph)
|
||||
|
||||
public export %inline
|
||||
id : Subst f n n
|
||||
id = shift 0
|
||||
|
||||
public export
|
||||
map : (f to -> g to) -> Subst f from to -> Subst g from to
|
||||
map f (Shift by) = Shift by
|
||||
map f (t ::: th) = f t ::: map f th
|
||||
|
||||
|
||||
public export %inline
|
||||
push : CanSubst1 f => Subst f from to -> Subst f (S from) (S to)
|
||||
push th = fromVar VZ ::: (th . shift 1)
|
||||
|
||||
public export
|
||||
drop1 : Subst f (S from) to -> Subst f from to
|
||||
drop1 (Shift by) = Shift $ drop1 by
|
||||
drop1 (t ::: th) = th
|
||||
|
||||
|
||||
public export %inline
|
||||
one : f n -> Subst f (S n) n
|
||||
one x = x ::: id
|
||||
|
||||
|
||||
||| `prettySubst pr names bnd op cl th` pretty-prints the substitution `th`,
|
||||
||| with the following arguments:
|
||||
|||
|
||||
||| * `th : Subst f from to`
|
||||
||| * `pr : f to -> m (Doc HL)` prints a single element
|
||||
||| * `names : List Name` is a list of known bound var names
|
||||
||| * `bnd : HL` is the highlight to use for bound variables being subsituted
|
||||
||| * `op, cl : Doc HL` are the opening and closing brackets
|
||||
export
|
||||
prettySubstM : Pretty.HasEnv m =>
|
||||
(pr : f to -> m (Doc HL)) ->
|
||||
(names : List Name) -> (bnd : HL) -> (op, cl : Doc HL) ->
|
||||
Subst f from to -> m (Doc HL)
|
||||
prettySubstM pr names bnd op cl th =
|
||||
encloseSep (hl Delim op) (hl Delim cl) (hl Delim "; ") <$>
|
||||
withPrec Outer (go 0 th)
|
||||
where
|
||||
go1 : Nat -> f to -> m (Doc HL)
|
||||
go1 i t = pure $ hang 2 $ sep
|
||||
[hsep [!(prettyVar' bnd bnd names i),
|
||||
hl Delim !(ifUnicode "≔" ":=")],
|
||||
!(pr t)]
|
||||
|
||||
go : forall from. Nat -> Subst f from to -> m (List (Doc HL))
|
||||
go _ (Shift SZ) = pure []
|
||||
go _ (Shift by) = [|pure (prettyShift bnd by)|]
|
||||
go i (t ::: th) = [|go1 i t :: go (S i) th|]
|
||||
|
||||
||| prints with [square brackets] and the `TVar` highlight for variables
|
||||
export
|
||||
PrettyHL (f to) => PrettyHL (Subst f from to) where
|
||||
prettyM th = prettySubstM prettyM (!ask).tnames TVar "[" "]" th
|
||||
7
lib/Quox/Syntax/Term.idr
Normal file
7
lib/Quox/Syntax/Term.idr
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
module Quox.Syntax.Term
|
||||
|
||||
import public Quox.Syntax.Term.Base
|
||||
import public Quox.Syntax.Term.Split
|
||||
import public Quox.Syntax.Term.Subst
|
||||
import public Quox.Syntax.Term.Reduce
|
||||
import public Quox.Syntax.Term.Pretty
|
||||
110
lib/Quox/Syntax/Term/Base.idr
Normal file
110
lib/Quox/Syntax/Term/Base.idr
Normal file
|
|
@ -0,0 +1,110 @@
|
|||
module Quox.Syntax.Term.Base
|
||||
|
||||
import public Quox.Syntax.Var
|
||||
import public Quox.Syntax.Shift
|
||||
import public Quox.Syntax.Subst
|
||||
import public Quox.Syntax.Universe
|
||||
import public Quox.Syntax.Qty
|
||||
import public Quox.Syntax.Dim
|
||||
import public Quox.Name
|
||||
import public Quox.OPE
|
||||
|
||||
import Quox.Pretty
|
||||
|
||||
import public Data.DPair
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Nat
|
||||
import public Data.So
|
||||
import Data.String
|
||||
import Data.Vect
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
infixl 8 :#
|
||||
infixl 9 :@
|
||||
mutual
|
||||
public export
|
||||
TSubst : Nat -> Nat -> Nat -> Type
|
||||
TSubst d = Subst (\n => Elim d n)
|
||||
|
||||
||| first argument `d` is dimension scope size, second `n` is term scope size
|
||||
public export
|
||||
data Term : (d, n : Nat) -> Type where
|
||||
||| type of types
|
||||
TYPE : (l : Universe) -> Term d n
|
||||
|
||||
||| function type
|
||||
Pi : (qty : Qty) -> (x : Name) ->
|
||||
(arg : Term d n) -> (res : ScopeTerm d n) -> Term d n
|
||||
||| function term
|
||||
Lam : (x : Name) -> (body : ScopeTerm d n) -> Term d n
|
||||
|
||||
||| elimination
|
||||
E : (e : Elim d n) -> Term d n
|
||||
|
||||
||| term closure/suspended substitution
|
||||
CloT : (tm : Term d from) -> (th : Lazy (TSubst d from to)) -> Term d to
|
||||
||| dimension closure/suspended substitution
|
||||
DCloT : (tm : Term dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Term dto n
|
||||
|
||||
||| first argument `d` is dimension scope size, second `n` is term scope size
|
||||
public export
|
||||
data Elim : (d, n : Nat) -> Type where
|
||||
||| free variable
|
||||
F : (x : Name) -> Elim d n
|
||||
||| bound variable
|
||||
B : (i : Var n) -> Elim d n
|
||||
|
||||
||| term application
|
||||
(:@) : (fun : Elim d n) -> (arg : Term d n) -> Elim d n
|
||||
|
||||
||| type-annotated term
|
||||
(:#) : (tm, ty : Term d n) -> Elim d n
|
||||
|
||||
||| term closure/suspended substitution
|
||||
CloE : (el : Elim d from) -> (th : Lazy (TSubst d from to)) -> Elim d to
|
||||
||| dimension closure/suspended substitution
|
||||
DCloE : (el : Elim dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Elim dto n
|
||||
|
||||
||| a scope with one more bound variable
|
||||
public export
|
||||
data ScopeTerm : (d, n : Nat) -> Type where
|
||||
||| variable is used
|
||||
TUsed : (body : Term d (S n)) -> ScopeTerm d n
|
||||
||| variable is unused
|
||||
TUnused : (body : Term d n) -> ScopeTerm d n
|
||||
|
||||
||| a scope with one more bound dimension variable
|
||||
public export
|
||||
data DScopeTerm : (d, n : Nat) -> Type where
|
||||
||| variable is used
|
||||
DUsed : (body : Term (S d) n) -> DScopeTerm d n
|
||||
||| variable is unused
|
||||
DUnused : (body : Term d n) -> DScopeTerm d n
|
||||
|
||||
%name Term s, t, r
|
||||
%name Elim e, f
|
||||
%name ScopeTerm body
|
||||
%name DScopeTerm body
|
||||
|
||||
public export %inline
|
||||
Arr : Qty -> Term d n -> Term d n -> Term d n
|
||||
Arr pi a b = Pi {qty = pi, x = "_", arg = a, res = TUnused b}
|
||||
|
||||
||| same as `F` but as a term
|
||||
public export %inline
|
||||
FT : Name -> Term d n
|
||||
FT = E . F
|
||||
|
||||
||| abbreviation for a bound variable like `BV 4` instead of
|
||||
||| `B (VS (VS (VS (VS VZ))))`
|
||||
public export %inline
|
||||
BV : (i : Nat) -> (0 _ : LT i n) => Elim d n
|
||||
BV i = B $ V i
|
||||
|
||||
||| same as `BV` but as a term
|
||||
public export %inline
|
||||
BVT : (i : Nat) -> (0 _ : LT i n) => Term d n
|
||||
BVT i = E $ BV i
|
||||
86
lib/Quox/Syntax/Term/Pretty.idr
Normal file
86
lib/Quox/Syntax/Term/Pretty.idr
Normal file
|
|
@ -0,0 +1,86 @@
|
|||
module Quox.Syntax.Term.Pretty
|
||||
|
||||
import Quox.Syntax.Term.Base
|
||||
import Quox.Syntax.Term.Split
|
||||
import Quox.Syntax.Term.Subst
|
||||
import Quox.Pretty
|
||||
|
||||
import Data.Vect
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
parameters {auto _ : Pretty.HasEnv m}
|
||||
private %inline arrowD : m (Doc HL)
|
||||
arrowD = hlF Syntax $ ifUnicode "→" "->"
|
||||
|
||||
private %inline lamD : m (Doc HL)
|
||||
lamD = hlF Syntax $ ifUnicode "λ" "fun"
|
||||
|
||||
private %inline annD : m (Doc HL)
|
||||
annD = hlF Syntax $ ifUnicode "⦂" "::"
|
||||
|
||||
private %inline typeD : Doc HL
|
||||
typeD = hl Syntax "Type"
|
||||
|
||||
private %inline colonD : Doc HL
|
||||
colonD = hl Syntax ":"
|
||||
|
||||
mutual
|
||||
export covering
|
||||
PrettyHL (Term d n) where
|
||||
prettyM (TYPE l) =
|
||||
parensIfM App $ typeD <//> !(withPrec Arg $ prettyM l)
|
||||
prettyM (Pi qty x s t) =
|
||||
parensIfM Outer $ hang 2 $
|
||||
!(prettyBinder [qty] x s) <++> !arrowD
|
||||
<//> !(under T x $ prettyM t)
|
||||
prettyM (Lam x t) =
|
||||
parensIfM Outer $
|
||||
sep [!lamD, hl TVar !(prettyM x), !arrowD]
|
||||
<//> !(under T x $ prettyM t)
|
||||
prettyM (E e) =
|
||||
prettyM e
|
||||
prettyM (CloT s th) =
|
||||
parensIfM SApp . hang 2 =<<
|
||||
[|withPrec SApp (prettyM s) </> prettyTSubst th|]
|
||||
prettyM (DCloT s th) =
|
||||
parensIfM SApp . hang 2 =<<
|
||||
[|withPrec SApp (prettyM s) </> prettyDSubst th|]
|
||||
|
||||
export covering
|
||||
PrettyHL (Elim d n) where
|
||||
prettyM (F x) =
|
||||
hl' Free <$> prettyM x
|
||||
prettyM (B i) =
|
||||
prettyVar TVar TVarErr (!ask).tnames i
|
||||
prettyM (e :@ s) =
|
||||
let GotArgs f args _ = getArgs' e [s] in
|
||||
parensIfM App =<< withPrec Arg
|
||||
[|prettyM f <//> (align . sep <$> traverse prettyM args)|]
|
||||
prettyM (s :# a) =
|
||||
parensIfM Ann $ hang 2 $
|
||||
!(withPrec AnnL $ prettyM s) <++> !annD
|
||||
<//> !(withPrec Ann $ prettyM a)
|
||||
prettyM (CloE e th) =
|
||||
parensIfM SApp . hang 2 =<<
|
||||
[|withPrec SApp (prettyM e) </> prettyTSubst th|]
|
||||
prettyM (DCloE e th) =
|
||||
parensIfM SApp . hang 2 =<<
|
||||
[|withPrec SApp (prettyM e) </> prettyDSubst th|]
|
||||
|
||||
export covering
|
||||
PrettyHL (ScopeTerm d n) where
|
||||
prettyM body = prettyM $ fromScopeTerm body
|
||||
|
||||
export covering
|
||||
prettyTSubst : Pretty.HasEnv m => TSubst d from to -> m (Doc HL)
|
||||
prettyTSubst s = prettySubstM prettyM (!ask).tnames TVar "[" "]" s
|
||||
|
||||
export covering
|
||||
prettyBinder : Pretty.HasEnv m => List Qty -> Name -> Term d n -> m (Doc HL)
|
||||
prettyBinder pis x a =
|
||||
pure $ parens $ hang 2 $
|
||||
hsep [hl TVar !(prettyM x),
|
||||
sep [!(prettyQtyBinds pis),
|
||||
hsep [colonD, !(withPrec Outer $ prettyM a)]]]
|
||||
164
lib/Quox/Syntax/Term/Reduce.idr
Normal file
164
lib/Quox/Syntax/Term/Reduce.idr
Normal file
|
|
@ -0,0 +1,164 @@
|
|||
module Quox.Syntax.Term.Reduce
|
||||
|
||||
import Quox.Syntax.Term.Base
|
||||
import Quox.Syntax.Term.Subst
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
mutual
|
||||
||| true if a term has a closure or dimension closure at the top level,
|
||||
||| or is `E` applied to such an elimination
|
||||
public export %inline
|
||||
topCloT : Term d n -> Bool
|
||||
topCloT (CloT _ _) = True
|
||||
topCloT (DCloT _ _) = True
|
||||
topCloT (E e) = topCloE e
|
||||
topCloT _ = False
|
||||
|
||||
||| true if an elimination has a closure or dimension closure at the top level
|
||||
public export %inline
|
||||
topCloE : Elim d n -> Bool
|
||||
topCloE (CloE _ _) = True
|
||||
topCloE (DCloE _ _) = True
|
||||
topCloE _ = False
|
||||
|
||||
|
||||
public export IsNotCloT : Term d n -> Type
|
||||
IsNotCloT = So . not . topCloT
|
||||
|
||||
||| a term which is not a top level closure
|
||||
public export NotCloTerm : Nat -> Nat -> Type
|
||||
NotCloTerm d n = Subset (Term d n) IsNotCloT
|
||||
|
||||
public export IsNotCloE : Elim d n -> Type
|
||||
IsNotCloE = So . not . topCloE
|
||||
|
||||
||| an elimination which is not a top level closure
|
||||
public export NotCloElim : Nat -> Nat -> Type
|
||||
NotCloElim d n = Subset (Elim d n) IsNotCloE
|
||||
|
||||
public export %inline
|
||||
ncloT : (t : Term d n) -> (0 _ : IsNotCloT t) => NotCloTerm d n
|
||||
ncloT t @{p} = Element t p
|
||||
|
||||
public export %inline
|
||||
ncloE : (t : Elim d n) -> (0 _ : IsNotCloE t) => NotCloElim d n
|
||||
ncloE e @{p} = Element e p
|
||||
|
||||
|
||||
|
||||
mutual
|
||||
||| if the input term has any top-level closures, push them under one layer of
|
||||
||| syntax
|
||||
export %inline
|
||||
pushSubstsT : Term d n -> NotCloTerm d n
|
||||
pushSubstsT s = pushSubstsTWith id id s
|
||||
|
||||
||| if the input elimination has any top-level closures, push them under one
|
||||
||| layer of syntax
|
||||
export %inline
|
||||
pushSubstsE : Elim d n -> NotCloElim d n
|
||||
pushSubstsE e = pushSubstsEWith id id e
|
||||
|
||||
export
|
||||
pushSubstsTWith : DSubst dfrom dto -> TSubst dto from to ->
|
||||
Term dfrom from -> NotCloTerm dto to
|
||||
pushSubstsTWith th ph (TYPE l) =
|
||||
ncloT $ TYPE l
|
||||
pushSubstsTWith th ph (Pi qty x a body) =
|
||||
ncloT $ Pi qty x (subs a th ph) (subs body th ph)
|
||||
pushSubstsTWith th ph (Lam x body) =
|
||||
ncloT $ Lam x $ subs body th ph
|
||||
pushSubstsTWith th ph (E e) =
|
||||
let Element e _ = pushSubstsEWith th ph e in ncloT $ E e
|
||||
pushSubstsTWith th ph (CloT s ps) =
|
||||
pushSubstsTWith th (comp' th ps ph) s
|
||||
pushSubstsTWith th ph (DCloT s ps) =
|
||||
pushSubstsTWith (ps . th) ph s
|
||||
|
||||
export
|
||||
pushSubstsEWith : DSubst dfrom dto -> TSubst dto from to ->
|
||||
Elim dfrom from -> NotCloElim dto to
|
||||
pushSubstsEWith th ph (F x) =
|
||||
ncloE $ F x
|
||||
pushSubstsEWith th ph (B i) =
|
||||
assert_total pushSubstsE $ ph !! i
|
||||
pushSubstsEWith th ph (f :@ s) =
|
||||
ncloE $ subs f th ph :@ subs s th ph
|
||||
pushSubstsEWith th ph (s :# a) =
|
||||
ncloE $ subs s th ph :# subs a th ph
|
||||
pushSubstsEWith th ph (CloE e ps) =
|
||||
pushSubstsEWith th (comp' th ps ph) e
|
||||
pushSubstsEWith th ph (DCloE e ps) =
|
||||
pushSubstsEWith (ps . th) ph e
|
||||
|
||||
|
||||
parameters (th : DSubst dfrom dto) (ph : TSubst dto from to)
|
||||
public export %inline
|
||||
pushSubstsTWith' : Term dfrom from -> Term dto to
|
||||
pushSubstsTWith' s = (pushSubstsTWith th ph s).fst
|
||||
|
||||
public export %inline
|
||||
pushSubstsEWith' : Elim dfrom from -> Elim dto to
|
||||
pushSubstsEWith' e = (pushSubstsEWith th ph e).fst
|
||||
|
||||
|
||||
public export %inline
|
||||
pushSubstsT' : Term d n -> Term d n
|
||||
pushSubstsT' s = (pushSubstsT s).fst
|
||||
|
||||
public export %inline
|
||||
pushSubstsE' : Elim d n -> Elim d n
|
||||
pushSubstsE' e = (pushSubstsE e).fst
|
||||
|
||||
|
||||
mutual
|
||||
-- tightening a term/elim also causes substitutions to be pushed through.
|
||||
-- this is because otherwise a variable in an unused part of the subst
|
||||
-- would cause it to incorrectly fail
|
||||
|
||||
export covering
|
||||
Tighten (Term d) where
|
||||
tighten p (TYPE l) =
|
||||
pure $ TYPE l
|
||||
tighten p (Pi qty x arg res) =
|
||||
Pi qty x <$> tighten p arg
|
||||
<*> tighten p res
|
||||
tighten p (Lam x body) =
|
||||
Lam x <$> tighten p body
|
||||
tighten p (E e) =
|
||||
E <$> tighten p e
|
||||
tighten p (CloT tm th) =
|
||||
tighten p $ pushSubstsTWith' id th tm
|
||||
tighten p (DCloT tm th) =
|
||||
tighten p $ pushSubstsTWith' th id tm
|
||||
|
||||
export covering
|
||||
Tighten (Elim d) where
|
||||
tighten p (F x) =
|
||||
pure $ F x
|
||||
tighten p (B i) =
|
||||
B <$> tighten p i
|
||||
tighten p (fun :@ arg) =
|
||||
[|tighten p fun :@ tighten p arg|]
|
||||
tighten p (tm :# ty) =
|
||||
[|tighten p tm :# tighten p ty|]
|
||||
tighten p (CloE el th) =
|
||||
tighten p $ pushSubstsEWith' id th el
|
||||
tighten p (DCloE el th) =
|
||||
tighten p $ pushSubstsEWith' th id el
|
||||
|
||||
export covering
|
||||
Tighten (ScopeTerm d) where
|
||||
tighten p (TUsed body) = TUsed <$> tighten (Keep p) body
|
||||
tighten p (TUnused body) = TUnused <$> tighten p body
|
||||
|
||||
|
||||
public export %inline
|
||||
weakT : Term d n -> Term d (S n)
|
||||
weakT t = t //. shift 1
|
||||
|
||||
public export %inline
|
||||
weakE : Elim d n -> Elim d (S n)
|
||||
weakE t = t //. shift 1
|
||||
82
lib/Quox/Syntax/Term/Split.idr
Normal file
82
lib/Quox/Syntax/Term/Split.idr
Normal file
|
|
@ -0,0 +1,82 @@
|
|||
module Quox.Syntax.Term.Split
|
||||
|
||||
import Quox.Syntax.Term.Base
|
||||
import Quox.Syntax.Term.Subst
|
||||
|
||||
import Data.So
|
||||
import Data.Vect
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export %inline
|
||||
isLam : Term d n -> Bool
|
||||
isLam (Lam {}) = True
|
||||
isLam _ = False
|
||||
|
||||
public export
|
||||
NotLam : Term d n -> Type
|
||||
NotLam = So . not . isLam
|
||||
|
||||
|
||||
public export %inline
|
||||
isApp : Elim d n -> Bool
|
||||
isApp ((:@) {}) = True
|
||||
isApp _ = False
|
||||
|
||||
public export
|
||||
NotApp : Elim d n -> Type
|
||||
NotApp = So . not . isApp
|
||||
|
||||
|
||||
infixl 9 :@@
|
||||
||| apply multiple arguments at once
|
||||
public export %inline
|
||||
(:@@) : Elim d n -> List (Term d n) -> Elim d n
|
||||
f :@@ ss = foldl (:@) f ss
|
||||
|
||||
public export
|
||||
record GetArgs (d, n : Nat) where
|
||||
constructor GotArgs
|
||||
fun : Elim d n
|
||||
args : List (Term d n)
|
||||
0 notApp : NotApp fun
|
||||
|
||||
export
|
||||
getArgs' : Elim d n -> List (Term d n) -> GetArgs d n
|
||||
getArgs' fun args with (choose $ isApp fun)
|
||||
getArgs' (f :@ a) args | Left yes = getArgs' f (a :: args)
|
||||
_ | Right no = GotArgs {fun, args, notApp = no}
|
||||
|
||||
||| splits an application into its head and arguments. if it's not an
|
||||
||| application then the list is just empty
|
||||
export %inline
|
||||
getArgs : Elim d n -> GetArgs d n
|
||||
getArgs e = getArgs' e []
|
||||
|
||||
|
||||
infixr 1 :\\
|
||||
public export
|
||||
(:\\) : Vect m Name -> Term d (m + n) -> Term d n
|
||||
[] :\\ t = t
|
||||
x :: xs :\\ t = let t' = replace {p = Term _} (plusSuccRightSucc {}) t in
|
||||
Lam x $ TUsed $ xs :\\ t'
|
||||
|
||||
public export
|
||||
record GetLams (d, n : Nat) where
|
||||
constructor GotLams
|
||||
names : Vect lams Name
|
||||
body : Term d rest
|
||||
0 eq : lams + n = rest
|
||||
0 notLam : NotLam body
|
||||
|
||||
public export
|
||||
getLams : Term d n -> GetLams d n
|
||||
getLams s with (choose $ isLam s)
|
||||
getLams s@(Lam x body) | Left yes =
|
||||
let inner = getLams $ assert_smaller s $ fromScopeTerm body in
|
||||
GotLams {names = x :: inner.names,
|
||||
body = inner.body,
|
||||
eq = plusSuccRightSucc {} `trans` inner.eq,
|
||||
notLam = inner.notLam}
|
||||
_ | Right no = GotLams {names = [], body = s, eq = Refl, notLam = no}
|
||||
135
lib/Quox/Syntax/Term/Subst.idr
Normal file
135
lib/Quox/Syntax/Term/Subst.idr
Normal file
|
|
@ -0,0 +1,135 @@
|
|||
module Quox.Syntax.Term.Subst
|
||||
|
||||
import Quox.Syntax.Term.Base
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
export FromVar (Elim d) where fromVar = B
|
||||
export FromVar (Term d) where fromVar = E . fromVar
|
||||
|
||||
||| does the minimal reasonable work:
|
||||
||| - deletes the closure around a free name since it doesn't do anything
|
||||
||| - deletes an identity substitution
|
||||
||| - composes (lazily) with an existing top-level closure
|
||||
||| - immediately looks up a bound variable
|
||||
||| - otherwise, wraps in a new closure
|
||||
export
|
||||
CanSubst (Elim d) (Elim d) where
|
||||
F x // _ = F x
|
||||
B i // th = th !! i
|
||||
CloE e ph // th = assert_total CloE e $ ph . th
|
||||
e // th = case force th of
|
||||
Shift SZ => e
|
||||
th => CloE e th
|
||||
|
||||
||| does the minimal reasonable work:
|
||||
||| - deletes the closure around an atomic constant like `TYPE`
|
||||
||| - deletes an identity substitution
|
||||
||| - composes (lazily) with an existing top-level closure
|
||||
||| - goes inside `E` in case it is a simple variable or something
|
||||
||| - otherwise, wraps in a new closure
|
||||
export
|
||||
CanSubst (Elim d) (Term d) where
|
||||
TYPE l // _ = TYPE l
|
||||
E e // th = E $ e // th
|
||||
CloT s ph // th = CloT s $ ph . th
|
||||
s // th = case force th of
|
||||
Shift SZ => s
|
||||
th => CloT s th
|
||||
|
||||
export
|
||||
CanSubst (Elim d) (ScopeTerm d) where
|
||||
TUsed body // th = TUsed $ body // push th
|
||||
TUnused body // th = TUnused $ body // th
|
||||
|
||||
export CanSubst Var (Term d) where s // th = s // map (B {d}) th
|
||||
export CanSubst Var (Elim d) where e // th = e // map (B {d}) th
|
||||
export CanSubst Var (ScopeTerm d) where s // th = s // map (B {d}) th
|
||||
|
||||
|
||||
infixl 8 //., ///
|
||||
mutual
|
||||
namespace Term
|
||||
||| applies a term substitution with a less ambiguous type
|
||||
export
|
||||
(//.) : Term d from -> TSubst d from to -> Term d to
|
||||
t //. th = t // th
|
||||
|
||||
||| applies a dimension substitution with the same behaviour as `(//)`
|
||||
||| above
|
||||
export
|
||||
(///) : Term dfrom n -> DSubst dfrom dto -> Term dto n
|
||||
TYPE l /// _ = TYPE l
|
||||
E e /// th = E $ e /// th
|
||||
DCloT s ph /// th = DCloT s $ ph . th
|
||||
s /// Shift SZ = s
|
||||
s /// th = DCloT s th
|
||||
|
||||
||| applies a term and dimension substitution
|
||||
public export %inline
|
||||
subs : Term dfrom from -> DSubst dfrom dto -> TSubst dto from to ->
|
||||
Term dto to
|
||||
subs s th ph = s /// th // ph
|
||||
|
||||
namespace Elim
|
||||
||| applies a term substitution with a less ambiguous type
|
||||
export
|
||||
(//.) : Elim d from -> TSubst d from to -> Elim d to
|
||||
e //. th = e // th
|
||||
|
||||
||| applies a dimension substitution with the same behaviour as `(//)`
|
||||
||| above
|
||||
export
|
||||
(///) : Elim dfrom n -> DSubst dfrom dto -> Elim dto n
|
||||
F x /// _ = F x
|
||||
B i /// _ = B i
|
||||
DCloE e ph /// th = DCloE e $ ph . th
|
||||
e /// Shift SZ = e
|
||||
e /// th = DCloE e th
|
||||
|
||||
||| applies a term and dimension substitution
|
||||
public export %inline
|
||||
subs : Elim dfrom from -> DSubst dfrom dto -> TSubst dto from to ->
|
||||
Elim dto to
|
||||
subs e th ph = e /// th // ph
|
||||
|
||||
namespace ScopeTerm
|
||||
||| applies a term substitution with a less ambiguous type
|
||||
export
|
||||
(//.) : ScopeTerm d from -> TSubst d from to -> ScopeTerm d to
|
||||
body //. th = body // th
|
||||
|
||||
||| applies a dimension substitution with the same behaviour as `(//)`
|
||||
||| above
|
||||
export
|
||||
(///) : ScopeTerm dfrom n -> DSubst dfrom dto -> ScopeTerm dto n
|
||||
TUsed body /// th = TUsed $ body /// th
|
||||
TUnused body /// th = TUnused $ body /// th
|
||||
|
||||
||| applies a term and dimension substitution
|
||||
public export %inline
|
||||
subs : ScopeTerm dfrom from -> DSubst dfrom dto -> TSubst dto from to ->
|
||||
ScopeTerm dto to
|
||||
subs body th ph = body /// th // ph
|
||||
|
||||
export CanShift (Term d) where s // by = s //. Shift by
|
||||
export CanShift (Elim d) where e // by = e //. Shift by
|
||||
export CanShift (ScopeTerm d) where s // by = s //. Shift by
|
||||
|
||||
|
||||
export %inline
|
||||
comp' : DSubst dfrom dto -> TSubst dfrom from mid -> TSubst dto mid to ->
|
||||
TSubst dto from to
|
||||
comp' th ps ph = map (/// th) ps . ph
|
||||
|
||||
|
||||
export
|
||||
fromDScopeTerm : DScopeTerm d n -> Term (S d) n
|
||||
fromDScopeTerm (DUsed body) = body
|
||||
fromDScopeTerm (DUnused body) = body /// shift 1
|
||||
|
||||
export
|
||||
fromScopeTerm : ScopeTerm d n -> Term d (S n)
|
||||
fromScopeTerm (TUsed body) = body
|
||||
fromScopeTerm (TUnused body) = body //. shift 1
|
||||
23
lib/Quox/Syntax/Universe.idr
Normal file
23
lib/Quox/Syntax/Universe.idr
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
module Quox.Syntax.Universe
|
||||
|
||||
import Quox.Pretty
|
||||
|
||||
import Data.Fin
|
||||
import Generics.Derive
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
||||
|
||||
||| `UAny` doesn't show up in programs, but when checking something is
|
||||
||| just some type (e.g. in a signature) it's checked against `Star UAny`
|
||||
public export
|
||||
data Universe = U Nat | UAny
|
||||
%name Universe l
|
||||
|
||||
%runElab derive "Universe" [Generic, Meta, Eq, Ord, DecEq, Show]
|
||||
|
||||
export
|
||||
PrettyHL Universe where
|
||||
prettyM UAny = pure $ hl Delim "_"
|
||||
prettyM (U l) = pure $ hl Free $ pretty l
|
||||
273
lib/Quox/Syntax/Var.idr
Normal file
273
lib/Quox/Syntax/Var.idr
Normal file
|
|
@ -0,0 +1,273 @@
|
|||
module Quox.Syntax.Var
|
||||
|
||||
import Quox.Name
|
||||
import Quox.Pretty
|
||||
import Quox.OPE
|
||||
|
||||
import Data.Nat
|
||||
import Data.List
|
||||
import Decidable.Equality
|
||||
import Data.Bool.Decidable
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
data Var : Nat -> Type where
|
||||
VZ : Var (S n)
|
||||
VS : Var n -> Var (S n)
|
||||
%name Var i, j
|
||||
%builtin Natural Var
|
||||
|
||||
public export
|
||||
(.nat) : Var n -> Nat
|
||||
(VZ).nat = 0
|
||||
(VS i).nat = S i.nat
|
||||
%transform "Var.(.nat)" Var.(.nat) i = believe_me i
|
||||
|
||||
public export %inline Cast (Var n) Nat where cast = (.nat)
|
||||
public export %inline Cast (Var n) Integer where cast = cast . cast {to = Nat}
|
||||
|
||||
export %inline Eq (Var n) where i == j = i.nat == j.nat
|
||||
export %inline Ord (Var n) where compare i j = compare i.nat j.nat
|
||||
export %inline Show (Var n) where showPrec d i = showCon d "V" $ showArg i.nat
|
||||
|
||||
public export %inline Injective VS where injective Refl = Refl
|
||||
|
||||
|
||||
parameters {auto _ : Pretty.HasEnv m}
|
||||
private
|
||||
prettyIndex : Nat -> m (Doc a)
|
||||
prettyIndex i =
|
||||
ifUnicode (pretty $ pack $ map sup $ unpack $ show i) (":" <+> pretty i)
|
||||
where
|
||||
sup : Char -> Char
|
||||
sup c = case c of
|
||||
'0' => '⁰'; '1' => '¹'; '2' => '²'; '3' => '³'; '4' => '⁴'
|
||||
'5' => '⁵'; '6' => '⁶'; '7' => '⁷'; '8' => '⁸'; '9' => '⁹'; _ => c
|
||||
|
||||
||| `prettyVar hlok hlerr names i` pretty prints the de Bruijn index `i`.
|
||||
|||
|
||||
||| If it is within the bounds of `names`, then it uses the name at that index,
|
||||
||| highlighted as `hlok`. Otherwise it is just printed as a number highlighted
|
||||
||| as `hlerr`.
|
||||
export
|
||||
prettyVar' : HL -> HL -> List Name -> Nat -> m (Doc HL)
|
||||
prettyVar' hlok hlerr names i =
|
||||
case inBounds i names of
|
||||
Yes _ => hlF' hlok [|prettyM (index i names) <+> prettyIndex i|]
|
||||
No _ => pure $ hl hlerr $ pretty i
|
||||
|
||||
export %inline
|
||||
prettyVar : HL -> HL -> List Name -> Var n -> m (Doc HL)
|
||||
prettyVar hlok hlerr names i = prettyVar' hlok hlerr names i.nat
|
||||
|
||||
|
||||
public export
|
||||
fromNatWith : (i : Nat) -> (0 p : i `LT` n) -> Var n
|
||||
fromNatWith Z (LTESucc _) = VZ
|
||||
fromNatWith (S i) (LTESucc p) = VS $ fromNatWith i p
|
||||
%transform "Var.fromNatWith" fromNatWith i p = believe_me i
|
||||
|
||||
public export %inline
|
||||
V : (i : Nat) -> {auto 0 p : i `LT` n} -> Var n
|
||||
V i {p} = fromNatWith i p
|
||||
|
||||
export %inline
|
||||
tryFromNat : Alternative f => (n : Nat) -> Nat -> f (Var n)
|
||||
tryFromNat n i =
|
||||
case i `isLT` n of
|
||||
Yes p => pure $ fromNatWith i p
|
||||
No _ => empty
|
||||
|
||||
export
|
||||
0 toNatLT : (i : Var n) -> i.nat `LT` n
|
||||
toNatLT VZ = LTESucc LTEZero
|
||||
toNatLT (VS i) = LTESucc $ toNatLT i
|
||||
|
||||
public export
|
||||
toNatInj : {i, j : Var n} -> i.nat = j.nat -> i = j
|
||||
toNatInj {i = VZ} {j = VZ} Refl = Refl
|
||||
toNatInj {i = VZ} {j = (VS i)} Refl impossible
|
||||
toNatInj {i = (VS i)} {j = VZ} Refl impossible
|
||||
toNatInj {i = (VS i)} {j = (VS j)} prf = cong VS $ toNatInj $ injective prf
|
||||
|
||||
public export %inline Injective (.nat) where injective = toNatInj
|
||||
|
||||
export
|
||||
0 fromToNat : (i : Var n) -> (p : i.nat `LT` n) -> fromNatWith i.nat p = i
|
||||
fromToNat VZ (LTESucc p) = Refl
|
||||
fromToNat (VS i) (LTESucc p) = rewrite fromToNat i p in Refl
|
||||
|
||||
export
|
||||
0 toFromNat : (i : Nat) -> (p : i `LT` n) -> (fromNatWith i p).nat = i
|
||||
toFromNat 0 (LTESucc x) = Refl
|
||||
toFromNat (S k) (LTESucc x) = cong S $ toFromNat k x
|
||||
|
||||
|
||||
-- not using %transform like other things because weakSpec requires the proof
|
||||
-- to be relevant. but since only `LTESucc` is ever possible that seems
|
||||
-- to be an instance of <https://github.com/idris-lang/Idris2/issues/1259>?
|
||||
export
|
||||
weak : (0 p : m `LTE` n) -> Var m -> Var n
|
||||
weak p i = fromNatWith i.nat $ transitive (toNatLT i) p
|
||||
|
||||
public export
|
||||
0 weakSpec : m `LTE` n -> Var m -> Var n
|
||||
weakSpec LTEZero _ impossible
|
||||
weakSpec (LTESucc p) VZ = VZ
|
||||
weakSpec (LTESucc p) (VS i) = VS $ weakSpec p i
|
||||
|
||||
export
|
||||
0 weakSpecCorrect : (p : m `LTE` n) -> (i : Var m) -> (weakSpec p i).nat = i.nat
|
||||
weakSpecCorrect LTEZero _ impossible
|
||||
weakSpecCorrect (LTESucc x) VZ = Refl
|
||||
weakSpecCorrect (LTESucc x) (VS i) = cong S $ weakSpecCorrect x i
|
||||
|
||||
export
|
||||
0 weakCorrect : (p : m `LTE` n) -> (i : Var m) -> (weak p i).nat = i.nat
|
||||
weakCorrect LTEZero _ impossible
|
||||
weakCorrect (LTESucc p) VZ = Refl
|
||||
weakCorrect (LTESucc p) (VS i) = cong S $ weakCorrect p i
|
||||
|
||||
export
|
||||
0 weakIsSpec : (p : m `LTE` n) -> (i : Var m) -> weak p i = weakSpec p i
|
||||
weakIsSpec p i = toNatInj $ trans (weakCorrect p i) (sym $ weakSpecCorrect p i)
|
||||
|
||||
|
||||
public export
|
||||
interface FromVar f where %inline fromVar : Var n -> f n
|
||||
|
||||
public export FromVar Var where fromVar = id
|
||||
|
||||
|
||||
public export
|
||||
data LT : Var n -> Var n -> Type where
|
||||
LTZ : VZ `LT` VS i
|
||||
LTS : i `LT` j -> VS i `LT` VS j
|
||||
%builtin Natural Var.LT
|
||||
%name Var.LT lt
|
||||
|
||||
public export %inline
|
||||
GT : Var n -> Var n -> Type
|
||||
i `GT` j = j `LT` i
|
||||
|
||||
export
|
||||
Transitive (Var n) LT where
|
||||
transitive LTZ (LTS _) = LTZ
|
||||
transitive (LTS p) (LTS q) = LTS $ transitive p q
|
||||
|
||||
export Uninhabited (i `Var.LT` i) where uninhabited (LTS p) = uninhabited p
|
||||
export Uninhabited (VS i `LT` VZ) where uninhabited _ impossible
|
||||
|
||||
export
|
||||
isLT : (i, j : Var n) -> Dec (i `LT` j)
|
||||
isLT VZ VZ = No uninhabited
|
||||
isLT VZ (VS j) = Yes LTZ
|
||||
isLT (VS i) VZ = No uninhabited
|
||||
isLT (VS i) (VS j) with (isLT i j)
|
||||
_ | Yes prf = Yes (LTS prf)
|
||||
_ | No contra = No (\case LTS p => contra p)
|
||||
|
||||
|
||||
public export
|
||||
data Compare : (i, j : Var n) -> Type where
|
||||
IsLT : (lt : i `LT` j) -> Compare i j
|
||||
IsEQ : Compare i i
|
||||
IsGT : (gt : i `GT` j) -> Compare i j
|
||||
%name Compare cmp
|
||||
|
||||
export
|
||||
compareS : Compare i j -> Compare (VS i) (VS j)
|
||||
compareS (IsLT lt) = IsLT (LTS lt)
|
||||
compareS IsEQ = IsEQ
|
||||
compareS (IsGT gt) = IsGT (LTS gt)
|
||||
|
||||
export
|
||||
compareP : (i, j : Var n) -> Compare i j
|
||||
compareP VZ VZ = IsEQ
|
||||
compareP VZ (VS j) = IsLT LTZ
|
||||
compareP (VS i) VZ = IsGT LTZ
|
||||
compareP (VS i) (VS j) = compareS $ compareP i j
|
||||
|
||||
export
|
||||
0 compareSelf : (c : Compare i i) -> c = IsEQ
|
||||
compareSelf (IsLT lt) = absurd lt
|
||||
compareSelf IsEQ = Refl
|
||||
compareSelf (IsGT gt) = absurd gt
|
||||
|
||||
export
|
||||
0 comparePSelf : (i : Var n) -> compareP i i = IsEQ
|
||||
comparePSelf i = compareSelf {}
|
||||
|
||||
|
||||
public export
|
||||
data LTE : Var n -> Var n -> Type where
|
||||
LTEZ : VZ `LTE` j
|
||||
LTES : i `LTE` j -> VS i `LTE` VS j
|
||||
|
||||
export
|
||||
Reflexive (Var n) LTE where
|
||||
reflexive {x = VZ} = LTEZ
|
||||
reflexive {x = VS i} = LTES reflexive
|
||||
|
||||
export
|
||||
Transitive (Var n) LTE where
|
||||
transitive LTEZ q = LTEZ
|
||||
transitive (LTES p) (LTES q) = LTES $ transitive p q
|
||||
|
||||
export
|
||||
Antisymmetric (Var n) LTE where
|
||||
antisymmetric LTEZ LTEZ = Refl
|
||||
antisymmetric (LTES p) (LTES q) = cong VS $ antisymmetric p q
|
||||
|
||||
export
|
||||
splitLTE : {j : Var n} -> i `LTE` j -> Either (i = j) (i `LT` j)
|
||||
splitLTE {j = VZ} LTEZ = Left Refl
|
||||
splitLTE {j = VS _} LTEZ = Right LTZ
|
||||
splitLTE (LTES p) with (splitLTE p)
|
||||
_ | (Left eq) = Left $ cong VS eq
|
||||
_ | (Right lt) = Right $ LTS lt
|
||||
|
||||
|
||||
export Uninhabited (VZ = VS i) where uninhabited _ impossible
|
||||
export Uninhabited (VS i = VZ) where uninhabited _ impossible
|
||||
|
||||
|
||||
public export
|
||||
eqReflect : (i, j : Var n) -> (i = j) `Reflects` (i == j)
|
||||
eqReflect VZ VZ = RTrue Refl
|
||||
eqReflect VZ (VS i) = RFalse absurd
|
||||
eqReflect (VS i) VZ = RFalse absurd
|
||||
eqReflect (VS i) (VS j) with (eqReflect i j)
|
||||
eqReflect (VS i) (VS j) | r with (i == j)
|
||||
eqReflect (VS i) (VS j) | RTrue yes | True = RTrue $ cong VS yes
|
||||
eqReflect (VS i) (VS j) | RFalse no | False = RFalse $ no . injective
|
||||
|
||||
public export
|
||||
reflectToDec : p `Reflects` b -> Dec p
|
||||
reflectToDec (RTrue y) = Yes y
|
||||
reflectToDec (RFalse n) = No n
|
||||
|
||||
public export %inline
|
||||
varDecEq : (i, j : Var n) -> Dec (i = j)
|
||||
varDecEq i j = reflectToDec $ eqReflect i j
|
||||
|
||||
-- justified by eqReflect [citation needed]
|
||||
private %inline
|
||||
decEqFromBool : (i, j : Var n) -> Dec (i = j)
|
||||
decEqFromBool i j =
|
||||
if i == j then Yes $ believe_me $ Refl {x = 0}
|
||||
else No $ id . believe_me
|
||||
|
||||
%transform "Var.decEq" varDecEq = decEqFromBool
|
||||
|
||||
public export %inline DecEq (Var n) where decEq = varDecEq
|
||||
|
||||
export
|
||||
Tighten Var where
|
||||
tighten Id i = pure i
|
||||
tighten (Drop q) VZ = empty
|
||||
tighten (Drop q) (VS i) = tighten q i
|
||||
tighten (Keep q) VZ = pure VZ
|
||||
tighten (Keep q) (VS i) = VS <$> tighten q i
|
||||
52
lib/Quox/Token.idr
Normal file
52
lib/Quox/Token.idr
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
module Quox.Token
|
||||
|
||||
import Generics.Derive
|
||||
import Text.Lexer
|
||||
|
||||
%default total
|
||||
%language ElabReflection
|
||||
|
||||
|
||||
public export
|
||||
data Punc
|
||||
= LParen | RParen
|
||||
| LSquare | RSquare
|
||||
| LBrace | RBrace
|
||||
| Comma
|
||||
| Colon | DblColon
|
||||
| Dot
|
||||
| Arrow | DblArrow
|
||||
| Times | Triangle
|
||||
| Wild
|
||||
|
||||
%runElab derive "Punc" [Generic, Meta, Eq, Ord, DecEq, Show]
|
||||
|
||||
|
||||
public export
|
||||
data Keyword
|
||||
= Fun | Let | In | Case | Of | Omega
|
||||
|
||||
%runElab derive "Keyword" [Generic, Meta, Eq, Ord, DecEq, Show]
|
||||
|
||||
|
||||
||| zero and one are separate because they are
|
||||
||| quantity & dimension constants
|
||||
public export
|
||||
data Number = Zero | One | Other Nat
|
||||
|
||||
%runElab derive "Number" [Generic, Meta, Eq, Ord, DecEq, Show]
|
||||
|
||||
|
||||
public export
|
||||
data Token
|
||||
= P Punc
|
||||
| Name String | Symbol String
|
||||
| N Number
|
||||
| K Keyword
|
||||
|
||||
%runElab derive "Token" [Generic, Meta, Eq, Ord, DecEq, Show]
|
||||
|
||||
|
||||
public export
|
||||
BToken : Type
|
||||
BToken = WithBounds Token
|
||||
152
lib/Quox/Typechecker.idr
Normal file
152
lib/Quox/Typechecker.idr
Normal file
|
|
@ -0,0 +1,152 @@
|
|||
module Quox.Typechecker
|
||||
|
||||
import public Quox.Syntax
|
||||
import public Quox.Typing
|
||||
import Control.Monad.Either
|
||||
|
||||
%hide Equal.Error
|
||||
%default total
|
||||
|
||||
|
||||
private covering %inline
|
||||
expectTYPE : MonadError Error m => Term d n -> m Universe
|
||||
expectTYPE s =
|
||||
case (whnfT s).fst of
|
||||
TYPE l => pure l
|
||||
_ => throwError $ ExpectedTYPE s
|
||||
|
||||
private covering %inline
|
||||
expectPi : MonadError Error m => Term d n ->
|
||||
m (Qty, Term d n, ScopeTerm d n)
|
||||
expectPi ty =
|
||||
case (whnfT ty).fst of
|
||||
Pi qty _ arg res => pure (qty, arg, res)
|
||||
_ => throwError $ ExpectedPi ty
|
||||
|
||||
private %inline
|
||||
expectEqualQ : MonadError Error m =>
|
||||
(expect, actual : Qty) -> m ()
|
||||
expectEqualQ pi rh =
|
||||
unless (pi == rh) $ throwError $ EqualError $ ClashQ pi rh
|
||||
|
||||
|
||||
private %inline
|
||||
popQ : MonadError Error m => Qty -> QOutput (S n) -> m (QOutput n)
|
||||
popQ pi (qctx :< rh) = expectEqualQ pi rh $> qctx
|
||||
|
||||
|
||||
private %inline
|
||||
tail : TyContext d (S n) -> TyContext d n
|
||||
tail = {tctx $= tail, qctx $= tail}
|
||||
|
||||
|
||||
private %inline
|
||||
globalSubjQty : Global -> Qty
|
||||
globalSubjQty (MkGlobal {qty = Zero, _}) = Zero
|
||||
globalSubjQty (MkGlobal {qty = Any, _}) = One
|
||||
|
||||
|
||||
private %inline
|
||||
weakI : InferResult d n -> InferResult d (S n)
|
||||
weakI = {type $= weakT, qout $= (:< zero)}
|
||||
|
||||
private
|
||||
lookupBound : {n : Nat} -> Qty -> Var n -> TyContext d n -> InferResult d n
|
||||
lookupBound pi VZ (MkTyContext {tctx = _ :< ty, _}) =
|
||||
InfRes {type = weakT ty, qout = zero :< pi}
|
||||
lookupBound pi (VS i) ctx =
|
||||
weakI $ lookupBound pi i (tail ctx)
|
||||
|
||||
|
||||
private %inline
|
||||
subjMult : Qty -> Qty -> Subset Qty IsSubj
|
||||
subjMult sg qty =
|
||||
if sg == Zero || qty == Zero
|
||||
then Element Zero %search
|
||||
else Element One %search
|
||||
|
||||
|
||||
mutual
|
||||
-- [todo] it seems like the options here for dealing with substitutions are
|
||||
-- to either push them or parametrise the whole typechecker over ambient
|
||||
-- substitutions. both of them seem like the same amount of work for the
|
||||
-- computer but pushing is less work for the me
|
||||
|
||||
export covering %inline
|
||||
check : MonadError Error m => {d, n : Nat} ->
|
||||
(ctx : TyContext d n) -> (sg : Qty) -> {auto 0 sgs : IsSubj sg} ->
|
||||
(subj : Term d n) -> (ty : Term d n) ->
|
||||
m (CheckResult n)
|
||||
check ctx sg subj ty = check' ctx sg (pushSubstsT subj) ty
|
||||
|
||||
export covering %inline
|
||||
infer : MonadError Error m => {d, n : Nat} ->
|
||||
(ctx : TyContext d n) -> (sg : Qty) -> {auto 0 sgs : IsSubj sg} ->
|
||||
(subj : Elim d n) ->
|
||||
m (InferResult d n)
|
||||
infer ctx sg subj = infer' ctx sg (pushSubstsE subj)
|
||||
|
||||
|
||||
export covering
|
||||
check' : MonadError Error m => {d, n : Nat} ->
|
||||
(ctx : TyContext d n) -> (sg : Qty) -> {auto 0 sgs : IsSubj sg} ->
|
||||
(subj : NotCloTerm d n) -> (ty : Term d n) ->
|
||||
m (CheckResult n)
|
||||
|
||||
check' ctx sg (Element (TYPE l) _) ty = do
|
||||
l' <- expectTYPE ty
|
||||
expectEqualQ zero sg
|
||||
unless (l < l') $ throwError $ BadUniverse l l'
|
||||
pure zero
|
||||
|
||||
-- [todo] factor this stuff out
|
||||
check' ctx sg (Element (Pi qty x arg res) _) ty = do
|
||||
l <- expectTYPE ty
|
||||
expectEqualQ zero sg
|
||||
ignore $ check ctx zero arg (TYPE l)
|
||||
case res of
|
||||
TUsed res => ignore $ check (extendTy arg zero ctx) zero res (TYPE l)
|
||||
TUnused res => ignore $ check ctx zero res (TYPE l)
|
||||
pure zero
|
||||
|
||||
check' ctx sg (Element (Lam x body) _) ty = do
|
||||
(qty, arg, res) <- expectPi ty
|
||||
-- [todo] do this properly?
|
||||
let body = fromScopeTerm body; res = fromScopeTerm res
|
||||
qout <- check (extendTy arg (sg * qty) ctx) sg body res
|
||||
popQ qty qout
|
||||
|
||||
check' ctx sg (Element (E e) _) ty = do
|
||||
infres <- infer ctx sg e
|
||||
ignore $ check ctx zero ty (TYPE UAny)
|
||||
either (throwError . EqualError) pure $ infres.type `subT` ty
|
||||
pure infres.qout
|
||||
|
||||
export covering
|
||||
infer' : MonadError Error m => {d, n : Nat} ->
|
||||
(ctx : TyContext d n) -> (sg : Qty) -> {auto 0 sgs : IsSubj sg} ->
|
||||
(subj : NotCloElim d n) ->
|
||||
m (InferResult d n)
|
||||
|
||||
infer' ctx sg (Element (F x) _) =
|
||||
case lookup x ctx.globals of
|
||||
Just g => do
|
||||
expectEqualQ (globalSubjQty g) sg
|
||||
pure $ InfRes {type = g.type, qout = zero}
|
||||
Nothing => throwError $ NotInScope x
|
||||
|
||||
infer' ctx sg (Element (B i) _) =
|
||||
pure $ lookupBound sg i ctx
|
||||
|
||||
infer' ctx sg (Element (fun :@ arg) _) = do
|
||||
funres <- infer ctx sg fun
|
||||
(qty, argty, res) <- expectPi funres.type
|
||||
let Element sg' _ = subjMult sg qty
|
||||
argout <- check ctx sg' arg argty
|
||||
pure $ InfRes {type = fromScopeTerm res //. ((arg :# argty) ::: id),
|
||||
qout = funres.qout + argout}
|
||||
|
||||
infer' ctx sg (Element (tm :# ty) _) = do
|
||||
ignore $ check ctx zero ty (TYPE UAny)
|
||||
qout <- check ctx sg tm ty
|
||||
pure $ InfRes {type = ty, qout}
|
||||
109
lib/Quox/Typing.idr
Normal file
109
lib/Quox/Typing.idr
Normal file
|
|
@ -0,0 +1,109 @@
|
|||
module Quox.Typing
|
||||
|
||||
import public Quox.Syntax
|
||||
import public Quox.Context
|
||||
import public Quox.Equal
|
||||
|
||||
import Data.Nat
|
||||
import public Data.SortedMap
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
data DContext : Nat -> Type where
|
||||
DNil : DContext 0
|
||||
DBind : DContext d -> DContext (S d)
|
||||
DEq : Dim d -> Dim d -> DContext d -> DContext d
|
||||
|
||||
public export
|
||||
TContext : Nat -> Nat -> Type
|
||||
TContext d = Context (Term d)
|
||||
|
||||
public export
|
||||
QContext : Nat -> Type
|
||||
QContext = Context' Qty
|
||||
|
||||
public export
|
||||
QOutput : Nat -> Type
|
||||
QOutput = QContext
|
||||
|
||||
|
||||
public export
|
||||
record Global where
|
||||
constructor MkGlobal
|
||||
qty : Qty
|
||||
0 qtyGlobal : IsGlobal qty
|
||||
type, term : forall d, n. Term d n
|
||||
|
||||
public export
|
||||
Globals : Type
|
||||
Globals = SortedMap Name Global
|
||||
|
||||
|
||||
public export
|
||||
record TyContext (d, n : Nat) where
|
||||
constructor MkTyContext
|
||||
globals : Globals
|
||||
dctx : DContext d
|
||||
tctx : TContext d n
|
||||
qctx : QContext n
|
||||
|
||||
%name TyContext ctx
|
||||
|
||||
|
||||
namespace TContext
|
||||
export
|
||||
pushD : TContext d n -> TContext (S d) n
|
||||
pushD tel = map (/// shift 1) tel
|
||||
|
||||
|
||||
namespace TyContext
|
||||
export
|
||||
extendTy : Term d n -> Qty -> TyContext d n -> TyContext d (S n)
|
||||
extendTy s rho = {tctx $= (:< s), qctx $= (:< rho)}
|
||||
|
||||
export
|
||||
extendDim : TyContext d n -> TyContext (S d) n
|
||||
extendDim = {dctx $= DBind, tctx $= pushD}
|
||||
|
||||
export
|
||||
eqDim : Dim d -> Dim d -> TyContext d n -> TyContext d n
|
||||
eqDim p q = {dctx $= DEq p q}
|
||||
|
||||
|
||||
namespace QOutput
|
||||
export
|
||||
(+) : QOutput n -> QOutput n -> QOutput n
|
||||
(+) = zipWith (+)
|
||||
|
||||
export
|
||||
(*) : Qty -> QOutput n -> QOutput n
|
||||
(*) pi = map (pi *)
|
||||
|
||||
export
|
||||
zero : {n : Nat} -> QOutput n
|
||||
zero = pure Zero
|
||||
|
||||
|
||||
public export
|
||||
CheckResult : Nat -> Type
|
||||
CheckResult = QOutput
|
||||
|
||||
public export
|
||||
record InferResult d n where
|
||||
constructor InfRes
|
||||
type : Term d n
|
||||
qout : QOutput n
|
||||
|
||||
|
||||
public export
|
||||
data Error
|
||||
= NotInScope Name
|
||||
| ExpectedTYPE (Term d n)
|
||||
| ExpectedPi (Term d n)
|
||||
| BadUniverse Universe Universe
|
||||
| EqualError (Equal.Error)
|
||||
%hide Equal.Error
|
||||
Loading…
Add table
Add a link
Reference in a new issue