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 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 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


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 ]


module Circuits.NetList.Linear.Interp

import Decidable.Equality

import Data.Nat
import Data.Fin
import Data.List.Elem
import Data.List.Quantifiers

import Toolkit.Decidable.Informative

import Toolkit.Data.Graph.EdgeBounded
import Toolkit.Data.Graph.EdgeBounded.HasExactDegree.All

import Toolkit.Data.Whole
import Toolkit.Data.List.DeBruijn

import Circuits.NetList.Types

import Circuits.NetList.Linear.Usage
import Circuits.NetList.Linear.Terms

%default total

public export
InterpTy : Ty -> Type
InterpTy TyUnit
  = Unit

InterpTy (TyPort x)
  = Vertex String

InterpTy (TyChan x)
  = Pair (Vertex String) (Vertex String)

InterpTy TyGate
  = Graph String

select : Project dir -> Vertex a -> Vertex a -> Vertex a
select WRITE y z = y
select READ y z = z

namespace Environments

  public export
  data Env : List Item -> Type where
    Empty  : Env Nil
    Extend : (term : InterpTy type)
          -> (env  : Env rest)
                  -> Env (I type usage :: rest)

  namespace Port

    export
    lookup : (env : Env this)
          -> (prf : IsFreePort (I (TyPort (flow,type)) u) this)
          -> (use : UsePort this prf that)
                 -> (Env that, InterpTy (TyPort (flow,type)))
    lookup (Extend term rest) (FreePortHere pf) (UsePortHere use)
      = (Extend term rest, term)

    lookup (Extend not_term env) (FreePortThere rest) (UsePortThere later) with (lookup env rest later)
      lookup (Extend not_term env) (FreePortThere rest) (UsePortThere later) | (new, term)
        = (Extend not_term new, term)

  namespace Project

    export
    lookup : (env : Env this)
          -> (prf : IsFreeChannel how (I (TyChan type) (TyChan ein eout)) this)
          -> (use : ProjectChannel how this prf that)
                 -> (Env that, InterpTy (TyChan type))
    lookup (Extend term env) (FreeChannelHere prf) (ProjectHere use)
      = (Extend term env, term)

    lookup (Extend not_term env) (FreeChannelThere rest) (ProjectThere later) with (lookup env rest later)
      lookup (Extend not_term env) (FreeChannelThere rest) (ProjectThere later) | (new, term)
        = (Extend not_term new, term)

  namespace Index

   export
   lookup : (env : Env this)
         -> (prf : CanIndexPort idx (I (TyPort (flow, BVECT (W (S n) ItIsSucc) type)) u) this)
         -> (use : IndexPort idx this prf that)
                -> (Env that, InterpTy (TyPort (flow, type)))
   lookup (Extend term env) (CanIndexHere prf) (IndexHere use)
     = (Extend term env, term)

   lookup (Extend not_term env) (CanIndexThere rest) (IndexThere later) with (lookup env rest later)
     lookup (Extend not_term env) (CanIndexThere rest) (IndexThere later) | (new, term)
       = (Extend not_term new, term)

namespace Result

  public export
  data Result : (context : List Item)
             -> (type    : Ty)
                        -> Type
   where
     R : (counter : Nat)
      -> (env     : Env      new)
      -> (graph   : Graph String)
      -> (result  : InterpTy     type)
                 -> Result   new type

  public export
  getResult : Result ctxt type -> InterpTy type
  getResult (R counter env g result) = result

  public export
  data GetGraph : (res : Result.Result ctxt type) -> Graph String -> Type
    where
      G : (g : Graph String) -> GetGraph (R c e g r) g

  public export
  getGraph : (r : Result.Result ctxt type) -> DPair (Graph String) (GetGraph r)
  getGraph (R counter env graph result) = MkDPair graph (G graph)

interp : (env     : Env this)
      -> (counter : Nat)
      -> (graph   : Graph String)
      -> (term    : Term this type that)
                 -> Result that type

-- [ NOTE ]
--
-- As normal
interp e c g (VarPort prf use)

  = let (new, ret) = lookup e prf use
    in R c new g ret

-- [ NOTE ]
--
-- Ports are leaf nodes in the graph.
interp e c g (Port flow dtype (FP u prf) body)
    = let    c1 = S c
      in let v  = vertexFromFlow flow c1 (size dtype)

      in let R e1 c2 g1 MkUnit = interp (Extend v e)
                                        c1
                                        (insertNode v g)
                                        body
      in R e1 c2 g1 MkUnit

  where
    vertexFromFlow : Direction -> Nat -> Nat -> Vertex String
    vertexFromFlow INPUT  = driver  ("INPUT : "  <+> show dtype )
    vertexFromFlow OUTPUT = catcher ("OUTPUT : " <+> show dtype )
    vertexFromFlow INOUT  = gateway ("INOUT : "  <+> show dtype )

interp e c g (Wire dtype (FC u prf) body)
  = let    c1 = S c
    in let c2 = S c1

    in let s = size dtype

    in let chanIN  = node ("CHAN_IN : "  <+> show dtype) c1 s 1
    in let chanOUT = node ("CHAN_OUT : " <+> show dtype) c2 1 s

    in let R e1 c3 g2 MkUnit = interp (Extend (chanIN, chanOUT) e)
                                      c2
                                      (updateWith g [chanIN, chanOUT]
                                                    [MkPair (ident chanIN) (ident chanOUT)])
                                       body
    in R e1 c3 g2 MkUnit

interp e c g (Gate gate body)
  = let R c1 e1 g1 res = interp e c g gate
    in interp (Extend res e1) c1 (merge g res) body

interp e c g (Stop prf)
  = R c Empty g MkUnit

interp e c g (Mux o s l r)

  = let c1 = S c

    in let mux = node "MUX" c1 3 1

    in let R c2 e1 g1 vo = interp e  c1 g  o
    in let R c3 e2 g2 vc = interp e1 c2 g1 s
    in let R c4 e3 g3 vl = interp e2 c2 g2 l
    in let R c5 e4 g4 vr = interp e3 c3 g3 r

    in let mg = fromLists [mux]
                          [ (ident vl,  ident mux)
                          , (ident vr,  ident mux)
                          , (ident vc,  ident mux)
                          , (ident mux, ident vo)
                          ]
    in R c5 e4 g4 mg

interp e c g (GateU kind o i)
    = let c1 = S c

      in let ugate = node (show kind) c1 1 1

      in let R c2 e1 g1 vo = interp e  c1 g  o
      in let R c3 e2 g2 vi = interp e1 c2 g1 i

      in R c3 e2 g2
              (fromLists [ugate] [ MkPair (ident vi)    (ident ugate)
                                 , MkPair (ident ugate) (ident vo)
                                 ])

interp e c g (GateB kind o l r)

   = let c1 = S c

    in let bgate = node (show kind) c1 2 1

    in let R c2 e1 g1 vo = interp e  c1 g  o
    in let R c3 e2 g2 vl = interp e1 c2 g1 l
    in let R c4 e3 g3 vr = interp e2 c3 g2 r

    in let bg = fromLists [bgate]
                          [ MkPair (ident bgate) (ident vo)
                          , MkPair (ident vl) (ident bgate)
                          , MkPair (ident vr) (ident bgate)
                          ]

    in R c4 e3 g3 bg

interp e c g (Split a b i)

  = let c1 = S c
    in let s = size LOGIC

    in let sVertex = both "SPLIT" c1 s

    in let R c2 e1 g1 av = interp e  c1 g  a
    in let R c3 e2 g2 bv = interp e1 c2 g1 b
    in let R c4 e3 g3 iv = interp e2 c3 g2 i

    in let esIS = replicate s (MkPair (ident iv)      (ident sVertex))
    in let esSA = replicate s (MkPair (ident sVertex) (ident av))
    in let esSB = replicate s (MkPair (ident sVertex) (ident bv))

    in R c4 e3
            g3
            (fromLists [av,bv,iv,sVertex]
                       (esIS ++ esSA ++ esSB))

interp e c g (Collect {type} o a b)

  = let c1 = S c
    in let s = size type

    in let sVertex = both "COLLECT" c1 s

    in let R c2 e1 g1 ov = interp e  c1 g  o
    in let R c3 e2 g2 av = interp e1 c2 g1 a
    in let R c4 e3 g3 bv = interp e2 c3 g2 b

    in let esAC = replicate s (MkPair (ident av) (ident sVertex))
    in let esBC = replicate s (MkPair (ident bv) (ident sVertex))
    in let esSO = replicate s (MkPair (ident sVertex) (ident ov))

    in R c4 e3
            g3
            (fromLists [ov,av,bv,sVertex]
                       (esAC ++ esBC ++ esSO))

interp e c g (Cast cast port)
    = let c1 = S c

      in let cVertex = both "CAST" c1 1

      in let R c2 e1 g1 what = interp e c1 g port

      in R c2 e1
              (updateWith g1 [cVertex] [buildEdge cast cVertex what])
              cVertex

  where buildEdge : Cast INOUT r -> (a,b : Vertex String) -> Edge
        buildEdge BI a b = MkPair (ident b) (ident a)
        buildEdge BO a b = MkPair (ident a) (ident b)

