208 lines
5.4 KiB
Idris
208 lines
5.4 KiB
Idris
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
|
|
data IsLam : Pred $ Term {} where ItIsLam : IsLam $ Lam x body
|
|
|
|
public export %inline
|
|
isLam : Dec1 IsLam
|
|
isLam (TYPE _) = No $ \case _ impossible
|
|
isLam (Pi {}) = No $ \case _ impossible
|
|
isLam (Lam {}) = Yes ItIsLam
|
|
isLam (Eq {}) = No $ \case _ impossible
|
|
isLam (DLam {}) = No $ \case _ impossible
|
|
isLam (E _) = No $ \case _ impossible
|
|
isLam (CloT {}) = No $ \case _ impossible
|
|
isLam (DCloT {}) = No $ \case _ impossible
|
|
|
|
public export
|
|
0 NotLam : Pred $ Term {}
|
|
NotLam = Not . IsLam
|
|
|
|
|
|
public export
|
|
data IsDLam : Pred $ Term {} where ItIsDLam : IsDLam $ DLam i body
|
|
|
|
public export %inline
|
|
isDLam : Dec1 IsDLam
|
|
isDLam (TYPE _) = No $ \case _ impossible
|
|
isDLam (Pi {}) = No $ \case _ impossible
|
|
isDLam (Eq {}) = No $ \case _ impossible
|
|
isDLam (Lam {}) = No $ \case _ impossible
|
|
isDLam (DLam {}) = Yes ItIsDLam
|
|
isDLam (E _) = No $ \case _ impossible
|
|
isDLam (CloT {}) = No $ \case _ impossible
|
|
isDLam (DCloT {}) = No $ \case _ impossible
|
|
|
|
public export
|
|
0 NotDLam : Pred $ Term {}
|
|
NotDLam = Not . IsDLam
|
|
|
|
|
|
public export
|
|
data IsApp : Pred $ Elim {} where ItIsApp : IsApp $ f :@ s
|
|
|
|
public export %inline
|
|
isApp : Dec1 IsApp
|
|
isApp (F _) = No $ \case _ impossible
|
|
isApp (B _) = No $ \case _ impossible
|
|
isApp (_ :@ _) = Yes ItIsApp
|
|
isApp (_ :% _) = No $ \case _ impossible
|
|
isApp (_ :# _) = No $ \case _ impossible
|
|
isApp (CloE {}) = No $ \case _ impossible
|
|
isApp (DCloE {}) = No $ \case _ impossible
|
|
|
|
public export
|
|
0 NotApp : Pred $ Elim {}
|
|
NotApp = Not . IsApp
|
|
|
|
|
|
public export
|
|
data IsDApp : Pred $ Elim {} where ItIsDApp : IsDApp $ f :% d
|
|
|
|
public export %inline
|
|
isDApp : Dec1 IsDApp
|
|
isDApp (F _) = No $ \case _ impossible
|
|
isDApp (B _) = No $ \case _ impossible
|
|
isDApp (_ :@ _) = No $ \case _ impossible
|
|
isDApp (_ :% _) = Yes ItIsDApp
|
|
isDApp (_ :# _) = No $ \case _ impossible
|
|
isDApp (CloE {}) = No $ \case _ impossible
|
|
isDApp (DCloE {}) = No $ \case _ impossible
|
|
|
|
public export
|
|
0 NotDApp : Pred $ Elim {}
|
|
NotDApp = Not . IsDApp
|
|
|
|
|
|
infixl 9 :@@
|
|
||| apply multiple arguments at once
|
|
public export %inline
|
|
(:@@) : Elim q d n -> List (Term q d n) -> Elim q d n
|
|
f :@@ ss = foldl (:@) f ss
|
|
|
|
public export
|
|
record GetArgs q d n where
|
|
constructor GotArgs
|
|
fun : Elim q d n
|
|
args : List (Term q d n)
|
|
0 notApp : NotApp fun
|
|
|
|
export
|
|
getArgs' : Elim q d n -> List (Term q d n) -> GetArgs q d n
|
|
getArgs' fun args with (isApp fun)
|
|
getArgs' (f :@ a) args | Yes _ = getArgs' f (a :: args)
|
|
getArgs' fun args | No 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 q d n -> GetArgs q d n
|
|
getArgs e = getArgs' e []
|
|
|
|
|
|
infixl 9 :%%
|
|
||| apply multiple dimension arguments at once
|
|
public export %inline
|
|
(:%%) : Elim q d n -> List (Dim d) -> Elim q d n
|
|
f :%% ss = foldl (:%) f ss
|
|
|
|
public export
|
|
record GetDArgs q d n where
|
|
constructor GotDArgs
|
|
fun : Elim q d n
|
|
args : List (Dim d)
|
|
0 notDApp : NotDApp fun
|
|
|
|
export
|
|
getDArgs' : Elim q d n -> List (Dim d) -> GetDArgs q d n
|
|
getDArgs' fun args with (isDApp fun)
|
|
getDArgs' (f :% a) args | Yes yes = getDArgs' f (a :: args)
|
|
getDArgs' fun args | No no = GotDArgs {fun, args, notDApp = no}
|
|
|
|
||| splits a dimension application into its head and arguments. if it's not an
|
|
||| d application then the list is just empty
|
|
export %inline
|
|
getDArgs : Elim q d n -> GetDArgs q d n
|
|
getDArgs e = getDArgs' e []
|
|
|
|
|
|
infixr 1 :\\
|
|
public export
|
|
absN : Vect m Name -> Term q d (m + n) -> Term q d n
|
|
absN {m = 0} [] s = s
|
|
absN {m = S m} (x :: xs) s = Lam x $ TUsed $ absN xs $
|
|
rewrite sym $ plusSuccRightSucc m n in s
|
|
|
|
public export %inline
|
|
(:\\) : Vect m Name -> Term q d (m + n) -> Term q d n
|
|
(:\\) = absN
|
|
|
|
|
|
infixr 1 :\\%
|
|
public export
|
|
dabsN : Vect m Name -> Term q (m + d) n -> Term q d n
|
|
dabsN {m = 0} [] s = s
|
|
dabsN {m = S m} (x :: xs) s = DLam x $ DUsed $ dabsN xs $
|
|
rewrite sym $ plusSuccRightSucc m d in s
|
|
|
|
public export %inline
|
|
(:\\%) : Vect m Name -> Term q (m + d) n -> Term q d n
|
|
(:\\%) = dabsN
|
|
|
|
|
|
public export
|
|
record GetLams q d n where
|
|
constructor GotLams
|
|
{0 lams, rest : Nat}
|
|
names : Vect lams Name
|
|
body : Term q d rest
|
|
0 eq : lams + n = rest
|
|
0 notLam : NotLam body
|
|
|
|
export
|
|
getLams' : forall lams, rest.
|
|
Vect lams Name -> Term q d rest -> (0 eq : lams + n = rest) ->
|
|
GetLams q d n
|
|
getLams' xs s eq with (isLam s)
|
|
getLams' xs (Lam x sbody) Refl | Yes _ =
|
|
let body = assert_smaller (Lam x sbody) sbody.term in
|
|
getLams' (x :: xs) body Refl
|
|
getLams' xs s eq | No no = GotLams xs s eq no
|
|
|
|
export %inline
|
|
getLams : Term q d n -> GetLams q d n
|
|
getLams s = getLams' [] s Refl
|
|
|
|
|
|
public export
|
|
record GetDLams q d n where
|
|
constructor GotDLams
|
|
{0 lams, rest : Nat}
|
|
names : Vect lams Name
|
|
body : Term q rest n
|
|
0 eq : lams + d = rest
|
|
0 notDLam : NotDLam body
|
|
|
|
export
|
|
getDLams' : forall lams, rest.
|
|
Vect lams Name -> Term q rest n -> (0 eq : lams + d = rest) ->
|
|
GetDLams q d n
|
|
getDLams' is s eq with (isDLam s)
|
|
getDLams' is (DLam i sbody) Refl | Yes _ =
|
|
let body = assert_smaller (DLam i sbody) sbody.term in
|
|
getDLams' (i :: is) body Refl
|
|
getDLams' is s eq | No no = GotDLams is s eq no
|
|
|
|
export %inline
|
|
getDLams : Term q d n -> GetDLams q d n
|
|
getDLams s = getDLams' [] s Refl
|