{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

-- XXX: Lift instances. Don't want to pollute main module with TH shenanigans.
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.EDN.QQ
  ( edn
  , ednList
  , ednMap
  , ednVec
  , ednSet
  , fromEDN
  ) where

import Data.Data (Data)
#if MIN_VERSION_base(4,13,0)
#else
import Data.Semigroup ((<>))
#endif
import Data.Text (Text)
import Data.Typeable (cast)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH.Syntax (Exp(..), Lift(..), Q)

import qualified Data.Text as Text
import qualified Data.Vector as Vector
import qualified Language.Haskell.TH.Syntax as TH

import Data.EDN (FromEDN, decodeText, parseText)
import Data.EDN.AST.Types (Tagged(..), Value(..))

-- | Quasiquoter for 'Data.EDN.TaggedValue'.
--
-- @
-- Tagged "foo" "bar" Nil === [edn| #foo/bar nil |]
-- @
edn :: QuasiQuoter
edn :: QuasiQuoter
edn = (String -> Q Exp) -> QuasiQuoter
ednQQ ((String -> Q Exp) -> QuasiQuoter)
-> (String -> Q Exp) -> QuasiQuoter
forall a b. (a -> b) -> a -> b
$ \String
str -> do
  String
src <- (Loc -> String) -> Q Loc -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Loc -> String
TH.loc_filename Q Loc
forall (m :: * -> *). Quasi m => m Loc
TH.qLocation

  case String -> Text -> Either String TaggedValue
parseText String
src (String -> Text
Text.pack String
str) of
    Right TaggedValue
val ->
      TaggedValue -> Q Exp
forall t. Lift t => t -> Q Exp
lift TaggedValue
val
    Left String
err ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error String
err

-- | Quasiquoter for untagged 'Value' wrapped in a List.
--
-- @
-- [ednList| #foo/bar nil |]
-- ===
-- List [ Tagged "foo" "bar" Nil ]
-- @
ednList :: QuasiQuoter
ednList :: QuasiQuoter
ednList = (String -> Q Exp) -> QuasiQuoter
ednQQ ((String -> Q Exp) -> QuasiQuoter)
-> (String -> Q Exp) -> QuasiQuoter
forall a b. (a -> b) -> a -> b
$ \String
str -> do
  String
src <- (Loc -> String) -> Q Loc -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Loc -> String
TH.loc_filename Q Loc
forall (m :: * -> *). Quasi m => m Loc
TH.qLocation
  let doc :: Text
doc = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

  case String -> Text -> Either String TaggedValue
parseText String
src Text
doc of
    Right (NoTag Value
tv) ->
      Value -> Q Exp
forall t. Lift t => t -> Q Exp
lift Value
tv
    Right Tagged{} ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error String
"unexpected tagged value"
    Left String
err ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error String
err

-- | Quasiquoter for untagged 'Value' wrapped in a Vec.
--
-- @
-- [ednVec| #foo/bar nil |]
-- ===
-- Vec [ Tagged "foo" "bar" Nil ]
-- @
ednVec :: QuasiQuoter
ednVec :: QuasiQuoter
ednVec = (String -> Q Exp) -> QuasiQuoter
ednQQ ((String -> Q Exp) -> QuasiQuoter)
-> (String -> Q Exp) -> QuasiQuoter
forall a b. (a -> b) -> a -> b
$ \String
str -> do
  String
src <- (Loc -> String) -> Q Loc -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Loc -> String
TH.loc_filename Q Loc
forall (m :: * -> *). Quasi m => m Loc
TH.qLocation
  let doc :: Text
doc = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

  case String -> Text -> Either String TaggedValue
parseText String
src Text
doc of
    Right (NoTag Value
tv) ->
      Value -> Q Exp
forall t. Lift t => t -> Q Exp
lift Value
tv
    Right Tagged{} ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error String
"unexpected tagged value"
    Left String
err ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error String
err

-- | Quasiquoter for untagged 'Value' wrapped in a Set.
--
-- @
-- [ednList| #foo/bar nil |]
-- ===
-- List [ Tagged "foo" "bar" Nil ]
-- @
ednSet :: QuasiQuoter
ednSet :: QuasiQuoter
ednSet = (String -> Q Exp) -> QuasiQuoter
ednQQ ((String -> Q Exp) -> QuasiQuoter)
-> (String -> Q Exp) -> QuasiQuoter
forall a b. (a -> b) -> a -> b
$ \String
str -> do
  String
src <- (Loc -> String) -> Q Loc -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Loc -> String
TH.loc_filename Q Loc
forall (m :: * -> *). Quasi m => m Loc
TH.qLocation
  let doc :: Text
doc = Text
"#{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"

  case String -> Text -> Either String TaggedValue
parseText String
src Text
doc of
    Right (NoTag Value
tv) ->
      Value -> Q Exp
forall t. Lift t => t -> Q Exp
lift Value
tv
    Right Tagged{} ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error String
"unexpected tagged value"
    Left String
err ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error String
err

-- | Quasiquoter for untagged 'Value' wrapped in a Map.
--
-- @
-- [ednMap| :key value |]
-- ===
-- Map [ (NoTag (Keyword "key"), NoTag (Symbol "" "value")) ]
-- @
ednMap :: QuasiQuoter
ednMap :: QuasiQuoter
ednMap = (String -> Q Exp) -> QuasiQuoter
ednQQ ((String -> Q Exp) -> QuasiQuoter)
-> (String -> Q Exp) -> QuasiQuoter
forall a b. (a -> b) -> a -> b
$ \String
str -> do
  String
src <- (Loc -> String) -> Q Loc -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Loc -> String
TH.loc_filename Q Loc
forall (m :: * -> *). Quasi m => m Loc
TH.qLocation
  let doc :: Text
doc = Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"

  case String -> Text -> Either String TaggedValue
parseText String
src Text
doc of
    Right (NoTag Value
tv) ->
      Value -> Q Exp
forall t. Lift t => t -> Q Exp
lift Value
tv
    Right Tagged{} ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error String
"unexpected tagged value"
    Left String
err ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error String
err

-- | Specializable QuasiQuoter for compile-time decoding.
--
-- > ednPerson = fromEDN @Person
--
-- And in another module (a TH restriction):
--
-- > theFred = [ednPerson| #myapp/Person { :first "Fred" } |]
fromEDN :: forall a. (Lift a, FromEDN a) => QuasiQuoter
fromEDN :: QuasiQuoter
fromEDN = (String -> Q Exp) -> QuasiQuoter
ednQQ ((String -> Q Exp) -> QuasiQuoter)
-> (String -> Q Exp) -> QuasiQuoter
forall a b. (a -> b) -> a -> b
$ \String
str -> do
  String
src <- (Loc -> String) -> Q Loc -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Loc -> String
TH.loc_filename Q Loc
forall (m :: * -> *). Quasi m => m Loc
TH.qLocation
  case String -> Text -> Either String a
forall a. FromEDN a => String -> Text -> Either String a
decodeText String
src (String -> Text
Text.pack String
str) of
    Left String
err ->
      String -> Q Exp
forall a. HasCallStack => String -> a
error String
err
    Right (a
val :: a) ->
      a -> Q Exp
forall t. Lift t => t -> Q Exp
lift a
val

ednQQ :: (String -> Q Exp) -> QuasiQuoter
ednQQ :: (String -> Q Exp) -> QuasiQuoter
ednQQ String -> Q Exp
qexp = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp  = String -> Q Exp
qexp
  , quotePat :: String -> Q Pat
quotePat  = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"EDN unavailable in patterns"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"EDN unavailable in types"
  , quoteDec :: String -> Q [Dec]
quoteDec  = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"EDN unavailable in declarations"
  }

-- XXX: Workaround for Text.pack not present in the same module with Text constructors.
-- See https://stackoverflow.com/a/38182444
#if MIN_VERSION_base(4,15,0)
liftData' :: (Data a, TH.Quote m) => a -> m Exp
#else
liftData' :: Data a => a -> Q Exp
#endif
liftData' :: a -> Q Exp
liftData' = (forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
forall a.
Data a =>
(forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
TH.dataToExpQ ((forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp)
-> (forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Text -> Q Exp) -> Maybe Text -> Maybe (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Q Exp
liftText (Maybe Text -> Maybe (Q Exp))
-> (b -> Maybe Text) -> b -> Maybe (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe Text
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast

#if MIN_VERSION_base(4,15,0)
liftText :: TH.Quote m => Text.Text -> m Exp
#else
liftText :: Text.Text -> Q Exp
#endif
liftText :: Text -> Q Exp
liftText Text
txt = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Text.pack) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Exp
forall t. Lift t => t -> Q Exp
lift (Text -> String
Text.unpack Text
txt)

#if MIN_VERSION_base(4,15,0)
liftVector :: (Lift a, TH.Quote m) => Vector.Vector a -> m Exp
#else
liftVector :: Lift a => Vector.Vector a -> Q Exp
#endif
liftVector :: Vector a -> Q Exp
liftVector Vector a
vec =
  Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Vector.fromList) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Q Exp
forall t. Lift t => t -> Q Exp
lift (Vector a -> [a]
forall a. Vector a -> [a]
Vector.toList Vector a
vec)

-- XXX: Workaround for undefined toConstr in Data instance for Vector.
instance Data a => Lift (Tagged Text a) where
  lift :: Tagged Text a -> Q Exp
lift = \case
    NoTag a
val -> do
      Exp
val' <- a -> Q Exp
forall a. Data a => a -> Q Exp
liftData' a
val
      Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'NoTag Exp -> Exp -> Exp
`AppE` Exp
val'
    Tagged Text
tagNS Text
tag a
val -> do
      Exp
tagNS' <- Text -> Q Exp
liftText Text
tagNS
      Exp
tag' <- Text -> Q Exp
liftText Text
tag
      Exp
val' <- a -> Q Exp
forall a. Data a => a -> Q Exp
liftData' a
val
      Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'Tagged Exp -> Exp -> Exp
`AppE` Exp
tagNS' Exp -> Exp -> Exp
`AppE` Exp
tag' Exp -> Exp -> Exp
`AppE` Exp
val'

#if MIN_VERSION_template_haskell(2,17,0)
  liftTyped = TH.unsafeCodeCoerce . lift
#elif MIN_VERSION_template_haskell(2,16,0)
  liftTyped :: Tagged Text a -> Q (TExp (Tagged Text a))
liftTyped = Q Exp -> Q (TExp (Tagged Text a))
forall a. Q Exp -> Q (TExp a)
TH.unsafeTExpCoerce (Q Exp -> Q (TExp (Tagged Text a)))
-> (Tagged Text a -> Q Exp)
-> Tagged Text a
-> Q (TExp (Tagged Text a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged Text a -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif

instance Lift Value where
  lift :: Value -> Q Exp
lift = \case
    Vec EDNVec
items ->
      Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Vec) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EDNVec -> Q Exp
forall a. Lift a => Vector a -> Q Exp
liftVector EDNVec
items
    Value
val ->
      Value -> Q Exp
forall a. Data a => a -> Q Exp
liftData' Value
val

#if MIN_VERSION_template_haskell(2,17,0)
  liftTyped = TH.unsafeCodeCoerce . lift
#elif MIN_VERSION_template_haskell(2,16,0)
  liftTyped :: Value -> Q (TExp Value)
liftTyped = Q Exp -> Q (TExp Value)
forall a. Q Exp -> Q (TExp a)
TH.unsafeTExpCoerce (Q Exp -> Q (TExp Value))
-> (Value -> Q Exp) -> Value -> Q (TExp Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Q Exp
forall t. Lift t => t -> Q Exp
lift
#endif