interp e c g (Project how prf use)

    = let (new, (i,o)) = lookup e prf use

      in R c new g (selectNode how i o)

  where selectNode : Project dir -> Vertex String -> Vertex String -> Vertex String
        selectNode WRITE i _ = i
        selectNode READ  _ o = o

interp e c g (Index dir idx prf use)
    = let c1 = S c

      in let idxVertex = both ("IDX [" <+> show (finToNat idx) <+> "](" <+>  show dir <+>")" ) c1 1

      in let (new,p) = lookup e prf use

      in R c1 new (updateWith g [idxVertex]
                               (buildEdge dir p idxVertex))
              idxVertex
  where buildEdge : Index direc -> (a,b : Vertex String) -> Edges
        buildEdge (UP x)   a b = [MkPair (ident b) (ident a)]
        buildEdge (DOWN x) a b = [MkPair (ident a) (ident b)]

public export
data ValidGraph : Graph type -> Type where
  IsValid : HasExactDegrees vs es
         -> ValidGraph (MkGraph vs es)

export
validGraph : {type : Type}
          -> (g    : Graph type)
                  -> DecInfo (HasExactDegree.Error type)
                             (ValidGraph g)
validGraph (MkGraph nodes edges) with (hasExactDegrees nodes edges)
  validGraph (MkGraph nodes edges) | (Yes prf)
    = Yes (IsValid prf)
  validGraph (MkGraph nodes edges) | (No msg contra)
    = No msg (\(IsValid prf) => contra prf)

public export
data Valid : (res  : Result ctxt TyUnit)
                  -> Type
  where
    D : {res : Result ctxt TyUnit}
     -> (g   : Graph String)
            -> GetGraph res g
            -> ValidGraph g
            -> Valid res

isValid : (r : Result ctxt TyUnit)
            -> DecInfo (Graph String, HasExactDegree.Error String)
                       (Valid r)
isValid r with (getGraph r)
  isValid (R c e g r) | (MkDPair g (G g)) with (validGraph g)
    isValid (R c e g r) | (MkDPair g (G g)) | (Yes prf)
      = Yes (D g (G g) prf)
    isValid (R c e g r) | (MkDPair g (G g)) | (No msg contra)
      = No (g,msg) (\(D graph (G graph) prf) => contra prf)

public export
data Run : (term : Term Nil TyUnit Nil) -> Type where
  R : (prf  : Valid (interp Empty Z (MkGraph Nil Nil) term))
           -> Run term

public export
getGraph : Run term -> DPair (Graph String) ValidGraph
getGraph (R (D g x y)) = MkDPair g y

export
run : (term : Term Nil TyUnit Nil)
           -> DecInfo (Graph String, HasExactDegree.Error String) (Run term)
run term with (isValid (interp Empty Z empty term))
  run term | (Yes prf) = Yes (R prf)
  run term | (No msg contra) = No msg (\(R prf) => contra prf)

export
runIO : (term : Term Nil TyUnit Nil)
             -> IO (Either (Graph String, HasExactDegree.Error String)
                           (Run term))
runIO term = pure $ (asEither (run term))

-- [ EOF ]


module Core.Abstraction

import General
import Core.Variable
import Core.Term
import Core.ConSig

%access export

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

implementation Abstract a b c => Abstract a b (Plict,c) where
	abstr (plic,x) = MkPair plic <$> abstr x

implementation (Abstract a b Pattern, Abstract a b Term) => Abstract a b Clause where
	abstr (NewClause psc sc) = NewClause <$> abstractScope psc <*> abstractScope sc

implementation Abstract a b Term => Abstract a b CaseMotive where
	abstr (CaseMotiveNil a) = CaseMotiveNil <$> abstr a
	abstr (CaseMotiveCons a sc) = CaseMotiveCons <$> abstr a <*> abstractScope sc

implementation Abstract a b Term => Abstract a b Telescope where
	abstr TelescopeNil = pure TelescopeNil
	abstr (TelescopeCons t sc) = TelescopeCons <$> abstr t <*> abstractScope sc

mutual
	implementation Abstract String Term Term where
		abstr (Meta i) = pure $ Meta i
		abstr (Var (Name x)) = asks $ \e => case SortedMap.lookup x e of
			Nothing => Var (Name x)
			Just m  => m
		abstr (Var (Generated x i)) = pure $ Var (Generated x i)
		abstr (DottedVar m var) = pure $ DottedVar m var
		abstr (AbsoluteDottedVar m var) = pure $ AbsoluteDottedVar m var
		abstr (Ann m ty) = Ann <$> abstr m <*> pure ty
		abstr Star = pure Star
		abstr (Pi plic a sc) = Pi plic <$> abstr a <*> abstractScope sc
		abstr (Lam plic sc) = Lam plic <$> abstractScope sc
		abstr (App plic f a) = App plic <$> abstr f <*> abstr a
		abstr (Con c as) = Con c <$> Traversable.for as (\(plic, a) => do a' <- abstr a ; pure (plic,a'))
		abstr (Case as t cs) = Case <$> traverse abstr as <*> abstr t <*> traverse abstr cs
		abstr (RecordType tele) = RecordType <$> abstr tele
		abstr (RecordCon fields) = RecordCon <$> (sequence [ MkPair x <$> abstr m | (x,m) <- fields ])
		abstr (Project m x) = Project <$> abstr m <*> pure x

	implementation Abstract String Term Pattern where
		abstr (VarPat x) = pure $ VarPat x
		abstr (ConPat c ps) = ConPat c <$> traverse abstr ps
		abstr (AssertionPat m) = AssertionPat <$> abstr m
		abstr MakeMeta = pure MakeMeta

mutual
	implementation Abstract Int Term Term where
		abstr (Meta i) = pure $ Meta i
		abstr (Var (Name x)) = pure $ Var (Name x)
		abstr (Var (Generated x i)) = asks $ \e => case SortedMap.lookup i e of
			Nothing => Var (Generated x i)
			Just m  => m
		abstr (DottedVar m var) = pure $ DottedVar m var
		abstr (AbsoluteDottedVar m var) = pure $ AbsoluteDottedVar m var
		abstr (Ann m ty) = Ann <$> abstr m <*> pure ty
		abstr Star = pure Star
		abstr (Pi plic a sc) = Pi plic <$> abstr a <*> abstractScope sc
		abstr (Lam plic sc) = Lam plic <$> abstractScope sc
		abstr (App plic f a) = App plic <$> abstr f <*> abstr a
		abstr (Con c as) = Con c <$> Traversable.for as (\(plic,a) => do a' <- abstr a ; pure (plic,a'))
		abstr (Case as t cs) = Case <$> traverse abstr as <*> abstr t <*> traverse abstr cs
		abstr (RecordType tele) = RecordType <$> abstr tele
		abstr (RecordCon fields) = RecordCon <$> (sequence [ MkPair x <$> abstr m | (x,m) <- fields ])
		abstr (Project m x) = Project <$> abstr m <*> pure x

	implementation Abstract Int Term Pattern where
		abstr (VarPat x) = pure $ VarPat x
		abstr (ConPat c ps) = ConPat c <$> traverse abstr ps
		abstr (AssertionPat m) = AssertionPat <$> abstr m
		abstr MakeMeta = pure MakeMeta

mutual
	implementation Abstract String Variable Term where
		abstr (Meta i) = pure $ Meta i
		abstr (Var (Name x)) = asks $ \e => case SortedMap.lookup x e of
			Nothing => Var (Name x)
			Just y  => Var y
		abstr (Var (Generated x i)) = pure $ Var (Generated x i)
		abstr (DottedVar m var) = pure $ DottedVar m var
		abstr (AbsoluteDottedVar m var) = pure $ AbsoluteDottedVar m var
		abstr (Ann m ty) = Ann <$> abstr m <*> pure ty
		abstr Star = pure Star
		abstr (Pi plic a sc) = Pi plic <$> abstr a <*> abstractScope sc
		abstr (Lam plic sc) = Lam plic <$> abstractScope sc
		abstr (App plic f a) = App plic <$> abstr f <*> abstr a
		abstr (Con c as) = Con c <$> Traversable.for as (\(plic,a) => do a' <- abstr a ; pure (plic,a'))
		abstr (Case as t cs) = Case <$> traverse abstr as <*> abstr t <*> traverse abstr cs
		abstr (RecordType tele) = RecordType <$> abstr tele
		abstr (RecordCon fields) = RecordCon <$> (sequence [ MkPair x <$> abstr m | (x,m) <- fields ])
		abstr (Project m x) = Project <$> abstr m <*> pure x

	implementation Abstract String Variable Pattern where
		abstr (VarPat (Name x)) = asks $ \e => case SortedMap.lookup x e of
			Nothing => VarPat (Name x)
			Just y  => VarPat y
		abstr (VarPat (Generated x i)) = pure $ VarPat (Generated x i)
		abstr (ConPat c ps) = ConPat c <$> traverse abstr ps
		abstr (AssertionPat m) = AssertionPat <$> abstr m
		abstr MakeMeta = pure MakeMeta

