module Burrito.Internal.TH
( expandTH
, uriTemplate
) where
import qualified Burrito.Internal.Expand as Expand
import qualified Burrito.Internal.Parse as Parse
import qualified Burrito.Internal.Type.Template as Template
import qualified Burrito.Internal.Type.Value as Value
import qualified Data.Bifunctor as Bifunctor
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Builder as Builder
import qualified Language.Haskell.TH.Quote as TH
import qualified Language.Haskell.TH.Syntax as TH
expandTH :: [(String, Value.Value)] -> Template.Template -> TH.Q TH.Exp
expandTH :: [(String, Value)] -> Template -> Q Exp
expandTH [(String, Value)]
xs Template
t = do
let
m :: Map Text Value
m = [(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Value)] -> Map Text Value)
-> [(Text, Value)] -> Map Text Value
forall a b. (a -> b) -> a -> b
$ ((String, Value) -> (Text, Value))
-> [(String, Value)] -> [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Text) -> (String, Value) -> (Text, Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bifunctor.first String -> Text
Text.pack) [(String, Value)]
xs
f :: Text -> Either String (Maybe Value)
f Text
k =
Either String (Maybe Value)
-> (Value -> Either String (Maybe Value))
-> Maybe Value
-> Either String (Maybe Value)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String (Maybe Value)
forall a b. a -> Either a b
Left (String -> Either String (Maybe Value))
-> String -> Either String (Maybe Value)
forall a b. (a -> b) -> a -> b
$ String
"missing variable: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
k) (Maybe Value -> Either String (Maybe Value)
forall a b. b -> Either a b
Right (Maybe Value -> Either String (Maybe Value))
-> (Value -> Maybe Value) -> Value -> Either String (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value
forall a. a -> Maybe a
Just)
(Maybe Value -> Either String (Maybe Value))
-> Maybe Value -> Either String (Maybe Value)
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
k Map Text Value
m
String
x <-
(String -> Q String)
-> (Builder -> Q String) -> Either String Builder -> Q String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Q String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Q String) -> (Builder -> String) -> Builder -> Q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
LazyText.unpack (Text -> String) -> (Builder -> Text) -> Builder -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
Builder.toLazyText)
(Either String Builder -> Q String)
-> Either String Builder -> Q String
forall a b. (a -> b) -> a -> b
$ (Text -> Either String (Maybe Value))
-> Template -> Either String Builder
forall (m :: * -> *).
Monad m =>
(Text -> m (Maybe Value)) -> Template -> m Builder
Expand.expandWith Text -> Either String (Maybe Value)
f Template
t
String -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift String
x
uriTemplate :: TH.QuasiQuoter
uriTemplate :: QuasiQuoter
uriTemplate = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
TH.QuasiQuoter
{ quoteDec :: String -> Q [Dec]
TH.quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot be used as a declaration"
, quoteExp :: String -> Q Exp
TH.quoteExp = Q Exp -> (Template -> Q Exp) -> Maybe Template -> Q Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid URI template") Template -> Q Exp
forall a. Data a => a -> Q Exp
TH.liftData (Maybe Template -> Q Exp)
-> (String -> Maybe Template) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Template
Parse.parse
, quotePat :: String -> Q Pat
TH.quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot be used as a pattern"
, quoteType :: String -> Q Type
TH.quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot be used as a type"
}