{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module Text.XML.Twiml.Internal.TH
( TwimlSpec(..)
, example
, exampleSpec
, runTwimlSpecParser
, twimlSpecToData
, twimlSpecStringToData
, s
) where
import Control.Monad
import Data.Char
import Data.Default
import Data.Maybe
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Text.Parsec
example :: String
example = unlines [
"Say",
" required",
" String",
" attributes",
" voice, Voice",
" loop, Bool",
" recursive" ]
exampleSpec :: TwimlSpec
exampleSpec = case runTwimlSpecParser example of
Right exampleSpec' -> exampleSpec'
Left parseError -> error $ show parseError
data TwimlSpec = TwimlSpec
{ twimlName :: String
, parameters :: [Parameters]
, recursive :: Bool
, toXMLForGADT :: Bool
, toAttrsForAttributes :: Bool
} deriving Show
instance Default TwimlSpec where
def = TwimlSpec def def False False False
data Parameters
= Required { getRequiredTypes :: [String] }
| Attributes { getAttributes :: [Attribute] }
deriving Show
data Attribute = Attribute
{ attributeName :: String
, attributeType :: String
, overrideName :: Maybe String
} deriving Show
isRequired :: Parameters -> Bool
isRequired (Required _) = True
isRequired _ = False
isAttributes :: Parameters -> Bool
isAttributes (Attributes _) = True
isAttributes _ = False
getAllRequired :: [Parameters] -> [String]
getAllRequired = concatMap getRequiredTypes . filter isRequired
getAllAttributes :: [Parameters] -> [Attribute]
getAllAttributes = concatMap getAttributes . filter isAttributes
hasAttributes :: TwimlSpec -> Bool
hasAttributes = not . null . getAllAttributes . parameters
attributeToVarStrictType :: (String -> String) -> Attribute -> VarStrictType
attributeToVarStrictType f Attribute{..} =
( mkName $ f attributeName
#if MIN_VERSION_template_haskell(2,11,0)
, Bang NoSourceUnpackedness SourceStrict
#else
, IsStrict
#endif
, AppT (ConT $ mkName "Maybe") (ConT $ mkName attributeType)
)
parametersToVarStrictTypes :: (String -> String) -> [Parameters] -> [VarStrictType]
parametersToVarStrictTypes f = map (attributeToVarStrictType f) . getAllAttributes
specToGADTName :: TwimlSpec -> Name
specToGADTName TwimlSpec{..} = mkName $ twimlName ++ "F"
specToAttributesName :: TwimlSpec -> Name
specToAttributesName TwimlSpec{..} = mkName $ twimlName ++ "Attributes"
specToGADTArity :: TwimlSpec -> Int
specToGADTArity spec@(TwimlSpec{..}) = length (getAllRequired parameters) + (if hasAttributes spec then 1 else 0) + (if recursive then 1 else 0)
specToGADTNames :: TwimlSpec -> [Name]
specToGADTNames spec@(TwimlSpec{..}) =
take (specToGADTArity spec) $ map (mkName . return) ['a'..'z']
specToGADTAttributesName :: TwimlSpec -> Maybe Name
specToGADTAttributesName spec@(TwimlSpec{..}) = go $ zip parameters $ specToGADTNames spec where
go [] = Nothing
go ((Required _, _):rest) = go rest
go ((Attributes _, name):_) = Just name
specToGADTChildName :: TwimlSpec -> Maybe Name
specToGADTChildName spec@(TwimlSpec{..}) = go $ zip parameters $ specToGADTNames spec where
go [] = Nothing
go ((Required _, name):_) = Just name
go ((Attributes _, _):rest) = go rest
specToGADTPat :: TwimlSpec -> Pat
specToGADTPat spec@(TwimlSpec{..}) = ConP (specToGADTName spec) varPs where
varPs = map VarP $ specToGADTNames spec
specToAttributesListE :: TwimlSpec -> Exp
specToAttributesListE (TwimlSpec{..}) = ListE . map go $ getAllAttributes parameters where
go (Attribute{..}) =
let name = LitE . StringL $ fromMaybe attributeName overrideName
in AppE (AppE (VarE $ mkName "makeAttr") name) (VarE . mkName $ makeAttr attributeName)
attrPrefix = '_' : map toLower twimlName
makeAttr (a:ttrName) = attrPrefix ++ toUpper a : ttrName
makeAttr _ = error "Unsupported"
specToToXML :: TwimlSpec -> Exp
specToToXML spec@(TwimlSpec{..}) = UInfixE (AppE (AppE (AppE (VarE $ mkName "makeElement") (LitE $ StringL twimlName)) (AppE (VarE $ mkName "toSomeNode") child)) attributesE) (ConE $ mkName ":") next where
child = maybe (TupE []) VarE $ specToGADTChildName spec
attributesE = maybe (ListE []) (AppE (VarE $ mkName "toAttrs") . VarE) $ specToGADTAttributesName spec
next = if recursive
then AppE (VarE $ mkName "toXML") (VarE . last $ specToGADTNames spec)
else ListE []
specToStrictTypes :: TwimlSpec -> [StrictType]
#if MIN_VERSION_template_haskell(2,11,0)
specToStrictTypes spec@(TwimlSpec{..}) = go parameters ++ [(Bang NoSourceUnpackedness NoSourceStrictness, VarT $ mkName "a") | recursive] where
#else
specToStrictTypes spec@(TwimlSpec{..}) = go parameters ++ [(NotStrict, VarT $ mkName "a") | recursive] where
#endif
go [] = []
go (Required as :bs) = map stringToStrictType as ++ go bs
#if MIN_VERSION_template_haskell(2,11,0)
go (Attributes _ :bs) = (Bang NoSourceUnpackedness NoSourceStrictness, ConT $ specToAttributesName spec) : go bs
#else
go (Attributes _ :bs) = (NotStrict, ConT $ specToAttributesName spec) : go bs
#endif
#if MIN_VERSION_template_haskell(2,11,0)
stringToStrictType a = (Bang NoSourceUnpackedness NoSourceStrictness, ConT $ mkName a)
#else
stringToStrictType a = (NotStrict, ConT $ mkName a)
#endif
attributesToDefExp :: Exp -> [Parameters] -> Exp
attributesToDefExp conE = go conE . length . getAllAttributes where
go conE 0 = conE
go conE n = go (AppE conE defE) (n-1)
defE = VarE $ mkName "def"
instance Default Attribute where
def = Attribute def def def
parseTwimlSpec :: Parsec String () TwimlSpec
parseTwimlSpec = do
twimlName <- parseTwimlName
parameters <- parseParameters
recursive <- option False $ try parseRecursive
toXMLForGADT <- option False parseToXMLForGADT
toAttrsForAttributes <- option False parseToAttrsForAttributes
eof
return $ TwimlSpec twimlName parameters recursive toXMLForGADT toAttrsForAttributes
parseTwimlName :: Parsec String () String
parseTwimlName = many1 letter <* newline
parseParameters :: Parsec String () [Parameters]
parseParameters = many (try parseRequiredSection <|> try parseAttributesSection)
parseRequiredSection :: Parsec String () Parameters
parseRequiredSection = do
string " required"; newline
Required <$> many (try parseRequired)
parseRequired :: Parsec String () String
parseRequired =
string " " >> many1 (noneOf "\n") <* newline
parseAttributesSection :: Parsec String () Parameters
parseAttributesSection = do
string " attributes"; newline
Attributes <$> many (try parseAttribute)
parseAttribute :: Parsec String () Attribute
parseAttribute = do
string " "
abc <- many1 (noneOf ",\n") `sepBy` string ", " <* newline
case abc of
[a,b] -> return $ Attribute a b Nothing
a:b:[c] -> return . Attribute a b $ Just c
_ -> mzero
parseRecursive :: Parsec String () Bool
parseRecursive =
const True <$> string " recursive" <* newline
parseToXMLForGADT :: Parsec String () Bool
parseToXMLForGADT =
const True <$> string " toXMLForGADT" <* newline
parseToAttrsForAttributes :: Parsec String () Bool
parseToAttrsForAttributes =
const True <$> string " toAttrsForAttributes" <* newline
runTwimlSpecParser :: String -> Either ParseError TwimlSpec
runTwimlSpecParser = runParser parseTwimlSpec () ""
s :: QuasiQuoter
s = QuasiQuoter {
quoteExp = stringE . trim
, quotePat = undefined
, quoteType = undefined
, quoteDec = undefined
}
trim :: String -> String
trim = trimTail . dropWhile isSpace
trimTail :: String -> String
trimTail "" = "\n"
trimTail s = take (lastNonBlank s) s ++ "\n"
where lastNonBlank = (+1) . fst . foldl acc (0, 0)
acc (l, n) c | isSpace c = (l, n + 1)
| otherwise = (n, n + 1)
twimlSpecStringToData :: String -> DecsQ
twimlSpecStringToData str = case runTwimlSpecParser str of
Right twimlSpec -> twimlSpecToData twimlSpec
Left msg -> error $ show msg
twimlSpecToData :: TwimlSpec -> DecsQ
twimlSpecToData spec@(TwimlSpec{..}) = pure $
[ emptyDataDecl
, gadt
, deriveFunctorForGADT
, instanceFunctor1ForGADT
, deriveShowForGADT
, attributes
, instanceDefaultForAttributes
]
++ [instanceToXMLForGADT | toXMLForGADT]
++ [instanceToAttrsForAttributes | toAttrsForAttributes]
where
conName = mkName twimlName
#if MIN_VERSION_template_haskell(2,12,0)
emptyDataDecl = DataD [] conName [] Nothing [] [DerivClause Nothing []]
#else
#if MIN_VERSION_template_haskell(2,11,0)
emptyDataDecl = DataD [] conName [] Nothing [] []
#else
emptyDataDecl = DataD [] conName [] [] []
#endif
#endif
i' = mkName "i"
a' = mkName "a"
i = VarT i'
a = VarT a'
tyVarBndrs = [KindedTV i' $ AppT ListT StarT, PlainTV a']
proxy = ConT $ mkName "Proxy"
proxyI = AppT proxy i
list = AppT (AppT PromotedConsT (ConT conName)) PromotedNilT
proxyList = AppT proxy list
cxt' = [AppT (AppT EqualityT proxyI) proxyList]
conNameF = mkName $ twimlName ++ "F"
con = ForallC [] cxt'
. NormalC conNameF $ specToStrictTypes spec
#if MIN_VERSION_template_haskell(2,12,0)
gadt = DataD [] conNameF tyVarBndrs Nothing [con] [DerivClause Nothing []]
#else
#if MIN_VERSION_template_haskell(2,11,0)
gadt = DataD [] conNameF tyVarBndrs Nothing [con] []
#else
gadt = DataD [] conNameF tyVarBndrs [con] []
#endif
#endif
dataN = mkName "Data"
defaultN = mkName "Default"
defaultC = ConT defaultN
eqN = mkName "Eq"
functorN = mkName "Functor"
functorC = ConT functorN
functor1N = mkName "Functor1"
functor1C = ConT functor1N
genericN = mkName "Generic"
nfdataN = mkName "NFData"
ordN = mkName "Ord"
readN = mkName "Read"
showN = mkName "Show"
showC = ConT showN
toAttrsN = mkName "ToAttrs"
toAttrsC = ConT toAttrsN
toXMLN = mkName "ToXML"
toXMLC = ConT toXMLN
#if MIN_VERSION_template_haskell(2,11,0)
#else
#endif
#if MIN_VERSION_template_haskell(2,12,0)
#else
#endif
#if MIN_VERSION_template_haskell(2,12,0)
#else
#endif
#if MIN_VERSION_template_haskell(2,12,0)
deriveFunctorForGADT = StandaloneDerivD Nothing [] $ AppT functorC (AppT (ConT conNameF) i)
#else
deriveFunctorForGADT = StandaloneDerivD [] $ AppT functorC (AppT (ConT conNameF) i)
#endif
#if MIN_VERSION_template_haskell(2,11,0)
instanceFunctor1ForGADT = InstanceD Nothing [] (AppT functor1C $ ConT conNameF) [ValD (VarP $ mkName "fmap1") (NormalB . VarE $ mkName "fmap") []]
#else
instanceFunctor1ForGADT = InstanceD [] (AppT functor1C $ ConT conNameF) [ValD (VarP $ mkName "fmap1") (NormalB . VarE $ mkName "fmap") []]
#endif
#if MIN_VERSION_template_haskell(2,11,0)
#else
#endif
#if MIN_VERSION_template_haskell(2,12,0)
#else
#endif
#if MIN_VERSION_template_haskell(2,12,0)
#else
#endif
#if MIN_VERSION_template_haskell(2,12,0)
deriveShowForGADT = StandaloneDerivD Nothing [AppT showC a] $ AppT showC (AppT (AppT (ConT conNameF) i) a)
#else
deriveShowForGADT = StandaloneDerivD [AppT showC a] $ AppT showC (AppT (AppT (ConT conNameF) i) a)
#endif
#if MIN_VERSION_template_haskell(2,11,0)
instanceToXMLForGADT = InstanceD Nothing [AppT toXMLC a | recursive] (AppT toXMLC (AppT (AppT (ConT conNameF) i) a))
#else
instanceToXMLForGADT = InstanceD [AppT toXMLC a | recursive] (AppT toXMLC (AppT (AppT (ConT conNameF) i) a))
#endif
[FunD (mkName "toXML") [Clause [specToGADTPat spec] (NormalB $ specToToXML spec) []]]
attrPrefix = '_' : map toLower twimlName
makeAttr (a:ttrName) = attrPrefix ++ toUpper a : ttrName
makeAttr _ = error "Unsupported"
attributesName = specToAttributesName spec
#if MIN_VERSION_template_haskell(2,12,0)
attributes = DataD [] attributesName [] Nothing [RecC attributesName (parametersToVarStrictTypes makeAttr parameters)] . pure . DerivClause Nothing $ ConT <$> [dataN, eqN, genericN, nfdataN, ordN, readN, showN]
#else
#if MIN_VERSION_template_haskell(2,11,0)
attributes = DataD [] attributesName [] Nothing [RecC attributesName (parametersToVarStrictTypes makeAttr parameters)] $ ConT <$> [dataN, eqN, genericN, nfdataN, ordN, readN, showN]
#else
attributes = DataD [] attributesName [] [RecC attributesName (parametersToVarStrictTypes makeAttr parameters)] [dataN, eqN, genericN, nfdataN, ordN, readN, showN]
#endif
#endif
#if MIN_VERSION_template_haskell(2,11,0)
instanceDefaultForAttributes = InstanceD Nothing [] (AppT defaultC $ ConT attributesName) [ValD (VarP $ mkName "def") (NormalB $ attributesToDefExp (ConE attributesName) parameters) []]
#else
instanceDefaultForAttributes = InstanceD [] (AppT defaultC $ ConT attributesName) [ValD (VarP $ mkName "def") (NormalB $ attributesToDefExp (ConE attributesName) parameters) []]
#endif
#if MIN_VERSION_template_haskell(2,11,0)
instanceToAttrsForAttributes = InstanceD Nothing [] (AppT toAttrsC $ ConT attributesName) [ValD (VarP $ mkName "toAttrs") (NormalB (AppE (AppE (VarE $ mkName "flip") (VarE $ mkName "makeAttrs")) (specToAttributesListE spec))) []]
#else
instanceToAttrsForAttributes = InstanceD [] (AppT toAttrsC $ ConT attributesName) [ValD (VarP $ mkName "toAttrs") (NormalB (AppE (AppE (VarE $ mkName "flip") (VarE $ mkName "makeAttrs")) (specToAttributesListE spec))) []]
#endif