module Java.Lang

import IdrisJvm.FFI
import Data.Vect

%access public export

namespace Boolean
  BooleanClass : JVM_NativeTy
  BooleanClass = Class "java/lang/Boolean"

  parseBool : String -> Bool
  parseBool s = unsafePerformIO $ invokeStatic BooleanClass "parseBoolean" (String -> JVM_IO Bool) s

namespace Byte
  ByteClass : JVM_NativeTy
  ByteClass = Class "java/lang/Byte"

  parseByte : String -> Bits8
  parseByte s = unsafePerformIO $ invokeStatic ByteClass "parseByte" (String -> JVM_IO Bits8) s

namespace Character
  CharacterClass : JVM_NativeTy
  CharacterClass = Class "java/lang/Character"

namespace JInteger
  integerClass : String
  integerClass = "java/lang/Integer"

  IntegerClass : JVM_NativeTy
  IntegerClass = Class integerClass

  JInteger : Type
  JInteger = JVM_Native IntegerClass

  parseInt : String -> Int
  parseInt s = unsafePerformIO $ invokeStatic IntegerClass "parseInt" (String -> JVM_IO Int) s

  valueOf : Int -> JInteger
  valueOf n = unsafePerformIO $ invokeStatic IntegerClass "valueOf" (Int -> JVM_IO JInteger) n

namespace Short
  ShortClass : JVM_NativeTy
  ShortClass = Class "java/lang/Short"

  Short : Type
  Short = JVM_Native ShortClass

  parseShort : String -> Bits16
  parseShort s = unsafePerformIO $ invokeStatic ShortClass "parseShort" (String -> JVM_IO Bits16) s

  valueOf : Bits16 -> Short
  valueOf n = unsafePerformIO $ invokeStatic ShortClass "valueOf" (Bits16 -> JVM_IO Short) n

namespace Long
  LongClass : JVM_NativeTy
  LongClass = Class "java/lang/Long"

  Long : Type
  Long = JVM_Native LongClass

  parseLong : String -> Bits64
  parseLong s = unsafePerformIO $ invokeStatic LongClass "parseLong" (String -> JVM_IO Bits64) s

  valueOf : Bits64 -> Long
  valueOf n = unsafePerformIO $ invokeStatic LongClass "valueOf" (Bits64 -> JVM_IO Long) n

  intValue : Bits64 -> Int
  intValue n = unsafePerformIO $ invokeInstance "intValue" (Long -> JVM_IO Int) (Long.valueOf n)

namespace JDouble
  DoubleClass : JVM_NativeTy
  DoubleClass = Class "java/lang/Double"

  JDouble : Type
  JDouble = JVM_Native DoubleClass

  parseDouble : String -> Double
  parseDouble s = unsafePerformIO $ invokeStatic DoubleClass "parseDouble" (String -> JVM_IO Double) s

  valueOf : Double -> JDouble
  valueOf n = unsafePerformIO $ invokeStatic DoubleClass "valueOf" (Double -> JVM_IO JDouble) n

namespace Math

  MathClass : JVM_NativeTy
  MathClass = Class "java/lang/Math"

  Math : Type
  Math = JVM_Native MathClass

  maxInt : Int -> Int -> Int
  maxInt a b = unsafePerformIO $ invokeStatic MathClass "max" (Int -> Int -> JVM_IO Int) a b

  maxDouble : Double -> Double -> Double
  maxDouble a b = unsafePerformIO $ invokeStatic MathClass "max" (Double -> Double -> JVM_IO Double) a b

  maxFloat : JFloat -> JFloat -> JFloat
  maxFloat a b = unsafePerformIO $ invokeStatic MathClass "max" (JFloat -> JFloat -> JVM_IO JFloat) a b

namespace Closeable

  Closeable : Type
  Closeable = JVM_Native (Interface "java/io/Closeable")

  close : Inherits Closeable closeable => closeable -> JVM_IO ()
  close closeable = invokeInstance "close" (Closeable -> JVM_IO ()) (believe_me closeable)

namespace Flushable

  Flushable : Type
  Flushable = JVM_Native (Interface "java/io/Flushable")

  flush : Inherits Flushable flushable => flushable -> JVM_IO ()
  flush flushable = invokeInstance "flush" (Flushable -> JVM_IO ()) (believe_me flushable)

namespace InputStream

  InputStream : Type
  InputStream = JVM_Native (Class "java/io/InputStream")

  Inherits Closeable InputStream where {}

namespace PrintStream

  PrintStream : Type
  PrintStream = JVM_Native $ Class "java/io/PrintStream"

  println : PrintStream -> String -> JVM_IO ()
  println = invokeInstance "println" (PrintStream -> String -> JVM_IO ())

  printCh : PrintStream -> Char -> JVM_IO ()
  printCh = invokeInstance "print" (PrintStream -> Char -> JVM_IO ())

  Inherits Flushable PrintStream where {}

namespace System

  systemClass : String
  systemClass = "java/lang/System"

  SystemClass : JVM_NativeTy
  SystemClass = Class systemClass

  getProperty : String -> JVM_IO (Maybe String)
  getProperty p = nullableStringToMaybe <$> invokeStatic SystemClass "getProperty" (String -> JVM_IO String) p

  getenv : String -> JVM_IO (Maybe String)
  getenv p = nullableStringToMaybe <$> invokeStatic SystemClass "getenv" (String -> JVM_IO String) p

  setProperty : String -> String -> JVM_IO (Maybe String)
  setProperty name value = nullableStringToMaybe <$>
    invokeStatic SystemClass "setProperty" (String -> String -> JVM_IO String) name value

  -- Takes a property name and a default value and returns the property value
  -- if it exists otherwise returns the default value
  getPropertyWithDefault : String -> String -> JVM_IO String
  getPropertyWithDefault = invokeStatic SystemClass "getProperty" (String -> String -> JVM_IO String)

  stdout : PrintStream
  stdout = unsafePerformIO $ getStaticField SystemClass "out" (JVM_IO PrintStream)

  stderr : PrintStream
  stderr = unsafePerformIO $ getStaticField SystemClass "err" (JVM_IO PrintStream)

  stdin : InputStream
  stdin = unsafePerformIO $ getStaticField SystemClass "in" (JVM_IO InputStream)

  lineSeparator : JVM_IO String
  lineSeparator = invokeStatic SystemClass "lineSeparator" (JVM_IO String)

  exit : Int -> JVM_IO ()
  exit = invokeStatic SystemClass "exit" (Int -> JVM_IO ())

namespace Runnable
  Runnable : Type
  Runnable = javaInterface "java/lang/Runnable"

  %inline
  jlambda : JVM_IO () -> Runnable
  jlambda f = javalambda "run" (JVM_IO ()) g
    where
      g : () -> ()
      g x = unsafePerformIO f

  run : Runnable -> JVM_IO ()
  run runnable = invokeInstance "run" (Runnable -> JVM_IO ()) runnable

namespace Thread

  ThreadClass : JVM_NativeTy
  ThreadClass = Class "java/lang/Thread"

  Thread : Type
  Thread = JVM_Native ThreadClass

  fromRunnable : Runnable -> JVM_IO Thread
  fromRunnable runnable = FFI.new (Runnable -> JVM_IO Thread) runnable

  start : Thread -> JVM_IO ()
  start thread = invokeInstance "start" (Thread -> JVM_IO ()) thread

  sleep : Bits64 -> JVM_IO ()
  sleep millis = invokeStatic ThreadClass "sleep" (Bits64 -> JVM_IO ()) millis

  currentThread : JVM_IO Thread
  currentThread = invokeStatic ThreadClass "currentThread" (JVM_IO Thread)

  getId : Thread -> JVM_IO Bits64
  getId thread = invokeInstance "getId" (Thread -> JVM_IO Bits64) thread

  join : Thread -> JVM_IO ()
  join thread = invokeInstance "join" (Thread -> JVM_IO ()) thread

namespace JavaString

  stringClass : String
  stringClass = "java/lang/String"

  StringClass : JVM_NativeTy
  StringClass = Class stringClass

  StringArray : Type
  StringArray = JVM_Array String

  boolToString : Bool -> String
  boolToString b = unsafePerformIO $ invokeStatic StringClass "valueOf" (Bool -> JVM_IO String) b

  charAt : String -> Int -> Char
  charAt str index = unsafePerformIO $ invokeInstance "charAt" (String -> Int -> JVM_IO Char) str index

  charToString : Char -> String
  charToString b = unsafePerformIO $ invokeStatic StringClass "valueOf" (Char -> JVM_IO String) b

  byteToString : Bits8 -> String
  byteToString b = unsafePerformIO $ invokeStatic ByteClass "toString" (Bits8 -> JVM_IO String) b

  shortToString : Bits16 -> String
  shortToString b = unsafePerformIO $ invokeStatic ShortClass "toString" (Bits16 -> JVM_IO String) b

  longToString : Bits64 -> String
  longToString b = unsafePerformIO $ invokeStatic LongClass "toString" (Bits64 -> JVM_IO String) b

  getBytes : String -> JVM_IO (JVM_Array Bits8)
  getBytes str = invokeInstance "getBytes" (String -> String -> JVM_IO (JVM_Array Bits8)) str "UTF-8"

  format : String -> JVM_Array Object -> String
  format fmt args = unsafePerformIO $ invokeStatic StringClass "format" (String -> JVM_Array Object -> JVM_IO String) fmt args

namespace StringBuilder
    StringBuilderClass : JVM_NativeTy
    StringBuilderClass = Class "java/lang/StringBuilder"

    StringBuilder : Type
    StringBuilder = JVM_Native StringBuilderClass

    new : Int -> JVM_IO StringBuilder
    new = FFI.new (Int -> JVM_IO StringBuilder)

    appendString : StringBuilder -> String -> JVM_IO StringBuilder
    appendString = invokeInstance "append" (StringBuilder -> String -> JVM_IO StringBuilder)

    toString : StringBuilder -> JVM_IO String
    toString = invokeInstance "toString" (StringBuilder -> JVM_IO String)

%inline
vectToArray : Vect n elemTy -> {auto jvmType: JVM_Types elemTy} -> JVM_IO (JVM_Array elemTy)
vectToArray {elemTy} xs
    = vectToArray' xs
        (\n => newArray elemTy n)
        (setArray (JVM_Array elemTy -> Int -> elemTy -> JVM_IO ()))
  where
    vectToArray' : Vect n elemTy
                -> (Nat -> JVM_IO (JVM_Array elemTy))
                -> (JVM_Array elemTy -> Int -> elemTy -> JVM_IO ())
                -> JVM_IO (JVM_Array elemTy)
    vectToArray' {n} xs createArray setArray' = do
        arr <- createArray n
        go arr 0 xs
      where
        go : JVM_Array elemTy -> Int -> Vect m elemTy -> JVM_IO (JVM_Array elemTy)
        go arr index [] = pure arr
        go arr index (x :: xs) = do
          setArray' arr index x
          go arr (index + 1) xs

%inline
listToArray : List elemTy -> {auto jvmType: JVM_Types elemTy} -> JVM_IO (JVM_Array elemTy)
listToArray {elemTy} xs
    = assert_total $ listToArray' xs
        (newArray elemTy (length xs))
        (setArray (JVM_Array elemTy -> Int -> elemTy -> JVM_IO ()))
  where
    listToArray' : List elemTy
                -> JVM_IO (JVM_Array elemTy)
                -> (JVM_Array elemTy -> Int -> elemTy -> JVM_IO ())
                -> JVM_IO (JVM_Array elemTy)
    listToArray' xs createArray setArray' = do
        arr <- createArray
        go arr 0 xs
      where
        go : JVM_Array elemTy -> Int -> List elemTy -> JVM_IO (JVM_Array elemTy)
        go arr index [] = pure arr
        go arr index (x :: xs) = do
          setArray' arr index x
          go arr (index + 1) xs

%inline
vectToArray2d : Vect m (Vect n elemTy) -> {auto jvmType: JVM_Types elemTy} -> JVM_IO (JVM_Array (JVM_Array elemTy))
vectToArray2d {elemTy} xs
    = vectToArray2d' xs
        (\m, n => newMultiArray (Int -> Int -> JVM_IO (JVM_Array (JVM_Array elemTy))) (cast m) (cast n))
        (setArray (JVM_Array (JVM_Array elemTy) -> Int -> Int -> elemTy -> JVM_IO ()))
  where
    vectToArray2d' : Vect m (Vect n elemTy)
                  -> (Nat -> Nat -> JVM_IO (JVM_Array (JVM_Array elemTy)))
                  -> (JVM_Array (JVM_Array elemTy) -> Int -> Int -> elemTy -> JVM_IO ())
                  -> JVM_IO (JVM_Array (JVM_Array elemTy))
    vectToArray2d' {m} {n} xs createArray setArray' = do
        arr <- createArray m n
        go arr 0 xs
      where
        createRow : JVM_Array (JVM_Array elemTy) -> Int -> Int -> Vect a elemTy -> JVM_IO ()
        createRow arr row col [] = pure ()
        createRow arr row col (x :: xs) = do
          setArray' arr row col x
          createRow arr row (col + 1) xs

        go : JVM_Array (JVM_Array elemTy) -> Int -> Vect a (Vect b elemTy) -> JVM_IO (JVM_Array (JVM_Array elemTy))
        go {b} arr row [] = pure arr
        go {b} arr row (xs :: xxs) = do
          createRow arr row 0 xs
          go arr (row + 1) xxs

%inline
arrayToVect : JVM_Array elemTy -> {auto jvmType: JVM_Types elemTy} -> JVM_IO (n ** Vect n elemTy)
arrayToVect {elemTy} arr = do
    len <- arrayLength arr
    v <- f 0 len (getArray (JVM_Array elemTy -> Int -> JVM_IO elemTy) arr)
    pure (_ ** v)
  where
    f : (index: Nat) -> (n: Nat) -> (Int -> JVM_IO elemTy) -> JVM_IO (Vect n elemTy)
    f index Z getter = pure []
    f index (S k) getter = do
      rest <- f (index + 1) k getter
      curr <- getter (cast index)
      pure (curr :: rest)


module System.File.Permissions

import public System.File.Error
import System.File.Support
import public System.File.Types

%default total

