module Schema

import SQLiteTypes

import Decidable.Equality
import Language.Reflection

%access public export
%default total

%auto_implicits on

infix 5 :::
data Attribute = (:::) String SQLiteType
%name Attribute attr,attr'

getName : Attribute -> String
getName (c:::_) = c

getTy : Attribute -> SQLiteType
getTy (_:::t) = t

attrEta : (attr : Attribute) -> (getName attr ::: getTy attr) = attr
attrEta (x ::: y) = Refl

attrInj : (c ::: t = c' ::: t') -> (c=c', t=t')
attrInj Refl = (Refl, Refl)

-- the first case forces it to get stuck if the constants are not in canonical form
foo : (x : String) -> (y : String) -> Dec (x = y)
foo "" "" = Yes Refl
foo x y with (decEq x y)
  foo x y | Yes _ = Yes (really_believe_me (Refl {x}))
  foo x y | No urgh = No urgh

implementation DecEq Attribute where
  decEq (x ::: y) (z ::: w) with (foo x z, decEq y w)
    decEq (x ::: y) (x ::: y) | (Yes Refl, Yes Refl) = Yes Refl
    decEq (x ::: y) (x ::: w) | (Yes Refl, No prf) = No $ prf . snd . attrInj
    decEq (x ::: y) (z ::: w) | (No prf, _) = No $ prf . fst . attrInj

data Schema = Nil | (::) Attribute Schema
%name Schema s,s'

append : (s1, s2 : Schema) -> Schema
append [] s2 = s2
append (attr :: s) s2 = attr :: (append s s2)

names : Schema -> List String
names [] = []
names ((n ::: _) :: s) = n :: names s

