module EquivOptimize0Plus

import Equiv
import Expr
import Logic
import Imp
import Maps

%access public export

%default total

optimize_0plus_aexp : AExp -> AExp
optimize_0plus_aexp (ANum n) = ANum n
optimize_0plus_aexp (AId x) = AId x
optimize_0plus_aexp (APlus (ANum Z) y) = optimize_0plus_aexp y
optimize_0plus_aexp (APlus x y) = APlus (optimize_0plus_aexp x)
                                        (optimize_0plus_aexp y)
optimize_0plus_aexp (AMinus x y) = AMinus (optimize_0plus_aexp x)
                                          (optimize_0plus_aexp y)
optimize_0plus_aexp (AMult x y) = AMult (optimize_0plus_aexp x)
                                        (optimize_0plus_aexp y)

optimize_0plus_bexp : BExp -> BExp
optimize_0plus_bexp BTrue = BTrue
optimize_0plus_bexp BFalse = BFalse
optimize_0plus_bexp (BEq a1 a2) =
  case (optimize_0plus_aexp a1, optimize_0plus_aexp a2) of
    (ANum n1, ANum n2) => if n1 == n2
                             then BTrue
                             else BFalse
    (e1, e2) => BEq e1 e2
optimize_0plus_bexp (BLe a1 a2) =
  case (optimize_0plus_aexp a1, optimize_0plus_aexp a2) of
    (ANum n1, ANum n2) => if lte n1 n2
                             then BTrue
                             else BFalse
    (e1, e2) => BLe e1 e2
optimize_0plus_bexp (BNot b) = case optimize_0plus_bexp b of
  BTrue => BFalse
  BFalse => BTrue
  e => BNot e
optimize_0plus_bexp (BAnd b1 b2) =
  case (optimize_0plus_bexp b1, optimize_0plus_bexp b2) of
    (BTrue, e2) => e2
    (BFalse, _) => BFalse
    (e1, e2) => BAnd e1 e2

optimize_0plus_com : Com -> Com
optimize_0plus_com CSkip = CSkip
optimize_0plus_com (CAss x e) = CAss x (optimize_0plus_aexp e)
optimize_0plus_com (CSeq c1 c2) = CSeq (optimize_0plus_com c1)
                                       (optimize_0plus_com c2)
optimize_0plus_com (CIf b ct cf) = case optimize_0plus_bexp b of
  BTrue => optimize_0plus_com ct
  BFalse => optimize_0plus_com cf
  e => CIf e (optimize_0plus_com ct) (optimize_0plus_com cf)
optimize_0plus_com (CIf1 b c) = case optimize_0plus_bexp b of
  BTrue => optimize_0plus_com c
  BFalse => SKIP
  e => CIf1 e (optimize_0plus_com c)
optimize_0plus_com (CWhile b c) = case optimize_0plus_bexp b of
  BTrue => CWhile BTrue CSkip
  BFalse => CSkip
  e => CWhile e (optimize_0plus_com c)
optimize_0plus_com (CFor init cond updt body) = case optimize_0plus_bexp cond of
  BTrue => CSeq (optimize_0plus_com init) (CWhile BTrue SKIP)
  BFalse => optimize_0plus_com init
  e => CFor (optimize_0plus_com init)
            e
            (optimize_0plus_com updt)
            (optimize_0plus_com body)
optimize_0plus_com (CRepeat body cond) = case optimize_0plus_bexp cond of
  BTrue => optimize_0plus_com body
  BFalse => CSeq (optimize_0plus_com body) (CWhile BTrue SKIP)
  e => CRepeat (optimize_0plus_com body) e

optimize_0plus_aexp_sound : ATransSound EquivOptimize0Plus.optimize_0plus_aexp
optimize_0plus_aexp_sound {a = ANum _} _ = Refl
optimize_0plus_aexp_sound {a = AId _} _ = Refl
optimize_0plus_aexp_sound {a = APlus (ANum Z) a2} st =
  optimize_0plus_aexp_sound a2 st
optimize_0plus_aexp_sound {a = APlus (ANum (S _)) a2} st =
  rewrite optimize_0plus_aexp_sound a2 st
  in Refl
optimize_0plus_aexp_sound {a = APlus (AId _) a2} st =
  rewrite optimize_0plus_aexp_sound a2 st
  in Refl
optimize_0plus_aexp_sound {a = APlus a1@(APlus _ _) a2} st =
  rewrite optimize_0plus_aexp_sound a1 st
  in rewrite optimize_0plus_aexp_sound a2 st
  in Refl
optimize_0plus_aexp_sound {a = APlus a1@(AMinus _ _) a2} st =
  rewrite optimize_0plus_aexp_sound a1 st
  in rewrite optimize_0plus_aexp_sound a2 st
  in Refl
optimize_0plus_aexp_sound {a = APlus a1@(AMult _ _) a2} st =
  rewrite optimize_0plus_aexp_sound a1 st
  in rewrite optimize_0plus_aexp_sound a2 st
  in Refl
optimize_0plus_aexp_sound {a = AMinus a1 a2} st =
  rewrite optimize_0plus_aexp_sound a1 st
  in rewrite optimize_0plus_aexp_sound a2 st
  in Refl
optimize_0plus_aexp_sound {a = AMult a1 a2} st =
  rewrite optimize_0plus_aexp_sound a1 st
  in rewrite optimize_0plus_aexp_sound a2 st
  in Refl

optimize_0plus_bexp_sound : BTransSound EquivOptimize0Plus.optimize_0plus_bexp
optimize_0plus_bexp_sound {b = BTrue} _ = Refl
optimize_0plus_bexp_sound {b = BFalse} _ = Refl
optimize_0plus_bexp_sound {b = BEq a1 a2} st
  with (optimize_0plus_aexp a1) proof a1prf
    optimize_0plus_bexp_sound {b = BEq a1 a2} st | ANum k
      with (optimize_0plus_aexp a2) proof a2prf
        optimize_0plus_bexp_sound {b = BEq a1 a2} st | ANum k | ANum j
          with (k == j) proof eprf
            optimize_0plus_bexp_sound {b = BEq a1 a2} st
            | ANum k | ANum j | False =
              rewrite optimize_0plus_aexp_sound a1 st
              in rewrite sym a1prf
              in rewrite optimize_0plus_aexp_sound a2 st
              in rewrite sym a2prf
              in sym eprf
            optimize_0plus_bexp_sound {b = BEq a1 a2} st
            | ANum k | ANum j | True =
              rewrite optimize_0plus_aexp_sound a1 st
              in rewrite sym a1prf
              in rewrite optimize_0plus_aexp_sound a2 st
              in rewrite sym a2prf
              in sym eprf
        optimize_0plus_bexp_sound {b = BEq a1 a2} st | ANum _ | AId _ =
          rewrite optimize_0plus_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite optimize_0plus_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        optimize_0plus_bexp_sound {b = BEq a1 a2} st | ANum _ | APlus _ _ =
          rewrite optimize_0plus_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite optimize_0plus_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        optimize_0plus_bexp_sound {b = BEq a1 a2} st | ANum _ | AMinus _ _ =
          rewrite optimize_0plus_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite optimize_0plus_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        optimize_0plus_bexp_sound {b = BEq a1 a2} st | ANum _ | AMult _ _ =
          rewrite optimize_0plus_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite optimize_0plus_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
    optimize_0plus_bexp_sound {b = BEq a1 a2} st | AId _ =
      rewrite optimize_0plus_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite optimize_0plus_aexp_sound a2 st
      in Refl
    optimize_0plus_bexp_sound {b = BEq a1 a2} st | APlus _ _ =
      rewrite optimize_0plus_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite optimize_0plus_aexp_sound a2 st
      in Refl
    optimize_0plus_bexp_sound {b = BEq a1 a2} st | AMinus _ _ =
      rewrite optimize_0plus_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite optimize_0plus_aexp_sound a2 st
      in Refl
    optimize_0plus_bexp_sound {b = BEq a1 a2} st | AMult _ _ =
      rewrite optimize_0plus_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite optimize_0plus_aexp_sound a2 st
      in Refl
optimize_0plus_bexp_sound {b = BLe a1 a2} st
  with (optimize_0plus_aexp a1) proof a1prf
    optimize_0plus_bexp_sound {b = BLe a1 a2} st | ANum k
      with (optimize_0plus_aexp a2) proof a2prf
        optimize_0plus_bexp_sound {b = BLe a1 a2} st | ANum k | ANum j
          with (lte k j) proof eprf
            optimize_0plus_bexp_sound {b = BLe a1 a2} st
            | ANum k | ANum j | False =
              rewrite optimize_0plus_aexp_sound a1 st
              in rewrite sym a1prf
              in rewrite optimize_0plus_aexp_sound a2 st
              in rewrite sym a2prf
              in sym eprf
            optimize_0plus_bexp_sound {b = BLe a1 a2} st
            | ANum k | ANum j | True =
              rewrite optimize_0plus_aexp_sound a1 st
              in rewrite sym a1prf
              in rewrite optimize_0plus_aexp_sound a2 st
              in rewrite sym a2prf
              in sym eprf
        optimize_0plus_bexp_sound {b = BLe a1 a2} st | ANum _ | AId _ =
          rewrite optimize_0plus_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite optimize_0plus_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        optimize_0plus_bexp_sound {b = BLe a1 a2} st | ANum _ | APlus _ _ =
          rewrite optimize_0plus_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite optimize_0plus_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        optimize_0plus_bexp_sound {b = BLe a1 a2} st | ANum _ | AMinus _ _ =
          rewrite optimize_0plus_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite optimize_0plus_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
        optimize_0plus_bexp_sound {b = BLe a1 a2} st | ANum _ | AMult _ _ =
          rewrite optimize_0plus_aexp_sound a1 st
          in rewrite sym a1prf
          in rewrite optimize_0plus_aexp_sound a2 st
          in rewrite sym a2prf
          in Refl
    optimize_0plus_bexp_sound {b = BLe a1 a2} st | AId _ =
      rewrite optimize_0plus_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite optimize_0plus_aexp_sound a2 st
      in Refl
    optimize_0plus_bexp_sound {b = BLe a1 a2} st | APlus _ _ =
      rewrite optimize_0plus_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite optimize_0plus_aexp_sound a2 st
      in Refl
    optimize_0plus_bexp_sound {b = BLe a1 a2} st | AMinus _ _ =
      rewrite optimize_0plus_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite optimize_0plus_aexp_sound a2 st
      in Refl
    optimize_0plus_bexp_sound {b = BLe a1 a2} st | AMult _ _ =
      rewrite optimize_0plus_aexp_sound a1 st
      in rewrite sym a1prf
      in rewrite optimize_0plus_aexp_sound a2 st
      in Refl
optimize_0plus_bexp_sound {b = BNot b} st
  with (optimize_0plus_bexp b) proof bprf
    optimize_0plus_bexp_sound {b = BNot b} st | BTrue =
      rewrite optimize_0plus_bexp_sound b st
      in rewrite sym bprf
      in Refl
    optimize_0plus_bexp_sound {b = BNot b} st | BFalse =
      rewrite optimize_0plus_bexp_sound b st
      in rewrite sym bprf
      in Refl
    optimize_0plus_bexp_sound {b = BNot b} st | BEq _ _ =
      rewrite optimize_0plus_bexp_sound b st
      in rewrite sym bprf
      in Refl
    optimize_0plus_bexp_sound {b = BNot b} st | BLe _ _ =
      rewrite optimize_0plus_bexp_sound b st
      in rewrite sym bprf
      in Refl
    optimize_0plus_bexp_sound {b = BNot b} st | BNot _ =
      rewrite optimize_0plus_bexp_sound b st
      in rewrite sym bprf
      in Refl
    optimize_0plus_bexp_sound {b = BNot b} st | BAnd _ _ =
      rewrite optimize_0plus_bexp_sound b st
      in rewrite sym bprf
      in Refl
optimize_0plus_bexp_sound {b = BAnd b1 b2} st
  with (optimize_0plus_bexp b1) proof b1prf
    optimize_0plus_bexp_sound {b = BAnd b1 b2} st | BTrue =
      rewrite optimize_0plus_bexp_sound b1 st
      in rewrite sym b1prf
      in rewrite optimize_0plus_bexp_sound b2 st
      in Refl
    optimize_0plus_bexp_sound {b = BAnd b1 b2} st | BFalse =
      rewrite optimize_0plus_bexp_sound b1 st
      in rewrite sym b1prf
      in Refl
    optimize_0plus_bexp_sound {b = BAnd b1 b2} st | BEq _ _ =
      rewrite optimize_0plus_bexp_sound b1 st
      in rewrite sym b1prf
      in rewrite optimize_0plus_bexp_sound b2 st
      in Refl
    optimize_0plus_bexp_sound {b = BAnd b1 b2} st | BLe _ _ =
      rewrite optimize_0plus_bexp_sound b1 st
      in rewrite sym b1prf
      in rewrite optimize_0plus_bexp_sound b2 st
      in Refl
    optimize_0plus_bexp_sound {b = BAnd b1 b2} st | BNot _ =
      rewrite optimize_0plus_bexp_sound b1 st
      in rewrite sym b1prf
      in rewrite optimize_0plus_bexp_sound b2 st
      in Refl
    optimize_0plus_bexp_sound {b = BAnd b1 b2} st | BAnd _ _ =
      rewrite optimize_0plus_bexp_sound b1 st
      in rewrite sym b1prf
      in rewrite optimize_0plus_bexp_sound b2 st
      in Refl

optimize_0plus_com_sound : CTransSound EquivOptimize0Plus.optimize_0plus_com
optimize_0plus_com_sound {c = CSkip} st st' = refl_cequiv {c=CSkip} st st'
optimize_0plus_com_sound {c = (CAss _ e)} st st' =
  let c_equiv = cAss_congruence (optimize_0plus_aexp_sound e)
  in c_equiv st st'
optimize_0plus_com_sound {c = (CSeq c1 c2)} st st' =
  let c_equiv = cSeq_congruence (optimize_0plus_com_sound c1)
                                (optimize_0plus_com_sound c2)
  in c_equiv st st'
