{-# 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
{ BinderS -> PlaceHolderIndex
varIndex :: PlaceHolderIndex,
BinderS -> [Value]
varBindings :: [Value],
BinderS -> PlaceHolderIndex
asLabelIndex :: PlaceHolderIndex
}
deriving (PlaceHolderIndex -> BinderS -> ShowS
[BinderS] -> ShowS
BinderS -> String
(PlaceHolderIndex -> BinderS -> ShowS)
-> (BinderS -> String) -> ([BinderS] -> ShowS) -> Show BinderS
forall a.
(PlaceHolderIndex -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BinderS] -> ShowS
$cshowList :: [BinderS] -> ShowS
show :: BinderS -> String
$cshow :: BinderS -> String
showsPrec :: PlaceHolderIndex -> BinderS -> ShowS
$cshowsPrec :: PlaceHolderIndex -> BinderS -> ShowS
Show,BinderS -> BinderS -> Bool
(BinderS -> BinderS -> Bool)
-> (BinderS -> BinderS -> Bool) -> Eq BinderS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BinderS -> BinderS -> Bool
$c/= :: BinderS -> BinderS -> Bool
== :: BinderS -> BinderS -> Bool
$c== :: BinderS -> BinderS -> Bool
Eq)
initBinderS :: BinderS
initBinderS :: BinderS
initBinderS =
BinderS :: PlaceHolderIndex -> [Value] -> PlaceHolderIndex -> BinderS
BinderS
{ varIndex :: PlaceHolderIndex
varIndex = PlaceHolderIndex
0,
varBindings :: [Value]
varBindings = [],
asLabelIndex :: PlaceHolderIndex
asLabelIndex = PlaceHolderIndex
0
}
newtype Binder a = Binder { Binder a -> State BinderS a
unBinder :: State BinderS a }
deriving (a -> Binder b -> Binder a
(a -> b) -> Binder a -> Binder b
(forall a b. (a -> b) -> Binder a -> Binder b)
-> (forall a b. a -> Binder b -> Binder a) -> Functor Binder
forall a b. a -> Binder b -> Binder a
forall a b. (a -> b) -> Binder a -> Binder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Binder b -> Binder a
$c<$ :: forall a b. a -> Binder b -> Binder a
fmap :: (a -> b) -> Binder a -> Binder b
$cfmap :: forall a b. (a -> b) -> Binder a -> Binder b
Functor, Functor Binder
a -> Binder a
Functor Binder
-> (forall a. a -> Binder a)
-> (forall a b. Binder (a -> b) -> Binder a -> Binder b)
-> (forall a b c.
(a -> b -> c) -> Binder a -> Binder b -> Binder c)
-> (forall a b. Binder a -> Binder b -> Binder b)
-> (forall a b. Binder a -> Binder b -> Binder a)
-> Applicative Binder
Binder a -> Binder b -> Binder b
Binder a -> Binder b -> Binder a
Binder (a -> b) -> Binder a -> Binder b
(a -> b -> c) -> Binder a -> Binder b -> Binder c
forall a. a -> Binder a
forall a b. Binder a -> Binder b -> Binder a
forall a b. Binder a -> Binder b -> Binder b
forall a b. Binder (a -> b) -> Binder a -> Binder b
forall a b c. (a -> b -> c) -> Binder a -> Binder b -> Binder c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Binder a -> Binder b -> Binder a
$c<* :: forall a b. Binder a -> Binder b -> Binder a
*> :: Binder a -> Binder b -> Binder b
$c*> :: forall a b. Binder a -> Binder b -> Binder b
liftA2 :: (a -> b -> c) -> Binder a -> Binder b -> Binder c
$cliftA2 :: forall a b c. (a -> b -> c) -> Binder a -> Binder b -> Binder c
<*> :: Binder (a -> b) -> Binder a -> Binder b
$c<*> :: forall a b. Binder (a -> b) -> Binder a -> Binder b
pure :: a -> Binder a
$cpure :: forall a. a -> Binder a
$cp1Applicative :: Functor Binder
Applicative, Applicative Binder
a -> Binder a
Applicative Binder
-> (forall a b. Binder a -> (a -> Binder b) -> Binder b)
-> (forall a b. Binder a -> Binder b -> Binder b)
-> (forall a. a -> Binder a)
-> Monad Binder
Binder a -> (a -> Binder b) -> Binder b
Binder a -> Binder b -> Binder b
forall a. a -> Binder a
forall a b. Binder a -> Binder b -> Binder b
forall a b. Binder a -> (a -> Binder b) -> Binder b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Binder a
$creturn :: forall a. a -> Binder a
>> :: Binder a -> Binder b -> Binder b
$c>> :: forall a b. Binder a -> Binder b -> Binder b
>>= :: Binder a -> (a -> Binder b) -> Binder b
$c>>= :: forall a b. Binder a -> (a -> Binder b) -> Binder b
$cp1Monad :: Applicative Binder
Monad)
type Binding = Object
newBind :: ToJSON v
=> v
-> Binder (Greskell v)
newBind :: v -> Binder (Greskell v)
newBind v
val = State BinderS (Greskell v) -> Binder (Greskell v)
forall a. State BinderS a -> Binder a
Binder (State BinderS (Greskell v) -> Binder (Greskell v))
-> State BinderS (Greskell v) -> Binder (Greskell v)
forall a b. (a -> b) -> a -> b
$ do
BinderS
state <- StateT BinderS Identity BinderS
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
let next_index :: PlaceHolderIndex
next_index = BinderS -> PlaceHolderIndex
varIndex BinderS
state
values :: [Value]
values = BinderS -> [Value]
varBindings BinderS
state
BinderS -> StateT BinderS Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (BinderS -> StateT BinderS Identity ())
-> BinderS -> StateT BinderS Identity ()
forall a b. (a -> b) -> a -> b
$ BinderS
state { varIndex :: PlaceHolderIndex
varIndex = PlaceHolderIndex -> PlaceHolderIndex
forall a. Enum a => a -> a
succ PlaceHolderIndex
next_index,
varBindings :: [Value]
varBindings = [Value]
values [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [v -> Value
forall a. ToJSON a => a -> Value
toJSON v
val]
}
Greskell v -> State BinderS (Greskell v)
forall (m :: * -> *) a. Monad m => a -> m a
return (Greskell v -> State BinderS (Greskell v))
-> Greskell v -> State BinderS (Greskell v)
forall a b. (a -> b) -> a -> b
$ PlaceHolderIndex -> Greskell v
forall a. PlaceHolderIndex -> Greskell a
unsafePlaceHolder PlaceHolderIndex
next_index
runBinder :: Binder a -> (a, Binding)
runBinder :: Binder a -> (a, Binding)
runBinder Binder a
binder = (a
ret, Binding
binding)
where
(a
ret, BinderS
state) = State BinderS a -> BinderS -> (a, BinderS)
forall s a. State s a -> s -> (a, s)
State.runState (Binder a -> State BinderS a
forall a. Binder a -> State BinderS a
unBinder Binder a
binder) BinderS
initBinderS
values :: [Value]
values = BinderS -> [Value]
varBindings BinderS
state
binding :: Binding
binding = [(Text, Value)] -> Binding
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Value)] -> Binding) -> [(Text, Value)] -> Binding
forall a b. (a -> b) -> a -> b
$ [Text] -> [Value] -> [(Text, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((PlaceHolderIndex -> Text) -> [PlaceHolderIndex] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map PlaceHolderIndex -> Text
toPlaceHolderVariableStrict [PlaceHolderIndex
0 ..]) ([Value] -> [(Text, Value)]) -> [Value] -> [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ [Value]
values
toPlaceHolderVariableStrict :: PlaceHolderIndex -> Text
toPlaceHolderVariableStrict = Text -> Text
TL.toStrict (Text -> Text)
-> (PlaceHolderIndex -> Text) -> PlaceHolderIndex -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlaceHolderIndex -> Text
toPlaceHolderVariable
type PlaceHolderIndex = Int
unsafePlaceHolder :: PlaceHolderIndex -> Greskell a
unsafePlaceHolder :: PlaceHolderIndex -> Greskell a
unsafePlaceHolder = Text -> Greskell a
forall a. Text -> Greskell a
unsafeGreskellLazy (Text -> Greskell a)
-> (PlaceHolderIndex -> Text) -> PlaceHolderIndex -> Greskell a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlaceHolderIndex -> Text
toPlaceHolderVariable
toPlaceHolderVariable :: PlaceHolderIndex -> TL.Text
toPlaceHolderVariable :: PlaceHolderIndex -> Text
toPlaceHolderVariable PlaceHolderIndex
i = String -> Text
TL.pack (String
"__v" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PlaceHolderIndex -> String
forall a. Show a => a -> String
show PlaceHolderIndex
i)
newAsLabel :: Binder (AsLabel a)
newAsLabel :: Binder (AsLabel a)
newAsLabel = State BinderS (AsLabel a) -> Binder (AsLabel a)
forall a. State BinderS a -> Binder a
Binder (State BinderS (AsLabel a) -> Binder (AsLabel a))
-> State BinderS (AsLabel a) -> Binder (AsLabel a)
forall a b. (a -> b) -> a -> b
$ do
BinderS
state <- StateT BinderS Identity BinderS
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
let label_index :: PlaceHolderIndex
label_index = BinderS -> PlaceHolderIndex
asLabelIndex BinderS
state
label :: String
label = String
"__a" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PlaceHolderIndex -> String
forall a. Show a => a -> String
show PlaceHolderIndex
label_index
BinderS -> StateT BinderS Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put (BinderS -> StateT BinderS Identity ())
-> BinderS -> StateT BinderS Identity ()
forall a b. (a -> b) -> a -> b
$ BinderS
state { asLabelIndex :: PlaceHolderIndex
asLabelIndex = PlaceHolderIndex -> PlaceHolderIndex
forall a. Enum a => a -> a
succ PlaceHolderIndex
label_index }
AsLabel a -> State BinderS (AsLabel a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AsLabel a -> State BinderS (AsLabel a))
-> AsLabel a -> State BinderS (AsLabel a)
forall a b. (a -> b) -> a -> b
$ Text -> AsLabel a
forall a. Text -> AsLabel a
AsLabel (Text -> AsLabel a) -> Text -> AsLabel a
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
label