module Text.Heredoc (here, there, str) where
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
import Language.Haskell.TH
( litE
, stringL
)
import Language.Haskell.TH.Quote
( QuasiQuoter
( QuasiQuoter
, quoteExp
, quotePat
, quoteType
, quoteDec
)
, quoteFile
)
data Ctx = Exp | Pat | Type | Dec
qq :: String -> Ctx -> QuasiQuoter
qq qqName correctCtx = QuasiQuoter
{ quoteExp = const $ error $ errorString Exp
, quotePat = const $ error $ errorString Pat
, quoteType = const $ error $ errorString Type
, quoteDec = const $ error $ errorString Dec
}
where
errorString ctx =
"You have used the `" ++ qqName ++ "` QuasiQuoter " ++
"in " ++ ctxName ctx ++ " context; " ++
"you must only use it in " ++ ctxName correctCtx ++ " context"
ctxName c = case c of
Exp -> "an expression"
Pat -> "a pattern"
Type -> "a type"
Dec -> "a declaration"
toUnix :: String -> String
toUnix cs = case cs of
'\r':'\n' : cs -> '\n' : toUnix cs
'\r' : cs -> '\n' : toUnix cs
c : cs -> c : toUnix cs
[] -> []
here :: QuasiQuoter
here = (qq "here" Exp) { quoteExp = litE . stringL . toUnix }
there :: QuasiQuoter
there = quoteFile here
str :: QuasiQuoter
str = (qq "str" Exp)
{ quoteExp = litE . stringL . intercalate "\n" . unPipe . lines . toUnix }
where
unPipe ls = case ls of
[] -> []
l : ls -> l : case splitLast ls of
Nothing -> []
Just (middles, last) ->
map removePipe middles ++ [fromMaybe "" (tryRemovePipe last)]
where
removePipe cs = case tryRemovePipe cs of
Nothing -> error "no pipe character found in line '" ++ cs ++ "'"
Just cs -> cs
tryRemovePipe cs = case dropWhile (/='|') cs of
[] -> Nothing
c:cs -> Just cs
splitLast :: [a] -> Maybe ([a], a)
splitLast xs = case reverse xs of
[] -> Nothing
l:i -> Just (reverse i, l)