%foreign support "idris2_chmod"
         "node:support:chmod,support_system_file"
prim__chmod : String -> Int -> PrimIO Int

||| The UNIX file modes.
namespace FileMode
  public export
  data FileMode = Read | Write | Execute

||| The permissions of a file, grouped by the 3 types of owners of a file.
public export
record Permissions where
  constructor MkPermissions
  user   : List FileMode
  group  : List FileMode
  others : List FileMode

||| Convert the given `Permissions` to their integer value.
mkMode : Permissions -> Int
mkMode p
    = getMs (user p) * 64 + getMs (group p) * 8 + getMs (others p)
  where
    getM : FileMode -> Int
    getM Read = 4
    getM Write = 2
    getM Execute = 1

    getMs : List FileMode -> Int
    getMs = sum . map getM

||| Change the permissions of the file with the specified name to the given
||| integer representation of some permissions.
||| You likely want to use `chmod` and `Permissions`, or go via `mkMode`
||| instead of using this.
|||
||| @ fname the name of the file whose permissions to change
||| @ p     the integer representation of the permissions to set
export
chmodRaw : HasIO io => (fname : String) -> (p : Int) -> io (Either FileError ())
chmodRaw fname p
    = do ok <- primIO $ prim__chmod fname p
         if ok == 0
            then pure (Right ())
            else returnError

||| Change the permissions of the file with the specified name to the
||| permissions in the given `Permissions` record.
|||
||| @ fname the name of the file whose permissions to change
||| @ p     a `Permissions` record containing the permissions to set
export
chmod : HasIO io => (fname : String) -> (p : Permissions) -> io (Either FileError ())
chmod fname p = chmodRaw fname (mkMode p)


import NewEden.Natural
import NewEden.Implementations.Int64

{- Int64

   At present, this is pretty much completely worthless, as Idris doesn't have
   unboxed primitives, which means you're not gaining any practically significant
   performance by using this over GMP integers.

   But hopefully in the future they'll be available. Along with unboxed arrays.

-}

x : Natural Int64
x = 1024

y : Natural Int64
y = 12345

z : Natural Int64
z = x * y + y * x


%default total

data InfIO : Type where
     Do : IO a -> (a -> Inf InfIO) -> InfIO
     Seq : IO () -> Inf InfIO -> InfIO

(>>=) : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) = Do

(>>) : IO () -> Inf InfIO -> InfIO
(>>) = Seq

loopPrint : String -> InfIO
loopPrint msg = do putStrLn msg
                   loopPrint msg

data Fuel = Dry | More (Lazy Fuel)

tank : Nat -> Fuel
tank Z = Dry
tank (S k) = More (tank k)

partial
runPartial : InfIO -> IO ()
runPartial (Do action f) = do res <- action
                              runPartial (f res)

run : Fuel -> InfIO -> IO ()
run (More fuel) (Do c f) = do res <- c
                              run fuel (f res)
run (More fuel) (Seq io k) = do io; run fuel k
run Dry p = putStrLn "Out of fuel"

partial
forever : Fuel
forever = More forever

partial
main : IO ()
main = run (tank 10) (loopPrint "vroom")


module Js.Json
{-
import public Lightyear
import public Lightyear.Char
import public Lightyear.Strings

import Pruviloj.Core
import public Data.SortedMap

public export
data JsonValue = JsonString String
               | JsonNumber Double
               | JsonBool Bool
               | JsonNull
               | JsonArray (List JsonValue)
               | JsonObject (SortedMap String JsonValue)

{-
export
Eq JsonValue where
  (==) (JsonString x) (JsonString y) = x == y
  (==) (JsonNumber x) (JsonNumber y) = x == y
  (==) JsonNull JsonNull = True
  (==) (JsonArray x) (JsonArray y) = x == y
  (==) (JsonObject x) (JsonObject y) = toList x == toList y
  (==) _ _ = False
-}

export
Show JsonValue where
  show (JsonString s)   = show s
  show (JsonNumber x)   = show x
  show (JsonBool True ) = "true"
  show (JsonBool False) = "false"
  show  JsonNull        = "null"
  show (JsonArray  xs)  = show xs
  show (JsonObject xs)  =
      "{" ++ intercalate ", " (map fmtItem $ SortedMap.toList xs) ++ "}"
    where
      intercalate : String -> List String -> String
      intercalate sep [] = ""
      intercalate sep [x] = x
      intercalate sep (x :: xs) = x ++ sep ++ intercalate sep xs

      fmtItem (k, v) = show k ++ ": " ++ show v

hex : Parser Int
hex = do
  c <- map (ord . toUpper) $ satisfy isHexDigit
  pure $ if c >= ord '0' && c <= ord '9' then c - ord '0'
                                         else 10 + c - ord 'A'

hexQuad : Parser Int
hexQuad = do
  a <- hex
  b <- hex
  c <- hex
  d <- hex
  pure $ a * 4096 + b * 256 + c * 16 + d

specialChar : Parser Char
specialChar = do
  c <- satisfy (const True)
  case c of
    '"'  => pure '"'
    '\\' => pure '\\'
    '/'  => pure '/'
    'b'  => pure '\b'
    'f'  => pure '\f'
    'n'  => pure '\n'
    'r'  => pure '\r'
    't'  => pure '\t'
    'u'  => map chr hexQuad
    _    => fail "expected special char"

jsonString' : Parser (List Char)
jsonString' = (char '"' *!> pure Prelude.List.Nil) <|> do
  c <- satisfy (/= '"')
  if (c == '\\') then map (::) specialChar <*> jsonString'
                 else map (c ::) jsonString'

jsonString : Parser String
jsonString = char '"' *> map pack jsonString' <?> "JSON string"

-- inspired by Haskell's Data.Scientific module
record Scientific where
  constructor MkScientific
  coefficient : Integer
  exponent : Integer

scientificToFloat : Scientific -> Double
scientificToFloat (MkScientific c e) = fromInteger c * exp
  where exp = if e < 0 then 1 / pow 10 (fromIntegerNat (- e))
                       else pow 10 (fromIntegerNat e)

parseScientific : Parser Scientific
parseScientific = do sign <- maybe 1 (const (-1)) `map` opt (char '-')
                     digits <- some digit
                     hasComma <- isJust `map` opt (char '.')
                     decimals <- if hasComma then some digit else pure Prelude.List.Nil
                     hasExponent <- isJust `map` opt (char 'e')
                     exponent <- if hasExponent then integer else pure 0
                     pure $ MkScientific (sign * fromDigits (digits ++ decimals))
                                         (exponent - cast (length decimals))
  where fromDigits : List (Fin 10) -> Integer
        fromDigits = foldl (\a, b => 10 * a + cast b) 0

jsonNumber : Parser Double
jsonNumber = map scientificToFloat parseScientific

jsonBool : Parser Bool
jsonBool  =  (char 't' >! string "rue"  *> pure True)
         <|> (char 'f' >! string "alse" *> pure False) <?> "JSON Bool"

jsonNull : Parser ()
jsonNull = (char 'n' >! string "ull" >! pure ()) <?> "JSON Null"

mutual
  jsonArray : Parser (List JsonValue)
  jsonArray = char '[' *!> (jsonValue `sepBy` (char ',')) <* char ']'

  keyValuePair : Parser (String, JsonValue)
  keyValuePair = do
    key <- spaces *> jsonString <* spaces
    char ':'
    value <- jsonValue
    pure (key, value)

  jsonObject : Parser (SortedMap String JsonValue)
  jsonObject = map fromList (char '{' >! (keyValuePair `sepBy` char ',') <* char '}')

  jsonValue' : Parser JsonValue
  jsonValue' =  (map JsonString jsonString)
            <|> (map JsonNumber jsonNumber)
            <|> (map JsonBool   jsonBool)
            <|> (pure JsonNull <* jsonNull)
            <|>| map JsonArray  jsonArray
            <|>| map JsonObject jsonObject

  jsonValue : Parser JsonValue
  jsonValue = spaces *> jsonValue' <* spaces

jsonToplevelValue : Parser JsonValue
jsonToplevelValue = (map JsonArray jsonArray) <|> (map JsonObject jsonObject)

export
parsJson : String -> Either String JsonValue
parsJson s = parse jsonValue s

public export
interface ToJson a where
  toJson : a -> JsonValue

public export
interface FromJson a where
  fromJson : JsonValue -> Either String a

export
interface (ToJson a, FromJson a) => BothJson a where

export
(ToJson a, FromJson a) => BothJson a where

export
FromJson String where
  fromJson (JsonString s) = Right s
  fromJson o = Left $ "fromJson: " ++ show o ++ " is not a String"

export
ToJson String where
  toJson s = JsonString s

export
FromJson JsonValue where
  fromJson = Right

export
ToJson JsonValue where
  toJson = id

export
FromJson () where
  fromJson JsonNull = Right ()

export
ToJson () where
  toJson () = JsonNull

export
ToJson a => ToJson (List a) where
  toJson x = JsonArray $ map toJson x

export
FromJson a => FromJson (List a) where
  fromJson (JsonArray x) = sequence $ map fromJson x

export
ToJson a => ToJson (Vect n a) where
  toJson x = JsonArray $ toList $ map toJson x

vectFromJson : FromJson a => JsonValue -> Either String (Vect n a)
vectFromJson {n} {a} (JsonArray x) =
  let p1 = the (List (Either String a)) $ map fromJson x
      p2 = sequence $ fromList p1
  in case exactLength n <$> p2 of
        Right (Just z) => Right z

export
FromJson a => FromJson (Vect n a) where
  fromJson = vectFromJson

export
(ToJson a, ToJson b) => ToJson (a,b) where
  toJson (x, y) = JsonArray [toJson x, toJson y]

export
(FromJson a, FromJson b) => FromJson (a, b) where
  fromJson (JsonArray [x, y]) = MkPair <$> fromJson x <*> fromJson y

export
decode : FromJson a => String -> Either String a
decode x = parsJson x >>= fromJson

export
encode : ToJson a => a -> String
encode x = show $ toJson x
-}


module Unlambda

import Control.Monad.Trans
import src.ContT

-- Based on http://www.madore.org/~david/programs/unlambda/

data Rec : (r : Type) -> (m : Type -> Type) -> Type where
  RecK : (Rec r m -> ContT r m (Rec r m)) -> Rec r m

data Expr : Type where
  S : Expr
  K : Expr
  I : Expr
  R : Expr
  C : Expr
  Dot : Char -> Expr
  Backtick : Expr -> Expr -> Expr

apply : ContT r m (Rec r m) -> ContT r m (Rec r m) -> ContT r m (Rec r m)
apply first second = do (RecK k) <- first
                        b <- second
                        k b

