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

-- | This can be used together with the @TemplateHaskell@ language extension to
-- expand a URI template at compile time. This is slightly different from
-- 'Expand.expand' in that missing variables will throw an exception. This is
-- convenient because it allows you to verify that all of the variables have
-- been supplied at compile time.
--
-- >>> :set -XQuasiQuotes -XTemplateHaskell
-- >>> import Burrito
-- >>> $( expandTH [("foo", stringValue "bar")] [uriTemplate|l-{foo}-r|] )
-- "l-bar-r"
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

-- | This can be used together with the @QuasiQuotes@ language extension to
-- parse a URI template at compile time. This is convenient because it allows
-- you to verify the validity of the template when you compile your file as
-- opposed to when you run it.
--
-- >>> :set -XQuasiQuotes
-- >>> import Burrito
-- >>> let template = [uriTemplate|http://example/search{?query}|]
-- >>> let values = [("query", stringValue "chorizo")]
-- >>> expand values template
-- "http://example/search?query=chorizo"
--
-- Note that you cannot use escape sequences in this quasi-quoter. For example,
-- this is invalid: @[uriTemplate|\\xa0|]@. You can however use percent encoded
-- triples as normal. So this is valid: @[uriTemplate|%c2%a0|]@.
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"
  }