{-# 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, dataToExpQ, loc_filename, qLocation)
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import Data.EDN (FromEDN, decodeText, parseText)
import Data.EDN.AST.Types (Tagged(..), Value(..))
edn :: QuasiQuoter
edn = ednQQ $ \str -> do
src <- fmap loc_filename qLocation
case parseText src (Text.pack str) of
Right val ->
lift val
Left err ->
error err
ednList :: QuasiQuoter
ednList = ednQQ $ \str -> do
src <- fmap loc_filename qLocation
let doc = "(" <> Text.pack str <> ")"
case parseText src doc of
Right (NoTag tv) ->
lift tv
Right Tagged{} ->
error "unexpected tagged value"
Left err ->
error err
ednVec :: QuasiQuoter
ednVec = ednQQ $ \str -> do
src <- fmap loc_filename qLocation
let doc = "[" <> Text.pack str <> "]"
case parseText src doc of
Right (NoTag tv) ->
lift tv
Right Tagged{} ->
error "unexpected tagged value"
Left err ->
error err
ednSet :: QuasiQuoter
ednSet = ednQQ $ \str -> do
src <- fmap loc_filename qLocation
let doc = "#{" <> Text.pack str <> "}"
case parseText src doc of
Right (NoTag tv) ->
lift tv
Right Tagged{} ->
error "unexpected tagged value"
Left err ->
error err
ednMap :: QuasiQuoter
ednMap = ednQQ $ \str -> do
src <- fmap loc_filename qLocation
let doc = "{" <> Text.pack str <> "}"
case parseText src doc of
Right (NoTag tv) ->
lift tv
Right Tagged{} ->
error "unexpected tagged value"
Left err ->
error err
fromEDN :: forall a. (Lift a, FromEDN a) => QuasiQuoter
fromEDN = ednQQ $ \str -> do
src <- fmap loc_filename qLocation
case decodeText src (Text.pack str) of
Left err ->
error err
Right (val :: a) ->
lift val
ednQQ :: (String -> Q Exp) -> QuasiQuoter
ednQQ qexp = QuasiQuoter
{ quoteExp = qexp
, quotePat = error "EDN unavailable in patterns"
, quoteType = error "EDN unavailable in types"
, quoteDec = error "EDN unavailable in declarations"
}
liftData' :: Data a => a -> Q Exp
liftData' = dataToExpQ $ fmap liftText . cast
liftText :: Text.Text -> Q Exp
liftText txt = AppE (VarE 'Text.pack) <$> lift (Text.unpack txt)
instance Data a => Lift (Tagged Text a) where
lift = \case
NoTag val -> do
val' <- liftData' val
pure $ ConE 'NoTag `AppE` val'
Tagged tagNS tag val -> do
tagNS' <- liftText tagNS
tag' <- liftText tag
val' <- liftData' val
pure $ ConE 'Tagged `AppE` tagNS' `AppE` tag' `AppE` val'
instance Lift Value where
lift = \case
Vec items ->
AppE (ConE 'Vec) <$> liftVector items
val ->
liftData' val
liftVector :: Lift a => Vector.Vector a -> Q Exp
liftVector vec =
AppE (VarE 'Vector.fromList) <$> lift (Vector.toList vec)