data HasCol : Schema -> Attribute -> Type where
  Here : HasCol (attr::s) attr
  There : HasCol s attr -> HasCol (attr'::s) attr

HasColNotEmpty : HasCol [] a -> Void
HasColNotEmpty Here impossible
HasColNotEmpty (There _) impossible

implementation Uninhabited (HasCol [] a) where
  uninhabited x = HasColNotEmpty x

decHasColLemma :  (HasCol s attr -> Void) ->
                  (attr' = attr -> Void) ->
                  HasCol (attr' :: s) attr -> Void
decHasColLemma h1 h2 Here = h2 Refl
decHasColLemma h1 h2 (There x) = h1 x

decHasCol : (s : Schema) -> (attr : Attribute) -> Dec (HasCol s attr)
decHasCol [] attr = No HasColNotEmpty
decHasCol (attr' :: s) attr with (decEq attr' attr)
  decHasCol (attr' :: s) attr' | (Yes Refl) = Yes Here
  decHasCol (attr' :: s) attr | (No f) with (decHasCol s attr)
    decHasCol (attr' :: s) attr | (No f) | (Yes x) = Yes (There x)
    decHasCol (attr' :: s) attr | (No f) | (No g) = No $ \h => decHasColLemma g f h

data SubSchema : Schema -> Schema -> Type where
  Empty : SubSchema [] s
  Head : (tailSub : SubSchema small large) ->
         (alsoThere : HasCol large attr) ->
         SubSchema (attr :: small) large

HasColNamed : Schema -> String -> Type
HasColNamed s col = (t : SQLiteType ** HasCol s (col ::: t))

decHasColNamed_lemma : ((HasColNamed s col) -> Void) -> ((col' = col) -> Void) ->
                       (t ** HasCol ((col' ::: ty) :: s) (col ::: t)) -> Void
decHasColNamed_lemma notThere notHere (ty ** Here)         = notHere Refl
decHasColNamed_lemma notThere notHere (ty ** (There more)) = notThere (ty ** more)

decHasColNamed : (s : Schema) -> (col : String) -> Dec (HasColNamed s col)
decHasColNamed [] col = No $ \h => HasColNotEmpty (snd h)
decHasColNamed ((col' ::: ty) :: s) col with (decEq col' col)
  decHasColNamed ((col ::: ty) :: s)  col | (Yes Refl) = Yes (ty ** Here)
  decHasColNamed ((col' ::: ty) :: s) col | (No f) with (decHasColNamed s col)
    decHasColNamed ((col' ::: ty) :: s) col | (No f) | (Yes x) =
      Yes (fst x ** There (snd x))
    decHasColNamed ((col' ::: ty) :: s) col | (No f) | (No g) = No (decHasColNamed_lemma g f)

colNames : Schema -> List String
colNames [] = []
colNames ((col ::: _) :: s) = col :: colNames s

data Disjointness : Type where
  Disjoint : Disjointness
  Overlap : (attr : Attribute) -> Disjointness

isDisjoint : (s1, s2 : Schema) -> Disjointness
isDisjoint [] s2 = Disjoint
isDisjoint (attr :: s) s2 with (decHasColNamed s2 (getName attr))
  isDisjoint (attr :: s) s2 | (Yes x) = Overlap attr
  isDisjoint (attr :: s) s2 | (No f) = isDisjoint s s2


import Data.Vect

data WordState: (guesses_remaining: Nat) -> (letters: Nat) -> Type where
  MkWordState: (word: String) -> (missing: Vect letters Char) -> WordState guesses_remaining letters

data Finished: Type where
  Lost: (game: WordState 0 (S letters))   -> Finished
  Won:  (game: WordState (S remaining) 0) -> Finished

data ValidInput: List Char -> Type where
  Letter: (c: Char) -> ValidInput [c]

total emptyNotValidInput : ValidInput [] -> Void
emptyNotValidInput (Letter _) impossible

total tooManyChars : ValidInput (x :: (y :: xs)) -> Void
tooManyChars (Letter _) impossible

total isValidInput: (chars: List Char) -> Dec (ValidInput chars)
isValidInput [] = No emptyNotValidInput
isValidInput (x :: []) = Yes(Letter x)
isValidInput (x :: (y :: xs)) = No tooManyChars

isValidString: (s: String) -> Dec(ValidInput(unpack s))
isValidString s = isValidInput (unpack s)

readGuess: IO (x ** ValidInput x)
readGuess = do
  putStr "Guess: "
  userGuess <- getLine
  case isValidString (toUpper userGuess) of
    (Yes prf) => pure (_ ** prf)
    (No contra) => do
      putStrLn ("Invalid guess = [" ++ userGuess ++"]")
      readGuess

removeElem: (value: a) -> (xs: Vect (S n) a) -> {auto prf: Elem value xs} -> Vect n a
removeElem             value (value :: ys) {prf = Here}          = ys
removeElem {n = Z}     value (y     :: []) {prf = (There later)} = absurd later
removeElem {n = (S k)} value (y     :: ys) {prf = (There later)} = y :: removeElem value ys

processGuess: (letter: Char) ->
              WordState (S guesses) (S letters) ->
              Either (WordState guesses (S letters))
                     (WordState (S guesses) letters)
processGuess letter (MkWordState word missing) = case isElem letter missing of
  (Yes prf) => Right (MkWordState word (removeElem letter missing))
  (No contra) => Left (MkWordState word missing)

game: (state: WordState (S guesses) (S letters)) -> IO Finished
game {guesses} {letters} state = do
  ([input] ** Letter input) <- readGuess
  case processGuess input state of
    (Left l) => do
      putStrLn "Wrong!"
      case guesses of
        Z   => pure (Lost l)
        S k => game l
    (Right r) => do
      putStrLn "Right!"
      case letters of
        Z => pure (Won r)
        (S k) => game r

main: IO ()
main =
  let
    wordToGuess = MkWordState "Test" ['T', 'E', 'S']
  in
    do
      result <- game {guesses=2} wordToGuess
      case result of
        (Lost (MkWordState word missing)) => putStrLn ("You lost. The word was" ++ word)
        (Won game) => putStrLn "You win"


module Toolkit.Data.List.Subset

import Toolkit.Decidable.Informative

%default total

public export
data Subset : (eq   : a -> b -> Type)
           -> (this : List a)
           -> (that : List b)
                   -> Type
  where
    Empty : Subset eq Nil Nil

    EmptyThis : Subset eq Nil xs

    Keep : {eq : a -> b -> Type}
        -> (prf  :        eq  x       y)
        -> (rest : Subset eq    xs      ys)
                -> Subset eq (x::xs) (y::ys)

    Skip : (rest : Subset eq xs     ys)
                -> Subset eq xs (y::ys)

public export
data Error : Type -> Type where
  EmptyThat : Error a
  Fail : a -> Error a
  FailThere : Error a -> Error a

emptyThat : Subset eq (x :: xs) [] -> Void
emptyThat Empty impossible

yesButNo : {eq : a -> b -> Type}
        -> {x : a} -> {xs : List a}
        -> {y : b} -> {ys : List b}
        -> (h : Subset eq     xs       ys -> Void)
        -> (t : Subset eq (x::xs)      ys -> Void)
             -> Subset eq (x::xs) (y::ys)
             -> Void
yesButNo h t (Keep prf rest) = h rest
yesButNo h t (Skip rest) = t rest

justNot : {eq : a -> b -> Type}
       -> {x : a} -> {xs : List a}
       -> {y : b} -> {ys : List b}
       -> (eq x y -> Void)
       -> (Subset eq (x :: xs) ys -> Void   )
       -> Subset eq (x :: xs) (y :: ys)
       -> Void
justNot f g (Keep prf rest) = f prf
justNot f g (Skip rest) = g rest

export
subset : {eq   : a -> b -> Type}
      -> (test : (x : a) -> (y : b) -> DecInfo err (eq x y))
      -> (this : List a)
      -> (that : List b)
              -> DecInfo (Error err) (Subset eq this that)
subset test [] []
  = Yes Empty

subset test [] (x :: xs)
  = Yes EmptyThis

subset test (x :: xs) []
  = No EmptyThat emptyThat

subset test (x :: xs) (y :: ys) with (test x y)
  subset test (x :: xs) (y :: ys) | (Yes prfHere) with (subset test xs ys)
    subset test (x :: xs) (y :: ys) | (Yes prfHere) | (Yes prfThere)
      = Yes (Keep prfHere prfThere)
    subset test (x :: xs) (y :: ys) | (Yes prfHere) | (No msgWhyNot prfWhyNot) with (subset test (x::xs) ys)
      subset test (x :: xs) (y :: ys) | (Yes prfHere) | (No msgWhyNot prfWhyNot) | (Yes prfThere)
        = Yes (Skip prfThere)
      subset test (x :: xs) (y :: ys) | (Yes prfHere) | (No msgWhyNotHere prfWhyNotHere) | (No msgWhyNotThere prfWhyNotThere)
        = No (FailThere msgWhyNotThere)
             (yesButNo prfWhyNotHere prfWhyNotThere)

  subset test (x :: xs) (y :: ys) | (No msgWhyNotHere prfWhyNotHere) with (subset test (x::xs) ys)
    subset test (x :: xs) (y :: ys) | (No msgWhyNotHere prfWhyNotHere) | (Yes prfThere)
      = Yes (Skip prfThere)
    subset test (x :: xs) (y :: ys) | (No msgWhyNotHere prfWhyNotHere) | (No msgWhyNotThere prfWhyNotThere)
      = No (FailThere msgWhyNotThere)
           (justNot prfWhyNotHere prfWhyNotThere)


import Data.Vect

%default total

infix 3 .<=.
(.<=.) : Int -> Int -> Bool
(.<=.) p q = case (p, q) of
  (0, _) => True
  _ => False

countGreater : (thr : Int) -> (ctx : Vect n Int) -> Nat
countGreater thr [] = Z
countGreater thr (x :: xs) with (x .<=. thr)
  countGreater thr (x :: xs) | True = countGreater thr xs
  countGreater thr (x :: xs) | False = S $ countGreater thr xs

-- map a variable from the old context to the erased context
-- where we erase all bindings less than or equal to the threshold
eraseVar : (thr : Int) -> (ctx : Vect n Int) -> Fin n -> Maybe (Fin (countGreater thr ctx))
eraseVar thr (x :: xs) j with (x .<=. thr)
  eraseVar thr (x :: xs) FZ | True = Nothing
  eraseVar thr (x :: xs) FZ | False = Just FZ
  eraseVar thr (x :: xs) (FS i) | True = FS <$> eraseVar thr xs i
  eraseVar thr (x :: xs) (FS i) | False = FS <$> eraseVar thr xs i

boom : Maybe (Fin 1)
boom = eraseVar 0 [0, 1] (FS FZ)


module Example.Qtt.Zero

import Control.Monad.State

import Data.List
import Data.List.Quantifiers

import Data.Maybe

import Syntax.WithProof

%default total

-------------------------
--- Bounded arguments ---
-------------------------

namespace BoundedArgumentW

  total
  head : (l : List a) -> NonEmpty l => a
  head (x::_) = x

namespace BoundedArgumentW_auto

  total
  head : (l : List a) -> {auto _ : NonEmpty l} -> a
  head (x::_) = x

namespace BoundedArgument0_auto

  total
  head : (l : List a) -> {auto 0 _ : NonEmpty l} -> a
  head (x::_) = x

namespace BoundedArgument0

  total
  head : (l : List a) -> (0 _ : NonEmpty l) => a
  head (x::_) = x

------------------------------------
--- Meta-parameters in the "the" ---
------------------------------------

namespace TheUsage

  f : (MonadState Int m, MonadState Nat m, Monad m) => m Integer
  f = put (the Int 0) *> natToInteger <$> get

  Monad m => MonadState a (StateT (a, b) m) where
    get = Builtin.fst <$> get
    put x = put (x, !(snd <$> get))

  Monad m => MonadState b (StateT (a, b) m) where
    get = snd <$> get
    put x = put (!(Builtin.fst <$> get), x)

  f_mono : State (Int, Nat) Integer
  f_mono = f

  f_run : ((Int, Nat), Integer)
  f_run = runState (1, 2) f

---------------------------
--- Proof-carrying code ---
---------------------------

namespace SubsetAsLib

  data Subset : (type : Type)
             -> (pred : type -> Type)
             -> Type
    where
      Element : (value : type)
             -> (0 prf : pred value)
             -> Subset type pred

namespace SubsetAsRecord

  public export
  record Subset type pred where
    constructor Element
    value : type
    0 prf : pred value

namespace FiltersDPair

  filt : (p : a -> Bool) -> List a -> List (x : a ** p x = True)
  filt p [] = []
  filt p (x::xs) = case @@ p x of
    (True  ** prf) => (x ** prf) :: filt p xs
    (False ** _)   => filt p xs

namespace FiltersSubset

  filt : (p : a -> Bool) -> List a -> List $ Subset a (\x => p x = True)
  filt p [] = []
  filt p (x::xs) = case @@ p x of
    (True  ** prf) => Element x prf :: filt p xs
    (False ** _)   => filt p xs

-----------------------
--- Match on erased ---
-----------------------

pushIn : (xs : List a) -> (0 _ : All p xs) -> List $ Subset a p
pushIn []      []      = []
pushIn (x::xs) (p::ps) = Element x p :: pushIn xs ps

---------------------
--- Parametricity ---
---------------------

namespace WithoutAsq

  id : a -> a
  id x = x

namespace WithForall

  id : forall a. a -> a
  id x = x

namespace WithWType

  id : {a : Type} -> a -> a
  id x = x

  nonid : {a : Type} -> a -> a
  nonid {a=Int}    x = x + 1
  nonid {a=String} x = x ++ "a"
  nonid x = x

namespace With0Type

  id : {0 a : Type} -> a -> a
  id x = x

--------------------------------------
--- Need to not to have at runtime ---
--------------------------------------

namespace NotAtRuntime

  -- data Nat = Z | S Nat

  namespace Hiding

    data BNat : Nat -> Type where
      BZ : BNat 0
      B0 : BNat n -> BNat (2*n)
      B1 : BNat n -> BNat (1 + 2*n)

    (+) : BNat n -> BNat m -> BNat (n + m)

    toNat' : {n : Nat} -> BNat n -> Subset Nat (\k => k = n)
    toNat' x = Element n Refl

    toNat : BNat n -> Subset Nat (\k => k = n)
    toNat BZ     = Element 0 Refl
    toNat (B0 x) = let Element s prf = toNat x in
                   Element (2*s) rewrite prf in Refl
    toNat (B1 x) = let Element s prf = toNat x in
                   Element (1 + 2*s) rewrite prf in Refl

  namespace Exposing

    data BNat : Nat -> Type where
      BZ : BNat 0
      B0 : {n : Nat} -> BNat n -> BNat (2*n)
      B1 : {n : Nat} -> BNat n -> BNat (1 + 2*n)

    toNat : BNat n -> Subset Nat (\k => k = n)
    toNat BZ         = Element 0 Refl
    toNat (B0 {n} _) = Element (2*n) Refl
    toNat (B1 {n} _) = Element (1 + 2*n) Refl


-- Non-strictly-positive recursion
data La : Type where
  Lam : (La -> La) -> La

app : La -> La -> La
app (Lam f) x = f x

selfApp : La
selfApp = Lam \x => app x x

om : La
om = app selfApp selfApp


||| An expression language with mechanical proof of type-safety.
|||
||| `Variant` is an expression language supporting Let-bindings, and
||| type unsafe variants.  Standard constructions are used to
||| represent the language as an EDSL, together with proof of progress
||| taken from PLFA Part 2.
|||
||| This module compliments Section 4.1 of the Functional Pearl.
|||
module Razor.Variant

import Razor.Common

%default total

namespace Types

  public export
  data Ty = TyInt
          | TyChar
          | TyVariant (Vect (S n) (Pair String Ty))

namespace Terms
  mutual
    public export
    data Case : (ctxt  : List Ty)
             -> (label : String)
             -> (type  : Ty)
             -> (body  : Ty)
             -> Type
      where
        MkCase : (label  : String)
              -> (branch : Variant (ctxt +=    type) body)
                        -> Case     ctxt label type body

    public export
    data Cases : (ctxt  : List Ty)
              -> (types : Vect (S n) (Pair String Ty))
              -> (body  : Ty)
              -> Type
      where
          Singleton : (branch : Case  g   label  ty   b)
                             -> Cases g [(label, ty)] b

          Extend : (branch : Case  g   label  ty          b)
                -> (rest   : Cases g                 kvs  b)
                          -> Cases g ((label, ty) :: kvs) b

    public export
    data Variant : List Ty -> Ty -> Type where
      -- Let-Binding & Variables
      Var : Elem ty g -> Variant g ty

      Let : {expr, body : Ty}
         -> (this     : Variant        g  expr)
         -> (beInThis : Variant (expr::g) body)
                     -> Variant        g  body

      -- Base Values
      I : Int  -> Variant g TyInt
      C : Char -> Variant g TyChar

      -- Variants & Accessors
      Tag : {kvs : Vect (S n) (Pair String Ty)}
         -> (label : String)
         -> (value : Variant g ty)
         -> (prf   : Elem (label, ty) kvs)
                  -> Variant g (TyVariant kvs)

      Match : {kvs : Vect (S n) (Pair String Ty)}
           -> {b : Ty}
           -> (value : Variant g (TyVariant kvs))
           -> (cases : Cases   g            kvs   b)
                    -> Variant g                  b

namespace Renaming
  public export
  weaken : forall type
         . (Contains  old           type -> Contains  new           type)
        -> (Contains (old += type') type -> Contains (new += type') type)

  weaken func Here         = Here
  weaken func (There rest) = There (func rest)

  mutual
    namespace Case

      public export
      rename : (forall type . Contains old type -> Contains new type)
            -> (forall type, body . Case old label type body
                                 -> Case new label type body)
      rename f (MkCase label branch)
        = MkCase label (rename (weaken f) branch)

    namespace Cases
      public export
      rename : (forall type . Contains (old) type -> Contains (new) type)
            -> (forall types, type . Cases old types type
                                  -> Cases new types type)
      rename f (Singleton branch)
        = Singleton (Case.rename f branch)
      rename f (Extend branch rest)
        = Extend (Case.rename f branch) (rename f rest)

    public export
    rename : (forall type . Contains old type -> Contains new type)
          -> (forall type . Variant  old type -> Variant  new type)
    -- Let-Bindings & Variables
    rename f (Var x) = Var (f x)
    rename f (Let this beInThis)
      = Let (rename f this)
            (rename (weaken f) beInThis)

    -- Base Variables
    rename f (I x) = I x
    rename f (C x) = C x

    -- Variants & Accesors
    rename f (Tag label value prf) = Tag label (rename f value) prf
    rename f (Match value cases) = Match (rename f value)
                                         (Cases.rename f cases)

namespace Substitution
  public export
  weakens : forall old, new
          . (f : forall type
               . Contains old type
              -> Variant  new type)
         -> (forall type . Contains (old += type') type
                        -> Variant  (new += type') type)
  weakens f Here         = Var Here
  weakens f (There rest) = rename There (f rest)

  namespace General
    mutual
      namespace Case
        public export
        subst : (f : forall type
                   . Contains old type
                  -> Variant  new type)
             -> (forall type, body . Case old label type body
                                  -> Case new label type body)
        subst f (MkCase label branch)
          = MkCase label (subst (weakens f) branch)

      namespace Cases
        public export
        subst : (f : forall type
                   . Contains old type
                  -> Variant new type)
             -> (forall types, type . Cases old types type
                                   -> Cases new types type)
        subst f (Singleton branch)
          = Singleton (Case.subst f branch)
        subst f (Extend branch rest)
          = Extend (Case.subst f branch) (subst f rest)

      public export
      subst : (forall type . Contains old type -> Variant new type)
           -> (forall type . Variant  old type -> Variant new type)
      -- Let-Bindings & Variables
      subst f (Var x) = f x
      subst f (Let this beInThis)
        = Let (subst f this) (subst (weakens f) beInThis)

      -- Base Values
      subst f (I x) = I x
      subst f (C x) = C x

      -- Variants & Accessors
      subst f (Tag label value prf)
        = Tag label (subst f value) prf
      subst f (Match value cases)
        = Match (subst f value) (subst f cases)

  namespace Single
    public export
    apply : (this : Variant ctxt typeB)
         -> (idx  : Contains (ctxt += typeB) typeA)
                 -> Variant ctxt typeA
    apply this Here         = this
    apply this (There rest) = Var rest

    public export
    subst : (this   : Variant  ctxt           typeB)
         -> (inThis : Variant (ctxt += typeB) typeA)
                   -> Variant  ctxt           typeA
    subst {ctxt} {typeA} {typeB} this inThis
       = General.subst (apply this) inThis

namespace Values

  public export
  data Value : Variant ctxt type -> Type where
    -- Base Values
    IV : Value (I i)
    CV : Value (C c)

    -- Variants
    MkTagV : {kvs    : Vect (S n) (Pair String Ty)}
          -> {value' : Variant Nil type}
          -> (value  : Value value')
          -> {prf    : Elem (label, type) kvs}
                    -> Value (Tag label value' prf)

namespace Reduction

  namespace Cases
    public export
    data Redux : (value  : Variant g type)
              -> (cases  : Cases g kvs body)
              -> (idx    : Elem (label, type) kvs)
              -> (result : Variant g body)
              -> Type
      where
        ReduceSingleton : {value : Variant g type}
                                -> Value value
                                -> Redux value
                                         (Singleton (MkCase label branch))
                                         Here
                                         (subst value branch)
        ReduceExtend : {value : Variant g type}
                    -> {rest  : Cases g kvs body}
                    -> Value value
                    -> Redux value
                             (Extend (MkCase label branch) rest)
                             Here
                             (Single.subst value branch)
        SkipThis : Redux value rest later result
                -> Redux value
                         (Extend branch rest)
                         (There later)
                         result

  public export
  data Redux : (this, that : Variant ctxt type) -> Type where
    -- Let Bindings
    SimplifyLetValue : Redux this that
                    -> Redux (Let this body)
                             (Let that body)
    ReduceLetBody : Value value
                 -> Redux (Let value body)
                          (subst value body)

    -- Variants & Accessors
    SimplifyTag : {kvs   : Vect (S n) (Pair String Ty)}
               -> {prf   : Elem (label, type) kvs}
               -> (redux : Redux this that)
                        -> Redux (Tag label this prf) (Tag label that prf)

    SimplifyMatchCase : {cases : Cases _ kvs type}
                     -> (redux : Redux this that)
                              -> Redux (Match this cases) (Match that cases)

    ReduceCases : {kvs   : Vect (S n) (Pair String Ty)}
               -> {idx   : Elem (label, type') kvs}
               -> {value : Variant g type'}
               -> {this  : Cases g kvs type}
               -> {that  : Variant g type}
               -> (prf   : Value value)
               -> (redux : Redux value this idx that)
                        -> Redux (Match (Tag label value idx) this)
                                 that

namespace Progress

  public export
  data Progress : (term : Variant Nil type)
                       -> Type
    where
      Done : {term  : Variant Nil type}
          -> (value : Value term)
                   -> Progress term

      Step : {type       : Ty}
          -> {this, that : Variant Nil type}
          -> (step       : Redux this that)
                        -> Progress this

  namespace Cases
    public export
    data Progress : (label : String)
                 -> (value : Variant Nil type)
                 -> (idx   : Elem (label, type) kvs)
                 -> (term  : Cases Nil kvs body)
                 -> Type
      where
        Step : {value : Variant Nil type'}
            -> {idx   : Elem (label, type') kvs}
            -> {cases : Cases Nil kvs type}
            -> {that  : Variant Nil type}
            -> (step  : Redux value cases idx that)
                    -> Progress label value idx cases
  mutual
    namespace Cases
      public export
      progress : {value' : Variant Nil type}
              -> (idx    : Elem (label, type) kvs)
              -> (value  : Value value')
              -> (term   : Cases Nil kvs body)
                        -> Progress label value' idx term
      progress Here value (Singleton (MkCase label branch))
        = Step (ReduceSingleton value)
      progress Here value (Extend (MkCase label branch) rest)
        = Step (ReduceExtend value)
      progress (There later) value (Extend branch rest) with (progress later value rest)
        progress (There later) value (Extend branch rest) | Step step
          = Step (SkipThis step)

    public export
    progress : forall type . (term : Variant Nil type) -> Progress term
    -- Let-Bindings & Variables
    progress (Var _) impossible

    progress (Let this beInThis) with (progress this)
      progress (Let this beInThis) | (Done value) = Step (ReduceLetBody value)
      progress (Let this beInThis) | (Step step) = Step (SimplifyLetValue step)

    -- Base Values
    progress (I x) = Done IV
    progress (C x) = Done CV

    -- Variants & Accessors
    progress (Tag label value prf) with (progress value)
      progress (Tag label value prf) | (Done value') = Done (MkTagV value')
      progress (Tag label value prf) | (Step step) = Step (SimplifyTag step)

    progress (Match value cases) with (progress value)
      progress (Match (Tag label value' prf) cases) | (Done (MkTagV x)) with (progress prf x cases)
        progress (Match (Tag label value' prf) cases) | (Done (MkTagV x)) | (Step step)
          = Step (ReduceCases x step)
      progress (Match value cases) | (Step step) = Step (SimplifyMatchCase step)

namespace Evaluation

  public export
  data Reduces : (this : Variant ctxt type)
              -> (that : Variant ctxt type)
              -> Type
    where
      Refl  : {this : Variant ctxt type}
                   -> Reduces this this
      Trans : {this, that, end : Variant ctxt type}
           -> Redux this that
           -> Reduces that end
           -> Reduces this end

  public export
  data Finished : (term : Variant ctxt type)
                       -> Type
    where
      Normalised : {term : Variant ctxt type}
                -> (this : Value term)
                        -> Finished term
      OOF : Finished term

  public export
  data Evaluate : (term : Variant Nil type) -> Type where
    RunEval : {this, that : Variant Nil type}
           -> (steps      : Inf (Reduces this that))
           -> (result     : Finished that)
                         -> Evaluate this

  public export
  data Fuel = Empty | More (Lazy Fuel)

  public export
  covering
  forever : Fuel
  forever = More forever

  public export
  compute : (fuel : Fuel)
         -> (term : Variant Nil type)
                 -> Evaluate term
  compute Empty term = RunEval Refl OOF
  compute (More fuel) term with (progress term)
    compute (More fuel) term | (Done value) = RunEval Refl (Normalised value)
    compute (More fuel) term | (Step step {that}) with (compute fuel that)
      compute (More fuel) term | (Step step {that = that}) | (RunEval steps result)
        = RunEval (Trans step steps) result

public export
covering
run : (this : Variant Nil type)
           -> Maybe (Subset (Variant Nil type) (Reduces this))
run this with (compute forever this)
  run this | (RunEval steps (Normalised {term} x)) = Just (Element term steps)
  run this | (RunEval steps OOF) = Nothing

namespace Examples

  public export
  ici : Variant Nil (TyVariant [("int", TyInt), ("char", TyChar)])
  ici = Tag "int" (I 1) Here

  public export
  icc : Variant Nil (TyVariant [("int", TyInt), ("char", TyChar)])
  icc = Tag "char" (C 'c') (There Here)

  public export
  iciM : Variant Nil TyInt
  iciM = Match ici (Extend (MkCase "int" (Var Here)) (Singleton (MkCase "char" $ I 2)))

  public export
  iccM : Variant Nil TyInt
  iccM = Match icc (Extend (MkCase "int" $ Var Here) (Singleton (MkCase "char" $ I 2)))

{-
  public export
  snip : Variant Nil TyInt
  snip = (Match (Tag "int" (I 1) Here) (Extend (MkCase "int" (Var Here))
                                       (Singleton (MkCase "char" (I 2)))))
-}


test : Nat -> Int
test n =
  let c = if n == Z then 0 else 1
  in c


-- f1 : (a:Type) -> (x:a) -> (y:x) -> x
-- f1 a x y = y

hej : (tyOp : List Type -> Type) -> Type
hej tyOp = tyOp [Int, Bool]

hej2 : List Type -> Type
hej2 (t :: ts) = t

test21 : Type
test21 = hej2 [Type]  -- test21 == Type

test22 : Type
test22 = hej2 [Int]   -- test22 == Int


module Control.Monad.Indexed

%access public
%default total

class IndexedFunctor (f : Type -> Type -> Type -> Type) where
  imap : (a -> b) -> f i i a -> f i i b

-- fがIndexedFunctorな時点で、fの種は確定すると思うのだが、明示しないと受け付けてくれない...
infixl 2 <:$>
class IndexedFunctor f => IndexedApplicative (f : Type -> Type -> Type -> Type) where
  ipure : a -> f i i a
  (<:$>) : f i i (a -> b) -> f i i a -> f i i b

infixl 2 :>>=
class IndexedApplicative f => IndexedMonad (f : Type -> Type -> Type -> Type) where
  (:>>=) : f j k x -> (x -> f j k a) -> f i k a

iflatten : IndexedMonad f => f i j (f i j a) -> f i j a
iflatten a = a :>>= id

ireturn : IndexedMonad f => a -> f i i a
ireturn = ipure


module Tests.Array

import TypeTrans.Array
import Data.Vect

assertEq : Eq a => (given : a) -> (expected : a) -> IO ()
assertEq g e = if g == e
    then putStrLn "Test Passed"
    else putStrLn "Test Failed"

assertNotEq : Eq a => (given : a) -> (expected : a) -> IO ()
assertNotEq g e = if not (g == e)
    then putStrLn "Test Passed"
    else putStrLn "Test Failed"

assertTrue : Bool -> IO ()
assertTrue b = if b
                then putStrLn "Test Passed"
                else putStrLn "Test Failed"

assertFalse : Bool -> IO ()
assertFalse b = assertTrue (not b)

testRedDim : IO ()
testRedDim = assertEq (redDim arr) reducedArr

  where arr : Array [3, 3] Int
        arr = [[2,3,7], [4,2,6], [5,7,9]]

        reducedArr : Array [9] Int
        reducedArr = [2,3,7,4,2,6,5,7,9]

testIncDim : IO ()
testIncDim = assertEq (incDim arr) incArr

  where arr : Array [2 * 2] Int
        arr = [2, 3, 4, 5]

        incArr : Array [2,2] Int
        incArr = [[2, 3], [4, 5]]

testIncDimFactor : IO ()
testIncDimFactor = assertEq (incDim $ reshapeByFactor 3 arr) incArr

    where arr : Array [3] Int
          arr = [27, 10, 2]

          incArr : Array [3, 1] Int
          incArr = [[27], [10], [2]]

-- Test reducing dimensions, and then increasing
-- results in the same initial Array
testRedInc : IO ()
testRedInc = assertEq (incDim $ redDim arr') arr'

  where arr' : Array [3, 3] Int
        arr' = [[1,3,7], [4,2,6], [5,7,9]]

-- Test increasing dimensions and then reducing
-- results in the same initial Array
testIncRed : IO ()
testIncRed = assertEq (redDim $ incDim $ reshapeByFactor 3 arr) arr

 where
       arr : Array [3] Int
       arr = [27, 10, 2]

{-
testIncFactors : IO ()
testIncFactors = do
    assertTrue res0

  where arr : Array [8] Int
        arr = [1, 2, 3, 4, 5, 6, 7, 8]

        arr0 : Array [1, 8] Int
        arr0 = [[1, 2, 3, 4, 5, 6, 7, 8]]

        res0 : Bool
        res0  with (splitNFactor 0 arr)
                | (_ ** xs) = xs == arr0
-}

testSplitting : IO ()
testSplitting = do
                  printSplitArr
  where

    arr : Array [20] Int
    arr = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20];

    arr2 : (xs ** Array (1::xs) Int)
    arr2 = ([1,1] ** [[[1]]])

    liftArr : Array [S x] Int -> (xs ** Array ((S x)::xs) Int)
    liftArr vs = ([] ** vs)

    printSplitArr : IO()
    printSplitArr with  (liftArr arr)
      | (vs ** xs) = printArrs (splitFactorsGeneric xs) {t=Int}

    test20 : Array (x::xs) t -> IO ()
    test20 a = print "todo"

    test10 : IO ()
    test10 with (arr2)
      | (_ ** xs) = test20 xs


module Data.SOP.NP

import Data.List.Elem
import Data.SOP.Utils
import Data.SOP.Interfaces

import Decidable.Equality

%default total

||| An n-ary product.
|||
||| The product is parameterized by a type constructor f and indexed by a
||| type-level list ks. The length of the list determines the number of
||| elements in the product, and if the i-th element of the list is of type k,
||| then the i-th element of the product is of type f k.
|||
||| Two common instantiations of f are the identity functor I and the constant
||| functor K. For I, the product becomes a heterogeneous list, where the
||| type-level list describes the types of its components.  For K a, the product
||| becomes a homogeneous list, where the contents of the type-level list are
||| ignored, but its length still specifies the number of elements.
|||
||| In the context of the SOP approach to generic programming, an n-ary product
||| describes the structure of the arguments of a single data constructor.
|||
||| Note: `NP_` takes an additional type parameter `k` to simulate
|||       Haskell's kind polymorphism. In theory, this could be left
|||       as an implicit argument. However, type-inference when calling
|||       interface functions like `hpure` was rather poor with `k`
|||       being implicit.
|||
|||       We therefore made `k` explicit and added a type alias `NP`
|||       to be used in those occasions when `k` can be inferred.
|||
||| Examples:
|||
||| ```idris example
||| ex1 : NP I [Char,Bool]
||| ex1 = ['c',False]
|||
||| ex2 : NP (K String) [Char,Bool,Int]
||| ex2 = ["Hello","World","!"]
|||
||| ex3 : NP Maybe [Char,Bool,Int]
||| ex3 = [Just 'x', Nothing, Just 1]
||| ```
public export
data NP_ : (k : Type) -> (f : k -> Type) -> (ks : List k) -> Type where
  Nil  : NP_ k f []
  (::) : (v : f t) -> (vs : NP_ k f ks) -> NP_ k f (t :: ks)

||| Type alias for `NP_` with type parameter `k` being
||| implicit. This reflects the kind-polymorphic data type
||| in Haskell.
public export
NP : {k : Type} -> (f : k -> Type) -> (ks : List k) -> Type
NP = NP_ k

||| Changes an n-ary product to the identity context `I`
||| by adjusting the types of stored values accordingly.
public export
toI : NP_ k f ks -> NP I (map f ks)
toI []       = []
toI (h :: t) = h :: toI t

--------------------------------------------------------------------------------
--          Specialized Interface Functions
--------------------------------------------------------------------------------

||| Specialiced version of `hmap`
public export
mapNP : (fun : forall a . f a -> g a) -> NP f ks -> NP g ks
mapNP fun []        = []
mapNP fun (v :: vs) = fun v :: mapNP fun vs

||| Specialization of `hpure`.
public export
pureNP : {ks : _} -> (forall a . f a) -> NP f ks
pureNP {ks = []}     _ = []
pureNP {ks = _ :: _} f = f :: pureNP f

||| Specialization of `hap`.
public export
hapNP : NP (\a => f a -> g a) ks -> NP f ks -> NP g ks
hapNP []        []        = []
hapNP (f :: fs) (v :: vs) = f v :: hapNP fs vs

||| Specialization of `hfoldl`
public export
foldlNP : (fun : acc -> el -> acc) -> acc -> NP (K el) ks -> acc
foldlNP _   acc []        = acc
foldlNP fun acc (v :: vs) = foldlNP fun (fun acc v) vs

||| Specialization of `hfoldr`
public export
foldrNP : (fun : el -> Lazy acc -> acc) -> Lazy acc -> NP (K el) ks -> acc
foldrNP _   acc []        = acc
foldrNP fun acc (v :: vs) = fun v (foldrNP fun acc vs)

||| Specialization of `hsequence`
public export
sequenceNP : Applicative g => NP (\a => g (f a)) ks -> g (NP f ks)
sequenceNP []        = pure []
sequenceNP (v :: vs) = [| v :: sequenceNP vs |]

||| Specialization of `hcollapse`
public export
collapseNP : NP (K a) ks -> List a
collapseNP []        = []
collapseNP (v :: vs) = v :: collapseNP vs

--------------------------------------------------------------------------------
--          Core Functions
--------------------------------------------------------------------------------

||| Returns the head of a non-empty n-ary product
public export
hd : NP f (k :: ks) -> f k
hd (v :: _) = v

||| Returns the tail of a non-empty n-ary product
public export
tl : NP f (k :: ks) -> NP f ks
tl (_ :: vs) = vs

||| Tries to creates a homogeneous n-ary product of the given
||| shape from a list of values.
public export
fromListNP : NP f ks -> List a -> Maybe (NP (K a) ks)
fromListNP []       []        = Just []
fromListNP []       (_ :: _)  = Nothing
fromListNP (_ :: _) []        = Nothing
fromListNP (_ :: t) (x :: xs) = (x ::) <$> fromListNP t xs

||| Like `fromListNP` but takes the shape from the implicit
||| list of types.
public export
fromList : {ks : _} -> List a -> Maybe (NP (K a) ks)
fromList = fromListNP (pureNP ())

||| Creates a homogeneous n-ary product of the given
||| shape by repeatedly applying a function to a seed value.
public export
unfoldNP : NP f ks -> (s -> (s,a)) -> s -> NP (K a) ks
unfoldNP []       _ _ = []
unfoldNP (_ :: t) g s = let (s2,v) = g s
                         in v :: unfoldNP t g s2

||| Like `unfoldNP` but takes the shape from the implicit
||| list of types.
public export
unfold : {ks : _} -> (s -> (s,a)) -> s -> NP (K a) ks
unfold = unfoldNP (pureNP ())

||| Creates a homogeneous n-ary product of the given
||| shape using an initial value and a function for
||| generating the next value.
public export
iterateNP : NP f ks -> (a -> a) -> a -> NP (K a) ks
iterateNP np f = unfoldNP np (\v => (f v, v))

||| Like `iterate` but takes the shape from the implicit
||| list of types.
public export
iterate : {ks : _} -> (a -> a) -> a -> NP (K a) ks
iterate = iterateNP (pureNP ())

||| A projection of an n-ary product p extracts the
||| value of p at a certain position.
public export
0 Projection : (f : k -> Type) -> (ks : List k) -> (v : k) -> Type
Projection f ks v = NP f ks -> f v

||| The set of projections of an n-ary product `NP f ks` can
||| itself be wrapped in an n-ary product of the same shape.
public export
projections : {ks : _} -> NP (Projection f ks) ks
projections {ks = []}       = []
projections {ks = (_ :: _)} = hd :: mapNP (. tl) projections

--------------------------------------------------------------------------------
--          Accessing Values
--------------------------------------------------------------------------------

||| Access the first element of the given type in
||| an n-ary product
public export
get : (0 t : k) -> {auto prf : Elem t ks} -> NP_ k f ks -> f t
get t {prf = Here}    (v :: _) = v
get t {prf = There _} (_ :: vs) = get t vs

--------------------------------------------------------------------------------
--          Modifying Values
--------------------------------------------------------------------------------

||| Modify a single element of the given type
||| in an n-ary product, thereby possibly changing the
||| types of stored values.
public export
modify :  (fun : f t -> f t')
       -> {auto prf : UpdateOnce t t' ks ks'}
       -> NP_ k f ks
       -> NP_ k f ks'
modify fun {prf = UpdateHere}    (v :: vs) = fun v :: vs
modify fun {prf = UpdateThere _} (v :: vs) = v :: modify fun vs

||| Modify a single element of the given type
||| in an n-ary product by applying an effectful
||| function.
|||
||| This is the effectful version of `modify`.
public export
modifyF :  Functor g
        => (fun : f t -> g (f t'))
        -> {auto prf : UpdateOnce t t' ks ks'}
        -> NP_ k f ks
        -> g (NP_ k f ks')
modifyF fun {prf = UpdateHere}    (v :: vs) = (:: vs) <$> fun v
modifyF fun {prf = UpdateThere _} (v :: vs) = (v ::)  <$> modifyF fun vs

||| Modify several elements of the given type
||| in an n-ary product, thereby possibly changing the
||| types of stored values.
public export
modifyMany :  (fun : f t -> f t')
           -> {auto prf : UpdateMany t t' ks ks'}
           -> NP_ k f ks
           -> NP_ k f ks'
modifyMany f {prf = UMNil}        []      = []
modifyMany f {prf = UMConsSame x} (v::vs) = f v :: modifyMany f vs
modifyMany f {prf = UMConsDiff x} (v::vs) = v   :: modifyMany f vs

||| Modify several elements of the given type
||| in an n-ary product by applying an effectful function.
|||
||| This is the effectful version of `modifyMany`.
public export
modifyManyF :  Applicative g
            => (fun : f t -> g (f t'))
            -> {auto prf : UpdateMany t t' ks ks'}
            -> NP_ k f ks
            -> g (NP_ k f ks')
modifyManyF f {prf = UMNil}        []      = pure []
modifyManyF f {prf = UMConsSame x} (v::vs) = [| f v :: modifyManyF f vs |]
modifyManyF f {prf = UMConsDiff x} (v::vs) = (v ::) <$> modifyManyF f vs

||| Replaces the first element of the given type
||| in an n-ary product, thereby possibly changing the
||| types of stored values.
public export %inline
setAt :  (0 t : k)
      -> (v' : f t')
      -> {auto prf : UpdateOnce t t' ks ks'}
      -> NP_ k f ks
      -> NP_ k f ks'
setAt t v' = modify {t = t} (const v')

||| Replaces several elements of the given type
||| in an n-ary product, thereby possibly changing the
||| types of stored values.
public export %inline
setAtMany :  (0 t : k)
          -> (v' : f t')
          -> {auto prf : UpdateMany t t' ks ks'}
          -> NP_ k f ks
          -> NP_ k f ks'
setAtMany t v' = modifyMany {t = t} (const v')

||| Alias for `setAt` for those occasions when
||| Idris cannot infer the type of the new value.
public export %inline
setAt' :  (0 t  : k)
       -> (0 t' : k)
       -> (v' : f t')
       -> {auto prf : UpdateOnce t t' ks ks'}
       -> NP_ k f ks
       -> NP_ k f ks'
setAt' t _ v' np = setAt t v' np

||| Alias for `setAtMany` for those occasions when
||| Idris cannot infer the type of the new value.
public export %inline
setAtMany' :  (0 t  : k)
           -> (0 t' : k)
           -> (v' : f t')
           -> {auto prf : UpdateMany t t' ks ks'}
           -> NP_ k f ks
           -> NP_ k f ks'
setAtMany' t _ v' np = setAtMany t v' np

--------------------------------------------------------------------------------
--          Narrowing and expanding products
--------------------------------------------------------------------------------

||| Extracts a subset of values from an n-ary product.
||| The values must appear in the same order in both lists.
public export
narrow : NP f ks -> {auto prf: Sublist ks' ks} -> NP f ks'
narrow x         {prf = SLNil}    = []
narrow (v :: vs) {prf = SLSame y} = v :: narrow vs
narrow (_ :: vs) {prf = SLDiff y} = narrow vs

||| Appends two n-ary products.
public export
append : NP f ks -> NP f ks' -> NP f (ks ++ ks')
append []        y = y
append (v :: vs) y = v :: append vs y

||| Expands an n-ary product by filling missing
||| values with the given default-generating function.
public export
expand :  {ks' : List k}
       -> (forall k . f k)
       -> NP f ks
       -> {auto prf : Sublist ks ks'}
       -> NP f ks'
expand f []                         = pureNP f
expand f (v :: vs) {prf = SLSame x} = v :: expand f vs
expand f vs        {prf = SLDiff x} = f :: expand f vs

||| Expands an n-ary product by filling missing
||| values with the given default-generating function.
|||
||| This is the constrained version of `expand`.
public export
cexpand :  (0 c : k -> Type)
        -> (cs : NP c ks')
        => (forall k . c k => f k)
        -> {auto prf : Sublist ks ks'}
        -> NP_ k f ks
        -> NP_ k f ks'
cexpand c {cs = []}   f []                         = []
cexpand c {cs = _::_} f []                         = f :: cexpand c f []
cexpand c {cs = _::_} f (v :: vs) {prf = SLSame x} = v :: cexpand c f vs
cexpand c {cs = _::_} f vs        {prf = SLDiff x} = f :: cexpand c f vs

--------------------------------------------------------------------------------
--          Interface Conversions
--------------------------------------------------------------------------------

||| This is needed to implement `Ord` below.
public export %hint
ordToEqNP : NP (Ord . f) ks -> NP (Eq . f) ks
ordToEqNP = mapNP (\_ => materialize Eq)

||| This is needed to implement `Monoid` below.
public export %hint
monoidToSemigroupNP : NP (Monoid . f) ks -> NP (Semigroup . f) ks
monoidToSemigroupNP = mapNP (\_ => materialize Semigroup)

--------------------------------------------------------------------------------
--          Implementations
--------------------------------------------------------------------------------

public export %inline
HPure k (List k) (NP_ k) where hpure  = pureNP

public export %inline
HFunctor k (List k) (NP_ k) where hmap  = mapNP

public export %inline
HAp k (List k) (NP_ k) (NP_ k) where hap = hapNP

public export %inline
HFold k (List k) (NP_ k) where
  hfoldl = foldlNP
  hfoldr = foldrNP

public export %inline
HCollapse k (List k) (NP_ k) List where hcollapse = collapseNP

public export %inline
HSequence k (List k) (NP_ k) where hsequence = sequenceNP

public export
(all : NP (Eq . f) ks) => Eq (NP_ k f ks) where
  (==) {all = []}     [] []               = True
  (==) {all = _ :: _} (v :: vs) (w :: ws) = v == w && vs == ws

public export
(all : NP (Ord . f) ks) => Ord (NP_ k f ks) where
  compare {all = []}     [] []               = EQ
  compare {all = _ :: _} (v :: vs) (w :: ws) = compare v w <+> compare vs ws

public export
(all : NP (Semigroup . f) ks) => Semigroup (NP_ k f ks) where
  (<+>) {all = []}     [] []               = []
  (<+>) {all = _ :: _} (v :: vs) (w :: ws) = (v <+> w) :: (vs <+> ws)

public export
(all : NP (Monoid . f) ks) => Monoid (NP_ k f ks) where
  neutral {all = []}     = []
  neutral {all = _ :: _} = neutral :: neutral

public export
(all : NP (Show . f) ks) => Show (NP_ k f ks) where
  show =  dispStringList . hcollapse . hcmap (Show . f) show

private
consInjective : Data.SOP.NP.(::) a b = Data.SOP.NP.(::) c d -> (a = c, b = d)
consInjective Refl = (Refl, Refl)

public export
(all : NP (DecEq . f) ks) => DecEq (NP_ k f ks) where
  decEq {all = []}     []        []        = Yes Refl
  decEq {all = _::_} (v::vs) (w::ws) with (decEq v w)
    decEq {all = _::_} (v::vs) (w::ws) | (No contra) =
      No $ contra . fst . consInjective
    decEq {all = _::_} (v::vs) (v::ws) | (Yes Refl) with (decEq vs ws)
      decEq {all = _::_} (v::vs) (v::vs) | (Yes Refl) | (Yes Refl) = Yes Refl
      decEq {all = _::_} (v::vs) (v::ws) | (Yes Refl) | (No contra) =
        No $ contra . snd . consInjective

--------------------------------------------------------------------------------
--          Examples and Tests
--------------------------------------------------------------------------------

Ex1 : NP I [Char,Bool]
Ex1 = ['c',True]

Ex2 : NP Maybe [Int,Int,Int]
Ex2 = [Nothing,Nothing,Just 2]

Ex3 : NP (K String) [Char,Bool,Int]
Ex3 = ["Hello","World","!"]

EqTest1 : Ex1 == Ex1 = True
EqTest1 = Refl

EqTest2 : Ex1 == ['x',False] = False
EqTest2 = Refl

OrdTest1 : compare Ex1 Ex1 = EQ
OrdTest1 = Refl

OrdTest2 : compare Ex1 ['x',False] = LT
OrdTest2 = Refl

HdTest : hd Ex1 = 'c'
HdTest = Refl

TlTest : tl Ex1 = [True]
TlTest = Refl

SemiTest : the (NP I [String]) ["hello"] <+> ["world"] = ["helloworld"]
SemiTest = Refl

NeutralTest : the (NP I [String,List Int]) Prelude.neutral = ["",[]]
NeutralTest = Refl

HMapTest : hmap Just Ex1 = [Just 'c', Just True]
HMapTest = Refl

HCMapRes : NP (K String) [Char,Bool]
HCMapRes = hcmap Show show Ex1

HPureTest : NP Maybe [String,Int]
HPureTest = hpure Nothing

CPureNeutralTest : NP I [String,String]
CPureNeutralTest = hcpure Monoid neutral

Person : (f : Type -> Type) -> Type
Person f = NP f [String,Int]

toPersonMaybe : Person I -> Person Maybe
toPersonMaybe = hmap Just

personShowValues : Person I -> Person (K String)
personShowValues = hcmap Show show

emptyPerson : Person Maybe
emptyPerson = hpure Nothing

fooPerson : Person (K String)
fooPerson = hconst "foo"

Foo : (f : Type -> Type) -> Type
Foo f = NP f [String,String,List Int]

neutralFoo : Foo I
neutralFoo = hcpure Monoid neutral

update : forall a . Maybe a -> I a -> I a
update (Just a) _ = a
update Nothing  a = a

updatePerson : Person (\a => a -> a)
updatePerson = hmap update [Just "foo", Nothing]

updatedPerson : Person I
updatedPerson = hap updatePerson ["bar",12]

seqMaybe : NP Maybe [Int,String] -> Maybe (NP I [Int,String])
seqMaybe = hsequence

htraverseEx : NP (Either String) [Int,String] -> Maybe (NP I [Int,String])
htraverseEx = htraverse (either (const Nothing) Just)

interface Read a where
  read : String -> Maybe a

hctraverseEx : NP Read [Int,String] => NP (K String) [Int,String] -> Maybe (NP I [Int,String])
hctraverseEx = hctraverse Read read

subproductEx : NP I [Int,String,Bool,Maybe Bool] -> NP I [Int,Bool]
subproductEx np = narrow np