{-# LANGUAGE CPP #-}

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

import Control.Monad ((>=>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Char as C
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import GHC.Generics (Generic)
import qualified Language.Haskell.TH.Quote as TH
import qualified Language.Haskell.TH.Syntax as TH

#if !(MIN_VERSION_base(4,13,0))
import Control.Monad.Fail (MonadFail)
#endif
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>))
#endif

data Segment
  = Lit String
  | Var String
  | ShowVar String
  | Abs -- idea due to interpolate
  | ShowAbs
  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
    -- rewrite this
    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
        (String
var, Char
'}' : String
rest) ->
          let seg :: Segment
seg = case String
var of
                String
"" -> Segment
Abs
                String
"show" -> Segment
ShowAbs
                Char
's' : Char
'h' : Char
'o' : Char
'w' : Char
' ' : String
var -> String -> Segment
ShowVar String
var
                String
var -> String -> Segment
Var String
var
           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'
            var :: String
var = Char
v Char -> ShowS
forall a. a -> [a] -> [a]
: String
vs
            s :: Segment
s = if String
var String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"show" then Segment
ShowAbs else String -> Segment
Var String
var
         in (Segment
s 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. [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 -> TH.Exp) -> [Segment] -> TH.Q TH.Exp
ipExpr :: Exp -> (Exp -> Exp) -> [Segment] -> Q Exp
ipExpr Exp
cast Exp -> Exp
combine [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 -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
lams (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
combine (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
TH.ListE [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) (Q (Exp, Exp -> Exp) -> Q ([Exp], Exp -> Exp))
-> Q (Exp, Exp -> Exp) -> Q ([Exp], Exp -> Exp)
forall a b. (a -> b) -> a -> b
$ case Segment
s of
        Lit String
l -> (Exp, Exp -> Exp) -> Q (Exp, Exp -> Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Type -> Exp
TH.SigE (Lit -> Exp
TH.LitE (String -> Lit
TH.StringL String
l)) (Name -> Type
TH.ConT ''String), Exp -> Exp
forall a. a -> a
id)
        Var String
v -> (Exp, Exp -> Exp) -> Q (Exp, Exp -> Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
v), Exp -> Exp
forall a. a -> a
id)
        ShowVar String
v -> (Exp, Exp -> Exp) -> Q (Exp, Exp -> Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'show) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.VarE (String -> Name
TH.mkName String
v), 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])
        Segment
ShowAbs -> do
          Name
n <- String -> Q Name
TH.newName String
"showint"
          (Exp, Exp -> Exp) -> Q (Exp, Exp -> Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'show) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ 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 Exp
cast 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 -> Exp) -> [Segment] -> Q Exp
ipExpr (Name -> Exp
TH.VarE 'stringy) (Exp -> Exp
pp (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 'mconcat))
    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 Stringy a b where
  stringy :: a -> b

instance Stringy String String where
  stringy :: ShowS
stringy = ShowS
forall a. a -> a
id

instance Stringy String T.Text where
  stringy :: String -> Text
stringy = String -> Text
T.pack

instance Stringy String TL.Text where
  stringy :: String -> Text
stringy = String -> Text
TL.pack

instance Stringy String B.ByteString where
  stringy :: String -> ByteString
stringy = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance Stringy String BL.ByteString where
  stringy :: String -> ByteString
stringy = Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack

instance Stringy T.Text T.Text where
  stringy :: Text -> Text
stringy = Text -> Text
forall a. a -> a
id

instance Stringy T.Text String where
  stringy :: Text -> String
stringy = Text -> String
T.unpack

instance Stringy T.Text TL.Text where
  stringy :: Text -> Text
stringy = Text -> Text
TL.fromStrict

instance Stringy T.Text B.ByteString where
  stringy :: Text -> ByteString
stringy = Text -> ByteString
T.encodeUtf8

instance Stringy T.Text BL.ByteString where
  stringy :: Text -> ByteString
stringy = ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8

instance Stringy TL.Text TL.Text where
  stringy :: Text -> Text
stringy = Text -> Text
forall a. a -> a
id

instance Stringy TL.Text String where
  stringy :: Text -> String
stringy = Text -> String
TL.unpack

instance Stringy TL.Text T.Text where
  stringy :: Text -> Text
stringy = Text -> Text
TL.toStrict

instance Stringy TL.Text B.ByteString where
  stringy :: Text -> ByteString
stringy = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TL.encodeUtf8

instance Stringy TL.Text BL.ByteString where
  stringy :: Text -> ByteString
stringy = Text -> ByteString
TL.encodeUtf8

instance Stringy B.ByteString B.ByteString where
  stringy :: ByteString -> ByteString
stringy = ByteString -> ByteString
forall a. a -> a
id

instance Stringy B.ByteString BL.ByteString where
  stringy :: ByteString -> ByteString
stringy = ByteString -> ByteString
BL.fromStrict

instance Stringy BL.ByteString BL.ByteString where
  stringy :: ByteString -> ByteString
stringy = ByteString -> ByteString
forall a. a -> a
id

instance Stringy BL.ByteString B.ByteString where
  stringy :: ByteString -> ByteString
stringy = ByteString -> ByteString
BL.toStrict