module LightClick.DSL.Convert

import Toolkit.Data.DList
import Toolkit.Data.DList.DeBruijn

import Toolkit.Data.Location

import LightClick.Types
import LightClick.Terms
import LightClick.Error

import LightClick.DSL.AST

%default covering

public export
MetaTyCheck : Type -> Type
MetaTyCheck = Either LightClick.Error

convert : (ctxt : Context)
       -> (expr : AST)
       -> MetaTyCheck (type ** Term ctxt type)

expectPort : (ctxt : Context)
          -> (term : AST)
          -> MetaTyCheck (n ** Term ctxt (PORT n))
expectPort ctxt expr with (convert ctxt expr)
  expectPort ctxt expr | (Left l) = Left l
  expectPort ctxt expr | (Right (PORT n ** term)) = Right (n ** term)
  expectPort ctxt expr | (Right (type ** term)) = do
    loc <- getFC term
    Left (MetaTypeMismatch loc (PORT "") type)

checkType : (ctxt : Context)
         -> (type : MTy)
         -> AST
         -> MetaTyCheck (Term ctxt type)
checkType ctxt typeE ast with (convert ctxt ast)
  checkType ctxt typeE ast | (Left l) = Left l
  checkType ctxt typeE ast | (Right (typeG ** term)) with (decEq typeG typeE)
    checkType ctxt typeE ast | (Right (typeE ** term)) | (Yes Refl) = Right term
    checkType ctxt typeE ast | (Right (typeG ** term)) | (No contra) = do
        l <- getFC term
        Left (MetaTypeMismatch l typeE typeG)

doKVConvert : (ctxt : Context)
           -> (type : MTy)
           -> Pair String AST
           -> MetaTyCheck (Pair String (Term ctxt type))