optimize_0plus_com_sound {c = (CIf b ct cf)} st st'
  with (optimize_0plus_bexp b) proof bprf
    optimize_0plus_com_sound {c = (CIf b ct cf)} st st' | BTrue =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
      in trans_cequiv (test_true b_equiv) (optimize_0plus_com_sound ct) st st'
    optimize_0plus_com_sound {c = (CIf b ct cf)} st st' | BFalse =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
      in trans_cequiv (test_false b_equiv) (optimize_0plus_com_sound cf) st st'
    optimize_0plus_com_sound {c = (CIf b ct cf)} st st' | BEq _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
          ct_equiv = optimize_0plus_com_sound ct
          cf_equiv = optimize_0plus_com_sound cf
          if_equiv = cIf_congruence b_equiv ct_equiv cf_equiv
      in if_equiv st st'
    optimize_0plus_com_sound {c = (CIf b ct cf)} st st' | BLe _ _ =
      let b_equiv = \st1 =>
            replace {P=\x => beval st1 b = beval st1 x}
                    (sym bprf) (optimize_0plus_bexp_sound b st1)
          ct_equiv = optimize_0plus_com_sound ct
          cf_equiv = optimize_0plus_com_sound cf
          if_equiv = cIf_congruence b_equiv ct_equiv cf_equiv
      in if_equiv st st'
    optimize_0plus_com_sound {c = (CIf b ct cf)} st st' | BNot _ =
      let b_equiv = \st1 =>
            replace {P=\x => beval st1 b = beval st1 x}
                    (sym bprf) (optimize_0plus_bexp_sound b st1)
          ct_equiv = optimize_0plus_com_sound ct
          cf_equiv = optimize_0plus_com_sound cf
          if_equiv = cIf_congruence b_equiv ct_equiv cf_equiv
      in if_equiv st st'
    optimize_0plus_com_sound {c = (CIf b ct cf)} st st' | BAnd _ _ =
      let b_equiv = \st1 =>
            replace {P=\x => beval st1 b = beval st1 x}
                    (sym bprf) (optimize_0plus_bexp_sound b st1)
          ct_equiv = optimize_0plus_com_sound ct
          cf_equiv = optimize_0plus_com_sound cf
          if_equiv = cIf_congruence b_equiv ct_equiv cf_equiv
      in if_equiv st st'
optimize_0plus_com_sound {c = (CIf1 b c)} st st'
  with (optimize_0plus_bexp b) proof bprf
    optimize_0plus_com_sound {c = (CIf1 b c)} st st' | BTrue =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
      in trans_cequiv (if1_true b_equiv) (optimize_0plus_com_sound c) st st'
    optimize_0plus_com_sound {c = (CIf1 b c)} st st' | BFalse =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
      in if1_false b_equiv st st'
    optimize_0plus_com_sound {c = (CIf1 b c)} st st' | BEq _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
          cif1_equiv = cIf1_congruence b_equiv (optimize_0plus_com_sound c)
      in cif1_equiv st st'
    optimize_0plus_com_sound {c = (CIf1 b c)} st st' | BLe _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
          cif1_equiv = cIf1_congruence b_equiv (optimize_0plus_com_sound c)
      in cif1_equiv st st'
    optimize_0plus_com_sound {c = (CIf1 b c)} st st' | BNot _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
          cif1_equiv = cIf1_congruence b_equiv (optimize_0plus_com_sound c)
      in cif1_equiv st st'
    optimize_0plus_com_sound {c = (CIf1 b c)} st st' | BAnd _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
          cif1_equiv = cIf1_congruence b_equiv (optimize_0plus_com_sound c)
      in cif1_equiv st st'
optimize_0plus_com_sound {c = (CWhile b c)} st st'
  with (optimize_0plus_bexp b) proof bprf
    optimize_0plus_com_sound {c = (CWhile b c)} st st' | BTrue =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
      in while_true b_equiv st st'
    optimize_0plus_com_sound {c = (CWhile b c)} st st' | BFalse =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
      in while_false b_equiv st st'
    optimize_0plus_com_sound {c = (CWhile b c)} st st' | BEq _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
          while_equiv = cWhile_congruence b_equiv (optimize_0plus_com_sound c)
      in while_equiv st st'
    optimize_0plus_com_sound {c = (CWhile b c)} st st' | BLe _ _ =
      let b_equiv = \st1 => replace {P=\x => beval st1 b = beval st1 x}
                                    (sym bprf) (optimize_0plus_bexp_sound b st1)
          while_equiv = cWhile_congruence b_equiv (optimize_0plus_com_sound c)
      in while_equiv st st'
    optimize_0plus_com_sound {c = (CWhile b c)} st st' | BNot _ =
      let b_equiv = \st1 =>
                         replace {P=\x => beval st1 b = beval st1 x}
                                 (sym bprf) (optimize_0plus_bexp_sound b st1)
          while_equiv = cWhile_congruence b_equiv (optimize_0plus_com_sound c)
      in while_equiv st st'
    optimize_0plus_com_sound {c = (CWhile b c)} st st' | BAnd _ _ =
      let b_equiv = \st1 =>
                         replace {P=\x => beval st1 b = beval st1 x}
                                 (sym bprf) (optimize_0plus_bexp_sound b st1)
          while_equiv = cWhile_congruence b_equiv (optimize_0plus_com_sound c)
      in while_equiv st st'
