QQ.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# 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)
import Data.Semigroup ((<>))
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, parseText, decodeText)
import Data.EDN.AST.Types (Tagged(..), Value(..))

-- | Quasiquoter for 'Data.EDN.TaggedValue'.
--
-- @
-- Tagged "foo" "bar" Nil === [edn| #foo/bar nil |]
-- @
edn :: QuasiQuoter
edn = ednQQ $ \str -> do
  src <- fmap loc_filename qLocation
  tv <- parseText src (Text.pack str)
  lift tv

-- | Quasiquoter for untagged 'Value' wrapped in a List.
--
-- @
-- [ednList| #foo/bar nil |]
-- ===
-- List [ Tagged "foo" "bar" Nil ]
-- @
ednList :: QuasiQuoter
ednList = ednQQ $ \str -> do
  src <- fmap loc_filename qLocation
  NoTag tv <- parseText src $ "(" <> Text.pack str <> ")"
  lift tv

-- | Quasiquoter for untagged 'Value' wrapped in a Vec.
--
-- @
-- [ednVec| #foo/bar nil |]
-- ===
-- Vec [ Tagged "foo" "bar" Nil ]
-- @
ednVec :: QuasiQuoter
ednVec = ednQQ $ \str -> do
  src <- fmap loc_filename qLocation
  NoTag tv <- parseText src $ "[" <> Text.pack str <> "]"
  lift tv

-- | Quasiquoter for untagged 'Value' wrapped in a Set.
--
-- @
-- [ednList| #foo/bar nil |]
-- ===
-- List [ Tagged "foo" "bar" Nil ]
-- @
ednSet :: QuasiQuoter
ednSet = ednQQ $ \str -> do
  src <- fmap loc_filename qLocation
  NoTag tv <- parseText src $ "#{" <> Text.pack str <> "}"
  lift tv

-- | Quasiquoter for untagged 'Value' wrapped in a Map.
--
-- @
-- [ednMap| :key value |]
-- ===
-- Map [ (NoTag (Keyword "key"), NoTag (Symbol "" "value")) ]
-- @
ednMap :: QuasiQuoter
ednMap = ednQQ $ \str -> do
  src <- fmap loc_filename qLocation
  NoTag tv <- parseText src $ "{" <> Text.pack str <> "}"
  lift tv

-- | 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 = ednQQ $ \str -> do
  src <- fmap loc_filename qLocation
  val <- decodeText src (Text.pack str) :: Q 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"
  }

-- XXX: Workaround for Text.pack not present in the same module with Text constructors.
-- See https://stackoverflow.com/a/38182444
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)

-- XXX: Workaround for undefined toConstr in Data instance for Vector.
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)