-----------------------------------------------------------------------------
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveLift            #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE ViewPatterns          #-}
{-# LANGUAGE BlockArguments        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -Wno-duplicate-exports #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.FFI.QQ
-- Copyright   :  (C) 2016-2025 David M. Johnson (@dmjio)
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- A QuasiQuoter for `inline-js` functionality.
--
-- @
--
-- {-# LANGUAGE QuasiQuotes #-}
--
-- import Miso.FFI.QQ (js)
--
-- fac :: Int -> IO Int
-- fac n = [js|
--   let x = 1;
--   for (i = 1; i <= ${n}; i++) {
--     x *= i;
--   }
--   return x;
-- |]
--
-- @
--
----------------------------------------------------------------------------
module Miso.FFI.QQ
  ( js
  ) where
----------------------------------------------------------------------------
import           Control.Applicative
import           Data.Data
import           Control.Monad
import           System.IO.Unsafe (unsafePerformIO)
import           Language.Haskell.TH.Lib
import           Language.Haskell.TH.Quote
import           Language.Haskell.TH.Syntax
----------------------------------------------------------------------------
import           Miso.String (MisoString)
import           Miso.Util.Lexer
import           Miso.DSL
import qualified Miso.String as MS
import qualified Miso.FFI as FFI
----------------------------------------------------------------------------
-- | QuasiQuoter for specifying inline JavaScript.
--
js :: QuasiQuoter
js :: QuasiQuoter
js = QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp  = \String
s -> (forall b. Data b => b -> Maybe (Q Exp)) -> String -> Q Exp
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ (b -> Maybe (Q Exp)
forall (m :: * -> *) a. (Quote m, Typeable a) => a -> Maybe (m Exp)
withString (b -> Maybe (Q Exp))
-> (String -> Maybe (Q Exp)) -> b -> Maybe (Q Exp)
forall a b c.
(Typeable a, Typeable b) =>
(a -> c) -> (b -> c) -> a -> c
`extQ` String -> Maybe (Q Exp)
inlineJS) String
s
  , quotePat :: String -> Q Pat
quotePat  = \String
_ -> String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"quotePat: not implemented"
  , quoteType :: String -> Q Type
quoteType = \String
_ -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"quoteType: not implemented"
  , quoteDec :: String -> Q [Dec]
quoteDec  = \String
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"quoteDec: not implemented"
  }
----------------------------------------------------------------------------
inlineJS :: String -> Maybe (Q Exp)
inlineJS :: String -> Maybe (Q Exp)
inlineJS String
jsString = Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Q Exp -> Maybe (Q Exp)) -> Q Exp -> Maybe (Q Exp)
forall a b. (a -> b) -> a -> b
$ do
  found <- [MisoString] -> Q [(MisoString, MisoString)]
typeCheck [MisoString]
vars
  kvs <- forM found $ \(MisoString
var, MisoString
key) -> do
    k <- [| MS.pack $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (MisoString -> String
MS.unpack MisoString
key)) |]
    let v = String -> Name
mkName (MisoString -> String
MS.unpack MisoString
var)
    val <- [| unsafePerformIO (toJSVal $(varE v)) :: JSVal |]
    pure $ tupE [ pure k, pure val ]
  [| do o <- createWith ($(listE kvs) :: [(MisoString, JSVal)])
        FFI.inline $(stringE (MS.unpack (formatVars (MS.pack jsString) found)))
          o
   |] where
        vars :: [MisoString]
