{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExistentialQuantification #-}
module LLVM.DSL.Render.Argument (
   T(Cons),
   Creator,
   unit,
   primitive,
   wrap,
   pair,
   triple,
   newDispose,
   ) where

import qualified LLVM.DSL.Expression as Expr
import LLVM.DSL.Expression (Exp)

import qualified LLVM.Extra.Multi.Value.Marshal as Marshal

import Data.Tuple.Strict (mapPair, mapTriple)

import Prelude2010
import Prelude ()



type Creator p = IO (p, IO ())


{- |
Transfer 'a' to 'adsl' with 'al' as transit stop.
-}
data T a adsl =
   forall al. Marshal.C al =>
   Cons (Exp al -> adsl) (a -> Creator al)


primitiveCreator :: a -> Creator a
primitiveCreator a = return (a, return ())

unit :: T () ()
unit = Cons (\ _unit -> ()) primitiveCreator

primitive :: (Marshal.C a) => T a (Exp a)
primitive = Cons id primitiveCreator

wrap :: (Marshal.C a) => (b -> a) -> (adsl -> bdsl) -> T a adsl -> T b bdsl
wrap unwrp wrp (Cons pass create) = Cons (wrp . pass) (create . unwrp)


pair :: T a ad -> T b bd -> T (a,b) (ad,bd)
pair (Cons passA createA) (Cons passB createB) =
   Cons
      (mapPair (passA,passB) . Expr.unzip)
      (\(a,b) -> do
         (pa,finalA) <- createA a
         (pb,finalB) <- createB b
         return ((pa,pb), finalB>>finalA))

triple :: T a ad -> T b bd -> T c cd -> T (a,b,c) (ad,bd,cd)
triple (Cons passA createA) (Cons passB createB) (Cons passC createC) =
   Cons
      (mapTriple (passA,passB,passC) . Expr.unzip3)
      (\(a,b,c) -> do
         (pa,finalA) <- createA a
         (pb,finalB) <- createB b
         (pc,finalC) <- createC c
         return ((pa,pb,pc), finalC>>finalB>>finalA))


newDispose ::
   (Marshal.C handle) =>
   (a -> IO handle) -> (handle -> IO ()) ->
   (Exp handle -> ad) -> T a ad
newDispose new dispose fetch =
   Cons fetch
      (\x -> do
         it <- new x
         return (it, dispose it))