optimize_0plus_com_sound {c = (CFor init cond updt body)} st st'
  with (optimize_0plus_bexp cond) proof cond_prf
    optimize_0plus_com_sound {c = (CFor init cond updt body)} st st' | BTrue =
      let cond_equiv = \st1 => cong {f=beval st1} (sym cond_prf)
          while_equiv = trans_cequiv
                          (trans_cequiv
                             (cFor_congruence
                                {cond1=optimize_0plus_bexp cond} {cond2=BTrue}
                                refl_cequiv cond_equiv refl_cequiv refl_cequiv)
                             for_while_equiv)
                          (cSeq_congruence (optimize_0plus_com_sound init)
                                           (while_true btrue_is_true))
          equiv = trans_cequiv (cFor_congruence
                                  refl_cequiv
                                  (optimize_0plus_bexp_sound cond)
                                  refl_cequiv
                                refl_cequiv)
                               while_equiv
      in equiv st st'
    optimize_0plus_com_sound {c = (CFor init cond updt body)} st st' | BFalse =
      let cond_equiv = \st1 => cong {f=beval st1} (sym cond_prf)
          while_equiv = trans_cequiv
                          (trans_cequiv
                             (cFor_congruence
                                {cond1=optimize_0plus_bexp cond} {cond2=BFalse}
                                refl_cequiv cond_equiv refl_cequiv refl_cequiv)
                             for_while_equiv)
                          (cSeq_congruence (optimize_0plus_com_sound init)
                                           (while_false bfalse_is_false))
          equiv = trans_cequiv (cFor_congruence
                                  refl_cequiv
                                  (optimize_0plus_bexp_sound cond)
                                  refl_cequiv
                                  refl_cequiv)
                               (trans_cequiv while_equiv skip_right)
      in equiv st st'
    optimize_0plus_com_sound {c = (CFor init cond updt body)} st st' | BEq _ _ =
      let cond_equiv = trans_bequiv (optimize_0plus_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cFor_congruence (optimize_0plus_com_sound init)
                                  cond_equiv
                                  (optimize_0plus_com_sound updt)
                                  (optimize_0plus_com_sound body)
      in equiv st st'
    optimize_0plus_com_sound {c = (CFor init cond updt body)} st st' | BLe _ _ =
      let cond_equiv = trans_bequiv (optimize_0plus_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cFor_congruence (optimize_0plus_com_sound init)
                                  cond_equiv
                                  (optimize_0plus_com_sound updt)
                                  (optimize_0plus_com_sound body)
      in equiv st st'
    optimize_0plus_com_sound {c = (CFor init cond updt body)} st st' | BNot _ =
      let cond_equiv = trans_bequiv (optimize_0plus_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cFor_congruence (optimize_0plus_com_sound init)
                                  cond_equiv
                                  (optimize_0plus_com_sound updt)
                                  (optimize_0plus_com_sound body)
      in equiv st st'
    optimize_0plus_com_sound {c = (CFor init cond updt body)} st st' | BAnd _ _ =
      let cond_equiv = trans_bequiv (optimize_0plus_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cFor_congruence (optimize_0plus_com_sound init)
                                  cond_equiv
                                  (optimize_0plus_com_sound updt)
                                  (optimize_0plus_com_sound body)
      in equiv st st'
optimize_0plus_com_sound {c = (CRepeat body cond)} st st'
  with (optimize_0plus_bexp cond) proof cond_prf
    optimize_0plus_com_sound {c = (CRepeat body cond)} st st' | BTrue =
      let cond_equiv = trans_bequiv
                         (optimize_0plus_bexp_sound cond)
                         (\st1 => cong {f=beval st1} (sym cond_prf))
          while_equiv = trans_cequiv
                          (cRepeat_congruence (optimize_0plus_com_sound body)
                                              cond_equiv)
                          (trans_cequiv
                             repeat_while_equiv
                             (cSeq_congruence
                                refl_cequiv
                                (while_false bnot_btrue_is_bfalse)))
          equiv = trans_cequiv while_equiv skip_right
      in equiv st st'
    optimize_0plus_com_sound {c = (CRepeat body cond)} st st' | BFalse =
      let cond_equiv = trans_bequiv
                         (optimize_0plus_bexp_sound cond)
                         (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = trans_cequiv
                    (cRepeat_congruence (optimize_0plus_com_sound body)
                                        cond_equiv)
                    (trans_cequiv
                       repeat_while_equiv
                       (cSeq_congruence
                          refl_cequiv
                          (while_true bnot_bfalse_is_btrue)))
      in equiv st st'
    optimize_0plus_com_sound {c = (CRepeat body cond)} st st' | BEq _ _ =
      let cond_equiv = trans_bequiv (optimize_0plus_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cRepeat_congruence (optimize_0plus_com_sound body) cond_equiv
      in equiv st st'
    optimize_0plus_com_sound {c = (CRepeat body cond)} st st' | BLe _ _ =
      let cond_equiv = trans_bequiv (optimize_0plus_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cRepeat_congruence (optimize_0plus_com_sound body) cond_equiv
      in equiv st st'
    optimize_0plus_com_sound {c = (CRepeat body cond)} st st' | BNot _ =
      let cond_equiv = trans_bequiv (optimize_0plus_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cRepeat_congruence (optimize_0plus_com_sound body) cond_equiv
      in equiv st st'
    optimize_0plus_com_sound {c = (CRepeat body cond)} st st' | BAnd _ _ =
      let cond_equiv = trans_bequiv (optimize_0plus_bexp_sound cond)
                                    (\st1 => cong {f=beval st1} (sym cond_prf))
          equiv = cRepeat_congruence (optimize_0plus_com_sound body) cond_equiv
      in equiv st st'


module Stlc

import Expr
import Logic
import Maps

%access public export

%default total

data Ty : Type where
  TyBool : Ty
  TyArrow : Ty -> Ty -> Ty

Uninhabited (TyArrow ty _ = ty) where
  uninhabited Refl impossible

data Tm : Type where
  Var : Id -> Tm
  App : Tm -> Tm -> Tm
  Abs : Id -> Ty -> Tm -> Tm
  Tru : Tm
  Fls : Tm
  Test : Tm -> Tm -> Tm -> Tm

idB : Tm
idB = Abs X TyBool (Var X)

idBB : Tm
idBB = Abs X (TyArrow TyBool TyBool) (Var X)

idBBBB : Tm
idBBBB = Abs X (TyArrow (TyArrow TyBool TyBool) (TyArrow TyBool TyBool)) (Var X)

k : Tm
k = Abs X TyBool (Abs Y TyBool (Var X))

notB : Tm
notB = Abs X TyBool (Test (Var X) Fls Tru)

data Value : Tm -> Type where
  V_Abs : Value (Abs x ty t)
  V_Tru : Value Tru
  V_Fls : Value Fls

subst : (x : Id) -> (s : Tm) -> (t : Tm) -> Tm
subst x s (Var y) with (decEq x y)
  subst x s (Var y) | Yes _ = s
  subst x s (Var y) | No _ = Var y
subst x s (App t1 t2) = App (subst x s t1) (subst x s t2)
subst x s (Abs y ty t) with (decEq x y)
  subst x s (Abs y ty t) | Yes _ = Abs y ty t
  subst x s (Abs y ty t) | No _ = Abs y ty (subst x s t)
subst x s Tru = Tru
subst x s Fls = Fls
subst x s (Test t1 t2 t3) = Test (subst x s t1) (subst x s t2) (subst x s t3)

syntax "<" [x] ":=" [s] ">" [t] = subst x s t

data Substi : (s : Tm) -> (x : Id) -> Tm -> Tm -> Type where
  S_Var1 : Substi s x (Var x) s
  S_Var2 : Not (x = y) -> Substi s x (Var y) (Var y)
  S_App : Substi s x t1 t1' -> Substi s x t2 t2' ->
          Substi s x (App t1 t2) (App t1' t2')
  S_Abs1 : Substi s x (Abs x ty t) (Abs x ty t)
  S_Abs2 : Not (x = y) -> Substi s x t t' ->
           Substi s x (Abs y ty t) (Abs y ty t')
  S_Tru : Substi s x Tru Tru
  S_Fls : Substi s x Fls Fls
  S_Test : Substi s x t1 t1' -> Substi s x t2 t2' -> Substi s x t3 t3' ->
           Substi s x (Test t1 t2 t3) (Test t1' t2' t3')

substi_correct : (subst x s t = t') ↔ (Substi s x t t')
substi_correct = (forward, backward)
where forward : subst x s t = t' -> Substi s x t t'
      forward {x} {t = Var y} prf with (decEq x y)
        forward {x} {t = Var y} prf | Yes prf' = rewrite sym prf
                                                 in rewrite prf'
                                                 in S_Var1
        forward {x} {t = Var y} prf | No contra = rewrite sym prf
                                                  in S_Var2 contra
      forward {x} {s} {t = App t1 t2} prf with (subst x s t1) proof t1_prf
        forward {x} {s} {t = App t1 t2} prf | t1'
          with (subst x s t2) proof t2_prf
            forward {x} {s} {t = App t1 t2} prf | t1' | t2' =
              rewrite sym prf
              in S_App (forward (sym t1_prf)) (forward (sym t2_prf))
      forward {x} {s} {t = Abs y ty t} prf with (decEq x y)
        forward {x} {s} {t = Abs y ty t} prf | Yes prf' =
          rewrite sym prf
          in rewrite prf'
          in S_Abs1
        forward {x} {s} {t = Abs y ty t} prf | No contra
          with (subst x s t) proof t_prf
            forward {x} {s} {t = Abs y ty t} prf | No contra | t' =
              rewrite sym prf
              in S_Abs2 contra (forward (sym t_prf))
      forward {t = Tru} prf = rewrite sym prf in S_Tru
      forward {t = Fls} prf = rewrite sym prf in S_Fls
      forward {x} {s} {t = Test t1 t2 t3} prf with (subst x s t1) proof t1_prf
        forward {x} {s} {t = Test t1 t2 t3} prf | t1'
          with (subst x s t2) proof t2_prf
            forward {x} {s} {t = Test t1 t2 t3} prf | t1' | t2'
              with (subst x s t3) proof t3_prf
                forward {x} {s} {t = Test t1 t2 t3} prf | t1' | t2' | t3' =
                  rewrite sym prf
                  in S_Test (forward (sym t1_prf))
                            (forward (sym t2_prf))
                            (forward (sym t3_prf))
      backward : Substi s x t t' -> subst x s t = t'
      backward {x} S_Var1 with (decEq x x)
        backward {x} S_Var1 | Yes _ = Refl
        backward {x} S_Var1 | No contra = absurd (contra Refl)
      backward {x} {t=Var y} (S_Var2 contra) with (decEq x y)
        backward {x} {t=Var y} (S_Var2 contra) | Yes prf = absurd (contra prf)
        backward {x} {t=Var y} (S_Var2 contra) | No _ = Refl
      backward (S_App s1 s2) = rewrite backward s1
                               in rewrite backward s2
                               in Refl
      backward {x} S_Abs1 with (decEq x x)
        backward {x} S_Abs1 | Yes _ = Refl
        backward {x} S_Abs1 | No contra = absurd (contra Refl)
      backward {x} {t=Abs y _ _} (S_Abs2 contra s) with (decEq x y)
        backward {x} {t=Abs y _ _} (S_Abs2 contra s) | Yes prf =
          absurd (contra prf)
        backward {x} {t=Abs y _ _} (S_Abs2 contra s) | No _ =
          rewrite backward s in Refl
      backward S_Tru = Refl
      backward S_Fls = Refl
      backward (S_Test s1 s2 s3) = rewrite backward s1
                                   in rewrite backward s2
                                   in rewrite backward s3
                                   in Refl

data Step : Tm -> Tm -> Type where
  ST_AppAbs : Value v -> Step (App (Abs x ty t) v) (subst x v t)
  ST_App1 : Step t1 t1' -> Step (App t1 t2) (App t1' t2)
  ST_App2 : Value v1 -> Step t2 t2' -> Step (App v1 t2) (App v1 t2')
  ST_TestTru : Step (Test Tru t1 t2) t1
  ST_TestFls : Step (Test Fls t1 t2) t2
  ST_Test : Step t1 t1' -> Step (Test t1 t2 t3) (Test t1' t2 t3)

Uninhabited (Step Tru _) where
  uninhabited (ST_AppAbs _) impossible
  uninhabited (ST_App1 _) impossible
  uninhabited (ST_App2 _ _) impossible
  uninhabited ST_TestTru impossible
  uninhabited ST_TestFls impossible
  uninhabited (ST_Test _) impossible

Uninhabited (Step Fls _) where
  uninhabited (ST_AppAbs _) impossible
  uninhabited (ST_App1 _) impossible
  uninhabited (ST_App2 _ _) impossible
  uninhabited ST_TestTru impossible
  uninhabited ST_TestFls impossible
  uninhabited (ST_Test _) impossible

Uninhabited (Step (Abs _ _ _) _) where
  uninhabited (ST_AppAbs _) impossible
  uninhabited (ST_App1 _) impossible
  uninhabited (ST_App2 _ _) impossible
  uninhabited ST_TestTru impossible
  uninhabited ST_TestFls impossible
  uninhabited (ST_Test _) impossible

infix 4 -+>

(-+>) : Tm -> Tm -> Type
(-+>) = Step

MultiStep : Tm -> Tm -> Type
MultiStep = Multi Step

infix 4 -+>*

(-+>*) : Tm -> Tm -> Type
(-+>*) = MultiStep

step_example_1 : App Stlc.idBB Stlc.idB -+>* Stlc.idB
step_example_1 = MultiStep (ST_AppAbs V_Abs) MultiRefl

step_example_2 : App Stlc.idBB (App Stlc.idBB Stlc.idB) -+>* Stlc.idB
step_example_2 = MultiStep (ST_App2 V_Abs (ST_AppAbs V_Abs))
               $ MultiStep (ST_AppAbs V_Abs)
               $ MultiRefl

step_example_3 : App (App Stlc.idBB Stlc.notB) Tru -+>* Fls
step_example_3 = MultiStep (ST_App1 (ST_AppAbs V_Abs))
               $ MultiStep (ST_AppAbs V_Tru)
               $ MultiStep ST_TestTru
               $ MultiRefl

step_example_4 : App Stlc.idBB (App Stlc.notB Tru) -+>* Fls
step_example_4 = MultiStep (ST_App2 V_Abs (ST_AppAbs V_Tru))
               $ MultiStep (ST_App2 V_Abs ST_TestTru)
               $ MultiStep (ST_AppAbs V_Fls)
               $ MultiRefl

step_example_5 : App (App Stlc.idBBBB Stlc.idBB) Stlc.idB -+>* Stlc.idB
step_example_5 = MultiStep (ST_App1 (ST_AppAbs V_Abs))
               $ MultiStep (ST_AppAbs V_Abs)
               $ MultiRefl

Context : Type
Context = PartialMap Ty

data HasType : Context -> Tm -> Ty -> Type where
  T_Var : gamma x = Just ty -> HasType gamma (Var x) ty
  T_Abs : HasType (update x ty11 gamma) t12 ty12 ->
          HasType gamma (Abs x ty11 t12) (TyArrow ty11 ty12)
  T_App : HasType gamma t1 (TyArrow ty11 ty12) ->
          HasType gamma t2 ty11 ->
          HasType gamma (App t1 t2) ty12
  T_Tru : HasType gamma Tru TyBool
  T_Fls : HasType gamma Fls TyBool
  T_Test : HasType gamma t1 TyBool ->
           HasType gamma t2 ty ->
           HasType gamma t3 ty ->
           HasType gamma (Test t1 t2 t3) ty

typing_example_1 : HasType Maps.empty
                           (Abs x TyBool (Var x))
                           (TyArrow TyBool TyBool)
typing_example_1 {x} = T_Abs (T_Var (rewrite sym (beq_id_refl x) in Refl))

typing_example_2 : HasType Maps.empty
                           (Abs X TyBool
                                (Abs Y (TyArrow TyBool TyBool)
                                     (App (Var Y) (App (Var Y) (Var X)))))
                           (TyArrow TyBool
                                    (TyArrow (TyArrow TyBool TyBool)
                                             TyBool))
typing_example_2 =
  T_Abs (T_Abs (T_App (T_Var Refl) (T_App (T_Var Refl) (T_Var Refl))))

typing_example_3 : (  ty : Ty
                   ** HasType Maps.empty
                              (Abs X (TyArrow TyBool TyBool)
                                   (Abs Y (TyArrow TyBool TyBool)
                                        (Abs Z TyBool
                                             (App (Var Y)
                                                  (App (Var X) (Var Z))))))
                              ty )
typing_example_3 = ( TyArrow (TyArrow TyBool TyBool)
                             (TyArrow (TyArrow TyBool TyBool)
                                      (TyArrow TyBool TyBool))
                   ** T_Abs
                        (T_Abs (T_Abs (T_App (T_Var Refl)
                                             (T_App (T_Var Refl)
                                                    (T_Var Refl))))))

typing_nonexample_3 : Not (  ty1 : Ty ** ty2 : Ty
                          ** HasType Maps.empty
                                     (Abs X ty1 (App (Var X) (Var X)))
                                     ty2 )
typing_nonexample_3 (_ ** _ ** T_Abs (T_App (T_Var prf1) (T_Var prf2))) =
  absurd (justInjective (trans (sym prf1) prf2))


module Issue1328A
%default total

infix 4 `InCtx`
data InCtx : (a, b : Type) -> Type where

prop0 : a `InCtx` b
prop0 = ?undef_0

prop1 : (`InCtx` b) a
prop1 = ?undef_1

prop2 : (a `InCtx`) b
prop2 = ?undef_2

def0 : (m, n : Integer) -> Integer
def0 m n = m `div` n

def1 : (m, n : Integer) -> Integer
def1 m n = (`div` n) m

def2 : (m, n : Integer) -> Integer
def2 m n = (m `div`) n

infix 4 |-
data (|-) : (a, b : Type) -> Type where

inProp0 : a |- b
inProp0 = ?undef_3

inProp1 : (|- b) a
inProp1 = ?undef_4

inProp2 : (a |-) b
inProp2 = ?undef_5

inDef0 : Nat
inDef0 = 42 + 21

inDef1 : Nat
inDef1 = (+ 21) 42

inDef2 : Nat
inDef2 = (42 +) 21


||| Relationship between sum-types and the monoidal operation on wires
module SumWire

import Data.Vect
import ProcessLib
import Proto
import Primitives
import VertComp

%default total

-- TODO: move these to a util
pi1: (a,b,c) -> a
pi1 (x,y,z) = x
pi2: (a,b,c) -> b
pi2 (x,y,z) = y
pi3: (a,b,c) -> c
pi3 (x,y,z) = z

--------------------------------
--  Split Eithers
--------------------------------

normal: (msg : Req (MkNiche [Down (Either a b)] [Down a, Down b])) ->
        SubProc (MkNiche [Down (Either a b)] [Down a, Down b]) (ProcIF (MkNiche [Down (Either a b)] [Down a, Down b]) msg)
normal (Val (TopInWire Here) x) = Pure Accepted
normal (Conn _ _ _) = Pure Taken
normal (Val (TopInWire (There _)) _) impossible
normal (Val (BotInWire (There (There _))) _) impossible

forward : MessagePID (ProcIF niche_a) ->
          InWire niche_a a ->
          MessagePID (ProcIF niche_b) ->
          InWire niche_b b ->
          Maybe (Req (MkNiche [Down (Either a b)] [Down a, Down b])) ->
          Process (ProcIF (MkNiche [Down (Either a b)] [Down a, Down b]))
                  ()
                  Sent
                  Sent
forward pid_a tar_a pid_b tar_b Nothing = Pure ()
forward pid_a tar_a pid_b tar_b (Just (Conn _ _ _)) = Pure ()
forward pid_a tar_a pid_b tar_b (Just (Val (TopInWire Here) x)) = case x of
  Left l  => do { Request pid_a (Val tar_a l); Pure () }
  Right r => do { Request pid_b (Val tar_b r); Pure () }
forward pid_a tar_a pid_b tar_b (Just (Val (TopInWire (There _)) _))         impossible
forward pid_a tar_a pid_b tar_b (Just (Val (BotInWire (There (There _))) _)) impossible

initResp : Slot a ->
           Slot b ->
           (msg : Req (MkNiche [Down (Either a b)] [Down a, Down b])) ->
           ( SubProc (MkNiche [Down (Either a b)] [Down a, Down b])
                     (ProcIF (MkNiche [Down (Either a b)] [Down a, Down b]) msg)
           , Slot a
           , Slot b )
initResp EmptySlot slot_b    (Conn (BotOutWire Here) pid tar)         = ( Pure ConnAccepted, FullSlot pid tar, slot_b           )
initResp slot_a    EmptySlot (Conn (BotOutWire (There Here)) pid tar) = ( Pure ConnAccepted, slot_a          , FullSlot pid tar )
initResp slot_a    slot_b    (Conn (BotOutWire _) _   _  )            = ( Pure Taken       , slot_a          , slot_b           )
initResp slot_a    slot_b    (Val _ _)                                = ( Pure Error       , slot_a          , slot_b           )
initResp _         _         (Conn (BotOutWire (There (There _))) _ _) impossible
initResp _         _         (Conn (TopOutWire (There _)) _ _)         impossible

splitEither': Slot a -> Slot b -> Hom [Down (Either a b)] [Down a, Down b]
splitEither' sl1@(FullSlot pid_a tar_a) sl2@(FullSlot pid_b tar_b) = do
  r <- Respond normal
  forward pid_a tar_a pid_b tar_b r
  Loop $ splitEither' sl1 sl2
splitEither' {a} {b} slot_a slot_b = do
  Just msg <- Respond $ (\msg => pi1 (initResp slot_a slot_b msg)) | _ => Loop (splitEither' slot_a slot_b)
  Loop $ splitEither' (pi2 $ initResp slot_a slot_b msg) (pi3 $ initResp slot_a slot_b msg)

export splitEither: Hom [Down (Either a b)] [Down a, Down b]
splitEither = splitEither' EmptySlot EmptySlot

------------------------------
--  Join Eithers
------------------------------

respJ : (msg : Req (MkNiche [Down a, Down b] [Down (Either a b)])) ->
        ( SubProc (MkNiche [Down a, Down b] [Down (Either a b)])
                  (ProcIF (MkNiche [Down a, Down b] [Down (Either a b)]) msg)
        , Slot (Either a b) )
respJ (Conn (BotOutWire Here) pid tar) = ( Pure ConnAccepted, FullSlot pid tar )
respJ (Val inWire x)                   = ( Pure Error       , EmptySlot        )
respJ (Conn (BotOutWire (There Here)) _ _)      impossible
respJ (Conn (BotOutWire (There (There _))) _ _) impossible
respJ (Conn (TopOutWire (There (There _))) _ _) impossible

normalJ: MessagePID (ProcIF niche) ->
         InWire niche (Either a b) ->
         (msg : Req (MkNiche [Down a, Down b] [Down (Either a b)])) ->
         ( ProcIF (MkNiche [Down a, Down b] [Down (Either a b)]) msg
         , Process (ProcIF (MkNiche [Down a, Down b] [Down (Either a b)])) () Sent Sent )
normalJ pid tar (Conn _ _ _)                          = ( Taken   , Pure ()                                         )
normalJ pid tar (Val (TopInWire Here) x)              = ( Accepted, do { Request pid (Val tar (Left  x)); Pure () } )
normalJ pid tar (Val (TopInWire (There Here)) x)      = ( Accepted, do { Request pid (Val tar (Right x)); Pure () } )
normalJ pid tar (Val (TopInWire (There (There _))) _) impossible
normalJ pid tar (Val (BotInWire (There _)) _)         impossible

joinEither': Slot (Either a b) -> Hom [Down a, Down b] [Down (Either a b)]
joinEither' slot@(FullSlot pid tar) = do Just msg <- Respond (\msg => Pure $ fst $ normalJ pid tar msg) | _ => Loop (joinEither' slot)
                                         snd $ normalJ pid tar msg
                                         Loop (joinEither' slot)
joinEither' EmptySlot = do Just msg <- Respond (\msg => fst (respJ msg)) | _ => Loop (joinEither' EmptySlot)
                           Loop $ joinEither' $ snd (respJ msg)

export joinEither: Hom [Down a, Down b] [Down (Either a b)]
joinEither = joinEither' EmptySlot

-----------------------------------
--  Symetric monoidal structure
-----------------------------------

-- we get this for free by using {join,split}Either, but would be better to make a primitive

symEither: Either a b -> Either b a
symEither (Left x)  = Right x
symEither (Right x) = Left x

export partial sym: (Show a, Show b) => Hom [Down a, Down b] [Down b, Down a]
sym = joinEither -*- (mkPure "sym: " symEither) -*- splitEither

--------------------------------------
--  Splicing
--------------------------------------

spliceEither: Either a a -> a
spliceEither (Left x)  = x
spliceEither (Right x) = x

export partial splice: Show a => Hom [Down a, Down a] [Down a]
splice = joinEither -*- (mkPure "splice: " spliceEither)


module LightClick.IR.ModuleCentric

import Data.String
import Data.Vect

import Toolkit.Data.DList
import Toolkit.Data.DVect

import Language.SystemVerilog.Gates

import LightClick.Types
import LightClick.Values

%default total

public export
data TyIR = PORT
          | UNIT
          | MODULE
          | CONN
          | DATA
          | CHAN
          | GATE

export
Show TyIR where
  show PORT   = "MTyPORT"
  show UNIT   = "MTyUNIT"
  show MODULE = "MTyMODULE"
  show CONN   = "MTyCONN"
  show DATA   = "MTyDATA"
  show CHAN   = "MTyCHAN"
  show GATE   = "MTyGATE"

public export
data ModuleIR : TyIR -> Type where
  MRef : (name : String) -> (type : TyIR) -> ModuleIR type
  MLet : {term : TyIR} -> (name : String)
      -> (beThis : ModuleIR (term))
      -> (inThis : ModuleIR (expr)) -> ModuleIR (expr)

  MSeq : {a,b : TyIR} -> (doThis   : ModuleIR a)
      -> (thenThis : ModuleIR b) -> ModuleIR b

  MEnd  : ModuleIR UNIT

  MPort : (label : String)
       -> (dir   : Direction)
       -> (type  : ModuleIR DATA) -> ModuleIR PORT

  MModule : {n : Nat} -> Vect (S n) (ModuleIR PORT) -> ModuleIR MODULE

  MDataLogic : ModuleIR DATA
  MDataArray : ModuleIR DATA -> Nat -> ModuleIR DATA
  MDataStruct : {n : Nat} -> Vect (S n) (Pair String (ModuleIR DATA)) -> ModuleIR DATA
  MDataUnion  : {n : Nat} -> Vect (S n) (Pair String (ModuleIR DATA)) -> ModuleIR DATA

  MChan : ModuleIR DATA -> ModuleIR CHAN

  MIDX : (label : String)
      -> ModuleIR MODULE
      -> ModuleIR PORT
      -> ModuleIR PORT

  MConn : {n : Nat}
       -> (cname  : ModuleIR CHAN)
       -> (input  : ModuleIR PORT)
       -> (output : Vect (S n) $ ModuleIR PORT)
       -> ModuleIR CONN

  MNot : ModuleIR CHAN
      -> ModuleIR CHAN
      -> ModuleIR GATE

  MGate : {n : Nat}
       -> TyGateComb
       -> ModuleIR CHAN
       -> Vect (S (S n)) (ModuleIR CHAN)
       -> ModuleIR GATE

  MConnG : ModuleIR CHAN
        -> ModuleIR PORT
        -> ModuleIR CONN

-- go from value (with proof of normal form) to moduleIR
public export
interp : TyValue -> TyIR
interp (PORT x) = PORT
interp UNIT = UNIT
interp (MODULE xs) = MODULE
interp CONN = CONN
interp DATA = DATA
interp CHAN = CHAN
interp GATE = GATE

covering
convert : Value type -> ModuleIR (interp type)
convert (VRef name type) = MRef name (interp type)
convert (VLet name beThis inThis) = MLet name (convert beThis) (convert inThis)
convert (VSeq this thenThis) = MSeq (convert this) (convert thenThis)
convert VEnd = MEnd

convert (VPort label dir type) = MPort label dir (convert type)
convert (VModule x) = MModule $ mapToVect (\p => (convert p)) x

convert VDataLogic = MDataLogic
convert (VDataArray x k) = MDataArray (convert x) k
convert (VDataStruct xs) = MDataStruct $ map (\(l,p) => (l,convert p)) xs
convert (VDataUnion xs) = MDataUnion $ map (\(l,p) => (l,convert p)) xs

convert (VChan x) = MChan (convert x)
convert (VIDX name x y) = MIDX name (convert x) (convert y)

convert (VConnD x y z) = MConn (convert x) (convert y) [convert z]
convert (VConnFO x y z) = MConn (convert x) (convert y) (mapToVect (\p => convert p) z)
convert (VNot o i) = MNot (convert o) (convert i)
convert (VGate ty o ins) = MGate ty (convert o) (map convert ins)
convert (VConnG c idx) = MConnG (convert c) (convert idx)

covering
export
runConvert : Value type -> ModuleIR (interp type)
runConvert = convert

covering
showM : ModuleIR type -> String
showM (MRef name type) =
  "(MRef " <+> show name <+> ")"

showM (MLet x y z) =
   "(MLet "
     <+> show x <+> " "
     <+> showM y <+> " "
     <+> showM z
     <+> ")"

showM (MSeq x y) =
    "(MSeq "
      <+> showM x <+> " "
      <+> showM y
      <+> ")"
showM MEnd = "(MEnd)"

showM (MPort x y z) =
    "(MPort "
      <+> show x <+> " "
      <+> show y <+> " "
      <+> showM z <+> " "
      <+> ")"

showM (MModule x) =
    "(MModule "
      <+> show (map showM x)
      <+> ")"

showM MDataLogic = "(MTyLogic)"

showM (MDataArray x k) =
  "(MTyArray "
    <+> showM x <+> " "
    <+> show k
    <+> ")"

showM (MDataStruct {n} xs) = "(MTyStruct " <+> show ps <+> ")"
  where
    covering
    ps : Vect (S n) String
    ps = map (\(l,c) => "(" <+> show l <+> " " <+> showM c <+> ")") xs

showM (MDataUnion {n} xs) = "(TyUnion " <+> show ps <+> ")"
  where
    covering
    ps : Vect (S n) String
    ps = map (\(l,c) => "(" <+> show l <+> " " <+> showM c <+> ")") xs

showM (MChan x) = "(MChan " <+> showM x <+> ")"

showM (MIDX x y z) =
    "(MIndex "
       <+> show x <+> " "
       <+> showM y <+> " "
       <+> showM z
       <+> ")"

showM (MConn x y ps) =
    "(MDConn "
      <+> showM x <+> " "
      <+> showM y <+> " "
      <+> show (map showM ps)
      <+> ")"

showM (MNot o i)
  = unwords ["(MNot", showM o, showM i, ")"]

showM (MGate ty o ins)
    = unwords ["(MGate", show ty, showM o, ins', ")"]

  where
    covering
    ins' : String
    ins' = unwords $ toList $ map (\c => "(" <+> showM c <+> ")") ins

showM (MConnG c idx)
  = unwords ["(MConnG", showM c, showM idx, ")"]

export
Show (ModuleIR type) where
  show = assert_total showM -- TODO


module Control.Eff.Reader

import Control.Eff.Internal

%default total

public export
data ReaderL : (lbl : k) -> (env : Type) -> (a : Type) -> Type where
  [search lbl]
  Ask : ReaderL lbl env env

public export
Reader : (env,a : Type) -> Type
Reader = ReaderL ()

export
askAt : (0 lbl : k) -> Has (ReaderL lbl env) fs => Eff fs env
askAt lbl = send $ Ask {lbl}

export %inline
ask : Has (Reader env) fs => Eff fs env
ask = askAt ()

export %inline
asksAt : (0 lbl : k) -> Has (ReaderL lbl env) fs => (env -> a) -> Eff fs a
asksAt lbl f = f <$> askAt lbl

export %inline
asks : Has (Reader env) fs => (env -> a) -> Eff fs a
asks f = f <$> ask

--------------------------------------------------------------------------------
--          Running Reader
--------------------------------------------------------------------------------

export
handleReader :  {0 m : Type -> Type}
             -> m env
             -> ReaderL lbl env a
             -> m a
handleReader x Ask = x

unReader : env -> ReaderL lbl env a -> a
unReader ve Ask = ve

export
runReaderAt : (0 lbl : k)
            -> Has (ReaderL lbl env) fs
            => env
            -> Eff fs t
            -> Eff (fs - ReaderL lbl env) t
runReaderAt _ ve = handleRelay pure $ \v,f => f (unReader ve v)

export %inline
runReader : Has (Reader env) fs => env -> Eff fs t -> Eff (fs - Reader env) t
runReader = runReaderAt ()


module DataStore

import Data.List
import Data.Strings
import Data.Vect
import System.REPL

%default total

infixr 5 .+.

data Schema = SChar
            | SString
            | SInt
            | (.+.) Schema Schema

SchemaType : Schema -> Type
SchemaType SChar = Char
SchemaType SString = String
SchemaType SInt = Int
SchemaType (x .+. y) = (SchemaType x, SchemaType y)

parsePrefix : (schema : Schema) -> (inp : String) -> Maybe (SchemaType schema, String)
parsePrefix SChar inp = getSingleQuoted (unpack inp)
  where
    getSingleQuoted : List Char -> Maybe (Char, String)
    getSingleQuoted ('\'' :: xs) = case xs of
                                        (c :: '\'' :: rest) => Just (c, ltrim (pack rest))
                                        _ => Nothing
    getSingleQuoted _ = Nothing
parsePrefix SString inp = getQuoted (unpack inp)
  where
    getQuoted : List Char -> Maybe (String, String)
    getQuoted ('"' :: xs) = case span (/= '"') xs of
                                 (quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest))
                                 _ => Nothing
    getQuoted _ = Nothing
parsePrefix SInt inp = case span isDigit inp of
                            ("", rest) => Nothing
                            (num, rest) => Just (cast num, ltrim rest)
parsePrefix (schemal .+. schemar) inp =
  do (lval, inp') <- parsePrefix schemal inp
     (rval, inp'') <- parsePrefix schemar inp'
     Just ((lval, rval), inp'')

stringToSchema : (schema : Schema) -> (inp : String) -> Maybe (SchemaType schema)
stringToSchema schema inp =
  case parsePrefix schema inp of
       Just (res, "") => Just res
       Just _ => Nothing
       Nothing => Nothing

schemaToString : { schema : Schema } -> SchemaType schema -> String
schemaToString {schema = SChar} item = show item
schemaToString {schema = SString} item = show item
schemaToString {schema = SInt} item = show item
schemaToString {schema = (x .+. y)} (itemx, itemy) =
  schemaToString itemx ++ ", " ++ schemaToString itemy

record DataStore where
  constructor MkData
  schema : Schema
  size : Nat
  items : Vect size (SchemaType schema)

addToStore : (store : DataStore) -> (item : SchemaType (schema store)) -> DataStore
addToStore (MkData schema size items) newItem = MkData _ _ (addItem items)
  where
    addItem : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)
    addItem [] = [newItem]
    addItem (item :: items) = item :: addItem items

getEntry : (store : DataStore) -> (idx : Integer) -> String
getEntry (MkData _ size items) idx = case integerToFin idx size of
                                      Nothing => "invalid index: " ++ show idx
                                      Just idx' => schemaToString (index idx' items)

getAllEntries : (store : DataStore) -> String
getAllEntries store = getAllEntriesHelper (size store) ""
  where
    getAllEntriesHelper : (idx : Nat) -> (results : String) -> String
    getAllEntriesHelper Z results = results
    getAllEntriesHelper (S idx') results = getAllEntriesHelper idx' results ++ "\n" ++ getEntry store (cast idx')

data Command : Schema -> Type where
  SetSchema : (newschema : Schema) -> Command schema
  Add : SchemaType schema -> Command schema
  Get : Maybe Integer -> Command schema
  Size : Command schema
  Quit : Command schema

parseSchema : List String -> Maybe Schema
parseSchema ("Char" :: xs) =
  case xs of
       [] => Just SChar
       _ => case parseSchema xs of
                 Nothing => Nothing
                 Just schema' => Just (SChar .+. schema')
parseSchema ("String" :: xs) =
  case xs of
       [] => Just SString
       _ => case parseSchema xs of
                 Nothing => Nothing
                 Just schema' => Just (SString .+. schema')
parseSchema ("Int" :: xs) =
  case xs of
       [] => Just SInt
       _ => case parseSchema xs of
                 Nothing => Nothing
                 Just schema' => Just (SInt .+. schema')
parseSchema _ = Nothing

parseCommand : (schema : Schema) -> (cmd : String) -> (args : String) -> Maybe (Command schema)
parseCommand schema "add" item = case stringToSchema schema item of
                                      Nothing => Nothing
                                      Just item' => Just (Add item')
parseCommand schema "get" idxStr =
  if idxStr == ""
     then Just (Get Nothing)
     else case all isDigit (unpack idxStr) of
             False => Nothing
             True => Just $ Get (Just (cast idxStr))
parseCommand schema "size" "" = Just Size
parseCommand schema "setschema" newschema =
  case parseSchema (words newschema) of
       Nothing => Nothing
       Just schema => Just (SetSchema schema)
parseCommand schema "quit" "" = Just Quit
parseCommand _ _ _ = Nothing

parse : (schema : Schema) -> (inp : String) -> Maybe (Command schema)
parse schema inp = let (cmd, args) = span (/= ' ') inp in
                       parseCommand schema cmd (ltrim args)

setSchema : (store : DataStore) -> (newschema : Schema) -> Maybe DataStore
setSchema store newschema = case size store of
                                 Z => Just (MkData newschema 0 [])
                                 _ => Nothing

processCommand : (store : DataStore) -> (cmd : Command (schema store)) -> Maybe (String, DataStore)
processCommand store (Add item) = Just ("ID" ++ show (size store) ++ "\n", addToStore store item)
processCommand store (Get idx) =
  case idx of
       Nothing => Just (getAllEntries store ++ "\n", store)
       Just idx' => Just (getEntry store idx' ++ "\n", store)
processCommand store Size = Just (show (size store) ++ "\n", store)
processCommand store (SetSchema schema) =
  case setSchema store schema of
       Nothing => Just ("Cannot update schema - store is possibly not empty\n", store)
       Just store' => Just ("updated schema\n", store')
processCommand store Quit = Nothing

processInput : (store : DataStore) -> (inp : String) -> Maybe (String, DataStore)
processInput store inp =
  case parse (schema store) inp of
       Nothing => Just ("invalid command\n", store)
       Just cmd => processCommand store cmd

partial
main : HasIO io => io ()
main = replWith (MkData (SString .+. SString .+. SInt) 0 []) "Command: " processInput


module Types

import Logic

%access public export

%default total

data Tm : Type where
  Tru : Tm
  Fls : Tm
  Test : Tm -> Tm -> Tm -> Tm
  Zro : Tm
  Scc : Tm -> Tm
  Prd : Tm -> Tm
  IsZro : Tm -> Tm

data BValue : Tm -> Type where
  BV_Tru : BValue Tru
  BV_Fls : BValue Fls

data NValue : Tm -> Type where
  NV_Zro : NValue Zro
  NV_Scc : NValue t -> NValue (Scc t)

Value : (t : Tm) -> Type
Value t = Either (BValue t) (NValue t)

data Step : Tm -> Tm -> Type where
  ST_TestTru : Step (Test Tru t1 t2) t1
  ST_TestFls : Step (Test Fls t1 t2) t2
  ST_Test : Step t1 t1' -> Step (Test t1 t2 t3) (Test t1' t2 t3)
  ST_Scc : Step t1 t1' -> Step (Scc t1) (Scc t1')
  ST_PrdZro : Step (Prd Zro) Zro
  ST_PrdScc : NValue t1 -> Step (Prd (Scc t1)) t1
  ST_Prd : Step t1 t1' -> Step (Prd t1) (Prd t1')
  ST_IsZroZro : Step (IsZro Zro) Tru
  ST_IsZroScc : NValue t1 -> Step (IsZro (Scc t1)) Fls
  ST_IsZro : Step t1 t1' -> Step (IsZro t1) (IsZro t1')