doKVConvert ctxt type (k,v) = do
    v' <- checkType ctxt type v
    Right (k,v')

convertListPort : (ctxt : Context)
               -> (ps : Vect n AST)
               -> MetaTyCheck (ss : Vect n String
                                 **
                                DVect String
                                      (\s => Term ctxt (PORT s))
                                      n
                                      ss)

convertListPort ctxt [] = Right (_ ** Nil)
convertListPort ctxt (x :: xs) with (convert ctxt x)
  convertListPort ctxt (x :: xs) | (Left l) = Left l
  convertListPort ctxt (x :: xs) | (Right (PORT s ** term)) with (convertListPort ctxt xs)
    convertListPort ctxt (x :: xs) | (Right (PORT s ** term)) | (Left l) = Left l
    convertListPort ctxt (x :: xs) | (Right (PORT s ** term)) | (Right (ss ** ports)) = Right (s::ss ** term::ports)

  convertListPort ctxt (x :: xs) | (Right (type ** term)) = do
      loc <- getFC term
      Left (MetaTypeConstructionError loc (PORT "") type)

convertListPortM : (ctxt : Context)
                -> (ps : Vect (S n) AST)
                -> MetaTyCheck (ss : Vect (S n) String
                                 **
                                 DVect String
                                       (\s => Term ctxt (PORT s)) (S n)
                                       ss)
convertListPortM = convertListPort

convertListPortF : (ctxt : Context)
                -> (ps : Vect (S (S n)) AST)
                -> MetaTyCheck (ss : Vect (S (S n)) String
                                 **
                                 DVect String
                                       (\s => Term ctxt (PORT s)) (S (S n))
                                       ss)
convertListPortF = convertListPort

genIndex : (fc : FileContext)
        -> (ctxt : Context)
        -> (label : String)
        -> MetaTyCheck (type ** Index ctxt (label,type))
genIndex fc [] label =
  Left (IdentifierNotFound fc label)
genIndex fc ((x,t) :: xs) label with (decEq label x)
  genIndex fc ((x,t) :: xs) x | (Yes Refl) = Right (t ** Here)
  genIndex fc ((x,t) :: xs) label | (No contra) with (genIndex fc xs label)
    genIndex fc ((x,t) :: xs) label | (No contra) | (Left l) = Left l
    genIndex fc ((x,t) :: xs) label | (No contra) | (Right (type ** prf)) = Right (type ** There prf)

convert ctxt (Ref fc x) with (genIndex fc ctxt x)
  convert ctxt (Ref fc x) | (Left l) = Left l
  convert ctxt (Ref fc x) | (Right (type ** idx)) =
      Right (type ** Ref fc idx)

convert ctxt (Bind fc name expr body) with (genIndex fc ctxt name)
  convert ctxt (Bind fc name expr body) | (Left l) = do
    expr' <- convert ctxt expr
    body' <- convert ((name, fst expr')::ctxt) body
    Right (fst body' ** Let fc name (snd expr') (snd body'))
  convert ctxt (Bind fc name expr body) | (Right r) =
    Left (IdentifierAlreadyExists fc name)

convert ctxt (Seq exprA exprB) = do
   exprA' <- convert ctxt exprA
   exprB' <- convert ctxt exprB
   Right (fst exprB' ** Seq (snd exprA') (snd exprB'))

convert ctxt (DataLogic fc)      = Right (DATA ** DataLogic fc)

convert ctxt (DataArray fc ty l) = do
  term <- checkType ctxt DATA ty
  Right (DATA ** DataArray fc term l)

convert ctxt (DataStruct fc kvs) = do
    kvs' <- traverse (doKVConvert ctxt DATA) kvs
    Right (DATA ** DataStruct fc kvs')

convert ctxt (DataUnion fc kvs) = do
    kvs' <- traverse (doKVConvert ctxt DATA) kvs
    Right (DATA ** DataUnion fc kvs')

convert ctxt (Port fc l d s w t) = do
  dataType <- checkType ctxt DATA t
  Right (PORT l ** Port fc l d s w dataType)

convert ctxt (ModuleDef fc ps) = do
  ps' <- convertListPortM ctxt ps
  Right (MODULE (fst ps') ** Module fc $ snd ps')

convert ctxt (Index fc x b) with (convert ctxt x)
  convert ctxt (Index fc x b) | (Left l) = Left l
  convert ctxt (Index fc x b) | (Right (MODULE ns ** term)) with (isElem b ns)
    convert ctxt (Index fc x b) | (Right (MODULE ns ** term)) | (Yes prf) = Right (_ ** Index fc term prf)
    convert ctxt (Index fc x b) | (Right (MODULE ns ** term)) | (No contra) = do
      Left (InvalidModuleIndex fc b ns)

  convert ctxt (Index fc x b) | (Right (type ** term)) =
     Left (MetaTypeConstructionError fc (MODULE [""]) type)

convert ctxt (Connect fc x y) = do
  x' <- expectPort ctxt x
  y' <- expectPort ctxt y
  Right (CONN ** Connect fc (snd x') (snd y'))

convert ctxt (FanOut fc w ws) = do
   w'  <- expectPort ctxt w
   ws' <- convertListPortF ctxt ws
   Right (CONN ** FanOut fc (snd w') (snd ws'))

convert ctxt (Mux fc fan ctrl out) = do
  fan' <- convertListPortF ctxt fan
  ctrl' <- expectPort ctxt ctrl
  out'  <- expectPort ctxt out
  Right (CONN ** Mux fc (snd fan') (snd ctrl') (snd out'))

convert ctxt (NOT fc i o)
  = do x' <- expectPort ctxt i
       y' <- expectPort ctxt o
       Right (GATE ** NOT fc (snd x') (snd y'))

convert ctxt (GATE fc ty is o)
  = do is' <- convertListPortF ctxt is
       o'  <- expectPort ctxt o
       Right (GATE ** GATE fc ty (snd is') (snd o'))

convert ctxt End = Right (UNIT ** End)

export
runConvert : AST -> MetaTyCheck (Term Nil UNIT)
runConvert ast with (convert Nil ast)
  runConvert ast | (Left l) = Left l
  runConvert ast | (Right (UNIT ** term)) = Right term
  runConvert ast | (Right (type ** term)) = Left (NotSupposedToHappen $ Just "runConvert")


module subway

%default partial

data Subway : Type where
  Sub : List Subway -> Subway

Eq Subway where
  (Sub ls) == (Sub ls') = ls  == ls'

Ord Subway where
  compare (Sub ls) (Sub ls') = compare ls ls'

fromChars : Subway -> List Subway -> List Char -> Subway
fromChars _ [root] [] = root
fromChars cur@(Sub ys) stack ('0' :: xs) =
  let newSub = Sub []
  in fromChars newSub (Sub (newSub :: ys) :: stack) xs
fromChars cur@(Sub ys) (sub :: subs) ('1' :: xs) =
  fromChars sub subs xs

fromString : String -> Subway
fromString = fromChars (Sub []) [] . unpack

canonical : Subway -> Subway
canonical (Sub ss) = Sub $ sort (map canonical ss)

-- traverseSub : Subway -> List Char
-- traverseSub sub = traverseSub' sub []
--   where
--     traverseSub' : Subway -> Maybe Subway -> List Char -> List Char
--     traverseSub' (Sub [])
-- toString : Subway -> String
-- toString  = pack . traverseSub . canonical


data MyN = MkN Nat Nat

foo : Nat -> Nat -> Nat
foo x y = case MkN x of
               MkN z => y

main : IO ()
main = printLn (foo 2 2)


module Main

import Dart.Core
import Dart.FFI

%inline
export
Point : Type
Point = Struct """
Point,
// All foreign names must be fully qualified and
// the following import can always be assumed to exist:
// import 'dart:core' as $;
class Point {
  $.int x;
  $.int y;
  Point({this.x, this.y});
  void moveTo($.int x, $.int y) { this.x = x; this.y = y; }
  static Point from({$.int x, $.int y}) => Point(x: x, y: y);
}
""" [
  ("x", Int),
  ("y", Int)
]

Show Point where
  show pt = show (the Int (getField pt "x"), the Int (getField pt "y"))

namespace Point

  namespace From

    data Tag : Type where

    %inline
    public export
    x : Parameter Tag
    x = MkParameter "x" Int Tag

    %inline
    public export
    y : Parameter Tag
    y = MkParameter "y" Int Tag

  %inline
  public export
  from : Parameters [From.x, From.y] -> IO Point
  from ps = primIO $ prim__dart_invoke "Point.from" [] [] ps

  %inline
  public export
  moveTo : Int -> Int -> Point -> IO ()
  moveTo x y this = primIO $ prim__dart_invoke ".moveTo" [] [this, x, y] none

main : IO ()
main = do
  pt <- Point.from [
    x @= 42,
    y @= 37
  ]
  printLn pt
  moveTo 11 21 pt
  printLn pt


module Main

main : IO ()
main = do putStrLn $ show $ map (\x => x + 1) $ Just 3
          putStrLn $ show $ map (*3) $ reverse [1..10]


test : Not (Nat = String)
test eq impossible

test2 : Not (Char = String)
test2 eq impossible

test3 : Not (Type = String)
test3 eq impossible

test4 : Not (Type = Nat)
test4 eq impossible

test5 : Not (List Nat = Type)
test5 eq impossible

test6 : Not (Bits64 = Type)
test6 eq impossible

test7 : Not ('a' = 'b')
test7 eq impossible

-- The following ones are actually possible

test8 : Not (a = Type)
test8 eq impossible

test9 : Not (a = 'a')
test9 eq impossible

test10 : Not (a = Nat)
test10 eq impossible

test11 : Not (3 = a)
test11 eq impossible


module Verified.Applicative.Maybe

import Verified.Applicative
import Verified.Functor
import Verified.Functor.Maybe

instance VerifiedApplicative Maybe where
  applicativeMap Nothing g = Refl
  applicativeMap (Just x) g = Refl
  applicativeIdentity Nothing = Refl
  applicativeIdentity (Just x) = Refl
  applicativeComposition Nothing g1 g2 = Refl
  applicativeComposition (Just x) Nothing g2 = Refl
  applicativeComposition (Just x) (Just g1) Nothing = Refl
  applicativeComposition (Just x) (Just g1) (Just g2) = Refl
  applicativeHomomorphism x g = Refl
  applicativeInterchange x Nothing = Refl
  applicativeInterchange x (Just g) = Refl


-- This ought to go into base at some future point
module Libraries.Data.Span

public export
record Span (a : Type) where
  constructor MkSpan
  start    : Nat
  length   : Nat
  property : a

export
Functor Span where
  map f = { property $= f }

export
Foldable Span where
  foldr c n span = c span.property n

export
Traversable Span where
  traverse f (MkSpan start width prop)
    = MkSpan start width <$> f prop

export
Show a => Show (Span a) where
  show (MkSpan start width prop)
    = concat {t = List} [ "[", show start, "-", show width, "]"
                        , show prop
                        ]


module CatenableDeque

import public Deque

%default total
%access private

public export
interface Deque d => CatenableDeque (d : Type -> Type) where
  (++) : d a -> d a -> d a


module Default

happyPairs : List (Nat, Char)
happyPairs = map (uncurry $ \ c, n => (n, c)) [('a', 1)]

-- In Idris1 `sadPairs` is rejected with the following error:
--    |
-- 10 | sadPairs = map (\ (c, n) => (n, c)) [('a', 1)]
--    |                             ~~
-- When checking right hand side of Default.case block in sadPairs at Default.idr:10:19-24 with expected type
--         (Nat, Char)

-- When checking argument a to constructor Builtins.MkPair:
--         Type mismatch between
--                 Integer (Type of n)
--         and
--                 Nat (Expected type)

sadPairs : List (Nat, Char)
sadPairs = map (\ (c, n) => (n, c)) [('a', 1)]


module Main

import Cairo

public export
%foreign
  """
  code:
  func Main_knowsSecretFactors(x) -> (result):
      tempvar a
      tempvar b
      %{
          ids.a = program_input['a']
          ids.b = program_input['b']
      %}
      if x == a * b:
        return (1)
      else:
        return (0)
      end
  end
  """
knowsSecretFactors : Felt -> Felt

%noinline
main : Cairo ()
main = output $ knowsSecretFactors 10967535067


module GRL.Test.Utils

import GRL.Lang.GLang
import GRL.Eval

import Debug.Trace

%default total
%access public export

data TestResults : Type where
  BadModel     : TestResults
  BadResults   : List (GoalNode, SValue, SValue) -> TestResults
  ValidResults : TestResults

getResult : GoalNode -> Strategy -> Maybe (GoalNode, SValue, SValue)
getResult n es =
    let e = getExpSValue n es  in
    let g = getSValue' n       in
      if g == e
        then Nothing
        else Just (n, g, e)
  where
    getSValue' : GoalNode -> SValue
    getSValue' n = fromMaybe NONE (getSValue n)

    getExpectedResult : GoalNode -> Strategy -> Maybe SValue
    getExpectedResult n ss = lookupBy (\x,y => getNodeTitle x == getNodeTitle y) n ss

    getExpSValue : GoalNode -> Strategy -> SValue
    getExpSValue n ss = fromMaybe NONE $ getExpectedResult n ss

collectResults : List GoalNode -> Strategy -> List (GoalNode, SValue, SValue)
collectResults Nil     ss = Nil
collectResults (g::gs) ss =
  case getResult g ss of
    Nothing => collectResults gs ss
    Just x  => x :: collectResults gs ss

partial
execTest : GModel -> Maybe Strategy -> Strategy -> TestResults
execTest m s es =
    case (evaluate FORWARD s m) of
      BadModel   => BadModel
      Result res => case collectResults res es of
        Nil  => ValidResults
        xs   => BadResults xs

partial
printResults : List (GoalNode, SValue, SValue) -> IO ()
printResults Nil     = pure ()
printResults ((n,g,e)::xs) = do
    putStrLn $ unwords
      [show $ getNodeTitle n , show g, show e]
    printResults xs

partial
doTest : GModel -> Strategy -> Strategy -> IO ()
doTest m s es = do
  case execTest m (Just s) es of
    BadModel      => printLn "Bad Model Evaluation"
    ValidResults  => printLn "Test Passed"
    BadResults xs => do
      putStrLn "Tests Failed"
      printResults xs

partial
runEval : GModel -> Maybe Strategy -> IO ()
runEval m s = do
    putStrLn "Results"
    let res = evaluate FORWARD s m
    putStrLn $ fromMaybe "Nout" $ toString res (\x => show x)


module tipos

import Data.SortedMap

%access public export

mutual
  data Id = ValID String

  data AExp = Sum AExp AExp | Sub AExp AExp | Div AExp AExp | Mul AExp AExp | N Int | IdA Id

  data BExp = Equal AExp AExp | Not BExp | LT AExp AExp | GT AExp AExp | LE AExp AExp | GE AExp AExp | And BExp BExp | OR BExp BExp | Boo Bool | IdB Id

  data Exp = AExpR AExp | BExpR BExp | Ref Exp | DeRef Id | ValRef Id | Cns Exp

  data Formals = Form (List Id)

  data Actuals = Act (List Exp)

  data Cmd = Assign Id Exp | Loop BExp Cmd | Cond BExp Cmd Cmd | CSeq Cmd Cmd | Blk Dec Cmd | Call Id Actuals | NOP

  data Abst = Abstr Formals Cmd

  data Dec = Bind Id Exp | DSeq Dec Dec | BindF Id Abst | Rbnd Id Abst

  data CmdOp = CtrlAssign | CtrlLoop | CtrlCond | CtrlCSeq | CtrlBlkDec | CtrlBlkCmd | CtrlCall Id Nat

  data ExpOp = CtrlSum | CtrlSub | CtrlDiv | CtrlMul | CtrlNot | CtrlLT | CtrlGT | CtrlLE | CtrlGE | CtrlAnd | CtrlOR | CtrlEq | CtrlRef | CtrlCns

  data DecOp = CtrlBind | CtrlDSeq | CtrlBindF

  data Ctrl = CtExp Exp | CtExpOp ExpOp | CtCmd Cmd | CtDec Dec | CtCmdOp CmdOp | CtDecOp DecOp | CtAbs Abst

  data Loc = L Int

  data Bindable = BindLoc Loc | BindInt Int | BindClos Closure | BindRec Reclose

  data Val = ValInt Int | ValBool Bool | ValId String | ValCmd Cmd | ValLoc Loc | ValListLoc (List Loc) | ValEnv (SortedMap Id Bindable) | ValBindable Bindable | ValClos Closure | ValNop

  data Closure = Clos (Formals, Cmd, (SortedMap Id Bindable))

  data Reclose = Rec (Formals, Cmd, (SortedMap Id Bindable), (SortedMap Id Bindable))

  implementation Eq Loc where
    (L a) == (L b) = a == b
    (L a) /= (L b) = a /= b

  implementation Ord Loc where
    compare (L a) (L b) = compare a b

  implementation Eq Id where
    (ValID a) == (ValID b) = a == b
    (ValID a) /= (ValID b) = a /= b

  implementation Ord Id where
    compare (ValID a) (ValID b) = compare a b

  implementation Show Id where
    show (ValID x) = "ValID " ++ show x

  implementation Show AExp where
    show (Sum a b) = "Sum (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (Sub a b) = "Sub (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (Mul a b) = "Mul (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (Div a b) = "Div (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (N a) = "N " ++ show a
    show (IdA a) = "IdA (" ++ show a ++ ")"

  implementation Show BExp where
    show (Equal a b) = "Equal (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (GT a b) = "GT (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (LT a b) = "LT (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (LE a b) = "LE (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (GE a b) = "GE (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (And a b) = "And (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (OR a b) = "OR (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (Boo a) = "Boo " ++ show a
    show (Not a) = "Not (" ++ show a ++ ")"
    show (IdB a) = "IdB (" ++ show a ++ ")"

  implementation Show Exp where
    show (AExpR a) = "AExpR (" ++ show a ++ ")"
    show (BExpR a) = "BExpR (" ++ show a ++ ")"
    show (Ref a) = "Ref (" ++ show a ++ ")"
    show (DeRef id) = "DeRef (" ++ show id ++ ")"
    show (ValRef id) = "ValRef (" ++ show id ++ ")"

  implementation Show Actuals where
    show (Act x) = "Act " ++ show x

  implementation Show Formals where
    show (Form x) = "Form " ++ show x

  implementation Show Abst where
    show (Abstr b c) = "Abstr (" ++ show b ++ ") " ++ "(" ++ show c ++ ")"

  implementation Show Dec where
    show (Bind a b) = "Bind (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (DSeq a b) = "DSeq (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (BindF a b) = "BindF (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"
    show (Rbnd a b) = "Rbnd (" ++ show a ++ ") " ++ "(" ++ show b ++ ")"

  implementation Show Cmd where
    show (Assign id exp) = "Assign (" ++ show id ++ ") " ++ "("++ show exp ++ ")"
    show (Loop b c) = "Loop (" ++ show b ++ ") " ++ "("++ show c ++ ")"
    show (Cond b c1 c2) = "Cond (" ++ show b ++ ") " ++ "("++ show c1 ++ ")" ++ " (" ++ show c2 ++ ")"
    show (CSeq c1 c2) = "CSeq (" ++ show c1 ++ ") " ++ "("++ show c2 ++ ")"
    show (Blk d c) = "Blk (" ++ show d ++ ") " ++ "("++ show c ++ ")"
    show (Call d c) = "Call (" ++ show d ++ ") " ++ "("++ show c ++ ")"
    show (NOP) = "NOP"

  implementation Show Closure where
    show (Clos (f, c, e)) = "Clos (" ++ show f ++ ", " ++ show c ++ ", " ++ show (toList e) ++ ")"

  implementation Show Reclose where
    show (Rec (f, c, e, e')) = "Clos (" ++ show f ++ ", " ++ show c ++ ", " ++ show (toList e) ++ show (toList e') ++ ")"

  implementation Show CmdOp where
    show CtrlAssign = "CtrlAssign"
    show CtrlLoop = "CtrlLoop"
    show CtrlCond = "CtrlCond"
    show CtrlCSeq = "CtrlCSeq"
    show CtrlBlkDec = "CtrlBlkDec"
    show CtrlBlkCmd = "CtrlBlkCmd"
    show (CtrlCall id tam) = "CtrlCall (" ++ show id ++ ") " ++ "(" ++ show tam ++ ")"

  implementation Show ExpOp where
    show CtrlSum = "CtrlSum"
    show CtrlSub = "CtrlSub"
    show CtrlDiv = "CtrlDiv"
    show CtrlMul = "CtrlMul"
    show CtrlNot = "CtrlNot"
    show CtrlLT = "CtrlLT"
    show CtrlGT = "CtrlGT"
    show CtrlLE = "CtrlLE"
    show CtrlGE = "CtrlGE"
    show CtrlAnd = "CtrlAnd"
    show CtrlOR = "CtrlOR"
    show CtrlEq = "CtrlEq"
    show CtrlRef = "CtrlRef"
    show CtrlCns = "CtrlCns"

  implementation Show DecOp where
    show CtrlBind = "CtrlBind"
    show CtrlDSeq = "CtrlDSeq"
    show CtrlBindF = "CtrlBindF"

  implementation Show Ctrl where
    show (CtExp a) = "CtExp (" ++ show a ++ ")"
    show (CtExpOp a) = "CtExpOp (" ++ show a ++ ")"
    show (CtCmd a) = "CtCmd (" ++ show a ++ ")"
    show (CtDec a) = "CtDec " ++ show a
    show (CtAbs a) = "CtAbs " ++ show a
    show (CtCmdOp a) = "CtCmdOp (" ++ show a ++ ")"
    show (CtDecOp a) = "CtDecOp (" ++ show a ++ ")"

  implementation Show Loc where
    show (L a) = "L " ++ show a

  implementation Show Bindable where
    show (BindLoc x) = "BindLoc (" ++ show x ++ ")"
    show (BindInt x) = "BindInt (" ++ show x ++ ")"
    show (BindClos x) = "BindClos (" ++ show x ++ ")"
    show (BindRec x) = "BindRec (" ++ show x ++ ")"

  implementation Show Val where
    show (ValInt a) = "ValInt (" ++ show a ++ ")"
    show (ValBool b) = "ValBool (" ++ show b ++ ")"
    show (ValId a) = "ValId (" ++ show a ++ ")"
    show (ValCmd a) = "ValCmd (" ++ show a ++ ")"
    show (ValLoc a) = "ValLoc (" ++ show a ++ ")"
    show (ValListLoc a) = "ValListLoc (" ++ show a ++ ")"
    show (ValEnv map) = "ValEnv (" ++ show (toList map) ++ ")"
    show (ValClos cls) = "ValClos (" ++ show cls ++ ")"
    show ValNop = "ValNop"


module WebAssembly.Validation.Modules.DataSegments

import WebAssembly.Structure
import WebAssembly.Validation.Conventions
import WebAssembly.Validation.Instructions
import WebAssembly.Validation.Types

||| [🔗 Spec](https://webassembly.github.io/spec/core/valid/modules.html#data-segments)
|||
||| ```
||| C.mems[x] = limits    C ⊢ expr : [i32]    C ⊢ expr const
||| --------------------------------------------------------
||| C ⊢ {data x, offset expr, init b*} ok
||| ```
public export
data ValidData : Context -> Data -> Type where
  MkValidData  : (c : Context)
              -> (x : MemIdx)
              -> (expr : Expr)
              -> (bs : List Byte)
              -> {auto in_bounds: InBounds x (mems c)}
              -> ValidSequence c expr ([] ->> [TI32])
              -> ConstExpr c expr
              -> ValidData c (MkData x expr bs)


-- ----------------------------------------------------------------- [ Key.idr ]
-- Module      : Keys
-- Description : Types for Cryptographic Keys
-- Copyright   : (c) Jan de Muijnck-Hughes
-- License     : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
module Crypto.Std.Key

import Crypto.Common
import Data.Bits

||| Keys are vectors of bits.
|||
||| @ v The Visibility of the key with respect to the owner.
||| @ s The setting in which the key is to be used.
||| @ l The length of the key in bits.
data Key : (v : Visibility) -> (s : Setting) -> (l : Nat) -> Type where
  ||| PKE Encryption keys.
  MkEncKey : Bits n -> Key Public Asymm n

  ||| PKE Decryption keys
  MkDecKey : Bits n -> Key Private Asymm n

  ||| DS Signing keys.
  MkSignKey : Bits n -> Key Private Sign n

  ||| DS Verifying keys.
  MkVerifyKey : Bits n -> Key Public Sign n

  ||| Symmetric keys
  MkSymmKey : Bits n -> Key Private Symm n

||| Key pairs
|||
||| @ s The setting in which the key is to be used.
||| @ l The length of the key in bits.
data KeyPair : (s : Setting) -> (l : Nat) -> Type where
  ||| Key pair for PKE.
  |||
  ||| @ pub The public key.
  ||| @ priv The private key.
  MkAsymmKeyPair : (pub : Key Public Asymm n)
                 -> (priv : Key Private Asymm n)
                 -> KeyPair Asymm n

  ||| Key pair for DS.
  |||
  ||| @ sig The signing key.
  ||| @ ver The verifying key.
  MkSignKeyPair : (sig : Key Private Sign n)
                -> (ver : Key Public Sign n)
                -> KeyPair Sign n

data TDESKeyOption = KeyOption1 | KeyOption2 | KeyOption3

||| Representation of a Triple DES
|||
||| @ s The setting in ehich the key is to be used.
||| @ n The length of each key
||| @ option The Keying option used.
data TDESKey : (s : Setting) -> (n : Nat) -> (option : TDESKeyOption)-> Type where
  |||
  MkTDESKey : (key1 : Bits n)
             -> (key2 : Bits n)
             -> (key3 : Bits n)
             -> (opt : TDESKeyOption)
             -> TDESKey Symm n opt
-- --------------------------------------------------------------------- [ EOF ]


module Ex6

import Data.Vect

%default total

Matrix : Nat -> Nat -> Type
Matrix n m = Vect n (Vect m Double)

testMatrix : Matrix 2 3
testMatrix = [[0, 0, 0], [1, 2, 3]]

data Format = Integ Format
            | Dbl Format
            | Chr Format
            | Str Format
            | Lit String Format
            | End

PrintfType : (fmt : Format) -> Type
PrintfType (Integ fmt) = (i : Int) -> PrintfType fmt
PrintfType (Dbl fmt) = (d : Double) -> PrintfType fmt
PrintfType (Chr fmt) = (c : Char) -> PrintfType fmt
PrintfType (Str fmt) = (s : String) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType End = String

printfFmt : Num ty => (fmt : Format) -> (acc : String) -> PrintfType fmt
printfFmt (Integ fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Dbl fmt) acc = \d => printfFmt fmt (acc ++ show d)
printfFmt (Chr fmt) acc = \c => printfFmt fmt (acc ++ show c)
printfFmt (Str fmt) acc = \s => printfFmt fmt (acc ++ s)
printfFmt (Lit str fmt) acc = printfFmt fmt (acc ++ str)
printfFmt End acc = acc

toFormat : List Char -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Integ (toFormat chars)
toFormat ('%' :: 'f' :: chars) = Dbl (toFormat chars)
toFormat ('%' :: 'c' :: chars) = Chr (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
                             Lit lit chars' => Lit (strCons c lit) chars'
                             fmt => Lit (strCons c "") fmt

printf : (inp : String) -> PrintfType (toFormat (unpack inp))
printf fmt = printfFmt (toFormat (unpack fmt)) ""

{-

  TupleVect 0 ty = ()
  TupleVect 1 ty = (ty, ())
  TupleVect 2 ty = (ty, (ty, ()))
  ...

-}

TupleVect : (nesting : Nat) -> (elemType : Type) -> Type
TupleVect Z ty = ()
TupleVect (S k) ty = (ty, TupleVect k ty)

test : TupleVect 5 Nat
test = (1, 2, 3, 4, 5, ())


module Incrementer
import Service
import System
import Numeric

%default total

-- Run external service
public export
runIncrementer : Integer -> IO Integer
runIncrementer = do ?run

public export
incrementerContract : (a : Integer) -> Contract (runIncrementer a) Integer
incrementerContract a = MkContract (runIncrementer a)

public export
incrementerService : Integer -> Service Integer
incrementerService a = Promise (incrementerContract a)


module Flexidisc.Function

import Flexidisc.TaggedValue

%default total
%access public export

infixr 8 |->
infix 7 ~~

||| A wrapper for functions to allow definition of typeclasses
record (|->) (a : Type) (b : Type) where
  constructor F
  unwrap : (a -> b)

Functor ((|->) a) where
  map g (F f) = F (g . f)

Applicative ((|->) a) where
  pure x = F (const x)
  (<*>) (F f) (F x) = F (\y => f y (x y))

(~~) : (l : k) -> (a -> b) -> TaggedValue l (a |-> b)
(~~) l f = l := F f


module Commons.Control.Logging.Simple

import Control.ST

public export
interface Logging (m : Type -> Type) where
  Logger : Type

  startLogging : (lvl : Nat)
              -> ST m (Var) [add Logger]

  setLevel : (logger : Var)
          -> (lvl : Nat)
          -> ST m () [logger ::: Logger]

  log : (logger : Var)
     -> (lvl    : Nat)
     -> (msg    : String)
     -> ST m () [logger ::: Logger]

  endLogging : (logger : Var)
            -> ST m () [Remove logger Logger]

public export
Logging IO where
  Logger = State Nat

  startLogging lvl = do
    logger <- new lvl
    pure logger

  setLevel logger new = write logger new

  log logger lvl msg = do
    curr <- read logger
    case compare lvl curr of
      GT => pure ()
      _  => do
        putStr $ unwords ["[", show lvl, "]", msg]
        pure ()

  endLogging logger = delete logger

-- --------------------------------------------------------------------- [ EOF ]


-- ------------------------------------------------------ [ Tree.idr<RedBlack> ]
-- Module    : Tree.idr
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
-- http://www.cs.kent.ac.uk/people/staff/smk/redblack/Untyped.hs
module Data.RedBlack.Tree

import Debug.Error
%language ElabReflection

%default total
%access export

-- ------------------------------------------------------------- [ Definitions ]
public export
data Colour = R | B

||| The core tree key-value data structure used to represent an
||| Red-Black Tree.
|||
||| This structure doesn't encode the invariants of the tree and is
||| *simply* a container. This structure ideally shouldn't be exposed
||| to the user at all. This structure should be used to build other
||| data structures.  See the modules alongside this for appropriate
||| interfaces for using the tree.
|||
||| @keyTy The type associated with the key.
||| @valTy The type associated with the value.
public export
data Tree : (colour : Colour)
         -> (keyTy : Type)
         -> (valTy : Type)
         -> Type
  where
    ||| An empty Tree node.
    Empty : Tree B k v

    ||| A Key Value node in the Tree.
    |||
    ||| @key   The key.
    ||| @val   The value associated with the key.
    ||| @left  The left child of the Node
    ||| @right THe right child of the Node.
    Node : (c3 : Colour)
        -> (key   : k)
        -> (val   : v)
        -> (left  : Tree c1 k v)
        -> (right : Tree c2 k v)
        -> Tree c3 k v

%name Tree t, tree

public export
data RBInvariant : (blackHeight : Nat)
                -> (colour : Colour)
                -> (valid : Bool)
                -> (tree : Tree colour k v)
                -> Type
  where
    ||| A tree of height zero.
    RBEmpty : RBInvariant 0 B True Empty
    ||| A balanced black tree.
    |||
    ||| @left  The invariant of the left child.
    ||| @right The invariant of the right child.
    BNode : (left  : RBInvariant n _ True l)
         -> (right : RBInvariant n _ True r)
         -> RBInvariant (S n) B True (Node B k v l r)
    ||| A balanced red tree.
    |||
    ||| @left  The invariant of the left child.
    ||| @right The invariant of the right child.
    RNode : (left  : RBInvariant n B True l)
         -> (right : RBInvariant n B True r)
         -> RBInvariant n R True (Node R k v l r)

    ||| A red tree with a red left child.
    |||
    ||| @left  The invariant of the left child.
    ||| @right The invariant of the right child.
    LBad : (left  : RBInvariant n R True l)
        -> (right : RBInvariant n B True r)
        -> RBInvariant n R False (Node R k v l r)

    ||| A red tree with a red right child.
    |||
    ||| @left  The invariant of the left child.
    ||| @right The invariant of the right child.
    RBad : (left  : RBInvariant n B True l)
        -> (right : RBInvariant n R True r)
        -> RBInvariant n R False (Node R k v l r)

%name RBInvariant inv

||| An Red-Black Tree.
|||
||| Modelled using subset to separate the invariants from the tree
||| implementation itself.
|||
||| @blackHeight  The height of the Tree.
||| @keyTy        The type associated with the keys.
||| @valueTy      The type associated with the values.
public export
RBTree : (blackHeight  : Nat)
      -> (colour : Colour)
      -> (keyTy   : Type)
      -> (valueTy : Type)
      -> Type
RBTree n c k v = Subset (Tree c k v) (RBInvariant n c True)

private
InsTree : (blackHeight  : Nat)
       -> (colour : Colour)
       -> (keyTy   : Type)
       -> (valueTy : Type)
       -> (valid : Bool)
       -> Type
InsTree n c k v valid = Subset (Tree c k v) (RBInvariant n c valid)

-- --------------------------------------------------------------- [ Insertion ]

private
balance : k -> v -> RBTree n c1 k v -> RBTree n c2 k v -> (c3 ** RBTree (S n) c3 k v)
balance {n} y vy (Element (Node _ x vx a b) (RNode pf_l_l pf_l_r))
                 (Element (Node _ z vz c d) (RNode pf_r_l pf_r_r)) =
  let t = (Node R y vy (Node B x vx a b) (Node B z vz c d))
      pf = RNode (BNode pf_l_l pf_l_r) (BNode pf_r_l pf_r_r)
  in (R ** Element t pf)
balance {n} x vx (Element a pf_a) (Element b pf_b) =
  let t = (Node B x vx a b)
      pf = BNode pf_a pf_b
  in (B ** Element t pf)

private
recolorRight : (Ord k) => k -> v -> RBTree n c k v -> InsTree n R k v False -> (c' ** valid ** InsTree (S n) c' k v valid)

recolorRight g vg (Element (Node R u vu t5 t4) (RNode pf_5 pf_4))
                  (Element (Node R p vp t3 tn) (RBad pf_3 pf_n)) =
  (R ** True ** Element (Node R g vg (Node B u vu t5 t4) (Node B p vp t3 tn))
                        (RNode (BNode pf_5 pf_4) (BNode pf_3 pf_n)))

recolorRight g vg (Element (Node R u vu t5 t4) (RNode pf_5 pf_4))
                  (Element (Node R p vp tn t3) (LBad pf_n pf_3)) =
  (R ** True ** Element (Node R g vg (Node B u vu t4 t5) (Node B p vp tn t3))
                        (RNode (BNode pf_4 pf_5) (BNode pf_n pf_3)))

recolorRight g vg (Element (Node B u vu t5 t4) (BNode pf_5 pf_4))
                  (Element (Node R p vp t3 (Node R n vn t2 t1)) (RBad pf_3 (RNode pf_2 pf_1))) =
  (B ** True ** Element (Node B p vp (Node R g vg (Node B u vu t5 t4) t3)
                                     (Node R n vn t2 t1))
                        (BNode (RNode (BNode pf_5 pf_4) pf_3) (RNode pf_2 pf_1)))

recolorRight g vg (Element Empty RBEmpty)
                  (Element (Node R p vp t3 (Node R n vn t2 t1)) (RBad pf_3 (RNode pf_2 pf_1))) =
  (B ** True ** Element (Node B p vp (Node R g vg Empty t3)
                                     (Node R n vn t2 t1))
                        (BNode (RNode RBEmpty pf_3) (RNode pf_2 pf_1)))

recolorRight g vg (Element (Node B u vu t5 t4) (BNode pf_5 pf_4))
                  (Element (Node R p vp (Node R n vn t3 t2) t1) (LBad (RNode pf_3 pf_2) pf_1)) =
  (B ** True ** Element (Node B n vn (Node R g vg (Node B u vu t5 t4) t3)
                                     (Node R p vp t2 t1))
                        (BNode (RNode (BNode pf_5 pf_4) pf_3) (RNode pf_2 pf_1)))

recolorRight g vg (Element Empty RBEmpty)
                  (Element (Node R p vp (Node R n vn t3 t2) t1) (LBad (RNode pf_3 pf_2) pf_1)) =
  (B ** True ** Element (Node B n vn (Node R g vg Empty t3)
                                     (Node R p vp t2 t1))
                        (BNode (RNode RBEmpty pf_3) (RNode pf_2 pf_1)))

private
recolorLeft : (Ord k) => k -> v -> InsTree n R k v False -> RBTree n c k v -> (c' ** valid ** InsTree (S n) c' k v valid)

recolorLeft g vg (Element (Node R p vp tn t3) (LBad pf_n pf_3))
                 (Element (Node R u vu t4 t5) (RNode pf_4 pf_5)) =
  (R ** True ** Element (Node R g vg (Node B p vp tn t3)
                                     (Node B u vu t4 t5))
                        (RNode (BNode pf_n pf_3) (BNode pf_4 pf_5)))

recolorLeft g vg (Element (Node R p vp t1 tn) (RBad pf_1 pf_n))
                 (Element (Node R u vu t4 t5) (RNode pf_4 pf_5)) =
  (R ** True ** Element (Node R g vg (Node B p vp t1 tn)
                                     (Node B u vu t4 t5))
                        (RNode (BNode pf_1 pf_n) (BNode pf_4 pf_5)))

recolorLeft g vg (Element (Node R p vp (Node R n vn t1 t2) t3) (LBad (RNode pf_1 pf_2) pf_3))
                 (Element (Node B u vu t4 t5) (BNode pf_4 pf_5)) =
  (B ** True ** Element (Node B p vp (Node R n vn t1 t2)
                                     (Node R g vg t3 (Node B u vu t4 t5)))
                        (BNode (RNode pf_1 pf_2) (RNode pf_3 (BNode pf_4 pf_5))))

recolorLeft g vg (Element (Node R p vp (Node R n vn t1 t2) t3) (LBad (RNode pf_1 pf_2) pf_3))
                 (Element Empty RBEmpty) =
  (B ** True ** Element (Node B p vp (Node R n vn t1 t2)
                                     (Node R g vg t3 Empty))
                        (BNode (RNode pf_1 pf_2) (RNode pf_3 RBEmpty)))

recolorLeft g vg (Element (Node R p vp t1 (Node R n vn t2 t3)) (RBad pf_1 (RNode pf_2 pf_3)))
                 (Element (Node B u vu t4 t5) (BNode pf_4 pf_5)) =
  (B ** True ** Element (Node B n vn (Node R p vp t1 t2)
                                     (Node R g vg t3 (Node B u vu t4 t5)))
                        (BNode (RNode pf_1 pf_2) (RNode pf_3 (BNode pf_4 pf_5))))

recolorLeft g vg (Element (Node R p vp t1 (Node R n vn t2 t3)) (RBad pf_1 (RNode pf_2 pf_3)))
                 (Element Empty RBEmpty) =
  (B ** True ** Element (Node B n vn (Node R p vp t1 t2)
                                     (Node R g vg t3 Empty))
                        (BNode (RNode pf_1 pf_2) (RNode pf_3 RBEmpty)))

private
ins : Ord k => k -> v -> RBTree n c k v -> (c' ** valid ** InsTree n c' k v valid)
ins x vx (Element Empty RBEmpty) = (R ** True ** Element (Node R x vx Empty Empty) (RNode RBEmpty RBEmpty))
ins x vx t@(Element (Node _ y _ _ _) _) = insWith x vx t (compare x y)
  where
    addValid : (c ** InsTree n c k v True) -> (c ** valid ** InsTree n c k v valid)
    addValid (c ** t) = (c ** True ** t)

    insWith : Ord k => k -> v -> RBTree n c k v -> Ordering -> (c' ** valid ** InsTree n c' k v valid)

    insWith x vx (Element Empty RBEmpty) _ =  -- unreachable, but make totality checker happy
      (R ** True ** Element (Node R x vx Empty Empty) (RNode RBEmpty RBEmpty))

    insWith x vx (Element n@(Node B y vy a b) pf) EQ =
      (B ** True ** Element n pf)
    insWith x vx t@(Element (Node B y vy a b) (BNode pf_a pf_b)) LT =
      let t_a = assert_smaller t (Element a pf_a)
      in case ins x vx t_a of
        (_ ** True ** t_a') => addValid (balance y vy t_a' (Element b pf_b))
        (R ** False ** t_a') => recolorLeft y vy t_a' (Element b pf_b)
        (B ** False ** (Element _ _)) impossible
    insWith x vx t@(Element (Node B y vy a b) (BNode pf_a pf_b)) GT =
      let t_b = assert_smaller t (Element b pf_b)
      in case ins x vx t_b of
        (_ ** True ** t_b') => addValid (balance y vy (Element a pf_a) t_b')
        (R ** False ** t_b') => recolorRight y vy (Element a pf_a) t_b'
        (B ** False ** (Element _ _)) impossible

    insWith x vx (Element n@(Node R y vy a b) pf) EQ =
      (R ** True ** Element n pf)
    insWith x vx t@(Element (Node R y vy a b) (RNode pf_a pf_b)) LT =
      let t_a = assert_smaller t (Element a pf_a)
      in case ins x vx t_a of
        (B ** True ** Element a' pf_a') => (R ** True ** Element (Node R y vy a' b) (RNode pf_a' pf_b))
        (R ** True ** Element a' pf_a') => (R ** False ** Element (Node R y vy a' b) (LBad pf_a' pf_b))
        (R ** False ** t_a') => error "impossible"
        (B ** False ** Element _ _) impossible
    insWith x vx t@(Element (Node R y vy a b) (RNode pf_a pf_b)) GT =
      let t_b = assert_smaller t (Element b pf_b)
      in case ins x vx t_b of
        (B ** True ** Element b' pf_b') => (R ** True ** Element (Node R y vy a b') (RNode pf_a pf_b'))
        (R ** True ** Element b' pf_b') => (R ** False ** Element (Node R y vy a b') (RBad pf_a pf_b'))
        (R ** False ** t_b') => error "impossible"
        (B ** False ** Element _ _) impossible

-- --------------------------------------- [ Public API for working with Trees ]

||| An empty tree
empty : RBTree 0 B k v
empty = Element Empty RBEmpty

||| Insert a key value pair into the tree, returning a the new tree
||| and possibly its new height.
insert : Ord k => k -> v -> RBTree n B k v -> (n' : Nat ** RBTree n' B k v)
insert x vx s =
  case ins x vx s of
    (B ** True ** t) => (_ ** t)
    (R ** True ** Element (Node R k v l r) (RNode pf_l pf_r)) =>
      (_ ** Element (Node B k v l r) (BNode pf_l pf_r))
    (B ** False ** Element _ _) impossible
    (R ** False ** Element (Node R k v l r) (RBad pf_l pf_r)) =>
      (_ ** Element (Node B k v l r) (BNode pf_l pf_r))
    (R ** False ** Element (Node R k v l r) (LBad pf_l pf_r)) =>
      (_ ** Element (Node B k v l r) (BNode pf_l pf_r))

||| Find a value in the tree.
lookup : (Ord k) => k -> RBTree n B k v -> Maybe v
lookup key (Element t _) = lookup' key t
  where
    lookup' : (Ord k) => k -> Tree c k v -> Maybe v
    lookup' key Empty = Nothing
    lookup' key (Node _ key' value' l r) with (compare key key')
      lookup' key (Node _ key' value' l r) | LT = lookup' key l
      lookup' key (Node _ key' value' l r) | EQ = Just value'
      lookup' key (Node _ key' value' l r) | GT = lookup' key r

||| Perform a right fold over the tree.
foldr : (step : k -> v -> p -> p)
     -> (init : p)
     -> RBTree n B k v
     -> p
foldr step init (Element t _) = foldr' step init t
  where
    foldr' : (k -> v -> p -> p) -> p -> Tree c k v -> p
    foldr' step' init' Empty = init'
    foldr' step' init' (Node _ key val l r) = foldr' step' (step' key val (foldr' step' init' r)) l

||| Construct a AVL Tree from an association list.
fromList : (Ord k) => List (k, v) -> (n : Nat ** RBTree n B k v)
fromList xs = go xs empty
  where go : (Ord k) => List (k, v) -> RBTree n B k v -> (n' : Nat ** RBTree n' B k v)
        go [] t = (0 ** Element Empty RBEmpty)
        go ((k, v) :: xs) t = case insert k v t of
          (_ ** t') => go xs t'

||| Flatten the tree to an association list.
toList : RBTree n B k v -> List (k, v)
toList = foldr (\k,v,xs => (k, v) :: xs) []

||| Size of the tree.
size : RBTree n B k v -> Nat
size t = Tree.foldr (\_,_,res => S res) Z t

-- --------------------------------------------------------------------- [ EOF ]


module WebServer.Format

import WebServer.Requests

%default total

%access public export

data Format
  = Num Format
  | Str Format
  | End
%name Format format

HandlerType : Format -> Type
HandlerType (Num fmt) = Nat -> HandlerType fmt
HandlerType (Str fmt) = String -> HandlerType fmt
HandlerType End = Response
%name HandlerType f

parse : (acc : Format) -> (parts : List String) -> Format
parse acc [] = acc
parse acc (part :: parts) =
  case unpack part of
       (':' :: 'n' :: 'u' :: 'm' :: '.' :: _) =>
         Num (parse acc parts)
       (':' :: _) =>
         Str (parse acc parts)
       _ =>
         parse acc parts

parseFormat : (routePath : String) -> Format
parseFormat routePath = parse End $ (== '/') `split` routePath


%default total

nonproductive : Stream a -> (Stream a, ())
nonproductive (x :: xs) =
  case nonproductive xs of
    (xs, ()) => (xs, ())


module Libraries.Data.DList

%default total

-- Do not re-export the type so that it does not get unfolded in goals
-- and error messages!
export
DList : Type -> Type
DList a = List a -> List a

export
Nil : DList a
Nil = id

export
(::) : a -> DList a -> DList a
(::) a as = (a ::) . as

export
snoc : DList a -> a -> DList a
snoc as a = as . (a ::)

export
appendR : DList a -> List a -> DList a
appendR as bs = as . (bs ++)

export
appendL : List a -> DList a -> DList a
appendL as bs = (as ++) . bs

export
(++) : DList a -> DList a -> DList a
(++) = (.)

export
reify : DList a -> List a
reify as = as []

-- NB: No Functor instance because it's too expensive to reify, map, put back
-- Consider using a different data structure if you need mapping (e.g. a rope)


module Data.MSF

import public Data.MSF.Core
import public Data.MSF.Event
import public Data.MSF.Running
import public Data.MSF.Util
import public Data.SOP


module Main

import Cairo

public export
%foreign
    "linear_implicits:range_check_ptr, pedersen_ptr"
    "imports:starkware.cairo.common.pow pow, starkware.cairo.common.hash hash2, starkware.cairo.common.cairo_builtins HashBuiltin"
    """
    code:
    # Important notes:
    # - Parameters are untyped
    # - Implicit paramters come first in the same order as listed aboove in "linear_implicits"
    # - The results come first, followed by the implicits, again in the same order
    func Main_externalfn(range_check_ptr, pedersen_ptr, a, b) -> (res, range_check_ptr, pedersen_ptr):
        let (p) = pow{range_check_ptr=range_check_ptr}(a,b)
        let pedersen_ptr_cast = cast(pedersen_ptr, HashBuiltin*)
        let (res) = hash2{hash_ptr=pedersen_ptr_cast}(p,p)
        return (res, range_check_ptr, cast(pedersen_ptr_cast, felt))
    end
    """
externalfn : Felt -> Felt -> Felt

%noinline
main : Cairo ()
main = output $ externalfn 2 3


module Solutions.DPair

import Control.Monad.State

import Data.DPair
import Data.Either
import Data.HList
import Data.List
import Data.List1
import Data.Singleton
import Data.String
import Data.Vect

import Text.CSV

import System.File

%default total

--------------------------------------------------------------------------------
--          Dependent Pairs
--------------------------------------------------------------------------------

-- 1

filterVect : (a -> Bool) -> Vect m a -> (n ** Vect n a)
filterVect f []        = (_ ** [])
filterVect f (x :: xs) = case f x of
  True  => let (_ ** ys) = filterVect f xs in (_ ** x :: ys)
  False => filterVect f xs

-- 2

mapMaybeVect : (a -> Maybe b) -> Vect m a -> (n ** Vect n b)
mapMaybeVect f []        = (_ ** [])
mapMaybeVect f (x :: xs) = case f x of
  Just v  => let (_ ** vs) = mapMaybeVect f xs in (_ ** v :: vs)
  Nothing => mapMaybeVect f xs

-- 3

dropWhileVect : (a -> Bool) -> Vect m a -> Exists (\n => Vect n a)
dropWhileVect f []        = Evidence _ []
dropWhileVect f (x :: xs) = case f x of
  True  => dropWhileVect f xs
  False => Evidence _ (x :: xs)

-- 4

vectLength : Vect n a -> Singleton n
vectLength []        = Val 0
vectLength (x :: xs) = let Val k = vectLength xs in Val (S k)

dropWhileVect' : (a -> Bool) -> Vect m a -> (n ** Vect n a)
dropWhileVect' f xs =
  let Evidence _ ys = dropWhileVect f xs
      Val n         = vectLength ys
   in (n ** ys)

--------------------------------------------------------------------------------
--          Use Case: Nucleic Acids
--------------------------------------------------------------------------------

-- 1

data BaseType = DNABase | RNABase

data Nucleobase' : BaseType -> Type where
  Adenine'  : Nucleobase' b
  Cytosine' : Nucleobase' b
  Guanine'  : Nucleobase' b
  Thymine'  : Nucleobase' DNABase
  Uracile'  : Nucleobase' RNABase

RNA' : Type
RNA' = List (Nucleobase' RNABase)

DNA' : Type
DNA' = List (Nucleobase' DNABase)

Acid1 : Type
Acid1 = (b ** List (Nucleobase' b))

record Acid2 where
  constructor MkAcid2
  baseType : BaseType
  sequence : List (Nucleobase' baseType)

data Acid3 : Type where
  SomeRNA : RNA' -> Acid3
  SomeDNA : DNA' -> Acid3

nb12 : Acid1 -> Acid2
nb12 (fst ** snd) = MkAcid2 fst snd

nb21 : Acid2 -> Acid1
nb21 (MkAcid2 bt seq) = (bt ** seq)

nb13 : Acid1 -> Acid3
nb13 (DNABase ** snd) = SomeDNA snd
nb13 (RNABase ** snd) = SomeRNA snd

nb31 : Acid3 -> Acid1
nb31 (SomeRNA xs) = (RNABase ** xs)
nb31 (SomeDNA xs) = (DNABase ** xs)

-- 2

data Dir = Sense | Antisense

data Nucleobase : BaseType -> Dir -> Type where
  Adenine  : Nucleobase b d
  Cytosine : Nucleobase b d
  Guanine  : Nucleobase b d
  Thymine  : Nucleobase DNABase d
  Uracile  : Nucleobase RNABase d

RNA : Dir -> Type
RNA d = List (Nucleobase RNABase d)

DNA : Dir -> Type
DNA d = List (Nucleobase DNABase d)

-- 3

inverse : Dir -> Dir
inverse Sense     = Antisense
inverse Antisense = Sense

complementBase :  (b : BaseType)
               -> Nucleobase b dir
               -> Nucleobase b (inverse dir)
complementBase DNABase Adenine  = Thymine
complementBase RNABase Adenine  = Uracile
complementBase _       Cytosine = Guanine
complementBase _       Guanine  = Cytosine
complementBase _       Thymine  = Adenine
complementBase _       Uracile  = Adenine

complement :  (b : BaseType)
           -> List (Nucleobase b dir)
           -> List (Nucleobase b $ inverse dir)
complement b = map (complementBase b)

transcribeBase : Nucleobase DNABase Antisense -> Nucleobase RNABase Sense
transcribeBase Adenine  = Uracile
transcribeBase Cytosine = Guanine
transcribeBase Guanine  = Cytosine
transcribeBase Thymine  = Adenine

transcribe : DNA Antisense -> RNA Sense
transcribe = map transcribeBase

transcribeAny : (dir : Dir) -> DNA dir -> RNA Sense
transcribeAny Antisense = transcribe
transcribeAny Sense     = transcribe . complement _

-- 4

record NucleicAcid where
  constructor MkNucleicAcid
  baseType : BaseType
  dir      : Dir
  sequence : List (Nucleobase baseType dir)

-- 5

readAnyBase : {0 dir : _} -> Char -> Maybe (Nucleobase b dir)
readAnyBase 'A' = Just Adenine
readAnyBase 'C' = Just Cytosine
readAnyBase 'G' = Just Guanine
readAnyBase _   = Nothing

readRNABase : {0 dir : _} -> Char -> Maybe (Nucleobase RNABase dir)
readRNABase 'U' = Just Uracile
readRNABase c   = readAnyBase c

readDNABase : {0 dir : _} -> Char -> Maybe (Nucleobase DNABase dir)
readDNABase 'T' = Just Thymine
readDNABase c   = readAnyBase c

readRNA : String -> Maybe (dir : Dir ** RNA dir)
readRNA str = case forget $ split ('-' ==) str of
  ["5´",s,"3´"] => MkDPair Sense     <$> traverse readRNABase (unpack s)
  ["3´",s,"5´"] => MkDPair Antisense <$> traverse readRNABase (unpack s)
  _             => Nothing

readDNA : String -> Maybe (dir : Dir ** DNA dir)
readDNA str = case forget $ split ('-' ==) str of
  ["5´",s,"3´"] => MkDPair Sense     <$> traverse readDNABase (unpack s)
  ["3´",s,"5´"] => MkDPair Antisense <$> traverse readDNABase (unpack s)
  _             => Nothing

-- 6

preSuf : Dir -> (String,String)
preSuf Sense     = ("5´-", "-3´")
preSuf Antisense = ("3´-", "-5´")

encodeBase : Nucleobase c d -> Char
encodeBase Adenine  = 'A'
encodeBase Cytosine = 'C'
encodeBase Guanine  = 'G'
encodeBase Thymine  = 'T'
encodeBase Uracile  = 'U'

encode : (dir : Dir) -> List (Nucleobase b dir) -> String
encode dir seq =
  let (pre,suf) = preSuf dir
   in pre ++ pack (map encodeBase seq) ++ suf

-- 7

public export
data InputError : Type where
  UnknownBaseType : String -> InputError
  InvalidSequence : String -> InputError

readAcid :  (b : BaseType)
         -> String
         -> Either InputError (d ** List $ Nucleobase b d)
readAcid b str =
  let err = InvalidSequence str
   in case b of
        DNABase => maybeToEither err $ readDNA str
        RNABase => maybeToEither err $ readRNA str

toAcid : (b : BaseType) -> (d ** List $ Nucleobase b d) -> NucleicAcid
toAcid b (d ** seq) = MkNucleicAcid b d seq

getNucleicAcid : IO (Either InputError NucleicAcid)
getNucleicAcid = do
  baseString <- getLine
  case baseString of
    "DNA" => map (toAcid _) . readAcid DNABase <$> getLine
    "RNA" => map (toAcid _) . readAcid RNABase <$> getLine
    _     => pure $ Left (UnknownBaseType baseString)

printRNA : RNA Sense -> IO ()
printRNA = putStrLn . encode _

transcribeProg : IO ()
transcribeProg = do
  Right (MkNucleicAcid b d seq) <- getNucleicAcid
    | Left (InvalidSequence str) => putStrLn $ "Invalid sequence: " ++ str
    | Left (UnknownBaseType str) => putStrLn $ "Unknown base type: " ++ str
  case b of
    DNABase => printRNA $ transcribeAny d seq
    RNABase => case d of
      Sense     => printRNA seq
      Antisense => printRNA $ complement _ seq

--------------------------------------------------------------------------------
--          Use Case: CSV Files with a Schema
--------------------------------------------------------------------------------

-- A lot of code was copy-pasted from the chapter's text and is, therefore
-- not very interesting. I tried to annotate the new parts with some hints
-- for better understanding. Also, instead of grouping code by exercise number,
-- I organized it thematically.

--   *** Types ***

-- I used an indexed type here to make sure, data
-- constructor `Optional` takes only non-nullary types
-- as arguments. As noted in exercise 3, having a nesting
-- of nullary types does not make sense without a way to
-- distinguish between a `Nothing` and a `Just Nothing`,
-- both of which would be encoded as the empty string.
-- For `Finite`, we have to add `n` as an argument to the
-- data constructor, so we can use it to decode values
-- of type `Fin n`.
data ColType0 : (nullary : Bool) -> Type where
  I64      : ColType0 b
  Str      : ColType0 b
  Boolean  : ColType0 b
  Float    : ColType0 b
  Natural  : ColType0 b
  BigInt   : ColType0 b
  Finite   : Nat -> ColType0 b
  Optional : ColType0 False -> ColType0 True

-- This is the type used in schemata, where nullary types
-- are explicitly allowed.
ColType : Type
ColType = ColType0 True

Schema : Type
Schema = List ColType

-- The only interesting new parts are the last two
-- lines. They should be pretty self-explanatory.
IdrisType : ColType0 b -> Type
IdrisType I64          = Int64
IdrisType Str          = String
IdrisType Boolean      = Bool
IdrisType Float        = Double
IdrisType Natural      = Nat
IdrisType BigInt       = Integer
IdrisType (Finite n)   = Fin n
IdrisType (Optional t) = Maybe $ IdrisType t

Row : Schema -> Type
Row = HList . map IdrisType

record Table where
  constructor MkTable
  schema : Schema
  size   : Nat
  rows   : Vect size (Row schema)

data Error : Type where
  ExpectedEOI    : (pos : Nat) -> String -> Error
  ExpectedLine   : Error
  InvalidCell    : (row, col : Nat) -> ColType0 b -> String -> Error
  NoNat          : String -> Error
  OutOfBounds    : (size : Nat) -> (index : Nat) -> Error
  ReadError      : (path : String) -> FileError -> Error
  UnexpectedEOI  : (pos : Nat) -> String -> Error
  UnknownCommand : String -> Error
  UnknownType    : (pos : Nat) -> String -> Error
  WriteError     : (path : String) -> FileError -> Error

-- Oh, the type of `Query` is a nice one. :-)
-- `PrintTable`, on the other hand, is trivial.
-- The save and load commands are special: They will
-- already have carried out their tasks after parsing.
-- This allow us to keep `applyCommand` pure.
data Command : (t : Table) -> Type where
  PrintSchema : Command t
  PrintSize   : Command t
  PrintTable  : Command t
  Load        : Table -> Command t
  Save        : Command t
  New         : (newSchema : Schema) -> Command t
  Prepend     : Row (schema t) -> Command t
  Get         : Fin (size t) -> Command t
  Delete      : Fin (size t) -> Command t
  Quit        : Command t
  Query       :  (ix  : Fin (length $ schema t))
              -> (val : IdrisType $ indexList (schema t) ix)
              -> Command t

--   *** Core Functionality ***

-- Compares two values for equality.
eq : (c : ColType0 b) -> IdrisType c -> IdrisType c -> Bool
eq I64          x        y        = x == y
eq Str          x        y        = x == y
eq Boolean      x        y        = x == y
eq Float        x        y        = x == y
eq Natural      x        y        = x == y
eq BigInt       x        y        = x == y
eq (Finite k)   x        y        = x == y
eq (Optional z) (Just x) (Just y) = eq z x y
eq (Optional z) Nothing  Nothing  = True
eq (Optional z) _        _        = False

-- Note: It would have been quite a bit easier to type and
-- implement this, had we used a heterogeneous vector instead
-- of a heterogeneous list for encoding table rows. However,
-- I still think it's pretty cool that this type checks!
eqAt :  (ts  : Schema)
     -> (ix  : Fin $ length ts)
     -> (val : IdrisType $ indexList ts ix)
     -> (row : Row ts)
     -> Bool
eqAt (x :: _)  FZ     val (v :: _)  = eq x val v
eqAt (_ :: xs) (FS y) val (_ :: vs) = eqAt xs y val vs
eqAt []        _      _   _ impossible

-- Most new commands don't change the table,
-- so their cases are trivial. The exception is
-- `Load`, which replaces the table completely.
applyCommand : (t : Table) -> Command t -> Table
applyCommand t                 PrintSchema    = t
applyCommand t                 PrintSize      = t
applyCommand t                 PrintTable     = t
applyCommand t                 Save           = t
applyCommand _                 (Load t')      = t'
applyCommand _                 (New ts)       = MkTable ts _ []
applyCommand (MkTable ts n rs) (Prepend r)    = MkTable ts _ $ r :: rs
applyCommand t                 (Get x)        = t
applyCommand t                 Quit           = t
applyCommand t                 (Query ix val) = t
applyCommand (MkTable ts n rs) (Delete x)  = case n of
  S k => MkTable ts k (deleteAt x rs)
  Z   => absurd x

--   *** Parsers ***

zipWithIndex : Traversable t => t a -> t (Nat, a)
zipWithIndex = evalState 1 . traverse pairWithIndex
  where pairWithIndex : a -> State Nat (Nat,a)
        pairWithIndex v = (,v) <$> get <* modify S

fromCSV : String -> List String
fromCSV = forget . split (',' ==)

-- Reads a primitive (non-nullary) type. This is therefore
-- universally quantified over parameter `b`.
-- The only interesting part is the parsing of `finXYZ`,
-- where we `break` the string at the occurrence of
-- the first digit.
readPrim : Nat -> String -> Either Error (ColType0 b)
readPrim _ "i64"      = Right I64
readPrim _ "str"      = Right Str
readPrim _ "boolean"  = Right Boolean
readPrim _ "float"    = Right Float
readPrim _ "natural"  = Right Natural
readPrim _ "bigint"   = Right BigInt
readPrim n s          =
  let err = Left $ UnknownType n s
   in case break isDigit s of
        ("fin",r) => maybe err (Right . Finite) $ parsePositive r
        _         => err

-- This is the parser for (possibly nullary) column types.
-- A nullary type is encoded as the corresponding non-nullary
-- type with a question mark appended. We therefore first check
-- for the presence of said question mark at the end of the string.
readColType : Nat -> String -> Either Error ColType
readColType n s = case reverse (unpack s) of
  '?' :: t => Optional <$> readPrim n (pack $ reverse t)
  _        => readPrim n s

readSchema : String -> Either Error Schema
readSchema = traverse (uncurry readColType) . zipWithIndex . fromCSV

readSchemaList : List String -> Either Error Schema
readSchemaList [s] = readSchema s
readSchemaList _   = Left ExpectedLine

-- For all except nullary types we can just use the `CSVField`
-- implementation for reading values.
-- For values of nullary types, we treat the empty string specially.
decodeF : (c : ColType0 b) -> String -> Maybe (IdrisType c)
decodeF I64          s  = read s
decodeF Str          s  = read s
decodeF Boolean      s  = read s
decodeF Float        s  = read s
decodeF Natural      s  = read s
decodeF BigInt       s  = read s
decodeF (Finite k)   s  = read s
decodeF (Optional y) "" = Just Nothing
decodeF (Optional y) s  = Just <$> decodeF y s

decodeField : (row,col : Nat) -> (c : ColType0 b) -> String -> Either Error (IdrisType c)
decodeField row k c s = maybeToEither (InvalidCell row k c s) $ decodeF c s

decodeRow : {ts : _} -> (row : Nat) -> String -> Either Error (Row ts)
decodeRow row s = go 1 ts $ fromCSV s
  where go : Nat -> (cs : Schema) -> List String -> Either Error (Row cs)
        go k []       []         = Right []
        go k []       (_ :: _)   = Left $ ExpectedEOI k s
        go k (_ :: _) []         = Left $ UnexpectedEOI k s
        go k (c :: cs) (s :: ss) = [| decodeField row k c s :: go (S k) cs ss |]

decodeRows : {ts : _} -> List String -> Either Error (List $ Row ts)
decodeRows = traverse (uncurry decodeRow) . zipWithIndex

readFin : {n : _} -> String -> Either Error (Fin n)
readFin s = do
  S k <- maybeToEither (NoNat s) $ parsePositive {a = Nat} s
    | Z => Left $ OutOfBounds n Z
  maybeToEither (OutOfBounds n $ S k) $ natToFin k n

readCommand :  (t : Table) -> String -> Either Error (Command t)
readCommand _                "schema"  = Right PrintSchema
readCommand _                "size"    = Right PrintSize
readCommand _                "table"   = Right PrintTable
readCommand _                "quit"    = Right Quit
readCommand (MkTable ts n _) s         = case words s of
  ["new",    str]    => New     <$> readSchema str
  "add" ::   ss      => Prepend <$> decodeRow 1 (unwords ss)
  ["get",    str]    => Get     <$> readFin str
  ["delete", str]    => Delete  <$> readFin str
  "query" :: n :: ss => do
    ix  <- readFin n
    val <- decodeField 1 1 (indexList ts ix) (unwords ss)
    pure $ Query ix val
  _                  => Left $ UnknownCommand s

--   *** Printers ***

toCSV : List String -> String
toCSV = concat . intersperse ","

-- We mark optional type by appending a question
-- mark after the corresponding non-nullary type.
showColType : ColType0 b -> String
showColType I64          = "i64"
showColType Str          = "str"
showColType Boolean      = "boolean"
showColType Float        = "float"
showColType Natural      = "natural"
showColType BigInt       = "bigint"
showColType (Finite n)   = "fin\{show n}"
showColType (Optional t) = showColType t ++ "?"

-- Again, only nullary values are treated specially. This
-- is another case of a dependent pattern match: We use
-- explicit pattern matches on the value to encode based
-- on the type calculated from the `ColType0 b` parameter.
-- There are few languages capable of expressing this as
-- cleanly as Idris does.
encodeField : (t : ColType0 b) -> IdrisType t -> String
encodeField I64          x        = show x
encodeField Str          x        = x
encodeField Boolean      True     = "t"
encodeField Boolean      False    = "f"
encodeField Float        x        = show x
encodeField Natural      x        = show x
encodeField BigInt       x        = show x
encodeField (Finite k)   x        = show x
encodeField (Optional y) (Just v) = encodeField y v
encodeField (Optional y) Nothing  = ""

encodeFields : (ts : Schema) -> Row ts -> Vect (length ts) String
encodeFields []        []        = []
encodeFields (c :: cs) (v :: vs) = encodeField c v :: encodeFields cs vs

encodeTable : Table -> String
encodeTable (MkTable ts _ rows) =
  unlines . toList $ map (toCSV . toList . encodeFields ts) rows

encodeSchema : Schema -> String
encodeSchema = toCSV . map showColType

-- Pretty printing a table plus header. All cells are right-padded
-- with spaces to adjust their size to the cell with the longest
-- entry for each colum.
-- Value `ls` is a `Vect n Nat` holding these lengths.
-- Here is an example of how the output looks like:
--
-- fin100 | boolean | natural | str         | bigint?
-- --------------------------------------------------
-- 88     | f       | 10      | stefan      |
-- 13     | f       | 10      | hock        | -100
-- 58     | t       | 1000    | hello world | -1234
--
-- Ideally, numeric values would be right-aligned, but since this
-- whole exercise is already quite long and complex, I refrained
-- from adding this luxury.
prettyTable :  {n : _}
            -> (header : Vect n String)
            -> (table  : Vect m (Vect n String))
            -> String
prettyTable h t =
  let -- vector holding the maximal length of each column
      ls  = foldl (zipWith $ \k => max k . length) (replicate n Z) (h::t)

      -- horizontal bar used to separate the header from the rows
      bar = concat . intersperse "---" $ map (`replicate` '-') ls
   in unlines . toList $ line ls h :: bar :: map (line ls) t

  where pad : Nat -> String -> String
        pad v = padRight v ' '

        -- given a vector of lengths, pads each string to the
        -- desired length, separating cells with a vertical bar.
        line : Vect n Nat -> Vect n String -> String
        line lengths = concat . intersperse " | " . zipWith pad lengths

printTable :  (cs   : List ColType)
           -> (rows : Vect n (Row cs))
           -> String
printTable cs rows =
  let header  = map showColType $ fromList cs
      table   = map (encodeFields cs) rows
   in prettyTable header table

allTypes : String
allTypes = concat
         . List.intersperse ", "
         . map (showColType {b = True})
         $ [I64,Str,Boolean,Float]

showError : Error -> String
showError ExpectedLine = """
  Error when reading schema.
  Expected a single line of content.
  """

showError (UnknownCommand x) = """
  Unknown command: \{x}.
  Known commands are: clear, schema, size, table, new, add, get, delete, quit.
  """

showError (UnknownType pos x) = """
  Unknown type at position \{show pos}: \{x}.
  Known types are: \{allTypes}.
  """

showError (InvalidCell row col tpe x) = """
  Invalid value at row \{show row}, column \{show col}.
  Expected type: \{showColType tpe}.
  Value found: \{x}.
  """

showError (ExpectedEOI k x) = """
  Expected end of input.
  Position: \{show k}
  Input: \{x}
  """

showError (UnexpectedEOI k x) = """
  Unxpected end of input.
  Position: \{show k}
  Input: \{x}
  """

showError (OutOfBounds size index) = """
  Index out of bounds.
  Size of table: \{show size}
  Index: \{show index}
  Note: Indices start at zero.
  """

showError (WriteError path err) = """
  Error when writing file \{path}.
  Message: \{show err}
  """

showError (ReadError path err) = """
  Error when reading file \{path}.
  Message: \{show err}
  """

showError (NoNat x) = "Not a natural number: \{x}"

result :  (t : Table) -> Command t -> String
result t PrintSchema    = "Current schema: \{encodeSchema t.schema}"
result t PrintSize      = "Current size: \{show t.size}"
result t PrintTable     = "Table:\n\n\{printTable t.schema t.rows}"
result _ Save           = "Table written to disk."
result _ (Load t)       = "Table loaded. Schema: \{encodeSchema t.schema}"
result _ (New ts)       = "Created table. Schema: \{encodeSchema ts}"
result t (Prepend r)    = "Row prepended:\n\n\{printTable t.schema [r]}"
result _ (Delete x)     = "Deleted row: \{show $ FS x}."
result _ Quit           = "Goodbye."
result t (Query ix val) =
  let (_ ** rs) = filter (eqAt t.schema ix val) t.rows
   in "Result:\n\n\{printTable t.schema rs}"
result t (Get x)        =
  "Row \{show $ FS x}:\n\n\{printTable t.schema [index x t.rows]}"

--   *** File IO ***

-- We use partial function `readFile` for simplicity here.
partial
load :  (path   : String)
     -> (decode : List String -> Either Error a)
     -> IO (Either Error a)
load path decode = do
  Right ls <- readFile path
    | Left err        => pure $ Left (ReadError path err)
  pure $ decode (filter (not . null) $ lines ls)

write : (path : String) -> (content : String) -> IO (Either Error ())
write path content = mapFst (WriteError path) <$> writeFile path content

namespace IOEither
  export
  (>>=) : IO (Either err a) -> (a -> IO (Either err b)) -> IO (Either err b)
  ioa >>= f = Prelude.(>>=) ioa (either (pure . Left) f)

  export
  (>>) : IO (Either err ()) -> IO (Either err a) -> IO (Either err a)
  (>>) x y = x >>= const y

  export
  pure : a -> IO (Either err a)
  pure = Prelude.pure . Right

partial
readCommandIO : (t : Table) -> String -> IO (Either Error (Command t))
readCommandIO t s = case words s of
  ["save", pth] => IOEither.do
    write (pth ++ ".schema") (encodeSchema t.schema)
    write (pth ++ ".csv") (encodeTable t)
    pure Save

  ["load", pth] => IOEither.do
    schema <- load (pth ++ ".schema") readSchemaList
    rows   <- load (pth ++ ".csv") (decodeRows {ts = schema})
    pure . Load $ MkTable schema (length rows) (fromList rows)

  _ => Prelude.pure $ readCommand t s

--   *** Main Loop ***

partial
runProg : Table -> IO ()
runProg t = do
  putStr "Enter a command: "
  str <- getLine
  cmd <- readCommandIO t str
  case cmd of
    Left err   => putStrLn (showError err) >> runProg t
    Right Quit => putStrLn (result t Quit)
    Right cmd  => putStrLn (result t cmd) >>
                  runProg (applyCommand t cmd)

partial
main : IO ()
main = runProg $ MkTable [] _ []


-- --------------------------------------------------------------- [ Graph.idr ]
-- Module    : Graph.idr
-- Copyright : (c) 2015,2016 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| A Graph implementation based on Adjacency Lists.
|||
||| The underlying implementation is that of an AVL-based Dictionary
||| that associates a `(id,value)` pair to an adjacency list
||| `(id,label)`.
module Data.AVL.Graph

import Data.AVL
import Data.AVL.Set

import public Data.AVL.Dict

%access export

||| Node Identifier
public export
NodeID : Type
NodeID = Nat

||| A labelled edge between two nodes using NodeID
public export
Edge : Type -> Type
Edge b = (NodeID, NodeID, Maybe b)

||| A demi labeld Edge
public export
DemiEdge : Type -> Type
DemiEdge b = (NodeID, Maybe b)

||| Adjacency 'list' denoting adjacent nodes in the graph.
||| The list is a dict between destination `NodeID` and label.
|||
||| Note:: Should probably change this to a dict with a list of edges,
||| but that is too much work at the momemt.
public export
AList : Type -> Type
AList b = List (NodeID, Maybe b)

-- ------------------------------------------------------------------- [ Types ]
public export
GraphRep : (vTy : Type) -> (eTy : Type) -> Type
GraphRep vTy eTy = Dict NodeID (vTy, AList eTy)

||| A compact adjacency list representation of a graph.
|||
||| Implementation details:
|||
||| The Graph is actually a record that contains:
|||
||| 1. A labelling `counter`.
||| 2. An association list to contain value to identifier pairings.
||| 3. A BST-based dictionary containing the adjacency Lists.
|||
||| A BST based (AVL) Dictionary is used as the underlying data
||| structure, access to a node's adjaceny list should be `O(log
||| n)`. Constant time access to elements in the graph is not
||| guaranteed.
|||
||| The dictionary is indexed using a *Node Identifier* (`Nat`), as
||| Idris does not have support for hashes, cryptographic or
||| otherwise. Future work will be to replace the simple labelling
||| mnemoic with a hash. As such we need a secondary map to keep
||| record of what values map to what `NodeID`. To simplify matters a
||| association list is used to reduce the need for values in the
||| graph to be orderable.
|||
||| The dictionary stores a node value, successor list pairing as the
||| value.
|||
||| @vTy The type of the value associated with the vertex.
||| @eTy The type of the label used on edges.
public export
record Graph (vTy : Type) (eTy : Type) where
  constructor MkGraph
  counter : NodeID
  legend  : List (vTy, NodeID)
  graph   : GraphRep vTy eTy

public export
Legend : Type -> Type
Legend vTy = List (vTy, NodeID)

implementation (Show v, Show e) => Show (Graph v e) where
  show (MkGraph _ _ g) = show g

-- ---------------------------------------------------------- [ Legend Utility ]
private
delFromLegend : ((v,NodeID) -> Bool) -> Legend v -> Legend v
delFromLegend f Nil = Nil
delFromLegend f (x::xs) =
  if f x
    then xs
    else x::xs

private
insertLegend : Eq v => v -> NodeID -> Legend v -> Legend v
insertLegend val id l = (val, id) :: delFromLegend (\(x,_) => x == val) l

private
updateLegend : Eq v => v -> v -> Legend v -> Legend v
updateLegend old new l = map (\(x,id) => if x == old then (new,id) else (x,id)) l

-- ------------------------------------------------------------ [ Construction ]

mkEmptyGraph : Graph v e
mkEmptyGraph = MkGraph Z Nil empty

||| Add an orphan node to the graph.
|||
||| To insert a connected node use `insert` instead.
addNode : Eq v => v -> Graph v e -> Graph v e
addNode val (MkGraph c l g) = MkGraph (S c) newL newG
  where
    newG : GraphRep v e
    newG = insert c (val,Nil) g

    newL : Legend v
    newL = insertLegend val c l

||| Add many orphan nodes to the graph.
addNodes : Eq v => List v -> Graph v e -> Graph v e
addNodes vs g = foldl (flip $ addNode) g vs

getNodeIDUsing : (v -> Bool) -> Graph v e -> Maybe NodeID
getNodeIDUsing f g = doLook f (legend g)
  where
    doLook : (v -> Bool) -> List (v,NodeID) -> Maybe NodeID
    doLook _ Nil         = Nothing
    doLook f ((x,id)::xs) = if f x then Just id else doLook f xs

||| For a given value return the node id
getNodeID : Eq v => v -> Graph v e -> Maybe NodeID
getNodeID v g = List.lookup v (legend g)

||| Add a labelled edge to the Graph.
addEdge : Edge e -> Graph v e -> Graph v e
addEdge (x,y,l) g =
    case validEdge x y of
      True  => record {graph = doUpdate (x,y,l) (graph g)} g
      False => g
  where
    validEdge : NodeID -> NodeID -> Bool
    validEdge x' y' = hasKey x' (graph g) && hasKey y' (graph g)

    doUpdate : (NodeID, NodeID, Maybe e) -> GraphRep v e -> GraphRep v e
    doUpdate (x'',y'',l') gr = update x'' (\(val,as) => (val, (y'',l')::as)) gr

||| Add multiple labelled edges to the Graph.
addEdges : List (Edge e) -> Graph v e -> Graph v e
addEdges es g = foldl (flip $ addEdge) g es

||| Add Value Edge
addValueEdge : Eq v => (v, v, Maybe e) -> Graph v e -> Graph v e
addValueEdge l g =
    case newEdge l of
      Just e' => addEdge e' g
      Nothing => g
  where
    conv : v -> v -> Maybe (NodeID, NodeID)
    conv x y =
      case getNodeID x g of
        Nothing  => Nothing
        Just xID =>
          case getNodeID y g of
            Nothing  => Nothing
            Just yID => Just (xID,yID)

    newEdge : (v, v, Maybe e) -> Maybe $ (Edge e)
    newEdge (x',y',l') =
      case conv x' y' of
        Just (xID', yID') => Just (xID',yID',l')
        otherwise       => Nothing

addValueEdges : Eq v => List (v,v, Maybe e) -> Graph v e -> Graph v e
addValueEdges vs g  = foldl (flip $ addValueEdge) g vs

||| Insert a node, complete with predefined adjacency list to the graph.
insertNode : Eq v => v -> AList e -> Graph v e -> Graph v e
insertNode val es (MkGraph c l g) = MkGraph (S c) newL (insert c (val,es) g)
  where
    newL : Legend v
    newL = insertLegend val c l

-- ------------------------------------------------------------------- [ Dumps ]

||| Return the a list of node identifiers used in the graph.
verticesID : Graph v e -> List NodeID
verticesID g = map (snd) (legend g)

||| Return the list of nodes in the graph.
vertices : Graph v e -> List v
vertices g = map (fst) (legend g)

||| Return the list of edges within the graph.
edges : Graph v e -> List (Edge e)
edges g = func $ toList $ graph g
  where
    func' : NodeID -> (v, AList e) -> List (Edge e)
    func' id (_,es) = map (\(y,l) => (id,y,l)) es

    func : List (NodeID, (v,AList e)) -> List (Edge e)
    func xs = foldl (\res,(x,y) => func' x y ++ res) Nil xs

-- ----------------------------------------------------------------- [ Lookups ]

||| Using Node ID, extract the node value and adjacency list from the graph.
lookupNodeByID : NodeID -> Graph v e -> Maybe $ (v, AList e)
lookupNodeByID n g = lookup n (graph g)

||| Using the node value, extract the node value and adjaceny list from the graph.
lookupNode : Eq v => v -> Graph v e -> Maybe (v, AList e)
lookupNode val g =
  case List.lookup val (legend g) of
    Just id => lookup id (graph g)
    Nothing => Nothing

-- ----------------------------------------------------------------- [ Queries ]

||| Does the graph contain a node with a specific value.
hasValue : Eq v => v -> Graph v e -> Bool
hasValue v g = isJust $ getNodeID v g

||| Get a nodes value
getValueByID : NodeID -> Graph v e -> Maybe v
getValueByID id g =
   case lookup id (graph g) of
      Just (val,_) => Just val
      Nothing      => Nothing

||| Get Node Value
getValueUsing : (v -> Bool) -> Graph v e -> Maybe v
getValueUsing f g = doLook f (legend g)
  where
    doLook : (v -> Bool) -> List (v,NodeID) -> Maybe v
    doLook _ Nil         = Nothing
    doLook f ((x,_)::xs) = if f x then Just x else doLook f xs

||| Get a nodes successors.
getSuccsByID : NodeID -> Graph v e -> List NodeID
getSuccsByID id g =
  case lookup id (graph g) of
    Just (_,as) => map fst as
    Nothing     => Nil

||| Get a nodes successor
getSuccs : Eq v => v -> Graph v e -> List NodeID
getSuccs val g =
  case getNodeID val g of
    Nothing => Nil
    Just id => getSuccsByID id g

||| Get the adjaceny list for an node
getEdgesByID : NodeID -> Graph v e -> List (DemiEdge e)
getEdgesByID id g =
  case lookup id (graph g) of
    Nothing     => Nil
    Just (_,as) => as

||| Get the adjaceny list for an node.
getEdges : Eq v => v -> Graph v e -> List (DemiEdge e)
getEdges val g =
  case getNodeID val g of
    Just id => getEdgesByID id g
    Nothing => Nil

||| Get the full edge description
getEdgesVerboseByID : NodeID -> Graph v e -> List (Edge e)
getEdgesVerboseByID id g =
  case lookup id (graph g) of
    Nothing     => Nil
    Just (_,as) => map (\(destID,label) => (id,destID,label)) as

||| Get the full edge description
getEdgesVerbose : Eq v => v -> Graph v e -> List (Edge e)
getEdgesVerbose val g =
  case getNodeID val g of
    Just id => getEdgesVerboseByID id g
    Nothing => Nil

-- ----------------------------------------------------------------- [ Updates ]
private
updateLegendByID : NodeID -> (v -> v) -> Legend v -> Legend v
updateLegendByID x f l = map (\(oval,y) => if x == y then (f oval,y) else (oval,y)) l

updateNodeValueByIDUsing : Eq v => NodeID -> (v -> v) -> Graph v e -> Graph v e
updateNodeValueByIDUsing id f g = record {graph = newG id f, legend = newL id f} g
  where
    newG : Eq v => NodeID -> (v -> v) -> GraphRep v e
    newG i f = update i (\(o,as) => (f o, as)) (graph g)

    newL : NodeID -> (v -> v) -> Legend v
    newL i f = updateLegendByID i f (legend g)

updateNodeValueUsing : Eq v => v -> (v -> v) -> Graph v e -> Graph v e
updateNodeValueUsing oldval f g =
  case getNodeID oldval g of
    Nothing => g
    Just id => updateNodeValueByIDUsing id f g

replaceNodeValueByID : Eq v => NodeID -> v -> Graph v e -> Graph v e
replaceNodeValueByID id val g = updateNodeValueByIDUsing id (\x => val) g

replaceNodeValue : Eq v => v -> v -> Graph v e -> Graph v e
replaceNodeValue val newVal g =
  case getNodeID val g of
    Just id => replaceNodeValueByID id newVal g
    Nothing => g

-- -------------------------------------------------------------------- [ Misc ]

getValuesByID : List NodeID -> Graph v e -> List v
getValuesByID is g = catMaybes $ map (\x => getValueByID x g) is

-- foldr (\(v,id),res => if elem id is then v::res else res) List.Nil (legend g)

leafNodes : Graph v e -> List NodeID
leafNodes g = filter (\x => isNil (getSuccsByID x g)) (verticesID g)

rootNodes : Graph v e -> List NodeID
rootNodes g = Set.toList $ Set.difference parents succs
  where
    parents : Set NodeID
    parents = Set.fromList $ filter (\x => isCons (getSuccsByID x g)) (verticesID g)

    nodes : Set NodeID
    nodes = Set.fromList (verticesID g)

    succs : Set NodeID
    succs = Set.fromList $ concatMap (\x => getSuccsByID x g) (verticesID g)

disconnectedNodes : Graph v e -> List NodeID
disconnectedNodes g = Set.toList $ Set.difference (Set.fromList nodes) cNodes
  where
    nodes : List NodeID
    nodes = (verticesID g)

    yNodes : List NodeID
    yNodes = concatMap (\x => getSuccsByID x g) nodes

    xNodes : List NodeID
    xNodes = filter (\x => isCons (getSuccsByID x g)) nodes

    cNodes : Set NodeID
    cNodes = Set.fromList $ xNodes ++ yNodes

isDisconnected : Graph v e -> Bool
isDisconnected g = isCons $ (disconnectedNodes g)

-- ------------------------------------------------------------- [ Build Graph ]

||| Construct a graph using a list of nodes and a list of edges.
buildG : Eq v => List v -> List (v,v, Maybe e) -> Graph v e
buildG Nil _   = mkEmptyGraph
buildG ns  Nil = addNodes ns mkEmptyGraph
buildG ns  es  = addValueEdges es $ addNodes ns mkEmptyGraph
  where
    g : Graph v e
    g = addNodes ns mkEmptyGraph

    g' : Graph v e
    g' = addValueEdges es g

-- --------------------------------------------------------------------- [ EOF ]


module Data.Prim.Bits64

import public Control.WellFounded
import public Data.DPair
import public Data.Prim.Ord
import public Algebra.Solver.Ring
import Syntax.PreorderReasoning

%default total

unsafeRefl : a === b
unsafeRefl = believe_me (Refl {x = a})

--------------------------------------------------------------------------------
--          (<)
--------------------------------------------------------------------------------

||| Witness that `m < n === True`.
export
data (<) : (m,n : Bits64) -> Type where
  LT : {0 m,n : Bits64} -> (0 prf : (m < n) === True) -> m < n

||| Contructor for `(<)`.
|||
||| This can only be used in an erased context.
export %hint
0 mkLT : (0 prf : (m < n) === True) -> m < n
mkLT = LT

||| Extractor for `(<)`.
|||
||| This can only be used in an erased context.
export
0 runLT : m < n -> (m < n) === True
runLT (LT prf) = prf

||| We don't trust values of type `(<)` too much,
||| so we use this when creating magical results.
export
strictLT : (0 p : m < n) -> Lazy c -> c
strictLT (LT prf) x = x

--------------------------------------------------------------------------------
--          Aliases
--------------------------------------------------------------------------------

||| Flipped version of `(<)`.
public export
0 (>) : (m,n : Bits64) -> Type
m > n = n < m

||| `m <= n` mean that either `m < n` or `m === n` holds.
public export
0 (<=) : (m,n : Bits64) -> Type
m <= n = Either (m < n) (m === n)

||| Flipped version of `(<=)`.
public export
0 (>=) : (m,n : Bits64) -> Type
m >= n = n <= m

||| `m /= n` mean that either `m < n` or `m > n` holds.
public export
0 (/=) : (m,n : Bits64) -> Type
m /= n = Either (m < n) (m > n)

--------------------------------------------------------------------------------
--          Order
--------------------------------------------------------------------------------

0 ltNotEQ : m < n -> Not (m === n)
ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ")

0 ltNotGT : m < n -> Not (n < m)
ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT")

0 eqNotLT : m === n -> Not (m < n)
eqNotLT = flip ltNotEQ

export
comp : (m,n : Bits64) -> Trichotomy (<) m n
comp m n = case prim__lt_Bits64 m n of
  0 => case prim__eq_Bits64 m n of
    0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl)
    x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl)
  x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl)

export
Total Bits64 (<) where
  trichotomy   = comp
  transLT p q  = strictLT p $ strictLT q $ LT unsafeRefl

--------------------------------------------------------------------------------
--          Bounds and Well-Foundedness
--------------------------------------------------------------------------------

||| Lower bound of `Bits64`
public export
MinBits64 : Bits64
MinBits64 = 0

||| Upper bound of `Bits64`
public export
MaxBits64 : Bits64
MaxBits64 = 0xffffffffffffffff

||| `m >= 0` for all `m` of type `Bits64`.
export
0 GTE_MinBits64 : (m : Bits64) -> m >= MinBits64
GTE_MinBits64 m = case comp MinBits64 m of
  LT x f g => %search
  EQ f x g => %search
  GT f g x => assert_total $ idris_crash "IMPOSSIBLE: Bits64 smaller than 0"

||| Not value of type `Bits64` is less than zero.
export
0 Not_LT_MinBits64 : m < 0 -> Void
Not_LT_MinBits64 = GTE_not_LT (GTE_MinBits64 m)

||| `m <= MaxBits64` for all `m` of type `Bits64`.
export
0 LTE_MaxBits64 : (m : Bits64) -> m <= MaxBits64
LTE_MaxBits64 m = case comp m MaxBits64 of
  LT x f g => %search
  EQ f x g => %search
  GT f g x => assert_total
            $ idris_crash "IMPOSSIBLE: Bits64 greater than \{show MaxBits64}"

||| Not value of type `Bits64` is greater than `MaxBits64`.
export
0 Not_GT_MaxBits64 : m > MaxBits64 -> Void
Not_GT_MaxBits64 = LTE_not_GT (LTE_MaxBits64 m)

||| Every value of type `Bits64` is accessible with relation
||| to `(<)`.
export
accessLT : (m : Bits64) -> Accessible (<) m
accessLT m = Access $ \n,lt => accessLT (assert_smaller m n)

||| `(<)` is well founded.
export %inline
WellFounded Bits64 (<) where
  wellFounded = accessLT

||| Every value of type `Bits64` is accessible with relation
||| to `(>)`.
export
accessGT : (m : Bits64) -> Accessible (>) m
accessGT m = Access $ \n,gt => accessGT (assert_smaller m n)

||| `(>)` is well founded.
export %inline
[GT] WellFounded Bits64 (>) where
  wellFounded = accessGT

--------------------------------------------------------------------------------
--          Arithmetics
--------------------------------------------------------------------------------

||| Safe division.
|||
||| This uses `0 < d` as a constraint instead
||| of `0 /= d`, because in my experience, the former
||| is much more useful.
export %inline
sdiv : (n,d : Bits64) -> (0 prf : 0 < d) => Bits64
sdiv n d = n `div` d

||| Refined division.
|||
||| This comes with a proof that the result is
||| strictly smaller than `n`.
|||
||| This uses `0 < n` as a constraint instead
||| of `0 /= n`, because in my experience, the former
||| is much more useful.
export %inline
rdiv :  (n,d : Bits64)
     -> (0 dgt1 : 1 < d)
     => (0 ngt0 : 0 < n)
     => Subset Bits64 (< n)
rdiv n d = Element (n `div` d) (LT unsafeRefl)

||| Safe modulo.
|||
||| This uses `0 < d` as a constraint instead
||| of `0 /= d`, because in my experience, the former
||| is much more useful.
|||
||| If you need the postcondition that the result is strictly
||| smaller than `d`, use `rmod` instead.
export %inline
smod : (n,d : Bits64) -> (0 prf : 0 < d) => Bits64
smod n d = n `mod` d

||| Refined modulo.
|||
||| This comes with a proof that the result is strictly smaller
||| than `d`.
|||
||| It uses `0 < d` as a constraint instead
||| of `0 /= d`, because in my experience, the former
||| is much more useful.
export %inline
rmod : (n,d : Bits64) -> (0 prf : 0 < d) => Subset Bits64 (< d)
rmod n d = Element (n `mod` d) (LT unsafeRefl)


module Control.Lens.Review
import Data.Contravariant
import Control.Lens.Types
import Control.Lens.Getter
import Control.Monad.Identity
import Data.Profunctor
import Data.Tagged

%default total
%access public export

infixr 8 #

(#) : AReview t b -> b -> t
(#) p = runIdentity . untag . p . MkTagged . Id

re : AReview t b -> Getter b t
re p = to (p #)


module Task.Equality

import Task.Internal
import Task.Semantics

import Helpers

%default total
%access export

-- Equivallence ----------------------------------------------------------------

equivallent : MonadRef l m => TaskT m a -> TaskT m a -> m Bool
equivallent {a} t1 t2 = do
  t1' <- normalise t1
  t2' <- normalise t2
  v1 <- value t1'
  v2 <- value t2'
  let _ = eq a --NOTE: Brings `Eq` in scope for universe type `a`
  pure $ v1 == v2

-- Similarity ------------------------------------------------------------------

similar : MonadTrace NotApplicable m => MonadRef l m => TaskT m a -> TaskT m a -> m Bool
similar {a} t1 t2 = do
  t1' <- normalise t1
  t2' <- normalise t2
  v1 <- value t1'
  v2 <- value t2'
  let _ = eq a --NOTE: Brings `Eq` in scope for universe type `a`
  if v1 == v2 then do
    ok12 <- sim t1 t2
    ok21 <- sim t2 t1
    pure $ ok12 && ok21
  else
    pure False
where
    sim : MonadTrace NotApplicable m => MonadRef l m => TaskT m a -> TaskT m a -> m Bool
    sim t1 t2 = do
      is1 <- inputs t1
      is2 <- inputs t2
      pairs <- sequence [ bisequence ( handle t1 i1, handle t2 i2 ) | i1 <- is1, i2 <- is2, i2 =~ i1 ]
      results <- sequence $ map (uncurry similar) pairs
      pure $ and results

-- Conform ---------------------------------------------------------------------


module Control.Effect.Labelled

import Control.EffectAlgebra

||| Wrap an effect in a label.
||| This can help disambiguate between multiple identical effects and
||| lessen the number of type annotations.
public export
data Labelled : (label : k)
             -> (sub : (Type -> Type) -> (Type -> Type))
             -> (m : Type -> Type) -> (Type -> Type) where
  MkLabelled : (eff : sub m a) -> Labelled label sub m a

public export
runLabelled : Labelled label sub m a -> sub m a
runLabelled (MkLabelled eff) = eff

public export
Functor (sub m) => Functor (Labelled label sub m) where
  map f (MkLabelled x) = MkLabelled (map f x)

public export
Applicative (sub m) => Applicative (Labelled label sub m) where
  pure x = MkLabelled (pure x)

  (MkLabelled f) <*> (MkLabelled x) = MkLabelled (f <*> x)

public export
Monad (sub m) => Monad (Labelled label sub m) where
  (MkLabelled x) >>= f = MkLabelled (x >>= runLabelled . f)

public export
Algebra (eff :+: sig) (sub m)
  => Algebra (Labelled label eff :+: sig)
             (Labelled label sub m) where
  alg ctxx hdl (Inl (MkLabelled x)) = MkLabelled $
    alg {sig = eff :+: sig, m = sub m}
        ctxx (runLabelled . hdl) (Inl x)
  alg ctxx hdl (Inr x) = MkLabelled $
    alg {sig = eff :+: sig, m = sub m}
        ctxx (runLabelled . hdl) (Inr x)

||| Higher-order injections where signatures are inferred from the label.
public export
interface InjL (0 label : k)
               (0 sub : (Type -> Type) -> (Type -> Type))
               (0 sup : (Type -> Type) -> (Type -> Type)) | label where
  constructor MkSubL
  injLabelled : Labelled label sub m a -> sup m a

public export
[LabelAuto] Inj sub sup => InjL label sub sup where
  injLabelled (MkLabelled x) = inj x

public export
Label : Inj sub sup -> InjL label sub sup
Label x = LabelAuto @{x}

public export
labelled : (label : k)
        -> InjL label sub sig
        => Algebra sig m
        => sub m a -> m a
labelled label @{sub} x =
  let y = injLabelled (MkLabelled {label} x) in
  alg {ctx = id} () id y


||| SipHash24 copied from C [reference implementation](https://github.com/veorq/SipHash/blob/master/siphash.c)
module Data.Hashable.SipHash

import Data.Buffer
import Data.IORef

%default total

%inline
CROUNDS : Nat
CROUNDS = 2

%inline
DROUNDS : Nat
DROUNDS = 4

record State where
    constructor MkState
    v0 : Bits64
    v1 : Bits64
    v2 : Bits64
    v3 : Bits64

%inline
shl : Bits64 -> Bits64 -> Bits64
shl = prim__shl_Bits64

%inline
shr : Bits64 -> Bits64 -> Bits64
shr = prim__shr_Bits64

%inline
bor : Bits64 -> Bits64 -> Bits64
bor = prim__or_Bits64

%inline
xor : Bits64 -> Bits64 -> Bits64
xor = prim__xor_Bits64

%inline
and : Int -> Int -> Int
and = prim__and_Int

%inline
%spec b
rotl : Bits64 -> (b : Bits64) -> Bits64
rotl x b = (x `shl` b) `bor` (x `shr` (64 - b))

||| Make the length the smallest multiple of 8 bytes >= the given number
%inline
fullSize : Int -> Int
fullSize x =
    let left = x `prim__and_Int` 7
     in if (x `prim__and_Int` 7) == 0
        then x
        else x - left + 8

-- %inline
compress : IORef State -> IO ()
compress stref = do
    MkState v0 v1 v2 v3 <- readIORef stref
    let v0 = v0 + v1;
        v1 = v1 `rotl` 13;
        v1 = v1 `xor` v0;
        v0 = v0 `rotl` 32;
        v2 = v2 + v3;
        v3 = v3 `rotl` 16;
        v3 = v3 `xor` v2;
        v0 = v0 + v3;
        v3 = v3 `rotl` 21;
        v3 = v3 `xor` v0;
        v2 = v2 + v1;
        v1 = v1 `rotl` 17;
        v1 = v1 `xor` v2;
        v2 = v2 `rotl` 32;
    writeIORef stref $ MkState v0 v1 v2 v3

-- this could all be in ST, but Buffer doesn't support it
%inline
siphashInit : IO (IORef State)
siphashInit = newIORef $ MkState
    { v0 = 0x736f6d6570736575
    , v1 = 0x646f72616e646f6d
    , v2 = 0x6c7967656e657261
    , v3 = 0x7465646279746573
    }

%inline
%spec count
repeat : (count : Nat) -> IO () -> IO ()
repeat Z _ = pure ()
repeat (S k) act = act >> repeat k act

siphashLoop : IORef State -> Buffer -> Int -> Int -> IO ()
siphashLoop stref buf idx len = if idx >= len
    then pure ()
    else do
        m <- getBits64 buf idx
        repeat CROUNDS $ compress stref
        siphashLoop stref buf (assert_smaller idx $ idx + 8) len

%inline
siphashLeftover : IORef State -> Buffer -> Int -> Int -> Int -> IO Bits64
siphashLeftover stref buf size left idx = do
    x <- getBits64 buf idx
    pure $ x `bor` (cast size `shl` 56)

siphash : Buffer -> IO Bits64
siphash buf = do
    stref <- siphashInit
    size <- fullSize <$> rawSize buf
    siphashLoop stref buf 0 size
    let left = size `and` 7
    b <- siphashLeftover stref buf size (size - left) left
    modifyIORef stref $ record { v3 $= (`xor` b) }
    repeat DROUNDS $ compress stref
    modifyIORef stref $ record { v0 $= (`xor` b) }
    MkState v0 v1 v2 v3 <- readIORef stref
    pure $ (v0 `xor` v1) `xor` (v2 `xor` v3)

export
siphashString : String -> Bits64
siphashString str = unsafePerformIO $ do
    Just buf <- newBuffer $ fullSize $ stringByteLength str
        | Nothing => assert_total $ idris_crash "Error allocating buffer"
    setString buf 0 str
    siphash buf


||| Provide Do-Notation support for Indexed Monad. Withouth this, the Indexed interfaces use
||| operators that do not collide with the non-Indexed interfaces.
module Control.Monad.Indexed.Do

import Control.Monad.Indexed

public export
(>>=) : IndexedMonad z m => m a i j -> (a -> m b j k) -> m b i k
(>>=) = (>>>=)

public export
(>>) : IndexedMonad z m => m () i j -> Lazy (m b j k) -> m b i k
(>>) = (>>>)