module Core.Primitives

import Core.Core
import Core.Context
import Core.TT
import Core.Value
import Libraries.Utils.String

import Data.Vect

%default covering

public export
record Prim where
  constructor MkPrim
  {arity : Nat}
  fn : PrimFn arity
  type : ClosedTerm
  totality : Totality

binOp : (Constant -> Constant -> Maybe Constant) ->
        {vars : _} -> Vect 2 (NF vars) -> Maybe (NF vars)
binOp fn [NPrimVal fc x, NPrimVal _ y]
    = map (NPrimVal fc) (fn x y)
binOp _ _ = Nothing

unaryOp : (Constant -> Maybe Constant) ->
          {vars : _} -> Vect 1 (NF vars) -> Maybe (NF vars)
unaryOp fn [NPrimVal fc x]
    = map (NPrimVal fc) (fn x)
unaryOp _ _ = Nothing

b8max : Int
b8max = 0x100

b16max : Int
b16max = 0x10000

b32max : Integer
b32max = 4294967296

b64max : Integer
b64max = 18446744073709551616 -- 0x10000000000000000

bitCastWrap : (i : Integer) -> (max : Integer) -> Integer
bitCastWrap i max
    = if i >= 0 -- oops, we don't have `rem` yet!
        then i `mod` max
        else max + i `mod` max

