module Language.Haskell.Exts.QQ (hs, dec) where
import qualified Language.Haskell.Exts as Hs
import qualified Language.Haskell.Exts.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)
hs = QuasiQuoter { quoteExp = Hs.parseExpWithMode
Hs.defaultParseMode{Hs.extensions = Hs.knownExtensions}
`project` antiquoteExp
, quotePat = Hs.parsePat `project` antiquotePat
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 613
, quoteType = error "Unimplemented."
, quoteDec = error "Unimplemented."
#endif
}
dec = QuasiQuoter { quoteExp = Hs.parseDeclWithMode
Hs.defaultParseMode{Hs.extensions = Hs.knownExtensions}
`project` antiquoteExp
, quotePat = Hs.parsePat `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
qualify n | ":" <- nameBase n = '(:)
| "[]" <- nameBase n = '[]
| "Nothing" <- nameBase n = '[]
| "Just" <- nameBase n = 'Just
| "SrcLoc" <- nameBase n = 'Hs.SrcLoc
| 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")
antiquoteExp :: Data a => a -> Q Exp
antiquoteExp t = dataToQa (conE . qualify) litE (foldl appE)
(const Nothing `extQ` antiE `extQ` antiP) 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
antiquotePat :: Data a => a -> Q Pat
antiquotePat = dataToQa qualify litP conP (const Nothing `extQ` antiP)
where antiE (Hs.SpliceExp (Hs.IdSplice v)) = Just $ varP $ mkName v
antiE (Hs.SpliceExp (Hs.ParenSplice e)) =
case Hs.parsePat $ Hs.prettyPrint e of
Hs.ParseOk p -> Just $ return $ Hs.toPat p
Hs.ParseFailed _ err -> Just $ fail err
antiE _ = Nothing
antiP (Hs.PParen (Hs.PParen (Hs.PVar (Hs.Ident n)))) =
Just $ conP 'Hs.PVar [varP (mkName n)]
antiP _ = Nothing