{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

-- | This module provides a quasiquoter which makes it a bit easier to define
-- lists of textual aliases.
--
-- >>> :{
-- data Foo = Foo {xa :: Int, xb :: Bool, xc :: Char, xd :: String, xe :: Int}
--            deriving stock (Read, Show, Eq, Generic)
--            deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo)
-- instance Aliased JSON Foo where
--   aliases = [aliasList| 
--      xa = "aax",
--      xb = "bbx",
--      xc = "ccx",
--      xd = "ddx",
--      xe = "eex",
--    |]
-- :}
--
--
module ByOtherNames.TH (aliasList) where

import Control.Applicative
import Control.Monad
import GHC.Read
import Language.Haskell.TH
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote
import Text.ParserCombinators.ReadP
import Text.ParserCombinators.ReadPrec
import Text.Read.Lex (Lexeme (..))

-- if you are only interested in defining a quasiquoter to be used for
-- expressions, you would define a QuasiQuoter with only quoteExp, and leave
-- the other fields stubbed out with errors.
aliasList :: QuasiQuoter
aliasList :: QuasiQuoter
aliasList =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
quoteExp',
      quotePat :: String -> Q Pat
quotePat = forall a. HasCallStack => String -> a
error String
"can only be used as expression",
      quoteType :: String -> Q Type
quoteType = forall a. HasCallStack => String -> a
error String
"can only be used as expression",
      quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => String -> a
error String
"can only be used as expression"
    }

quoteExp' :: String -> Q Exp
quoteExp' :: String -> Q Exp
quoteExp' String
input = do
  let parsed :: [([(String, String)], String)]
parsed = forall a. ReadPrec a -> Int -> ReadS a
readPrec_to_S ReadPrec [(String, String)]
parseManyAlias Int
0 String
input
  case [([(String, String)], String)]
parsed of
    ([(String, String)], String)
_ : ([(String, String)], String)
_ : [([(String, String)], String)]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"ambiguous parse"
    [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"couldn't parse"
    ([(String, String)]
pairs, String
_) : [([(String, String)], String)]
_ ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
TH.AppE (Name -> Exp
VarE (String -> Name
mkName String
"aliasListBegin")) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, String) -> Exp -> Exp
addAlias (Name -> Exp
VarE (String -> Name
mkName String
"aliasListEnd")) [(String, String)]
pairs
  where
    addAlias :: (String, String) -> Exp -> Exp
addAlias (String
fieldName, String
fieldAlias) =
      Exp -> Exp -> Exp
TH.AppE forall a b. (a -> b) -> a -> b
$
        Name -> Exp
VarE (String -> Name
mkName String
"alias") Exp -> Type -> Exp
`TH.AppTypeE` TyLit -> Type
LitT (String -> TyLit
StrTyLit String
fieldName) Exp -> Exp -> Exp
`TH.AppE` Lit -> Exp
LitE (String -> Lit
StringL String
fieldAlias)

parseManyAlias :: ReadPrec [(String, String)]
parseManyAlias :: ReadPrec [(String, String)]
parseManyAlias = do
  [(String, String)]
pairs <-
    forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepEndBy1
      ReadPrec (String, String)
parseAlias
      ( do
          Punc String
punc <- ReadPrec Lexeme
lexP
          forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
punc forall a. Eq a => a -> a -> Bool
== String
",")
      )
  forall a. ReadP a -> ReadPrec a
lift ReadP ()
skipSpaces
  forall a. ReadP a -> ReadPrec a
lift ReadP ()
eof
  return [(String, String)]
pairs

parseAlias :: ReadPrec (String, String)
parseAlias :: ReadPrec (String, String)
parseAlias = do
  Ident String
name <- ReadPrec Lexeme
lexP
  Punc String
punc <- ReadPrec Lexeme
lexP
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
punc forall a. Eq a => a -> a -> Bool
== String
"=")
  String String
theAlias <- ReadPrec Lexeme
lexP
  forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, String
theAlias)

-- how to use standard ReadP combinators here?
--
-- https://hackage.haskell.org/package/parser-combinators

-- | @'sepEndBy' p sep@ parses /zero/ or more occurrences of @p@, separated
-- and optionally ended by @sep@. Returns a list of values returned by @p@.
sepEndBy :: Alternative m => m a -> m sep -> m [a]
sepEndBy :: forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepEndBy m a
p m sep
sep = forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepEndBy1 m a
p m sep
sep forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
{-# INLINE sepEndBy #-}

-- | @'sepEndBy1' p sep@ parses /one/ or more occurrences of @p@, separated
-- and optionally ended by @sep@. Returns a list of values returned by @p@.
sepEndBy1 :: Alternative m => m a -> m sep -> m [a]
sepEndBy1 :: forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepEndBy1 m a
p m sep
sep = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) m a
p ((m sep
sep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepEndBy m a
p m sep
sep) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
{-# INLINEABLE sepEndBy1 #-}

-- $setup
--
-- >>> :set -XBlockArguments
-- >>> :set -XTypeApplications
-- >>> :set -XDerivingStrategies
-- >>> :set -XDerivingVia
-- >>> :set -XDataKinds
-- >>> :set -XMultiParamTypeClasses
-- >>> :set -XDeriveGeneric
-- >>> :set -XOverloadedStrings
-- >>> :set -XTemplateHaskell
-- >>> :set -XQuasiQuotes
-- >>> import ByOtherNames.Aeson
-- >>> import ByOtherNames.TH
-- >>> import Data.Aeson
-- >>> import Data.Aeson.Types
-- >>> import GHC.Generics
-- >>> import GHC.TypeLits