{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}
module Data.Greskell.Binder
(
Binder,
Binding,
newBind,
newAsLabel,
runBinder
) where
import Control.Monad.Trans.State (State)
import qualified Control.Monad.Trans.State as State
import Data.Aeson (Value, ToJSON(toJSON), Object)
import Data.Monoid ((<>))
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Greskell.AsLabel (AsLabel(..))
import Data.Greskell.Greskell (unsafeGreskellLazy, Greskell)
data BinderS =
BinderS
{ varIndex :: PlaceHolderIndex,
varBindings :: [Value],
asLabelIndex :: PlaceHolderIndex
}
deriving (Show,Eq)
initBinderS :: BinderS
initBinderS =
BinderS
{ varIndex = 0,
varBindings = [],
asLabelIndex = 0
}
newtype Binder a = Binder { unBinder :: State BinderS a }
deriving (Functor, Applicative, Monad)
type Binding = Object
newBind :: ToJSON v
=> v
-> Binder (Greskell v)
newBind val = Binder $ do
state <- State.get
let next_index = varIndex state
values = varBindings state
State.put $ state { varIndex = succ next_index,
varBindings = values ++ [toJSON val]
}
return $ unsafePlaceHolder next_index
runBinder :: Binder a -> (a, Binding)
runBinder binder = (ret, binding)
where
(ret, state) = State.runState (unBinder binder) initBinderS
values = varBindings state
binding = HM.fromList $ zip (map toPlaceHolderVariableStrict [0 ..]) $ values
toPlaceHolderVariableStrict = TL.toStrict . toPlaceHolderVariable
type PlaceHolderIndex = Int
unsafePlaceHolder :: PlaceHolderIndex -> Greskell a
unsafePlaceHolder = unsafeGreskellLazy . toPlaceHolderVariable
toPlaceHolderVariable :: PlaceHolderIndex -> TL.Text
toPlaceHolderVariable i = TL.pack ("__v" ++ show i)
newAsLabel :: Binder (AsLabel a)
newAsLabel = Binder $ do
state <- State.get
let label_index = asLabelIndex state
label = "__a" ++ show label_index
State.put $ state { asLabelIndex = succ label_index }
return $ AsLabel $ T.pack label