vars = MisoString -> [MisoString]
getVariables (String -> MisoString
MS.pack String
jsString)
----------------------------------------------------------------------------
extQ :: (Typeable a, Typeable b) => (a -> c) -> (b -> c) -> a -> c
extQ :: forall a b c.
(Typeable a, Typeable b) =>
(a -> c) -> (b -> c) -> a -> c
extQ a -> c
f b -> c
g a
a = c -> (b -> c) -> Maybe b -> c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> c
f a
a) b -> c
g (a -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a)
----------------------------------------------------------------------------
withString :: (Quote m, Typeable a) => a -> Maybe (m Exp)
withString :: forall (m :: * -> *) a. (Quote m, Typeable a) => a -> Maybe (m Exp)
withString a
a = String -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
liftString (String -> m Exp) -> Maybe String -> Maybe (m Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe String
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
a
----------------------------------------------------------------------------
-- | Use `isPrefixOf` as you traverse the string in lex order and do a replace
formatVars :: MisoString -> [(MisoString, MisoString)] -> MisoString
formatVars :: MisoString -> [(MisoString, MisoString)] -> MisoString
formatVars MisoString
s [] = MisoString
s
formatVars MisoString
s table :: [(MisoString, MisoString)]
table@((MisoString
var,MisoString
key):[(MisoString, MisoString)]
xs) =
  case MisoString -> Maybe (Char, MisoString)
MS.uncons MisoString
s of
    Maybe (Char, MisoString)
Nothing ->
      MisoString
forall a. Monoid a => a
mempty
    Just (Char
'$', MisoString
cs) -> do
      let needle :: MisoString
needle = MisoString
"{" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
var MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"}"
      if MisoString
needle MisoString -> MisoString -> Bool
`MS.isPrefixOf` MisoString
cs
        then
          MisoString -> [(MisoString, MisoString)] -> MisoString
formatVars (MisoString
key MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Int -> MisoString -> MisoString
MS.drop (MisoString -> Int
MS.length MisoString
needle) MisoString
cs) [(MisoString, MisoString)]
xs
        else
          MisoString -> [(MisoString, MisoString)] -> MisoString
formatVars MisoString
cs [(MisoString, MisoString)]
table
    Just (Char
c,MisoString
cs) ->
      Char -> MisoString -> MisoString
MS.cons Char
c (MisoString -> [(MisoString, MisoString)] -> MisoString
formatVars MisoString
cs [(MisoString, MisoString)]
table)
----------------------------------------------------------------------------
keys :: [MisoString]
keys :: [MisoString]
keys = do
  (x,y) <- (,) (Char -> Char -> (Char, Char)) -> String -> [Char -> (Char, Char)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char
'a'..Char
'z'] [Char -> (Char, Char)] -> String -> [(Char, Char)]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char
'0'..Char
'9']
  pure (MS.pack [x,y])
----------------------------------------------------------------------------
typeCheck :: [MisoString] -> Q [(MisoString, MisoString)]
typeCheck :: [MisoString] -> Q [(MisoString, MisoString)]
typeCheck [MisoString]
vars = do
  [(MisoString, MisoString)]
-> ((MisoString, MisoString) -> Q (MisoString, MisoString))
-> Q [(MisoString, MisoString)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([MisoString] -> [MisoString] -> [(MisoString, MisoString)]
forall a b. [a] -> [b] -> [(a, b)]
Prelude.zip [MisoString]
vars [MisoString]
keys) (((MisoString, MisoString) -> Q (MisoString, MisoString))
 -> Q [(MisoString, MisoString)])
-> ((MisoString, MisoString) -> Q (MisoString, MisoString))
-> Q [(MisoString, MisoString)]
forall a b. (a -> b) -> a -> b
$ \(MisoString
var, MisoString
key) ->
    String -> Q (Maybe Name)
lookupValueName (MisoString -> String
MS.unpack MisoString
var) Q (Maybe Name)
-> (Maybe Name -> Q (MisoString, MisoString))
-> Q (MisoString, MisoString)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Name
Nothing -> String -> Q (MisoString, MisoString)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (MisoString -> String
MS.unpack MisoString
var String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not in scope")
      Just Name
_ -> (MisoString, MisoString) -> Q (MisoString, MisoString)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MisoString
var, MisoString
key)
---------------------------------------------------------------------------
getVariables :: MisoString -> [MisoString]
getVariables :: MisoString -> [MisoString]
getVariables MisoString
s =
  case Lexer [MisoString]
-> Stream -> Either LexerError ([MisoString], Stream)
forall token.
Lexer token -> Stream -> Either LexerError (token, Stream)
runLexer Lexer [MisoString]
lexer (MisoString -> Stream
mkStream MisoString
s) of
    Left LexerError
_ -> [MisoString]
forall a. Monoid a => a
mempty
    Right ([MisoString]
xs,Stream
_) -> [MisoString]
xs
  where
    varLexer :: Lexer MisoString
    varLexer :: Lexer MisoString
varLexer = do
      Lexer MisoString -> Lexer ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MisoString -> Lexer MisoString
string MisoString
"${")
      xs <- Lexer Char -> Lexer String
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Lexer Char -> Lexer String) -> Lexer Char -> Lexer String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Lexer Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}')
      void (char '}')
      pure (MS.pack xs)

    anything :: Lexer MisoString
    anything :: Lexer MisoString
anything = MisoString
forall a. Monoid a => a
mempty MisoString -> Lexer Char -> Lexer MisoString
forall a b. a -> Lexer b -> Lexer a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Bool) -> Lexer Char
satisfy (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)

    lexer :: Lexer [MisoString]
    lexer :: Lexer [MisoString]
lexer = (MisoString -> Bool) -> [MisoString] -> [MisoString]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (MisoString -> MisoString -> Bool
forall a. Eq a => a -> a -> Bool
/=MisoString
"") ([MisoString] -> [MisoString])
-> Lexer [MisoString] -> Lexer [MisoString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Lexer MisoString -> Lexer [MisoString]
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Lexer MisoString
varLexer Lexer MisoString -> Lexer MisoString -> Lexer MisoString
forall a. Lexer a -> Lexer a -> Lexer a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Lexer MisoString
anything)
----------------------------------------------------------------------------