module NeatInterpolation (trimming, untrimming, text) where
import NeatInterpolation.Prelude
import Language.Haskell.TH
import Language.Haskell.TH.Quote hiding (quoteExp)
import qualified Data.Text as Text
import qualified NeatInterpolation.String as String
import qualified NeatInterpolation.Parsing as Parsing
expQQ :: ([Char] -> Q Exp) -> QuasiQuoter
expQQ [Char] -> Q Exp
quoteExp = ([Char] -> Q Exp)
-> ([Char] -> Q Pat)
-> ([Char] -> Q Type)
-> ([Char] -> Q [Dec])
-> QuasiQuoter
QuasiQuoter [Char] -> Q Exp
quoteExp [Char] -> Q Pat
forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
notSupported [Char] -> Q Type
forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
notSupported [Char] -> Q [Dec]
forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
notSupported where
notSupported :: p -> m a
notSupported p
_ = [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Quotation in this context is not supported"
text :: QuasiQuoter
text :: QuasiQuoter
text = QuasiQuoter
trimming
trimming :: QuasiQuoter
trimming :: QuasiQuoter
trimming = ([Char] -> Q Exp) -> QuasiQuoter
expQQ ([Char] -> Q Exp
quoteExp ([Char] -> Q Exp) -> ([Char] -> [Char]) -> [Char] -> Q Exp
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Char] -> [Char]
String.trim ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Char] -> [Char]
String.unindent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Char] -> [Char]
String.tabsToSpaces)
untrimming :: QuasiQuoter
untrimming :: QuasiQuoter
untrimming = ([Char] -> Q Exp) -> QuasiQuoter
expQQ ([Char] -> Q Exp
quoteExp ([Char] -> Q Exp) -> ([Char] -> [Char]) -> [Char] -> Q Exp
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Char] -> [Char]
String.unindent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Char] -> [Char]
String.tabsToSpaces)
indentQQPlaceholder :: Int -> Text -> Text
indentQQPlaceholder :: Int -> Text -> Text
indentQQPlaceholder Int
indent Text
text = case Text -> [Text]
Text.lines Text
text of
Text
head:[Text]
tail -> Text -> [Text] -> Text
Text.intercalate (Char -> Text
Text.singleton Char
'\n') ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
Text
head Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
Text.replicate Int
indent (Char -> Text
Text.singleton Char
' ') Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
tail
[] -> Text
text
quoteExp :: String -> Q Exp
quoteExp :: [Char] -> Q Exp
quoteExp [Char]
input =
case [Char] -> Either ParseException [Line]
Parsing.parseLines [Char]
input of
Left ParseException
e -> [Char] -> Q Exp
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ParseException -> [Char]
forall a. Show a => a -> [Char]
show ParseException
e
Right [Line]
lines -> Q Exp -> Q Type -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
sigE (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|Text.intercalate (Text.singleton '\n')|] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Line -> Q Exp) -> [Line] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Line -> Q Exp
lineExp [Line]
lines)
[t|Text|]
lineExp :: Parsing.Line -> Q Exp
lineExp :: Line -> Q Exp
lineExp (Parsing.Line Int
indent [LineContent]
contents) =
case [LineContent]
contents of
[] -> [| Text.empty |]
[Item [LineContent]
x] -> LineContent -> Q Exp
toExp Item [LineContent]
LineContent
x
[LineContent]
xs -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|Text.concat|] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (LineContent -> Q Exp) -> [LineContent] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map LineContent -> Q Exp
toExp [LineContent]
xs
where toExp :: LineContent -> Q Exp
toExp = Integer -> LineContent -> Q Exp
contentExp (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
indent)
contentExp :: Integer -> Parsing.LineContent -> Q Exp
contentExp :: Integer -> LineContent -> Q Exp
contentExp Integer
_ (Parsing.LineContentText [Char]
text) = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|Text.pack|] ([Char] -> Q Exp
forall (m :: * -> *). Quote m => [Char] -> m Exp
stringE [Char]
text)
contentExp Integer
indent (Parsing.LineContentIdentifier [Char]
name) = do
Maybe Name
valueName <- [Char] -> Q (Maybe Name)
lookupValueName [Char]
name
case Maybe Name
valueName of
Just Name
valueName -> do
Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
(Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'indentQQPlaceholder) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
indent)
(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
valueName)
Maybe Name
Nothing -> [Char] -> Q Exp
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Value `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"` is not in scope"