{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# 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(..))
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
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
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
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
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
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"
}
#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)
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