{-# LANGUAGE GADTs #-}
module Data.HMemDb.RefConverter
    (PreRefConv(PreRefConv, rcFrom, rcTo), RefConv(RefConv)) where
import Control.Applicative (Applicative(pure, (<*>)))
import Control.Monad (liftM2)
import Data.HMemDb.Bin (Bin, TableRefs(TRNil, TRPair), binPair, binUnit)
import Data.HMemDb.MapTVar (MS)
data PreRefConv r input output =
    PreRefConv {rcFrom :: input -> MS r, rcTo :: r -> MS output}
data RefConv input output where
    RefConv :: Bin r -> TableRefs r -> PreRefConv r input output -> RefConv input output
(|*|) ::
    PreRefConv r1 input (middle -> output)
    -> PreRefConv r2 input middle
    -> PreRefConv (r1, r2) input output
p1 |*| p2 = PreRefConv from to where
   from input = liftM2 (,) (rcFrom p1 input) (rcFrom p2 input)
   to (r1, r2) = liftM2 ($) (rcTo p1 r1) (rcTo p2 r2)
instance Functor (RefConv input) where fmap h r = pure h <*> r
instance Applicative (RefConv input) where
    pure output =
        RefConv binUnit TRNil $
        PreRefConv {rcFrom = const $ return (), rcTo = \ ~() -> return output}
    RefConv bf trf pf <*> RefConv bx trx px =
        RefConv (binPair bf bx) (TRPair trf trx) (pf |*| px)