mutual
	implementation Abstract Int Variable Term where
		abstr (Meta i) = pure $ Meta i
		abstr (Var (Name x)) = pure $ Var (Name x)
		abstr (Var (Generated x i)) = asks $ \e => case SortedMap.lookup i e of
			Nothing => Var (Generated x i)
			Just y  => Var y
		abstr (DottedVar m var) = pure $ DottedVar m var
		abstr (AbsoluteDottedVar m var) = pure $ AbsoluteDottedVar m var
		abstr (Ann m ty) = Ann <$> abstr m <*> pure ty
		abstr Star = pure Star
		abstr (Pi plic a sc) = Pi plic <$> abstr a <*> abstractScope sc
		abstr (Lam plic sc) = Lam plic <$> abstractScope sc
		abstr (App plic f a) = App plic <$> abstr f <*> abstr a
		abstr (Con c as) = Con c <$> Traversable.for as (\(plic,a) => do a' <- abstr a ; pure (plic,a'))
		abstr (Case as t cs) = Case <$> traverse abstr as <*> abstr t <*> traverse abstr cs
		abstr (RecordType tele) = RecordType <$> abstr tele
		abstr (RecordCon fields) = RecordCon <$> (sequence [ MkPair x <$> abstr m | (x,m) <- fields ])
		abstr (Project m x) = Project <$> abstr m <*> pure x

	implementation Abstract Int Variable Pattern where
		abstr (VarPat (Name x)) = pure $ VarPat (Name x)
		abstr (VarPat (Generated x i)) = asks $ \e => case SortedMap.lookup i e of
			Nothing => VarPat (Generated x i)
			Just y  => VarPat y
		abstr (ConPat c ps) = ConPat c <$> traverse abstr ps
		abstr (AssertionPat m) = AssertionPat <$> abstr m
		abstr MakeMeta = pure MakeMeta

