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 :: String -> Ctx -> QuasiQuoter
qq String
qqName Ctx
correctCtx = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = Q Exp -> String -> Q Exp
forall a b. a -> b -> a
const (Q Exp -> String -> Q Exp) -> Q Exp -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Ctx -> String
errorString Ctx
Exp
, quotePat :: String -> Q Pat
quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall a. HasCallStack => String -> a
error (String -> Q Pat) -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ Ctx -> String
errorString Ctx
Pat
, quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall a. HasCallStack => String -> a
error (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ Ctx -> String
errorString Ctx
Type
, quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall a. HasCallStack => String -> a
error (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Ctx -> String
errorString Ctx
Dec
}
where
errorString :: Ctx -> String
errorString Ctx
ctx =
String
"You have used the `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
qqName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"` QuasiQuoter " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ctx -> String
ctxName Ctx
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" context; " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"you must only use it in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ctx -> String
ctxName Ctx
correctCtx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" context"
ctxName :: Ctx -> String
ctxName Ctx
c = case Ctx
c of
Ctx
Exp -> String
"an expression"
Ctx
Pat -> String
"a pattern"
Ctx
Type -> String
"a type"
Ctx
Dec -> String
"a declaration"
toUnix :: String -> String
toUnix :: String -> String
toUnix String
cs = case String
cs of
Char
'\r':Char
'\n' : String
cs -> Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toUnix String
cs
Char
'\r' : String
cs -> Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toUnix String
cs
Char
c : String
cs -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
toUnix String
cs
[] -> []
here :: QuasiQuoter
here :: QuasiQuoter
here = (String -> Ctx -> QuasiQuoter
qq String
"here" Ctx
Exp) { quoteExp :: String -> Q Exp
quoteExp = Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (String -> Lit) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL (String -> Lit) -> (String -> String) -> String -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toUnix }
there :: QuasiQuoter
there :: QuasiQuoter
there = QuasiQuoter -> QuasiQuoter
quoteFile QuasiQuoter
here
str :: QuasiQuoter
str :: QuasiQuoter
str = (String -> Ctx -> QuasiQuoter
qq String
"str" Ctx
Exp)
{ quoteExp :: String -> Q Exp
quoteExp = Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (String -> Lit) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL (String -> Lit) -> (String -> String) -> String -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
unPipe ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toUnix }
where
unPipe :: [String] -> [String]
unPipe [String]
ls = case [String]
ls of
[] -> []
String
l : [String]
ls -> String
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
: case [String] -> Maybe ([String], String)
forall a. [a] -> Maybe ([a], a)
splitLast [String]
ls of
Maybe ([String], String)
Nothing -> []
Just ([String]
middles, String
last) ->
(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
removePipe [String]
middles [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (String -> Maybe String
tryRemovePipe String
last)]
where
removePipe :: String -> String
removePipe String
cs = case String -> Maybe String
tryRemovePipe String
cs of
Maybe String
Nothing -> String -> String
forall a. HasCallStack => String -> a
error String
"no pipe character found in line '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
Just String
cs -> String
cs
tryRemovePipe :: String -> Maybe String
tryRemovePipe String
cs = case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'|') String
cs of
[] -> Maybe String
forall a. Maybe a
Nothing
Char
c:String
cs -> String -> Maybe String
forall a. a -> Maybe a
Just String
cs
splitLast :: [a] -> Maybe ([a], a)
splitLast :: forall a. [a] -> Maybe ([a], a)
splitLast [a]
xs = case [a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs of
[] -> Maybe ([a], a)
forall a. Maybe a
Nothing
a
l:[a]
i -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
i, a
l)