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

module Quox.Syntax.Term.Split

import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Subst
import Quox.Syntax.Term.Tighten
import Quox.Context

import public Quox.No
import public Data.Vect

%default total


public export %inline
isLam : Term {} -> Bool
isLam (Lam {}) = True
isLam _        = False

public export
0 NotLam : Pred $ Term {}
NotLam = No . isLam


public export %inline
isDLam : Term {} -> Bool
isDLam (DLam {}) = True
isDLam _         = False

public export
0 NotDLam : Pred $ Term {}
NotDLam = No . isDLam


public export %inline
isPair : Term {} -> Bool
isPair (Pair {}) = True
isPair _         = False

public export
0 NotPair : Pred $ Term {}
NotPair = No . isPair


public export %inline
isApp : Elim {} -> Bool
isApp (App {}) = True
isApp _        = False

public export
0 NotApp : Pred $ Elim {}
NotApp = No . isApp


public export %inline
isDApp : Elim {} -> Bool
isDApp (DApp {}) = True
isDApp _         = False

public export
0 NotDApp : Pred $ Elim {}
NotDApp = No . isDApp


-- infixl 9 :@@
-- ||| apply multiple arguments at once
-- public export %inline
-- (:@@) : Elim d n -> List (Term d n) -> Elim d n
-- f :@@ ss = foldl app f ss where
--   app : Elim d n -> Term d n -> Elim d n
--   app f s = App f s (f.loc `extend'` s.loc.bounds)

public export
record GetArgs d n where
  constructor GotArgs
  fun      : Elim d n
  args     : List (Term d n)
  0 notApp : NotApp fun

mutual
  export %inline
  getArgs' : Elim d n -> List (Term d n) -> GetArgs d n
  getArgs' fun0 args =
    let Element fun nc = pushSubsts fun0 in
    getArgsNc (assert_smaller fun0 fun) args

  private
  getArgsNc : (e : Elim d n) -> (0 nc : NotClo e) =>
              List (Term d n) -> GetArgs d n
  getArgsNc fun args = case nchoose $ isApp fun of
    Left  y => let App f a _ = fun in getArgs' f (a :: args)
    Right n => GotArgs {fun, args, notApp = n}

||| splits an application into its head and arguments. if it's not an
||| application then the list is just empty.
||| looks through substitutions for applications.
export %inline
getArgs : Elim d n -> GetArgs d n
getArgs e = getArgs' e []


-- infixl 9 :%%
-- ||| apply multiple dimension arguments at once
-- public export %inline
-- (:%%) : Elim d n -> List (Dim d) -> Elim d n
-- f :%% ss = foldl dapp f ss where
--   dapp : Elim d n -> Dim d -> Elim d n
--   dapp f p = DApp f p (f.loc `extend'` p.loc.bounds)

public export
record GetDArgs d n where
  constructor GotDArgs
  fun       : Elim d n
  args      : List (Dim d)
  0 notDApp : NotDApp fun

mutual
  export %inline
  getDArgs' : Elim d n -> List (Dim d) -> GetDArgs d n
  getDArgs' fun0 args =
    let Element fun nc = pushSubsts fun0 in
    getDArgsNc (assert_smaller fun0 fun) args

  private
  getDArgsNc : (e : Elim d n) -> (0 nc : NotClo e) =>
               List (Dim d) -> GetDArgs d n
  getDArgsNc fun args = case nchoose $ isDApp fun of
    Left  y => let DApp f d _ = fun in getDArgs' f (d :: args)
    Right n => GotDArgs {fun, args, notDApp = n}

||| 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 d n -> GetDArgs d n
getDArgs e = getDArgs' e []


-- infixr 1 :\\
-- public export
-- absN : BContext m -> Term d (m + n) -> Term d n
-- absN [<]       s = s
-- absN (xs :< x) s = absN xs $ Lam (ST [< x] s) ?absloc

-- public export %inline
-- (:\\) : BContext m -> Term d (m + n) -> Term d n
-- (:\\) = absN


-- infixr 1 :\\%
-- public export
-- dabsN : BContext m -> Term (m + d) n -> Term d n
-- dabsN [<]       s = s
-- dabsN (xs :< x) s = dabsN xs $ DLam (DST [< x] s) ?dabsLoc

-- public export %inline
-- (:\\%) : BContext m -> Term (m + d) n -> Term d n
-- (:\\%) = dabsN


public export
record GetLams d n where
  constructor GotLams
  {0 lams, rest : Nat}
  names    : BContext lams
  body     : Term d rest
  0 eq     : lams + n = rest
  0 notLam : NotLam body

mutual
  export %inline
  getLams' : forall lams, rest.
             BContext lams -> Term d rest -> (0 eq : lams + n = rest) ->
             GetLams d n
  getLams' xs s0 eq =
    let Element s nc = pushSubsts s0 in
    getLamsNc xs (assert_smaller s0 s) eq

  private
  getLamsNc : forall lams, rest.
              BContext lams ->
              (t : Term d rest) -> (0 nc : NotClo t) =>
              (0 eq : lams + n = rest) ->
              GetLams d n
  getLamsNc xs s Refl = case nchoose $ isLam s of
    Left  y => let Lam (S [< x] body) _ = s in
               getLams' (xs :< x) (assert_smaller s body.term) Refl
    Right n => GotLams xs s Refl n

export %inline
getLams : Term d n -> GetLams d n
getLams s = getLams' [<] s Refl


public export
record GetDLams d n where
  constructor GotDLams
  {0 lams, rest : Nat}
  names     : BContext lams
  body      : Term rest n
  0 eq      : lams + d = rest
  0 notDLam : NotDLam body

mutual
  export %inline
  getDLams' : forall lams, rest.
              BContext lams -> Term rest n -> (0 eq : lams + d = rest) ->
              GetDLams d n
  getDLams' xs s0 eq =
    let Element s nc = pushSubsts s0 in
    getDLamsNc xs (assert_smaller s0 s) eq

  private
  getDLamsNc : forall lams, rest.
               BContext lams ->
               (t : Term rest n) -> (0 nc : NotClo t) =>
               (0 eq : lams + d = rest) ->
               GetDLams d n
  getDLamsNc is s Refl = case nchoose $ isDLam s of
    Left  y => let DLam (S [< i] body) _ = s in
               getDLams' (is :< i) (assert_smaller s body.term) Refl
    Right n => GotDLams is s Refl n

export %inline
getDLams : Term d n -> GetDLams d n
getDLams s = getDLams' [<] s Refl


public export
record GetPairs d n where
  constructor GotPairs
  init : SnocList $ Term d n
  last : Term d n
  notPair : NotPair last

mutual
  export %inline
  getPairs' : SnocList (Term d n) -> Term d n -> GetPairs d n
  getPairs' ss t0 =
    let Element t nc = pushSubsts t0 in getPairsNc ss (assert_smaller t0 t)

  private
  getPairsNc : SnocList (Term d n) ->
               (t : Term d n) -> (0 nc : NotClo t) =>
               GetPairs d n
  getPairsNc ss t = case nchoose $ isPair t of
    Left  y => let Pair s t _ = t in
               getPairs' (ss :< s) t
    Right n => GotPairs ss t n

export
getPairs : Term d n -> GetPairs d n
getPairs = getPairs' [<]