{-# OPTIONS_HADDOCK not-home #-}
module Morley.Util.Interpolate.Internal
( module Morley.Util.Interpolate.Internal
) where
import Prelude hiding (lift)
import Data.Char (isSpace)
import Data.List qualified as List
import Data.Set qualified as S
import Data.Text.Lazy qualified as TL
import Fmt (build, fmt)
import Language.Haskell.TH (Exp, Name, Q, lookupValueName, mkName, reportWarning, varE)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Prettyprinter (align)
import Text.ParserCombinators.ReadP (readP_to_S)
import Text.Read.Lex (lexChar)
data Transformation
= Unescaping
| Unindenting
| Trimming
| Polymorphic
deriving stock (Transformation -> Transformation -> Bool
(Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Bool) -> Eq Transformation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Transformation -> Transformation -> Bool
$c/= :: Transformation -> Transformation -> Bool
== :: Transformation -> Transformation -> Bool
$c== :: Transformation -> Transformation -> Bool
Eq, Eq Transformation
Eq Transformation
-> (Transformation -> Transformation -> Ordering)
-> (Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Transformation)
-> (Transformation -> Transformation -> Transformation)
-> Ord Transformation
Transformation -> Transformation -> Bool
Transformation -> Transformation -> Ordering
Transformation -> Transformation -> Transformation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Transformation -> Transformation -> Transformation
$cmin :: Transformation -> Transformation -> Transformation
max :: Transformation -> Transformation -> Transformation
$cmax :: Transformation -> Transformation -> Transformation
>= :: Transformation -> Transformation -> Bool
$c>= :: Transformation -> Transformation -> Bool
> :: Transformation -> Transformation -> Bool
$c> :: Transformation -> Transformation -> Bool
<= :: Transformation -> Transformation -> Bool
$c<= :: Transformation -> Transformation -> Bool
< :: Transformation -> Transformation -> Bool
$c< :: Transformation -> Transformation -> Bool
compare :: Transformation -> Transformation -> Ordering
$ccompare :: Transformation -> Transformation -> Ordering
Ord, Int -> Transformation
Transformation -> Int
Transformation -> [Transformation]
Transformation -> Transformation
Transformation -> Transformation -> [Transformation]
Transformation
-> Transformation -> Transformation -> [Transformation]
(Transformation -> Transformation)
-> (Transformation -> Transformation)
-> (Int -> Transformation)
-> (Transformation -> Int)
-> (Transformation -> [Transformation])
-> (Transformation -> Transformation -> [Transformation])
-> (Transformation -> Transformation -> [Transformation])
-> (Transformation
-> Transformation -> Transformation -> [Transformation])
-> Enum Transformation
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Transformation
-> Transformation -> Transformation -> [Transformation]
$cenumFromThenTo :: Transformation
-> Transformation -> Transformation -> [Transformation]
enumFromTo :: Transformation -> Transformation -> [Transformation]
$cenumFromTo :: Transformation -> Transformation -> [Transformation]
enumFromThen :: Transformation -> Transformation -> [Transformation]
$cenumFromThen :: Transformation -> Transformation -> [Transformation]
enumFrom :: Transformation -> [Transformation]
$cenumFrom :: Transformation -> [Transformation]
fromEnum :: Transformation -> Int
$cfromEnum :: Transformation -> Int
toEnum :: Int -> Transformation
$ctoEnum :: Int -> Transformation
pred :: Transformation -> Transformation
$cpred :: Transformation -> Transformation
succ :: Transformation -> Transformation
$csucc :: Transformation -> Transformation
Enum, Transformation
Transformation -> Transformation -> Bounded Transformation
forall a. a -> a -> Bounded a
maxBound :: Transformation
$cmaxBound :: Transformation
minBound :: Transformation
$cminBound :: Transformation
Bounded)
type Transformations = Set Transformation
transformationsPowerSet :: [Transformations]
transformationsPowerSet :: [Transformations]
transformationsPowerSet = Set Transformations -> [Element (Set Transformations)]
forall t. Container t => t -> [Element t]
toList (Set Transformations -> [Element (Set Transformations)])
-> Set Transformations -> [Element (Set Transformations)]
forall a b. (a -> b) -> a -> b
$ Transformations -> Set Transformations
forall a. Set a -> Set (Set a)
S.powerSet (Transformations -> Set Transformations)
-> Transformations -> Set Transformations
forall a b. (a -> b) -> a -> b
$ [Transformation] -> Transformations
forall a. Eq a => [a] -> Set a
S.fromAscList [Transformation
forall a. Bounded a => a
minBound..Transformation
forall a. Bounded a => a
maxBound]
generateName :: Transformations -> Name
generateName :: Transformations -> Name
generateName Transformations
ls = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$
Transformation -> [Char] -> [Char] -> [Char]
t Transformation
Unescaping [Char]
"" [Char]
"l" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"i" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Transformation -> [Char] -> [Char] -> [Char]
t Transformation
Trimming [Char]
"t" [Char]
""
[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Transformation -> [Char] -> [Char] -> [Char]
t Transformation
Unindenting [Char]
"u" [Char]
"" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Transformation -> [Char] -> [Char] -> [Char]
t Transformation
Polymorphic [Char]
"" [Char]
"b"
where t :: Transformation -> [Char] -> [Char] -> [Char]
t Transformation
el [Char]
tru [Char]
fls = if Transformation -> Transformations -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Transformation
el Transformations
ls then [Char]
tru else [Char]
fls
mkQuoter :: Transformations -> QuasiQuoter
mkQuoter :: Transformations -> QuasiQuoter
mkQuoter Transformations
ts = QuasiQuoter :: ([Char] -> Q Exp)
-> ([Char] -> Q Pat)
-> ([Char] -> Q Type)
-> ([Char] -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: [Char] -> Q Exp
quoteExp = (Element [Transformation] -> ([Char] -> Q Exp) -> [Char] -> Q Exp)
-> ([Char] -> Q Exp) -> [Transformation] -> [Char] -> Q Exp
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr Element [Transformation] -> ([Char] -> Q Exp) -> [Char] -> Q Exp
Transformation -> ([Char] -> Q Exp) -> [Char] -> Q Exp
go [Char] -> Q Exp
makeBuilder ([Transformation] -> [Char] -> Q Exp)
-> [Transformation] -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Transformations -> [Element Transformations]
forall t. Container t => t -> [Element t]
toList Transformations
ts
, quotePat :: [Char] -> Q Pat
quotePat = \[Char]
_ -> [Char] -> Q Pat
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Cannot be used at pattern position"
, quoteType :: [Char] -> Q Type
quoteType = \[Char]
_ -> [Char] -> Q Type
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Cannot be used at type position"
, quoteDec :: [Char] -> Q [Dec]
quoteDec = \[Char]
_ -> [Char] -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Cannot be used as declaration"
}
where
go :: Transformation -> ([Char] -> Q Exp) -> [Char] -> Q Exp
go Transformation
Unescaping [Char] -> Q Exp
f = [Char] -> Q Exp
f ([Char] -> Q Exp) -> ([Char] -> Q [Char]) -> [Char] -> Q Exp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Char] -> Q [Char]
unescape
go Transformation
Unindenting [Char] -> Q Exp
f = [Char] -> Q Exp
f ([Char] -> Q Exp) -> ([Char] -> [Char]) -> [Char] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
unindent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
dropLeadingNewline
go Transformation
Trimming [Char] -> Q Exp
f = [Char] -> Q Exp
f ([Char] -> Q Exp) -> ([Char] -> [Char]) -> [Char] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
trim
go Transformation
Polymorphic [Char] -> Q Exp
f = \[Char]
s -> [| fmt $(f s) |]
unescape :: String -> Q String
unescape :: [Char] -> Q [Char]
unescape (Char
'\\':Char
'#':[Char]
xs) = (Char
'\\'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'#'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> Q [Char] -> Q [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Q [Char]
unescape [Char]
xs
unescape (Char
'\\':Char
'&':[Char]
xs) = [Char] -> Q [Char]
unescape [Char]
xs
unescape xs :: [Char]
xs@(Char
'\\':Char
c:[Char]
cs) = case ReadP Char -> ReadS Char
forall a. ReadP a -> ReadS a
readP_to_S ReadP Char
lexChar [Char]
xs of
(Char
ch, [Char]
rest):[(Char, [Char])]
_ -> (Char
ch Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> Q [Char] -> Q [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Q [Char]
unescape [Char]
rest
[] -> do
[Char] -> Q ()
reportWarning ([Char] -> Q ()) -> [Char] -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Unrecognized escape sequence near '" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) [Char]
xs [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"'"
(Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> Q [Char] -> Q [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Q [Char]
unescape [Char]
cs
unescape (Char
c:[Char]
cs) = (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> Q [Char] -> Q [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Q [Char]
unescape [Char]
cs
unescape [] = [Char] -> Q [Char]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
makeBuilder :: String -> Q Exp
makeBuilder :: [Char] -> Q Exp
makeBuilder = Doc -> [Char] -> Q Exp
go Doc
forall a. Monoid a => a
mempty
where
go :: Doc -> [Char] -> Q Exp
go Doc
tacc (Char
'\\':Char
'#':[Char]
xs) = Doc -> [Char] -> Q Exp
go (Doc
tacc Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"#") [Char]
xs
go Doc
tacc (Char
'#':Char
'{':[Char]
xs)
| ([Char]
expr, Char
'}':[Char]
ys) <- (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'}') [Char]
xs
= [Char] -> Q (Maybe Name)
lookupValueName [Char]
expr Q (Maybe Name) -> (Maybe Name -> Q Exp) -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Name
valueName ->
let txt :: Text
txt = Doc -> Text
forall a. FromDoc a => Doc -> a
fmt Doc
tacc :: Text
in [| build txt <> align (build $(varE valueName)) <> $(go mempty ys) |]
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]
"Variable '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
expr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' is not in scope"
go Doc
tacc (Char
c:[Char]
cs) = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span (Element [Char] -> [Char] -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
`notElem` [Char
'\\', Char
'#']) [Char]
cs of
([Char]
str, [Char]
rest) -> Doc -> [Char] -> Q Exp
go (Doc
tacc Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
forall a. Buildable a => a -> Doc
build (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
str)) [Char]
rest
go Doc
tacc [] = let txt :: Text
txt = forall a. FromDoc a => Doc -> a
fmt @Text Doc
tacc in [| build txt |]
splitTextLazy :: (Char -> Bool) -> TL.Text -> NonEmpty TL.Text
splitTextLazy :: (Char -> Bool) -> Text -> NonEmpty Text
splitTextLazy Char -> Bool
p Text
t = case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Text] -> Maybe (NonEmpty Text))
-> [Text] -> Maybe (NonEmpty Text)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
TL.split Char -> Bool
p Text
t of
Just NonEmpty Text
ne -> NonEmpty Text
ne
Maybe (NonEmpty Text)
Nothing -> Text -> NonEmpty Text
forall a. HasCallStack => Text -> a
error Text
"Morley.Util.Interpolate.splitTextLazy: the impossible happened"
dropLeadingNewline :: String -> String
dropLeadingNewline :: [Char] -> [Char]
dropLeadingNewline (Char
'\n':[Char]
xs) = [Char]
xs
dropLeadingNewline [Char]
xs = [Char]
xs
unindent :: String -> String
unindent :: [Char] -> [Char]
unindent [Char]
s =
case [[Char]] -> Maybe (NonEmpty [Char])
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Bool
forall t. Container t => t -> Bool
null) [[Char]]
ls) of
Just NonEmpty [Char]
ne ->
let minIndent :: Int
minIndent = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
minimum (NonEmpty Int -> Int) -> NonEmpty Int -> Int
forall a b. (a -> b) -> a -> b
$ [Char] -> Int
indentOf ([Char] -> Int) -> NonEmpty [Char] -> NonEmpty Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty [Char]
ne
in [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
minIndent ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
ls
Maybe (NonEmpty [Char])
Nothing -> [Char]
s
where
ls :: [[Char]]
ls = (Char -> Bool) -> [Char] -> [[Char]]
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') [Char]
s
indentOf :: [Char] -> Int
indentOf = [Char] -> Int
forall i a.
(Integral i, Container a, CheckIntSubType Length i,
DefaultToInt (IsIntSubType Length i) i) =>
a -> i
length ([Char] -> Int) -> ([Char] -> [Char]) -> [Char] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
split :: (Char -> Bool) -> String -> [String]
split :: (Char -> Bool) -> [Char] -> [[Char]]
split Char -> Bool
cond [Char]
s = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
cond [Char]
s of
([Char]
pfx, Char
_:[Char]
suf) -> [Char]
pfx [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (Char -> Bool) -> [Char] -> [[Char]]
split Char -> Bool
cond [Char]
suf
([Char]
pfx, [Char]
"") -> [[Char]
pfx]
trim :: String -> String
trim :: [Char] -> [Char]
trim = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd ((Element [Char] -> Bool) -> [Char] -> Bool
forall c b.
(Container c, BooleanMonoid b) =>
(Element c -> b) -> c -> b
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '))
([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Element [Char] -> Bool) -> [Char] -> Bool
forall c b.
(Container c, BooleanMonoid b) =>
(Element c -> b) -> c -> b
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')) ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [[Char]]
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n')