Uninhabited (Step Tru _) where
  uninhabited ST_TestTru impossible
  uninhabited ST_TestFls impossible
  uninhabited (ST_Test _) impossible
  uninhabited (ST_Scc _) impossible
  uninhabited ST_PrdZro impossible
  uninhabited (ST_PrdScc _) impossible
  uninhabited (ST_Prd _) impossible
  uninhabited ST_IsZroZro impossible
  uninhabited (ST_IsZroScc _) impossible
  uninhabited (ST_IsZro _) impossible

Uninhabited (Step Fls _) where
  uninhabited ST_TestTru impossible
  uninhabited ST_TestFls impossible
  uninhabited (ST_Test _) impossible
  uninhabited (ST_Scc _) impossible
  uninhabited ST_PrdZro impossible
  uninhabited (ST_PrdScc _) impossible
  uninhabited (ST_Prd _) impossible
  uninhabited ST_IsZroZro impossible
  uninhabited (ST_IsZroScc _) impossible
  uninhabited (ST_IsZro _) impossible

Uninhabited (Step Zro _) where
  uninhabited ST_TestTru impossible
  uninhabited ST_TestFls impossible
  uninhabited (ST_Test _) impossible
  uninhabited (ST_Scc _) impossible
  uninhabited ST_PrdZro impossible
  uninhabited (ST_PrdScc _) impossible
  uninhabited (ST_Prd _) impossible
  uninhabited ST_IsZroZro impossible
  uninhabited (ST_IsZroScc _) impossible
  uninhabited (ST_IsZro _) impossible

