{-# LANGUAGE UndecidableInstances #-}

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

import Control.Monad ((>=>))
import qualified Data.Char as C
import qualified Data.Text as T
import qualified Data.Text.Display as TD
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import GHC.Generics (Generic)
import qualified Language.Haskell.Meta.Parse as GhcHsMeta
import qualified Language.Haskell.TH.Lib as TH
import qualified Language.Haskell.TH.Quote as TH
import qualified Language.Haskell.TH.Syntax 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
showList :: [Segment] -> ShowS
$cshowList :: [Segment] -> ShowS
show :: Segment -> String
$cshow :: Segment -> String
showsPrec :: Int -> Segment -> ShowS
$cshowsPrec :: Int -> Segment -> ShowS
Show, Segment -> Segment -> Bool
(Segment -> Segment -> Bool)
-> (Segment -> Segment -> Bool) -> Eq Segment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Segment -> Segment -> Bool
$c/= :: Segment -> Segment -> Bool
== :: Segment -> Segment -> Bool
$c== :: 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
$cto :: forall x. Rep Segment x -> Segment
$cfrom :: forall x. Segment -> Rep Segment x
Generic)

parseSegments :: MonadFail m => Char -> String -> m [Segment]
parseSegments :: Char -> String -> m [Segment]
parseSegments Char
c = ([Segment] -> [Segment]) -> m [Segment] -> m [Segment]
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 (t :: * -> *) a. Foldable t => t a -> Bool
null String
lit) = (String -> Segment
Lit String
lit Segment -> [Segment] -> [Segment]
forall a. a -> [a] -> [a]
:) ([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 (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 (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] -> [Segment]
forall a. a -> [a] -> [a]
:) ([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] -> [Segment]
forall a. a -> [a] -> [a]
:) ([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 (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] -> [Segment]
forall a. a -> [a] -> [a]
:) ([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 (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 (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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Exp -> Exp -> Exp -> Exp) -> Exp -> Exp -> Exp -> Exp
forall a b c. (a -> b -> c) -> b -> a -> c
flip Exp -> Exp -> Exp -> Exp
TH.UInfixE (Name -> Exp
TH.VarE '(<>))) (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 (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
<$> [|$(TH.stringE 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 (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
            Left (Int
line, Int
col, String
msg) ->
              String -> Q Exp
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 (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
TH.newName String
"int"
          (Exp, Exp -> Exp) -> Q (Exp, Exp -> Exp)
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'displayish) 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 = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
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
quoteDec :: forall b a. b -> Q a
quoteType :: forall b a. b -> Q a
quotePat :: forall b a. b -> Q a
quoteExp :: String -> Q Exp
..}
  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 (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 (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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"declaration context not supported"

class Displayish a where
  displayish :: a -> TLB.Builder

instance {-# OVERLAPPABLE #-} TD.Display a => Displayish a where
  displayish :: a -> Builder
displayish = a -> Builder
forall a. Display a => a -> Builder
TD.displayBuilder

-- String is still used too pervasively...
instance Displayish String where
  displayish :: String -> Builder
displayish = String -> Builder
TLB.fromString

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

instance Stringish String where
  stringish :: Builder -> String
stringish = Text -> String
TL.unpack (Text -> String) -> (Builder -> Text) -> Builder -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TLB.toLazyText

instance Stringish T.Text where
  stringish :: Builder -> Text
stringish = Text -> Text
TL.toStrict (Text -> Text) -> (Builder -> Text) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TLB.toLazyText

instance Stringish TL.Text where
  stringish :: Builder -> Text
stringish = Builder -> Text
TLB.toLazyText