-- | This module defines quasiquoters for haskell-src-exts expressions and
-- declarations.
--
-- Antiquotations steal the splice syntax of Template Haskell, so for
-- example example 'x' appears antiquoted in @[$hs| $x ++ $(Hs.strE \"bar\") |]@.
-- Expressions appearing inside parenthesized splices are limited to concrete
-- syntax expressible by Template Haskell's 'Exp' data type.
--
-- Names in patterns can also be antiquoted, using double parentheses. For
-- instance:
--
-- > let x = Hs.name "n" in [hs| \ ((x)) -> $(Hs.Var (Hs.UnQual x)) + 1 |]
--
-- Alternatively, one can use the double underscore syntax, useful when
-- antiquoting a function name as in the following:
--
-- > let f = "incr"
-- > fE = Hs.Var $ Hs.UnQual $ Hs.name f
-- > in [hs| let __f__ x = x + 1 in $fE 10 |]
--
-- The double parentheses syntax is also used for antiquoting types. For
-- instance:
--
-- > let typ = Hs.TyCon (Hs.UnQual $ Hs.name "Int")
-- > in [hs| 1 :: ((typ)) |]
--
-- In a pattern context, antiquotations use the same syntax.
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
-- | A quasiquoter for expressions. All Haskell extensions known by
-- haskell-src-exts are activated by default.
hs :: QuasiQuoter
hs = hsWithMode allExtensions
-- | A quasiquoter for types. All Haskell extensions known by
-- haskell-src-exts are activated by default.
ty :: QuasiQuoter
ty = tyWithMode allExtensions
-- | A quasiquoter for a single top-level declaration.
dec :: QuasiQuoter
dec = decWithMode allExtensions
-- | A quasiquoter for multiple top-level declarations.
decs :: QuasiQuoter
decs = decsWithMode allExtensions
-- | A quasiquoter for patterns
pat :: QuasiQuoter
pat = patWithMode allExtensions
-- | Rather than importing the above quasiquoters, one can create custom
-- quasiquoters with a customized 'ParseMode' using this function.
--
-- > hs = hsWithMode mode
-- > dec = decWithMode mode
-- > decs = decsWithMode mode
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
-- Implementation note, to parse multiple decls it's (ab)used that a
-- listing of decls (possibly with import istatements and other extras)
-- is a valid module.
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
-- | The generic functions in 'Language.Haskell.TH.Quote' don't use global
-- names for syntax constructors previous to GHC 7.4.1. This has the unfortunate
-- effect of breaking quotation when the haskell-src-exts syntax module is
-- imported qualified. The solution is to set the flavour of all names to
-- 'NameG' on older versions of GHC.
-- See also <http://www.haskell.org/pipermail/glasgow-haskell-users/2013-February/023793.html>.
qualify :: Name -> Name
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 704
-- Need special cases for constructors used in string literals. Assume nearly
-- all else is a datatype defined in Syntax module of haskell-src-exts.
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 is also exported by Data.Generics
| "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