castString : Vect 1 (NF vars) -> Maybe (NF vars)
castString [NPrimVal fc (I i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (I8 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (I16 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (I32 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (I64 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (BI i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (B8 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (B16 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (B32 i)] = Just (NPrimVal fc (Str (show $ bitCastWrap (the Integer $ cast i) b32max)))
castString [NPrimVal fc (B64 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (Ch i)] = Just (NPrimVal fc (Str (stripQuotes (show i))))
castString [NPrimVal fc (Db i)] = Just (NPrimVal fc (Str (show i)))
castString _ = Nothing

castInteger : Vect 1 (NF vars) -> Maybe (NF vars)
castInteger [NPrimVal fc (I i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (I8 i)] = Just (NPrimVal fc (BI i))
castInteger [NPrimVal fc (I16 i)] = Just (NPrimVal fc (BI i))
castInteger [NPrimVal fc (I32 i)] = Just (NPrimVal fc (BI i))
castInteger [NPrimVal fc (I64 i)] = Just (NPrimVal fc (BI i))
castInteger [NPrimVal fc (B8 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (B16 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (B32 i)] = Just (NPrimVal fc (BI (bitCastWrap (the Integer $ cast i) b32max)))
castInteger [NPrimVal fc (B64 i)] = Just (NPrimVal fc (BI i))
castInteger [NPrimVal fc (Ch i)] = Just (NPrimVal fc (BI (cast (cast {to=Int} i))))
castInteger [NPrimVal fc (Db i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (Str i)] = Just (NPrimVal fc (BI (cast i)))
castInteger _ = Nothing

castInt : Vect 1 (NF vars) -> Maybe (NF vars)
castInt [NPrimVal fc (I8 i)] = Just (NPrimVal fc (I (fromInteger i)))
castInt [NPrimVal fc (I16 i)] = Just (NPrimVal fc (I (fromInteger i)))
castInt [NPrimVal fc (I32 i)] = Just (NPrimVal fc (I (fromInteger i)))
castInt [NPrimVal fc (I64 i)] = Just (NPrimVal fc (I (fromInteger i)))
castInt [NPrimVal fc (BI i)] = Just (NPrimVal fc (I (fromInteger i)))
castInt [NPrimVal fc (B8 i)] = Just (NPrimVal fc (I i))
castInt [NPrimVal fc (B16 i)] = Just (NPrimVal fc (I i))
castInt [NPrimVal fc (B32 i)] = Just (NPrimVal fc (I i))
castInt [NPrimVal fc (B64 i)] = Just (NPrimVal fc (I (fromInteger i)))
castInt [NPrimVal fc (Db i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (Ch i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (Str i)] = Just (NPrimVal fc (I (cast i)))
castInt _ = Nothing

bit8CastWrap : (i : Int) -> Int
bit8CastWrap i = cast $ bitCastWrap (cast i) (cast b8max)

bit16CastWrap : (i : Int) -> Int
bit16CastWrap i = cast $ bitCastWrap (cast i) (cast b16max)

bit32CastWrap : (i : Int) -> Int
bit32CastWrap i = cast $ bitCastWrap (cast i) b32max

bit64CastWrap : (i : Integer) -> Integer
bit64CastWrap i = bitCastWrap i b64max

int8max : Integer
int8max = 0x80

int16max : Integer
int16max = 0x8000

int32max : Integer
int32max = 0x80000000

int64max : Integer
int64max = 0x8000000000000000

intCastWrap : (i : Integer) -> (max : Integer) -> Integer
intCastWrap i max =
  let max2 = 2*max
      i2   = i `mod` max2
      i3   = if i2 < 0 then i2 + max2 else i2
   in if i3 >= max then i3 - max2 else i3

int8CastWrap : (i : Integer) -> Integer
int8CastWrap i = intCastWrap i int8max

int16CastWrap : (i : Integer) -> Integer
int16CastWrap i = intCastWrap i int16max

int32CastWrap : (i : Integer) -> Integer
int32CastWrap i = intCastWrap i int32max

int64CastWrap : (i : Integer) -> Integer
int64CastWrap i = intCastWrap i int64max

constantIntegerValue : Constant -> Maybe Integer
constantIntegerValue (I i)   = Just $ cast i
constantIntegerValue (I8 i)   = Just i
constantIntegerValue (I16 i)   = Just i
constantIntegerValue (I32 i)   = Just i
constantIntegerValue (I64 i)   = Just i
constantIntegerValue (BI i)  = Just i
constantIntegerValue (B8 i)  = Just $ cast i
constantIntegerValue (B16 i) = Just $ cast i
constantIntegerValue (B32 i) = Just $ cast i
constantIntegerValue (B64 i) = Just i
constantIntegerValue _       = Nothing

castBits8 : Vect 1 (NF vars) -> Maybe (NF vars)
castBits8 [NPrimVal fc constant] = do
    value <- constantIntegerValue constant
    let wrapped = bitCastWrap value (cast b8max)
    pure (NPrimVal fc (B8 (cast wrapped)))
castBits8 _ = Nothing

castBits16 : Vect 1 (NF vars) -> Maybe (NF vars)
castBits16 [NPrimVal fc constant] = do
    value <- constantIntegerValue constant
    let wrapped = bitCastWrap value (cast b16max)
    pure (NPrimVal fc (B16 (cast wrapped)))
castBits16 _ = Nothing

castBits32 : Vect 1 (NF vars) -> Maybe (NF vars)
castBits32 [NPrimVal fc constant] = do
    value <- constantIntegerValue constant
    let wrapped = bitCastWrap value b32max
    pure (NPrimVal fc (B32 (cast wrapped)))
castBits32 _ = Nothing

castBits64 : Vect 1 (NF vars) -> Maybe (NF vars)
castBits64 [NPrimVal fc constant] = do
    value <- constantIntegerValue constant
    let wrapped = bitCastWrap value b64max
    pure (NPrimVal fc (B64 wrapped))
castBits64 _ = Nothing

castInt8 : Vect 1 (NF vars) -> Maybe (NF vars)
castInt8 [NPrimVal fc constant] = do
    value <- constantIntegerValue constant
    let wrapped = int8CastWrap value
    pure (NPrimVal fc (I8 wrapped))
castInt8 _ = Nothing

castInt16 : Vect 1 (NF vars) -> Maybe (NF vars)
castInt16 [NPrimVal fc constant] = do
    value <- constantIntegerValue constant
    let wrapped = int16CastWrap value
    pure (NPrimVal fc (I16 wrapped))
castInt16 _ = Nothing

castInt32 : Vect 1 (NF vars) -> Maybe (NF vars)
castInt32 [NPrimVal fc constant] = do
    value <- constantIntegerValue constant
    let wrapped = int32CastWrap value
    pure (NPrimVal fc (I32 wrapped))
castInt32 _ = Nothing

castInt64 : Vect 1 (NF vars) -> Maybe (NF vars)
castInt64 [NPrimVal fc constant] = do
    value <- constantIntegerValue constant
    let wrapped = int64CastWrap value
    pure (NPrimVal fc (I64 wrapped))
castInt64 _ = Nothing

castDouble : Vect 1 (NF vars) -> Maybe (NF vars)
castDouble [NPrimVal fc (I i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (I8 i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (I16 i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (I32 i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (I64 i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (BI i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (Str i)] = Just (NPrimVal fc (Db (cast i)))
castDouble _ = Nothing

castChar : Vect 1 (NF vars) -> Maybe (NF vars)
castChar [NPrimVal fc (I i)] = Just (NPrimVal fc (Ch (cast i)))
castChar _ = Nothing

strLength : Vect 1 (NF vars) -> Maybe (NF vars)
strLength [NPrimVal fc (Str s)] = Just (NPrimVal fc (I (cast (length s))))
strLength _ = Nothing

strHead : Vect 1 (NF vars) -> Maybe (NF vars)
strHead [NPrimVal fc (Str "")] = Nothing
strHead [NPrimVal fc (Str str)]
    = Just (NPrimVal fc (Ch (assert_total (prim__strHead str))))
strHead _ = Nothing

strTail : Vect 1 (NF vars) -> Maybe (NF vars)
strTail [NPrimVal fc (Str "")] = Nothing
strTail [NPrimVal fc (Str str)]
    = Just (NPrimVal fc (Str (assert_total (prim__strTail str))))
strTail _ = Nothing

strIndex : Vect 2 (NF vars) -> Maybe (NF vars)
strIndex [NPrimVal fc (Str str), NPrimVal _ (I i)]
    = if i >= 0 && integerToNat (cast i) < length str
         then Just (NPrimVal fc (Ch (assert_total (prim__strIndex str i))))
         else Nothing
strIndex _ = Nothing

strCons : Vect 2 (NF vars) -> Maybe (NF vars)
strCons [NPrimVal fc (Ch x), NPrimVal _ (Str y)]
    = Just (NPrimVal fc (Str (strCons x y)))
strCons _ = Nothing

strAppend : Vect 2 (NF vars) -> Maybe (NF vars)
strAppend [NPrimVal fc (Str x), NPrimVal _ (Str y)]
    = Just (NPrimVal fc (Str (x ++ y)))
strAppend _ = Nothing

strReverse : Vect 1 (NF vars) -> Maybe (NF vars)
strReverse [NPrimVal fc (Str x)]
    = Just (NPrimVal fc (Str (reverse x)))
strReverse _ = Nothing

strSubstr : Vect 3 (NF vars) -> Maybe (NF vars)
strSubstr [NPrimVal fc (I start), NPrimVal _ (I len), NPrimVal _ (Str str)]
    = Just (NPrimVal fc (Str (prim__strSubstr start len str)))
strSubstr _ = Nothing

add : Constant -> Constant -> Maybe Constant
add (BI x) (BI y) = pure $ BI (x + y)
add (I x) (I y) = pure $ I (x + y)
add (I8 x) (I8 y) = pure $ I8 (int8CastWrap $ x + y)
add (I16 x) (I16 y) = pure $ I16 (int16CastWrap $ x + y)
add (I32 x) (I32 y) = pure $ I32 (int32CastWrap $ x + y)
add (I64 x) (I64 y) = pure $ I64 (int64CastWrap $ x + y)
add (B8 x) (B8 y) = pure $ B8 $ (x + y) `mod` b8max
add (B16 x) (B16 y) = pure $ B16 $ (x + y) `mod` b16max
add (B32 x) (B32 y) = pure $ B32 $ cast $ (cast (x + y)) `mod` b32max
add (B64 x) (B64 y) = pure $ B64 $ (x + y) `mod` b64max
add (Ch x) (Ch y) = pure $ Ch (cast (cast {to=Int} x + cast y))
add (Db x) (Db y) = pure $ Db (x + y)
add _ _ = Nothing

sub : Constant -> Constant -> Maybe Constant
sub (BI x) (BI y) = pure $ BI (x - y)
sub (I x) (I y) = pure $ I (x - y)
sub (I8 x) (I8 y) = pure $ I8 (int8CastWrap $ x - y)
sub (I16 x) (I16 y) = pure $ I16 (int16CastWrap $ x - y)
sub (I32 x) (I32 y) = pure $ I32 (int32CastWrap $ x - y)
sub (I64 x) (I64 y) = pure $ I64 (int64CastWrap $ x - y)
sub (B8 x) (B8 y) = pure $ B8 (bit8CastWrap $ x - y)
sub (B16 x) (B16 y) = pure $ B16 (bit16CastWrap $ x - y)
sub (B32 x) (B32 y) = pure $ B32 (bit32CastWrap $ x - y)
sub (B64 x) (B64 y) = pure $ B64 (bit64CastWrap $ x - y)
sub (Ch x) (Ch y) = pure $ Ch (cast (cast {to=Int} x - cast y))
sub (Db x) (Db y) = pure $ Db (x - y)
sub _ _ = Nothing

mul : Constant -> Constant -> Maybe Constant
mul (BI x) (BI y) = pure $ BI (x * y)
mul (B8 x) (B8 y) = pure $ B8 $ (x * y) `mod` b8max
mul (B16 x) (B16 y) = pure $ B16 $ (x * y) `mod` b16max
mul (B32 x) (B32 y) = pure $ B32 $ cast $ (cast (x * y)) `mod` b32max
mul (B64 x) (B64 y) = pure $ B64 $ (x * y) `mod` b64max
mul (I x) (I y) = pure $ I (x * y)
mul (I8 x) (I8 y) = pure $ I8 (int8CastWrap $ x * y)
mul (I16 x) (I16 y) = pure $ I16 (int16CastWrap $ x * y)
mul (I32 x) (I32 y) = pure $ I32 (int32CastWrap $ x * y)
mul (I64 x) (I64 y) = pure $ I64 (int64CastWrap $ x * y)
mul (Db x) (Db y) = pure $ Db (x * y)
mul _ _ = Nothing

div : Constant -> Constant -> Maybe Constant
div (BI x) (BI 0) = Nothing
div (BI x) (BI y) = pure $ BI (assert_total (x `div` y))
div (I x) (I 0) = Nothing
div (I x) (I y) = pure $ I (assert_total (x `div` y))
div (I8 x) (I8 0) = Nothing
div (I8 x) (I8 y) = pure $ I8 (int8CastWrap $ assert_total (x `div` y))
div (I16 x) (I16 0) = Nothing
div (I16 x) (I16 y) = pure $ I16 (int16CastWrap $ assert_total (x `div` y))
div (I32 x) (I32 0) = Nothing
div (I32 x) (I32 y) = pure $ I32 (int32CastWrap $ assert_total (x `div` y))
div (I64 x) (I64 0) = Nothing
div (I64 x) (I64 y) = pure $ I64 (int64CastWrap $ assert_total (x `div` y))
div (B8 x) (B8 0) = Nothing
div (B8 x) (B8 y) = pure $ B8 (bit8CastWrap $ assert_total (x `div` y))
div (B16 x) (B16 0) = Nothing
div (B16 x) (B16 y) = pure $ B16 (bit16CastWrap $ assert_total (x `div` y))
div (B32 x) (B32 0) = Nothing
div (B32 x) (B32 y) = pure $ B32 (bit32CastWrap $ assert_total (x `div` y))
div (B64 x) (B64 0) = Nothing
div (B64 x) (B64 y) = pure $ B64 (bit64CastWrap $ assert_total (x `div` y))
div (Db x) (Db y) = pure $ Db (x / y)
div _ _ = Nothing

mod : Constant -> Constant -> Maybe Constant
mod (BI x) (BI 0) = Nothing
mod (BI x) (BI y) = pure $ BI (assert_total (x `mod` y))
mod (I x) (I 0) = Nothing
mod (I x) (I y) = pure $ I (assert_total (x `mod` y))
mod (I8 x) (I8 0) = Nothing
mod (I8 x) (I8 y) = pure $ I8 (int8CastWrap $ assert_total (x `mod` y))
mod (I16 x) (I16 0) = Nothing
mod (I16 x) (I16 y) = pure $ I16 (int16CastWrap $ assert_total (x `mod` y))
mod (I32 x) (I32 0) = Nothing
mod (I32 x) (I32 y) = pure $ I32 (int32CastWrap $ assert_total (x `mod` y))
mod (I64 x) (I64 0) = Nothing
mod (I64 x) (I64 y) = pure $ I64 (int64CastWrap $ assert_total (x `mod` y))
mod (B8 x) (B8 0) = Nothing
mod (B8 x) (B8 y) = pure $ B8 (bit8CastWrap $ assert_total (x `mod` y))
mod (B16 x) (B16 0) = Nothing
mod (B16 x) (B16 y) = pure $ B16 (bit16CastWrap $ assert_total (x `mod` y))
mod (B32 x) (B32 0) = Nothing
mod (B32 x) (B32 y) = pure $ B32 (bit32CastWrap $ assert_total (x `mod` y))
mod (B64 x) (B64 0) = Nothing
mod (B64 x) (B64 y) = pure $ B64 (bit64CastWrap $ assert_total (x `mod` y))
mod _ _ = Nothing

-- Make sure a signed integer stays within bounds after a
-- bitwise shift operation. If, after the shift, the highest bit
-- is set, treat the result as a negative number, computing its
-- twos complement, otherwise treat it as a positive number,
-- truncating all bits above the highest one.
signedShift : (i : Integer) -> (max : Integer) -> Integer
signedShift i max =
  if prim__and_Integer i max == 0
     then prim__and_Integer i (max - 1) -- treat as positive number: highest bit unset
     else prim__or_Integer i (-max)     -- treat as negative number: highest bit set

shiftl : Constant -> Constant -> Maybe Constant
shiftl (I x) (I y) = pure $ I (prim__shl_Int x y)
shiftl (I8 x) (I8 y) = pure $ I8 (signedShift (prim__shl_Integer x y) int8max)
shiftl (I16 x) (I16 y) = pure $ I16 (signedShift (prim__shl_Integer x y) int16max)
shiftl (I32 x) (I32 y) = pure $ I32 (signedShift (prim__shl_Integer x y) int32max)
shiftl (I64 x) (I64 y) = pure $ I64 (signedShift (prim__shl_Integer x y) int64max)
shiftl (BI x) (BI y) = pure $ BI (prim__shl_Integer x y)
shiftl (B8 x) (B8 y) = pure $ B8 $ (prim__shl_Int x y) `mod` b8max
shiftl (B16 x) (B16 y) = pure $ B16 $ (prim__shl_Int x y) `mod` b16max
shiftl (B32 x) (B32 y) = pure $ B32 $ cast $ (cast (prim__shl_Int x y)) `mod` b32max
shiftl (B64 x) (B64 y) = pure $ B64 $ (prim__shl_Integer x y) `mod` b64max
shiftl _ _ = Nothing

shiftr : Constant -> Constant -> Maybe Constant
shiftr (I x) (I y) = pure $ I (prim__shr_Int x y)
shiftr (I8 x) (I8 y) = pure $ I8 (signedShift (prim__shr_Integer x y) int8max)
shiftr (I16 x) (I16 y) = pure $ I16 (signedShift (prim__shr_Integer x y) int16max)
shiftr (I32 x) (I32 y) = pure $ I32 (signedShift (prim__shr_Integer x y) int32max)
shiftr (I64 x) (I64 y) = pure $ I64 (signedShift (prim__shr_Integer x y) int64max)
shiftr (B8 x) (B8 y) = pure $ B8 $ (prim__shr_Int x y)
shiftr (B16 x) (B16 y) = pure $ B16 $ (prim__shr_Int x y)
shiftr (B32 x) (B32 y) = pure $ B32 $ (prim__shr_Int x y)
shiftr (B64 x) (B64 y) = pure $ B64 $ (prim__shr_Integer x y)
shiftr _ _ = Nothing

band : Constant -> Constant -> Maybe Constant
band (I x) (I y) = pure $ I (prim__and_Int x y)
band (I8 x) (I8 y) = pure $ I8 (prim__and_Integer x y)
band (I16 x) (I16 y) = pure $ I16 (prim__and_Integer x y)
band (I32 x) (I32 y) = pure $ I32 (prim__and_Integer x y)
band (I64 x) (I64 y) = pure $ I64 (prim__and_Integer x y)
band (BI x) (BI y) = pure $ BI (prim__and_Integer x y)
band (B8 x) (B8 y) = pure $ B8 (prim__and_Int x y)
band (B16 x) (B16 y) = pure $ B16 (prim__and_Int x y)
band (B32 x) (B32 y) = pure $ B32 (prim__and_Int x y)
band (B64 x) (B64 y) = pure $ B64 (prim__and_Integer x y)
band _ _ = Nothing

bor : Constant -> Constant -> Maybe Constant
bor (I x) (I y) = pure $ I (prim__or_Int x y)
bor (I8 x) (I8 y) = pure $ I8 (prim__or_Integer x y)
bor (I16 x) (I16 y) = pure $ I16 (prim__or_Integer x y)
bor (I32 x) (I32 y) = pure $ I32 (prim__or_Integer x y)
bor (I64 x) (I64 y) = pure $ I64 (prim__or_Integer x y)
bor (BI x) (BI y) = pure $ BI (prim__or_Integer x y)
bor (B8 x) (B8 y) = pure $ B8 (prim__or_Int x y)
bor (B16 x) (B16 y) = pure $ B16 (prim__or_Int x y)
bor (B32 x) (B32 y) = pure $ B32 (prim__or_Int x y)
bor (B64 x) (B64 y) = pure $ B64 (prim__or_Integer x y)
bor _ _ = Nothing

bxor : Constant -> Constant -> Maybe Constant
bxor (I x) (I y) = pure $ I (prim__xor_Int x y)
bxor (B8 x) (B8 y) = pure $ B8 (prim__xor_Int x y)
bxor (B16 x) (B16 y) = pure $ B16 (prim__xor_Int x y)
bxor (B32 x) (B32 y) = pure $ B32 (prim__xor_Int x y)
bxor (B64 x) (B64 y) = pure $ B64 (prim__xor_Integer x y)
bxor (I8 x) (I8 y) = pure $ I8 (prim__xor_Integer x y)
bxor (I16 x) (I16 y) = pure $ I16 (prim__xor_Integer x y)
bxor (I32 x) (I32 y) = pure $ I32 (prim__xor_Integer x y)
bxor (I64 x) (I64 y) = pure $ I64 (prim__xor_Integer x y)
bxor (BI x) (BI y) = pure $ BI (prim__xor_Integer x y)
bxor _ _ = Nothing

neg : Constant -> Maybe Constant
neg (BI x) = pure $ BI (-x)
neg (I x) = pure $ I (-x)
neg (I8 x) = pure . I8 $ int8CastWrap (-x)
neg (I16 x) = pure . I16 $ int16CastWrap (-x)
neg (I32 x) = pure . I32 $ int32CastWrap (-x)
neg (I64 x) = pure . I64 $ int64CastWrap (-x)
neg (B8 x) = pure . B8 $ bit8CastWrap (-x)
neg (B16 x) = pure . B16 $ bit16CastWrap (-x)
neg (B32 x) = pure . B32 $ bit32CastWrap (-x)
neg (B64 x) = pure . B64 $ bit64CastWrap (-x)
neg (Db x) = pure $ Db (-x)
neg _ = Nothing

toInt : Bool -> Constant
toInt True = I 1
toInt False = I 0

lt : Constant -> Constant -> Maybe Constant
lt (I x) (I y) = pure $ toInt (x < y)
lt (I8 x) (I8 y) = pure $ toInt (x < y)
lt (I16 x) (I16 y) = pure $ toInt (x < y)
lt (I32 x) (I32 y) = pure $ toInt (x < y)
lt (I64 x) (I64 y) = pure $ toInt (x < y)
lt (BI x) (BI y) = pure $ toInt (x < y)
lt (B8 x) (B8 y) = pure $ toInt (x < y)
lt (B16 x) (B16 y) = pure $ toInt (x < y)
lt (B32 x) (B32 y) = pure $ toInt (x < y)
lt (B64 x) (B64 y) = pure $ toInt (x < y)
lt (Str x) (Str y) = pure $ toInt (x < y)
lt (Ch x) (Ch y) = pure $ toInt (x < y)
lt (Db x) (Db y) = pure $ toInt (x < y)
lt _ _ = Nothing

lte : Constant -> Constant -> Maybe Constant
lte (I x) (I y) = pure $ toInt (x <= y)
lte (I8 x) (I8 y) = pure $ toInt (x <= y)
lte (I16 x) (I16 y) = pure $ toInt (x <= y)
lte (I32 x) (I32 y) = pure $ toInt (x <= y)
lte (I64 x) (I64 y) = pure $ toInt (x <= y)
lte (BI x) (BI y) = pure $ toInt (x <= y)
lte (B8 x) (B8 y) = pure $ toInt (x <= y)
lte (B16 x) (B16 y) = pure $ toInt (x <= y)
lte (B32 x) (B32 y) = pure $ toInt (x <= y)
lte (B64 x) (B64 y) = pure $ toInt (x <= y)
lte (Str x) (Str y) = pure $ toInt (x <= y)
lte (Ch x) (Ch y) = pure $ toInt (x <= y)
lte (Db x) (Db y) = pure $ toInt (x <= y)
lte _ _ = Nothing

eq : Constant -> Constant -> Maybe Constant
eq (I x) (I y) = pure $ toInt (x == y)
eq (I8 x) (I8 y) = pure $ toInt (x == y)
eq (I16 x) (I16 y) = pure $ toInt (x == y)
eq (I32 x) (I32 y) = pure $ toInt (x == y)
eq (I64 x) (I64 y) = pure $ toInt (x == y)
eq (BI x) (BI y) = pure $ toInt (x == y)
eq (B8 x) (B8 y) = pure $ toInt (x == y)
eq (B16 x) (B16 y) = pure $ toInt (x == y)
eq (B32 x) (B32 y) = pure $ toInt (x == y)
eq (B64 x) (B64 y) = pure $ toInt (x == y)
eq (Str x) (Str y) = pure $ toInt (x == y)
eq (Ch x) (Ch y) = pure $ toInt (x == y)
eq (Db x) (Db y) = pure $ toInt (x == y)
eq _ _ = Nothing

gte : Constant -> Constant -> Maybe Constant
gte (I x) (I y) = pure $ toInt (x >= y)
gte (I8 x) (I8 y) = pure $ toInt (x >= y)
gte (I16 x) (I16 y) = pure $ toInt (x >= y)
gte (I32 x) (I32 y) = pure $ toInt (x >= y)
gte (I64 x) (I64 y) = pure $ toInt (x >= y)
gte (BI x) (BI y) = pure $ toInt (x >= y)
gte (B8 x) (B8 y) = pure $ toInt (x >= y)
gte (B16 x) (B16 y) = pure $ toInt (x >= y)
gte (B32 x) (B32 y) = pure $ toInt (x >= y)
gte (B64 x) (B64 y) = pure $ toInt (x >= y)
gte (Str x) (Str y) = pure $ toInt (x >= y)
gte (Ch x) (Ch y) = pure $ toInt (x >= y)
gte (Db x) (Db y) = pure $ toInt (x >= y)
gte _ _ = Nothing

gt : Constant -> Constant -> Maybe Constant
gt (I x) (I y) = pure $ toInt (x > y)
gt (I8 x) (I8 y) = pure $ toInt (x > y)
gt (I16 x) (I16 y) = pure $ toInt (x > y)
gt (I32 x) (I32 y) = pure $ toInt (x > y)
gt (I64 x) (I64 y) = pure $ toInt (x > y)
gt (BI x) (BI y) = pure $ toInt (x > y)
gt (B8 x) (B8 y) = pure $ toInt (x > y)
gt (B16 x) (B16 y) = pure $ toInt (x > y)
gt (B32 x) (B32 y) = pure $ toInt (x > y)
gt (B64 x) (B64 y) = pure $ toInt (x > y)
gt (Str x) (Str y) = pure $ toInt (x > y)
gt (Ch x) (Ch y) = pure $ toInt (x > y)
gt (Db x) (Db y) = pure $ toInt (x > y)
gt _ _ = Nothing

doubleOp : (Double -> Double) -> Vect 1 (NF vars) -> Maybe (NF vars)
doubleOp f [NPrimVal fc (Db x)] = Just (NPrimVal fc (Db (f x)))
doubleOp f _ = Nothing

doubleExp : Vect 1 (NF vars) -> Maybe (NF vars)
doubleExp = doubleOp exp

doubleLog : Vect 1 (NF vars) -> Maybe (NF vars)
doubleLog = doubleOp log

doublePow : {vars : _ } -> Vect 2 (NF vars) -> Maybe (NF vars)
doublePow = binOp pow'
    where pow' : Constant -> Constant -> Maybe Constant
          pow' (Db x) (Db y) = pure $ Db (pow x y)
          pow' _ _ = Nothing

doubleSin : Vect 1 (NF vars) -> Maybe (NF vars)
doubleSin = doubleOp sin

doubleCos : Vect 1 (NF vars) -> Maybe (NF vars)
doubleCos = doubleOp cos

doubleTan : Vect 1 (NF vars) -> Maybe (NF vars)
doubleTan = doubleOp tan

doubleASin : Vect 1 (NF vars) -> Maybe (NF vars)
doubleASin = doubleOp asin

doubleACos : Vect 1 (NF vars) -> Maybe (NF vars)
doubleACos = doubleOp acos

doubleATan : Vect 1 (NF vars) -> Maybe (NF vars)
doubleATan = doubleOp atan

doubleSqrt : Vect 1 (NF vars) -> Maybe (NF vars)
doubleSqrt = doubleOp sqrt

doubleFloor : Vect 1 (NF vars) -> Maybe (NF vars)
doubleFloor = doubleOp floor

doubleCeiling : Vect 1 (NF vars) -> Maybe (NF vars)
doubleCeiling = doubleOp ceiling

-- Only reduce for concrete values
believeMe : Vect 3 (NF vars) -> Maybe (NF vars)
believeMe [_, _, val@(NDCon _ _ _ _ _)] = Just val
believeMe [_, _, val@(NTCon _ _ _ _ _)] = Just val
believeMe [_, _, val@(NPrimVal _ _)] = Just val
believeMe [_, _, NType fc] = Just (NType fc)
believeMe [_, _, val] = Nothing

constTy : Constant -> Constant -> Constant -> ClosedTerm
constTy a b c
    = let arr = fnType emptyFC in
    PrimVal emptyFC a `arr` (PrimVal emptyFC b `arr` PrimVal emptyFC c)

constTy3 : Constant -> Constant -> Constant -> Constant -> ClosedTerm
constTy3 a b c d
    = let arr = fnType emptyFC in
    PrimVal emptyFC a `arr`
         (PrimVal emptyFC b `arr`
             (PrimVal emptyFC c `arr` PrimVal emptyFC d))

predTy : Constant -> Constant -> ClosedTerm
predTy a b = let arr = fnType emptyFC in
             PrimVal emptyFC a `arr` PrimVal emptyFC b

arithTy : Constant -> ClosedTerm
arithTy t = constTy t t t

cmpTy : Constant -> ClosedTerm
cmpTy t = constTy t t IntType

doubleTy : ClosedTerm
doubleTy = predTy DoubleType DoubleType

pi : (x : String) -> RigCount -> PiInfo (Term xs) -> Term xs ->
     Term (UN (Basic x) :: xs) -> Term xs
pi x rig plic ty sc = Bind emptyFC (UN (Basic x)) (Pi emptyFC rig plic ty) sc

believeMeTy : ClosedTerm
believeMeTy
    = pi "a" erased Explicit (TType emptyFC) $
      pi "b" erased Explicit (TType emptyFC) $
      pi "x" top    Explicit (Local emptyFC Nothing _ (Later First)) $
      Local emptyFC Nothing _ (Later First)

crashTy : ClosedTerm
crashTy
    = pi "a" erased Explicit (TType emptyFC) $
      pi "msg" top Explicit (PrimVal emptyFC StringType) $
      Local emptyFC Nothing _ (Later First)

castTo : Constant -> Vect 1 (NF vars) -> Maybe (NF vars)
castTo IntType = castInt
castTo Int8Type = castInt8
castTo Int16Type = castInt16
castTo Int32Type = castInt32
castTo Int64Type = castInt64
castTo IntegerType = castInteger
castTo Bits8Type = castBits8
castTo Bits16Type = castBits16
castTo Bits32Type = castBits32
castTo Bits64Type = castBits64
castTo StringType = castString
castTo CharType = castChar
castTo DoubleType = castDouble
castTo _ = const Nothing

export
getOp : {0 arity : Nat} -> PrimFn arity ->
        {vars : List Name} -> Vect arity (NF vars) -> Maybe (NF vars)
getOp (Add ty) = binOp add
getOp (Sub ty) = binOp sub
getOp (Mul ty) = binOp mul
getOp (Div ty) = binOp div
getOp (Mod ty) = binOp mod
getOp (Neg ty) = unaryOp neg
getOp (ShiftL ty) = binOp shiftl
getOp (ShiftR ty) = binOp shiftr

getOp (BAnd ty) = binOp band
getOp (BOr ty) = binOp bor
getOp (BXOr ty) = binOp bxor

getOp (LT ty) = binOp lt
getOp (LTE ty) = binOp lte
getOp (EQ ty) = binOp eq
getOp (GTE ty) = binOp gte
getOp (GT ty) = binOp gt

getOp StrLength = strLength
getOp StrHead = strHead
getOp StrTail = strTail
getOp StrIndex = strIndex
getOp StrCons = strCons
getOp StrAppend = strAppend
getOp StrReverse = strReverse
getOp StrSubstr = strSubstr

getOp DoubleExp = doubleExp
getOp DoubleLog = doubleLog
getOp DoublePow = doublePow
getOp DoubleSin = doubleSin
getOp DoubleCos = doubleCos
getOp DoubleTan = doubleTan
getOp DoubleASin = doubleASin
getOp DoubleACos = doubleACos
getOp DoubleATan = doubleATan
getOp DoubleSqrt = doubleSqrt
getOp DoubleFloor = doubleFloor
getOp DoubleCeiling = doubleCeiling

getOp (Cast _ y) = castTo y
getOp BelieveMe = believeMe

getOp _ = const Nothing

prim : String -> Name
prim str = UN $ Basic $ "prim__" ++ str

export
opName : {0 arity : Nat} -> PrimFn arity -> Name
opName (Add ty) = prim $ "add_" ++ show ty
opName (Sub ty) = prim $ "sub_" ++ show ty
opName (Mul ty) = prim $ "mul_" ++ show ty
opName (Div ty) = prim $ "div_" ++ show ty
opName (Mod ty) = prim $ "mod_" ++ show ty
opName (Neg ty) = prim $ "negate_" ++ show ty
opName (ShiftL ty) = prim $ "shl_" ++ show ty
opName (ShiftR ty) = prim $ "shr_" ++ show ty
opName (BAnd ty) = prim $ "and_" ++ show ty
opName (BOr ty) = prim $ "or_" ++ show ty
opName (BXOr ty) = prim $ "xor_" ++ show ty
opName (LT ty) = prim $ "lt_" ++ show ty
opName (LTE ty) = prim $ "lte_" ++ show ty
opName (EQ ty) = prim $ "eq_" ++ show ty
opName (GTE ty) = prim $ "gte_" ++ show ty
opName (GT ty) = prim $ "gt_" ++ show ty
opName StrLength = prim "strLength"
opName StrHead = prim "strHead"
opName StrTail = prim "strTail"
opName StrIndex = prim "strIndex"
opName StrCons = prim "strCons"
opName StrAppend = prim "strAppend"
opName StrReverse = prim "strReverse"
opName StrSubstr = prim "strSubstr"
opName DoubleExp = prim "doubleExp"
opName DoubleLog = prim "doubleLog"
opName DoublePow = prim "doublePow"
opName DoubleSin = prim "doubleSin"
opName DoubleCos = prim "doubleCos"
opName DoubleTan = prim "doubleTan"
opName DoubleASin = prim "doubleASin"
opName DoubleACos = prim "doubleACos"
opName DoubleATan = prim "doubleATan"
opName DoubleSqrt = prim "doubleSqrt"
opName DoubleFloor = prim "doubleFloor"
opName DoubleCeiling = prim "doubleCeiling"
opName (Cast x y) = prim $ "cast_" ++ show x ++ show y
opName BelieveMe = prim $ "believe_me"
opName Crash = prim $ "crash"

integralTypes : List Constant
integralTypes = [ IntType
                , Int8Type
                , Int16Type
                , Int32Type
                , Int64Type
                , IntegerType
                , Bits8Type
                , Bits16Type
                , Bits32Type
                , Bits64Type
                ]

numTypes : List Constant
numTypes = integralTypes ++ [DoubleType]

primTypes : List Constant
primTypes = numTypes ++ [StringType, CharType]

export
allPrimitives : List Prim
allPrimitives =
    map (\t => MkPrim (Add t) (arithTy t) isTotal)     numTypes ++
    map (\t => MkPrim (Sub t) (arithTy t) isTotal)     numTypes ++
    map (\t => MkPrim (Mul t) (arithTy t) isTotal)     numTypes ++
    map (\t => MkPrim (Neg t) (predTy t t) isTotal)    numTypes ++
    map (\t => MkPrim (Div t) (arithTy t) notCovering) numTypes ++
    map (\t => MkPrim (Mod t) (arithTy t) notCovering) integralTypes ++

    map (\t => MkPrim (ShiftL t) (arithTy t) isTotal)  integralTypes ++
    map (\t => MkPrim (ShiftR t) (arithTy t) isTotal)  integralTypes ++
    map (\t => MkPrim (BAnd t) (arithTy t) isTotal)    integralTypes ++
    map (\t => MkPrim (BOr t) (arithTy t) isTotal)     integralTypes ++
    map (\t => MkPrim (BXOr t) (arithTy t) isTotal)    integralTypes ++

    map (\t => MkPrim (LT t) (cmpTy t) isTotal)  primTypes ++
    map (\t => MkPrim (LTE t) (cmpTy t) isTotal) primTypes ++
    map (\t => MkPrim (EQ t) (cmpTy t) isTotal)  primTypes ++
    map (\t => MkPrim (GTE t) (cmpTy t) isTotal) primTypes ++
    map (\t => MkPrim (GT t) (cmpTy t) isTotal)  primTypes ++

    [MkPrim StrLength (predTy StringType IntType) isTotal,
     MkPrim StrHead (predTy StringType CharType) notCovering,
     MkPrim StrTail (predTy StringType StringType) notCovering,
     MkPrim StrIndex (constTy StringType IntType CharType) notCovering,
     MkPrim StrCons (constTy CharType StringType StringType) isTotal,
     MkPrim StrAppend (arithTy StringType) isTotal,
     MkPrim StrReverse (predTy StringType StringType) isTotal,
     MkPrim StrSubstr (constTy3 IntType IntType StringType StringType) isTotal,
     MkPrim BelieveMe believeMeTy isTotal,
     MkPrim Crash crashTy notCovering] ++

    [MkPrim DoubleExp doubleTy isTotal,
     MkPrim DoubleLog doubleTy isTotal,
     MkPrim DoublePow (arithTy DoubleType) isTotal,
     MkPrim DoubleSin doubleTy isTotal,
     MkPrim DoubleCos doubleTy isTotal,
     MkPrim DoubleTan doubleTy isTotal,
     MkPrim DoubleASin doubleTy isTotal,
     MkPrim DoubleACos doubleTy isTotal,
     MkPrim DoubleATan doubleTy isTotal,
     MkPrim DoubleSqrt doubleTy isTotal,
     MkPrim DoubleFloor doubleTy isTotal,
     MkPrim DoubleCeiling doubleTy isTotal] ++

    -- support all combinations of primitive casts with the following
    -- exceptions: String -> Char, Double -> Char, Char -> Double
    [ MkPrim (Cast t1 t2) (predTy t1 t2) isTotal
    | t1 <- primTypes
    , t2 <- primTypes
    , t1 /= t2                         &&
      (t1,t2) /= (StringType,CharType) &&
      (t1,t2) /= (DoubleType,CharType) &&
      (t1,t2) /= (CharType,DoubleType)
    ]


module Main

import Data.Strings

%default total

libsmall : String -> String
libsmall fn = "C:" ++ fn ++ ",libsmall"

%foreign (libsmall "add")
prim_add : Int -> Int -> PrimIO Int

add : HasIO io => Int -> Int -> io Int
add x y = primIO $ prim_add x y

%foreign (libsmall "sub")
prim_sub : Int -> Int -> PrimIO Int

sub : HasIO io => Int -> Int -> io Int
sub x y = primIO $ prim_sub x y

%foreign (libsmall "mul")
prim_mul : Int -> Int -> PrimIO Int

mul : HasIO io => Int -> Int -> io Int
mul x y = primIO $ prim_mul x y

%foreign (libsmall "divide")
prim_div : Int -> Int -> PrimIO Int

div : HasIO io => Int -> Int -> io Int
div x y = primIO $ prim_div x y

%foreign (libsmall "add_with_message")
prim_addWithMessage : String -> Int -> Int -> PrimIO ()

addWithMessage : HasIO io => String -> Int -> Int -> io ()
addWithMessage m x y = primIO $ prim_addWithMessage m x y

%foreign (libsmall "sub_with_message")
prim_subWithMessage : String -> Int -> Int -> PrimIO ()

subWithMessage : HasIO io => String -> Int -> Int -> io ()
subWithMessage m x y = primIO $ prim_subWithMessage m x y

%foreign (libsmall "mul_with_message")
prim_mulWithMessage : String -> Int -> Int -> PrimIO ()

mulWithMessage : HasIO io => String -> Int -> Int -> io ()
mulWithMessage m x y = primIO $ prim_mulWithMessage m x y

%foreign (libsmall "div_with_message")
prim_divWithMessage : String -> Int -> Int -> PrimIO ()

divWithMessage : HasIO io => String -> Int -> Int -> io ()
divWithMessage m x y = primIO $ prim_divWithMessage m x y

readInt : HasIO io => io (Maybe Int)
readInt = do input <- getLine
             case all isDigit (unpack input) of
                  False => pure Nothing
                  True => pure $ Just (cast input)

main : IO ()
main = do Just x <- readInt
            | Nothing => putStrLn "first number is invalid"
          Just y <- readInt
            | Nothing => putStrLn "second number is invalid"
          sum <- add x y
          printLn sum
          addWithMessage "sum" x y
          subWithMessage "sub" x y
          mulWithMessage "mul" x y
          divWithMessage "div" x y


-- ---------------------------------------------------------------- [ Date.idr ]
-- Module  : Data.Date
-- Description : Simple data types and helper functions to represent dates.
--
-- License : This code is distributed under the MIT license. See the
--           file LICENSE in the root directory for its full text.
-- --------------------------------------------------------------------- [ EOH ]
module Data.Date

%access public export

-- -------------------------------------------------------------- [ Data Types ]

||| A day of the week.
data Day = Monday
         | Tuesday
         | Wednesday
         | Thursday
         | Friday
         | Saturday
         | Sunday

%name Day day, day1, day2

||| A month of the year.
data Month = January
           | February
           | March
           | April
           | May
           | June
           | July
           | August
           | September
           | October
           | November
           | December

%name Month month, month1, month2

-- ------------------------------------------------------ [ Eq Implementations ]

Eq Day where
  Monday    == Monday    = True
  Tuesday   == Tuesday   = True
  Wednesday == Wednesday = True
  Thursday  == Thursday  = True
  Friday    == Friday    = True
  Saturday  == Saturday  = True
  Sunday    == Sunday    = True
  _         == _         = False

Eq Month where
  January   == January   = True
  February  == February  = True
  March     == March     = True
  April     == April     = True
  May       == May       = True
  June      == June      = True
  July      == July      = True
  August    == August    = True
  September == September = True
  October   == October   = True
  November  == November  = True
  December  == December  = True
  _         == _         = False

-- ---------------------------------------------------- [ Show Implementations ]

Show Day where
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"
  show Sunday    = "Sunday"

Show Month where
  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

-- -------------------------------------------------------- [ Helper Functions ]

namespace Days
  ||| Convert a string to a day, if possible, otherwise return `Nothing`.
  ||| @ str A string representing a day.
  fromString : (str : String) -> Maybe Day
  fromString "Monday"    = Just Monday
  fromString "Tuesday"   = Just Tuesday
  fromString "Wednesday" = Just Wednesday
  fromString "Thursday"  = Just Thursday
  fromString "Friday"    = Just Friday
  fromString "Saturday"  = Just Saturday
  fromString "Sunday"    = Just Sunday
  fromString _           = Nothing

namespace Months
  ||| Convert a string to a month, if possible, otherwise return `Nothing`.
  ||| @ str A string representing a month.
  fromString : (str : String) -> Maybe Month
  fromString "January"   = Just January
  fromString "February"  = Just February
  fromString "March"     = Just March
  fromString "April"     = Just April
  fromString "May"       = Just May
  fromString "June"      = Just June
  fromString "July"      = Just July
  fromString "August"    = Just August
  fromString "September" = Just September
  fromString "October"   = Just October
  fromString "November"  = Just November
  fromString "December"  = Just December
  fromString _           = Nothing

-- -------------------------------------------------------------------- [ Date ]

||| A date consists of a day, month, date and year.
record Date where
    ||| Make a date.
    constructor MkDate
    ||| A day.
    DDay  : Day
    ||| A month.
    DMon  : Month
    ||| A date.
    DDate : Integer -- Fin 32
    ||| A year.
    DYear : Integer
    -- TODO: data Time where ...

implementation Show Date where
    show (MkDate day month date year) =
        concat $ List.intersperse ", " [ show day
                                       , show month ++ " " ++ show date
                                       , show year ]

implementation Eq Date where
    (MkDate dayA monthA dateA yearA) == (MkDate dayB monthB dateB yearB) =
        dayA   == dayB   &&
        monthA == monthB &&
        dateA  == dateB  &&
        yearA  == yearB

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


module Issue1831_1

export
fooFromInteger : Num x => Integer -> x
fooFromInteger x = fromInteger (x + x)

%integerLit Issue1831_1.fooFromInteger

test : Nat
test = 5 + 6

test2 : Nat -> Bool
test2 1 = True
test2 _ = False


module Day1
import Data.String

foldCount : (Int, Int) -> Int -> (Int, Int)
foldCount (a, b) c = (c, (if a < c then b + 1 else b))

foldCount2 : (Int, Int, Int, Int) -> Int -> (Int, Int, Int, Int)
foldCount2 (a, b, c, d) e = (b, c, e, (if (a+b+c) < (b+c+e) then d + 1 else d))

export
solve : List String -> (Int, Int, Int, Int)
solve content = foldl foldCount2 (1000000, 1000000, 100000, 0) (mapMaybe parseInteger content)


%default total

nice : (x : Bool) -> x === True
nice .(_) = Refl


-- Copyright (c) 2013 Radek Micek

module Algo

-- s - state, i - reason of interruption, r - result of whole computation.
data AlgoResult s i r
  = Interrupt s i (s -> AlgoResult s i r)
  | Finish s r

data Algo s i r a
  = MkAlgo (s -> (a -> s -> AlgoResult s i r) -> AlgoResult s i r)

runAlgo : Algo s i r a -> s -> (a -> s -> AlgoResult s i r) -> AlgoResult s i r
runAlgo (MkAlgo x) = x

algoReturn : a -> Algo s i r a
algoReturn a = MkAlgo $ \s, k => k a s

algoBind : Algo s i r a -> (a -> Algo s i r b) -> Algo s i r b
algoBind x f = MkAlgo $ \s, k =>
  runAlgo x s (\a, s' => runAlgo (f a) s' k)

instance Functor (Algo s i r) where
  fmap f x = algoBind x (\x' => algoReturn (f x'))

instance Applicative (Algo s i r) where
  pure = algoReturn
  f <$> x =
    algoBind f (\f' =>
    algoBind x (\x' =>
    algoReturn (f' x')))

instance Monad (Algo s i r) where
  return = algoReturn
  (>>=) = algoBind

run : s -> Algo s i r r -> AlgoResult s i r
run s x = runAlgo x s (\r, s' => Finish s' r)

interrupt : i -> Algo s i r ()
interrupt i = MkAlgo $ \s, k => Interrupt s i (k ())

resume : s -> (s -> AlgoResult s i r) -> AlgoResult s i r
resume s k = k s

put : s -> Algo s i r ()
put s = MkAlgo $ \_, k => k () s

get : Algo s i r s
get = MkAlgo $ \s, k => k s s


%default total

cool : (x : Bool) -> x === True
cool ? = Refl


module Test.Leap

import Test.Assertions
import System

import Leap

collect : {default 0 acc : Nat} -> (List (IO Bool)) -> IO Nat
collect {acc} []               = pure acc
collect {acc} (test :: tests) = do
    bool <- test
    case bool of
        True  => collect {acc=acc}   tests
        False => collect {acc=S acc} tests

export
runTests : IO ()
runTests = do
    count <- collect
        [ assertFalse (isLeap 2015)
        , assertTrue  (isLeap 2016)
        , assertFalse (isLeap 2100)
        , assertTrue  (isLeap 2000)
        , assertEquals version "1.0.0"
        ]
    case count of
        Z => exitSuccess
        _ => exitFailure


a : Monad m => (Unit -> Unit) -> m $ Maybe ()

f : Monad m => m ()
f = do
  Just _ <- a id
    | Nothing => pure ()

  Just _ <- a id
  | Nothing => pure ()

  Just _ <- a $ \() => ()
  | Nothing => pure ()

  Just _ <- a $ \() => ()
    | Nothing => pure ()

  pure ()


module Learn.Elab4

import Prelude.Strings as S
import Language.Reflection.Utils
-- import Pruviloj.Core
-- import Pruviloj

%language ElabReflection

-- implementation Show TT where
--   show _ = "foo"

-- implementation Show x => Show (Binder x) where
--   show _ = "binder"

implementation Show x => Show (FunDefn x) where
   show ttname = "TTname"

data Foo : Type where
  Fee : Foo

fee : Int -> Int
fee x = x+1

record FnDesc where
  constructor MkFnDesc
  nameType : NameType
  fnType : TT
  fnDef : (FunDefn TT)

implementation Show FnDesc where
  show fd =
    "nameType: " ++ (show (nameType fd)) ++ "\n"
    ++ "fnType: " ++ (show (fnType fd)) ++ "\n"
    ++ "fnDef: " ++ (show (fnDef fd)) ++ "\n"

getTTForFn : TTName -> Elab ()
getTTForFn n =
  do
    (_,nt,t) <- lookupTyExact n
    fnd <- lookupFunDefnExact n
    fill `(MkFnDesc ~(quote nt) ~(quote t) ~(quote fnd))
    --    fill `((~(quote nt)))
    solve

bar : Int -> Int
bar xxx = 42

bar2 : Nat -> Nat
bar2 xxx = S xxx

bar3 : Nat -> Nat
bar3 = \x => S x

bar4 : (n : Nat) -> Nat
bar4 = \x => S x

bar5 : Nat -> Nat
bar5 Z = Z
bar5 (S k) = k

foo' : FnDesc
foo' = %runElab (getTTForFn `{bar})

foo2 : FnDesc
foo2 = %runElab (getTTForFn `{bar2})

foo3 : FnDesc
foo3 = %runElab (getTTForFn `{bar3})

foo4 : FnDesc
foo4 = %runElab (getTTForFn `{bar4})

foo5 : FnDesc
foo5 = %runElab (getTTForFn `{bar5})

bar6 : Nat
bar6 = Z

foo6 : FnDesc
foo6 = %runElab (getTTForFn `{bar6})

-- bar7 : Nat -> x
-- bar7 y = y

-- foo7 : FnDesc
-- foo7 = %runElab (getTTForFn `{bar7})

foo : FnDesc
foo = %runElab (getTTForFn `{fee})
-- foo = %runElab getTT

-- debuggetenv : Elab ()
-- debugGetEnv =
--   do
--     g <- getEnv
--     debugMessage [TextPart (show g)]

-- %runElab debugGetEnv


module Main

import Data.Vect

withFile : String -> (File -> IO (Either FileError a)) -> IO (Either FileError a)
withFile p cb = do
    Right f <- openFile p Read | Left e => pure (Left e)
    result <- cb f
    closeFile f
    pure result

parseLine : String -> List Int
parseLine = map cast . words

toVect : List a -> (n ** Vect n a)
toVect [] = (_ ** [])
toVect (x :: xs) =
    let (_ ** xsVect) = toVect xs
    in (_ ** x :: xsVect)

main : IO ()
main = do
    Right (xs, ys) <- withFile {a = (List Int, List Int)} "data.txt" $ \f => do
        Right xLine <- fGetLine f | Left e => pure (Left e)
        Right yLine <- fGetLine f | Left e => pure (Left e)
        pure (Right (parseLine xLine, parseLine yLine))
    | Left e => putStrLn ("FAILED: " ++ show e)

    let (xsLength ** xsVect) = toVect xs
    let (ysLength ** ysVect) = toVect ys

    case exactLength xsLength ysVect of
        Nothing => putStrLn "Vector lengths do not match"
        Just ysVect' => printLn (zipWith (+) xsVect ysVect')


data A : Type where
  The : Type -> A

U : A -> Type
U (The x) = x

works : (a : A) -> (H : U a) -> (let q = H in Nat)
works a h = 0

fails : (a : A) -> (H : U a) -> (let q : U a = H in Nat)
fails a h = 0

dolet : Maybe Int -> Maybe Int -> Maybe Int
dolet x y
    = do let Just x' : Maybe Int = x
             | Nothing => Nothing
         y' <- y
         pure (x' + y')

dolet2 : Maybe Int -> Maybe Int -> Maybe Int
dolet2 x y
    = do let Just x' : Maybe String = x
             | Nothing => Nothing
         y' <- y
         pure (x' + y')


module System.Random.SplitMix32

import System.Random
import Data.IORef

||| Generator for splitmix PRNG
export
data SMGen
    = MkGen
        Bits32 -- seed
        Bits32 -- gamma (odd)

||| Create a SMGen with specific seed and gamma (gamma is forced to be odd)
export
makeSMGen : Int -> Int -> SMGen
makeSMGen seed gamma = MkGen (cast seed) (cast gamma `prim__or_Bits32` 1)

{-
================
Helper Functions
================
-}

succBits32 : Bits32 -> Bits32
succBits32 x = if x == 0xffffffff
    then x
    else x + 1

neg : Bits32 -> Bits32
neg x = cast $ the Int 0x100000000 - cast x

xor : Bits32 -> Bits32 -> Bits32
xor = prim__xor_Bits32

and : Bits32 -> Bits32 -> Bits32
and = prim__and_Bits32

shiftR : Bits32 -> Bits32 -> Bits32
shiftR = prim__shr_Bits32

m1 : Bits32
m1 = 0x55555555

m2 : Bits32
m2 = 0x33333333

m4 : Bits32
m4 = 0x0f0f0f0f

popCount : Bits32 -> Bits32
popCount x0 = -- feel free to add this as a primitive
    let x1 = (x0 `shiftR` 1) `and` m1
        x2 = (x1 `and` m2) + ((x1 `shiftR` 2) `and` m2)
        x3 = (x2 + (x2 `shiftR` 4)) `and` m4
        x4 = x3 + (x3 `shiftR` 8)
        x5 = x4 + (x4 `shiftR` 16)
        x6 = x5 + (x5 `shiftR` 32)
    in x6 `and` 0x7f

shiftXor : Bits32 -> Bits32 -> Bits32
shiftXor n w = w `xor` (w `shiftR` n)

shiftXorMult : Bits32 -> Bits32 -> Bits32 -> Bits32
shiftXorMult n k w = shiftXor n w * k

mix32 : Bits32 -> Bits32
mix32 z0 =
    let z1 = shiftXorMult 16 0x85ebca6b z0
        z2 = shiftXorMult 13 0xc2b2ae35 z1
        z3 = shiftXor 16 z2
    in z3

mix32variant13 : Bits32 -> Bits32
mix32variant13 z0 =
    let z1 = shiftXorMult 16 0x69ad6ccb z0
        z2 = shiftXorMult 13 0xcd9ab5b3 z1
        z3 = shiftXor 16 z2
    in z3

mixGamma : Bits32 -> Bits32
mixGamma z0 =
    let z1 = mix32variant13 z0 `xor` 1
        n = popCount (z1 `xor` (z1 `shiftR` 1))
    in if n >= 12
        then z1
        else z1 `xor` 0xaaaaaaaa

{-
==========
Operations
==========
-}

||| Return the next Bits32 and the updated SMGen
export
nextBits32 : SMGen -> (Bits32, SMGen)
nextBits32 (MkGen seed gamma) = (mix32 seed', MkGen seed' gamma)
  where
    seed' : Bits32
    seed' = seed + gamma

||| Return the next Bits32 in range (lo, hi) inclusive and the updated SMGen
export
nextBits32Range : (Bits32, Bits32) -> SMGen -> (Bits32, SMGen)
nextBits32Range (lo, hi) = mapFst (+ lo) . nextBits32R (succBits32 $ cast $ the Int (cast hi - cast lo))
  where
    nextBits32R : Bits32 -> SMGen -> (Bits32, SMGen)
    nextBits32R 0 gen0 = (0, snd (nextBits32 gen0))
    nextBits32R range gen0 =
        let t = assert_total prim__mod_Bits32 (neg range) range
            go : Bits64 -> SMGen -> (Bits32, SMGen)
            go m gen = if (the Bits32 $ cast m) < t
                then (the Bits32 $ cast $ m `prim__shr_Bits64` 32, gen)
                else
                    let (x, gen') = nextBits32 gen
                        m' = the Bits64 $ cast x * cast range
                    in go m' gen'
            xgen : (Bits32, SMGen)
            xgen = nextBits32 gen0
        in go (cast $ fst xgen) (snd xgen)

||| Return the next Bits64 and the updated SMGen
export
nextBits64 : SMGen -> (Bits64, SMGen)
nextBits64 gen0 =
    let (bottom, gen1) = nextBits32 gen0
        (top, gen2) = nextBits32 gen1
    in (cast top `prim__shl_Bits64` 32 + cast bottom, gen2)

||| Return the next Int and the updated SMGen
export
nextInt : SMGen -> (Int, SMGen)
nextInt gen =
    let (bits64, gen') = nextBits64 gen
    in (if bits64 >= 0x7fffffffffffffff
        then negate $ cast $ bits64 + 0x7fffffffffffffff
        else cast bits64
        , gen')

{-
=========
Splitting
=========
-}

||| Return an unrelated SMGen and the updated SMGen
export
splitSMGen : SMGen -> (SMGen, SMGen)
splitSMGen (MkGen seed gamma) =
    (MkGen seed'' gamma, MkGen (mix32 seed') (mixGamma seed''))
  where
    seed' : Bits32
    seed' = seed + gamma
    seed'' : Bits32
    seed'' = seed + gamma

{-
==========
Generation
==========
-}

||| Deterministically create a new SMGen from a seed
export
mkSMGen : Bits32 -> SMGen
mkSMGen seed = MkGen (mix32 seed) goldenGamma -- different from haskell version
  where
    goldenGamma : Bits32
    goldenGamma = 0x9e3779b9

theSMGen : IORef SMGen
theSMGen = unsafePerformIO $ do
    init <- cast <$> randomRIO (the Int 0, 0xffffffff)
    newIORef (mkSMGen init)

||| Randomly create an SMGen
export
newSMGen : HasIO io => io SMGen
newSMGen = do
    (newThe, new) <- splitSMGen <$> readIORef theSMGen
    writeIORef theSMGen newThe
    pure new


module Control.Monad.Codensity

import Control.Monad.Trans
import Control.Monad.Reader
import Control.Monad.State

import Control.Linear.LIO

public export
data Codensity : (m : Type -> Type) -> (a : Type) -> Type where
  MkCodensity : (1 _ : (forall b. (a -> m b) -> m b)) -> Codensity m a

runCodensity : Codensity m a -> (forall b. (a -> m b) -> m b)
runCodensity (MkCodensity x) = x

public export
implementation Functor (Codensity m) where
  map f g = MkCodensity $ \bmr => runCodensity g (\a => bmr (f a))

public export
implementation Applicative (Codensity m) where
  pure x = MkCodensity \amr => amr x
  f <*> x = MkCodensity \bmr =>
   runCodensity f (\ab => runCodensity x (\a => bmr (ab a)))

public export
implementation Alternative m => Alternative (Codensity m) where
  x <|> y = MkCodensity \k => runCodensity x k <|> runCodensity y k
  empty = MkCodensity \_ => empty

public export
implementation Monad (Codensity m) where
  x >>= k = MkCodensity \bmr => runCodensity x (\a => runCodensity (k a) bmr)

public export
implementation HasIO m => HasIO (Codensity m) where
  liftIO x = MkCodensity (liftIO x >>=)

public export
implementation MonadTrans Codensity where
  lift x = MkCodensity (Prelude.(>>=) x)

MonadReader r m => MonadReader r (Codensity m) where
  ask = MkCodensity (ask >>=)
  local f (MkCodensity co) = MkCodensity \amb => do
    r <- ask
    local f . co $ local (const r) . amb

MonadReader s m => MonadState s (Codensity m) where
  get = MkCodensity (ask >>=)
  put s = MkCodensity \amb => local (const s) (amb ())


module LightClick.Types

import public Data.Vect

import public Toolkit.Data.DVect
import public Toolkit.Data.Rig

import public LightClick.Types.Meta
import public LightClick.Types.Direction
import public LightClick.Types.Sensitivity
import public LightClick.Types.WireType

%default total

public export
data Ty : MTy -> Type where
  TyLogic : Ty DATA
  TyArray : (type : Ty DATA) -> (length : Nat) -> Ty DATA
  TyStruct : {n : Nat} -> (kvs : Vect (S n) (Pair String (Ty DATA))) -> Ty DATA
  TyUnion  : {n : Nat} -> (kvs : Vect (S n) (Pair String (Ty DATA))) -> Ty DATA

  TyUnit : Ty UNIT
  TyConn : Ty CONN
  TyGate : Ty GATE

  TyPort : (label : String)
        -> (dir : Direction)
        -> (sense: Sensitivity)
        -> (wty : Wire)
        -> (type : Ty DATA)
        -> (usage : TyRig)
        -> Ty (PORT label)

  TyModule : {n : Nat}
          -> {names : Vect (S n) String}
          -> DVect String (Ty . PORT) (S n) names
          -> Ty (MODULE names)

-- [ Accessors and ]
public export
mkDual : Ty (PORT label) -> Ty (PORT label)
mkDual (TyPort l d s w t u) with (d)
  mkDual (TyPort l d s w t u) | IN = TyPort l OUT s w t u
  mkDual (TyPort l d s w t u) | OUT = TyPort l IN s w t u
  mkDual (TyPort l d s w t u) | INOUT = TyPort l INOUT s w t u

namespace Control
  public export
  mkDual : Ty (PORT label) -> Ty (PORT label)
  mkDual (TyPort l d s w t u) with (d)
    mkDual (TyPort l d s w t u) | IN = TyPort l OUT s Control t u
    mkDual (TyPort l d s w t u) | OUT = TyPort l IN s Control t u
    mkDual (TyPort l d s w t u) | INOUT = TyPort l INOUT s Control t u

getPortLabel : {label : String} -> Ty (PORT label) -> String
getPortLabel {label} p = label

export
getUsage : Ty (PORT s) -> TyRig
getUsage (TyPort label dir sense wty type usage) = usage

export
setUsage : Ty (PORT s) -> TyRig -> Ty (PORT s)
setUsage (TyPort label dir sense wty type _) = TyPort label dir sense wty type

-- [ EOF ]


module Gen.Scope

import Data.SortedMap
import Control.Monad.Identity
import Control.Monad.Reader

import Gen.Abs

public export
record Scope s a where
	constructor NewScope
	names : List String
	instantiate : List s -> a

export
abstractScope : Abstract i e a => Scope s a -> Abstracted i e (Scope s a)
abstractScope (NewScope ns f) = asks $ \e => NewScope ns $ \vs' => runIdentity $ runReaderT (abstr (f vs')) e

export
scope : Abstract String s a => List String -> a -> Scope s a
scope xs m = NewScope xs (abstractOver xs m)

export
scope2 : Abstract String s a => List String -> List String -> a -> Scope s a
scope2 xs xs' m = NewScope xs (abstractOver xs' m)

export
descope : (String -> s) -> Scope s a -> a
descope f sc = instantiate sc (map f (names sc))

export
Functor (Scope s) where
	map f (NewScope ns b) = NewScope ns (f . b)

export
helperFold : (a -> b -> b) -> List a -> b -> b
helperFold c xs n = foldr c n xs

export
isVar : String -> Bool
isVar s = (s == "_") || strHead s == '$'

export
removeByDummies : List String -> List a -> List a
removeByDummies ns xs = [ x | (n,x) <- zip ns xs, isVar n ]


module Toolkit.Data.Nat

%default total

public export
toNat : Int -> Nat
toNat = (integerToNat . cast)


data Foo : Type where [noHints]
  A : Foo
  B : Foo

findA : {auto foo : Foo} -> String
findA {foo = A} = "Found an A"
findA {foo = _} = "Failed to find an A"

Baz : String -> Type
Baz s = s = "Found an A"

baz : (s : String ** Baz s)
baz = let %hint arg : Foo
          arg = A
      in (findA ** Refl)

interface Gnu where
  constructor MkGnu
  hasFoo : Foo

findB : Gnu => String
findB = case hasFoo of
  B => "Found a B"
  _ => "Failed to find a B"

Bar : String -> Type
Bar s = s = "Found a B"

bar : (s : String ** Bar s)
bar = let %hint arg : Gnu
          arg = MkGnu B
      in (findB ** Refl)

interface Gnat a where
  constructor MkGnat
  makeFoo : a -> Foo

record More where
  constructor MkMore
  0 Ty : Type

%unbound_implicits off
bug : forall a . a -> (s : String ** Bar s)
bug {a} x = let M : More
                M = MkMore a
                %hint arg : Gnat (Ty M)
                arg = MkGnat (const B)
            in (findB ** Refl)


import Data.Vect

data CopK : Type where
  Nil : CopK
  (::) : (head : Type -> Type) -> (tail : CopK) -> CopK

data ElemK : (value : (Type -> Type)) -> CopK -> Type where
  Here : ElemK head (head :: tail)
  There : (later : ElemK x xs) -> ElemK x ( y :: xs)

foo : CopK
foo = List :: (Vect 3) :: Maybe :: Nil

x : ElemK Maybe Main.foo
x = There (There Here)


module Data.Tagged

import Data.Bifunctor
import Data.Profunctor

%default total

public export
data Tagged : (a : Type) -> (b : Type) -> Type where
  MkTagged: b -> Tagged a b

public export
retag : Tagged s b -> Tagged t b
retag (MkTagged b) = MkTagged b

||| Alias for 'unTagged'
public export
untag : Tagged s b -> b
untag (MkTagged x) = x

||| Tag a value with its own type.
public export
tagSelf : a -> Tagged a a
tagSelf = MkTagged

||| 'asTaggedTypeOf' is a type-restricted version of 'const'. It is usually used as an infix operator, and its typing forces its first argument (which is usually overloaded) to have the same type as the tag of the second.
public export
asTaggedTypeOf : s -> Tagged s b -> s
asTaggedTypeOf = const

||| 'untagSelf' is a type-restricted version of 'untag'.
public export
untagSelf : Tagged a a -> a
untagSelf (MkTagged x) = x

public export
Semigroup a => Semigroup (Tagged s a) where
  (MkTagged a) <+> (MkTagged b) = MkTagged (a <+> b)

public export
Monoid a => Monoid (Tagged s a) where
  neutral = MkTagged neutral

public export
Functor (Tagged s) where
  map f (MkTagged x) = MkTagged (f x)

public export
implementation Applicative (Tagged s) where
  pure = MkTagged
  (MkTagged f) <*> (MkTagged x) = MkTagged (f x)

public export
implementation Monad (Tagged s) where
  (MkTagged m) >>= k = k m

public export
implementation Bifunctor Tagged where
  bimap _ g (MkTagged b) = MkTagged (g b)

public export
implementation Profunctor Tagged where
  dimap _ f (MkTagged s) = MkTagged (f s)
  lmap _ = retag
  rmap = map

public export
implementation Choice Tagged where
  left' (MkTagged b) = MkTagged (Left b)
  right' (MkTagged b) = MkTagged (Right b)


import Data.Vect
import Data.String
import System.File.Handle
import System.File.Mode
import System.File.ReadWrite

data VectUnknown : Type -> Type where
     MkVect : (len : Nat) -> Vect len a -> VectUnknown a

readVect : IO (len ** Vect len String)
readVect = do x <- getLine
              if (x == "")
                then pure (_ ** [])
                else do (_ ** xs) <- readVect
                        pure (_ ** x :: xs)

printVect : Show a => VectUnknown a -> IO ()
printVect (MkVect len xs) = putStrLn (show xs ++ " (length " ++ show len ++ ")")

zipInputs : IO ()
zipInputs = do putStrLn "Enter first vector (blank line to end):"
               (len1 ** vec1) <- readVect
               putStrLn "Enter second vector (blank line to end):"
               (len2 ** vec2) <- readVect
               case exactLength len1 vec2 of
                    Nothing => putStrLn "Vectors are different lengths"
                    Just vec2 => printLn (zip vec1 vec2)

readToBlank : IO (List String)
readToBlank = do x <- getLine
                 if x == ""
                    then pure ([])
                    else do xs <- readToBlank
                            pure (x :: xs)

||| Read until blank line then
||| Read file name and save entered data to file
readAndSave : IO ()
readAndSave = do putStrLn "Type some lines (blank line to end):"
                 list <- readToBlank
                 putStrLn "Enter file name:"
                 fileName <- getLine
                 Left err <- writeFile fileName (unlines list)
                           | Right () => pure ()
                 printLn err

msg : String -> Maybe FileError -> IO (n ** Vect n String)
msg m err = let m_ = case err of
                          Nothing => m
                          Just err => m ++ ": " ++ (show err)
                     in do putStrLn m_
                           pure (_ ** [])

||| Reads file contents into Vect
||| ex.
|||   :exec readVectFile "test.txt" >>= printLn
readVectFile : (filename : String) -> IO (n ** Vect n String)
readVectFile filename = do Right file <- openFile filename Read
                                       | Left err => msg "Could not open file" (Just err)
                           nextLine file where
                           nextLine : File -> IO (n ** Vect n String)
                           nextLine f = do eof <- fEOF f
                                           if eof then msg "Done reading file" Nothing
                                            else do Right line <- fGetLine f
                                                                | Left err => msg "Could not read line" (Just err)
                                                    (_ ** xs) <- nextLine f
                                                    pure (_ ** line :: xs)

handleErr : FileError -> IO String
handleErr err = pure (show err)

readFileToVect : File -> IO (Either String (n ** Vect n String))
readFileToVect f = do eof <- fEOF f
                      if eof then pure (Right (_ ** []))
                        else do Right line <- fGetLine f
                                                 | Left err => pure (Left (show err))
                                Right (_ ** xs) <- readFileToVect f
                                                 | Left err => pure (Left (show err))
                                pure (Right (_ ** line :: xs))

||| Reads file contents into Vect using withFile
||| Returns either an error message or the Vect of file contents
readVectFile2 : (filename : String) -> IO (Either String (n ** Vect n String))
readVectFile2 filename = do withFile filename Read handleErr readFileToVect


||| Dependent sorted maps
|||
||| Mostly copied from Data.SortedMap, but with some changes
module Extra.Data.DepMap

import Decidable.Equality

||| Used to report errors when key lookups don't agree
public export
data BadKey : (k : Type) -> (Ord k, DecEq k) => Type where
  KeyIsBad : (Ord k, DecEq k)
    => (x : k) -> (y : k)
    -> (compare x y = EQ)
    -> Not (x = y)
    -> BadKey k

-- Multiplicities are very intentional here, I just haven't gotten around to
-- "linear"-izing the rest of the library
data Tree : Nat -> (k : Type) -> (k -> Type) -> Type where
  Leaf : (x : k) -> (1 _ : p x) -> Tree Z k p
  Branch2 :
    (1 _ : Tree n k p) -> k ->
    (1 _ : Tree n k p) ->
    Tree (S n) k p
  Branch3 :
    (1 _ : Tree n k p) -> k ->
    (1 _ : Tree n k p) -> k ->
    (1 _ : Tree n k p) ->
    Tree (S n) k p

branch4 :
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) ->
  Tree (S (S n)) k p
branch4 a b c d e f g =
  Branch2 (Branch2 a b c) d (Branch2 e f g)

branch5 :
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) ->
  Tree (S (S n)) k p
branch5 a b c d e f g h i =
  Branch2 (Branch2 a b c) d (Branch3 e f g h i)

branch6 :
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) ->
  Tree (S (S n)) k p
branch6 a b c d e f g h i j k =
  Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)

branch7 :
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) -> k ->
  (1 _ : Tree n k p) ->
  Tree (S (S n)) k p
branch7 a b c d e f g h i j k l m =
  Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)

merge1 :
  (1 _ : Tree    n  k p) -> k ->
  (1 _ : Tree (S n) k p) -> k ->
  (1 _ : Tree (S n) k p) ->
  Tree (S (S n)) k p
merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i
merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k
merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k
merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

merge2 :
  (1 _ : Tree (S n) k p) -> k ->
  (1 _ : Tree    n  k p) -> k ->
  (1 _ : Tree (S n) k p) ->
  Tree (S (S n)) k p
merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i
merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k
merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k
merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

merge3 :
  (1 _ : Tree (S n) k p) -> k ->
  (1 _ : Tree (S n) k p) -> k ->
  (1 _ : Tree    n  k p) ->
  Tree (S (S n)) k p
merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i
merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k
merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k
merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m

treeLookup : (Ord k, DecEq k) => (x : k) -> Tree n k p -> Either (BadKey k) (Maybe (p x))
treeLookup k (Leaf k' v) with (KeyIsBad k k')
  treeLookup k (Leaf k' v) | err with (compare k k')
    treeLookup k (Leaf k' v) | err | EQ with (decEq k k')
      treeLookup k (Leaf k  v) | err | EQ | Yes Refl = Right $ Just v
      treeLookup k (Leaf k' v) | err | EQ | No bad = Left $ err Refl bad
    treeLookup k (Leaf k' v) | err | _ = Right Nothing
treeLookup k (Branch2 t1 k' t2) =
  if k <= k' then
    treeLookup k t1
  else
    treeLookup k t2
treeLookup k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    treeLookup k t1
  else if k <= k2 then
    treeLookup k t2
  else
    treeLookup k t3

treeInsert' : Ord k
  => (x : k) -> p x
  -> Tree n k p
  -> Either (Tree n k p) (Tree n k p, k, Tree n k p)
treeInsert' k v (Leaf k' v') =
  case compare k k' of
    LT => Right (Leaf k v, k, Leaf k' v')
    EQ => Left (Leaf k v)
    GT => Right (Leaf k' v', k', Leaf k v)
treeInsert' k v (Branch2 t1 k' t2) =
  if k <= k' then
    case treeInsert' k v t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right (a, b, c) => Left (Branch3 a b c k' t2)
  else
    case treeInsert' k v t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right (a, b, c) => Left (Branch3 t1 k' a b c)
treeInsert' k v (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeInsert' k v t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3)
  else
    if k <= k2 then
      case treeInsert' k v t2 of
        Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
        Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3)
    else
      case treeInsert' k v t3 of
        Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
        Right (a, b, c) => Right (Branch2 t1 k1 t2, k2, Branch2 a b c)

treeInsert : Ord k
  => (x : k) -> p x
  -> Tree n k p
  -> Either (Tree n k p) (Tree (S n) k p)
treeInsert k v t =
  case treeInsert' k v t of
    Left t' => Left t'
    Right (a, b, c) => Right (Branch2 a b c)

delType : Nat -> (k : Type) -> (k -> Type) -> Type
delType Z k p = ()
delType (S n) k p = Tree n k p

treeDelete : Ord k => (n : Nat) -> k -> Tree n k p -> Either (Tree n k p) (delType n k p)
treeDelete _ k (Leaf k' v) =
  if k == k' then
    Right ()
  else
    Left (Leaf k' v)
treeDelete (S Z) k (Branch2 t1 k' t2) =
  if k <= k' then
    case treeDelete Z k t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right () => Right t2
  else
    case treeDelete Z k t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right () => Right t1
treeDelete (S Z) k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeDelete Z k t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right () => Left (Branch2 t2 k2 t3)
  else if k <= k2 then
    case treeDelete Z k t2 of
      Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
      Right () => Left (Branch2 t1 k1 t3)
  else
    case treeDelete Z k t3 of
      Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
      Right () => Left (Branch2 t1 k1 t2)
treeDelete (S (S n)) k (Branch2 t1 k' t2) =
  if k <= k' then
    case treeDelete (S n) k t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right t1' =>
        case t2 of
          Branch2 a b c => Right (Branch3 t1' k' a b c)
          Branch3 a b c d e => Left (branch4 t1' k' a b c d e)
  else
    case treeDelete (S n) k t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right t2' =>
        case t1 of
          Branch2 a b c => Right (Branch3 a b c k' t2')
          Branch3 a b c d e => Left (branch4 a b c d e k' t2')
treeDelete (S (S n)) k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeDelete (S n) k t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right t1' => Left (merge1 t1' k1 t2 k2 t3)
  else if k <= k2 then
    case treeDelete (S n) k t2 of
      Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
      Right t2' => Left (merge2 t1 k1 t2' k2 t3)
  else
    case treeDelete (S n) k t3 of
      Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
      Right t3' => Left (merge3 t1 k1 t2 k2 t3')

treeToList : Tree n k p -> List (DPair k p)
treeToList = treeToList' (:: [])
  where
    -- explicit quantification to avoid conflation with {n} from treeToList
    treeToList' : {0 n : Nat} -> (DPair k p -> List (DPair k p)) -> Tree n k p -> List (DPair k p)
    treeToList' cont (Leaf k v) = cont (k ** v)
    treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1
    treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1

export
data DepMap : (k : Type) -> (k -> Type) -> Type where
  Empty : DepMap k p
  M : (n : Nat) -> Tree n k p -> DepMap k p

export
empty : DepMap k p
empty = Empty

export
lookup : (Ord k, DecEq k)
  => (x : k)
  -> DepMap k p
  -> Either (BadKey k) (Maybe (p x))
lookup _ Empty = Right Nothing
lookup k (M _ t) = treeLookup k t

export
insert : Ord k
  => (x : k) -> p x
  -> DepMap k p
  -> DepMap k p
insert k v Empty = M Z (Leaf k v)
insert k v (M _ t) =
  case treeInsert k v t of
    Left t' => (M _ t')
    Right t' => (M _ t')

export
singleton : Ord k => (x : k) -> p x -> DepMap k p
singleton k v = insert k v empty

export
insertFrom : (Ord k, Foldable f) => f (DPair k p) -> DepMap k p -> DepMap k p
insertFrom = flip $ foldl $ flip insert'
  where insert' : DPair k p -> DepMap k p -> DepMap k p
        insert' (k ** v) = insert k v

export
delete : Ord k => k -> DepMap k p -> DepMap k p
delete _ Empty = Empty
delete k (M Z t) =
  case treeDelete Z k t of
    Left t' => (M _ t')
    Right () => Empty
delete k (M (S n) t) =
  case treeDelete (S n) k t of
    Left t' => (M _ t')
    Right t' => (M _ t')

export
fromList : Ord k => List (DPair k p) -> DepMap k p
fromList l = foldl (flip insert') empty l
  where insert' : DPair k p -> DepMap k p -> DepMap k p
        insert' (k ** v) = insert k v

export
toList : DepMap k p -> List (DPair k p)
toList Empty = []
toList (M _ t) = treeToList t

||| Gets the keys of the map.
export
keys : DepMap k p -> List k
keys = map fst . toList

-- Not really that possible
-- ||| Gets the values of the map. Could contain duplicates.
-- export
-- values : DepMap k v -> List v
-- values = map snd . toList

export
null : DepMap k p -> Bool
null Empty = True
null (M _ _) = False

treeMap : ((x : k) -> a x -> b x) -> Tree n k a -> Tree n k b
treeMap f (Leaf k v) = Leaf k (f k v)
treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)
treeMap f (Branch3 t1 k1 t2 k2 t3)
    = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3)

treeTraverse : Applicative f
  => ((x : k) -> a x -> f (b x))
  -> Tree n k a
  -> f (Tree n k b)
treeTraverse f (Leaf k v) = Leaf k <$> f k v
treeTraverse f (Branch2 t1 k t2) =
  Branch2
    <$> treeTraverse f t1
    <*> pure k
    <*> treeTraverse f t2
treeTraverse f (Branch3 t1 k1 t2 k2 t3) =
  Branch3
    <$> treeTraverse f t1
    <*> pure k1
    <*> treeTraverse f t2
    <*> pure k2
    <*> treeTraverse f t3

||| Not a Functor, but close enough
||| Still a functor from the category of Idris endofunctors to Idris tho?
export
map : ({x : k} -> a x -> b x) -> DepMap k a -> DepMap k b
map _ Empty = Empty
map f (M n t) = M n (treeMap (\k, v => f v) t)

||| Not a traversable, but close enough
export
traverse : Applicative f
  => ({x : k} -> a x -> f (b x))
  -> DepMap k a -> f (DepMap k b)
traverse _ Empty = pure Empty
traverse f (M n t) = M n <$> treeTraverse (\k, v => f v) t

||| Merge two maps. When encountering duplicate keys, using a function to
||| combine the values.
-- TODO: this could totally have better linearity
export
mergeWith : (Ord k, DecEq k)
  => ({x : k} -> p x -> p x -> p x)
  -> DepMap k p
  -> DepMap k p
  -> Either (BadKey k) (DepMap k p)
mergeWith f x y = flip insertFrom x <$> traverse go (toList y)
  where go : DPair k p -> Either (BadKey k) (DPair k p)
        go (a ** v) with (lookup a x)
          go (a ** v) | Left bad = Left bad
          go (a ** v) | Right Nothing = Right (a ** v)
          go (a ** v) | Right (Just v') = Right (a ** f v v')

||| Left-biased merge
-- TODO: lift DecEq requirement? idk
-- would require a lot of work, so prob not
mergeLeft : (Ord k, DecEq k)
  => DepMap k p
  -> DepMap k p
  -> Either (BadKey k) (DepMap k p)
mergeLeft = mergeWith (\x, y => x)


-- examples in "Type-Driven Development with Idris"
-- chapter 11, section 3, part 1

import Data.Primitives.Views
import System

-- check that all functions are total
%default total

randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
                (seed' `shiftR` 2) :: randoms seed'

arithInputs : Int -> Stream Int
arithInputs seed = map bound (randoms seed)
  where
    bound : Int -> Int
    bound num with (divides num 12)
      bound ((12 * div) + rem) | (DivBy prf) = rem + 1

data LazyFuel = LDry | LMore (Lazy LazyFuel)

partial
forever : LazyFuel
forever = LMore forever

data RunIO : Type -> Type where
  Quit : a -> RunIO a
  Do : IO a -> (a -> Inf (RunIO b)) -> RunIO b

(>>=) : IO a -> (a -> Inf (RunIO b)) -> RunIO b
(>>=) = Do

run : LazyFuel -> RunIO a -> IO (Maybe a)
run _ (Quit value) = pure $ Just value
run LDry (Do act gen) = pure Nothing
run (LMore fuel) (Do act gen) = do res <- act
                                   run fuel $ gen res

greet : RunIO ()
greet = do putStr "Enter your name: "
           name <- getLine
           if name == ""
             then do putStrLn "Bye bye!"
                     Quit ()
             else do putStrLn $ "Hello " ++ name
                     greet

partial
main : IO ()
main = do run forever greet
          pure ()


module TotallyTotal

%default total

zero : Nat
zero = Z


module Utils.Bytes

import Syntax.WithProof
import Data.Bits
import Data.DPair
import Data.Fin
import Data.Fin.Extra
import Data.Nat
import Data.List
import Data.Vect
import Data.Nat.Factor
import Data.Nat.Order.Properties
import Utils.Misc

weakenN' : {m : Nat} -> (0 n : Nat) -> Fin m -> Fin (n + m)
weakenN' n m' = rewrite plusCommutative n m in weakenN n m'

fix_fin : (m : Nat) -> (n : Nat) -> (S m) = n -> S (S (S (S (S (S (S (S (mult m 8)))))))) = mult n 8
fix_fin m n prf = rewrite sym prf in Refl

export
to_le : (FiniteBits a, Cast a Bits8) => {n : _} -> {auto 0 no0 : NonZero n} -> {auto 0 prf : n * 8 = (bitSize {a})} -> a -> Vect n Bits8
to_le x = let (S m) = n; nmeq = Refl in map (go nmeq x) Fin.range
  where
    go : {m : Nat} -> ((S m) = n) -> a -> Fin (S m) -> Bits8
    go nmeq b i = cast $ shiftR b (bitsToIndex $ coerce prf $ coerce (fix_fin m n nmeq) $ weakenN' 7 $ i * 8)

export
to_be : (FiniteBits a, Cast a Bits8) => {n : _} -> {auto 0 no0 : NonZero n} -> {auto 0 prf : n * 8 = (bitSize {a})} -> a -> Vect n Bits8
to_be = reverse . to_le

export
from_le : (FiniteBits a, Cast Bits8 a) => {n : _} -> {auto 0 no0 : NonZero n} -> {auto 0 prf : n * 8 = (bitSize {a})} -> Vect n Bits8 -> a
from_le p = let (S m) = n; nmeq = Refl in foldl (.|.) zeroBits $ zipWith (go nmeq) p Fin.range
  where
    go : {m : Nat} -> ((S m) = n) -> Bits8 -> Fin (S m) -> a
    go nmeq b i = shiftL (cast b) (bitsToIndex $ coerce prf $ coerce (fix_fin m n nmeq) $ weakenN' 7 $ i * 8)

export
from_be : (FiniteBits a, Cast Bits8 a) => {n : _} -> {auto 0 no0 : NonZero n} -> {auto 0 prf :  n * 8 = (bitSize {a})} -> Vect n Bits8 -> a
from_be = from_le . reverse

export
set_bit_to : Bits a => Bool -> Index {a} -> a -> a
set_bit_to False _ x = x
set_bit_to True pos x = setBit x pos

export
to_bools_be' : FiniteBits a => (n : Fin (S (bitSize {a}))) -> a -> Vect (finToNat n) Bool
to_bools_be' FZ x = []
to_bools_be' (FS wit) x = testBit x (bitsToIndex wit) :: (replace_vect finToNatWeakenNeutral $ to_bools_be' (weaken wit) x)

export
to_bools_be : FiniteBits a => a -> Vect (bitSize {a}) Bool
to_bools_be x = replace_vect finToNatLastIsBound $ to_bools_be' {a = a} Fin.last x

export
le_to_integer : Foldable t => t Bits8 -> Integer
le_to_integer = go . toList
  where
  go : List Bits8 -> Integer
  go v = foldr (.|.) 0 $ zipWith shiftL (cast {to=Integer} <$> v) ((*8) <$> [0..(length v)])

export
be_to_integer : Foldable t => t Bits8 -> Integer
be_to_integer = le_to_integer . reverse . toList

export
integer_to_le : (n : Nat) -> Integer -> Vect n Bits8
integer_to_le n v = (cast . shiftR v) <$> (((*8) . finToNat) <$> Fin.range)

export
integer_to_be : (n : Nat) -> Integer -> Vect n Bits8
integer_to_be n = reverse . integer_to_le n

export
to_digit : Bool -> Char
to_digit False = '0'
to_digit True = '1'

export
show_bin : FiniteBits a => a -> String
show_bin = pack . toList . map to_digit . to_bools_be

||| if 0-15, then return the corresponding hex char
||| otherwise returns a '?'
export
hex_lower : Bits8 -> Char
hex_lower 0 = '0'
hex_lower 1 = '1'
hex_lower 2 = '2'
hex_lower 3 = '3'
hex_lower 4 = '4'
hex_lower 5 = '5'
hex_lower 6 = '6'
hex_lower 7 = '7'
hex_lower 8 = '8'
hex_lower 9 = '9'
hex_lower 10 = 'a'
hex_lower 11 = 'b'
hex_lower 12 = 'c'
hex_lower 13 = 'd'
hex_lower 14 = 'e'
hex_lower 15 = 'f'
hex_lower _ = '?'

export
show_hex : Bits8 -> String
show_hex x = strCons (hex_lower (div x 16)) $ strCons (hex_lower (mod x 16)) $ ""

||| takes a list of bytes and show them using `show_hex` interspersed by a whitespace
export
xxd : Foldable t => t Bits8 -> String
xxd = concat . intersperse " " . map show_hex . toList

export
string_to_ascii : (x : String) -> List Bits8
string_to_ascii = map (cast . ord) . unpack

export
ascii_to_string : List Bits8 -> String
ascii_to_string = pack . map cast

maybe_a_a : Lazy a -> Maybe a -> a
maybe_a_a a Nothing  = Force a
maybe_a_a _ (Just a) = a

export
shiftL' : FiniteBits a => a -> Nat -> a
shiftL' x i = maybe_a_a zeroBits $ do
  i' <- natToFin i _
  Just $ shiftL x (bitsToIndex i')

export
shiftR' : FiniteBits a => a -> Nat -> a
shiftR' x i = maybe_a_a zeroBits $ do
  i' <- natToFin i _
  Just $ shiftR x (bitsToIndex i')

export
rotl : FiniteBits a => {n : Nat} -> {auto prf : ((S n) = bitSize {a})} -> Fin (S n) -> a -> a
rotl FZ x = x
rotl (FS i) x = (shiftL x $ bitsToIndex (coerce prf $ FS i)) .|. (shiftR x $ bitsToIndex $ invFin $ coerce prf $ weaken i)

export
rotr : FiniteBits a => {n : Nat} -> {auto prf : ((S n) = bitSize {a})} -> Fin (S n) -> a -> a
rotr FZ x = x
rotr (FS i) x = (shiftR x $ bitsToIndex (coerce prf $ FS i)) .|. (shiftL x $ bitsToIndex $ invFin $ coerce prf $ weaken i)


module Control.Comonad.Env.Interface

import Control.Comonad
import Control.Comonad.Env.Env
import Control.Comonad.Store.Store
import Control.Comonad.Traced.Traced
import Control.Comonad.Trans

%default total

public export
interface Comonad w => ComonadEnv e w | w where
  ask : w a -> e

public export %inline
asks : ComonadEnv e w => (e -> e') -> w a -> e'
asks = (. ask)

public export %inline
lowerAsk : (ComonadEnv e w, ComonadTrans t) => t w a -> e
lowerAsk = ask . lower

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

public export %inline
Comonad w => ComonadEnv e (EnvT e w) where
  ask = env

public export %inline
ComonadEnv e w => ComonadEnv e (StoreT t w) where
  ask = lowerAsk {t = StoreT t}

public export %inline
(ComonadEnv e w, Monoid m) => ComonadEnv e (TracedT m w) where
  ask = lowerAsk {t = TracedT m}