-----------------------------------------------------------------------------
{-# 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 qualified Data.Set as S
import           Data.Set (Set)
import           System.IO.Unsafe (unsafePerformIO)
import           Language.Haskell.TH.Lib
import           Language.Haskell.TH.Quote
import           Language.Haskell.TH.Syntax
----------------------------------------------------------------------------
import           Miso.String
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 <- Set MisoString -> Q (Set MisoString)
typeCheck Set MisoString
vars
  kvs <- forM (S.toList found) $ \MisoString
s -> do
    k <- [| MS.pack $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (MisoString -> String
MS.unpack MisoString
s)) |]
    let v = String -> Name
mkName (MisoString -> String
MS.unpack MisoString
s)
    val <- [| unsafePerformIO $ toJSVal $(varE v) |]
    pure $ tupE [ pure k, pure val ]
  [| FFI.inline $(stringE (MS.unpack (formatVars (MS.pack jsString) vars))) =<< createWith $(listE kvs) |]
    where
      vars :: Set MisoString
vars = MisoString -> Set 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
----------------------------------------------------------------------------
formatVars :: MisoString -> Set MisoString -> MisoString
formatVars :: MisoString -> Set MisoString -> MisoString
formatVars = (MisoString -> MisoString -> MisoString)
-> MisoString -> Set MisoString -> MisoString
forall b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl' MisoString -> MisoString -> MisoString
go
  where
    go :: MisoString -> MisoString -> MisoString
    go :: MisoString -> MisoString -> MisoString
go MisoString
haystack MisoString
var = HasCallStack =>
MisoString -> MisoString -> MisoString -> MisoString
MisoString -> MisoString -> MisoString -> MisoString
replace MisoString
needle MisoString
var MisoString
haystack
      where
        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
"}"
----------------------------------------------------------------------------
typeCheck :: Set MisoString -> Q (Set MisoString)
typeCheck :: Set MisoString -> Q (Set MisoString)
typeCheck Set MisoString
xs = [Set MisoString] -> Set MisoString
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set MisoString] -> Set MisoString)
-> Q [Set MisoString] -> Q (Set MisoString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
  [MisoString]
-> (MisoString -> Q (Set MisoString)) -> Q [Set MisoString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set MisoString -> [MisoString]
forall a. Set a -> [a]
S.toList Set MisoString
xs) ((MisoString -> Q (Set MisoString)) -> Q [Set MisoString])
-> (MisoString -> Q (Set MisoString)) -> Q [Set MisoString]
forall a b. (a -> b) -> a -> b
$ \MisoString
x ->
    String -> Q (Maybe Name)
lookupValueName (MisoString -> String
unpack MisoString
x) Q (Maybe Name)
-> (Maybe Name -> Q (Set MisoString)) -> Q (Set 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 (Set MisoString)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (MisoString -> String
MS.unpack MisoString
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not in scope")
      Just Name
_ -> Set MisoString -> Q (Set MisoString)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MisoString -> Set MisoString
forall a. a -> Set a
S.singleton MisoString
x)
---------------------------------------------------------------------------
getVariables :: MisoString -> Set MisoString
getVariables :: MisoString -> Set MisoString
getVariables MisoString
s =
  case Lexer (Set MisoString)
-> Stream -> Either LexerError (Set MisoString, Stream)
forall token.
Lexer token -> Stream -> Either LexerError (token, Stream)
runLexer Lexer (Set MisoString)
lexer (MisoString -> Stream
mkStream MisoString
s) of
    Left LexerError
_ -> Set MisoString
forall a. Monoid a => a
mempty
    Right (Set MisoString
xs,Stream
_) -> Set 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 (Set MisoString)
    lexer :: Lexer (Set MisoString)
lexer = (MisoString -> Bool) -> Set MisoString -> Set MisoString
forall a. (a -> Bool) -> Set a -> Set a
S.filter (MisoString -> MisoString -> Bool
forall a. Eq a => a -> a -> Bool
/=MisoString
"") (Set MisoString -> Set MisoString)
-> ([MisoString] -> Set MisoString)
-> [MisoString]
-> Set MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MisoString] -> Set MisoString
forall a. Ord a => [a] -> Set a
S.fromList ([MisoString] -> Set MisoString)
-> Lexer [MisoString] -> Lexer (Set 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)
----------------------------------------------------------------------------