rhi/quox
rhi/quox
1
0
Fork 0
Code Issues 15 Pull requests 1 Releases Wiki Activity

parameterise over qty semiring

Browse source
This commit is contained in:
rhiannon morris 2023-01-08 20:44:25 +01:00
parent 961c8415b5
commit c45a963ba0
16 changed files with 712 additions and 491 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
exe/Main.idr
View file

@ -5,6 +5,7 @@ import public Quox.Syntax
import public Quox.Equal import public Quox.Equal
import public Quox.Pretty import public Quox.Pretty
import public Quox.Typechecker import public Quox.Typechecker
import public Quox.Syntax.Qty.Three
import Data.Nat import Data.Nat
import Data.Vect import Data.Vect
@ -53,7 +54,7 @@ banner : PrettyOpts -> String
banner opts = unlines $ zipWith (join1 opts) (qtuwu opts) (text opts) banner opts = unlines $ zipWith (join1 opts) (qtuwu opts) (text opts)
export export
tm : Term 1 2 tm : Term Three 1 2
tm = tm =
(Pi One "a" (BVT 0) (TUsed $ E (F "F" :@@ [BVT 0, FT "w"])) (Pi One "a" (BVT 0) (TUsed $ E (F "F" :@@ [BVT 0, FT "w"]))
`DCloT` (K One ::: id)) `DCloT` (K One ::: id))

55
lib/Quox/Definition.idr
View file

@ -2,49 +2,66 @@ module Quox.Definition
import public Quox.Syntax import public Quox.Syntax
import public Data.SortedMap import public Data.SortedMap
import public Control.Monad.State import public Control.Monad.Reader
import Decidable.Decidable
public export public export
record AnyTerm where record AnyTerm q where
constructor T constructor T
get : forall d, n. Term d n get : forall d, n. Term q d n
public export public export
record Definition where record Definition' q (isGlobal : q -> Type) where
constructor MkDef' constructor MkDef'
qty : Qty qty : q
type : AnyTerm type : AnyTerm q
term : Maybe AnyTerm term : Maybe $ AnyTerm q
{auto 0 qtyGlobal : IsGlobal qty} {auto 0 qtyGlobal : isGlobal qty}
public export
0 Definition : (q : Type) -> IsQty q => Type
Definition q = Definition' q IsGlobal
public export %inline public export %inline
mkDef : (qty : Qty) -> (0 _ : IsGlobal qty) => mkDef : IsQty q => (qty : q) -> (0 _ : IsGlobal qty) =>
(type, term : forall d, n. Term d n) -> Definition (type, term : forall d, n. Term q d n) -> Definition q
mkDef qty type term = MkDef' {qty, type = T type, term = Just (T term)} mkDef qty type term = MkDef' {qty, type = T type, term = Just (T term)}
public export %inline public export %inline
mkAbstract : (qty : Qty) -> (0 _ : IsGlobal qty) => mkAbstract : IsQty q => (qty : q) -> (0 _ : IsGlobal qty) =>
(type : forall d, n. Term d n) -> Definition (type : forall d, n. Term q d n) -> Definition q
mkAbstract qty type = MkDef' {qty, type = T type, term = Nothing} mkAbstract qty type = MkDef' {qty, type = T type, term = Nothing}
public export %inline public export %inline
(.type0) : Definition -> Term 0 0 (.type0) : Definition' q _ -> Term q 0 0
g.type0 = g.type.get g.type0 = g.type.get
public export %inline public export %inline
(.term0) : Definition -> Maybe (Term 0 0) (.term0) : Definition' q _ -> Maybe (Term q 0 0)
g.term0 = map (\t => t.get) g.term g.term0 = map (\t => t.get) g.term
public export %inline public export %inline
(.qtyP) : Definition -> Subset Qty IsGlobal (.qtyP) : forall q, isGlobal. Definition' q isGlobal -> Subset q isGlobal
g.qtyP = Element g.qty g.qtyGlobal g.qtyP = Element g.qty g.qtyGlobal
public export %inline public export %inline
isZero : Definition -> Bool isZero : IsQty q => Definition q -> Bool
isZero g = g.qty == Zero isZero g = isYes $ isZero g.qty
public export public export
Definitions : Type 0 Definitions' : (q : Type) -> (q -> Type) -> Type
Definitions = SortedMap Name Definition Definitions' q isGlobal = SortedMap Name $ Definition' q isGlobal
public export
0 Definitions : (q : Type) -> IsQty q => Type
Definitions q = Definitions' q IsGlobal
public export
0 HasDefs' : (q : Type) -> (q -> Type) -> (Type -> Type) -> Type
HasDefs' q isGlobal = MonadReader (Definitions' q isGlobal)
0 HasDefs : (q : Type) -> IsQty q => (Type -> Type) -> Type
HasDefs q = HasDefs' q IsGlobal

362
lib/Quox/Equal.idr
View file