infix 4 -+>

(-+>) : Tm -> Tm -> Type
(-+>) = Step

StepNormalForm : Tm -> Type
StepNormalForm = NormalForm Step

Stuck : (t : Tm) -> Type
Stuck t = (StepNormalForm t, Not (Value t))

some_term_is_stuck : (t : Tm ** Stuck t)
some_term_is_stuck = (IsZro Tru ** ( \(_ ** s) => case s of
                                       ST_IsZro ST_TestTru impossible
                                       ST_IsZro ST_TestFls impossible
                                       ST_IsZro (ST_Test _) impossible
                                       ST_IsZro (ST_Scc _) impossible
                                       ST_IsZro ST_PrdZro impossible
                                       ST_IsZro (ST_PrdScc _) impossible
                                       ST_IsZro (ST_Prd _) impossible
                                       ST_IsZro ST_IsZroZro impossible
                                       ST_IsZro (ST_IsZroScc _) impossible
                                       ST_IsZro (ST_IsZro _) impossible
                                   , \e => case e of
                                       Left BV_Tru impossible
                                       Left BV_Fls impossible
                                       Right NV_Zro impossible
                                       Right (NV_Scc _) impossible ))

value_is_nf : Value t -> StepNormalForm t
value_is_nf (Left BV_Tru) (_ ** s) = absurd s
value_is_nf (Left BV_Fls) (_ ** s) = absurd s
value_is_nf (Right NV_Zro) (_ ** s) = absurd s
value_is_nf (Right (NV_Scc nv)) (Scc t' ** ST_Scc s) =
  value_is_nf (Right nv) (t' ** s)

step_deterministic : Step x y1 -> Step x y2 -> y1 = y2
step_deterministic ST_TestTru ST_TestTru = Refl
step_deterministic ST_TestTru (ST_Test s) = absurd s
step_deterministic ST_TestFls ST_TestFls = Refl
step_deterministic ST_TestFls (ST_Test s) = absurd s
step_deterministic (ST_Test s) ST_TestTru = absurd s
step_deterministic (ST_Test s) ST_TestFls = absurd s
step_deterministic (ST_Test s1) (ST_Test s2) =
  rewrite step_deterministic s1 s2 in Refl
step_deterministic (ST_Scc s1) (ST_Scc s2) =
  rewrite step_deterministic s1 s2 in Refl
step_deterministic ST_PrdZro ST_PrdZro = Refl
step_deterministic ST_PrdZro (ST_Prd s) = absurd s
step_deterministic (ST_PrdScc _) (ST_PrdScc _) = Refl
step_deterministic (ST_PrdScc v) (ST_Prd (ST_Scc {t1'} s)) =
  absurd (value_is_nf (Right v) (t1' ** s))
step_deterministic (ST_Prd s) ST_PrdZro = absurd s
step_deterministic (ST_Prd (ST_Scc {t1'} s)) (ST_PrdScc v) =
  absurd (value_is_nf (Right v) (t1' ** s))
step_deterministic (ST_Prd s1) (ST_Prd s2) =
  rewrite step_deterministic s1 s2 in Refl
step_deterministic ST_IsZroZro ST_IsZroZro = Refl
step_deterministic ST_IsZroZro (ST_IsZro s) = absurd s
step_deterministic (ST_IsZroScc _) (ST_IsZroScc _) = Refl
step_deterministic (ST_IsZroScc v) (ST_IsZro (ST_Scc {t1'} s)) =
  absurd (value_is_nf (Right v) (t1' ** s))
step_deterministic (ST_IsZro s) ST_IsZroZro = absurd s
step_deterministic (ST_IsZro (ST_Scc {t1'} s)) (ST_IsZroScc v) =
  absurd (value_is_nf (Right v) (t1' ** s))
step_deterministic (ST_IsZro s1) (ST_IsZro s2) =
  rewrite step_deterministic s1 s2 in Refl

data Ty : Type where
  TyBool : Ty
  TyNat : Ty

data HasType : Tm -> Ty -> Type where
  T_Tru : Tru `HasType` TyBool
  T_Fls : Fls `HasType` TyBool
  T_Test : t1 `HasType` TyBool -> t2 `HasType` ty -> t3 `HasType` ty ->
           Test t1 t2 t3 `HasType` ty
  T_Zro : Zro `HasType` TyNat
  T_Scc : t `HasType` TyNat -> Scc t `HasType` TyNat
  T_Prd : t `HasType` TyNat -> Prd t `HasType` TyNat
  T_IsZro : t `HasType` TyNat -> IsZro t `HasType` TyBool

Uninhabited (Zro `HasType` TyBool) where
  uninhabited T_Tru impossible
  uninhabited T_Fls impossible
  uninhabited (T_Test _ _ _) impossible
  uninhabited T_Zro impossible
  uninhabited (T_Scc _) impossible
  uninhabited (T_Prd _) impossible
  uninhabited (T_IsZro _) impossible

Uninhabited (Scc _ `HasType` TyBool) where
  uninhabited T_Tru impossible
  uninhabited T_Fls impossible
  uninhabited (T_Test _ _ _) impossible
  uninhabited T_Zro impossible
  uninhabited (T_Scc _) impossible
  uninhabited (T_Prd _) impossible
  uninhabited (T_IsZro _) impossible

Uninhabited (Tru `HasType` TyNat) where
  uninhabited T_Tru impossible
  uninhabited T_Fls impossible
  uninhabited (T_Test _ _ _) impossible
  uninhabited T_Zro impossible
  uninhabited (T_Scc _) impossible
  uninhabited (T_Prd _) impossible
  uninhabited (T_IsZro _) impossible

Uninhabited (Fls `HasType` TyNat) where
  uninhabited T_Tru impossible
  uninhabited T_Fls impossible
  uninhabited (T_Test _ _ _) impossible
  uninhabited T_Zro impossible
  uninhabited (T_Scc _) impossible
  uninhabited (T_Prd _) impossible
  uninhabited (T_IsZro _) impossible

has_type_1 : Test Fls Zro (Scc Zro) `HasType` TyNat
has_type_1 = T_Test T_Fls T_Zro (T_Scc T_Zro)

has_type_not : Not (Test Fls Zro Tru `HasType` TyBool)
has_type_not (T_Test _ T_Tru _) impossible
has_type_not (T_Test _ T_Fls _) impossible
has_type_not (T_Test _ (T_Test _ _ _) _) impossible
has_type_not (T_Test _ T_Zro _) impossible
has_type_not (T_Test _ (T_Scc _) _) impossible
has_type_not (T_Test _ (T_Prd _) _) impossible
has_type_not (T_Test _ (T_IsZro _) _) impossible

scc_hastype_nat__hastype_nat : Scc t `HasType` TyNat -> t `HasType` TyNat
scc_hastype_nat__hastype_nat (T_Scc ty) = ty

bool_cannonical : t `HasType` TyBool -> Value t -> BValue t
bool_cannonical _ (Left bv) = bv
bool_cannonical ty (Right NV_Zro) = absurd ty
bool_cannonical ty (Right (NV_Scc _)) = absurd ty

nat_cannonical : t `HasType` TyNat -> Value t -> NValue t
nat_cannonical ty (Left BV_Tru) = absurd ty
nat_cannonical ty (Left BV_Fls) = absurd ty
nat_cannonical _ (Right bv) = bv

progress : t `HasType` ty -> Either (Value t) (t' ** t -+> t')
progress T_Tru = Left (Left BV_Tru)
progress T_Fls = Left (Left BV_Fls)
progress (T_Test {t2} {t3} ty1 ty2 ty3) = case progress ty1 of
  Left v => case bool_cannonical ty1 v of
    BV_Tru => Right (t2 ** ST_TestTru)
    BV_Fls => Right (t3 ** ST_TestFls)
  Right (t' ** s) => Right (Test t' t2 t3 ** ST_Test s)
progress T_Zro = Left (Right NV_Zro)
progress (T_Scc ty) = case progress ty of
  Left v => Left (Right (NV_Scc (nat_cannonical ty v)))
  Right (t' ** s) => Right (Scc t' ** ST_Scc s)
progress (T_Prd ty) = case progress ty of
  Left v => case nat_cannonical ty v of
    NV_Zro => Right (Zro ** ST_PrdZro)
    NV_Scc {t} nv => Right (t ** ST_PrdScc nv)
  Right (t' ** s) => Right (Prd t' ** ST_Prd s)
progress (T_IsZro ty) = case progress ty of
  Left v => case nat_cannonical ty v of
    NV_Zro => Right (Tru ** ST_IsZroZro)
    NV_Scc nv => Right (Fls ** ST_IsZroScc nv)
  Right (t' ** s) => Right (IsZro t' ** ST_IsZro s)

preservation : t `HasType` ty -> t -+> t' -> t' `HasType` ty
preservation T_Tru s = absurd s
preservation T_Fls s = absurd s
preservation (T_Test _ ty2 _) ST_TestTru = ty2
preservation (T_Test _ _ ty3) ST_TestFls = ty3
preservation (T_Test ty1 ty2 ty3) (ST_Test s) =
  T_Test (preservation ty1 s) ty2 ty3
preservation T_Zro s = absurd s
preservation (T_Scc ty) (ST_Scc s) = T_Scc (preservation ty s)
preservation (T_Prd ty) ST_PrdZro = ty
preservation (T_Prd (T_Scc ty)) (ST_PrdScc _) = ty
preservation (T_Prd ty) (ST_Prd s) = T_Prd (preservation ty s)
preservation (T_IsZro _) ST_IsZroZro = T_Tru
preservation (T_IsZro _) (ST_IsZroScc _) = T_Fls
preservation (T_IsZro ty) (ST_IsZro s) = T_IsZro (preservation ty s)

MultiStep : Relation Tm
MultiStep = Multi Step

infix 4 -+>*

(-+>*) : Relation Tm
(-+>*) = MultiStep

soundness : t `HasType` ty -> t -+>* t' -> Not (Stuck t')
soundness ht MultiRefl = case progress ht of
  Left v => \(_, p) => p v
  Right p => \(nf, _) => nf p
soundness ht (MultiStep once next) = soundness (preservation ht once) next

nvalue_hastype_nat : NValue t -> t `HasType` TyNat
nvalue_hastype_nat NV_Zro = T_Zro
nvalue_hastype_nat (NV_Scc v) = T_Scc (nvalue_hastype_nat v)

subject_expansion : (  t : Tm ** t' : Tm ** ty : Ty
                    ** (t -+> t', t' `HasType` ty, Not (t `HasType` ty)))
subject_expansion = (  Test Tru Zro Tru ** Zro ** TyNat
                    ** (ST_TestTru, T_Zro, \ty => case ty of
                                             T_Test _ _ ty3 => absurd ty3))


module SemVar.Parser

import SemVar.Lexer
import SemVar.Data
import Text.Parser
import Text.Token
import Data.List

import public SemVar.Tokens

%default total

release : Grammar _ SemVarToken True String
release =
  do
    match Hyphen
    match Text

metadata : Grammar _ SemVarToken True String
metadata =
  do
    match Plus
    match Text

dotOrDefault : Grammar _ SemVarToken False Int
dotOrDefault =
  option 0 (
    do
      match Dot
      match Number
  )

version : Grammar _ SemVarToken True Version
version =
  do
    major <- match Number
    minor <- dotOrDefault
    patch <- dotOrDefault
    release <- optional release
    metadata <- optional metadata
    pure (MkVersion major minor patch release metadata)

tilde : Grammar _ SemVarToken True Requirement
tilde =
  do
    match Tilde
    v <- version
    pure $ AND (GTE v) (LT $ nextMinor v)

pin : Grammar _ SemVarToken True Requirement
pin =
  do
    match Caret
    v <- version
    pure $ case v of
      MkVersion 0 0 patch Nothing Nothing =>
        EQ v
      _ =>
        AND (GTE v) (LT $ nextMajor v)

exact : Grammar _ SemVarToken True Requirement
exact =
  do
    ignore $ optional (match CmpEQ)
    v <- version
    pure $ EQ v

gt : Grammar _ SemVarToken True Requirement
gt =
  do
    ignore $ optional (match CmpGT)
    v <- version
    pure $ GT v

lt : Grammar _ SemVarToken True Requirement
lt =
  do
    ignore $ optional (match CmpLT)
    v <- version
    pure $ LT v

gte : Grammar _ SemVarToken True Requirement
gte =
  do
    ignore $ optional (match CmpGTE)
    v <- version
    pure $ GTE v

lte : Grammar _ SemVarToken True Requirement
lte =
  do
    ignore $ optional (match CmpLTE)
    v <- version
    pure $ LTE v

range : Grammar _ SemVarToken True Requirement
range =
  do
    v0 <- version
    ignore $ optional (match Whitespace)
    match Hyphen
    ignore $ optional (match Whitespace)
    v1 <- version
    pure $ AND (GTE v0) (LTE v1)

simpleRequirement : Grammar _ SemVarToken True Requirement
simpleRequirement =
  (
        range
    <|> tilde
    <|> pin
    <|> exact
    <|> gte
    <|> gt
    <|> lte
    <|> lt
  )

conj : Grammar _ SemVarToken True Requirement
conj =
  do
    v0 <- simpleRequirement
    match Whitespace
    v1 <- simpleRequirement
    pure $ AND v0 v1

disjuction : Grammar _ SemVarToken True Requirement
disjuction =
  do
    v0 <- simpleRequirement
    ignore $ optional (match Whitespace)
    ignore $ match Pipe
    ignore $ optional (match Whitespace)
    v1 <- simpleRequirement
    pure $ OR v0 v1

requirement : Grammar _ SemVarToken True Requirement
requirement =
  (
        conj
    <|> disjuction
    <|> simpleRequirement
  )

export
parseVersionToks : List (WithBounds SemVarToken) -> Maybe Version
parseVersionToks toks = case parse version toks of
                      Right (j, []) => Just j
                      _ => Nothing

export
parseRequirementToks : List (WithBounds SemVarToken) -> Maybe Requirement
parseRequirementToks toks = case parse requirement toks of
                      Right (j, []) => Just j
                      _ => Nothing


import Data.List

-- Taken from http://nicolas.biri.name/posts/2016-07-26-union-type-in-idris-part-1.html
data Union : List Type -> Type where
  MemberHere : ty -> Union (ty::ts)
  MemberThere : Union ts -> Union (ty::ts)

member : ty -> {auto e: Elem ty ts} -> Union ts
member x {e = Here} = MemberHere x
member x {e = There later} =
    MemberThere (member x {e = later})

x : Union [String, Nat, List String]
x = member "Ahoy!"

y : Union [String, Nat, List String]
y = member (S Z)


||| Spec: https://webassembly.github.io/spec/core/valid/types.html#external-types
module WebAssembly.Validation.Types.ExternalTypes

import WebAssembly.Structure.Types
import WebAssembly.Validation.Types.Limits
import WebAssembly.Validation.Types.FunctionTypes
import WebAssembly.Validation.Types.TableTypes
import WebAssembly.Validation.Types.MemoryTypes
import WebAssembly.Validation.Types.GlobalTypes

-------------------------------------------------------------------------------
-- Validation Rules
-------------------------------------------------------------------------------

public export
data ValidExternalType : (externType : ExternType) -> Type where
  MkValidExternFunkType   : (externType : ExternType) -> (externType = Func funcType)     -> (ValidFunctionType funcType) -> ValidExternalType externType
  MkValidExternTableType  : (externType : ExternType) -> (externType = Table tableType)   -> (ValidTableType tableType)   -> ValidExternalType externType
  MkValidExternMemType    : (externType : ExternType) -> (externType = Mem memType)       -> (ValidMemoryType memType)    -> ValidExternalType externType
  MkValidExternGlobalType : (externType : ExternType) -> (externType = Global globalType) -> (ValidGlobalType globalType) -> ValidExternalType externType

-------------------------------------------------------------------------------
-- Lemmas about external-type validation
-------------------------------------------------------------------------------

total ext_invalid_func_type : (contra : ValidFunctionType funcType -> Void) -> ValidExternalType (Func funcType) -> Void
ext_invalid_func_type contra (MkValidExternFunkType (Func funcType) Refl x) = contra x
ext_invalid_func_type _ (MkValidExternTableType (Func _) Refl _) impossible
ext_invalid_func_type _ (MkValidExternMemType (Func _) Refl _) impossible
ext_invalid_func_type _ (MkValidExternGlobalType (Func _) Refl _) impossible

total ext_valid_func_type : (prof : ValidFunctionType funcType) -> ValidExternalType (Func funcType)
ext_valid_func_type (MkValidFunctionType funcType)
  = MkValidExternFunkType (Func funcType) Refl (MkValidFunctionType funcType)

total ext_invalid_table_type : (contra : ValidTableType tableType -> Void) -> ValidExternalType (Table tableType) -> Void
ext_invalid_table_type _ (MkValidExternFunkType (Table _) Refl _) impossible
ext_invalid_table_type contra (MkValidExternTableType (Table tableType) Refl x) = contra x
ext_invalid_table_type _ (MkValidExternMemType (Table _) Refl _) impossible
ext_invalid_table_type _ (MkValidExternGlobalType (Table _) Refl _) impossible

total ext_valid_table_type : (prof : ValidTableType tableType) -> ValidExternalType (Table tableType)
ext_valid_table_type (MkValidTableType limits elementType limits_valid)
  = MkValidExternTableType (Table (limits, elementType)) Refl (MkValidTableType limits elementType limits_valid)

total ext_invalid_mem_type : (contra : ValidMemoryType memType -> Void) -> ValidExternalType (Mem memType) -> Void
ext_invalid_mem_type _ (MkValidExternFunkType (Mem _) Refl _) impossible
ext_invalid_mem_type _ (MkValidExternTableType (Mem _) Refl _) impossible
ext_invalid_mem_type contra (MkValidExternMemType (Mem memType) Refl x) = contra x
ext_invalid_mem_type _ (MkValidExternGlobalType (Mem _) Refl _) impossible

total ext_valid_mem_type : (prof : ValidMemoryType memType) -> ValidExternalType (Mem memType)
ext_valid_mem_type (MkValidMemoryType memType limits_valid) = MkValidExternMemType (Mem memType) Refl (MkValidMemoryType memType limits_valid)

total ext_invalid_global_type : (contra : ValidGlobalType globalType -> Void) -> ValidExternalType (Global globalType) -> Void
ext_invalid_global_type _ (MkValidExternFunkType (Global _) Refl _) impossible
ext_invalid_global_type _ (MkValidExternTableType (Global _) Refl _) impossible
ext_invalid_global_type _ (MkValidExternMemType (Global _) Refl _) impossible
ext_invalid_global_type contra (MkValidExternGlobalType (Global globalType) Refl x) = contra x

total ext_valid_global_type : (prof : ValidGlobalType globalType) -> ValidExternalType (Global globalType)
ext_valid_global_type (MkGlobalValidType globalType) = MkValidExternGlobalType (Global globalType) Refl (MkGlobalValidType globalType)

-------------------------------------------------------------------------------
-- Decidablity of Validation
-------------------------------------------------------------------------------

total public export
isValidExternalType : (externType : ExternType) -> Dec (ValidExternalType externType)
isValidExternalType (Func funcType) = case (isFunctionTypeValid funcType) of
  No contra => No (ext_invalid_func_type contra)
  Yes prof  => Yes (ext_valid_func_type prof)
isValidExternalType (Table tableType) = case (isTableTypeValid tableType) of
  No contra => No (ext_invalid_table_type contra)
  Yes prof  => Yes (ext_valid_table_type prof)
isValidExternalType (Mem memType) =  case (isMemoryTypeValid memType) of
  No contra => No (ext_invalid_mem_type contra)
  Yes prof  => Yes (ext_valid_mem_type prof)
isValidExternalType (Global globalType) =  case (isGlobalTypeValid globalType) of
  No contra => No (ext_invalid_global_type contra)
  Yes prof  => Yes (ext_valid_global_type prof)


module Typing.TypeChecking

import Typing.Common
import Typing.Util
import Typing.Unification

export
inferify : Term -> TypeChecker Inferred
export
checkify : Term -> Term -> TypeChecker Term

export
checkifyCaseMotive : CaseMotive -> TypeChecker CaseMotive
export
checkifyPattern : Pattern -> Term -> TypeChecker (Pattern >< Term)
export
checkifyClause : Clause -> CaseMotive -> TypeChecker Clause
export
checkifyClauses : List Clause -> CaseMotive -> TypeChecker (List Clause)

-- Y8Y 8o  0 8YYYY 8YYYY 8YYYo Y8Y 8YYYY 0   0
--  0  8Yo 8 8___  8___  8___P  0  8___  "o o"
--  0  8 Yo8 8"""  8"""  8""Yo  0  8"""    0
-- o8o 0   8 0     8oooo 0   0 o8o 0       0

--         8_   _8 8YYYY YY8YY  o8o
-- ____    8"o_o"8 8___    0   8   8
-- """"    0  8  0 8"""    0   8YYY8
--         0     0 8oooo   0   0   0

inferify (Meta i) = throw $ "The metavariable " ++ show (Meta i)
	++ " appears in checkable code, when it should not."

--         0   0  o8o  8YYYo
-- ____    0   0 8   8 8___P
-- """"    "o o" 8YYY8 8""Yo
--          "8"  0   0 0   0

inferify (Var (Name x0)) = do
	((m,x),t) <- typeInDefinitions x0
	pure $ AbsoluteDottedVar m x <:> t

inferify (Var (Generated x i)) = do
	t <- typeInContext i
	pure $ Var (Generated x i) <:> t

inferify (DottedVar m x) = do
	((m',x'),t) <- dottedTypeInDefinitions m x
	pure $ AbsoluteDottedVar m' x' <:> t

inferify (AbsoluteDottedVar m x) = do
	((m',x'),t) <- absoluteDottedTypeInDefinitions m x
	pure $ AbsoluteDottedVar m' x'<:> t

--          o8o  8o  0 8o  0
-- ____    8   8 8Yo 8 8Yo 8
-- """"    8YYY8 8 Yo8 8 Yo8
--         0   0 0   8 0   8

inferify (Ann m t) = do
	t' <- checkify t Star
	et' <- evaluate t'
	m' <- checkify m et'
	subs <- substitution
	pure $ instantiateMetas subs m' <:> instantiateMetas subs et'

--         oYYYo YY8YY  o8o  8YYYo
-- ____    %___    0   8   8 8___P
-- """"    `"""p   0   8YYY8 8""Yo
--         YoooY   0   0   0 0   0

inferify Star = pure $ Star <:> Star

--         8YYYo Y8Y
-- ____    8___P  0
-- """"    8"""   0
--         0     o8o

inferify (Pi plic arg sc) = do
	arg' <- checkify arg Star
	i <- newName
	case head' (names sc) of
		Nothing => throw "Should not happen"
		Just hsc => do
			ret' <- extendContext [(i, hsc, arg')] $ checkify (instantiate sc [Var (Generated hsc i)]) Star
			let sc' = the (Scope Term Term) $ NewScope (names sc) (abstractOver [i] ret')
			subs <- substitution
			pure $ instantiateMetas subs (Pi plic arg' sc') <:> Star

--         0     o8o  8_   _8
-- ____    0    8   8 8"o_o"8
-- """"    0    8YYY8 0  8  0
--         8ooo 0   0 0     0

inferify (Lam _ _) = throw "Cannot infer the type of a lambda expression."

--          o8o  8YYYo 8YYYo
-- ____    8   8 8___P 8___P
-- """"    8YYY8 8"""  8"""
--         0   0 0     0

inferify (App plic f a) = do
	(f0 <:> t0) <- inferify f
	et0 <- evaluate t0
	(app' <:> t') <- insertImplicits f0 plic et0
	subs <- substitution
	pure $ instantiateMetas subs app' <:> instantiateMetas subs t'
where
	insertImplicits : Term -> Plict -> Term -> TypeChecker Inferred
	insertImplicits f' Expl (Pi Expl arg sc) = do
		earg <- evaluate arg
		a' <- checkify a earg
		pure $ App Expl f' a' <:> instantiate sc [a']
	insertImplicits f' Impl (Pi Impl arg sc) = do
		earg <- evaluate arg
		a' <- checkify a earg
		pure $ App Impl f' a' <:> instantiate sc [a']
	insertImplicits f' Expl (Pi Impl _ sc) = do
		meta <- newMetaVar
		let impla = Meta meta
		let newF' = App Impl f' impla
		newT' <- evaluate (instantiate sc [impla])
		insertImplicits newF' Expl newT'
	insertImplicits _ Impl (Pi Expl _ _)
		= throw $ "Expected an explicit argument but found an implicit argument "
					++ "when applying " ++ show f ++ " to " ++ show a ++ " in "
					++ "the expression " ++ show (App plic f a)
	insertImplicits _ _ t
		= throw $ "Cannot insert implicit arguments for non-function type " ++ show t

--          oYYo _YYY_ 8o  0
-- ____    0   " 0   0 8Yo 8
-- """"    0   , 0   0 8 Yo8
--          YooY "ooo" 0   8

inferify (Con c as) = do
	(unaliasedC,consig) <- typeInSignature c
	(as' <:> ret) <- inferifyConArgs consig as consig
	subs <- substitution
	pure $ instantiateMetas subs (Con unaliasedC as') <:> instantiateMetas subs ret
where
	inferifyConArgs : ConSig Term ->
		List (Plict >< Term) ->
		ConSig Term ->
		TypeChecker (InferredF (List (Plict >< Term)) Term)

	inferifyConArgs _ [] (ConSigNil ret) = pure $ [] <:> ret

	inferifyConArgs consig ((Expl, m) :: ms) (ConSigCons Expl arg sc) = do
		subs <- substitution
		earg <- evaluate (instantiateMetas subs arg)
		m' <- checkify m earg
		(ms' <:> ret) <- inferifyConArgs consig ms (instantiate sc [m])
		pure $ ((Expl,m') :: ms') <:> ret

	inferifyConArgs consig ((Impl, m) :: ms) (ConSigCons Impl arg sc) = do
		subs <- substitution
		earg <- evaluate (instantiateMetas subs arg)
		m' <- checkify m earg
		(ms' <:> ret) <- inferifyConArgs consig ms (instantiate sc [m])
		pure $ ((Impl,m') :: ms') <:> ret

	inferifyConArgs consig ms (ConSigCons Impl _ sc) = do
		meta <- newMetaVar
		let implm = Meta meta
		(ms' <:> ret) <- inferifyConArgs consig ms (instantiate sc [implm])
		pure $ ((Impl,implm) :: ms') <:> ret

	inferifyConArgs consig ((Impl,_) :: _) (ConSigCons Expl _ _)
		= throw $ "Expected an explicit argument but found an implicit argument "
					++ "when checking " ++ show (Con c as)
					++ " matches the signature " ++ showConSig (Var . Name) consig

	inferifyConArgs consig _ _ = do
		let las = length as
		let lsig = conSigLength (Var . Name) consig
		throw $ show c ++ " expects " ++ show lsig ++ " "
				++ (if lsig == 1 then "arg" else "args")
				++ " but was given " ++ show las

--          oYYo  o8o  oYYYo 8YYYY
-- ____    0   " 8   8 %___  8___
-- """"    0   , 8YYY8 `"""p 8"""
--          YooY 0   0 YoooY 8oooo

inferify (Case ms0 mot cs) = do
	mot' <- checkifyCaseMotive mot
	ms0' <- checkifyCaseArgs ms0 mot'
	cs' <- checkifyClauses cs mot'
	ret <- auxMotive ms0' mot'
	subs <- substitution
	pure $ instantiateMetas subs (Case ms0' mot' cs') <:> instantiateMetas subs ret
where
	checkifyCaseArgs : List Term -> CaseMotive -> TypeChecker (List Term)
	checkifyCaseArgs [] (CaseMotiveNil _) = pure []
	checkifyCaseArgs (m :: ms) (CaseMotiveCons a sc) = do
		ea <- evaluate a
		m' <- checkify m ea
		ms' <- checkifyCaseArgs ms (instantiate sc [m])
		pure $ (m' :: ms')
	checkifyCaseArgs _ _ = do
		let lms = length ms0
		let lmot = caseMotiveLength mot
		throw $ "Motive " ++ show mot ++ " expects " ++ show lmot ++ " case "
					++ (if lmot == 1 then "arg" else "args")
					++ " but was given " ++ show lms

	auxMotive : List Term -> CaseMotive -> TypeChecker Term
	auxMotive [] (CaseMotiveNil a) = pure a
	auxMotive (m :: ms) (CaseMotiveCons _ sc) = auxMotive ms (instantiate sc [m])
	auxMotive _ _ = do
		let lms = length ms0
		let lmot = caseMotiveLength mot
		throw $ "Motive " ++ show mot ++ " expects " ++ show lmot ++ " case "
					++ (if lmot == 1 then "arg" else "args")
					++ " but was given " ++ show lms

--         8YYYo 8YYYY  oYYo _YYY_ 8YYYo 8888_ YY8YY 0   0 8YYYo 8YYYY
-- ____    8___P 8___  0   " 0   0 8___P 0   0   0   "o o" 8___P 8___
-- """"    8""Yo 8"""  0   , 0   0 8""Yo 0   0   0     0   8"""  8"""
--         0   0 8oooo  YooY "ooo" 0   0 8oooY   0     0   0     8oooo

inferify (RecordType tele) = do
	tele' <- checkifyTelescope tele
	pure $ RecordType tele' <:> Star
where
	checkifyTelescope : Telescope -> TypeChecker Telescope
	checkifyTelescope TelescopeNil = pure TelescopeNil
	checkifyTelescope (TelescopeCons t sc) = do
		t' <- checkify t Star
		i <- newName
		case head' (names sc) of
			Nothing => throw "Should not happen"
			Just hsc => do
				m' <- extendContext [(i, hsc, t')]
					$ checkifyTelescope (instantiate sc [Var (Generated hsc i)])
				pure $ TelescopeCons t' (NewScope (names sc) (abstractOver [i] m'))

--         8YYYo 8YYYY  oYYo _YYY_ 8YYYo 8888_  oYYo _YYY_ 8o  0
-- ____    8___P 8___  0   " 0   0 8___P 0   0 0   " 0   0 8Yo 8
-- """"    8""Yo 8"""  0   , 0   0 8""Yo 0   0 0   , 0   0 8 Yo8
--         0   0 8oooo  YooY "ooo" 0   0 8oooY  YooY "ooo" 0   8

inferify (RecordCon _) = throw "Cannot infer the type of a record expression."

--         8YYYo 8YYYY  oYYo _YYY_ 8YYYo 8888_ 8888_ _YYY_ YY8YY
-- ____    8___P 8___  0   " 0   0 8___P 0   0 0   0 0   0   0
-- """"    8""Yo 8"""  0   , 0   0 8""Yo 0   0 0   0 0   0   0
--         0   0 8oooo  YooY "ooo" 0   0 8oooY 8oooY "ooo"   0

inferify (Project m x) = do
	(m' <:> t) <- inferify m
	et <- evaluate t
	case et of
		RecordType tele => case lookupField m' x tele of
			Nothing => throw $ "Missing field " ++ x
			Just t' => pure $ Project m' x <:> t'
		t' => throw $ "Expecting a record type but found " ++ show t'
where
	lookupField : Term -> String -> Telescope -> Maybe Term
	lookupField _ _ TelescopeNil = Nothing
	lookupField m' f (TelescopeCons t sc) with (head' $ names sc)
		| Nothing = Nothing
		| Just (hsc) with (f == hsc)
			| True = Just t
			| _    = lookupField m' f $ instantiate sc [Project m' hsc]

--  oYYo 0   0 8YYYY  oYYo 0  oY Y8Y 8YYYY 0   0
-- 0   " 8___8 8___  0   " 8_oY   0  8___  "o o"
-- 0   , 8"""8 8"""  0   , 8"Yo   0  8"""    0
--  YooY 0   0 8oooo  YooY 0  Yo o8o 0       0

--         8_   _8 8YYYY YY8YY  o8o
-- ____    8"o_o"8 8___    0   8   8
-- """"    0  8  0 8"""    0   8YYY8
--         0     0 8oooo   0   0   0

checkify (Meta i) _ = throw $ "The metavariable " ++ show (Meta i)
						++ " appears in checkable code, when it should not."

--         0     o8o  8_   _8          8YYYo Y8Y
-- ____    0    8   8 8"o_o"8    88    8___P  0
-- """"    0    8YYY8 0  8  0          8"""   0
--         8ooo 0   0 0     0    88    0     o8o

checkify (Lam plic sc) t = do
	et <- evaluate t
	case (head' (names sc), plic, et) of
		(Just hsc, Expl, Pi Expl arg sc') => do-- \x -> M : (x : A) -> B
			i <- newName
			eret <- evaluate (instantiate sc' [Var (Generated hsc i)])
			m' <- extendContext [(i, hsc, arg)] $ checkify (instantiate sc [Var (Generated hsc i)]) eret
			subs <- substitution
			pure $ instantiateMetas subs (Lam Expl (NewScope (names sc) (abstractOver [i] m')))
		(Just hsc, Impl, Pi Impl arg sc') => do -- \{y} -> M : {y : A} -> B
			i <- newName
			eret <- evaluate (instantiate sc' [Var (Generated hsc i)])
			m' <- extendContext [(i, hsc, arg)] $ checkify (instantiate sc [Var (Generated hsc i)]) eret
			subs <- substitution
			pure $ instantiateMetas subs (Lam Impl (NewScope (names sc) (abstractOver [i] m')))
		(Just hsc, Expl, Pi Impl arg sc') => do -- \x -> M : {y : A} -> B
			i <- newName
			eret <- evaluate (instantiate sc' [Var (Generated hsc i)])
			f' <- extendContext [(i, hsc, arg)] $ checkify (Lam Expl sc) eret
			subs <- substitution
			pure $ instantiateMetas subs (Lam Impl (NewScope ["_"] (abstractOver (the (List String) []) f')))
		(Just hsc, Impl, Pi Expl _ _) => -- \{y} -> M : (x : A) -> B
			throw $ "Expected an explicit argument but found an implicit argument "
				++ "when checking " ++ show (Lam plic sc)
				++ " matches the signature " ++ show t
		_ => throw $ "Cannot check term: " ++ show (Lam plic sc) ++ "\n"
			++ "Against non-function type: " ++ show t

--          oYYo _YYY_ 8o  0          YY8YY
-- ____    0   " 0   0 8Yo 8    88      0
-- """"    0   , 0   0 8 Yo8            0
--          YooY "ooo" 0   8    88      0

checkify (Con c as) t = do
	(unaliasedC,consig) <- typeInSignature c
	(ats, ret) <- dropConArgs as consig
	unify t ret
	as' <- traverse checkifyConArg ats
	subs <- substitution
	pure $ instantiateMetas subs (Con unaliasedC as')
where
	dropConArgs : List (Plict >< Term) -> ConSig Term ->
		TypeChecker (List ((Plict >< Term) \/ (Plict >< Term >< Term)) >< Term)

	dropConArgs [] (ConSigNil ret) = pure ([], ret)
	dropConArgs ((Expl,m) :: ms) (ConSigCons Expl arg sc) = do
		(ats,ret) <- dropConArgs ms (instantiate sc [m])
		pure (Right (Expl,m,arg) :: ats, ret)
	dropConArgs ((Impl,m) :: ms) (ConSigCons Impl arg sc) = do
		(ats,ret) <- dropConArgs ms (instantiate sc [m])
		pure (Right (Impl,m,arg) :: ats, ret)
	dropConArgs ms (ConSigCons Impl _ sc) = do
		meta <- newMetaVar
		let x = Meta meta
		(ats, ret) <- dropConArgs ms (instantiate sc [x])
		pure (Left (Impl,x) :: ats,ret)
	dropConArgs ((Impl,_) :: _) (ConSigCons Expl _ _)
		= throw $ "Mismatching plicits when checking " ++ show (Con c as)
					++ " has type " ++ show t
	dropConArgs _ _
		= throw $ "Mismatching number of arguments when checking " ++ show (Con c as)
					++ " has type " ++ show t

	checkifyConArg : (Plict >< Term) \/ (Plict >< Term >< Term) -> TypeChecker (Plict >< Term)
	checkifyConArg (Left pm) = pure pm
	checkifyConArg (Right (plic, m, arg)) = do
		subs <- substitution
		earg <- evaluate (instantiateMetas subs arg)
		m' <- checkify m earg
		pure (plic,m')

--         8YYYo 8YYYY  oYYo _YYY_ 8YYYo 8888_
-- ____    8___P 8___  0   " 0   0 8___P 0   0
-- """"    8""Yo 8"""  0   , 0   0 8""Yo 0   0
--         0   0 8oooo  YooY "ooo" 0   0 8oooY

checkify (RecordCon fields) t = case t of
	RecordType tele => do
		fields' <- checkifyFields fields tele
		pure $ RecordCon fields'
	_ => throw $ "Cannot check a record against type " ++ show t
where
	checkifyFields : List (String >< Term) -> Telescope -> TypeChecker (List (String >< Term))
	checkifyFields [] TelescopeNil = pure []
	checkifyFields [] (TelescopeCons _ sc) = throw $ "Missing record field " ++ unwords (names sc)
	checkifyFields _ TelescopeNil = throw $ "Mismatching number of record fields."
	checkifyFields xs (TelescopeCons t' sc) with (head' (names sc))
		| Nothing = throw "Incorrect record field."
		| Just hsc with (extract (\(x',_) => x' == hsc) xs)
			| Nothing = throw $ "Missing record field " ++ unwords (names sc)
			| Just ((x',m),xs') = do
				et' <- evaluate t'
				m' <- checkify m et'
				fields' <- checkifyFields xs' (instantiate sc [m'])
				pure $ (x',m') :: fields'

--          oYYo 8YYYY 8o  0 8YYYY 8YYYo  o8o  0
-- ____    0  __ 8___  8Yo 8 8___  8___P 8   8 0
-- """"    0  "8 8"""  8 Yo8 8"""  8""Yo 8YYY8 0
--          YooY 8oooo 0   8 8oooo 0   0 0   0 8ooo

checkify m t = do
	(m' <:> t') <- inferify m
	et <- evaluate t
	et' <- evaluate t'
	m'' <- subtype m' et' et
	subs <- substitution
	pure $ instantiateMetas subs m''
where
	subtype : Term -> Term -> Term -> TypeChecker Term
	subtype m (Pi Expl a sc) (Pi Expl a' sc') = do
		unify a a'
		subs <- substitution
		i <- newName
		case (head' $ names sc) of
			Just hsc => do
				let b = instantiateMetas subs (instantiate sc [Var (Generated hsc i)])
				let b' = instantiateMetas subs (instantiate sc' [Var (Generated hsc i)])
				subtype m b b'
			Nothing => throw "Should not happen"
	subtype m (Pi Expl a sc) (Pi Impl a' sc')
		= throw $ "The type " ++ show (Pi Expl a sc)
			++ " is not a subtype of " ++ show (Pi Impl a' sc')
	subtype m (Pi Impl a sc) (Pi Expl a' sc') = do
		i <- newMetaVar
		subs <- substitution
		let b = instantiate sc [Meta i]
		subtype (App Impl m (Meta i)) b (Pi Expl a' sc')
	subtype m (Pi Impl a sc) (Pi Impl a' sc') = do
		unify a a'
		i <- newName
		subs <- substitution
		case (head' $ names sc) of
			Just hsc => do
				let b = instantiateMetas subs (instantiate sc [Var (Generated hsc i)])
				let b' = instantiateMetas subs (instantiate sc' [Var (Generated hsc i)])
				subtype m b b'
			Nothing => throw "Should not happen"
	subtype m t t' = do
		unify t t'
		pure m

--  oYYo 0   0 8YYYY  oYYo 0  oY Y8Y 8YYYY 0   0  oYYo  o8o  oYYYo 8YYYY 8_   _8 _YYY_ YY8YY Y8Y 0   0 8YYYY
-- 0   " 8___8 8___  0   " 8_oY   0  8___  "o o" 0   " 8   8 %___  8___  8"o_o"8 0   0   0    0  0   0 8___
-- 0   , 8"""8 8"""  0   , 8"Yo   0  8"""    0   0   , 8YYY8 `"""p 8"""  0  8  0 0   0   0    0  "o o" 8"""
--  YooY 0   0 8oooo  YooY 0  Yo o8o 0       0    YooY 0   0 YoooY 8oooo 0     0 "ooo"   0   o8o  "8"  8oooo

checkifyCaseMotive (CaseMotiveNil a) = do
	a' <- checkify a Star
	pure $ CaseMotiveNil a'
checkifyCaseMotive (CaseMotiveCons a sc) with (head' $ names sc)
	| Just hsc = do
		a' <- checkify a Star
		i <- newName
		b' <- extendContext [(i, hsc, a')]
				$ checkifyCaseMotive (instantiate sc [Var (Generated hsc i)])
		subs <- substitution
		pure $ instantiateMetasCaseMotive subs
			$ CaseMotiveCons a' $ NewScope (names sc) (abstractOver [i] b')
	| Nothing = throw "Should not happen"

--  oYYo 0   0 8YYYY  oYYo 0  oY Y8Y 8YYYY 0   0 8YYYo  o8o  YY8YY YY8YY 8YYYY 8YYYo 8o  0
-- 0   " 8___8 8___  0   " 8_oY   0  8___  "o o" 8___P 8   8   0     0   8___  8___P 8Yo 8
-- 0   , 8"""8 8"""  0   , 8"Yo   0  8"""    0   8"""  8YYY8   0     0   8"""  8""Yo 8 Yo8
--  YooY 0   0 8oooo  YooY 0  Yo o8o 0       0   0     0   0   0     0   8oooo 0   0 0   8

checkifyPattern (VarPat (Name x)) _ = pure (VarPat (Name x), Var (Name x))
checkifyPattern (VarPat (Generated x i)) t = do
	t' <- typeInContext i
	unify t t'
	pure (VarPat (Generated x i), Var (Generated x i))
checkifyPattern (ConPat _ _) Star = throw "Cannot pattern match on a type."
checkifyPattern (ConPat c ps0) t = do
	(unaliasedC,sig) <- typeInSignature c
	(ps',xs,ret) <- checkifyPatConArgs sig ps0 sig
	subs <- substitution
	et <- evaluate (instantiateMetas subs t)
	eret <- evaluate (instantiateMetas subs ret)
	unify et eret
	subs' <- substitution
	pure (instantiateMetasPat subs' (ConPat unaliasedC ps'), instantiateMetas subs' (Con unaliasedC xs))
where
	checkifyPatConArgs : ConSig Term -> List (Plict >< Pattern) ->
		ConSig Term -> TypeChecker (List (Plict >< Pattern) >< List (Plict >< Term) >< Term)
	checkifyPatConArgs _ [] (ConSigNil ret) = pure ([],[],ret)
	checkifyPatConArgs consig ((Expl,p) :: ps) (ConSigCons Expl arg sc') = do
		earg <- evaluate arg
		(p',x) <- checkifyPattern p earg
		(ps', xs, ret) <- checkifyPatConArgs consig ps (instantiate sc' [x])
		pure ((Expl,p') :: ps', (Expl,x) :: xs, ret)
	checkifyPatConArgs consig ((Impl,p) :: ps) (ConSigCons Impl arg sc') = do
		earg <- evaluate arg
		(p',x) <- checkifyPattern p earg
		(ps',xs,ret) <- checkifyPatConArgs consig ps (instantiate sc' [x])
		pure ((Impl,p') :: ps', (Impl,x) :: xs, ret)
	checkifyPatConArgs consig ps (ConSigCons Impl _ sc') = do
		meta <- newMetaVar
		let x = Meta meta
		(ps',xs,ret) <- checkifyPatConArgs consig ps (instantiate sc' [x])
		pure ((Impl,AssertionPat x) :: ps', (Impl,x) :: xs, ret)
	checkifyPatConArgs consig ((Impl,_) :: _) (ConSigCons Expl _ _)
		= throw $ "Expected an explicit argument but found an implicit argument "
					++ "when checking " ++ show (ConPat c ps0)
					++ " matches the signature " ++ showConSig (Var . Name) consig
	checkifyPatConArgs consig _ _ = do
		let lps = length ps0
		let lsig = conSigLength (Var . Name) consig
		throw $ show c ++ " expects " ++ show lsig ++ " case "
				++ (if lsig == 1 then "arg" else "args")
				++ " but was given " ++ show lps
checkifyPattern (AssertionPat m) t = do
	m' <- checkify m t
	subs <- substitution
	let m'' = instantiateMetas subs m'
	pure (AssertionPat m'', m'')
checkifyPattern MakeMeta _ = throw $ show MakeMeta ++ " should not appear in a checkable pattern."

--  oYYo 0   0 8YYYY  oYYo 0  oY Y8Y 8YYYY 0   0  oYYo 0     o8o  0   0 oYYYo 8YYYY
-- 0   " 8___8 8___  0   " 8_oY   0  8___  "o o" 0   " 0    8   8 0   0 %___  8___
-- 0   , 8"""8 8"""  0   , 8"Yo   0  8"""    0   0   , 0    8YYY8 0   0 `"""p 8"""
--  YooY 0   0 8oooo  YooY 0  Yo o8o 0       0    YooY 8ooo 0   0 "ooo" YoooY 8oooo

checkifyClause (NewClause psc sc0) motive = do
	ctx <- Traversable.for (names psc) $ \x => do
		i <- newName
		m <- newMetaVar
		pure (i, x, Meta m)
	let is = [ i | (i,_,_) <- ctx ]
	let xs1 = zipWith Generated (names psc) is
	let xs2 = map Var (removeByDummies (names psc) xs1)
	extendContext ctx $ do
		let ps = instantiate psc xs1
		(ps',ret) <- checkPatternsMotive ps motive
		subs <- substitution
		eret <- evaluate (instantiateMetas subs ret)
		m' <- checkify (instantiate sc0 xs2) eret
		subs' <- substitution
		let ps'' = map (instantiateMetasPat subs') ps'
		let psWithMsToBind = [ p | (MakeMeta, AssertionPat p) <- zip ps ps'' ]
		let msToBind = nub (psWithMsToBind >>= metas)
		newSubs <- Traversable.for msToBind $ \m => do
			i <- newName
			pure (m, Var (Generated ("_" ++ show i) i))
		addSubstitutions newSubs
		subs'' <- substitution
		let newPs = bindersByNewMetas ps (map (instantiateMetasPat subs'') ps'')
		let newVars = newPs >>= patternVars
		let (newNames, newIs) = unzip $ the (List $ String >< Int) $ do
			Generated x i <- newVars | _ => []
			pure (x, i)
		let newM = instantiateMetas subs'' m'
		pure $ NewClause (NewScope newNames (abstractOver newIs newPs))
			$ NewScope (removeByDummies newNames newNames)
				$ abstractOver (removeByDummies newNames newIs) newM
where
	bindersByNewMetas : List Pattern -> List Pattern -> List Pattern
	bindersByNewMetas [] [] = []
	bindersByNewMetas (MakeMeta :: guides) (AssertionPat x :: ps)
		= termToPattern x :: bindersByNewMetas guides ps
	bindersByNewMetas (_ :: guides) (p :: ps) = p :: bindersByNewMetas guides ps

	checkPatternsMotive : List Pattern -> CaseMotive -> TypeChecker (List Pattern >< Term)
	checkPatternsMotive [] (CaseMotiveNil ret) = pure ([],ret)
	checkPatternsMotive (MakeMeta :: ps) (CaseMotiveCons _ sc') = do
		m <- newMetaVar
		(ps',ret) <- checkPatternsMotive ps (instantiate sc' [Meta m])
		pure (AssertionPat (Meta m) :: ps', ret)
	checkPatternsMotive (p :: ps) (CaseMotiveCons arg sc') = do
		earg <- evaluate arg
		(p', x) <- checkifyPattern p earg
		(ps', ret) <- checkPatternsMotive ps (instantiate sc' [x])
		pure (p'::ps', ret )
	checkPatternsMotive _ _ = do
		let lps = length (descope Name psc)
		let lmot = caseMotiveLength motive
		throw $ "Motive " ++ show motive ++ " expects " ++ show lmot ++ " case "
				++ (if lmot == 1 then "arg" else "args")
				++ " but was given " ++ show lps

--  oYYo 0   0 8YYYY  oYYo 0  oY Y8Y 8YYYY 0   0  oYYo 0     o8o  0   0 oYYYo 8YYYY oYYYo
-- 0   " 8___8 8___  0   " 8_oY   0  8___  "o o" 0   " 0    8   8 0   0 %___  8___  %___
-- 0   , 8"""8 8"""  0   , 8"Yo   0  8"""    0   0   , 0    8YYY8 0   0 `"""p 8"""  `"""p
--  YooY 0   0 8oooo  YooY 0  Yo o8o 0       0    YooY 8ooo 0   0 "ooo" YoooY 8oooo YoooY

checkifyClauses [] _ = pure []
checkifyClauses (c :: cs) motive = do
	c' <- checkifyClause c motive
	cs' <- checkifyClauses cs motive
	pure $ c' :: cs'

--  oYYo 0   0 8YYYY  oYYo 0  oY Y8Y 8YYYY 0   0  oYYo _YYY_ 8o  0 oYYYo Y8Y  oYYo
-- 0   " 8___8 8___  0   " 8_oY   0  8___  "o o" 0   " 0   0 8Yo 8 %___   0  0  __
-- 0   , 8"""8 8"""  0   , 8"Yo   0  8"""    0   0   , 0   0 8 Yo8 `"""p  0  0  "8
--  YooY 0   0 8oooo  YooY 0  Yo o8o 0       0    YooY "ooo" 0   8 YoooY o8o  YooY

export
checkifyConSig : ConSig Term -> TypeChecker (ConSig Term)
checkifyConSig (ConSigNil ret) = do
	ret' <- checkify ret Star
	pure $ ConSigNil ret'
checkifyConSig (ConSigCons plic arg sc) with (head' $ names sc)
	| Just hsc = do
		arg' <- checkify arg Star
		i <- newName
		t <- extendContext [(i, hsc, arg')]
				$ checkifyConSig (instantiate sc [Var (Generated hsc i)])
		pure $ ConSigCons plic arg' (NewScope (names sc) (abstractOver [i] t))
	| Nothing = throw "Should not happen"

-- 8YYYo 0   0 8888. 0    Y8Y  oYYo    8YYYY 0   0 8o  0  oYYo YY8YY Y8Y _YYY_ 8o  0 oYYYo
-- 8___P 0   0 8___Y 0     0  0   "    8___  0   0 8Yo 8 0   "   0    0  0   0 8Yo 8 %___
-- 8"""  0   0 8"""o 0     0  0   ,    8"""  0   0 8 Yo8 0   ,   0    0  0   0 8 Yo8 `"""p
-- 0     "ooo" 8ooo" 8ooo o8o  YooY    0     "ooo" 0   8  YooY   0   o8o "ooo" 0   8 YoooY

export
metasSolved : TypeChecker ()
metasSolved = do
	s <- get
	unless (tcNextMeta s == cast (length $ tcSubs s))
		$ throw "Not all metavariables have been solved."

export
check : Term -> Term -> TypeChecker Term
check m t = do
	et <- evaluate t
	m' <- checkify m et
	metasSolved
	subs <- substitution
	pure $ instantiateMetas subs m'

export
infer : Term -> TypeChecker Inferred
infer m = do
	(m' <:> t) <- inferify m
	metasSolved
	subs <- substitution
	et <- evaluate (instantiateMetas subs t)
	pure $ instantiateMetas subs m' <:> et