-- 0   0 8YYYY 0    8YYYo 8YYYY 8YYYo oYYYo
-- 8___8 8___  0    8___P 8___  8___P %___
-- 8"""8 8"""  0    8"""  8"""  8""Yo `"""p
-- 0   0 8oooo 8ooo 0     8oooo 0   0 YoooY

piHelper : Plict -> String -> Term -> Term -> Term
piHelper plic x a b = Pi plic a (scope [x] b)

lamHelper : Plict -> String -> Term -> Term
lamHelper plic x b = Lam plic (scope [x] b)

clauseHelper : List Pattern -> List String -> Term -> Clause
clauseHelper ps xs b = do
	let cleanedXs = fst $ runState (traverse cleanXs xs) 0
	let cleanedPs = fst $ runState (traverse cleanPs ps) 0
	NewClause (scope2 xs cleanedXs cleanedPs) (scope (filter isVar xs) b)
where
	cleanXs : String -> State Integer String
	cleanXs "_" = do
		i <- get
		put (i + 1)
		pure $ "$" ++ show i
	cleanXs x = pure x

	cleanPs : Pattern -> State Integer Pattern
	cleanPs (VarPat (Name "_")) = do
		i <- get
		put (i + 1)
		pure $ VarPat (Name ("$" ++ show i))
	cleanPs (VarPat (Name n)) = pure $ VarPat (Name n)
	cleanPs (VarPat (Generated n i)) = pure $ VarPat (Generated n i)
	cleanPs (ConPat c ps') = ConPat c <$> traverse (\(plic,p) => do { p' <- cleanPs p ; pure (plic,p') }) ps'
	cleanPs (AssertionPat m) = pure $ AssertionPat m
	cleanPs MakeMeta = pure MakeMeta

consMotiveHelper : String -> Term -> CaseMotive -> CaseMotive
consMotiveHelper x a b = CaseMotiveCons a (scope [x] b)

telescopeHelper : List (String, Term) -> Telescope
telescopeHelper [] = TelescopeNil
telescopeHelper ((x,t)::xts) = let tele = telescopeHelper xts in TelescopeCons t (scope [x] tele)

implementation Abstract a Term Term => Abstract a Term (ConSig Term) where
	abstr (ConSigNil a) = ConSigNil <$> abstr a
	abstr (ConSigCons plic a sc) = ConSigCons plic <$> abstr a <*> abstractScope sc

conSigHelper : List DeclArg -> Term -> ConSig Term
conSigHelper [] b = ConSigNil b
conSigHelper (NewDeclArg plic x a :: as) b = ConSigCons plic a (scope [x] (conSigHelper as b))


module FoldFusion

Array : Type -> Type
Var : Type -> Type -> Type

interface Symantics (rep : Type -> Type) where
  int : Int -> rep Int
  bool : Bool -> rep Bool
  (==) : rep Int -> rep Int -> rep Bool
  (>) : rep Int -> rep Int -> rep Bool
  (<) : rep Int -> rep Int -> rep Bool
  (&&) : rep Bool -> rep Bool -> rep Bool
  (||) : rep Bool -> rep Bool -> rep Bool
  (+) : rep Int -> rep Int -> rep Int
  (*) : rep Int -> rep Int -> rep Int
  ite : rep Bool -> rep a -> rep a -> rep a
  deref : rep (Var s a) -> rep a
  assign : rep a -> rep (Var s a) -> rep ()
  newVar : rep a -> ({s : Type} -> rep (Var s a) -> rep b) -> rep b
  foreach : rep (Array a) -> (rep a -> rep ()) -> rep ()
  seq : rep a -> rep b -> rep b
  lam : (rep a -> rep b) -> rep (a -> b)
  app : rep (a -> b) -> rep a -> rep b

data Code : Type -> Type where
  C : (Int -> String) -> Code a

Symantics Code where
  int x = C (\_ => show x)
  bool x = C (\_ => if x then "true" else "false")
  (==) (C l) (C r) = C (\v => "( " ++ l v ++ " = " ++ r v ++ " )")
  (>) (C l) (C r) = C (\v => "( " ++ l v ++ " > " ++ r v ++ " )")
  (<) (C l) (C r) = C (\v => "( " ++ l v ++ " < " ++ r v ++ " )")
  (&&) (C l) (C r) = C (\v => "( " ++ l v ++ " && " ++ r v ++ " )")
  (||) (C l) (C r) = C (\v => "( " ++ l v ++ " || " ++ r v ++ " )")
  (+) (C l) (C r) = C (\v => "( " ++ l v ++ " + " ++ r v ++ " )")
  (*) (C l) (C r) = C (\v => "( " ++ l v ++ " * " ++ r v ++ " )")
  ite (C b) (C l) (C r) = C (\v => "(if " ++ b v ++ " then " ++ l v ++ " else " ++ r v ++ ")")
  deref (C x) = C (\v => "!" ++ x v)
  assign (C val) (C var) = C (\v => var v ++ " := " ++ val v)
  newVar {a} (C s) f = C (\v => let x = "x" ++ show v in
                                let (C c) = f $ the (Code (Var () a)) (C (\_ => x)) in
                                "let " ++ x ++ " = ref " ++ s v ++ " in " ++ c (v + 1))
  foreach (C arr) f = C (\v =>  let x = "x" ++ show v in
                                let (C c) = f (C (\_ => x)) in
                                "(for " ++ x ++ " in " ++ arr v ++ " do " ++ c (v + 1) ++ ")")
  seq (C fs) (C sn) = C (\v => "(" ++ fs v ++ "; " ++ sn v ++ ")")
  lam f = C (\v => let x = "x" ++ show v in
                   let (C g) = f (C (\_ => x)) in
                   "(fun " ++ x ++ " -> " ++ g (v + 1) ++ ")" )
  app (C f) (C g) = C (\v => "(" ++ f v ++ " " ++ g v ++ ")" )

data Fold : (rep : Type -> Type) -> (a : Type) -> Type where
  FC : ({r : Type} -> (rep a -> rep r -> rep r) -> rep r -> rep r) -> Fold rep a

ofArray : Symantics rep => rep (Array a) -> Fold rep a
ofArray arr = FC (\f, seed => newVar seed (\v => seq (foreach arr (\x => assign (f x (deref v)) v)) (deref v)))

fold : (rep a -> rep r -> rep r) -> rep r -> Fold rep a -> rep r
fold f seed (FC g) = g f seed

map : (rep a -> rep b) -> Fold rep a -> Fold rep b
map f (FC g) = FC (\h => g (\x, r => h (f x) r))

flatMap : (rep a -> Fold rep b) -> Fold rep a -> Fold rep b
flatMap f (FC g) = FC (\h => g (\x, r => fold h r (f x)))

filter : Symantics rep => (rep a -> rep Bool) -> Fold rep a -> Fold rep a
filter f (FC g) = FC (\h => g (\x, r =>  ite (f x) (h x r) r))

count : Symantics rep => Fold rep a -> rep Int
count = fold (\x, acc => acc + (int 1)) (int 0)

sum : Symantics rep => Fold rep Int -> rep Int
sum = fold (\x, acc => x + acc) (int 0)

example : Symantics rep => rep (Array Int) -> rep Int
example = sum . map (\x => x * (int 2)) . filter (\x => x < (int 5)) . ofArray

test : Code (Array Int -> Int)
test = lam example

code : String
code = let (C c) = test in c 0


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

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

import Decidable.Equality

-- Definition

public export
data ExternType : Type where
  Func   : FuncType    -> ExternType
  Table  : TableType   -> ExternType
  Mem    : MemType     -> ExternType
  Global : GlobalType  -> ExternType

-- Equality

total public export
lemma_externtype__func_injective : ((x = y) -> Void) -> (Func x = Func y) -> Void
lemma_externtype__func_injective func_types_neq Refl = func_types_neq Refl

total public export
lemma_externtype__table_injective : ((x = y) -> Void) -> (Table x = Table y) -> Void
lemma_externtype__table_injective table_tables_neq Refl = table_tables_neq Refl

total public export
lemma_externtype__mem_injective : ((x = y) -> Void) -> (Mem x = Mem y) -> Void
lemma_externtype__mem_injective mem_types_neq Refl = mem_types_neq Refl

total public export
lemma_externtype__global_injective : ((x = y) -> Void) -> (Global x = Global y) -> Void
lemma_externtype__global_injective global_types_neq Refl = global_types_neq Refl

total public export
lemma_func_not_table : (Func x = Table y) -> Void
lemma_func_not_table Refl impossible

total public export
lemma_func_not_mem : (Func x = Mem y) -> Void
lemma_func_not_mem Refl impossible

total public export
lemma_func_not_global : (Func x = Global y) -> Void
lemma_func_not_global Refl impossible

total public export
lemma_table_not_func : (Table x = Func y) -> Void
lemma_table_not_func Refl impossible

total public export
lemma_table_not_mem : (Table x = Mem y) -> Void
lemma_table_not_mem Refl impossible

total public export
lemma_table_not_global : (Table x = Global y) -> Void
lemma_table_not_global Refl impossible

total public export
lemma_mem_not_func : (Mem x = Func y) -> Void
lemma_mem_not_func Refl impossible

total public export
lemma_mem_not_table : (Mem x = Table y) -> Void
lemma_mem_not_table Refl impossible

total public export
lemma_mem_not_global : (Mem x = Global y) -> Void
lemma_mem_not_global Refl impossible

total public export
lemma_global_not_func : (Global x = Func y) -> Void
lemma_global_not_func Refl impossible

total public export
lemma_global_not_table : (Global x = Table y) -> Void
lemma_global_not_table Refl impossible

total public export
lemma_global_not_mem : (Global x = Mem y) -> Void
lemma_global_not_mem Refl impossible

-- Decidable Equality

public export
implementation DecEq ExternType where
  decEq (Func x)   (Func y)   = case decEq x y of
    No func_types_neq => No (lemma_externtype__func_injective func_types_neq)
    Yes Refl          => Yes Refl
  decEq (Table x)  (Table y)  = case decEq x y of
    No table_tables_neq => No (lemma_externtype__table_injective table_tables_neq)
    Yes Refl            => Yes Refl
  decEq (Mem x)    (Mem y)    = case decEq x y of
    No mem_types_neq => No (lemma_externtype__mem_injective mem_types_neq)
    Yes Refl         => Yes Refl
  decEq (Global x) (Global y) = case decEq x y of
    No global_types_neq => No (lemma_externtype__global_injective global_types_neq)
    Yes Refl            => Yes Refl
  decEq (Func x)   (Table y)  = No lemma_func_not_table
  decEq (Func x)   (Mem y)    = No lemma_func_not_mem
  decEq (Func x)   (Global y) = No lemma_func_not_global
  decEq (Table x)  (Func y)   = No lemma_table_not_func
  decEq (Table x)  (Mem y)    = No lemma_table_not_mem
  decEq (Table x)  (Global y) = No lemma_table_not_global
  decEq (Mem x)    (Func y)   = No lemma_mem_not_func
  decEq (Mem x)    (Table y)  = No lemma_mem_not_table
  decEq (Mem x)    (Global y) = No lemma_mem_not_global
  decEq (Global x) (Func y)   = No lemma_global_not_func
  decEq (Global x) (Table y)  = No lemma_global_not_table
  decEq (Global x) (Mem y)    = No lemma_global_not_mem


module Compiler.LLVM.Rapid.Integer

import Data.Bits
import Data.Vect

import Compiler.LLVM.IR
import Compiler.LLVM.Instruction
import Compiler.LLVM.Rapid.Object
import Control.Codegen

GMP_LIMB_SIZE : Integer
GMP_LIMB_SIZE = 8

GMP_LIMB_BITS : Integer
GMP_LIMB_BITS = 8 * GMP_LIMB_SIZE

GMP_LIMB_BOUND : Integer
GMP_LIMB_BOUND = (1 `prim__shl_Integer` (GMP_LIMB_BITS))

-- To estimate required count of limbs (upper bound):
-- x = the number (result)
--   length of string == number of digits <= log10(x) + 1
--   required limbs: log10(x) / log10(2^LIMB_BITS)
--     LIMB_BITS=32 -> required limbs <= number of digits / 9
--     LIMB_BITS=64 -> required limbs <= number of digits / 19
GMP_ESTIMATE_DIGITS_PER_LIMB : Integer
GMP_ESTIMATE_DIGITS_PER_LIMB = 19

TARGET_SIZE_T : IRType
TARGET_SIZE_T = I64

MP_LIMB_T : IRType
MP_LIMB_T = I64

twosComplement : Num a => Bits a => a -> a
twosComplement x = 1 + (complement x)

export
cgMkConstInteger : Integer -> Codegen (IRValue IRObjPtr)
cgMkConstInteger val =
    do
      let absVal = abs val
      let (len ** limbs) = getLimbs absVal
      let len32 = cast {to=Bits32} $ cast {to=Int} len
      let lenForHeader = if (val >= 0) then len32 else (twosComplement len32)
      let newHeader = constHeader OBJECT_TYPE_ID_BIGINT lenForHeader
      let typeSignature = "{i64, [" ++ show len ++ " x %LimbT]}"
      cName <- addConstant $ "private unnamed_addr addrspace(1) constant " ++ typeSignature ++ " {" ++ toIR newHeader ++ ", [" ++ show len ++ " x %LimbT] [" ++ (getLimbsIR limbs) ++ "]}, align 8"
      pure $ SSA IRObjPtr $ "bitcast (" ++ typeSignature ++ " addrspace(1)* " ++ cName ++ " to %ObjPtr)"
  where
      getLimbs : Integer -> (n:Nat ** Vect n Integer)
      getLimbs 0 = (0 ** [])
      getLimbs x = let (n ** v) = (getLimbs (x `div` GMP_LIMB_BOUND))
                       limb = (x `mod` GMP_LIMB_BOUND) in
                       ((S n) ** (limb::v))
      getLimbsIR : Vect n Integer -> String
      getLimbsIR [] = ""
      getLimbsIR (limb::[]) = "%LimbT " ++ show limb
      getLimbsIR (limb::rest) = "%LimbT " ++ show limb ++ ", " ++ (getLimbsIR rest)

export
integer0 : Codegen (IRValue IRObjPtr)
integer0 = do
  newObj <- dynamicAllocate (Const I64 0)
  putObjectHeader newObj (constHeader OBJECT_TYPE_ID_BIGINT 0)
  pure newObj

export
cgMkIntegerSigned : IRValue I64 -> Codegen (IRValue IRObjPtr)
cgMkIntegerSigned val = do
  isNegative <- icmp "slt" val (Const I64 0)
  isZero <- icmp "eq" val (Const I64 0)
  newSize1 <- mkSelect isNegative (Const I32 (-1)) (Const I32 1)
  newSize <- mkSelect isZero (Const I32 0) newSize1
  newHeader <- mkHeader OBJECT_TYPE_ID_BIGINT newSize
  newSizeAbs <- mkAbs newSize
  allocSize <- mkMul !(mkZext newSizeAbs) (Const I64 GMP_LIMB_SIZE)
  newObj <- dynamicAllocate allocSize
  ignore $ mkIf (pure isZero) (pure (Const I1 0)) (do
       absVal <- mkAbs64 val
       putObjectSlot newObj (Const I64 0) absVal
       pure $ Const I1 0)
  putObjectHeader newObj newHeader
  pure newObj

export
cgMkIntegerUnsigned : IRValue I64 -> Codegen (IRValue IRObjPtr)
cgMkIntegerUnsigned ival = do
  isZero <- icmp "eq" (Const I64 0) ival
  newObj <- mkIf (pure isZero) integer0 (do
      newInteger <- dynamicAllocate (Const I64 GMP_LIMB_SIZE)
      putObjectHeader newInteger !(mkHeader OBJECT_TYPE_ID_BIGINT (Const I32 1))
      putObjectSlot newInteger (Const I64 0) ival
      pure newInteger
    )
  pure newObj

export
unboxIntegerUnsigned : IRValue IRObjPtr -> Codegen (IRValue I64)
unboxIntegerUnsigned integerObj = do
  isZero <- icmp "eq" (Const I32 0) !(getObjectSize integerObj)
  -- get first limb (LSB)
  mkIf (pure isZero) (pure $ Const I64 0) (getObjectSlot {t=I64} integerObj 0)

export
unboxIntegerSigned : IRValue IRObjPtr -> Codegen (IRValue I64)
unboxIntegerSigned integerObj = do
  size <- getObjectSize integerObj
  isZero <- icmp "eq" (Const I32 0) size
  let isNegative = icmp "sgt" (Const I32 0) size
  -- get first limb (LSB)
  firstLimb <- getObjectSlot {t=I64} integerObj 0
  -- TODO: this is probably wrong for 64bit
  mkIf (pure isZero) (pure $ Const I64 0) (mkIf isNegative (mkSub (Const I64 0) firstLimb) (pure firstLimb))

||| compare two BigInts `a` and `b`, return -1 if a<b, +1 if a>b, 0 otherwise
export
compareInteger : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue I64)
compareInteger obj1 obj2 = do
  size1 <- getObjectSize obj1
  size2 <- getObjectSize obj2
  cmpResult <- mkIf (icmp "slt" size1 size2) (pure (Const I64 (-1))) (
    mkIf (icmp "sgt" size1 size2) (pure (Const I64 1)) (do
         limbs1 <- getObjectPayloadAddr {t=I64} obj1
         limbs2 <- getObjectPayloadAddr {t=I64} obj2
         absSize <- mkZext {to=I64} !(mkAbs size1)
         mpnResult <- call {t=I32} "ccc" "@__gmpn_cmp" [toIR limbs1, toIR limbs2, toIR absSize]
         sizeIsNegative <- icmp "slt" size1 (Const I32 0)
         mkSext !(mkSelect sizeIsNegative !(mkSub (Const I32 0) mpnResult) mpnResult)
         )
         )

  pure cmpResult

normaliseIntegerSize : IRValue IRObjPtr -> IRValue I32 -> IRValue I1 -> Codegen ()
normaliseIntegerSize integerObj maxSizeSigned invert = do
  maxSizeAbs <- mkAbs maxSizeSigned
  absRealNewSize <- mkTrunc {to=I32} !(call {t=I64} "ccc" "@rapid_bigint_real_size" [
    toIR !(getObjectPayloadAddr {t=I64} integerObj),
    toIR !(mkZext {to=I64} maxSizeAbs)
    ])
  isNegative <- icmp "slt" maxSizeSigned (Const I32 0)
  invertResult <- mkXOr isNegative invert
  signedNewSize <- mkSelect invertResult !(mkSub (Const I32 0) absRealNewSize) absRealNewSize
  newHeader <- mkHeader OBJECT_TYPE_ID_BIGINT signedNewSize
  putObjectHeader integerObj newHeader

export
addInteger : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
addInteger i1 i2 = do
      s1 <- getObjectSize i1
      s2 <- getObjectSize i2
      i1Negative <- icmp "slt" s1 (Const I32 0)
      s1a <- mkAbs s1
      s2a <- mkAbs s2
      i1longer <- icmp "ugt" s1a s2a
      -- "big" and "small" refer just to the respective limb counts
      -- it doesn't matter which number is actually bigger
      big <- mkSelect i1longer i1 i2
      small <- mkSelect i1longer i2 i1
      size1 <- mkZext {to=I64} !(mkSelect {t=I32} i1longer s1a s2a)
      size2 <- mkZext {to=I64} !(mkSelect {t=I32} i1longer s2a s1a)
      newLength <- mkAdd size1 (Const I64 1)
      newSize <- mkMul (Const I64 GMP_LIMB_SIZE) newLength
      newObj <- dynamicAllocate newSize
      carry <- call {t=I64} "ccc" "@__gmpn_add" [
        toIR !(getObjectPayloadAddr {t=I64} newObj),
        toIR !(getObjectPayloadAddr {t=I64} big),
        toIR size1,
        toIR !(getObjectPayloadAddr {t=I64} small),
        toIR size2
        ]
      putObjectSlot newObj size1 carry
      absRealNewSize <- mkAdd size1 carry
      signedNewSize <- mkSelect i1Negative !(mkSub (Const I64 0) absRealNewSize) absRealNewSize
      signedNewSize32 <- mkTrunc {to=I32} signedNewSize
      newHeader <- mkHeader OBJECT_TYPE_ID_BIGINT signedNewSize32
      putObjectHeader newObj newHeader
      pure newObj

export
subInteger : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
subInteger i1 i2 = do
      -- Subtract the smaller (by abs. value) from the larger (by abs. value)
      -- and use the sign of the larger (by abs. value) number as sign for the
      -- returned result.
      s1 <- getObjectSize i1
      s2 <- getObjectSize i2
      i1Negative <- icmp "slt" s1 (Const I32 0)
      s1a <- mkAbs s1
      s2a <- mkAbs s2
      i1longer <- icmp "ugt" s1a s2a
      i2longer <- icmp "ugt" s2a s1a
      i1bigger <- mkIf (pure i1longer) (pure $ Const I1 1) (mkIf (pure i2longer) (pure $ Const I1 0) (icmp "sgt" !(call "ccc" "@__gmpn_cmp" [
                                toIR !(getObjectPayloadAddr {t=I64} i1),
                                toIR !(getObjectPayloadAddr {t=I64} i2),
                                toIR !(mkZext {to=I64} s1a)
                                ]) (Const I32 0))
        )
      big <- mkSelect i1bigger i1 i2
      small <- mkSelect i1bigger i2 i1
      swapped <- mkSelect i1bigger (Const I1 0) (Const I1 1)
      bigSize <- getObjectSize big
      bigSizeAbs <- mkAbs bigSize
      smallSizeAbs <- mkAbs !(getObjectSize small)
      newSize <- mkMul (Const I64 GMP_LIMB_SIZE) !(mkZext {to=I64} bigSizeAbs)
      newObj <- dynamicAllocate newSize
      absDiff <- call {t=I64} "ccc" "@__gmpn_sub" [
        toIR !(getObjectPayloadAddr {t=I64} newObj),
        toIR !(getObjectPayloadAddr {t=I64} big),
        toIR !(mkZext {to=I64} bigSizeAbs),
        toIR !(getObjectPayloadAddr {t=I64} small),
        toIR !(mkZext {to=I64} smallSizeAbs)
        ]
      absRealNewSize <- call {t=I64} "ccc" "@rapid_bigint_real_size" [
        toIR !(getObjectPayloadAddr {t=I64} newObj),
        toIR !(mkZext {to=I64} bigSizeAbs)
        ]
      resultIsNegative <- mkXOr swapped i1Negative
      signedNewSize <- mkSelect resultIsNegative !(mkSub (Const I64 0) absRealNewSize) absRealNewSize
      signedNewSize32 <- mkTrunc {to=I32} signedNewSize
      newHeader <- mkHeader OBJECT_TYPE_ID_BIGINT signedNewSize32
      putObjectHeader newObj newHeader
      pure newObj

export
andInteger : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
andInteger i1 i2 = do
  -- TODO: what to do with negative numbers?
  s1 <- getObjectSize i1
  s2 <- getObjectSize i2
  zero1 <- icmp "eq" s1 (Const I32 0)
  zero2 <- icmp "eq" s2 (Const I32 0)
  resultIsZero <- mkOr zero1 zero2

  mkIf (pure resultIsZero) (mkSelect zero1 i1 i2) (do
    s1a <- mkAbs s1
    s2a <- mkAbs s2
    i1longer <- icmp "ugt" s1a s2a
    -- "long" and "short" refer just to the respective limb counts
    -- it doesn't matter which number is actually bigger
    long <- mkSelect i1longer i1 i2
    short <- mkSelect i1longer i2 i1
    size1 <- mkZext {to=I64} !(mkSelect {t=I32} i1longer s1a s2a)
    size2 <- mkZext {to=I64} !(mkSelect {t=I32} i1longer s2a s1a)
    -- result can not be longer than shortest number
    let newLength = size2
    newSize <- mkMul (Const I64 GMP_LIMB_SIZE) newLength
    newObj <- dynamicAllocate newSize
    putObjectHeader newObj !(mkHeader OBJECT_TYPE_ID_BIGINT !(mkTrunc newLength))

    newLimbs <- getObjectPayloadAddr {t=I64} newObj
    shortLimbs <- getObjectPayloadAddr {t=I64} short
    longLimbs <- getObjectPayloadAddr {t=I64} long
    voidCall "ccc" "@__gmpn_and_n" [toIR newLimbs, toIR shortLimbs, toIR longLimbs, toIR newLength]

    normaliseIntegerSize newObj !(mkTrunc newLength) (Const I1 0)

    pure newObj
    )

export
orInteger : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
orInteger i1 i2 = do
  -- TODO: what to do with negative numbers?
  s1 <- getObjectSize i1
  s2 <- getObjectSize i2
  zero1 <- icmp "eq" s1 (Const I32 0)
  zero2 <- icmp "eq" s2 (Const I32 0)
  resultIsZero <- mkAnd zero1 zero2

  mkIf (pure resultIsZero) (pure i1) (do
    s1a <- mkAbs s1
    s2a <- mkAbs s2
    i1longer <- icmp "ugt" s1a s2a
    -- "big" and "small" refer just to the respective limb counts
    -- it doesn't matter which number is actually bigger
    big <- mkSelect i1longer i1 i2
    small <- mkSelect i1longer i2 i1
    size1 <- mkZext {to=I64} !(mkSelect {t=I32} i1longer s1a s2a)
    size2 <- mkZext {to=I64} !(mkSelect {t=I32} i1longer s2a s1a)
    mkIf (icmp "eq" (Const I64 0) size2) (pure big) (do
      let newLength = size1
      newSize <- mkMul (Const I64 GMP_LIMB_SIZE) newLength
      newObj <- dynamicAllocate newSize
      putObjectHeader newObj !(mkHeader OBJECT_TYPE_ID_BIGINT !(mkTrunc newLength))

      newPayload <- getObjectPayloadAddr {t=I8} newObj
      bigPayload <- getObjectPayloadAddr {t=I8} big
      appendCode $ "  call void @llvm.memcpy.p1i8.p1i8.i64(" ++ toIR newPayload ++ ", " ++ toIR bigPayload ++ ", " ++ toIR newSize++ ", i1 false)"

      newLimbs <- getObjectPayloadAddr {t=I64} newObj
      smallLimbs <- getObjectPayloadAddr {t=I64} small
      voidCall "ccc" "@__gmpn_ior_n" [toIR newLimbs, toIR newLimbs, toIR smallLimbs, toIR size2]
      pure newObj
      )
    )

export
xorInteger : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
xorInteger i1 i2 = do
  -- TODO: what to do with negative numbers?
  s1 <- getObjectSize i1
  s2 <- getObjectSize i2
  zero1 <- icmp "eq" s1 (Const I32 0)
  zero2 <- icmp "eq" s2 (Const I32 0)
  resultIsUnchanged <- mkOr zero1 zero2

  mkIf (pure resultIsUnchanged) (mkSelect zero1 i2 i1) (do
    s1a <- mkAbs s1
    s2a <- mkAbs s2
    i1longer <- icmp "ugt" s1a s2a
    -- "long" and "short" refer just to the respective limb counts
    -- it doesn't matter which number is actually bigger
    long <- mkSelect i1longer i1 i2
    short <- mkSelect i1longer i2 i1
    size1 <- mkZext {to=I64} !(mkSelect {t=I32} i1longer s1a s2a)
    size2 <- mkZext {to=I64} !(mkSelect {t=I32} i1longer s2a s1a)
    -- result can not be longer than longest number
    let newLength = size1
    newSize <- mkMul (Const I64 GMP_LIMB_SIZE) newLength
    newObj <- dynamicAllocate newSize
    putObjectHeader newObj !(mkHeader OBJECT_TYPE_ID_BIGINT !(mkTrunc newLength))

    newPayload <- getObjectPayloadAddr {t=I8} newObj
    longPayload <- getObjectPayloadAddr {t=I8} long
    appendCode $ "  call void @llvm.memcpy.p1i8.p1i8.i64(" ++ toIR newPayload ++ ", " ++ toIR longPayload ++ ", " ++ toIR newSize ++ ", i1 false)"

    newLimbs <- getObjectPayloadAddr {t=I64} newObj
    shortLimbs <- getObjectPayloadAddr {t=I64} short
    voidCall "ccc" "@__gmpn_xor_n" [toIR newLimbs, toIR newLimbs, toIR shortLimbs, toIR size2]

    normaliseIntegerSize newObj !(mkTrunc newLength) (Const I1 0)

    pure newObj
    )

export
mulInteger : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
mulInteger i1 i2 = do
      s1 <- getObjectSize i1
      s2 <- getObjectSize i2
      zero1 <- icmp "eq" s1 (Const I32 0)
      zero2 <- icmp "eq" s2 (Const I32 0)
      resultIsZero <- mkOr zero1 zero2
      mkIf (pure resultIsZero) {- then -} integer0 {- else -} (do
        sx <- mkXOr s1 s2
        signsMatch <- icmp "sge" sx (Const I32 0)
        s1a <- mkAbs s1
        s2a <- mkAbs s2
        i1longer <- icmp "ugt" s1a s2a
        -- "big" and "small" refer just to the respective limb counts
        -- it doesn't matter which number is actually bigger
        big <- mkSelect i1longer i1 i2
        small <- mkSelect i1longer i2 i1
        size1 <- mkZext {to=I64} !(mkSelect {t=I32} i1longer s1a s2a)
        size2 <- mkZext {to=I64} !(mkSelect {t=I32} i1longer s2a s1a)
        newLength <- mkAdd size1 size2
        newSize <- mkMul (Const I64 GMP_LIMB_SIZE) newLength
        newObj <- dynamicAllocate newSize
        ignore $ call {t=I64} "ccc" "@__gmpn_mul" [
          toIR !(getObjectPayloadAddr {t=I64} newObj),
          toIR !(getObjectPayloadAddr {t=I64} big),
          toIR size1,
          toIR !(getObjectPayloadAddr {t=I64} small),
          toIR size2
          ]
        absRealNewSize <- call {t=I64} "ccc" "@rapid_bigint_real_size" [
          toIR !(getObjectPayloadAddr {t=I64} newObj),
          toIR newLength
          ]
        signedNewSize <- mkSelect signsMatch absRealNewSize !(mkSub (Const I64 0) absRealNewSize)
        signedNewSize32 <- mkTrunc {to=I32} signedNewSize
        newHeader <- mkHeader OBJECT_TYPE_ID_BIGINT signedNewSize32
        putObjectHeader newObj newHeader
        pure newObj)

||| divide i1 by i2, return (quotient, remainder)
divInteger : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr, IRValue IRObjPtr)
divInteger i1 i2 = do
  s1 <- getObjectSize i1
  s2 <- getObjectSize i2
  s1a <- mkZext !(mkAbs s1)
  s2a <- mkZext !(mkAbs s2)
  zero1 <- icmp "eq" s1 (Const I32 0)
  zero2 <- icmp "eq" s2 (Const I32 0)
  ignore $ mkIf (pure zero2) (do
                mkRuntimeCrash "division by 0"
                pure (Const I1 0)
                ) (pure (Const I1 0))

  retZeroLbl <- genLabel "ret0"
  checkDividendLbl <- genLabel "div_chk"
  dividendLargerLbl <- genLabel "div_lg"
  divLbl <- genLabel "div"
  endLbl <- genLabel "div_end"

  branch zero1 retZeroLbl checkDividendLbl

  beginLabel retZeroLbl
  zeroInteger <- integer0
  jump endLbl

  beginLabel checkDividendLbl
  dividendLarger <- icmp "ugt" s2a s1a
  branch dividendLarger dividendLargerLbl divLbl

  beginLabel dividendLargerLbl
  zeroQuotient <- integer0
  jump endLbl

  beginLabel divLbl
  -- i1, i2 /= 0
  sx <- mkXOr s1 s2
  signsMatch <- icmp "sge" sx (Const I32 0)

  -- remainder can not be bigger than divisor
  let maxLimbsRemainder = s2a
  remainder <- dynamicAllocate !(mkMul (Const I64 GMP_LIMB_SIZE) maxLimbsRemainder)
  -- object must have a valid header, because the next allocation might trigger a GC
  tempHeader <- mkHeader OBJECT_TYPE_ID_BIGINT !(mkTrunc maxLimbsRemainder)
  putObjectHeader remainder tempHeader

  maxLimbsQuotient <- mkMax (Const I64 1) !(mkAdd (Const I64 1) !(mkSub s1a s2a))
  quotient <- dynamicAllocate !(mkMul (Const I64 GMP_LIMB_SIZE) maxLimbsQuotient)

  voidCall "ccc" "@__gmpn_tdiv_qr" [
    toIR !(getObjectPayloadAddr {t=I64} quotient),
    toIR !(getObjectPayloadAddr {t=I64} remainder),
    toIR (Const I64 0),
    toIR !(getObjectPayloadAddr {t=I64} i1),
    toIR s1a,
    toIR !(getObjectPayloadAddr {t=I64} i2),
    toIR s2a
    ]
  qRealNewSize <- call {t=I64} "ccc" "@rapid_bigint_real_size" [
    toIR !(getObjectPayloadAddr {t=I64} quotient),
    toIR maxLimbsQuotient
    ]
  signedNewSize <- mkSelect signsMatch qRealNewSize !(mkSub (Const I64 0) qRealNewSize)
  signedNewSize32 <- mkTrunc {to=I32} signedNewSize
  newHeader <- mkHeader OBJECT_TYPE_ID_BIGINT signedNewSize32
  putObjectHeader quotient newHeader

  i1negative <- icmp "slt" s1 (Const I32 0)
  rRealNewSize <- call {t=I64} "ccc" "@rapid_bigint_real_size" [
    toIR !(getObjectPayloadAddr {t=I64} remainder),
    toIR maxLimbsRemainder
    ]
  signedNewSize <- mkSelect i1negative !(mkSub (Const I64 0) rRealNewSize) rRealNewSize
  signedNewSize32 <- mkTrunc {to=I32} signedNewSize
  newHeader <- mkHeader OBJECT_TYPE_ID_BIGINT signedNewSize32
  putObjectHeader remainder newHeader

  jump endLbl

  beginLabel endLbl
  quotient  <- phi [(zeroInteger, retZeroLbl), (zeroQuotient, dividendLargerLbl), (quotient,  divLbl)]
  remainder <- phi [(zeroInteger, retZeroLbl), (i1,           dividendLargerLbl), (remainder, divLbl)]
  pure (quotient, remainder)

export
divIntegerQuotient : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
divIntegerQuotient a b = fst <$> divInteger a b

export
divIntegerRemainder : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
divIntegerRemainder a b = snd <$> divInteger a b

export
shiftLeftInteger : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
shiftLeftInteger integerObj bitCountObj = do
  bitCount <- mkTrunc {to=I32} !(unboxIntegerUnsigned bitCountObj)

  size <- getObjectSize integerObj
  unchanged <- mkOr !(icmp "eq" size (Const I32 0)) !(icmp "eq" bitCount (Const I32 0))
  mkIf (pure unchanged) (do
    pure integerObj
    ) (do
    sizeAbs <- mkAbs size
    fullLimbs <- mkUDiv bitCount (Const I32 GMP_LIMB_BITS)
    maxLimbsCount <- mkAdd !(mkAdd fullLimbs sizeAbs) (Const I32 1)

    newObj <- dynamicAllocate !(mkZext !(mkMul maxLimbsCount (Const I32 GMP_LIMB_SIZE)))
    lowerLimbsAddr <- getObjectPayloadAddr {t=I8} newObj
    appendCode $ "  call void @llvm.memset.p1i8.i64(" ++ toIR lowerLimbsAddr ++ ", i8 0, " ++ toIR !(mkMul !(mkZext fullLimbs) (Const I64 8)) ++ ", i1 false)"

    restBits <- mkURem bitCount (Const I32 GMP_LIMB_BITS)
    mkIf_ (icmp "ne" (Const I32 0) restBits) (do
      srcLimbs <- getObjectPayloadAddr {t=I64} integerObj
      higherLimbsAddr <- getObjectSlotAddrVar {t=I64} newObj !(mkZext {to=I64} fullLimbs)
      msbLimb <- call {t=I64} "ccc" "@__gmpn_lshift" [
        toIR higherLimbsAddr,
        toIR srcLimbs,
        toIR !(mkZext {to=I64} sizeAbs),
        toIR restBits
        ]
      msbLimbAddr <- getObjectSlotAddrVar {t=I64} newObj !(mkZext !(mkSub maxLimbsCount (Const I32 1)))
      store msbLimb msbLimbAddr
      ) (do
      srcLimbs <- getObjectPayloadAddr {t=I8} integerObj
      higherLimbsAddr <- getObjectSlotAddrVar {t=I8} newObj !(mkZext {to=I64} fullLimbs)
      voidCall "ccc" "@llvm.memcpy.p1i8.p1i8.i64" [
        toIR higherLimbsAddr,
        toIR srcLimbs,
        toIR !(mkMul !(mkZext size) (Const I64 GMP_LIMB_SIZE)),
        "i1 false"
        ]
      )

    isNegative <- icmp "slt" size (Const I32 0)
    normaliseIntegerSize newObj maxLimbsCount isNegative
    pure newObj
    )

export
shiftRightInteger : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
shiftRightInteger integerObj bitCountObj = do
  bitCount <- mkTrunc {to=I32} !(unboxIntegerUnsigned bitCountObj)

  size <- getObjectSize integerObj
  unchanged <- mkOr !(icmp "eq" size (Const I32 0)) !(icmp "eq" bitCount (Const I32 0))
  mkIf (pure unchanged) (pure integerObj) (do
    sizeAbs <- mkAbs size
    fullLimbs <- mkUDiv bitCount (Const I32 GMP_LIMB_BITS)
    maxLimbsCount <- mkSub sizeAbs fullLimbs

    mkIf (icmp "sle" maxLimbsCount (Const I32 0)) integer0 (do
      newObj <- dynamicAllocate !(mkZext !(mkMul maxLimbsCount (Const I32 GMP_LIMB_SIZE)))

      restBits <- mkURem bitCount (Const I32 GMP_LIMB_BITS)
      mkIf_ (icmp "ne" (Const I32 0) restBits) (do
        srcHigherLimbs <- getObjectSlotAddrVar {t=I64} integerObj !(mkZext {to=I64} fullLimbs)
        dstLimbsAddr <- getObjectPayloadAddr {t=I64} newObj
        ignore $ call {t=I64} "ccc" "@__gmpn_rshift" [
          toIR dstLimbsAddr,
          toIR srcHigherLimbs,
          toIR !(mkZext {to=I64} maxLimbsCount),
          toIR restBits
          ]
        ) (do
        srcHigherLimbs <- getObjectSlotAddrVar {t=I8} integerObj !(mkZext {to=I64} fullLimbs)
        dstLimbsAddr <- getObjectPayloadAddr {t=I8} newObj
        voidCall "ccc" "@llvm.memcpy.p1i8.p1i8.i64" [
          toIR dstLimbsAddr,
          toIR srcHigherLimbs,
          toIR !(mkMul !(mkZext maxLimbsCount) (Const I64 GMP_LIMB_SIZE)),
          "i1 false"
          ]
        )

      isNegative <- icmp "slt" size (Const I32 0)
      normaliseIntegerSize newObj maxLimbsCount isNegative
      pure newObj
      )

    )

IEEE_DOUBLE_MASK_EXP  : Bits64
IEEE_DOUBLE_MASK_EXP  = 0x7ff0000000000000
IEEE_DOUBLE_MASK_FRAC : Bits64
IEEE_DOUBLE_MASK_FRAC = 0x000fffffffffffff
IEEE_DOUBLE_MASK_SIGN : Bits64
IEEE_DOUBLE_MASK_SIGN = 0x8000000000000000
IEEE_DOUBLE_INF_POS   : Bits64
IEEE_DOUBLE_INF_POS   = 0x7ff0000000000000
IEEE_DOUBLE_INF_NEG   : Bits64
IEEE_DOUBLE_INF_NEG   = 0xfff0000000000000

export
castDoubleToInteger : IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
castDoubleToInteger floatObj = do
  floatBitsAsI64 <- getObjectSlot {t=I64} floatObj 0
  exponent <- mkShiftR !(mkAnd (Const I64 $ cast IEEE_DOUBLE_MASK_EXP) floatBitsAsI64) (Const I64 52)
  -- NaN and infinity will be returned as "0"
  isInfOrNaN <- icmp "eq" exponent (Const I64 0x7ff)
  -- absolute values < 1.0 will be returned as "0"
  isSmallerThanOne <- icmp "ult" exponent (Const I64 1023)
  returnZero <- mkOr isInfOrNaN isSmallerThanOne

  mkIf (pure returnZero) {- then -} integer0 {- else -} (do
    fraction <- mkAnd (Const I64 $ cast IEEE_DOUBLE_MASK_FRAC) floatBitsAsI64
    -- highest bit is sign bit in both, Double and I64, so we can just use that one
    isNegative <- icmp "slt" floatBitsAsI64 (Const I64 0)
    initial <- mkOr fraction (Const I64 0x10000000000000)
    toShift <- mkSub exponent (Const I64 1075)
    shiftLeft <- icmp "sgt" toShift (Const I64 0)
    mkIf (pure shiftLeft) (do
      let maxLimbCount = Const I64 17
      payloadSize <- mkMul maxLimbCount (Const I64 GMP_LIMB_SIZE)
      -- requiredBits <- (exponent - 1022)
      -- requiredLimbs <- (requiredBits+63) / 64
      -- newObj <- allocObject (requiredLimbs * 8)
      newObj <- dynamicAllocate payloadSize
      payloadAddr <- getObjectPayloadAddr {t=I8} newObj
      appendCode $ "  call void @llvm.memset.p1i8.i64(" ++ toIR payloadAddr ++ ", i8 0, " ++ toIR payloadSize ++ ", i1 false)"
      putObjectSlot newObj (Const I64 0) initial
      absRealNewSize <- call {t=I64} "ccc" "@rapid_bigint_lshift_inplace" [
        toIR !(getObjectPayloadAddr {t=I64} newObj),
        toIR maxLimbCount,
        toIR !(mkTrunc {to=I32} toShift)
      ]
      signedNewSize <- mkSelect isNegative !(mkSub (Const I64 0) absRealNewSize) absRealNewSize
      size32 <- mkTrunc {to=I32} signedNewSize
      newHeader <- mkHeader OBJECT_TYPE_ID_BIGINT size32
      putObjectHeader newObj newHeader
      pure newObj
      ) (do
        newObj <- dynamicAllocate (Const I64 8)
        toShiftRight <- mkSub (Const I64 0) toShift
        shifted <- mkShiftR initial toShiftRight
        putObjectSlot newObj (Const I64 0) shifted
        signedNewSize32 <- mkSelect isNegative (Const I32 (-1)) (Const I32 1)
        newHeader <- mkHeader OBJECT_TYPE_ID_BIGINT signedNewSize32
        putObjectHeader newObj newHeader
        pure newObj
      )
    )

export
castIntegerToDouble : IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
castIntegerToDouble intObj = do
  size <- getObjectSize intObj
  isZero <- icmp "eq" (Const I32 0) size

  mkIf (pure isZero) (cgMkConstDouble 0.0) (do
    sizeAbs <- mkAbs size
    highestLimbIndex <- mkZext {to=I64} !(mkSub sizeAbs (Const I32 1))
    msbLimbAddr <- getObjectSlotAddrVar {t=I64} intObj highestLimbIndex
    msbLimb <- load msbLimbAddr
    countLeadingZeros <- SSA I64 <$> assignSSA ("  call ccc i64 @llvm.ctlz.i64(" ++ toIR msbLimb ++ ", i1 1)")
    exponentOffset <- mkAdd (Const I64 (1023 + 63)) !(mkMul highestLimbIndex (Const I64 64))
    exponent <- mkSub exponentOffset countLeadingZeros

    isInfinity <- icmp "ugt" exponent (Const I64 2046)
    doubleAsBits <- mkIf (pure isInfinity) (do
        pure (Const I64 $ cast IEEE_DOUBLE_INF_POS)
      ) (do
        fracShiftLeft <- icmp "uge" countLeadingZeros (Const I64 12)
        shiftedFraction <- mkIf (pure fracShiftLeft) (do
            mkShiftL msbLimb !(mkSub countLeadingZeros (Const I64 11))
          ) (do
            mkShiftR msbLimb !(mkSub (Const I64 11) countLeadingZeros)
          )
        fraction <- mkIf (icmp "eq" sizeAbs (Const I32 1)) (do
            pure shiftedFraction
          ) (do
            mkIf (pure fracShiftLeft) (do
                secondMsbLimbAddr <- getObjectSlotAddrVar {t=I64} intObj !(mkSub highestLimbIndex (Const I64 1))
                secondMsbLimb <- load secondMsbLimbAddr
                fractionLowerPart <- mkShiftR secondMsbLimb !(mkSub (Const I64 (64 + 11)) countLeadingZeros)
                mkOr shiftedFraction fractionLowerPart
              ) (do
                pure shiftedFraction
              )
          )
        shiftedExponent <- mkShiftL exponent (Const I64 52)
        maskedFraction <- mkAnd (Const I64 $ cast IEEE_DOUBLE_MASK_FRAC) fraction
        mkOr shiftedExponent maskedFraction
      )
    isNegative <- icmp "slt" size (Const I32 0)
    sign <- mkSelect isNegative (Const I64 $ cast IEEE_DOUBLE_MASK_SIGN) (Const I64 0)
    signedDoubleAsBits <- mkOr sign doubleAsBits
    cgMkDoubleFromBits signedDoubleAsBits
    )

export
castStringToInteger : IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
castStringToInteger strObj = do
  strLength <- getObjectSize strObj
  maxLimbsCount <- mkUDiv strLength (Const I32 GMP_ESTIMATE_DIGITS_PER_LIMB)
  -- GMP requires 1 limb scratch space
  maxLimbsCountPlus1 <- mkAdd maxLimbsCount (Const I32 1)

  newObj <- dynamicAllocate !(mkZext !(mkMul maxLimbsCountPlus1 (Const I32 GMP_LIMB_SIZE)))
  putObjectHeader newObj !(mkHeader OBJECT_TYPE_ID_BIGINT maxLimbsCountPlus1)
  ignore $ call {t=I32} "ccc" "@rapid_bigint_set_str" [
    toIR newObj,
    toIR strObj
    ]
  pure newObj

export
castIntegerToString : IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
castIntegerToString i1 = do
  s1 <- getObjectSize i1
  u1 <- mkZext {to=I64} !(mkAbs s1)

  isZero <- icmp "eq" s1 (Const I32 0)

  mkIf (pure isZero) (mkStr "0") (do
      maxDigits <- call {t=TARGET_SIZE_T} "ccc" "@__gmpn_sizeinbase" [toIR !(getObjectPayloadAddr {t=MP_LIMB_T} i1), toIR u1, "i32 10"]
      isNegative <- icmp "slt" s1 (Const I32 0)

      -- we need to add one extra byte of "scratch space" for mpn_get_str
      -- if the number is negative we need one character more for the leading minus
      needsSign <- mkSelect isNegative (Const I64 2) (Const I64 1)
      maxDigitsWithSign <- mkAdd maxDigits needsSign

      newStr <- dynamicAllocate maxDigitsWithSign
      newHeader <- mkHeader OBJECT_TYPE_ID_STR !(mkTrunc maxDigitsWithSign)
      putObjectHeader newStr newHeader

      actualDigits <- call {t=I64} "ccc" "@rapid_bigint_get_str" [toIR newStr, toIR i1, "i32 10"]
      actualLengthHeader <- mkHeader OBJECT_TYPE_ID_STR !(mkTrunc actualDigits)
      putObjectHeader newStr actualLengthHeader

      pure newStr
    )


module Flexidisc.Record.Update

import        Flexidisc.RecordContent
import public Flexidisc.Record.Type

%default total
%access export

||| Replace a row, can change its type
|||
||| Complexity is _O(n)_
|||
||| @ xs  the record
||| @ loc the proof that the row is in it
||| @ new the new value for the row
setByLabel : (xs : RecordM m k header) -> (loc : Label query header) ->
             (new : m ty) ->
             RecordM m k (changeType header loc ty)
setByLabel (Rec xs nub) (L loc) new =
  Rec (set xs loc new) (changeValuePreservesNub nub)

||| Update a row, the update can change the row type.
|||
||| Complexity is _O(n)_
|||
||| @ key the row name
||| @ xs    the record
||| @ loc   the proof that the row is in it
||| @ new   the new value for the row
set : (key : k) -> (new : m ty) -> (xs : RecordM m k header) ->
      {auto loc : Label key header} ->
      RecordM m k (changeType header loc ty)
set _ new xs {loc} = setByLabel xs loc new

||| Update a row, the update can change the row type.
|||
||| Complexity is _O(n)_
|||
||| @ query the row name
||| @ xs    the record
||| @ loc   the proof that the row is in it
||| @ new   the new value for the row
setA : Applicative m =>
       (query : k) -> (new : ty) -> (xs : RecordM m k header) ->
       {auto loc : Label query header} ->
       RecordM m k (changeType header loc ty)
setA loc = set loc . pure

||| Update a row at a given `Label`, can change its type.
|||
||| Complexity is _O(n)_
|||
||| @ xs     the record
||| @ loc    the proof that the row is in it
||| @ f      the update function
updateByLabel : (xs : RecordM m k header) -> (loc : Row query a header) ->
                (f : m a -> m b) ->
                RecordM m k (changeType header loc b)
updateByLabel (Rec xs nub) (R loc) f =
  Rec (update xs loc f) (changeValuePreservesNub nub)

||| Update a row at the given key, can change its type.
|||
||| Complexity is _O(n)_
|||
||| @ query  the row name
||| @ xs     the record
||| @ loc    the proof that the row is in it
||| @ f      the update function
update : (query : k) -> (f : m a -> m b) -> (xs : RecordM m k header) ->
         {auto loc : Row query a header} ->
         RecordM m k (changeType header loc b)
update _ f xs {loc} = updateByLabel xs loc f

||| Map at a given `Row`, can change its type.
|||
||| Complexity is _O(n)_
|||
||| @ query  the row name
||| @ xs     the record
||| @ loc    the proof that the row is in it
||| @ f      the update function
mapRow : Functor m =>
         (query : k) -> (f : a -> b) -> (xs : RecordM m k header) ->
         {auto loc : Row query a header} ->
         RecordM m k (changeType header loc b)
mapRow _ f xs {loc} = updateByLabel xs loc (map f)