@ -9,194 +9,228 @@ import Data.Maybe
private %inline private %inline
ClashE : EqMode -> Elim d n -> Elim d n -> Error ClashE : EqMode -> Elim q d n -> Elim q d n -> Error q
ClashE mode = ClashT mode `on` E ClashE mode = ClashT mode `on` E
public export public export
record Env where record Env' q (isGlobal : q -> Type) where
constructor MakeEnv constructor MakeEnv
defs : Definitions defs : Definitions' q isGlobal
mode : EqMode mode : EqMode
public export
0 Env : (q : Type) -> IsQty q => Type
Env q = Env' q IsGlobal
parameters {auto _ : MonadError Error m} {auto _ : MonadReader Env m} public export
private %inline 0 HasEnv' : (q : Type) -> (q -> Type) -> (Type -> Type) -> Type
mode : m EqMode HasEnv' q isGlobal = MonadReader (Env' q isGlobal)
mode = asks mode
private %inline public export
clashT : Term d n -> Term d n -> m a 0 HasEnv : (q : Type) -> IsQty q => (Type -> Type) -> Type
clashT s t = throwError $ ClashT !mode s t HasEnv q = HasEnv' q IsGlobal
private %inline
clashE : Elim d n -> Elim d n -> m a
clashE e f = throwError $ ClashE !mode e f
private %inline
defE : Name -> m (Maybe (Elim d n))
defE x = asks $ \env => do
g <- lookup x env.defs
pure $ (!g.term).get :# g.type.get
private %inline
defT : Name -> m (Maybe (Term d n))
defT x = map E <$> defE x
export %inline
compareU' : Universe -> Universe -> m Bool
compareU' i j = pure $
case !mode of Equal => i == j; Sub => i <= j
export %inline
compareU : Universe -> Universe -> m ()
compareU k l = unless !(compareU' k l) $
throwError $ ClashU !mode k l
mutual
private covering
compareTN' : (s, t : Term 0 n) ->
(0 _ : NotRedexT s) -> (0 _ : NotRedexT t) -> m ()
compareTN' (E e) (E f) ps pt = compareE0 e f
-- if either term is a def, try to unfold it
compareTN' s@(E (F x)) t ps pt = do
Just s' <- defT x | Nothing => clashT s t
compareT0 s' t
compareTN' s t@(E (F y)) ps pt = do
Just t' <- defT y | Nothing => clashT s t
compareT0 s t'
compareTN' s@(E _) t _ _ = clashT s t
compareTN' (TYPE k) (TYPE l) _ _ = compareU k l
compareTN' s@(TYPE _) t _ _ = clashT s t
compareTN' (Pi qty1 _ arg1 res1) (Pi qty2 _ arg2 res2) _ _ = do
unless (qty1 == qty2) $ throwError $ ClashQ qty1 qty2
compareT0 arg2 arg1 -- reversed for contravariant domain
compareTS0 res1 res2
compareTN' s@(Pi {}) t _ _ = clashT s t
-- [todo] eta
compareTN' (Lam _ body1) (Lam _ body2) _ _ =
local {mode := Equal} $ compareTS0 body1 body2
compareTN' s@(Lam {}) t _ _ = clashT s t
compareTN' (CloT {}) _ ps _ = void $ ps IsCloT
compareTN' (DCloT {}) _ ps _ = void $ ps IsDCloT
private covering
compareEN' : (e, f : Elim 0 n) ->
(0 _ : NotRedexE e) -> (0 _ : NotRedexE f) -> m ()
compareEN' e@(F x) f@(F y) _ _ =
if x == y then pure () else
case (!(defE x), !(defE y)) of
(Nothing, Nothing) => clashE e f
(s', t') => compareE0 (fromMaybe e s') (fromMaybe f t')
compareEN' e@(F x) f _ _ = do
Just e' <- defE x | Nothing => clashE e f
compareE0 e' f
compareEN' e f@(F y) _ _ = do
Just f' <- defE y | Nothing => clashE e f
compareE0 e f'
compareEN' e@(B i) f@(B j) _ _ =
unless (i == j) $ clashE e f
compareEN' e@(B _) f _ _ = clashE e f
-- [todo] tracking variance of functions? maybe???
-- probably not
compareEN' (fun1 :@ arg1) (fun2 :@ arg2) _ _ =
local {mode := Equal} $ do
compareE0 fun1 fun2
compareT0 arg1 arg2
compareEN' e@(_ :@ _) f _ _ = clashE e f
-- [todo] is always checking the types are equal correct?
compareEN' (tm1 :# ty1) (tm2 :# ty2) _ _ = do
compareT0 tm1 tm2
local {mode := Equal} $ compareT0 ty1 ty2
compareEN' e@(_ :# _) f _ _ = clashE e f
compareEN' (CloE {}) _ pe _ = void $ pe IsCloE
compareEN' (DCloE {}) _ pe _ = void $ pe IsDCloE
private covering %inline public export
compareTN : NonRedexTerm 0 n -> NonRedexTerm 0 n -> m () 0 CanEqual' : (q : Type) -> (q -> Type) -> (Type -> Type) -> Type
compareTN s t = compareTN' s.fst t.fst s.snd t.snd CanEqual' q isGlobal m = (HasErr q m, HasEnv' q isGlobal m)
private covering %inline public export
compareEN : NonRedexElim 0 n -> NonRedexElim 0 n -> m () 0 CanEqual : (q : Type) -> IsQty q => (Type -> Type) -> Type
compareEN e f = compareEN' e.fst f.fst e.snd f.snd CanEqual q = CanEqual' q IsGlobal
export covering %inline
compareT : DimEq d -> Term d n -> Term d n -> m ()
compareT eqs s t =
for_ (splits eqs) $ \th => compareT0 (s /// th) (t /// th)
export covering %inline private %inline
compareE : DimEq d -> Elim d n -> Elim d n -> m () mode : HasEnv' _ _ m => m EqMode
compareE eqs e f = mode = asks mode
for_ (splits eqs) $ \th => compareE0 (e /// th) (f /// th)
private %inline
clashT : CanEqual' q _ m => Term q d n -> Term q d n -> m a
clashT s t = throwError $ ClashT !mode s t
private %inline
clashE : CanEqual' q _ m => Elim q d n -> Elim q d n -> m a
clashE e f = throwError $ ClashE !mode e f
private %inline
defE : HasEnv' q _ m => Name -> m (Maybe (Elim q d n))
defE x = asks $ \env => do
g <- lookup x env.defs
pure $ (!g.term).get :# g.type.get
private %inline
defT : HasEnv' q _ m => Name -> m (Maybe (Term q d n))
defT x = map E <$> defE x
export %inline
compareU' : HasEnv' q _ m => Universe -> Universe -> m Bool
compareU' i j = pure $
case !mode of Equal => i == j; Sub => i <= j
export %inline
compareU : CanEqual' q _ m => Universe -> Universe -> m ()
compareU k l = unless !(compareU' k l) $
throwError $ ClashU !mode k l
mutual
private covering
compareTN' : CanEqual' q _ m => Eq q =>
(s, t : Term q 0 n) ->
(0 _ : NotRedexT s) -> (0 _ : NotRedexT t) -> m ()
compareTN' (E e) (E f) ps pt = compareE0 e f
-- if either term is a def, try to unfold it
compareTN' s@(E (F x)) t ps pt = do
Just s' <- defT x | Nothing => clashT s t
compareT0 s' t
compareTN' s t@(E (F y)) ps pt = do
Just t' <- defT y | Nothing => clashT s t
compareT0 s t'
compareTN' s@(E _) t _ _ = clashT s t
compareTN' (TYPE k) (TYPE l) _ _ = compareU k l
compareTN' s@(TYPE _) t _ _ = clashT s t
compareTN' (Pi qty1 _ arg1 res1) (Pi qty2 _ arg2 res2) _ _ = do
unless (qty1 == qty2) $ throwError $ ClashQ qty1 qty2
compareT0 arg2 arg1 -- reversed for contravariant domain
compareTS0 res1 res2
compareTN' s@(Pi {}) t _ _ = clashT s t
-- [todo] eta
compareTN' (Lam _ body1) (Lam _ body2) _ _ =
local {mode := Equal} $ compareTS0 body1 body2
compareTN' s@(Lam {}) t _ _ = clashT s t
compareTN' (CloT {}) _ ps _ = void $ ps IsCloT
compareTN' (DCloT {}) _ ps _ = void $ ps IsDCloT
private covering
compareEN' : CanEqual' q _ m => Eq q =>
(e, f : Elim q 0 n) ->
(0 _ : NotRedexE e) -> (0 _ : NotRedexE f) -> m ()
compareEN' e@(F x) f@(F y) _ _ =
if x == y then pure () else
case (!(defE x), !(defE y)) of
(Nothing, Nothing) => clashE e f
(s', t') => compareE0 (fromMaybe e s') (fromMaybe f t')
compareEN' e@(F x) f _ _ = do
Just e' <- defE x | Nothing => clashE e f
compareE0 e' f
compareEN' e f@(F y) _ _ = do
Just f' <- defE y | Nothing => clashE e f
compareE0 e f'
compareEN' e@(B i) f@(B j) _ _ =
unless (i == j) $ clashE e f
compareEN' e@(B _) f _ _ = clashE e f
-- [todo] tracking variance of functions? maybe???
-- probably not
compareEN' (fun1 :@ arg1) (fun2 :@ arg2) _ _ =
local {mode := Equal} $ do
compareE0 fun1 fun2
compareT0 arg1 arg2
compareEN' e@(_ :@ _) f _ _ = clashE e f
-- [todo] is always checking the types are equal correct?
compareEN' (tm1 :# ty1) (tm2 :# ty2) _ _ = do
compareT0 tm1 tm2
local {mode := Equal} $ compareT0 ty1 ty2
compareEN' e@(_ :# _) f _ _ = clashE e f
compareEN' (CloE {}) _ pe _ = void $ pe IsCloE
compareEN' (DCloE {}) _ pe _ = void $ pe IsDCloE
export covering %inline private covering %inline
compareT0 : Term 0 n -> Term 0 n -> m () compareTN : CanEqual' q _ m => Eq q =>
compareT0 s t = compareTN (whnfT s) (whnfT t) NonRedexTerm q 0 n -> NonRedexTerm q 0 n -> m ()
compareTN s t = compareTN' s.fst t.fst s.snd t.snd
export covering %inline private covering %inline
compareE0 : Elim 0 n -> Elim 0 n -> m () compareEN : CanEqual' q _ m => Eq q =>
compareE0 e f = compareEN (whnfE e) (whnfE f) NonRedexElim q 0 n -> NonRedexElim q 0 n -> m ()
compareEN e f = compareEN' e.fst f.fst e.snd f.snd
export covering %inline
compareTS0 : ScopeTerm 0 n -> ScopeTerm 0 n -> m ()
compareTS0 (TUnused body1) (TUnused body2) =
compareT0 body1 body2
compareTS0 body1 body2 =
compareT0 (fromScopeTerm body1) (fromScopeTerm body2)
parameters {auto _ : MonadError Error m} {auto _ : MonadReader Definitions m}
private %inline
into : EqMode ->
(forall n. MonadError Error n => MonadReader Env n =>
DimEq d -> a -> a -> n ()) ->
DimEq d -> a -> a -> m ()
into mode f eqs a b =
runReaderT {m} (MakeEnv {mode, defs = !ask}) $ f eqs a b
export covering %inline
equalTWith : DimEq d -> Term d n -> Term d n -> m ()
equalTWith = into Equal compareT
export covering %inline
equalEWith : DimEq d -> Elim d n -> Elim d n -> m ()
equalEWith = into Equal compareE
export covering %inline
subTWith : DimEq d -> Term d n -> Term d n -> m ()
subTWith = into Sub compareT
export covering %inline
subEWith : DimEq d -> Elim d n -> Elim d n -> m ()
subEWith = into Sub compareE
export covering %inline export covering %inline
equalT : {d : Nat} -> Term d n -> Term d n -> m () compareT : CanEqual' q _ m => Eq q =>
equalT = equalTWith DimEq.new DimEq d -> Term q d n -> Term q d n -> m ()
compareT eqs s t =
for_ (splits eqs) $ \th => compareT0 (s /// th) (t /// th)
export covering %inline export covering %inline
equalE : {d : Nat} -> Elim d n -> Elim d n -> m () compareE : CanEqual' q _ m => Eq q =>
equalE = equalEWith DimEq.new DimEq d -> Elim q d n -> Elim q d n -> m ()
compareE eqs e f =
for_ (splits eqs) $ \th => compareE0 (e /// th) (f /// th)
export covering %inline export covering %inline
subT : {d : Nat} -> Term d n -> Term d n -> m () compareT0 : CanEqual' q _ m => Eq q => Term q 0 n -> Term q 0 n -> m ()
subT = subTWith DimEq.new compareT0 s t = compareTN (whnfT s) (whnfT t)
export covering %inline export covering %inline
subE : {d : Nat} -> Elim d n -> Elim d n -> m () compareE0 : CanEqual' q _ m => Eq q => Elim q 0 n -> Elim q 0 n -> m ()
subE = subEWith DimEq.new compareE0 e f = compareEN (whnfE e) (whnfE f)
export covering %inline
compareTS0 : CanEqual' q _ m => Eq q =>
ScopeTerm q 0 n -> ScopeTerm q 0 n -> m ()
compareTS0 (TUnused body1) (TUnused body2) =
compareT0 body1 body2
compareTS0 body1 body2 =
compareT0 (fromScopeTerm body1) (fromScopeTerm body2)
private %inline
into : HasErr q m => HasDefs' q isg m => Eq q =>
(forall n. HasErr q n => HasEnv' q isg n => d -> a -> a -> n ()) ->
EqMode -> d -> a -> a -> m ()
into f mode eqs a b =
runReaderT {m} (MakeEnv {mode, defs = !ask}) $ f eqs a b
export covering %inline
equalTWith : HasErr q m => HasDefs' q _ m => Eq q =>
DimEq d -> Term q d n -> Term q d n -> m ()
equalTWith = into compareT Equal
export covering %inline
equalEWith : HasErr q m => HasDefs' q _ m => Eq q =>
DimEq d -> Elim q d n -> Elim q d n -> m ()
equalEWith = into compareE Equal
export covering %inline
subTWith : HasErr q m => HasDefs' q _ m => Eq q =>
DimEq d -> Term q d n -> Term q d n -> m ()
subTWith = into compareT Sub
export covering %inline
subEWith : HasErr q m => HasDefs' q _ m => Eq q =>
DimEq d -> Elim q d n -> Elim q d n -> m ()
subEWith = into compareE Sub
export covering %inline
equalT : HasErr q m => HasDefs' q _ m => Eq q =>
{d : Nat} -> Term q d n -> Term q d n -> m ()
equalT = equalTWith DimEq.new
export covering %inline
equalE : HasErr q m => HasDefs' q _ m => Eq q =>
{d : Nat} -> Elim q d n -> Elim q d n -> m ()
equalE = equalEWith DimEq.new
export covering %inline
subT : HasErr q m => HasDefs' q _ m => Eq q =>
{d : Nat} -> Term q d n -> Term q d n -> m ()
subT = subTWith DimEq.new
export covering %inline
subE : HasErr q m => HasDefs' q _ m => Eq q =>
{d : Nat} -> Elim q d n -> Elim q d n -> m ()
subE = subEWith DimEq.new

110
lib/Quox/Syntax/Qty.idr
View file

@ -1,84 +1,78 @@
module Quox.Syntax.Qty module Quox.Syntax.Qty
import Quox.Pretty import Quox.Pretty
import Data.DPair
import Data.Fin
import Generics.Derive
%default total %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 private
commas : List (Doc HL) -> List (Doc HL) commas : List (Doc HL) -> List (Doc HL)
commas [] = [] commas [] = []
commas [x] = [x] commas [x] = [x]
commas (x::xs) = (x <+> hl Delim ",") :: commas xs commas (x::xs) = (x <+> hl Delim ",") :: commas xs
export %inline export %inline
prettyQtyBinds : Pretty.HasEnv m => List Qty -> m (Doc HL) prettyQtyBinds : Pretty.HasEnv m => PrettyHL q =>
List q -> m (Doc HL)
prettyQtyBinds = prettyQtyBinds =
map ((hl Delim "@" <++>) . align . sep . commas) . traverse pretty0M map ((hl Delim "@" <++>) . align . sep . commas) . traverse pretty0M
public export public export
plus : Qty -> Qty -> Qty interface Eq q => IsQty q where
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 zero, one : q
(+), (*) : q -> q -> q (+), (*) : q -> q -> q
(<=.) : q -> q -> Bool
||| true if bindings of this quantity will be erased
||| and must not be runtime relevant
IsZero : q -> Type
isZero : (pi : q) -> Dec (IsZero pi)
zeroIsZero : IsZero zero
||| true if bindings of this quantity must be linear
-- [fixme] is this needed for anything?
IsOne : q -> Type
isOne : (pi : q) -> Dec (IsOne pi)
oneIsOne : IsOne one
||| ``p `Compat` q`` if it is ok for a binding of
||| quantity `q` to be used exactly `p` times.
||| e.g. ``1 `Compat` 1``, ``1 `Compat` ω``
Compat : q -> q -> Type
compat : (pi, rh : q) -> Dec (pi `Compat` rh)
||| true if it is ok for this quantity to appear for the
||| subject of a typing judgement. this is about the
||| subject reduction stuff in atkey
IsSubj : q -> Type
isSubj : (pi : q) -> Dec (IsSubj pi)
zeroIsSubj : IsSubj zero
oneIsSubj : IsSubj one
||| true if it is ok for a global definition to have this
||| quantity. so not exact usage counts, maybe.
IsGlobal : q -> Type
isGlobal : (pi : q) -> Dec (IsGlobal pi)
zeroIsGlobal : IsGlobal zero
public export public export
IsQty Qty where 0 SQty : (q : Type) -> IsQty q => Type
zero = Zero; one = One SQty q = Subset q IsSubj
(+) = plus; (*) = times
(<=.) = compat
public export %inline
szero : IsQty q => SQty q
szero = Element zero zeroIsSubj
public export %inline
sone : IsQty q => SQty q
sone = Element one oneIsSubj
public export public export
data IsSubj : Qty -> Type where 0 GQty : (q : Type) -> IsQty q => Type
SZero : IsSubj Zero GQty q = Subset q IsGlobal
SOne : IsSubj One
export Uninhabited (IsSubj Any) where uninhabited _ impossible public export %inline
gzero : IsQty q => GQty q
gzero = Element zero zeroIsGlobal
public export
data IsGlobal : Qty -> Type where
GZero : IsGlobal Zero
GAny : IsGlobal Any
export Uninhabited (IsGlobal One) where uninhabited _ impossible

111
lib/Quox/Syntax/Qty/Three.idr Normal file
View file

@ -0,0 +1,111 @@
module Quox.Syntax.Qty.Three
import Quox.Pretty
import public Quox.Syntax.Qty
import Generics.Derive
%default total
%language ElabReflection
public export
data Three = Zero | One | Any
%name Three pi, rh
%runElab derive "Three" [Generic, Meta, Eq, Ord, DecEq, Show]
export
PrettyHL Three where
prettyM pi = hl Qty <$>
case pi of
Zero => ifUnicode "𝟬" "0"
One => ifUnicode "𝟭" "1"
Any => ifUnicode "𝛚" "*"
public export
plus : Three -> Three -> Three
plus Zero rh = rh
plus pi Zero = pi
plus _ _ = Any
public export
times : Three -> Three -> Three
times Zero _ = Zero
times _ Zero = Zero
times One rh = rh
times pi One = pi
times Any Any = Any
public export
data Compat3 : Three -> Three -> Type where
CmpRefl : Compat3 pi pi
CmpAny : Compat3 pi Any
public export
compat3 : (pi, rh : Three) -> Dec (pi `Compat3` rh)
compat3 pi rh with (decEq pi rh)
compat3 pi pi | Yes Refl = Yes CmpRefl
compat3 pi rh | No ne with (decEq rh Any)
compat3 pi Any | No ne | Yes Refl = Yes CmpAny
compat3 pi rh | No ne | No na = No $ \case
CmpRefl => ne Refl
CmpAny => na Refl
public export
data IsSubj3 : Three -> Type where
SZero : IsSubj3 Zero
SOne : IsSubj3 One
public export
isSubj3 : (pi : Three) -> Dec (IsSubj3 pi)
isSubj3 Zero = Yes SZero
isSubj3 One = Yes SOne
isSubj3 Any = No $ \case _ impossible
public export
data IsGlobal3 : Three -> Type where
GZero : IsGlobal3 Zero
GAny : IsGlobal3 Any
isGlobal3 : (pi : Three) -> Dec (IsGlobal3 pi)
isGlobal3 Zero = Yes GZero
isGlobal3 One = No $ \case _ impossible
isGlobal3 Any = Yes GAny
public export
IsQty Three where
zero = Zero
one = One
(+) = plus
(*) = times
IsZero = Equal Zero
isZero = decEq Zero
zeroIsZero = Refl
IsOne = Equal One
isOne = decEq One
oneIsOne = Refl
Compat = Compat3
compat = compat3
IsSubj = IsSubj3
isSubj = isSubj3
zeroIsSubj = SZero
oneIsSubj = SOne
IsGlobal = IsGlobal3
isGlobal = isGlobal3
zeroIsGlobal = GZero
export Uninhabited (IsGlobal3 One) where uninhabited _ impossible
export Uninhabited (IsSubj3 Any) where uninhabited _ impossible

58
lib/Quox/Syntax/Term/Base.idr
View file

@ -26,63 +26,67 @@ infixl 8 :#
infixl 9 :@ infixl 9 :@
mutual mutual
public export public export
TSubst : Nat -> Nat -> Nat -> Type TSubst : Type -> Nat -> Nat -> Nat -> Type
TSubst d = Subst (\n => Elim d n) TSubst q d = Subst (\n => Elim q d n)
||| first argument `d` is dimension scope size, second `n` is term scope size ||| first argument `d` is dimension scope size, second `n` is term scope size
public export public export
data Term : (d, n : Nat) -> Type where data Term : (q : Type) -> (d, n : Nat) -> Type where
||| type of types ||| type of types
TYPE : (l : Universe) -> Term d n TYPE : (l : Universe) -> Term q d n
||| function type ||| function type
Pi : (qty : Qty) -> (x : Name) -> Pi : (qty : q) -> (x : Name) ->
(arg : Term d n) -> (res : ScopeTerm d n) -> Term d n (arg : Term q d n) -> (res : ScopeTerm q d n) -> Term q d n
||| function term ||| function term
Lam : (x : Name) -> (body : ScopeTerm d n) -> Term d n Lam : (x : Name) -> (body : ScopeTerm q d n) -> Term q d n
||| elimination ||| elimination
E : (e : Elim d n) -> Term d n E : (e : Elim q d n) -> Term q d n
||| term closure/suspended substitution ||| term closure/suspended substitution
CloT : (tm : Term d from) -> (th : Lazy (TSubst d from to)) -> Term d to CloT : (tm : Term q d from) -> (th : Lazy (TSubst q d from to)) ->
Term q d to
||| dimension closure/suspended substitution ||| dimension closure/suspended substitution
DCloT : (tm : Term dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Term dto n DCloT : (tm : Term q dfrom n) -> (th : Lazy (DSubst dfrom dto)) ->
Term q dto n
||| first argument `d` is dimension scope size, second `n` is term scope size ||| first argument `d` is dimension scope size, second `n` is term scope size
public export public export
data Elim : (d, n : Nat) -> Type where data Elim : (q : Type) -> (d, n : Nat) -> Type where
||| free variable ||| free variable
F : (x : Name) -> Elim d n F : (x : Name) -> Elim q d n
||| bound variable ||| bound variable
B : (i : Var n) -> Elim d n B : (i : Var n) -> Elim q d n
||| term application ||| term application
(:@) : (fun : Elim d n) -> (arg : Term d n) -> Elim d n (:@) : (fun : Elim q d n) -> (arg : Term q d n) -> Elim q d n
||| type-annotated term ||| type-annotated term
(:#) : (tm, ty : Term d n) -> Elim d n (:#) : (tm, ty : Term q d n) -> Elim q d n
||| term closure/suspended substitution ||| term closure/suspended substitution
CloE : (el : Elim d from) -> (th : Lazy (TSubst d from to)) -> Elim d to CloE : (el : Elim q d from) -> (th : Lazy (TSubst q d from to)) ->
Elim q d to
||| dimension closure/suspended substitution ||| dimension closure/suspended substitution
DCloE : (el : Elim dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Elim dto n DCloE : (el : Elim q dfrom n) -> (th : Lazy (DSubst dfrom dto)) ->
Elim q dto n
||| a scope with one more bound variable ||| a scope with one more bound variable
public export public export
data ScopeTerm : (d, n : Nat) -> Type where data ScopeTerm : (q : Type) -> (d, n : Nat) -> Type where
||| variable is used ||| variable is used
TUsed : (body : Term d (S n)) -> ScopeTerm d n TUsed : (body : Term q d (S n)) -> ScopeTerm q d n
||| variable is unused ||| variable is unused
TUnused : (body : Term d n) -> ScopeTerm d n TUnused : (body : Term q d n) -> ScopeTerm q d n
||| a scope with one more bound dimension variable ||| a scope with one more bound dimension variable
public export public export
data DScopeTerm : (d, n : Nat) -> Type where data DScopeTerm : (q : Type) -> (d, n : Nat) -> Type where
||| variable is used ||| variable is used
DUsed : (body : Term (S d) n) -> DScopeTerm d n DUsed : (body : Term q (S d) n) -> DScopeTerm q d n
||| variable is unused ||| variable is unused
DUnused : (body : Term d n) -> DScopeTerm d n DUnused : (body : Term q d n) -> DScopeTerm q d n
%name Term s, t, r %name Term s, t, r
%name Elim e, f %name Elim e, f
@ -90,21 +94,21 @@ mutual
%name DScopeTerm body %name DScopeTerm body
public export %inline public export %inline
Arr : (qty : Qty) -> (arg, res : Term d n) -> Term d n Arr : (qty : q) -> (arg, res : Term q d n) -> Term q d n
Arr {qty, arg, res} = Pi {qty, x = "_", arg, res = TUnused res} Arr {qty, arg, res} = Pi {qty, x = "_", arg, res = TUnused res}
||| same as `F` but as a term ||| same as `F` but as a term
public export %inline public export %inline
FT : Name -> Term d n FT : Name -> Term q d n
FT = E . F FT = E . F
||| abbreviation for a bound variable like `BV 4` instead of ||| abbreviation for a bound variable like `BV 4` instead of
||| `B (VS (VS (VS (VS VZ))))` ||| `B (VS (VS (VS (VS VZ))))`
public export %inline public export %inline
BV : (i : Nat) -> (0 _ : LT i n) => Elim d n BV : (i : Nat) -> (0 _ : LT i n) => Elim q d n
BV i = B $ V i BV i = B $ V i
||| same as `BV` but as a term ||| same as `BV` but as a term
public export %inline public export %inline
BVT : (i : Nat) -> (0 _ : LT i n) => Term d n BVT : (i : Nat) -> (0 _ : LT i n) => Term q d n
BVT i = E $ BV i BVT i = E $ BV i

12
lib/Quox/Syntax/Term/Pretty.idr
View file

@ -28,7 +28,7 @@ colonD = hl Syntax ":"
mutual mutual
export covering export covering
PrettyHL (Term d n) where PrettyHL q => PrettyHL (Term q d n) where
prettyM (TYPE l) = prettyM (TYPE l) =
parensIfM App $ typeD <//> !(withPrec Arg $ prettyM l) parensIfM App $ typeD <//> !(withPrec Arg $ prettyM l)
prettyM (Pi qty x s t) = prettyM (Pi qty x s t) =
@ -49,7 +49,7 @@ mutual
[|withPrec SApp (prettyM s) </> prettyDSubst th|] [|withPrec SApp (prettyM s) </> prettyDSubst th|]
export covering export covering
PrettyHL (Elim d n) where PrettyHL q => PrettyHL (Elim q d n) where
prettyM (F x) = prettyM (F x) =
hl' Free <$> prettyM x hl' Free <$> prettyM x
prettyM (B i) = prettyM (B i) =
@ -70,15 +70,17 @@ mutual
[|withPrec SApp (prettyM e) </> prettyDSubst th|] [|withPrec SApp (prettyM e) </> prettyDSubst th|]
export covering export covering
PrettyHL (ScopeTerm d n) where PrettyHL q => PrettyHL (ScopeTerm q d n) where
prettyM body = prettyM $ fromScopeTerm body prettyM body = prettyM $ fromScopeTerm body
export covering export covering
prettyTSubst : Pretty.HasEnv m => TSubst d from to -> m (Doc HL) prettyTSubst : Pretty.HasEnv m => PrettyHL q =>
TSubst q d from to -> m (Doc HL)
prettyTSubst s = prettySubstM prettyM (!ask).tnames TVar "[" "]" s prettyTSubst s = prettySubstM prettyM (!ask).tnames TVar "[" "]" s
export covering export covering
prettyBinder : Pretty.HasEnv m => List Qty -> Name -> Term d n -> m (Doc HL) prettyBinder : Pretty.HasEnv m => PrettyHL q =>
List q -> Name -> Term q d n -> m (Doc HL)
prettyBinder pis x a = prettyBinder pis x a =
pure $ parens $ hang 2 $ pure $ parens $ hang 2 $
hsep [hl TVar !(prettyM x), hsep [hl TVar !(prettyM x),

141
lib/Quox/Syntax/Term/Reduce.idr
View file

@ -7,43 +7,57 @@ import Quox.Syntax.Term.Subst
mutual mutual
||| true if a term has a closure or dimension closure at the top level, public export
||| or is `E` applied to such an elimination data NotCloT : Term {} -> Type where
public export %inline NCTYPE : NotCloT $ TYPE _
topCloT : Term d n -> Bool NCPi : NotCloT $ Pi {}
topCloT (CloT _ _) = True NCLam : NotCloT $ Lam {}
topCloT (DCloT _ _) = True NCE : NotCloE e -> NotCloT $ E e
topCloT (E e) = topCloE e
topCloT _ = False
||| true if an elimination has a closure or dimension closure at the top level public export
public export %inline data NotCloE : Elim {} -> Type where
topCloE : Elim d n -> Bool NCF : NotCloE $ F _
topCloE (CloE _ _) = True NCB : NotCloE $ B _
topCloE (DCloE _ _) = True NCApp : NotCloE $ _ :@ _
topCloE _ = False NCAnn : NotCloE $ _ :# _
mutual
export
notCloT : (t : Term {}) -> Dec (NotCloT t)
notCloT (TYPE _) = Yes NCTYPE
notCloT (Pi {}) = Yes NCPi
notCloT (Lam {}) = Yes NCLam
notCloT (E e) with (notCloE e)
notCloT (E e) | Yes nc = Yes $ NCE nc
notCloT (E e) | No c = No $ \case NCE nc => c nc
notCloT (CloT {}) = No $ \case _ impossible
notCloT (DCloT {}) = No $ \case _ impossible
public export IsNotCloT : Term d n -> Type export
IsNotCloT = So . not . topCloT notCloE : (e : Elim {}) -> Dec (NotCloE e)
notCloE (F _) = Yes NCF
notCloE (B _) = Yes NCB
notCloE (_ :@ _) = Yes NCApp
notCloE (_ :# _) = Yes NCAnn
notCloE (CloE {}) = No $ \case _ impossible
notCloE (DCloE {}) = No $ \case _ impossible
||| a term which is not a top level closure ||| a term which is not a top level closure
public export NotCloTerm : Nat -> Nat -> Type public export
NotCloTerm d n = Subset (Term d n) IsNotCloT NotCloTerm : Type -> Nat -> Nat -> Type
NotCloTerm q d n = Subset (Term q d n) NotCloT
public export IsNotCloE : Elim d n -> Type
IsNotCloE = So . not . topCloE
||| an elimination which is not a top level closure ||| an elimination which is not a top level closure
public export NotCloElim : Nat -> Nat -> Type public export
NotCloElim d n = Subset (Elim d n) IsNotCloE NotCloElim : Type -> Nat -> Nat -> Type
NotCloElim q d n = Subset (Elim q d n) NotCloE
public export %inline public export %inline
ncloT : (t : Term d n) -> (0 _ : IsNotCloT t) => NotCloTerm d n ncloT : (t : Term q d n) -> (0 _ : NotCloT t) => NotCloTerm q d n
ncloT t @{p} = Element t p ncloT t @{p} = Element t p
public export %inline public export %inline
ncloE : (t : Elim d n) -> (0 _ : IsNotCloE t) => NotCloElim d n ncloE : (e : Elim q d n) -> (0 _ : NotCloE e) => NotCloElim q d n
ncloE e @{p} = Element e p ncloE e @{p} = Element e p
@ -52,18 +66,18 @@ mutual
||| if the input term has any top-level closures, push them under one layer of ||| if the input term has any top-level closures, push them under one layer of
||| syntax ||| syntax
export %inline export %inline
pushSubstsT : Term d n -> NotCloTerm d n pushSubstsT : Term q d n -> NotCloTerm q d n
pushSubstsT s = pushSubstsTWith id id s pushSubstsT s = pushSubstsTWith id id s
||| if the input elimination has any top-level closures, push them under one ||| if the input elimination has any top-level closures, push them under one
||| layer of syntax ||| layer of syntax
export %inline export %inline
pushSubstsE : Elim d n -> NotCloElim d n pushSubstsE : Elim q d n -> NotCloElim q d n
pushSubstsE e = pushSubstsEWith id id e pushSubstsE e = pushSubstsEWith id id e
export export
pushSubstsTWith : DSubst dfrom dto -> TSubst dto from to -> pushSubstsTWith : DSubst dfrom dto -> TSubst q dto from to ->
Term dfrom from -> NotCloTerm dto to Term q dfrom from -> NotCloTerm q dto to
pushSubstsTWith th ph (TYPE l) = pushSubstsTWith th ph (TYPE l) =
ncloT $ TYPE l ncloT $ TYPE l
pushSubstsTWith th ph (Pi qty x a body) = pushSubstsTWith th ph (Pi qty x a body) =
@ -78,15 +92,15 @@ mutual
pushSubstsTWith (ps . th) ph s pushSubstsTWith (ps . th) ph s
export export
pushSubstsEWith : DSubst dfrom dto -> TSubst dto from to -> pushSubstsEWith : DSubst dfrom dto -> TSubst q dto from to ->
Elim dfrom from -> NotCloElim dto to Elim q dfrom from -> NotCloElim q dto to
pushSubstsEWith th ph (F x) = pushSubstsEWith th ph (F x) =
ncloE $ F x ncloE $ F x
pushSubstsEWith th ph (B i) = pushSubstsEWith th ph (B i) =
let res = ph !! i in let res = ph !! i in
case choose $ topCloE res of case notCloE res of
Left _ => assert_total pushSubstsE res Yes _ => ncloE res
Right _ => ncloE res No _ => assert_total pushSubstsE res
pushSubstsEWith th ph (f :@ s) = pushSubstsEWith th ph (f :@ s) =
ncloE $ subs f th ph :@ subs s th ph ncloE $ subs f th ph :@ subs s th ph
pushSubstsEWith th ph (s :# a) = pushSubstsEWith th ph (s :# a) =
@ -97,22 +111,22 @@ mutual
pushSubstsEWith (ps . th) ph e pushSubstsEWith (ps . th) ph e
parameters (th : DSubst dfrom dto) (ph : TSubst dto from to) parameters (th : DSubst dfrom dto) (ph : TSubst q dto from to)
public export %inline public export %inline
pushSubstsTWith' : Term dfrom from -> Term dto to pushSubstsTWith' : Term q dfrom from -> Term q dto to
pushSubstsTWith' s = (pushSubstsTWith th ph s).fst pushSubstsTWith' s = (pushSubstsTWith th ph s).fst
public export %inline public export %inline
pushSubstsEWith' : Elim dfrom from -> Elim dto to pushSubstsEWith' : Elim q dfrom from -> Elim q dto to
pushSubstsEWith' e = (pushSubstsEWith th ph e).fst pushSubstsEWith' e = (pushSubstsEWith th ph e).fst
public export %inline public export %inline
pushSubstsT' : Term d n -> Term d n pushSubstsT' : Term q d n -> Term q d n
pushSubstsT' s = (pushSubstsT s).fst pushSubstsT' s = (pushSubstsT s).fst
public export %inline public export %inline
pushSubstsE' : Elim d n -> Elim d n pushSubstsE' : Elim q d n -> Elim q d n
pushSubstsE' e = (pushSubstsE e).fst pushSubstsE' e = (pushSubstsE e).fst
@ -159,41 +173,41 @@ pushSubstsE' e = (pushSubstsE e).fst
public export %inline public export %inline
weakT : Term d n -> Term d (S n) weakT : Term q d n -> Term q d (S n)
weakT t = t //. shift 1 weakT t = t //. shift 1
public export %inline public export %inline
weakE : Elim d n -> Elim d (S n) weakE : Elim q d n -> Elim q d (S n)
weakE t = t //. shift 1 weakE t = t //. shift 1
mutual mutual
public export public export
data IsRedexT : Term d n -> Type where data IsRedexT : Term q d n -> Type where
IsUpsilonT : IsRedexT $ E (_ :# _) IsUpsilonT : IsRedexT $ E (_ :# _)
IsCloT : IsRedexT $ CloT {} IsCloT : IsRedexT $ CloT {}
IsDCloT : IsRedexT $ DCloT {} IsDCloT : IsRedexT $ DCloT {}
IsERedex : IsRedexE e -> IsRedexT $ E e IsERedex : IsRedexE e -> IsRedexT $ E e
public export %inline public export %inline
NotRedexT : Term d n -> Type NotRedexT : Term q d n -> Type
NotRedexT = Not . IsRedexT NotRedexT = Not . IsRedexT
public export public export
data IsRedexE : Elim d n -> Type where data IsRedexE : Elim q d n -> Type where
IsUpsilonE : IsRedexE $ E _ :# _ IsUpsilonE : IsRedexE $ E _ :# _
IsBetaLam : IsRedexE $ (Lam {} :# Pi {}) :@ _ IsBetaLam : IsRedexE $ (Lam {} :# Pi {}) :@ _
IsCloE : IsRedexE $ CloE {} IsCloE : IsRedexE $ CloE {}
IsDCloE : IsRedexE $ DCloE {} IsDCloE : IsRedexE $ DCloE {}
public export %inline public export %inline
NotRedexE : Elim d n -> Type NotRedexE : Elim q d n -> Type
NotRedexE = Not . IsRedexE NotRedexE = Not . IsRedexE
mutual mutual
export %inline export %inline
isRedexT : (t : Term d n) -> Dec (IsRedexT t) isRedexT : (t : Term {}) -> Dec (IsRedexT t)
isRedexT (E (tm :# ty)) = Yes IsUpsilonT isRedexT (E (tm :# ty)) = Yes IsUpsilonT
isRedexT (CloT {}) = Yes IsCloT isRedexT (CloT {}) = Yes IsCloT
isRedexT (DCloT {}) = Yes IsDCloT isRedexT (DCloT {}) = Yes IsDCloT
@ -201,7 +215,7 @@ mutual
isRedexT (E (DCloE {})) = Yes $ IsERedex IsDCloE isRedexT (E (DCloE {})) = Yes $ IsERedex IsDCloE
isRedexT (E e@(_ :@ _)) with (isRedexE e) isRedexT (E e@(_ :@ _)) with (isRedexE e)
_ | Yes yes = Yes $ IsERedex yes _ | Yes yes = Yes $ IsERedex yes
_ | No no = No \case IsERedex p => no p _ | No no = No $ \case IsERedex p => no p
isRedexT (TYPE {}) = No $ \case _ impossible isRedexT (TYPE {}) = No $ \case _ impossible
isRedexT (Pi {}) = No $ \case _ impossible isRedexT (Pi {}) = No $ \case _ impossible
isRedexT (Lam {}) = No $ \case _ impossible isRedexT (Lam {}) = No $ \case _ impossible
@ -209,7 +223,7 @@ mutual
isRedexT (E (B _)) = No $ \case IsERedex _ impossible isRedexT (E (B _)) = No $ \case IsERedex _ impossible
export %inline export %inline
isRedexE : (e : Elim d n) -> Dec (IsRedexE e) isRedexE : (e : Elim {}) -> Dec (IsRedexE e)
isRedexE (E _ :# _) = Yes IsUpsilonE isRedexE (E _ :# _) = Yes IsUpsilonE
isRedexE ((Lam {} :# Pi {}) :@ _) = Yes IsBetaLam isRedexE ((Lam {} :# Pi {}) :@ _) = Yes IsBetaLam
isRedexE (CloE {}) = Yes IsCloE isRedexE (CloE {}) = Yes IsCloE
@ -239,39 +253,38 @@ mutual
public export %inline public export %inline
RedexTerm : Nat -> Nat -> Type RedexTerm : Type -> Nat -> Nat -> Type
RedexTerm d n = Subset (Term d n) IsRedexT RedexTerm q d n = Subset (Term q d n) IsRedexT
public export %inline public export %inline
NonRedexTerm : Nat -> Nat -> Type NonRedexTerm : Type -> Nat -> Nat -> Type
NonRedexTerm d n = Subset (Term d n) NotRedexT NonRedexTerm q d n = Subset (Term q d n) NotRedexT
public export %inline public export %inline
RedexElim : Nat -> Nat -> Type RedexElim : Type -> Nat -> Nat -> Type
RedexElim d n = Subset (Elim d n) IsRedexE RedexElim q d n = Subset (Elim q d n) IsRedexE
public export %inline public export %inline
NonRedexElim : Nat -> Nat -> Type NonRedexElim : Type -> Nat -> Nat -> Type
NonRedexElim d n = Subset (Elim d n) NotRedexE NonRedexElim q d n = Subset (Elim q d n) NotRedexE
||| substitute a term with annotation for the bound variable of a `ScopeTerm` ||| substitute a term with annotation for the bound variable of a `ScopeTerm`
export %inline export %inline
substScope : (arg, argTy : Term d n) -> (body : ScopeTerm d n) -> Term d n substScope : (arg, argTy : Term q d n) -> (body : ScopeTerm q d n) -> Term q d n
substScope arg argTy (TUsed body) = body // one (arg :# argTy) substScope arg argTy (TUsed body) = body // one (arg :# argTy)
substScope arg argTy (TUnused body) = body substScope arg argTy (TUnused body) = body
mutual mutual
export %inline export %inline
stepT' : (s : Term d n) -> IsRedexT s -> Term d n stepT' : (s : Term q d n) -> IsRedexT s -> Term q d n
stepT' (E (s :# _)) IsUpsilonT = s stepT' (E (s :# _)) IsUpsilonT = s
stepT' (CloT s th) IsCloT = pushSubstsTWith' id th s stepT' (CloT s th) IsCloT = pushSubstsTWith' id th s
stepT' (DCloT s th) IsDCloT = pushSubstsTWith' th id s stepT' (DCloT s th) IsDCloT = pushSubstsTWith' th id s
stepT' (E e) (IsERedex p) = E $ stepE' e p stepT' (E e) (IsERedex p) = E $ stepE' e p
export %inline export %inline
stepE' : (e : Elim d n) -> IsRedexE e -> Elim d n stepE' : (e : Elim q d n) -> IsRedexE e -> Elim q d n
stepE' (E e :# _) IsUpsilonE = e stepE' (E e :# _) IsUpsilonE = e
stepE' ((Lam {body, _} :# Pi {arg, res, _}) :@ s) IsBetaLam = stepE' ((Lam {body, _} :# Pi {arg, res, _}) :@ s) IsBetaLam =
substScope s arg body :# substScope s arg res substScope s arg body :# substScope s arg res
@ -279,21 +292,21 @@ mutual
stepE' (DCloE e th) IsDCloE = pushSubstsEWith' th id e stepE' (DCloE e th) IsDCloE = pushSubstsEWith' th id e
export %inline export %inline
stepT : (s : Term d n) -> Either (NotRedexT s) (Term d n) stepT : (s : Term q d n) -> Either (NotRedexT s) (Term q d n)
stepT s = case isRedexT s of Yes y => Right $ stepT' s y; No n => Left n stepT s = case isRedexT s of Yes y => Right $ stepT' s y; No n => Left n
export %inline export %inline
stepE : (e : Elim d n) -> Either (NotRedexE e) (Elim d n) stepE : (e : Elim q d n) -> Either (NotRedexE e) (Elim q d n)
stepE e = case isRedexE e of Yes y => Right $ stepE' e y; No n => Left n stepE e = case isRedexE e of Yes y => Right $ stepE' e y; No n => Left n
export covering export covering
whnfT : Term d n -> NonRedexTerm d n whnfT : Term q d n -> NonRedexTerm q d n
whnfT s = case stepT s of whnfT s = case stepT s of
Right s' => whnfT s' Right s' => whnfT s'
Left done => Element s done Left done => Element s done
export covering export covering
whnfE : Elim d n -> NonRedexElim d n whnfE : Elim q d n -> NonRedexElim q d n
whnfE e = case stepE e of whnfE e = case stepE e of
Right e' => whnfE e' Right e' => whnfE e'
Left done => Element e done Left done => Element e done

102
lib/Quox/Syntax/Term/Split.idr
View file

@ -9,74 +9,100 @@ import Data.Vect
%default total %default total
public export %inline
isLam : Term d n -> Bool
isLam (Lam {}) = True
isLam _ = False
public export public export
NotLam : Term d n -> Type data IsLam : Term {} -> Type where
NotLam = So . not . isLam ItIsLam : IsLam $ Lam x body
public export %inline public export %inline
isApp : Elim d n -> Bool isLam : (s : Term {}) -> Dec (IsLam s)
isApp ((:@) {}) = True isLam (TYPE _) = No $ \case _ impossible
isApp _ = False isLam (Pi {}) = No $ \case _ impossible
isLam (Lam {}) = Yes ItIsLam
isLam (E _) = No $ \case _ impossible
isLam (CloT {}) = No $ \case _ impossible
isLam (DCloT {}) = No $ \case _ impossible
public export %inline
NotLam : Term {} -> Type
NotLam = Not . IsLam
public export public export
NotApp : Elim d n -> Type data IsApp : Elim {} -> Type where
NotApp = So . not . isApp ItIsApp : IsApp $ f :@ s
public export %inline
isApp : (e : Elim {}) -> Dec (IsApp e)
isApp (F _) = No $ \case _ impossible
isApp (B _) = No $ \case _ impossible
isApp (_ :@ _) = Yes ItIsApp
isApp (_ :# _) = No $ \case _ impossible
isApp (CloE {}) = No $ \case _ impossible
isApp (DCloE {}) = No $ \case _ impossible
public export
NotApp : Elim {} -> Type
NotApp = Not . IsApp
infixl 9 :@@ infixl 9 :@@
||| apply multiple arguments at once ||| apply multiple arguments at once
public export %inline public export %inline
(:@@) : Elim d n -> List (Term d n) -> Elim d n (:@@) : Elim q d n -> List (Term q d n) -> Elim q d n
f :@@ ss = foldl (:@) f ss f :@@ ss = foldl (:@) f ss
public export public export
record GetArgs (d, n : Nat) where record GetArgs q d n where
constructor GotArgs constructor GotArgs
fun : Elim d n fun : Elim q d n
args : List (Term d n) args : List (Term q d n)
0 notApp : NotApp fun 0 notApp : NotApp fun
export export
getArgs' : Elim d n -> List (Term d n) -> GetArgs d n getArgs' : Elim q d n -> List (Term q d n) -> GetArgs q d n
getArgs' fun args with (choose $ isApp fun) getArgs' fun args with (isApp fun)
getArgs' (f :@ a) args | Left yes = getArgs' f (a :: args) getArgs' (f :@ a) args | Yes yes = getArgs' f (a :: args)
_ | Right no = GotArgs {fun, args, notApp = no} getArgs' fun args | No no = GotArgs {fun, args, notApp = no}
||| splits an application into its head and arguments. if it's not an ||| splits an application into its head and arguments. if it's not an
||| application then the list is just empty ||| application then the list is just empty
export %inline export %inline
getArgs : Elim d n -> GetArgs d n getArgs : Elim q d n -> GetArgs q d n
getArgs e = getArgs' e [] getArgs e = getArgs' e []
infixr 1 :\\ infixr 1 :\\
public export public export
(:\\) : Vect m Name -> Term d (m + n) -> Term d n absN : Vect m Name -> Term q d (m + n) -> Term q d n
[] :\\ t = t absN {m = 0} [] s = s
x :: xs :\\ t = let t' = replace {p = Term _} (plusSuccRightSucc {}) t in absN {m = S m} (x :: xs) s = Lam x $ TUsed $ absN xs $
Lam x $ TUsed $ xs :\\ t' rewrite sym $ plusSuccRightSucc m n in s
public export %inline
(:\\) : Vect m Name -> Term q d (m + n) -> Term q d n
(:\\) = absN
public export public export
record GetLams (d, n : Nat) where record GetLams q d n where
constructor GotLams constructor GotLams
names : Vect lams Name names : Vect lams Name
body : Term d rest body : Term q d rest
0 eq : lams + n = rest 0 eq : lams + n = rest
0 notLam : NotLam body 0 notLam : NotLam body
public export export
getLams : Term d n -> GetLams d n getLams' : forall lams, rest.
getLams s with (choose $ isLam s) Vect lams Name -> Term q d rest -> lams + n = rest -> GetLams q d n
getLams s@(Lam x body) | Left yes = getLams' xs s eq with (isLam s)
let inner = getLams $ assert_smaller s $ fromScopeTerm body in getLams' xs (Lam x sbody) Refl | Yes ItIsLam =
GotLams {names = x :: inner.names, let 0 s = Lam x sbody
body = inner.body, body = assert_smaller s $ fromScopeTerm sbody
eq = plusSuccRightSucc {} `trans` inner.eq, in
notLam = inner.notLam} getLams' (x :: xs) body Refl
_ | Right no = GotLams {names = [], body = s, eq = Refl, notLam = no} getLams' xs s eq | No no =
GotLams xs s eq no
export
getLams : Term q d n -> GetLams q d n
getLams s = getLams' [] s Refl

54
lib/Quox/Syntax/Term/Subst.idr
View file

@ -5,8 +5,8 @@ import Quox.Syntax.Term.Base
%default total %default total
export FromVar (Elim d) where fromVar = B export FromVar (Elim q d) where fromVar = B
export FromVar (Term d) where fromVar = E . fromVar export FromVar (Term q d) where fromVar = E . fromVar
||| does the minimal reasonable work: ||| does the minimal reasonable work:
||| - deletes the closure around a free name since it doesn't do anything ||| - deletes the closure around a free name since it doesn't do anything
@ -15,7 +15,7 @@ export FromVar (Term d) where fromVar = E . fromVar
||| - immediately looks up a bound variable ||| - immediately looks up a bound variable
||| - otherwise, wraps in a new closure ||| - otherwise, wraps in a new closure
export export
CanSubst (Elim d) (Elim d) where CanSubst (Elim q d) (Elim q d) where
F x // _ = F x F x // _ = F x
B i // th = th !! i B i // th = th !! i
CloE e ph // th = assert_total CloE e $ ph . th CloE e ph // th = assert_total CloE e $ ph . th
@ -30,7 +30,7 @@ CanSubst (Elim d) (Elim d) where
||| - goes inside `E` in case it is a simple variable or something ||| - goes inside `E` in case it is a simple variable or something
||| - otherwise, wraps in a new closure ||| - otherwise, wraps in a new closure
export export
CanSubst (Elim d) (Term d) where CanSubst (Elim q d) (Term q d) where
TYPE l // _ = TYPE l TYPE l // _ = TYPE l
E e // th = E $ e // th E e // th = E $ e // th
CloT s ph // th = CloT s $ ph . th CloT s ph // th = CloT s $ ph . th
@ -39,13 +39,13 @@ CanSubst (Elim d) (Term d) where
th => CloT s th th => CloT s th
export export
CanSubst (Elim d) (ScopeTerm d) where CanSubst (Elim q d) (ScopeTerm q d) where
TUsed body // th = TUsed $ body // push th TUsed body // th = TUsed $ body // push th
TUnused body // th = TUnused $ body // th TUnused body // th = TUnused $ body // th
export CanSubst Var (Term d) where s // th = s // map (B {d}) th export CanSubst Var (Term q d) where s // th = s // map (B {q, d}) th
export CanSubst Var (Elim d) where e // th = e // map (B {d}) th export CanSubst Var (Elim q d) where e // th = e // map (B {q, d}) th
export CanSubst Var (ScopeTerm d) where s // th = s // map (B {d}) th export CanSubst Var (ScopeTerm q d) where s // th = s // map (B {q, d}) th
infixl 8 //., /// infixl 8 //., ///
@ -53,13 +53,13 @@ mutual
namespace Term namespace Term
||| applies a term substitution with a less ambiguous type ||| applies a term substitution with a less ambiguous type
export export
(//.) : Term d from -> TSubst d from to -> Term d to (//.) : Term q d from -> TSubst q d from to -> Term q d to
t //. th = t // th t //. th = t // th
||| applies a dimension substitution with the same behaviour as `(//)` ||| applies a dimension substitution with the same behaviour as `(//)`
||| above ||| above
export export
(///) : Term dfrom n -> DSubst dfrom dto -> Term dto n (///) : Term q dfrom n -> DSubst dfrom dto -> Term q dto n
TYPE l /// _ = TYPE l TYPE l /// _ = TYPE l
E e /// th = E $ e /// th E e /// th = E $ e /// th
DCloT s ph /// th = DCloT s $ ph . th DCloT s ph /// th = DCloT s $ ph . th
@ -68,20 +68,20 @@ mutual
||| applies a term and dimension substitution ||| applies a term and dimension substitution
public export %inline public export %inline
subs : Term dfrom from -> DSubst dfrom dto -> TSubst dto from to -> subs : Term q dfrom from -> DSubst dfrom dto -> TSubst q dto from to ->
Term dto to Term q dto to
subs s th ph = s /// th // ph subs s th ph = s /// th // ph
namespace Elim namespace Elim
||| applies a term substitution with a less ambiguous type ||| applies a term substitution with a less ambiguous type
export export
(//.) : Elim d from -> TSubst d from to -> Elim d to (//.) : Elim q d from -> TSubst q d from to -> Elim q d to
e //. th = e // th e //. th = e // th
||| applies a dimension substitution with the same behaviour as `(//)` ||| applies a dimension substitution with the same behaviour as `(//)`
||| above ||| above
export export
(///) : Elim dfrom n -> DSubst dfrom dto -> Elim dto n (///) : Elim q dfrom n -> DSubst dfrom dto -> Elim q dto n
F x /// _ = F x F x /// _ = F x
B i /// _ = B i B i /// _ = B i
DCloE e ph /// th = DCloE e $ ph . th DCloE e ph /// th = DCloE e $ ph . th
@ -90,46 +90,46 @@ mutual
||| applies a term and dimension substitution ||| applies a term and dimension substitution
public export %inline public export %inline
subs : Elim dfrom from -> DSubst dfrom dto -> TSubst dto from to -> subs : Elim q dfrom from -> DSubst dfrom dto -> TSubst q dto from to ->
Elim dto to Elim q dto to
subs e th ph = e /// th // ph subs e th ph = e /// th // ph
namespace ScopeTerm namespace ScopeTerm
||| applies a term substitution with a less ambiguous type ||| applies a term substitution with a less ambiguous type
export export
(//.) : ScopeTerm d from -> TSubst d from to -> ScopeTerm d to (//.) : ScopeTerm q d from -> TSubst q d from to -> ScopeTerm q d to
body //. th = body // th body //. th = body // th
||| applies a dimension substitution with the same behaviour as `(//)` ||| applies a dimension substitution with the same behaviour as `(//)`
||| above ||| above
export export
(///) : ScopeTerm dfrom n -> DSubst dfrom dto -> ScopeTerm dto n (///) : ScopeTerm q dfrom n -> DSubst dfrom dto -> ScopeTerm q dto n
TUsed body /// th = TUsed $ body /// th TUsed body /// th = TUsed $ body /// th
TUnused body /// th = TUnused $ body /// th TUnused body /// th = TUnused $ body /// th
||| applies a term and dimension substitution ||| applies a term and dimension substitution
public export %inline public export %inline
subs : ScopeTerm dfrom from -> DSubst dfrom dto -> TSubst dto from to -> subs : ScopeTerm q dfrom from -> DSubst dfrom dto -> TSubst q dto from to ->
ScopeTerm dto to ScopeTerm q dto to
subs body th ph = body /// th // ph subs body th ph = body /// th // ph
export CanShift (Term d) where s // by = s //. Shift by export CanShift (Term q d) where s // by = s //. Shift by
export CanShift (Elim d) where e // by = e //. Shift by export CanShift (Elim q d) where e // by = e //. Shift by
export CanShift (ScopeTerm d) where s // by = s //. Shift by export CanShift (ScopeTerm q d) where s // by = s //. Shift by
export %inline export %inline
comp' : DSubst dfrom dto -> TSubst dfrom from mid -> TSubst dto mid to -> comp' : DSubst dfrom dto -> TSubst q dfrom from mid -> TSubst q dto mid to ->
TSubst dto from to TSubst q dto from to
comp' th ps ph = map (/// th) ps . ph comp' th ps ph = map (/// th) ps . ph
export export
fromDScopeTerm : DScopeTerm d n -> Term (S d) n fromDScopeTerm : DScopeTerm q d n -> Term q (S d) n
fromDScopeTerm (DUsed body) = body fromDScopeTerm (DUsed body) = body
fromDScopeTerm (DUnused body) = body /// shift 1 fromDScopeTerm (DUnused body) = body /// shift 1
export export
fromScopeTerm : ScopeTerm d n -> Term d (S n) fromScopeTerm : ScopeTerm q d n -> Term q d (S n)
fromScopeTerm (TUsed body) = body fromScopeTerm (TUsed body) = body
fromScopeTerm (TUnused body) = body //. shift 1 fromScopeTerm (TUnused body) = body //. shift 1

88
lib/Quox/Typechecker.idr
View file

@ -4,48 +4,50 @@ import public Quox.Syntax
import public Quox.Typing import public Quox.Typing
import public Quox.Equal import public Quox.Equal
import public Control.Monad.Either import public Control.Monad.Either
import Decidable.Decidable
%default total %default total
private covering %inline private covering %inline
expectTYPE : MonadError Error m => Term d n -> m Universe expectTYPE : HasErr q m => Term q d n -> m Universe
expectTYPE s = expectTYPE s =
case (whnfT s).fst of case (whnfT s).fst of
TYPE l => pure l TYPE l => pure l
_ => throwError $ ExpectedTYPE s _ => throwError $ ExpectedTYPE s
private covering %inline private covering %inline
expectPi : MonadError Error m => Term d n -> expectPi : HasErr q m => Term q d n ->
m (Qty, Term d n, ScopeTerm d n) m (q, Term q d n, ScopeTerm q d n)
expectPi ty = expectPi ty =
case (whnfT ty).fst of case (whnfT ty).fst of
Pi qty _ arg res => pure (qty, arg, res) Pi qty _ arg res => pure (qty, arg, res)
_ => throwError $ ExpectedPi ty _ => throwError $ ExpectedPi ty
private %inline private %inline
expectEqualQ : MonadError Error m => expectEqualQ : HasErr q m => Eq q =>
(expect, actual : Qty) -> m () (expect, actual : q) -> m ()
expectEqualQ pi rh = expectEqualQ pi rh =
unless (pi == rh) $ throwError $ ClashQ pi rh unless (pi == rh) $ throwError $ ClashQ pi rh
private %inline private %inline
popQ : MonadError Error m => Qty -> QOutput (S n) -> m (QOutput n) popQ : HasErr q m => Eq q => q -> QOutput q (S n) -> m (QOutput q n)
popQ pi (qctx :< rh) = expectEqualQ pi rh $> qctx popQ pi (qctx :< rh) = expectEqualQ pi rh $> qctx
private %inline private %inline
tail : TyContext d (S n) -> TyContext d n tail : TyContext q d (S n) -> TyContext q d n
tail = {tctx $= tail, qctx $= tail} tail = {tctx $= tail, qctx $= tail}
private %inline private %inline
weakI : InferResult d n -> InferResult d (S n) weakI : IsQty q => InferResult q d n -> InferResult q d (S n)
weakI = {type $= weakT, qout $= (:< zero)} weakI = {type $= weakT, qout $= (:< zero)}
private private
lookupBound : {n : Nat} -> Qty -> Var n -> TyContext d n -> InferResult d n lookupBound : IsQty q =>
{n : Nat} -> q -> Var n -> TyContext q d n -> InferResult q d n
lookupBound pi VZ (MkTyContext {tctx = _ :< ty, _}) = lookupBound pi VZ (MkTyContext {tctx = _ :< ty, _}) =
InfRes {type = weakT ty, qout = zero :< pi} InfRes {type = weakT ty, qout = zero :< pi}
lookupBound pi (VS i) ctx = lookupBound pi (VS i) ctx =
@ -53,18 +55,22 @@ lookupBound pi (VS i) ctx =
private %inline private %inline
subjMult : Qty -> Qty -> Subset Qty IsSubj subjMult : IsQty q => (sg : SQty q) -> q -> SQty q
subjMult sg qty = subjMult (Element sg subj) qty =
if sg == Zero || qty == Zero if isYes (isZero sg) || isYes (isZero qty)
then Element Zero %search then Element zero zeroIsSubj
else Element One %search else Element sg subj
public export public export
CanTC : (Type -> Type) -> Type 0 CanTC' : (q : Type) -> (q -> Type) -> (Type -> Type) -> Type
CanTC m = (MonadError Error m, MonadReader Definitions m) CanTC' q isGlobal m = (HasErr q m, MonadReader (Definitions' q isGlobal) m)
parameters {auto _ : CanTC m} public export
0 CanTC : (q : Type) -> IsQty q => (Type -> Type) -> Type
CanTC q = CanTC' q IsGlobal
parameters {auto _ : IsQty q} {auto _ : CanTC q m}
mutual mutual
-- [todo] it seems like the options here for dealing with substitutions are -- [todo] it seems like the options here for dealing with substitutions are
-- to either push them or parametrise the whole typechecker over ambient -- to either push them or parametrise the whole typechecker over ambient
@ -73,76 +79,78 @@ parameters {auto _ : CanTC m}
export covering %inline export covering %inline
check : {d, n : Nat} -> check : {d, n : Nat} ->
(ctx : TyContext d n) -> (sg : Qty) -> (0 _ : IsSubj sg) => (ctx : TyContext q d n) -> (sg : SQty q) ->
(subj : Term d n) -> (ty : Term d n) -> (subj : Term q d n) -> (ty : Term q d n) ->
m (CheckResult n) m (CheckResult q n)
check ctx sg subj ty = check' ctx sg (pushSubstsT subj) ty check ctx sg subj ty = check' ctx sg (pushSubstsT subj) ty
export covering %inline export covering %inline
infer : {d, n : Nat} -> infer : {d, n : Nat} ->
(ctx : TyContext d n) -> (sg : Qty) -> (0 _ : IsSubj sg) => (ctx : TyContext q d n) -> (sg : SQty q) ->
(subj : Elim d n) -> (subj : Elim q d n) ->
m (InferResult d n) m (InferResult q d n)
infer ctx sg subj = infer' ctx sg (pushSubstsE subj) infer ctx sg subj = infer' ctx sg (pushSubstsE subj)
export covering export covering
check' : {d, n : Nat} -> check' : {d, n : Nat} ->
(ctx : TyContext d n) -> (sg : Qty) -> (0 _ : IsSubj sg) => (ctx : TyContext q d n) -> (sg : SQty q) ->
(subj : NotCloTerm d n) -> (ty : Term d n) -> (subj : NotCloTerm q d n) -> (ty : Term q d n) ->
m (CheckResult n) m (CheckResult q n)
check' ctx sg (Element (TYPE l) _) ty = do check' ctx sg (Element (TYPE l) _) ty = do
l' <- expectTYPE ty l' <- expectTYPE ty
expectEqualQ zero sg expectEqualQ zero sg.fst
unless (l < l') $ throwError $ BadUniverse l l' unless (l < l') $ throwError $ BadUniverse l l'
pure zero pure zero
check' ctx sg (Element (Pi qty x arg res) _) ty = do check' ctx sg (Element (Pi qty x arg res) _) ty = do
l <- expectTYPE ty l <- expectTYPE ty
expectEqualQ zero sg expectEqualQ zero sg.fst
ignore $ check ctx zero arg (TYPE l) ignore $ check ctx szero arg (TYPE l)
case res of case res of
TUsed res => ignore $ check (extendTy arg zero ctx) zero res (TYPE l) TUsed res =>
TUnused res => ignore $ check ctx zero res (TYPE l) ignore $ check (extendTy arg zero ctx) szero res (TYPE l)
TUnused res =>
ignore $ check ctx szero res (TYPE l)
pure zero pure zero
check' ctx sg (Element (Lam x body) _) ty = do check' ctx sg (Element (Lam x body) _) ty = do
(qty, arg, res) <- expectPi ty (qty, arg, res) <- expectPi ty
-- [todo] do this properly? -- [todo] do this properly?
let body = fromScopeTerm body; res = fromScopeTerm res let body = fromScopeTerm body; res = fromScopeTerm res
qout <- check (extendTy arg (sg * qty) ctx) sg body res qout <- check (extendTy arg (sg.fst * qty) ctx) sg body res
popQ qty qout popQ qty qout
check' ctx sg (Element (E e) _) ty = do check' ctx sg (Element (E e) _) ty = do
infres <- infer ctx sg e infres <- infer ctx sg e
ignore $ check ctx zero ty (TYPE UAny) ignore $ check ctx szero ty (TYPE UAny)
subT infres.type ty subT infres.type ty
pure infres.qout pure infres.qout
export covering export covering
infer' : {d, n : Nat} -> infer' : {d, n : Nat} ->
(ctx : TyContext d n) -> (sg : Qty) -> (0 _ : IsSubj sg) => (ctx : TyContext q d n) -> (sg : SQty q) ->
(subj : NotCloElim d n) -> (subj : NotCloElim q d n) ->
m (InferResult d n) m (InferResult q d n)
infer' ctx sg (Element (F x) _) = do infer' ctx sg (Element (F x) _) = do
Just g <- asks $ lookup x | Nothing => throwError $ NotInScope x Just g <- asks $ lookup x | Nothing => throwError $ NotInScope x
when (isZero g) $ expectEqualQ sg Zero when (isZero g) $ expectEqualQ sg.fst zero
pure $ InfRes {type = g.type.get, qout = zero} pure $ InfRes {type = g.type.get, qout = zero}
infer' ctx sg (Element (B i) _) = infer' ctx sg (Element (B i) _) =
pure $ lookupBound sg i ctx pure $ lookupBound sg.fst i ctx
infer' ctx sg (Element (fun :@ arg) _) = do infer' ctx sg (Element (fun :@ arg) _) = do
funres <- infer ctx sg fun funres <- infer ctx sg fun
(qty, argty, res) <- expectPi funres.type (qty, argty, res) <- expectPi funres.type
let Element sg' _ = subjMult sg qty let sg' = subjMult sg qty
argout <- check ctx sg' arg argty argout <- check ctx sg' arg argty
pure $ InfRes {type = fromScopeTerm res //. ((arg :# argty) ::: id), pure $ InfRes {type = fromScopeTerm res //. ((arg :# argty) ::: id),
qout = funres.qout + argout} qout = funres.qout + argout}
infer' ctx sg (Element (tm :# ty) _) = do infer' ctx sg (Element (tm :# ty) _) = do
ignore $ check ctx zero ty (TYPE UAny) ignore $ check ctx szero ty (TYPE UAny)
qout <- check ctx sg tm ty qout <- check ctx sg tm ty
pure $ InfRes {type = ty, qout} pure $ InfRes {type = ty, qout}

68
lib/Quox/Typing.idr
View file

@ -6,6 +6,7 @@ import public Quox.Definition
import Data.Nat import Data.Nat
import public Data.SortedMap import public Data.SortedMap
import Control.Monad.Either
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.State import Control.Monad.State
import Generics.Derive import Generics.Derive
@ -24,71 +25,72 @@ data DContext : Nat -> Type where
DEq : Dim d -> Dim d -> DContext d -> DContext d DEq : Dim d -> Dim d -> DContext d -> DContext d
public export public export
TContext : Nat -> Nat -> Type TContext : Type -> Nat -> Nat -> Type
TContext d = Context (Term d) TContext q d = Context (Term q d)
public export public export
QContext : Nat -> Type QContext : Type -> Nat -> Type
QContext = Context' Qty QContext = Context'
public export public export
QOutput : Nat -> Type QOutput : Type -> Nat -> Type
QOutput = QContext QOutput = QContext
public export public export
record TyContext (d, n : Nat) where record TyContext q d n where
constructor MkTyContext constructor MkTyContext
dctx : DContext d dctx : DContext d
tctx : TContext d n tctx : TContext q d n
qctx : QContext n qctx : QContext q n
%name TyContext ctx %name TyContext ctx
namespace TContext namespace TContext
export export
pushD : TContext d n -> TContext (S d) n pushD : TContext q d n -> TContext q (S d) n
pushD tel = map (/// shift 1) tel pushD tel = map (/// shift 1) tel
namespace TyContext namespace TyContext
export export
extendTy : Term d n -> Qty -> TyContext d n -> TyContext d (S n) extendTy : Term q d n -> q -> TyContext q d n -> TyContext q d (S n)
extendTy s rho = {tctx $= (:< s), qctx $= (:< rho)} extendTy s rho = {tctx $= (:< s), qctx $= (:< rho)}
export export
extendDim : TyContext d n -> TyContext (S d) n extendDim : TyContext q d n -> TyContext q (S d) n
extendDim = {dctx $= DBind, tctx $= pushD} extendDim = {dctx $= DBind, tctx $= pushD}
export export
eqDim : Dim d -> Dim d -> TyContext d n -> TyContext d n eqDim : Dim d -> Dim d -> TyContext q d n -> TyContext q d n
eqDim p q = {dctx $= DEq p q} eqDim p q = {dctx $= DEq p q}
namespace QOutput namespace QOutput
export parameters {auto _ : IsQty q}
(+) : QOutput n -> QOutput n -> QOutput n export
(+) = zipWith (+) (+) : QOutput q n -> QOutput q n -> QOutput q n
(+) = zipWith (+)
export export
(*) : Qty -> QOutput n -> QOutput n (*) : q -> QOutput q n -> QOutput q n
(*) pi = map (pi *) (*) pi = map (pi *)
export export
zero : {n : Nat} -> QOutput n zero : {n : Nat} -> QOutput q n
zero = pure Zero zero = pure zero
public export public export
CheckResult : Nat -> Type CheckResult : Type -> Nat -> Type
CheckResult = QOutput CheckResult = QOutput
public export public export
record InferResult d n where record InferResult q d n where
constructor InfRes constructor InfRes
type : Term d n type : Term q d n
qout : QOutput n qout : QOutput q n
public export public export
@ -97,12 +99,16 @@ data EqMode = Equal | Sub
public export public export
data Error data Error q
= ExpectedTYPE (Term d n) = ExpectedTYPE (Term q d n)
| ExpectedPi (Term d n) | ExpectedPi (Term q d n)
| BadUniverse Universe Universe | BadUniverse Universe Universe
| ClashT EqMode (Term d n) (Term d n) | ClashT EqMode (Term q d n) (Term q d n)
| ClashU EqMode Universe Universe | ClashU EqMode Universe Universe
| ClashQ Qty Qty | ClashQ q q
| NotInScope Name | NotInScope Name
public export
0 HasErr : Type -> (Type -> Type) -> Type
HasErr q = MonadError (Error q)

1
lib/quox-lib.ipkg
View file

@ -16,6 +16,7 @@ modules =
Quox.Syntax.Dim, Quox.Syntax.Dim,
Quox.Syntax.DimEq, Quox.Syntax.DimEq,
Quox.Syntax.Qty, Quox.Syntax.Qty,
Quox.Syntax.Qty.Three,
Quox.Syntax.Shift, Quox.Syntax.Shift,
Quox.Syntax.Subst, Quox.Syntax.Subst,
Quox.Syntax.Term, Quox.Syntax.Term,

12
tests/TermImpls.idr
View file

@ -1,7 +1,7 @@
module TermImpls module TermImpls
import Quox.Syntax import Quox.Syntax
import Quox.Pretty import public Quox.Pretty
private private
@ -22,7 +22,7 @@ eqSubst (_ ::: _) (Shift _) = Nothing
mutual mutual
export covering export covering
Eq (Term d n) where Eq q => Eq (Term q d n) where
TYPE k == TYPE l = k == l TYPE k == TYPE l = k == l
TYPE _ == _ = False TYPE _ == _ = False
@ -49,7 +49,7 @@ mutual
DCloT {} == _ = False DCloT {} == _ = False
export covering export covering
Eq (Elim d n) where Eq q => Eq (Elim q d n) where
F x == F y = x == y F x == F y = x == y
F _ == _ = False F _ == _ = False
@ -75,16 +75,16 @@ mutual
DCloE {} == _ = False DCloE {} == _ = False
export covering export covering
Eq (ScopeTerm d n) where Eq q => Eq (ScopeTerm q d n) where
TUsed s == TUsed t = s == t TUsed s == TUsed t = s == t
TUnused s == TUnused t = s == t TUnused s == TUnused t = s == t
TUsed _ == TUnused _ = False TUsed _ == TUnused _ = False
TUnused _ == TUsed _ = False TUnused _ == TUsed _ = False
export covering export covering
Show (Term d n) where PrettyHL q => Show (Term q d n) where
showPrec d t = showParens (d /= Open) $ prettyStr True t showPrec d t = showParens (d /= Open) $ prettyStr True t
export covering export covering
Show (Elim d n) where PrettyHL q => Show (Elim q d n) where
showPrec d e = showParens (d /= Open) $ prettyStr True e showPrec d e = showParens (d /= Open) $ prettyStr True e

16
tests/Tests/Equal.idr
View file

@ -2,10 +2,11 @@ module Tests.Equal
import Quox.Equal as Lib import Quox.Equal as Lib
import Quox.Pretty import Quox.Pretty
import Quox.Syntax.Qty.Three
import TAP import TAP
export export
ToInfo Error where ToInfo (Error Three) where
toInfo (NotInScope x) = toInfo (NotInScope x) =
[("type", "NotInScope"), [("type", "NotInScope"),
("name", show x)] ("name", show x)]
@ -35,10 +36,11 @@ ToInfo Error where
("right", prettyStr True rh)] ("right", prettyStr True rh)]
M = ReaderT Definitions (Either Error) 0 M : Type -> Type
M = ReaderT (Definitions Three) (Either (Error Three))
parameters (label : String) (act : Lazy (M ())) parameters (label : String) (act : Lazy (M ()))
{default empty globals : Definitions} {default empty globals : Definitions Three}
testEq : Test testEq : Test
testEq = test label $ runReaderT globals act testEq = test label $ runReaderT globals act
@ -46,19 +48,19 @@ parameters (label : String) (act : Lazy (M ()))
testNeq = testThrows label (const True) $ runReaderT globals act testNeq = testThrows label (const True) $ runReaderT globals act
subT : {default 0 d, n : Nat} -> Term d n -> Term d n -> M () subT : {default 0 d, n : Nat} -> Term Three d n -> Term Three d n -> M ()
subT = Lib.subT subT = Lib.subT
%hide Lib.subT %hide Lib.subT
equalT : {default 0 d, n : Nat} -> Term d n -> Term d n -> M () equalT : {default 0 d, n : Nat} -> Term Three d n -> Term Three d n -> M ()
equalT = Lib.equalT equalT = Lib.equalT
%hide Lib.equalT %hide Lib.equalT
subE : {default 0 d, n : Nat} -> Elim d n -> Elim d n -> M () subE : {default 0 d, n : Nat} -> Elim Three d n -> Elim Three d n -> M ()
subE = Lib.subE subE = Lib.subE
%hide Lib.subE %hide Lib.subE
equalE : {default 0 d, n : Nat} -> Elim d n -> Elim d n -> M () equalE : {default 0 d, n : Nat} -> Elim Three d n -> Elim Three d n -> M ()
equalE = Lib.equalE equalE = Lib.equalE
%hide Lib.equalE %hide Lib.equalE

10
tests/Tests/Reduce.idr
View file

@ -1,6 +1,7 @@
module Tests.Reduce module Tests.Reduce
import Quox.Syntax as Lib import Quox.Syntax as Lib
import Quox.Syntax.Qty.Three
import TermImpls import TermImpls
import TAP import TAP
@ -22,17 +23,18 @@ testNoStep step label e = test "\{label} (no step)" $
Right e' => with Prelude.(::) Left [("reduced", e')] Right e' => with Prelude.(::) Left [("reduced", e')]
parameters {default 0 d, n : Nat} parameters {default 0 d, n : Nat}
testWhnfT : String -> Term d n -> Term d n -> Test testWhnfT : String -> Term Three d n -> Term Three d n -> Test
testWhnfT = testWhnf whnfT testWhnfT = testWhnf whnfT
testWhnfE : String -> Elim d n -> Elim d n -> Test testWhnfE : String -> Elim Three d n -> Elim Three d n -> Test
testWhnfE = testWhnf whnfE testWhnfE = testWhnf whnfE
testNoStepE : String -> Elim d n -> Test testNoStepE : String -> Elim Three d n -> Test
testNoStepE = testNoStep stepE testNoStepE = testNoStep stepE
testNoStepT : String -> Term d n -> Test testNoStepT : String -> Term Three d n -> Test
testNoStepT = testNoStep stepT testNoStepT = testNoStep stepT