module Text.LaTeX.QQ (hat, hat', mkHaTeXQQ) where
import Text.LaTeX.QQ.Orphans ()
import Text.LaTeX.Utils (stripTeX)
import Control.Monad ((<=<))
import Data.Data (Typeable)
import qualified Data.Text as T
import Language.Haskell.AntiQuoter (AntiQuoterPass, (<>>))
import Language.Haskell.Meta.Parse.Careful (parseExp, parsePat)
import Language.Haskell.TH (Exp, ExpQ, Pat, PatQ)
import Language.Haskell.TH (stringL)
import Language.Haskell.TH (litE, litP, sigE)
import Language.Haskell.TH (appE, viewP)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Quote (dataToExpQ, dataToPatQ)
import Text.LaTeX (texy)
import Text.LaTeX.Base.Parser (parseLaTeX)
import Text.LaTeX.Base.Pretty (prettyLaTeX)
import Text.LaTeX.Base.Syntax (LaTeX (..), TeXArg (..))
hat :: QuasiQuoter
hat = mkHaTeXQQ "hask" False
hat' :: QuasiQuoter
hat' = mkHaTeXQQ "hask" True
mkHaTeXQQ :: String
-> Bool
-> QuasiQuoter
mkHaTeXQQ cmd triming =
let trimer | triming = trim
| otherwise = id
texTrimer | triming = viewP [| stripTeX |]
| otherwise = id
in QuasiQuoter { quoteType = const $ error "Type quoter not defined"
, quoteDec = const $ error "Dec quoter not defined"
, quoteExp = dataToExpQ (antiE cmd) <=< texExp . trimer
, quotePat = texTrimer . dataToPatQ (antiP cmd) <=< texExp . trimer
}
trim :: String -> String
trim = T.unpack . T.strip . T.pack
texExp :: Monad m => String -> m LaTeX
texExp src = case parseLaTeX (T.pack src) of
Right t -> return t
Left err -> error $ "malformed latex: " ++ show err
antiE :: Typeable e => String -> AntiQuoterPass e Exp
antiE cmd = antiTextE <>> antiE0 cmd <>> const Nothing
antiE0 :: String -> LaTeX -> Maybe ExpQ
antiE0 cmd (TeXComm s [FixArg src]) | cmd == s =
case parseExp $ prettyLaTeX src of
Right e -> Just [| texy $(return e) |]
Left e -> error $ "haskell parsing error " ++ show e
antiE0 _ _ = Nothing
antiP :: Typeable e => String -> AntiQuoterPass e Pat
antiP cmd = antiTextP <>> antiP0 cmd <>> const Nothing
antiTextE :: T.Text -> Maybe ExpQ
antiTextE = Just . flip sigE [t| T.Text |] . appE [| T.pack |] .
litE . stringL . T.unpack
antiTextP :: T.Text -> Maybe PatQ
antiTextP = Just . litP . stringL . T.unpack
antiP0 :: String -> LaTeX -> Maybe PatQ
antiP0 cmd (TeXComm name [FixArg src]) | cmd == name =
case parsePat $ prettyLaTeX src of
Right p -> Just $ return p
Left e -> error $ "haskell parsing error " ++ show e
antiP0 _ _ = Nothing