eval : Monad m => Expr -> (Char -> m ()) -> ContT r m (Rec r m)
eval S put = pure $ RecK (\rec =>
             pure $ RecK (\rec' =>
             pure $ RecK (\rec'' => apply (apply (pure rec) (pure rec'')) (apply (pure rec') (pure rec'')))))
eval K put = pure $ RecK (\rec => pure $ RecK (\_ => pure rec))
eval I put = pure $ RecK (\rec => pure rec)
eval R put = pure $ RecK (\rec => do lift $ put '\n'; pure rec)
eval C put = pure $ RecK (\(RecK k) => callCC (\k' => k $ RecK k'))
eval (Dot char) put = pure $ RecK (\rec => do lift $ put char; pure rec)
eval (Backtick expr expr') put = apply (eval expr put) (eval expr' put)

parse :  List Char -> Maybe (Expr, List Char)
parse ('s' :: xs) = Just (S, xs)
parse ('k' :: xs) = Just (K, xs)
parse ('i' :: xs) = Just (I, xs)
parse ('r' :: xs) = Just (R, xs)
parse ('c' :: xs) = Just (C, xs)
parse ('.' :: c :: xs) = Just (Dot c, xs)
parse ('`' :: xs) = do (expr, xs') <- parse xs
                       (expr', xs'') <- parse xs'
                       Just (Backtick expr expr', xs'')
parse (x :: xs) = Nothing
parse [] = Nothing

callCCTest : String
callCCTest = "``cir"

helloWorldTest : String
helloWorldTest = "```si`k``s.H``s.e``s.l``s.l``s.o``s. ``s.w``s.o``s.r``s.l``s.d``s.!``sri``si``si``si``si``si``si``si``si`ki"

example : IO ()
example = case parse (unpack helloWorldTest) of
            Just (expr, _) => run (\_ => pure ()) $ eval expr putChar
            Nothing => putStrLn "Parse error"


module Test4

import TTUtils as T

%language ElabReflection

%default total

data In : (f : Type -> Type) -> Type where
  MkIn : In f

-- This step requires definitional type constructor injectivity and is
-- the source of the problem.
injIn : In z = In y -> z = y
injIn (Refl {A=Type} {x=_}) = Refl

injInTT : FnDesc
injInTT = %runElab (getTTForFn `{injIn})

-- P : Type -> Type
-- P v = (a : (Type -> Type) ** (In a = v, a v -> Void))

-- func1 : P (In P) -> Void
-- func1 (a ** (InAEqInP, AAppInPImpVoid)) =
--   let lem2 : (P (In P) -> Void) = -- replace {P=\ x => x (In P) -> Void} (injIn InAEqX) AXImpVoid
--     let e1 = (injIn InAEqInP)
--         lem3 = replace {P=\ x => x (In P) -> Void} (injIn InAEqInP) AAppInPImpVoid
--     in
--       ?xxx
--   in lem2 (P ** (Refl, lem2))

-- total -- for extra oumph!
-- lem2 : Void
-- lem2 =
--   let foo : P (In P) = (P ** (Refl, func1))
--   in func1 foo

-- bla : x = y -> y = x
-- bla Refl = Refl

-- -- lookupFunDefnExact
-- -- let z : FunDefn TT = DefineFun (NS (UN "injIn") ["ProveVoid"])
-- --              [MkFunClause (Bind (UN "x")
-- --               (PVar (Bind (UN "__pi_arg")
-- --                     (Pi (TType (UVar "./Learn/ProveVoid.idr" 84)) (TType (UVar "./Learn/ProveVoid.idr" 86)))
-- --                     (TType (UVar "./Learn/ProveVoid.idr" 87))))
-- --               (App (App (App (P Ref (NS (UN "injIn") ["ProveVoid"]) Erased) (P Bound (UN "x") Erased)) (P Bound (UN "x") Erased))
-- --                    (App (App (P (DCon 0 2) (UN "Refl") Erased) Erased) Erased)))
-- --               (Bind (UN "x")
-- --               (PVar (Bind (UN "__pi_arg")
-- --                     (Pi (TType (UVar "./Learn/ProveVoid.idr" 84)) (TType (UVar "./Learn/ProveVoid.idr" 86)))
-- --                     (TType (UVar "./Learn/ProveVoid.idr" 87))))
-- --               (App (App (P (DCon 0 2) (UN "Refl") Erased)
-- --                   (Bind (UN "__pi_arg1")
-- --                   (Pi (TType (UVar "./Learn/ProveVoid.idr" 97)) (TType (UVar "./Learn/ProveVoid.idr" 99)))
-- --                   (TType (UVar "./Learn/ProveVoid.idr" 100))))
-- --                    (P Bound (UN "x") Erased)))]

-- -- lookupTyExact
-- -- let z : (TTName, NameType, TT) = (NS (UN "injIn") ["ProveVoid"],
-- --           Ref,
-- --           Bind (UN "y")
-- --                (Pi (Bind (UN "__pi_arg") (Pi (TType (UVar "./ProveVoid.idr" 59)) (TType (UVar "./ProveVoid.idr" 61))) (TType (UVar "./ProveVoid.idr" 62)))
-- --              (TType (UVar "./ProveVoid.idr" 64)))
-- --                (Bind (UN "x")
-- --                (Pi (Bind (UN "__pi_arg") (Pi (TType (UVar "./ProveVoid.idr" 65)) (TType (UVar "./ProveVoid.idr" 67))) (TType (UVar "./ProveVoid.idr" 68)))
-- --              (TType (UVar "./ProveVoid.idr" 70)))
-- --                (Bind (UN "__pi_arg")
-- --                (Pi (App (App (App (App (P (TCon 7 4) (UN "=") Erased) (TType (UVar "./ProveVoid.idr" 71))) (TType (UVar "./ProveVoid.idr" 72)))
-- --                  (App (P (TCon 8 1) (NS (UN "In") ["ProveVoid"]) Erased) (V 0)))
-- --                   (App (P (TCon 8 1) (NS (UN "In") ["ProveVoid"]) Erased) (V 1)))
-- --                    (TType (UVar "./ProveVoid.idr" 73)))
-- --                (App (App (App (App (P (TCon 7 4) (UN "=") Erased)
-- --                        (Bind (UN "__pi_arg1")
-- --                        (Pi (TType (UVar "./ProveVoid.idr" 74)) (TType (UVar "./ProveVoid.idr" 76)))
-- --                        (TType (UVar "./ProveVoid.idr" 77))))
-- --                   (Bind (UN "__pi_arg1")
-- --                   (Pi (TType (UVar "./ProveVoid.idr" 79)) (TType (UVar "./ProveVoid.idr" 81)))
-- --                   (TType (UVar "./ProveVoid.idr" 82))))
-- --                    (V 1))
-- --               (V 2)))))

-- -- lookupFunDefnExact
-- -- let z : FunDefn TT = DefineFun (NS (UN "bla") ["ProveVoid"])
-- --              [MkFunClause (Bind (MN 504 "phTy")
-- --               (PVar (TType (UVar "./ProveVoid.idr" 268)))
-- --               (Bind (MN 505 "x")
-- --               (PVar (P Bound (MN 504 "phTy") Erased))
-- --               (App (App (App (App (P Ref (NS (UN "bla") ["ProveVoid"]) Erased) (P Bound (MN 504 "phTy") Erased)) (P Bound (MN 505 "x") Erased))
-- --                   (P Bound (MN 505 "x") Erased))
-- --                    (App (App (P (DCon 0 2) (UN "Refl") Erased) Erased) Erased))))
-- --               (Bind (MN 504 "phTy")
-- --               (PVar (TType (UVar "./ProveVoid.idr" 268)))
-- --               (Bind (MN 505 "x")
-- --               (PVar (P Bound (MN 504 "phTy") Erased))
-- --               (App (App (P (DCon 0 2) (UN "Refl") Erased) (P Bound (MN 504 "phTy") Erased)) (P Bound (MN 505 "x") Erased))))]

-- -- lookupTyExact
-- blaTyExact : (TTName, NameType, TT)
-- blaTyExact =
--   (NS (UN "bla") ["ProveVoid"],
--     Ref,
--     Bind (UN "phTy")
--       (Pi (TType (UVar "./ProveVoid.idr" 262)) (TType (UVar "./ProveVoid.idr" 264)))
--       (Bind (UN "x")
--         (Pi (V 0) (TType (UVar "./ProveVoid.idr" 265)))
--         (Bind (UN "y")
--           (Pi (V 1) (TType (UVar "./ProveVoid.idr" 266)))
--           (Bind (UN "__pi_arg")
--              (Pi (App (App (App (App (P (TCon 7 4) (UN "=") Erased) (V 2)) (V 2)) (V 1)) (V 0)) (TType (UVar "./ProveVoid.idr" 267)))
--              (App (App (App (App (P (TCon 7 4) (UN "=") Erased) (V 3)) (V 3)) (V 1)) (V 2))))))

-- fazoo : 3 = 4 -> Void
-- fazoo Refl impossible


module Extra.C.CPtr

import Data.Nat
import Data.Vect
import Extra.String
import Extra.Proof
import Extra.C.Ptr
import Extra.C.Storable
import public Control.Linear.LIO
import public Extra.C.Types

public export
data Content : Type where
  NullTerminated : (can_free : Bool) -> Content
  Bytes : (can_free, can_read, can_write : Bool) -> Nat -> Content
  Opaque : (can_free : Bool) -> (ty : Type) -> Content

public export
isFreeable : Content -> Bool
isFreeable (NullTerminated can_free) = can_free
isFreeable (Bytes can_free _ _ _) = can_free
isFreeable (Opaque can_free _) = can_free

public export
typeOf : Content -> Type
typeOf (NullTerminated _) = CChar
typeOf (Bytes _ _ _ _) = CUInt8
typeOf (Opaque _ ty) = ty

public export
data CPtr : Content -> Type where
  MkCPtr : Ptr (typeOf content) -> CPtr content

export
malloc
  : LinearIO io
  => (length : Nat)
  -> {default True can_free : Bool}
  -> {default True can_read : Bool}
  -> {default True can_write : Bool}
  -> L io {use=1} (CPtr (Bytes can_free can_read can_write length))
malloc length = do
  ptr <- primIO $ prim__malloc $ cast $ natToInteger length
  pure1 $ MkCPtr (castPtr ptr)

export
calloc
  : LinearIO io
  => (length : Nat)
  -> {default True can_free : Bool}
  -> {default True can_read : Bool}
  -> {default True can_write : Bool}
  -> L io {use=1} (CPtr (Bytes can_free can_read can_write length))
calloc length = do
  ptr <- primIO $ prim__calloc $ cast $ natToInteger length
  pure1 $ MkCPtr (castPtr ptr)

export
free
  : LinearIO io
  => (1 _ : CPtr content)
  -> {auto okay : isFreeable content = True}
  -> L io ()
free (MkCPtr ptr) = primIO $ prim__free (forgetPtr ptr)

export
pokeByte
  : LinearIO io
  => (1 _ : CPtr (Bytes can_free can_read True length))
  -> (index : Nat)
  -> {auto 0 okay : LT index length}
  -> (byte : CUInt8)
  -> L io {use=1} (CPtr (Bytes can_free can_read True length))
pokeByte (MkCPtr ptr) index byte = do
  poke (plusPtr ptr (cast $ natToInteger index)) byte
  pure1 $ MkCPtr ptr

export
peekByte
  : LinearIO io
  => (1 _ : CPtr (Bytes can_free True can_write length))
  -> (index : Nat)
  -> {auto 0 okay : LT index length}
  -> L io {use=1} (Res CUInt8 (\_ => CPtr (Bytes can_free True can_write length)))
peekByte (MkCPtr ptr) index = do
  byte <- peek (plusPtr ptr (cast $ natToInteger index))
  pure1 $ (byte # MkCPtr ptr)

export
peekBytes
  : LinearIO io
  => (1 _ : CPtr (Bytes can_free True can_write length))
  -> (offset : Nat)
  -> (count : Nat)
  -> {auto okay : LTE (offset + count) length}
  -> L io {use=1} (Res (Vect count CUInt8) (\_ => CPtr (Bytes can_free True can_write length)))
peekBytes cptr ofs Z = pure1 $ Nil # cptr
peekBytes cptr ofs (S cnt) = do
  let m = lteAddRight (S ofs) {m = cnt}
  let m = replace {p = LTE (S ofs)} (plusSuccRightSucc ofs cnt) m
  byte # cptr <- peekByte {okay = lteTransitive m okay} cptr ofs
  let n = okay
  let n = replace {p = \a => LTE a length} (sym $ plusSuccRightSucc ofs cnt) n
  bytes # cptr <- peekBytes cptr (S ofs) cnt {okay = n}
  pure1 $ (byte :: bytes) # cptr

export
pokeBytes
  : LinearIO io
  => (1 _ : CPtr (Bytes can_free can_read True length))
  -> (offset : Nat)
  -> {count : Nat}
  -> (bytes : Vect count CUInt8)
  -> {auto okay : LTE (offset + count) length}
  -> L io {use=1} (CPtr (Bytes can_free can_read True length))
pokeBytes {count = Z} cptr ofs Nil             = pure1 $ cptr
pokeBytes {count = S cnt} cptr ofs (byte :: bytes) = do
  let m = lteAddRight (S ofs) {m = cnt}
  let m = replace {p = LTE (S ofs)} (plusSuccRightSucc ofs cnt) m
  cptr <- pokeByte {okay = lteTransitive m okay} cptr ofs byte
  let n = okay
  let n = replace {p = \a => LTE a length} (sym $ plusSuccRightSucc ofs cnt) n
  pokeBytes {okay = n} cptr (S ofs) bytes

export
unsafeToNullTerminated
  : LinearIO io
  => (1 _ : CPtr (Bytes can_free can_read can_write length))
  -> L io {use=1} (CPtr (NullTerminated can_free))
unsafeToNullTerminated (MkCPtr ptr) = pure1 $ MkCPtr ptr

export
unsafeToBytes
  : LinearIO io
  => (1 _ : CPtr (NullTerminated can_free))
  -> (0 length : Nat)
  -> {default True can_read  : Bool}
  -> {default True can_write : Bool}
  -> L io {use=1} (CPtr (Bytes can_free can_read can_write length))
unsafeToBytes (MkCPtr ptr) _ = pure1 $ MkCPtr ptr

-- TODO: behavior of length on strings containing '\0' is weird (?
export
packString
  : LinearIO io
  => String
  -> {default True can_free : Bool}
  -> L io {use=1} (CPtr (NullTerminated can_free))
packString str = do
  cptr <- malloc (S (length str))
  cptr <- pokeBytes {okay = believe_me ()} cptr 0 ((map (cast . ord) $ unpackVect str) `snoc` 0)
  let (MkCPtr ptr) = cptr
  pure1 $ MkCPtr ptr

export
packBytes
  : LinearIO io
  => {length : Nat}
  -> Vect length CUInt8
  -> {default True can_read  : Bool}
  -> {default True can_write : Bool}
  -> L io {use=1} (CPtr (Bytes True can_read can_write length))
packBytes bytes = do
  cptr <- malloc length
  cptr <- pokeBytes {okay = lteRefl} cptr 0 bytes
  let (MkCPtr ptr) = cptr
  pure1 $ MkCPtr ptr

export
unpackBytes
  : LinearIO io
  => {length : Nat}
  -> (1 _ : CPtr (Bytes can_free True can_write length))
  -> L io {use=1} (Res (Vect length CUInt8) (\_ => CPtr (Bytes can_free True can_write length)))
unpackBytes cptr = do
  bytes # cptr <- peekBytes {okay = lteRefl} cptr 0 length
  pure1 $ bytes # cptr


module BioFasta.Helpers

import Data.List
import Data.Maybe
import Data.Strings
import BioCore.Sequence
import BioFasta.Common

%default total

public export
||| Convert SeqData to String.
toStr : SeqData -> String
toStr (UnSD seqdata) = seqdata

public export
notLast : (l :(List (List Char))) -> {auto ok : NonEmpty l} -> List (List Char)
notLast l = init l

public export
splitsAt : Offset -> List Char -> List Char -> List (List Char)
splitsAt _ _ []       = []
splitsAt n s (_::ss') = let (s1,s2) = splitAt (integerToNat
                                              (prim__cast_IntInteger
                                              (extractUnOff n))) s
                          in if isNil s2
                               then [s1]
                               else s1 :: splitsAt n s2 ss'

public export
smallBlocks : List Char -> List (List Char)
smallBlocks blist = groupBy (const (/= '>'))
                    (filter (\x => x /= '#')
                    (dropWhile (\x => x /= '>') blist))


import Language.Reflection

%language ElabReflection

mkDecls : TTImp -> Elab ()
mkDecls v
    = declare `[ mkMult : Int -> Int
                 mkMult x = x * ~(v) ]

%runElab mkDecls `(94)

bad : a
bad = %runElab mkDecls `(94)


module Scheme.Print

import Data.Vect
import Scheme.Core

%hide Data.Vect.(::)

%default total
%access public export

showSequence : Show a => List a -> String
showSequence = concat . intersperse " " . map show

showDotted : Show a => Maybe a -> String
showDotted Nothing  = ""
showDotted (Just x) = " . " ++ show x

Show SNum where
  show (SNExactInt n) = show n

Show SExp where
  -- Short special forms
  show (SECons (SESymbol "quote"           ) x) = "'"  ++ show x
  show (SECons (SESymbol "quasiquote"      ) x) = "`"  ++ show x
  show (SECons (SESymbol "unquote"         ) x) = ","  ++ show x
  show (SECons (SESymbol "unquote-splicing") x) = ",@" ++ show x
  show (SECons (SESymbol "lambda"          ) x) = "λ"  ++ show x

  -- Lists and dotted lists
  show (SECons x y) =
    assert_total $
    case listify $ SECons x y of
         (ss, md) => "(" ++ showSequence ss ++ showDotted md ++ ")"

  -- terminals
  show  SEUnit           = "()"
  show (SEVect    xs   ) = "#(" ++ assert_total (showSequence (toList xs)) ++ ")"
  show (SESymbol  t    ) = t
  show (SENum     sn   ) = show sn
  show (SEStr     s    ) = show s
  show (SEBool    False) = "#f"
  show (SEBool    True ) = "#t"
  show (SEChar    c    ) = "#\\" ++ case c of
                                         ' '  => "space"
                                         '\t' => "tab"
                                         '\n' => "newline"
                                         _    => pack [c]


interface Foo m where
  bar : k -> v -> m k v -> m k v

-- This is kind of meaningless, except it exposes a potential error where
-- (\s, t => List (s, t)) is substituted in as 'm' in 'm k v' and the ks
-- clash, so one has to be renamed.
Eq k => Foo (\s, t => List (s, t)) where
  bar x y z = ?bang


-- ------------------------------------------------------------- [ Forward.idr ]
-- Module    : Forward.idr
-- Copyright : (c) Jan de Muijnck-Hughes
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]

module GRL.Eval.Forward

import Data.AVL.Dict
import Data.AVL.Graph
import Data.Stack
import Data.Queue
import Data.Vect

import GRL.Common
import GRL.Model

import GRL.Eval.Qualitative
import GRL.Eval.Strategy
import GRL.Eval.Common

%default partial
%access private

-- ----------------------------------------------------- [ Forward Propagation ]

private
getSat' : NodeID -> GModel -> Maybe SValue
getSat' id g =
  case getValueByID id g of
    Nothing => Nothing
    Just v  => getSValue v

calcDecomp : NodeID -> GModel -> Maybe SValue
calcDecomp id g =
    case getValueByID id g of
      Nothing  => Nothing
      Just val =>
        case getStructTy val of
          Nothing   => Nothing
          Just dval =>
            case dval of
              ANDty => Just $ getDecompAnd csat
              XORty => Just $ getDecompXOR csat
              IORty => Just $ getDecompIOR csat
  where
    children : List NodeID
    children = map fst $ getDeCompEdges id g

    csat : List SValue
    csat = catMaybes $ map (\x => getSat' x g) children

getWeightedContrib : NodeID -> CValue -> GModel -> Maybe SValue
getWeightedContrib id y g = case getSat' id g of
  Nothing => Nothing
  Just x  => Just $ weightedContrib x y

calcWeightedContrib : DemiEdge GoalEdge -> GModel -> Maybe SValue
calcWeightedContrib (id, Just (Contribution x))  g = getWeightedContrib id x g
calcWeightedContrib (id, Just (Correlation  x))  g = getWeightedContrib id x g
calcWeightedContrib _                            _ = Nothing

calcContrib : Maybe SValue -> NodeID -> GModel -> SValue
calcContrib dval id g =
    if (noUndec count > 0)
      then UNDECIDED
      else combineContribs count
  where
    children : List (DemiEdge GoalEdge)
    children = getIntentEdges id g

    wsat : List SValue
    wsat = catMaybes $ map (\e => calcWeightedContrib e g) children

    vals : List SValue
    vals = case dval of {Nothing => wsat; Just x  => x :: wsat}

    count : ContribCount
    count = adjustCounts vals

evalElem : NodeID -> GModel -> SValue
evalElem e g = calcContrib dVal e g
  where
    dVal : Maybe SValue
    dVal = (calcDecomp e g)

-- -------------------------------------------------------------- [ Init Check ]

validityCheck : GModel -> Bool
validityCheck g = allLeafsValid && not gTy
  where
    allLeafsValid : Bool
    allLeafsValid = and $ map (\x => isJust (getSValue x)) (getValuesByID (leafNodes g) g)

    gTy : Bool
    gTy = isDisconnected g

initGraph : GModel -> GModel
initGraph g = foldl (doUp) g (leaves)
  where
    leaves : List GoalNode
    leaves = map (\x => if isJust (getSValue x) then x else record {getSValue = Just NONE} x) (getValuesByID (leafNodes g) g)

    doUp : GModel -> GoalNode -> GModel
    doUp m n = updateGoalNode (\x => getNodeTitle n == getNodeTitle x)
                              (\x => n)
                              m

-- ------------------------------------------------------- [ Forward Algorithm ]

partial
export
doEval : GModel -> (Queue NodeID) -> GModel
doEval g q =
    case popQ' q of
      Nothing        => g
      Just (c, newQ) => --  TODO
        case getValueByID c g of --- if node doesn't exist
          Nothing => g
          Just c' =>
            if isJust $ getSValue c' --- if satisfied then move on
              then doEval g newQ
              else let cs = children c in
                if isNil cs --- if leaf node
                  then g
                  else do
                    if and $ map (\x => isJust $ getSValue x) cs
                      then doEval (newG c) newQ
                      else doEval g        (pushQ c newQ)
  where
    childrenIDs : NodeID -> List (DemiEdge GoalEdge)
    childrenIDs n = (getEdgesByID n g)

    children : NodeID -> List GoalNode
    children n = getValuesByID (map fst $ childrenIDs n) g

    newG : NodeID -> GModel
    newG n = updateNodeValueByIDUsing
                   n
                   (\x => record {getSValue = Just (evalElem n g)} x)
                   g

private
partial
runEval : GModel -> EvalResult
runEval g =
    if validityCheck g
        then Result (vertices (doEval g (defQueue g)))
        else let newG = getNewG g in
             let theQ = defQueue newG in
          if validityCheck newG
            then Result (vertices (doEval newG theQ))
            else BadModel
  where
    getNewG : GModel -> GModel
    getNewG m = initGraph m

    defQueue : GModel -> Queue NodeID
    defQueue m = (pushQThings (verticesID m) mkQueue)

||| Evaluate a model with or without a given strategy.
|||
||| This function will deploy the strategy if it is given. Using this
||| code with a predeployed strategy may give unexpected results.
partial
export
forwardEval : Maybe Strategy -> GModel -> EvalResult
forwardEval Nothing  g = runEval g
forwardEval (Just s) g = runEval $ fst (deployStrategy g s)
-- --------------------------------------------------------------------- [ EOF ]


module Test

public export
data Test : (f : a -> Type) -> Type where
  Check : { F : x -> Type } -> { t : x } -> ( value : F t) -> Test F


module Prelude.Cast

import Builtin
import Prelude.Basics
import Prelude.Num
import Prelude.Types

%default total

-----------
-- CASTS --
-----------

-- Casts between primitives only here.  They might be lossy.

||| Interface for transforming an instance of a data type to another type.
public export
interface Cast from to where
  constructor MkCast
  ||| Perform a (potentially lossy!) cast operation.
  ||| @ orig The original type
  cast : (orig : from) -> to

export
Cast a a where
  cast = id

-- To String

export
Cast Int String where
  cast = prim__cast_IntString

export
Cast Integer String where
  cast = prim__cast_IntegerString

export
Cast Char String where
  cast = prim__cast_CharString

export
Cast Double String where
  cast = prim__cast_DoubleString

export
Cast Nat String where
  cast = cast . natToInteger

export
Cast Int8 String where
  cast = prim__cast_Int8String

export
Cast Int16 String where
  cast = prim__cast_Int16String

export
Cast Int32 String where
  cast = prim__cast_Int32String

export
Cast Int64 String where
  cast = prim__cast_Int64String

export
Cast Bits8 String where
  cast = prim__cast_Bits8String

export
Cast Bits16 String where
  cast = prim__cast_Bits16String

export
Cast Bits32 String where
  cast = prim__cast_Bits32String

export
Cast Bits64 String where
  cast = prim__cast_Bits64String

-- To Integer

export
Cast Int Integer where
  cast = prim__cast_IntInteger

export
Cast Char Integer where
  cast = prim__cast_CharInteger

export
Cast Double Integer where
  cast = prim__cast_DoubleInteger

export
Cast String Integer where
  cast = prim__cast_StringInteger

export
Cast Nat Integer where
  cast = natToInteger

export
Cast Bits8 Integer where
  cast = prim__cast_Bits8Integer

export
Cast Bits16 Integer where
  cast = prim__cast_Bits16Integer

export
Cast Bits32 Integer where
  cast = prim__cast_Bits32Integer

export
Cast Bits64 Integer where
  cast = prim__cast_Bits64Integer

export
Cast Int8 Integer where
  cast = prim__cast_Int8Integer

export
Cast Int16 Integer where
  cast = prim__cast_Int16Integer

export
Cast Int32 Integer where
  cast = prim__cast_Int32Integer

export
Cast Int64 Integer where
  cast = prim__cast_Int64Integer

-- To Int

export
Cast Integer Int where
  cast = prim__cast_IntegerInt

export
Cast Char Int where
  cast = prim__cast_CharInt

export
Cast Double Int where
  cast = prim__cast_DoubleInt

export
Cast String Int where
  cast = prim__cast_StringInt

export
Cast Nat Int where
  cast = fromInteger . natToInteger

export
Cast Bits8 Int where
  cast = prim__cast_Bits8Int

export
Cast Bits16 Int where
  cast = prim__cast_Bits16Int

export
Cast Bits32 Int where
  cast = prim__cast_Bits32Int

export
Cast Bits64 Int where
  cast = prim__cast_Bits64Int

export
Cast Int8 Int where
  cast = prim__cast_Int8Int

export
Cast Int16 Int where
  cast = prim__cast_Int16Int

export
Cast Int32 Int where
  cast = prim__cast_Int32Int

export
Cast Int64 Int where
  cast = prim__cast_Int64Int

-- To Char

export
Cast Int Char where
  cast = prim__cast_IntChar

export
Cast Integer Char where
  cast = prim__cast_IntegerChar

export
Cast Nat Char where
  cast = cast . natToInteger

export
Cast Bits8 Char where
  cast = prim__cast_Bits8Char

export
Cast Bits16 Char where
  cast = prim__cast_Bits16Char

export
Cast Bits32 Char where
  cast = prim__cast_Bits32Char

export
Cast Bits64 Char where
  cast = prim__cast_Bits64Char

export
Cast Int8 Char where
  cast = prim__cast_Int8Char

export
Cast Int16 Char where
  cast = prim__cast_Int16Char

export
Cast Int32 Char where
  cast = prim__cast_Int32Char

export
Cast Int64 Char where
  cast = prim__cast_Int64Char

-- To Double

export
Cast Int Double where
  cast = prim__cast_IntDouble

export
Cast Integer Double where
  cast = prim__cast_IntegerDouble

export
Cast String Double where
  cast = prim__cast_StringDouble

export
Cast Nat Double where
  cast = prim__cast_IntegerDouble . natToInteger

export
Cast Bits8 Double where
  cast = prim__cast_Bits8Double

export
Cast Bits16 Double where
  cast = prim__cast_Bits16Double

export
Cast Bits32 Double where
  cast = prim__cast_Bits32Double

export
Cast Bits64 Double where
  cast = prim__cast_Bits64Double

export
Cast Int8 Double where
  cast = prim__cast_Int8Double

export
Cast Int16 Double where
  cast = prim__cast_Int16Double

export
Cast Int32 Double where
  cast = prim__cast_Int32Double

export
Cast Int64 Double where
  cast = prim__cast_Int64Double

-- To Bits8

export
Cast Int Bits8 where
  cast = prim__cast_IntBits8

export
Cast Integer Bits8 where
  cast = prim__cast_IntegerBits8

export
Cast Bits16 Bits8 where
  cast = prim__cast_Bits16Bits8

export
Cast Bits32 Bits8 where
  cast = prim__cast_Bits32Bits8

export
Cast Bits64 Bits8 where
  cast = prim__cast_Bits64Bits8

export
Cast String Bits8 where
  cast = prim__cast_StringBits8

export
Cast Double Bits8 where
  cast = prim__cast_DoubleBits8

export
Cast Char Bits8 where
  cast = prim__cast_CharBits8

export
Cast Nat Bits8 where
  cast = cast . natToInteger

export
Cast Int8 Bits8 where
  cast = prim__cast_Int8Bits8

export
Cast Int16 Bits8 where
  cast = prim__cast_Int16Bits8

export
Cast Int32 Bits8 where
  cast = prim__cast_Int32Bits8

export
Cast Int64 Bits8 where
  cast = prim__cast_Int64Bits8

-- To Bits16

export
Cast Int Bits16 where
  cast = prim__cast_IntBits16

export
Cast Integer Bits16 where
  cast = prim__cast_IntegerBits16

export
Cast Bits8 Bits16 where
  cast = prim__cast_Bits8Bits16

export
Cast Bits32 Bits16 where
  cast = prim__cast_Bits32Bits16

export
Cast Bits64 Bits16 where
  cast = prim__cast_Bits64Bits16

export
Cast String Bits16 where
  cast = prim__cast_StringBits16

export
Cast Double Bits16 where
  cast = prim__cast_DoubleBits16

export
Cast Char Bits16 where
  cast = prim__cast_CharBits16

export
Cast Nat Bits16 where
  cast = cast . natToInteger

export
Cast Int8 Bits16 where
  cast = prim__cast_Int8Bits16

export
Cast Int16 Bits16 where
  cast = prim__cast_Int16Bits16

export
Cast Int32 Bits16 where
  cast = prim__cast_Int32Bits16

export
Cast Int64 Bits16 where
  cast = prim__cast_Int64Bits16

-- To Bits32

export
Cast Int Bits32 where
  cast = prim__cast_IntBits32

export
Cast Integer Bits32 where
  cast = prim__cast_IntegerBits32

export
Cast Bits8 Bits32 where
  cast = prim__cast_Bits8Bits32

export
Cast Bits16 Bits32 where
  cast = prim__cast_Bits16Bits32

export
Cast Bits64 Bits32 where
  cast = prim__cast_Bits64Bits32

export
Cast String Bits32 where
  cast = prim__cast_StringBits32

export
Cast Double Bits32 where
  cast = prim__cast_DoubleBits32

export
Cast Char Bits32 where
  cast = prim__cast_CharBits32

export
Cast Nat Bits32 where
  cast = cast . natToInteger

export
Cast Int8 Bits32 where
  cast = prim__cast_Int8Bits32

export
Cast Int16 Bits32 where
  cast = prim__cast_Int16Bits32

export
Cast Int32 Bits32 where
  cast = prim__cast_Int32Bits32

export
Cast Int64 Bits32 where
  cast = prim__cast_Int64Bits32

-- To Bits64

export
Cast Int Bits64 where
  cast = prim__cast_IntBits64

export
Cast Integer Bits64 where
  cast = prim__cast_IntegerBits64

export
Cast Bits8 Bits64 where
  cast = prim__cast_Bits8Bits64

export
Cast Bits16 Bits64 where
  cast = prim__cast_Bits16Bits64

export
Cast Bits32 Bits64 where
  cast = prim__cast_Bits32Bits64

export
Cast String Bits64 where
  cast = prim__cast_StringBits64

export
Cast Double Bits64 where
  cast = prim__cast_DoubleBits64

export
Cast Char Bits64 where
  cast = prim__cast_CharBits64

export
Cast Nat Bits64 where
  cast = cast . natToInteger

export
Cast Int8 Bits64 where
  cast = prim__cast_Int8Bits64

export
Cast Int16 Bits64 where
  cast = prim__cast_Int16Bits64

export
Cast Int32 Bits64 where
  cast = prim__cast_Int32Bits64

export
Cast Int64 Bits64 where
  cast = prim__cast_Int64Bits64

-- To Int8

export
Cast String Int8 where
  cast = prim__cast_StringInt8

export
Cast Double Int8 where
  cast = prim__cast_DoubleInt8

export
Cast Char Int8 where
  cast = prim__cast_CharInt8

export
Cast Int Int8 where
  cast = prim__cast_IntInt8

export
Cast Integer Int8 where
  cast = prim__cast_IntegerInt8

export
Cast Nat Int8 where
  cast = cast . natToInteger

export
Cast Bits8 Int8 where
  cast = prim__cast_Bits8Int8

export
Cast Bits16 Int8 where
  cast = prim__cast_Bits16Int8

export
Cast Bits32 Int8 where
  cast = prim__cast_Bits32Int8

export
Cast Bits64 Int8 where
  cast = prim__cast_Bits64Int8

export
Cast Int16 Int8 where
  cast = prim__cast_Int16Int8

export
Cast Int32 Int8 where
  cast = prim__cast_Int32Int8

export
Cast Int64 Int8 where
  cast = prim__cast_Int64Int8

-- To Int16

export
Cast String Int16 where
  cast = prim__cast_StringInt16

export
Cast Double Int16 where
  cast = prim__cast_DoubleInt16

export
Cast Char Int16 where
  cast = prim__cast_CharInt16

export
Cast Int Int16 where
  cast = prim__cast_IntInt16

export
Cast Integer Int16 where
  cast = prim__cast_IntegerInt16

export
Cast Nat Int16 where
  cast = cast . natToInteger

export
Cast Bits8 Int16 where
  cast = prim__cast_Bits8Int16

export
Cast Bits16 Int16 where
  cast = prim__cast_Bits16Int16

export
Cast Bits32 Int16 where
  cast = prim__cast_Bits32Int16

export
Cast Bits64 Int16 where
  cast = prim__cast_Bits64Int16

export
Cast Int8 Int16 where
  cast = prim__cast_Int8Int16

export
Cast Int32 Int16 where
  cast = prim__cast_Int32Int16

export
Cast Int64 Int16 where
  cast = prim__cast_Int64Int16

-- To Int32

export
Cast String Int32 where
  cast = prim__cast_StringInt32

export
Cast Double Int32 where
  cast = prim__cast_DoubleInt32

export
Cast Char Int32 where
  cast = prim__cast_CharInt32

export
Cast Int Int32 where
  cast = prim__cast_IntInt32

export
Cast Integer Int32 where
  cast = prim__cast_IntegerInt32

export
Cast Nat Int32 where
  cast = cast . natToInteger

export
Cast Bits8 Int32 where
  cast = prim__cast_Bits8Int32

export
Cast Bits16 Int32 where
  cast = prim__cast_Bits16Int32

export
Cast Bits32 Int32 where
  cast = prim__cast_Bits32Int32

export
Cast Bits64 Int32 where
  cast = prim__cast_Bits64Int32

export
Cast Int8 Int32 where
  cast = prim__cast_Int8Int32

export
Cast Int16 Int32 where
  cast = prim__cast_Int16Int32

export
Cast Int64 Int32 where
  cast = prim__cast_Int64Int32

-- To Int64

export
Cast String Int64 where
  cast = prim__cast_StringInt64

export
Cast Double Int64 where
  cast = prim__cast_DoubleInt64

export
Cast Char Int64 where
  cast = prim__cast_CharInt64

export
Cast Int Int64 where
  cast = prim__cast_IntInt64

export
Cast Integer Int64 where
  cast = prim__cast_IntegerInt64

export
Cast Nat Int64 where
  cast = cast . natToInteger

export
Cast Bits8 Int64 where
  cast = prim__cast_Bits8Int64

export
Cast Bits16 Int64 where
  cast = prim__cast_Bits16Int64

export
Cast Bits32 Int64 where
  cast = prim__cast_Bits32Int64

export
Cast Bits64 Int64 where
  cast = prim__cast_Bits64Int64

export
Cast Int8 Int64 where
  cast = prim__cast_Int8Int64

export
Cast Int16 Int64 where
  cast = prim__cast_Int16Int64

export
Cast Int32 Int64 where
  cast = prim__cast_Int32Int64

-- To Nat

export
Cast String Nat where
  cast = integerToNat . cast

export
Cast Double Nat where
  cast = integerToNat . cast

export
Cast Char Nat where
  cast = integerToNat . cast {to = Integer}

export
Cast Int Nat where
  cast = integerToNat . cast

export
Cast Integer Nat where
  cast = integerToNat

export
Cast Bits8 Nat where
  cast = integerToNat . cast {to = Integer}

export
Cast Bits16 Nat where
  cast = integerToNat . cast {to = Integer}

export
Cast Bits32 Nat where
  cast = integerToNat . cast {to = Integer}

export
Cast Bits64 Nat where
  cast = integerToNat . cast {to = Integer}

export
Cast Int8 Nat where
  cast = integerToNat . cast

export
Cast Int16 Nat where
  cast = integerToNat . cast

export
Cast Int32 Nat where
  cast = integerToNat . cast

export
Cast Int64 Nat where
  cast = integerToNat . cast


module WebAssembly.Validation.Modules.Imports

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

||| [🔗 Spec](https://webassembly.github.io/spec/core/valid/modules.html#imports)
public export
data ValidImportDesc : Context -> ImportDesc -> ExternType -> Type where

  ||| [🔗 Spec](https://webassembly.github.io/spec/core/valid/modules.html#xref-syntax-modules-syntax-importdesc-mathsf-func-x)
  |||
  ||| ```
  ||| C.types[x] = [t1*] -> [t2*]
  ||| --------------------------------
  ||| C ⊢ func x : func [t1*] -> [t2*]
  ||| ```
  ValidImportFunc  : (c : Context)
                  -> (x : TypeIdx)
                  -> {auto in_bounds: InBounds x (types c)}
                  -> ValidImportDesc c (FuncImport x) (Func (index x (types c)))

  ||| [🔗 Spec](https://webassembly.github.io/spec/core/valid/modules.html#xref-syntax-modules-syntax-importdesc-mathsf-table-xref-syntax-types-syntax-tabletype-mathit-tabletype)
  |||
  ||| ```
  ||| tabletype ok
  ||| -------------------------------------
  ||| C ⊢ table tabletype : table tabletype
  ||| ```
  MkValidImportTable : (c : Context)
                    -> (tabletype : TableType)
                    -> ValidTableType tabletype
                    -> ValidImportDesc c (TableImport tabletype) (Table tabletype)

  ||| [🔗 Spec](https://webassembly.github.io/spec/core/valid/modules.html#xref-syntax-modules-syntax-importdesc-mathsf-mem-xref-syntax-types-syntax-memtype-mathit-memtype)
  |||
  ||| ```
  ||| memtype ok
  ||| -----------------------------
  ||| C ⊢ mem memtype : mem memtype
  ||| ```
  MkValidImportMem : (c : Context)
                  -> (memtype : MemType)
                  -> ValidMemoryType memtype
                  -> ValidImportDesc c (MemImport memtype) (Mem memtype)

  ||| [🔗 Spec](https://webassembly.github.io/spec/core/valid/modules.html#xref-syntax-modules-syntax-importdesc-mathsf-global-xref-syntax-types-syntax-globaltype-mathit-globaltype)
  |||
  ||| ```
  ||| globaltype ok
  ||| -----------------------------
  ||| C ⊢ global globaltype : global globaltype
  ||| ```
  MkValidImportGlobal  : (c : Context)
                      -> (globaltype : GlobalType)
                      -> ValidGlobalType globaltype
                      -> ValidImportDesc c (GlobalImport globaltype) (Global globaltype)

||| [🔗 Spec](https://webassembly.github.io/spec/core/valid/modules.html#imports)
public export
data ValidImport : Context -> Import -> ExternType -> Type where
  ||| [🔗 Spec](https://webassembly.github.io/spec/core/valid/modules.html#xref-syntax-modules-syntax-import-mathsf-module-xref-syntax-values-syntax-name-mathit-name-1-xref-syntax-modules-syntax-import-mathsf-name-xref-syntax-values-syntax-name-mathit-name-2-xref-syntax-modules-syntax-import-mathsf-desc-xref-syntax-modules-syntax-importdesc-mathit-importdesc)
  |||
  ||| ```
  ||| C ⊢ importdesc : externtype
  ||| ------------------------------------------------------------
  ||| C ⊢ {module name1, name name2, desc importdesc} : externtype
  ||| ```
  MkValidImport  : (c : Context)
                -> (name1 : Name)
                -> (name2 : Name)
                -> (importdesc : ImportDesc)
                -> (externtype : ExternType)
                -> ValidImportDesc c importdesc externtype
                -> ValidImport c (MkImport name1 name2 importdesc) externtype


module Crypto.Hash.Interfaces

import Data.Vect

public export
interface Digest (0 algo : Type) where
  digest_nbyte : Nat
  update : List Bits8 -> algo -> algo
  finalize : algo -> Vect digest_nbyte Bits8

public export
interface Digest algo => Hash algo where
  block_nbyte : Nat
  initialize : algo

public export
interface Digest algo => MAC (0 key : Type) algo where
  initialize_mac : key -> algo


module Control.Eff.Internal

import public Control.MonadRec
import public Control.Monad.Free
import public Data.Union

%default total

||| An effectful computation yielding a value
||| of type `t` and supporting the effects listed
||| in `fs`.
public export
Eff : (fs : List (Type -> Type)) -> (t : Type) -> Type
Eff fs t = Free (Union fs) t

||| Lift a an effectful comutation into the `Eff` monad.
export
send : Has f fs => f t -> Eff fs t
send = lift . inj

||| Handle all effectful computations in `m`,
||| returning the underlying free monad.
export
toFree : Eff fs t -> Handler fs m -> Free m t
toFree eff h = mapK (handleAll h) eff

||| Run an effectful computation without overflowing
||| the stack by handling all computations in monad `m`.
export
runEff : MonadRec m => Eff fs t -> Handler fs m -> m t
runEff eff h = foldMap (handleAll h) eff

||| Extract the (pure) result of an effectful computation
||| where all effects have been handled.
export
extract : Eff [] a -> a
extract fr = case toView fr of
  Pure val => val
  Bind u _ => absurd u

export
handleRelay :  (prf : Has f fs)
            => (a -> Eff (fs - f) b)
            -> (forall v . f v -> (v -> Eff (fs - f) b) -> Eff (fs - f) b)
            -> Eff fs a
            -> Eff (fs - f) b
handleRelay fval fcont fr = case toView fr of
  Pure val => fval val
  Bind x g => case decomp {prf} x of
    Left y  => assert_total $ lift y >>= handleRelay fval fcont . g
    Right y => assert_total $ fcont y (handleRelay fval fcont . g)

export
handleRelayS :  (prf : Has f fs)
             => s
             -> (s -> a -> Eff (fs - f) b)
             -> (forall v . s -> f v -> (s -> v -> Eff (fs - f) b) -> Eff (fs - f) b)
             -> Eff fs a
             -> Eff (fs - f) b
handleRelayS vs fval fcont fr = case toView fr of
  Pure val => fval vs val
  Bind x g => case decomp {prf} x of
    Left y  => assert_total $ lift y >>= handleRelayS vs fval fcont . g
    Right y => assert_total $ fcont vs y (\vs2 => handleRelayS vs2 fval fcont . g)


module Control.JS.Async

export
data Async : Type -> Type where
    Pure : a -> Async a
    LiftIO : PrimIO a -> Async a
    Asyn : ((a -> PrimIO ()) -> PrimIO ()) -> Async a
    Par : Async (a -> b) -> Async a -> Async b
    Bind : Async a -> (a -> Async b) -> Async b

export
Functor Async where
    map f (Pure x) = Pure $ f x
    map f (LiftIO g) = LiftIO $ \w => let MkIORes x w' = g w in MkIORes (f x) w'
    map f (Asyn g) = Asyn $ \k, w => g (\x, w' => k (f x) w') w
    map f (Par mf mx) = Par (map (f .) mf) mx
    map f (Bind mx g) = Bind mx $ \x => map f $ g x

export
Applicative Async where
    pure = Pure
    mf <*> mx = Bind mf $ \f => map f mx

export
[Parallel] Applicative Async where
    pure = Pure
    (<*>) = Par

export
Monad Async where
    (>>=) = Bind

export
HasIO Async where
    liftIO act = LiftIO (toPrim act)

export %inline
parallel : Traversable t => t (Async a) -> Async (t a)
parallel = sequence @{Parallel}

export %inline
parallelMap : Traversable t => (a -> Async b) -> t a -> Async (t b)
parallelMap = traverse @{%search} @{Parallel}

export %inline
prim__async : ((a -> PrimIO ()) -> PrimIO ()) -> Async a
prim__async = Asyn

export %inline
async : ((a -> IO ()) -> IO ()) -> Async a
async f = prim__async (\k, w => toPrim (f (\x => fromPrim (k x))) w)

data Promise : Type -> Type where [external]

%foreign "javascript:support:pure,async"
promise__pure : {0 a : _} -> a -> PrimIO (Promise a)

%foreign "javascript:support:liftIO,async"
promise__liftIO : {0 a : _} -> PrimIO a -> PrimIO (Promise a)

%foreign "javascript:support:async,async"
promise__async : {0 a : _} -> ((a -> PrimIO ()) -> PrimIO ()) -> PrimIO (Promise a)

%foreign "javascript:support:par_app,async"
promise__par_app : {0 a, b : _} -> Promise (a -> b) -> Promise a -> PrimIO (Promise b)

%foreign "javascript:support:bind,async"
promise__bind :{0 a, b : _} -> Promise a -> (a -> PrimIO (Promise b)) -> PrimIO (Promise b)

export
toPromise : Async a -> IO (Promise a)
toPromise (Pure x) = fromPrim $ promise__pure x
toPromise (LiftIO f) = fromPrim $ promise__liftIO f
toPromise (Asyn f) = fromPrim $ promise__async f
toPromise (Par x y) = fromPrim $ promise__par_app !(toPromise x) !(toPromise y)
toPromise (Bind x f) = fromPrim $ promise__bind !(toPromise x) (\x => toPrim $ toPromise (f x))

export
launch : Async a -> IO ()
launch = ignore . toPromise


module Dimp

import Data.Vect

import Assn
import Expr
import Hoare
import Imp
import Maps

-- %hide Assn.(->>)

%access public export

%default total

data DCom : Type where
  DCSkip : Assertion -> DCom
  DCSeq : DCom -> DCom -> DCom
  DCAss : Id -> AExp -> Assertion -> DCom
  DCIf : BExp -> Assertion -> DCom -> Assertion -> DCom -> Assertion -> DCom
  DCWhile : BExp -> Assertion -> DCom -> Assertion -> DCom
  DCPre : Assertion -> DCom -> DCom
  DCPost : DCom -> Assertion -> DCom

data Decorated : Type where
  Decorate : Assertion -> DCom -> Decorated

SKIP : Vect 1 Assertion -> DCom
SKIP [p] = DCSkip p

syntax [x] "::=" [a] "[" [p] "]" = DCAss x a p

syntax IF [b] THEN "[" [pThen] "]" [dt] ELSE "[" [pElse] "]" [df] END "[" [pIf] "]" = DCIf b pThen dt pElse df pIf

syntax WHILE [b] DO "[" [pBody] "]" [d] END "[" [pPost] "]" = DCWhile b pBody d pPost

syntax "->>" "[" [p] "]" [d] = DCPre p d

(->>) : DCom -> Vect 1 Assertion -> DCom
d ->> [p] = DCPost d p

(>>=) : DCom -> (() -> DCom) -> DCom
(>>=) c f = DCSeq c (f ())

syntax "[" [p] "]" [d] = Decorate p d

dec0 : DCom
dec0 = SKIP [const ()]

dec1 : DCom
dec1 = WHILE BTrue DO [const ()] SKIP [const ()] END [const ()]

dec_while : Decorated
dec_while =
  ([const ()]
   WHILE not (X == 0) DO
     [\st => ((), Not (st X = 0))]
     DCAss X (X - 1)
     (const ())
   END
   [\st => ((), st X = 0)] ->>
   [\st => st X = 0])

extract : DCom -> Com
extract (DCSkip _) = CSkip
extract (DCSeq d1 d2) = CSeq (extract d1) (extract d2)
extract (DCAss x e _) = CAss x e
extract (DCIf b _ dt _ df _) = CIf b (extract dt) (extract df)
extract (DCWhile b _ d _) = CWhile b (extract d)
extract (DCPre _ d) = extract d
extract (DCPost d _) = extract d

extract_dec : Decorated -> Com
extract_dec (Decorate _ d) = extract d

post : DCom -> Assertion
post (DCSkip p) = p
post (DCSeq _ d2) = post d2
post (DCAss _ _ p) = p
post (DCIf _ _ _ _ _ p) = p
post (DCWhile _ _ _ p) = p
post (DCPre _ d) = post d
post (DCPost _ p) = p

pre_dec : Decorated -> Assertion
pre_dec (Decorate p _) = p

post_dec : Decorated -> Assertion
post_dec (Decorate _ d) = post d

DecCorrect : (dec : Decorated) -> Type
DecCorrect dec = HoareTriple (pre_dec dec) (extract_dec dec) (post_dec dec)

VerificationConditions : (p : Assertion) -> (d : DCom) -> Type
VerificationConditions p (DCSkip q) = p ->> q
VerificationConditions p (DCSeq d1 d2) =
  ( VerificationConditions p d1
  , VerificationConditions (post d1) d2 )
VerificationConditions p (DCAss x a q) = p ->> AssignSub x a q
VerificationConditions p (DCIf b pt dt pf df q) =
  ( (\st => (p st, BAssn b st)) ->> pt
  , (\st => (p st, Not (BAssn b st))) ->> pf
  , post dt ->> q, post df ->> q
  , VerificationConditions pt dt
  , VerificationConditions pf df )
VerificationConditions p (DCWhile b pBody d q) =
  ( p ->> post d
  , (\st => (post d st, BAssn b st)) ->> pBody
  , (\st => (post d st, Not (BAssn b st))) ->> q
  , VerificationConditions pBody d )
VerificationConditions p (DCPre p' d) = (p ->> p', VerificationConditions p' d)
VerificationConditions p (DCPost d q) =
  (VerificationConditions p d, post d ->> q)

verification_correct : (d : DCom) -> (p : Assertion) ->
                       VerificationConditions p d ->
                       HoareTriple p (extract d) (post d)
verification_correct (DCSkip q) p vc st _ E_Skip p_st = vc st p_st
verification_correct (DCSeq d1 d2) p (vc1, vc2) st st' (E_Seq {st2} c1 c2) p_st =
  let post_d1_st2 = verification_correct d1 p vc1 st st2 c1 p_st
  in verification_correct d2 (post d1) vc2 st2 st' c2 post_d1_st2
verification_correct (DCAss x e q) p vc st _ (E_Ass prf) p_st =
  rewrite sym prf in vc st p_st
verification_correct (DCIf b pt dt pf df q) p
                     (p_pt_imp, p_pf_imp, pt_q_imp, pf_q_imp, vc_pt_dt, vc_pf_df)
                     st st' (E_IfTrue prf ct) p_st =
  let pt_st = p_pt_imp st (p_st, prf)
      post_dt_st' = verification_correct dt pt vc_pt_dt st st' ct pt_st
  in pt_q_imp st' post_dt_st'
verification_correct (DCIf b pt dt pf df q) p
                     (p_pt_imp, p_pf_imp, pt_q_imp, pf_q_imp, vc_pt_dt, vc_pf_df)
                     st st' (E_IfFalse prf cf) p_st =
  let pf_st = p_pf_imp st (p_st, bexp_eval_false prf)
      post_df_st' = verification_correct df pf vc_pf_df st st' cf pf_st
  in pf_q_imp st' post_df_st'
verification_correct (DCWhile b pd d q) p (p_d_imp, d_pd_imp, d_q_imp, vc_pd_d)
                     st _ (E_WhileEnd prf) p_st =
  d_q_imp st (p_d_imp st p_st, bexp_eval_false prf)
verification_correct w@(DCWhile b pd d q) p (p_d_imp, d_pd_imp, d_q_imp, vc_pd_d)
                     st st' (E_WhileLoop {st1} prf cbody cnext) p_st =
  let pd_st = d_pd_imp st (p_d_imp st p_st, prf)
      d_st1 = verification_correct d pd vc_pd_d st st1 cbody pd_st
  in verification_correct
       w
       (post d)
       (\_, d_st2 => d_st2, d_pd_imp, d_q_imp, vc_pd_d)
       st1
       st'
       cnext
       d_st1
verification_correct (DCPre p' d) p (imp, vc) st st' rel p_st =
  verification_correct d p' vc st st' rel (imp st p_st)
verification_correct (DCPost d q) p (vc, imp) st st' rel p_st =
  imp st' (verification_correct d p vc st st' rel p_st)

VerificationConditionsDec : Decorated -> Type
VerificationConditionsDec (Decorate p d) = VerificationConditions p d

verification_correct_dec : (dec : Decorated) -> VerificationConditionsDec dec ->
                           DecCorrect dec
verification_correct_dec (Decorate p d) vc = verification_correct d p vc


||| JSON parser/ADT
||| Reference: https://www.json.org/json-en.html
module Extra.Json

import Extra.Parser
import Extra.Alternative
import Extra.Scientific
import Extra.Applicative
import Debug.Trace
import Data.Fin
import Data.List

||| A JSON value
public export
data Value : Type where
  MkString : String -> Value
  MkObject : List (String, Value) -> Value
  MkArray : List Value -> Value
  MkNumber : Scientific -> Value
  MkBoolean : Bool -> Value
  MkNull : Value

export
Show Value where
  show (MkString str) = show str
  show (MkNumber scientific) = show scientific
  show (MkArray array) = "[" <+> (concat $ intersperse "," $ map show array) <+> "]"
  show (MkObject obj) = "{" <+> (concat $ intersperse "," $ map (\(a, b) => show a <+> ":" <+> show b) obj) <+> "}"
  show (MkBoolean False) = "false"
  show (MkBoolean True) = "true"
  show MkNull = "null"

export
oneNineP : Stream i Char => Parser i Integer
oneNineP = (token '1' $> 1) <|> (token '2' $> 2) <|> (token '3' $> 3)
       <|> (token '4' $> 4) <|> (token '5' $> 5) <|> (token '6' $> 6)
       <|> (token '7' $> 7) <|> (token '8' $> 8) <|> (token '9' $> 9)

export
digitP : Stream i Char => Parser i Integer
digitP = (token '0' $> 0) <|> oneNineP

export
digitsP : Stream i Char => Parser i Integer
digitsP = map snd helper
  where
  helper : Parser i (Integer, Integer)
  helper = do
    d <- digitP
    maybe_ds <- optional helper
    case maybe_ds of
      Nothing => pure (1, d)
      Just (n, ds) => let n' = n * 10 in pure (n', d * n' + ds)

export
integerP : Stream i Char => Parser i Integer
integerP = do
  b <- option 1 (token '-' $> (-1))
  n <- (token '0' $> 0) <|> digitsP
  pure $ b * n

export
signP : Stream i Char => Parser i Integer
signP = (token '+' $> 1) <|> (token '-' $> -1)

export
numberP : Stream i Char => Parser i Scientific
numberP = do
  pre <- integerP
  dec <- option 0 $ token '.' *> digitsP
  exp <- option 0 $ (token 'e' <|> token 'E') *> ((*) <$> (signP <|> pure 1) <*> digitsP)
  let a = MkScientific pre exp
  let b = asDecimal dec
  pure $ a + if pre < 0 then -b else b

export
whitespaceP : Stream i Char => Parser i ()
whitespaceP = many space $> ()

export
boolP : Stream i Char => Parser i Bool
boolP = (string "true" $> True) <|> (string "false" $> False)

export
escapeP : Stream i Char => Parser i Char
escapeP = (token '\\')
  <|> (token '/')
  <|> (token 'b' $> '\b')
  <|> (token 'f' $> '\f')
  <|> (token 'n' $> '\n')
  <|> (token 'r' $> '\r')
  <|> (token 't' $> '\t')

export
characterP : Stream i Char => Parser i Char
characterP = notFollowedBy (token '"') *> ((token '\\' *> escapeP) <|> utf16 <|> (notFollowedBy (token '\\') *> anyToken))
  where
  hex : Parser i Int
  hex = (cast . finToInteger) <$> hexDigit
  code : Parser i Int
  code = do
    skip (token '\\' *> token 'u')
    b1 <- hex; b2 <- hex; b3 <- hex; b4 <- hex
    pure $ b1 * 0x1000 + b2 * 0x100 + b3 * 0x10 + b4
  utf16 : Parser i Char
  utf16 = do
    code >>= \high => case (0xD800 <= high && high <= 0xDBFF) of
      False => pure $ chr high
      True => code >>= \low => case 0xDC00 <= low && low <= 0xDFFF of
        False => fail "utf16 no low surrogate"
        True => pure $ chr $ 0x10000 + (high - 0xD800) * 0x400 + (low - 0xDC00)

export
charactersP : Stream i Char => Parser i String
charactersP = (strCons <$> characterP <*>| charactersP) <|> pure neutral

export
stringP : Stream i Char => Parser i String
stringP = token '"' *> charactersP <* token '"'

export
nullP : Stream i Char => Parser i Value
nullP = string "null" $> MkNull

mutual
  export
  elementP : Stream i Char => Parser i Value
  elementP = whitespaceP *> valueP <* whitespaceP

  export
  elementsP : Stream i Char => Parser i (List Value)
  elementsP =
    ((::) <$> elementP <*>| (token ',' *> elementsP))
    <|> (pure <$> elementP)

  export
  memberP : Stream i Char => Parser i (String, Value)
  memberP = (,) <$> (whitespaceP *> stringP <* whitespaceP) <*> (token ':' *> elementP)

  export
  membersP : Stream i Char => Parser i (List (String, Value))
  membersP = ((::) <$> memberP <*>| (token ',' *> membersP)) <|> (pure <$> memberP)

  export
  arrayP : Stream i Char => Parser i (List Value)
  arrayP = (token '[' *> (whitespaceP $> []) <* token ']')
       <|> (token '[' *> elementsP <* token ']')

  export
  objectP : Stream i Char => Parser i (List (String, Value))
  objectP = (token '{' *> (whitespaceP $> []) <* token '}')
        <|> (token '{' *> membersP <* token '}')

  export
  valueP : Stream i Char => Parser i Value
  valueP = whitespaceP *> ((MkString <$> stringP)
                       <|> (MkNumber <$> numberP)
                       <|> (MkArray <$> arrayP))
                       <|> (MkBoolean <$> boolP)
                       <|> (MkObject <$> objectP)
                       <|> nullP


module Main

import Resimp

data Purpose = Reading | Writing

pstring : Purpose -> String
pstring Reading = "r"
pstring Writing = "w"

data FILE : Purpose -> Type where
    OpenH : File -> FILE p

syntax ifM [test] then [t] else [e]
    = test >>= (\b => if b then t else e)

open : String -> (p:Purpose) -> Creator (Either () (FILE p))
open fn p = ioc (do h <- fopen fn (pstring p)
                    ifM validFile h
                        then return (Right (OpenH h))
                        else return (Left ()))

close : FILE p -> Updater ()
close (OpenH h) = iou (closeFile h)

readLine : FILE Reading -> Reader String
readLine (OpenH h) = ior (fread h)

eof : FILE Reading -> Reader Bool
eof (OpenH h) = ior (feof h)

syntax rclose [h]    = Update close h
syntax rreadLine [h] = Use readLine h
syntax reof [h]      = Use eof h

syntax rputStrLn [s] = Lift (putStrLn s)

syntax if opened [f] then [e] else [t] = Check f t e

--------

readH : String -> RES ()
readH fn = res (do let x = open fn Reading
                   if opened x then
                       do While (do e <- reof x
                                    Return (not e))
                                (do str <- rreadLine x
                                    Lift (putStr str))
                          rclose x
                       else rputStrLn "Error")

main : IO ()
main = run (readH "test")


-- Things like  ( , )  ( ** )  ()   are special in that they denote more than
-- one thing at once. () can mean Unit or MkUnit, (,) can mean Pair or MkPair
-- Idiom brackets need to be able to work despite that, which is tested here

fez : IO Int
fez = pure 1

fez1 : IO (Int, ())
fez1 = [| MkPair fez (pure ()) |]

fez2 : IO (Int, Maybe Int)
fez2 = [| ( fez , (pure Nothing) ) |]


import OCaml.IO

front_legss : List (Int, Int)
front_legss = [
        (256, 246), (249, 287), (251, 343), (264, 346), (266, 306), (276, 276),
        (282, 306), (278, 343), (292, 343), (298, 306), (298, 277), (299, 254),
        (255, 246)
    ]

back_legss : List (Int, Int)
back_legss = [
         (432, 243), (441, 289), (430, 334), (445, 334), (462, 275), (469, 328),
         (476, 328), (478, 259), (454, 214), (461, 164), (407, 206)
    ]

set_color : Int -> OCaml_IO ()
set_color = ocamlCall "Graphics.set_color" (Int -> OCaml_IO ())

fe : Int -> Int -> Int -> Int -> Int -> OCaml_IO ()
fe y_max x y w h = let y = y_max - y in
    ocamlCall "Graphics.fill_ellipse" (Int -> Int -> Int -> Int -> OCaml_IO ())
     (x + (w `div` 2)) (y - (h `div` 2)) (w `div` 2) (h `div` 2)

fp : Int -> Ptr -> OCaml_IO ()
fp y_max ar = do
    f <- ocamlCall "Idrisobj.f" (Int -> OCaml_IO Ptr) y_max
    arr <- ocamlCall "Array.map"
        (Ptr -> Ptr -> OCaml_IO Ptr) f ar
    ocamlCall "Graphics.fill_poly" (Ptr -> OCaml_IO ()) arr

loop : () -> OCaml_IO ()
loop _ = do
    ocamlCall "Graphics.wait_next_event" (List Int -> OCaml_IO Ptr)
        [0,1,2,3,4]
    loop ()

main : OCaml_IO  ()
main = do
    ocamlCall "Graphics.open_graph" (String -> OCaml_IO ()) ""
    ocamlCall "Graphics.auto_synchronize" (Bool -> OCaml_IO ()) False
    ocamlCall "Graphics.clear_graph" (() -> OCaml_IO ()) ()
    ocamlCall "Graphics.synchronize" (() -> OCaml_IO ()) ()

    y_max <- ocamlCall "Graphics.size_y" (() -> OCaml_IO Int) ()

    orange <- ocamlCall "Graphics.rgb" (Int -> Int -> Int -> OCaml_IO Int)
        198 141 62
    white <- ocamlCall "Graphics.white" (OCaml_IO Int)
    black <- ocamlCall "Graphics.black" (OCaml_IO Int)

    back_legs <- ocamlCall "Idrisobj.back_legs" (OCaml_IO Ptr)
    front_legs <- ocamlCall "Idrisobj.front_legs" (OCaml_IO Ptr)

    set_color orange
    fe y_max 185 90 250 147
    fe y_max 269 54 68 98
    fe y_max 143 138 127 94

    set_color white
    fe y_max 89 (-79) 195 227

    set_color orange
    fe y_max 134 93 62 122
    fe y_max 97 101 86 47
    fe y_max 354 63 68 118
    fe y_max 367 101 98 109
    fe y_max 247 176 68 94

    fp y_max back_legs
    fp y_max front_legs

    ocamlCall "Graphics.moveto" (Int -> Int -> OCaml_IO ()) 200 40
    set_color black

    ocamlCall "Graphics.draw_string" (String -> OCaml_IO ())
        "Bactrian the Double-Humped OCaml"

    ocamlCall "Graphics.synchronize" (() -> OCaml_IO ()) ()
    loop ()


import Data.So
import Data.List.Quantifiers
import Data.String.Views
import Data.List

allowedWords : List String
allowedWords = [ "foo", "bar", "baz" ]

data StrPrefix : StrList outer -> StrList inner -> Type where
  Empty : StrPrefix (SCons x xs) SNil
  Next : StrPrefix ys xs -> StrPrefix (SCons x ys) (SCons x xs)

prefixWorks : StrPrefix (strList "foo12312") (strList "foo")
prefixWorks = Next (Next (Next Empty))

anyDoesNot : Any ( \inner => StrPrefix (strList "bar1234") (strList inner) ) Main.allowedWords
--anyDoesNot = There (Here (Next (Next (Next Empty))))
anyDoesNot = There (Here (Next (Next (Next Empty))))

infixes : List String
infixes = filter (\x => isInfixOf x "bar1234") Main.allowedWords

numberInfixes : String -> Nat
numberInfixes word = length $ filter (\w => isInfixOf w word) Main.allowedWords

isGT : GT (length Main.infixes) Z
isGT = LTESucc LTEZero

print : (w:String) -> { auto prf : GT (numberInfixes w) Z } -> String
print w = w

x : String
x = print "bax1234"

anyRefl : Any ( \inner => (=) "bar" inner) Main.allowedWords
anyRefl = There (Here Refl)


module Language.Reflection.TT

import public Data.List

public export
FilePos : Type
FilePos = (Int, Int)

public export
data FC : Type where
     MkFC : String -> FilePos -> FilePos -> FC
     EmptyFC : FC

public export
emptyFC : FC
emptyFC = EmptyFC

public export
data NameType : Type where
     Bound   : NameType
     Func    : NameType
     DataCon : (tag : Int) -> (arity : Nat) -> NameType
     TyCon   : (tag : Int) -> (arity : Nat) -> NameType

public export
data Constant
    = I Int
    | BI Integer
    | B8 Int
    | B16 Int
    | B32 Int
    | B64 Integer
    | Str String
    | Ch Char
    | Db Double
    | WorldVal

    | IntType
    | IntegerType
    | Bits8Type
    | Bits16Type
    | Bits32Type
    | Bits64Type
    | StringType
    | CharType
    | DoubleType
    | WorldType

public export
data Namespace = MkNS (List String) -- namespace, stored in reverse order

export
showSep : String -> List String -> String
showSep sep [] = ""
showSep sep [x] = x
showSep sep (x :: xs) = x ++ sep ++ showSep sep xs

export
Show Namespace where
  show (MkNS ns) = showSep "." (reverse ns)

public export
data Name = UN String -- user defined name
          | MN String Int -- machine generated name
          | NS Namespace Name -- name in a namespace
          | DN String Name -- a name and how to display it

export
Show Name where
  show (NS ns n) = show ns ++ "." ++ show n
  show (UN x) = x
  show (MN x y) = "{" ++ x ++ ":" ++ show y ++ "}"
  show (DN str y) = str

public export
data Count = M0 | M1 | MW

public export
data PiInfo t = ImplicitArg | ExplicitArg | AutoImplicit | DefImplicit t

public export
data IsVar : Name -> Nat -> List Name -> Type where
     First : IsVar n Z (n :: ns)
     Later : IsVar n i ns -> IsVar n (S i) (m :: ns)

public export
data LazyReason = LInf | LLazy | LUnknown

export
data TT : Type where [external]

{-
-- Type checked terms in the core TT
public export
data TT : List Name -> Type where
     Local : FC -> (idx : Nat) -> (0 prf : IsVar name idx vars) -> TT vars
     Ref : FC -> NameType -> Name -> TT vars
     Pi : FC -> Count -> PiInfo (TT vars) ->
          (x : Name) -> (argTy : TT vars) -> (retTy : TT (x :: vars)) ->
          TT vars
     Lam : FC -> Count -> PiInfo (TT vars) ->
           (x : Name) -> (argTy : TT vars) -> (scope : TT (x :: vars)) ->
           TT vars
     App : FC -> TT vars -> TT vars -> TT vars
     TDelayed : FC -> LazyReason -> TT vars -> TT vars
     TDelay : FC -> LazyReason -> (ty : TT vars) -> (arg : TT vars) -> TT vars
     TForce : FC -> LazyReason -> TT vars -> TT vars
     PrimVal : FC -> Constant -> TT vars
     Erased : FC -> TT vars
     TType : FC -> TT vars
     -}

public export
data TotalReq = Total | CoveringOnly | PartialOK

public export
data Visibility = Private | Export | Public


module ZiriaCont

data FreerCont : (f : Type -> Type) -> Type -> Type where
  Cont : ({r : Type} -> (a -> r) -> ({x : Type} -> f x -> (x -> r) -> r) -> r) -> FreerCont f a

return : a -> FreerCont f a
return x = Cont (\k, _ => k x)

(>>=) : FreerCont f a -> (a -> FreerCont f b) -> FreerCont f b
(>>=) (Cont g) f = Cont (\k, imp => g (\x => let (Cont g') = f x in g' k imp) imp)

data Zir : (i : Type) -> (o : Type) -> (v : Type) -> Type where
  Yield : o -> Zir i o ()
  NeedInput : Zir i o i

emit : o -> FreerCont (Zir i o) ()
emit o = Cont (\k, imp => imp (Yield o) k)

take : FreerCont (Zir i o) i
take = Cont (\k, imp => imp NeedInput k)

data Rec : (x : Type) -> (r : Type) -> Type where
  K : ((x -> Rec x r -> r) -> r) -> Rec x r

gImp :  ({y : Type} -> Zir i o y -> (y -> r) -> r) -> Zir m o x -> (x -> Rec m r -> r) -> Rec m r -> r
gImp imp (Yield ot) k rec = imp (Yield ot) (\() => k () rec)
gImp imp NeedInput k (K k') = k' k

fImp :  ({y : Type} -> Zir i o y -> (y -> r) -> r) -> Zir i m x -> (x -> (m -> Rec m r -> r) -> r) -> (m -> Rec m r -> r) -> r
fImp imp (Yield ot) k k' = k' ot (K (k ()))
fImp imp NeedInput k k' = imp NeedInput (\i => k i k')

infixl 9 >>>
(>>>) : FreerCont (Zir i m) v -> FreerCont (Zir m o) v -> FreerCont (Zir i o) v
(>>>) (Cont f) (Cont g) = Cont (\k, imp => let g' = g (\x, _ => k x) (gImp imp) in
                                           let f' = f (\x, _ => k x) (fImp imp) in
                                           g' (K f'))

imp : Zir i o x -> (x -> Stream i -> (v, List o)) -> Stream i -> (v, List o)
imp (Yield x) k xs = let (v, xs') = k () xs in (v, x :: xs')
imp NeedInput k (x :: xs) = k x xs

run : FreerCont (Zir i o) v -> Stream i -> (v, List o)
run (Cont f) = f k imp
 where
   k : v -> Stream i -> (v, List o)
   k x _ = (x, [])

example : FreerCont (Zir Int Int) Int
example = do x <- take
             emit (x + 1)
             y <- take
             emit (y + 2)
             return (x + y)

test : (Int, List Int)
test = run example [1..]

stream1 : FreerCont (Zir Int Int) Int
stream1 = do emit 1
             emit 2
             return 41

stream2 : FreerCont (Zir Int Int) Int
stream2 = do x <- take
             y <- take
             emit (x + y)
             return 42

test' : (Int, List Int)
test' = run (stream1 >>> stream2) [1..]


||| This module contains an adaptation of the session description language as presented in:
|||
|||     <https://dblp.uni-trier.de/rec/html/journals/corr/abs-1904-01288>
|||
||| This implementation differs from the original in that recursive
||| calls and calling of subprograms are achieved using standard idris
||| constructs. To support his natively in resources, one will need to
||| introduce new primitives. As described in the `Resources` paper,
||| however, this requires that now means to reason about the
||| interaction between the type-level state of the caller and callee
||| programs. It would not be correct to assume anything about said
||| interaction with the framework in its current form.
|||
||| Furthermore, as described in the `Resources` paper, there is no
||| handler program to provide projection capabilities.
module Example.Sessions

import Data.List

import Resources

%access public export
%default total

{- [ Actors]

Here we define actors/roles in a session description, ensuring that we have a means to compare them.

-}
data Actor = MkActor String

Eq Actor where
 (==) (MkActor a) (MkActor b) = a == b

actorNotEqual : ((x = y) -> Void) -> (MkActor x = MkActor y) -> Void
actorNotEqual f Refl = f Refl

actorDecEq : (x,y : Actor) -> Dec (x = y)
actorDecEq (MkActor x) (MkActor y) with (decEq x y)
  actorDecEq (MkActor y) (MkActor y) | (Yes Refl) = Yes Refl
  actorDecEq (MkActor x) (MkActor y) | (No contra) = No (actorNotEqual contra)

DecEq Actor where
  decEq = actorDecEq

Ord Actor where
  compare (MkActor a) (MkActor b) = compare a b

-- Here we describe our type-level states.
namespace TypeLevel

  ||| Channels are born free until they are bound.
  data Usage = Free | Bound

  ||| Variables in Sessions are either paired actors, or data types.
  data Ty = CHAN (Actor, Actor) | DATA Type

  namespace State

    ||| A channel's state is it's usage.
    record ChanState where
      constructor MkChanState
      usage : Usage

    ||| A data types state is the type of message and who has seen the message.
    record DataState where
      constructor MkDataState
      knownBy : List Actor
      type    : Type

    ||| A mapping between variable types and their abstract state.
    CalcStateType : Ty -> Type
    CalcStateType (CHAN _) = ChanState
    CalcStateType (DATA _) = DataState

namespace Predicates

  ||| A predicate to state that all the listed actors are aware of the data item.
  |||
  ||| @actors The actors who know about the item.
  ||| @var    The item the actors know about.
  ||| @item   The abstract state associated with the item.
  data AllKnow : (actors : List Actor)
              -> (var   : Var Ty (DATA type))
              -> (item  : StateItem Ty CalcStateType (DATA type))
              -> Type
     where
       NilKnows : (prf : Elem x actors)
               -> AllKnow [x] msg (MkStateItem (DATA type) msg (MkDataState actors type))
       ConsKnows : (prf : Elem x actors)
                -> (later : AllKnow xs msg (MkStateItem (DATA type) msg (MkDataState actors type)))
                -> AllKnow (x::xs) msg (MkStateItem (DATA type) msg (MkDataState actors type))

  ||| A predicate to state that the given actor knows about the provided data item.
  |||
  ||| @actor The actor who knows about the item.
  ||| @var   The item the actors know about.
  ||| @item  The abstract state associated with the item.
  data KnowsData : (actor : Actor)
                -> (var   : Var Ty (DATA type))
                -> (item  : StateItem Ty CalcStateType (DATA type))
                -> Type
    where
      DoesKnow : (prf : x = y)
              -> (prfE : Elem x actors)
              -> KnowsData y var (MkStateItem (DATA type) var (MkDataState actors type))

  ||| A type-level function to record that a particular message has been used by an actor.
  ExpandWhoKnows : (newActor : Actor)
                -> (oldState : StateItem Ty CalcStateType (DATA type))
                -> (prfState : KnowsData sender label oldState)
                -> StateItem Ty CalcStateType (DATA type)
  ExpandWhoKnows newActor (MkStateItem (DATA type) label (MkDataState actors type)) (DoesKnow Refl prfE) =
    MkStateItem (DATA type) label (MkDataState (newActor::actors) type)

  ||| Proof that the given sender and receiver are valid participants in the protocol.
  data AllowedToConnect : (sender, receiver : Actor)
                       -> (actors : List Actor)
                       -> Type where
    CanConnect : (prfSender   : Elem sender   actors)
              -> (prfReceiver : Elem receiver actors)
              -> AllowedToConnect sender receiver actors

  ||| An assertion that the given channel has the given state.
  data ChannelHasState : (assumedState : Usage)
                      -> (chan         : Var Ty (CHAN (s,r)))
                      -> (actual       : StateItem Ty CalcStateType (CHAN (s,r)))
                      -> Type
    where
      YesChanHasState : ChannelHasState state chan (MkStateItem (CHAN (s,r)) chan (MkChanState state))

  ||| A type-level function to set a channel's state.
  SetChannelState : (newState : Usage)
                 -> (oldState : StateItem Ty CalcStateType (CHAN (s,r)))
                 -> (prfState : ChannelHasState oldState' var oldState)
                 -> StateItem Ty CalcStateType (CHAN (s,r))
  SetChannelState newState (MkStateItem (CHAN (s,r)) var (MkChanState oldState')) YesChanHasState = MkStateItem (CHAN (s,r)) var (MkChanState newState)

  ||| A predicate to describe valid end states for data and connections.
  data EndState : (ty : Ty) -> StateItem Ty CalcStateType ty -> Type where
    ||| We do not care.
    EndData : EndState (DATA type)  state
    ||| Connections must be free.
    EndConn : EndState (CHAN (s,r)) (MkStateItem (CHAN (s,r)) lbl (MkChanState Free))

||| Our algebraic definition of a Session description language.
data Sessions : (participants : List Actor) -> Lang Ty CalcStateType where

  ||| Describe that the given actor `a` creates a message of type `type`.
  |||
  ||| We also need proof that the actor is allowed to participate in the description.
  NewData : (a    : Actor)
         -> (type : Type)
         -> (prf  : Elem a ps)
         -> Sessions ps (Var Ty (DATA type)) old (\lbl => MkStateItem (DATA type) lbl (MkDataState [a] type) :: old)

  ||| Describe that the given actor `a` creates a message that depends on an earlier message that `a` has seen.
  |||
  ||| The resulting message type will be a dependent pair.
  NewDataDep : (a        : Actor)
            -> (dep      : Var Ty (DATA type))
            -> (prfKnows : InContext (DATA type) (KnowsData a dep) old)
            -> (msgType  : (msg : type) -> Type)
            -> Sessions ps (Var Ty (DATA (x ** msgType x)))
                            old
                            (\lbl => MkStateItem (DATA (x ** msgType x))
                                                 lbl
                                                 (MkDataState [a] (x ** msgType x)) :: old)

  ||| Specify a new connection between two valid participants in the session.
  NewConnection : (a,b : Actor)
               -> (prf : AllowedToConnect a b ps)
               -> Sessions ps (Var Ty (CHAN (a,b))) old (\lbl => MkStateItem (CHAN (a,b)) lbl (MkChanState Bound) :: old)

  ||| Close an existing connection.
  EndConnection : (chan : Var Ty (CHAN (a,b)))
               -> (prf  : InContext (CHAN (a,b)) (ChannelHasState Bound chan) old)
               -> Sessions ps () old (const $ update old prf (SetChannelState Free))

  ||| Send a message that the channel sender knows about (either created or received) to the receiver on the given active channel.
  SendLeft : (chan : Var Ty (CHAN (s,r)))
          -> (msg  : Var Ty (DATA type))
          -> (prfActive : InContext (CHAN (s,r))  (ChannelHasState Bound chan) old)
          -> (prfKnows  : InContext (DATA type) (KnowsData s msg) old)
          -> Sessions ps () old (const $ update old prfKnows (ExpandWhoKnows r))

  ||| Send a message that the receiver on the channel knows about (either created or received) to the sending end on the given active channel.
  SendRight : (chan : Var Ty (CHAN (s,r)))
           -> (msg  : Var Ty (DATA type))
           -> (prfActive : InContext (CHAN (s,r))  (ChannelHasState Bound chan) old)
           -> (prfKnows  : InContext (DATA type) (KnowsData r msg) old)
           -> Sessions ps () old (const $ update old prfKnows (ExpandWhoKnows s))

  ||| If all actors in the session have seen the data then we can access the message's value and depend on it.
  ReadMsg : (msg : Var Ty (DATA type))
         -> (prf : InContext (DATA type) (AllKnow ps msg) old)
         -> Sessions ps type old (const old)

  ||| End the session description if all the variables are in the correct end state.
  |||
  ||| This is our check that all channels have been closed.
  StopSession : AllContext EndState old -> Sessions ps () old (const Nil)

{- [ NOTE ]

Here we define the language and high-level friendly API.

-}
||| Define the `SESSIONS` language.
SESSIONS : (ps : List Actor) -> LANG Ty CalcStateType
SESSIONS ps = MkLang Ty CalcStateType (Sessions ps)

||| Define a closed session.
Session : (m : Type -> Type) -> List Actor -> Type
Session m ps = LangM m () (SESSIONS ps) Nil (const Nil)

||| Describe that the given actor `a` creates a message of type `type`.
|||
||| We also need proof that the actor is allowed to participate in the description.
msg : (creator : Actor)
   -> (type : Type)
   -> {auto prf : Elem creator actors}
   -> LangM m (Var Ty (DATA type)) (SESSIONS actors) old (\lbl => MkStateItem (DATA type) lbl (MkDataState ([creator]) type) :: old)
msg creator type {prf} = Expr $ NewData creator type prf

||| Describe that the given actor `a` creates a message that depends on an earlier message that `a` has seen.
|||
||| The resulting message type will be a dependent pair.
msgDep : (creator  : Actor)
      -> (dep      : Var Ty (DATA type))
      -> {auto prfKnows : InContext (DATA type) (KnowsData creator dep) old}
      -> (msgType  : (msg : type) -> Type)
      -> LangM m
               (Var Ty (DATA (x ** msgType x)))
               (SESSIONS actors)
               old
               (\lbl => MkStateItem (DATA (x ** msgType x))
                                    lbl
                                    (MkDataState [creator] (x ** msgType x)) :: old)
msgDep creator dep {prfKnows} msgType = Expr (NewDataDep creator dep prfKnows msgType)

||| If all actors in the session have seen the data then we can access the message's value and depend on it.
read : (msg : Var Ty (DATA type))
    -> {auto prf : InContext (DATA type) (AllKnow actors msg) old}
    -> LangM m type (SESSIONS actors) old (const old)
read msg {prf} = Expr $ ReadMsg msg prf

||| End the session description if all the variables are in the correct end state.
|||
||| This is our check that all channels have been closed.
end : {auto prf : AllContext EndState old} -> LangM m () (SESSIONS actors) old (const Nil)
end {prf} = Expr $ StopSession prf

||| Specify a new connection between two valid participants in the session.
setup : (a, b : Actor)
     -> {auto prf : AllowedToConnect a b actors}
     -> LangM m (Var Ty (CHAN (a,b))) (SESSIONS actors) old (\lbl => MkStateItem (CHAN (a,b)) lbl (MkChanState Bound) :: old)
setup sender receiver {prf} = Expr $ NewConnection sender receiver prf

||| Close an existing connection.
destroy : (chan : Var Ty (CHAN (a,b)))
       -> {auto prf  : InContext (CHAN (a,b)) (ChannelHasState Bound chan) old}
       -> LangM m () (SESSIONS actors) old (const $ update old prf (SetChannelState Free))
destroy chan {prf} = Expr $ EndConnection chan prf

||| Send a message that the channel sender knows about (either created or received) to the receiver on the given active channel.
sendLeft : (chan : Var Ty (CHAN (s,r)))
        -> (msg  : Var Ty (DATA type))
        -> {auto prfActive : InContext (CHAN (s,r))  (ChannelHasState Bound chan) old}
        -> {auto prfKnows  : InContext (DATA type) (KnowsData s msg) old}
        -> LangM m () (SESSIONS actors) old (const $ update old prfKnows (ExpandWhoKnows r))
sendLeft chan msg {prfActive} {prfKnows} = Expr (SendLeft chan msg prfActive prfKnows)

||| Send a message that the receiver on the channel knows about (either created or received) to the sending end on the given active channel.
sendRight : (chan : Var Ty (CHAN (s,r)))
         -> (msg  : Var Ty (DATA type))
         -> {auto prfActive : InContext (CHAN (s,r))  (ChannelHasState Bound chan) old}
         -> {auto prfKnows  : InContext (DATA type) (KnowsData r msg) old}
         -> LangM m () (SESSIONS actors) old (const $ update old prfKnows (ExpandWhoKnows s))
sendRight chan msg {prfActive} {prfKnows} = Expr (SendRight chan msg prfActive prfKnows)

{- [ NOTE ]

Let's define some actors.

-}

Alice : Actor
Alice = MkActor "A"

Bob : Actor
Bob = MkActor "B"

Charlie : Actor
Charlie = MkActor "C"

{- [ NOTE ]

Here we define a value dependent version of the well known TCP Handshake.

Dependent pairs are used to ensure that the sequence numbers sent are the ones previously seen.

There are better ways to encode this, see the PLACES paper linked in the module's documentation.

-}

data Packet

TCPHandshake : Session m [Alice, Bob]
TCPHandshake = do
  chan <- setup Alice Bob

  m1 <- msg Alice (Packet, Nat)
  sendLeft chan m1

  (p,x) <- read m1
  m2 <- msg Bob (Packet, (x' ** x' = x), Nat)

  sendRight chan m2

  (p,xplus,y) <- read m2

  m3 <- msg Alice (Packet, (x' ** x' = x), (y' ** y' = y))
  sendLeft chan m3
  destroy chan
  end

{- [ NOTE ]

Here we define a PingPong protocol. In which Alice sends a Ping to Bob who responds with a Pong, and proof that they send a pong, and calls the session description again. If alice sent a Pong then the session ends.

This is *a* encoding, there are probably better ways to encode this.

-}
data PingPong = Ping | Pong

pingNotPong : (Ping = Pong) -> Void
pingNotPong Refl impossible

DecEq PingPong where
  decEq Ping Ping = Yes Refl
  decEq Pong Pong = Yes Refl
  decEq Ping Pong = No pingNotPong
  decEq Pong Ping = No (negEqSym pingNotPong)

RfcPingPong : Session m [Alice, Bob]
RfcPingPong = do chan <- setup Alice Bob
                 val <- msg Alice PingPong
                 sendLeft chan val
                 res <- read val
                 case res of
                   Pong => do destroy chan
                              end
                   Ping => do val' <- msg Bob (x : PingPong ** x = Pong)
                              sendRight chan val'
                              destroy chan
                              end
                              assert_total $ RfcPingPong

{- [ NOTE ]

Here we define a simple varient of the Echo protocol that uses an optional type to act as a quit message in the Empty case.

-}
Echo : Session m [Alice, Bob]
Echo {m} = do chan <- setup Alice Bob
              val <- msg Alice (Maybe String)
              sendLeft chan val
              res <- read val
              case res of
                Nothing => do destroy chan
                              end
                Just _  => do sendRight chan val
                              destroy chan
                              end
                              assert_total $ Echo {m=m}

{- [ NOTE ]

Here we define a simple Higher-Order-Protocol that emulates an authentication step using a Boolean.

-}

hoppy : Session m [Alice, Bob]
     -> Session m [Alice, Bob]
hoppy p = do chan <- setup Alice Bob
             val <- msg Alice String
             sendLeft chan val
             resp <- msg Bob Bool
             sendRight chan resp
             res <- read resp
             case res of
               False => do destroy chan
                           end
               True => do destroy chan
                          end
                          p

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