-- | Internal module, no stability guarantees
module Yasi.Internal
  ( Segment (..),
    parseSegments,
    ipExpr,
    interpolator,
    Stringish (..),
  )
where

import Control.Monad ((>=>))
import Data.Char qualified as C
import Data.List (foldl')
import Data.Text qualified as T
import Data.Text.Builder.Linear qualified as TBL
import Data.Text.Display qualified as TD
import Data.Text.Lazy qualified as TL
import GHC.Generics (Generic)
import Language.Haskell.Meta.Parse qualified as GhcHsMeta
import Language.Haskell.TH.Lib qualified as TH
import Language.Haskell.TH.Quote qualified as TH
import Language.Haskell.TH.Syntax qualified as TH

data Segment
  = Lit String
  | Exp String
  | Abs -- idea due to interpolate
  deriving (Int -> Segment -> ShowS
[Segment] -> ShowS
Segment -> String
(Int -> Segment -> ShowS)
-> (Segment -> String) -> ([Segment] -> ShowS) -> Show Segment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Segment -> ShowS
showsPrec :: Int -> Segment -> ShowS
$cshow :: Segment -> String
show :: Segment -> String
$cshowList :: [Segment] -> ShowS
showList :: [Segment] -> ShowS
Show, Segment -> Segment -> Bool
(Segment -> Segment -> Bool)
-> (Segment -> Segment -> Bool) -> Eq Segment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Segment -> Segment -> Bool
== :: Segment -> Segment -> Bool
$c/= :: Segment -> Segment -> Bool
/= :: Segment -> Segment -> Bool
Eq, (forall x. Segment -> Rep Segment x)
-> (forall x. Rep Segment x -> Segment) -> Generic Segment
forall x. Rep Segment x -> Segment
forall x. Segment -> Rep Segment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Segment -> Rep Segment x
from :: forall x. Segment -> Rep Segment x
$cto :: forall x. Rep Segment x -> Segment
to :: forall x. Rep Segment x -> Segment
Generic)

parseSegments :: (MonadFail m) => Char -> String -> m [Segment]
parseSegments :: forall (m :: * -> *). MonadFail m => Char -> String -> m [Segment]
parseSegments Char
c = ([Segment] -> [Segment]) -> m [Segment] -> m [Segment]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> [Segment] -> [Segment]
group []) (m [Segment] -> m [Segment])
-> (String -> m [Segment]) -> String -> m [Segment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m [Segment]
forall {f :: * -> *}. MonadFail f => String -> f [Segment]
go
  where
    -- ugly, but simple enough™
    go :: String -> f [Segment]
go String
s
      | let (String
lit, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
c) String
s, Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
lit) = (String -> Segment
Lit String
lit :) ([Segment] -> [Segment]) -> f [Segment] -> f [Segment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f [Segment]
go String
rest
      | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = [Segment] -> f [Segment]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== [Char
c] = String -> f [Segment]
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f [Segment]) -> String -> f [Segment]
forall a b. (a -> b) -> a -> b
$ String
"should not end with single " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char
c]
      | Char
_ : Char
c' : String
rest <- String
s, Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c' = (String -> Segment
Lit [Char
c] :) ([Segment] -> [Segment]) -> f [Segment] -> f [Segment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f [Segment]
go String
rest
      | Char
_ : Char
'{' : String
rest <- String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}') String
rest of -- TODO smarter?
          (String
exp, Char
'}' : String
rest) ->
            let seg :: Segment
