{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}
module Text.Nowdoc (nowdoc, txtfile, binfile) where
import Data.List (dropWhileEnd)
import Data.Char (isSpace)
import Language.Haskell.TH (ExpQ, stringE, runIO)
import Language.Haskell.TH.Syntax (addDependentFile)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import qualified Data.ByteString.Char8 as BSC
nowdoc :: QuasiQuoter
nowdoc = qq { quoteExp = stringE . unescape . \case '\n' : cs -> cs; cs -> cs }
unescape :: String -> String
unescape ('|' : cs) = case span (== ' ') cs of
(_ : ss, ']' : cs') -> '|' : ss ++ "]" ++ unescape cs'
(ss, cs') -> '|' : ss ++ unescape cs'
unescape (c : cs) = c : unescape cs
unescape "" = ""
txtfile :: QuasiQuoter
txtfile = qq { quoteExp = toQ readFile }
toQ :: (FilePath -> IO String) -> FilePath -> ExpQ
toQ rf fp_ = do
cnt <- runIO $ rf fp
addDependentFile fp
stringE cnt
where fp = dropBoth isSpace fp_
binfile :: QuasiQuoter
binfile = qq { quoteExp = toQ $ (BSC.unpack <$>) . BSC.readFile }
qq :: QuasiQuoter
qq = QuasiQuoter {
quoteExp = undefined,
quotePat = const $ err "pattern",
quoteType = const $ err "type",
quoteDec = const $ err "declaration" }
err :: String -> a
err ctx = error $
"You have used the `nowdoc' QuasiQoter in a " ++ ctx ++
" context; you must only use it in an expression context"
dropBoth :: (a -> Bool) -> [a] -> [a]
dropBoth = (.) <$> dropWhile <*> dropWhileEnd