quox/lib/Quox/Syntax/Term/Split.idr

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