seg = if String
exp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then Segment
Abs else String -> Segment
Exp String
exp
             in (Segment
seg :) ([Segment] -> [Segment]) -> f [Segment] -> f [Segment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f [Segment]
go String
rest
          (String, String)
_ -> String -> f [Segment]
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"missing closing bracket"
      | Char
_ : Char
v : String
rest' <- String
s,
        Char -> Bool
isVarStartChar Char
v =
          let (String
vs, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isVarChar String
rest'
           in (String -> Segment
Exp (Char
v Char -> ShowS
forall a. a -> [a] -> [a]
: String
vs) :) ([Segment] -> [Segment]) -> f [Segment] -> f [Segment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f [Segment]
go String
rest
      | Bool
otherwise = String -> f [Segment]
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f [Segment]) -> String -> f [Segment]
forall a b. (a -> b) -> a -> b
$ String
"invalid char after " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char
c]
    isVarStartChar :: Char -> Bool
isVarStartChar Char
v = Char -> Bool
C.isAscii Char
v Bool -> Bool -> Bool
&& Char -> Bool
C.isAlpha Char
v
    isVarChar :: Char -> Bool
isVarChar Char
v = Char -> Bool
C.isAscii Char
v Bool -> Bool -> Bool
&& (Char -> Bool
C.isAlphaNum Char
v Bool -> Bool -> Bool
|| Char
v Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
v Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'')

    group :: [String] -> [Segment] -> [Segment]
group [String]
ls [] = [String] -> [Segment]
lit [String]
ls
    group [String]
ls (Lit String
l : [Segment]
ss) = [String] -> [Segment] -> [Segment]
group (String
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ls) [Segment]
ss
    group [String]
ls (Segment
s : [Segment]
ss) = [String] -> [Segment]
lit [String]
ls [Segment] -> [Segment] -> [Segment]
forall a. Semigroup a => a -> a -> a
<> (Segment
s Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
: [String] -> [Segment] -> [Segment]
group [] [Segment]
ss)
    lit :: [String] -> [Segment]
lit [] = []
    lit [String]
ls = [String -> Segment
Lit (String -> Segment) -> String -> Segment
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse [String]
ls]

ipExpr :: (TH.Exp -> TH.Exp) -> [Segment] -> TH.Q TH.Exp
ipExpr :: (Exp -> Exp) -> [Segment] -> Q Exp
ipExpr Exp -> Exp
transform [Segment]
segs = do
  ([Exp]
ls, Exp -> Exp
lams) <- [Segment] -> Q ([Exp], Exp -> Exp)
go [Segment]
segs
  Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Exp -> Q Exp) -> ([Exp] -> Exp) -> [Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
lams
    (Exp -> Exp) -> ([Exp] -> Exp) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
transform
    (Exp -> Exp) -> ([Exp] -> Exp) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'stringish)
    (Exp -> Exp) -> ([Exp] -> Exp) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Exp
a Exp
b -> Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
a) (Name -> Exp
TH.VarE '(<>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
b)) (Name -> Exp
TH.VarE 'mempty)
    ([Exp] -> Q Exp) -> [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp]
ls
  where
    go :: [Segment] -> Q ([Exp], Exp -> Exp)
go = \case
      [] -> ([Exp], Exp -> Exp) -> Q ([Exp], Exp -> Exp)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp -> Exp
forall a. a -> a
id)
      Segment
s : [Segment]
ss -> Q ([Exp], Exp -> Exp)
-> Q (Exp, Exp -> Exp) -> Q ([Exp], Exp -> Exp)
forall {m :: * -> *} {a} {b} {c}.
Monad m =>
m ([Exp], a -> b) -> m (Exp, b -> c) -> m ([Exp], a -> c)
prep ([Segment] -> Q ([Exp], Exp -> Exp)
go [Segment]
ss) case Segment
s of
        Lit String
l -> (,Exp -> Exp
forall a. a -> a
id) (Exp -> (Exp, Exp -> Exp)) -> Q Exp -> Q (Exp, Exp -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|$(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.stringE String
l) :: String|]
        Exp String
e -> do
          [Extension]
exts <- Q [Extension]
TH.extsEnabled
          Exp
exp <- case [Extension] -> String -> Either (Int, Int, String) Exp
GhcHsMeta.parseExpWithExts [Extension]
exts String
e of
            Right Exp
