module Language.Haskell.Exts.QQ
( hs
, dec
, decs
, pat
, ty
, hsWithMode
, decWithMode
, decsWithMode
, patWithMode
, tyWithMode
) where
import qualified Language.Haskell.Exts as Hs
import qualified Language.Haskell.Meta.Syntax.Translate as Hs
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Lib
import Data.Generics
import Data.List (intercalate, isPrefixOf, isSuffixOf)
allExtensions :: Hs.ParseMode
allExtensions = Hs.defaultParseMode{Hs.extensions = known}
where
#if MIN_VERSION_haskell_src_exts(1,14,0)
known = [ext | ext@Hs.EnableExtension{} <- Hs.knownExtensions]
#else
known = Hs.knownExtensions
#endif
hs :: QuasiQuoter
hs = hsWithMode allExtensions
ty :: QuasiQuoter
ty = tyWithMode allExtensions
dec :: QuasiQuoter
dec = decWithMode allExtensions
decs :: QuasiQuoter
decs = decsWithMode allExtensions
pat :: QuasiQuoter
pat = patWithMode allExtensions
hsWithMode :: Hs.ParseMode -> QuasiQuoter
hsWithMode = qq . Hs.parseExpWithMode
decWithMode :: Hs.ParseMode -> QuasiQuoter
decWithMode = qq . Hs.parseDeclWithMode
decsWithMode :: Hs.ParseMode -> QuasiQuoter
decsWithMode mode = qq $ \src -> fmap strip $ Hs.parseModuleWithMode mode src
where
strip :: Hs.Module -> [Hs.Decl]
strip (Hs.Module _ _ _ _ _ _ decs) = decs
tyWithMode :: Hs.ParseMode -> QuasiQuoter
tyWithMode = qq . Hs.parseTypeWithMode
patWithMode :: Hs.ParseMode -> QuasiQuoter
patWithMode = qq . Hs.parsePatWithMode
qq :: Data a => (String -> Hs.ParseResult a) -> QuasiQuoter
qq parser = QuasiQuoter { quoteExp = parser `project` antiquoteExp
, quotePat = parser `project` antiquotePat
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 613
, quoteType = error "Unimplemented."
, quoteDec = error "Unimplemented."
#endif
}
project f k s = case f s of
Hs.ParseOk x -> k x
Hs.ParseFailed loc err -> fail err
qualify :: Name -> Name
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 704
qualify n | ":" <- nameBase n = '(:)
| "[]" <- nameBase n = '[]
| "(,)" <- nameBase n = '(,)
| "Nothing" <- nameBase n = 'Nothing
| "Just" <- nameBase n = 'Just
| "True" <- nameBase n = 'True
| "False" <- nameBase n = 'False
| "Left" <- nameBase n = 'Left
| "Right" <- nameBase n = 'Right
| "LT" <- nameBase n = 'LT
| "EQ" <- nameBase n = 'EQ
| "GT" <- nameBase n = 'Prelude.GT
| "SrcLoc" <- nameBase n = 'Hs.SrcLoc
| "Boxed" <- nameBase n = 'Hs.Boxed
| otherwise = Name (mkOccName (nameBase n)) flavour
where pkg = "haskell-src-exts-" ++ VERSION_haskell_src_exts
flavour = NameG VarName (mkPkgName pkg)
(mkModName "Language.Haskell.Exts.Syntax")
#else
qualify n = n
#endif
antiquoteExp :: Data a => a -> Q Exp
antiquoteExp t = dataToQa (conE . qualify) litE (foldl appE)
(const Nothing `extQ` antiE `extQ` antiP `extQ` antiN `extQ` antiT) t
where antiE (Hs.SpliceExp (Hs.IdSplice v)) = Just $ varE $ mkName v
antiE (Hs.SpliceExp (Hs.ParenSplice e)) = Just $ return $ Hs.toExp e
antiE _ = Nothing
antiP (Hs.PParen (Hs.PParen (Hs.PVar (Hs.Ident n)))) =
Just $ appE [| Hs.PVar |] (varE (mkName n))
antiP _ = Nothing
antiT (Hs.TyParen (Hs.TyParen (Hs.TyVar (Hs.Ident n)))) = Just . varE $ mkName n
antiT _ = Nothing
antiN (Hs.Ident n) | "__" `isPrefixOf` n, "__" `isSuffixOf` n =
let nn = take (length n 4) (drop 2 n)
in Just $ appE [| Hs.Ident |] (varE (mkName nn))
antiN _ = Nothing
antiquotePat :: Data a => a -> Q Pat
antiquotePat = dataToQa qualify litP conP (const Nothing `extQ` antiP)
where antiP (Hs.PParen (Hs.PParen (Hs.PVar (Hs.Ident n)))) =
Just $ conP 'Hs.PVar [varP (mkName n)]
antiP _ = Nothing