{-# 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 #-}
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 (..))
aliasList :: QuasiQuoter
aliasList :: QuasiQuoter
aliasList =
QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
quoteExp',
quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"can only be used as expression",
quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"can only be used as expression",
quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
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 = ReadPrec [(String, String)] -> Int -> ReadS [(String, String)]
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)]
_ -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"ambiguous parse"
[] -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"couldn't parse"
([(String, String)]
pairs, String
_) : [([(String, String)], String)]
_ ->
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
$ Exp -> Exp -> Exp
TH.AppE (Name -> Exp
VarE (String -> Name
mkName String
"aliasListBegin")) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
((String, String) -> Exp -> Exp)
-> Exp -> [(String, String)] -> Exp
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 (Exp -> Exp -> Exp) -> Exp -> Exp -> Exp
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 <-
ReadPrec (String, String)
-> ReadPrec () -> ReadPrec [(String, String)]
forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepEndBy1
ReadPrec (String, String)
parseAlias
( do
Punc String
punc <- ReadPrec Lexeme
lexP
Bool -> ReadPrec ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
punc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
",")
)
ReadP () -> ReadPrec ()
forall a. ReadP a -> ReadPrec a
lift ReadP ()
skipSpaces
ReadP () -> ReadPrec ()
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
Bool -> ReadPrec ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
punc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"=")
String String
theAlias <- ReadPrec Lexeme
lexP
(String, String) -> ReadPrec (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, String
theAlias)
sepEndBy :: Alternative m => m a -> m sep -> m [a]
sepEndBy :: m a -> m sep -> m [a]
sepEndBy m a
p m sep
sep = m a -> m sep -> m [a]
forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepEndBy1 m a
p m sep
sep m [a] -> m [a] -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> m [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
{-# INLINE sepEndBy #-}
sepEndBy1 :: Alternative m => m a -> m sep -> m [a]
sepEndBy1 :: m a -> m sep -> m [a]
sepEndBy1 m a
p m sep
sep = (a -> [a] -> [a]) -> m a -> m [a] -> m [a]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) m a
p ((m sep
sep m sep -> m [a] -> m [a]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a -> m sep -> m [a]
forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepEndBy m a
p m sep
sep) m [a] -> m [a] -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> m [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
{-# INLINEABLE sepEndBy1 #-}