e -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
            Left (Int
line, Int
col, String
msg) ->
              String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> ([String] -> String) -> [String] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> Q Exp) -> [String] -> Q Exp
forall a b. (a -> b) -> a -> b
$
                [ String
"Parse error at splice `" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"`:",
                  Int -> String
forall a. Show a => a -> String
show Int
line String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
col String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg
                ]
          (Exp, Exp -> Exp) -> Q (Exp, Exp -> Exp)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp
exp, Exp -> Exp
forall a. a -> a
id)
        Segment
Abs -> do
          Name
n <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"int"
          (Exp, Exp -> Exp) -> Q (Exp, Exp -> Exp)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Exp
TH.VarE Name
n, [Pat] -> Exp -> Exp
TH.LamE [Name -> Pat
TH.VarP Name
n])
    prep :: m ([Exp], a -> b) -> m (Exp, b -> c) -> m ([Exp], a -> c)
prep m ([Exp], a -> b)
asg m (Exp, b -> c)
af = do
      ([Exp]
as, a -> b
g) <- m ([Exp], a -> b)
asg
      (Exp
a, b -> c
f) <- m (Exp, b -> c)
af
      ([Exp], a -> c) -> m ([Exp], a -> c)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'TD.displayBuilder) Exp
a Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
as, b -> c
f (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
g)

interpolator ::
  Char ->
  -- | postprocess the 'TH.Exp'
  (TH.Exp -> TH.Exp) ->
  TH.QuasiQuoter
interpolator :: Char -> (Exp -> Exp) -> QuasiQuoter
interpolator Char
c Exp -> Exp
pp = TH.QuasiQuoter {String -> Q [Dec]
String -> Q Exp
String -> Q Pat
String -> Q Type
forall {b} {a}. b -> Q a
quoteExp :: String -> Q Exp
quotePat :: String -> Q Pat
quoteDec :: String -> Q [Dec]
quoteType :: String -> Q Type
quoteExp :: String -> Q Exp
quotePat :: forall {b} {a}. b -> Q a
quoteType :: forall {b} {a}. b -> Q a
quoteDec :: forall {b} {a}. b -> Q a
..}
  where
    quoteExp :: String -> Q Exp
quoteExp = Char -> String -> Q [Segment]
forall (m :: * -> *). MonadFail m => Char -> String -> m [Segment]
parseSegments Char
c (String -> Q [Segment]) -> ([Segment] -> Q Exp) -> String -> Q Exp
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Exp -> Exp) -> [Segment] -> Q Exp
ipExpr Exp -> Exp
pp
    quotePat :: b -> Q a
quotePat = Q a -> b -> Q a
forall a b. a -> b -> a
const (Q a -> b -> Q a) -> Q a -> b -> Q a
forall a b. (a -> b) -> a -> b
$ String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"pattern context not supported"
    quoteType :: b -> Q a
quoteType = Q a -> b -> Q a
forall a b. a -> b -> a
const (Q a -> b -> Q a) -> Q a -> b -> Q a
forall a b. (a -> b) -> a -> b
$ String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"type context not supported"
    quoteDec :: b -> Q a
quoteDec = Q a -> b -> Q a
forall a b. a -> b -> a
const (Q a -> b -> Q a) -> Q a -> b -> Q a
forall a b. (a -> b) -> a -> b
$ String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"declaration context not supported"

class Stringish a where
  stringish :: TBL.Builder -> a

instance Stringish String where
  stringish :: Builder -> String
stringish = Text -> String
T.unpack (Text -> String) -> (Builder -> Text) -> Builder -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
Builder -> Text
TBL.runBuilder

instance Stringish T.Text where
  stringish :: Builder -> Text
stringish = Builder -> Text
Builder -> Text
TBL.runBuilder

instance Stringish TL.Text where
  stringish :: Builder -> Text
stringish = Text -> Text
TL.fromStrict (Text -> Text) -> (Builder -> Text) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
Builder -> Text
TBL.runBuilder