-----------------------------------------------------------------------------
{-# 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-2026 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- = Overview
--
-- "Miso.FFI.QQ" provides the @'js'@ quasi-quoter, which lets you embed
-- JavaScript snippets directly in Haskell source. In-scope Haskell
-- variables are spliced into the JS body with @${varName}@ interpolation
-- syntax, and their types are checked at compile time via
-- 'Miso.DSL.ToJSVal'.
--
-- Enable the extension and import the quoter:
--
-- @
-- {-\# LANGUAGE QuasiQuotes \#-}
-- import "Miso.FFI.QQ" ('js')
-- @
--
-- = Quick start
--
-- @
-- -- Compute a factorial entirely in JavaScript
-- fac :: Int -> IO Int
-- fac n = ['js'|
--   let x = 1;
--   for (let i = 1; i \<= ${n}; i++) {
--     x *= i;
--   }
--   return x;
-- |]
--
-- -- Call a third-party JS library with a DOM reference and a string
-- highlight :: 'Miso.DSL.JSVal' -> 'Miso.String.MisoString' -> IO ()
-- highlight domRef lang = ['js'|
--   hljs.highlightElement(${domRef}, { language: ${lang} });
-- |]
-- @
--
-- = How it works
--
-- At compile time the quasi-quoter:
--
-- 1. Lexes the JS body to find all @${varName}@ interpolations.
-- 2. Looks up each @varName@ in the Haskell scope (compile error if not found).
-- 3. Builds a 'Miso.DSL.Object' mapping short generated keys to the
--    marshalled values (via 'Miso.FFI.Internal.inline' \/ 'Miso.DSL.createWith').
-- 4. Rewrites the JS body, replacing each @${varName}@ with its generated
--    key, and wraps the whole thing in a JS function so the keys are visible
--    as named parameters.
--
-- The result is semantically equivalent to:
--
-- @
-- do o <- 'Miso.DSL.createWith' [(\"a0\", toJSVal n)]
--    'Miso.FFI.Internal.inline' \"… body with a0 instead of n …\" o
-- @
--
-- = Differences from eval
--
-- Unlike 'Miso.DSL.eval', the generated code runs in a fresh function scope —
-- it cannot read or write surrounding local variables other than those
-- explicitly interpolated. This makes it both safer and faster (JS engines
-- can optimise closed-over functions that don't reference @eval@).
--
-- = See also
--
-- * 'Miso.FFI.Internal.inline' — the runtime primitive this expands to
-- * "Miso.DSL" — 'Miso.DSL.ToJSVal', 'Miso.DSL.createWith'
-- * "Miso.FFI" — higher-level browser API wrappers
-----------------------------------------------------------------------------
module Miso.FFI.QQ
  ( js
  ) where
----------------------------------------------------------------------------
#ifdef __MHS__
import Prelude hiding (mapM, mapM_, sequence, sequence_)
#endif
import           Control.Applicative
import           Data.Data
#ifdef __MHS__
import           Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
import           Data.Foldable (forM_, mapM_, sequence_)
import           Data.Traversable (forM, mapM, sequence)
#else
import           Control.Monad
#endif
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 :: [Char] -> Q Exp
quoteExp  = \[Char]
s -> (forall b. Data b => b -> Maybe (Q Exp)) -> [Char] -> 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))
-> ([Char] -> Maybe (Q Exp)) -> b -> Maybe (Q Exp)
forall a b c.
(Typeable a, Typeable b) =>
(a -> c) -> (b -> c) -> a -> c
`extQ` [Char] -> Maybe (Q Exp)
inlineJS) [Char]
s
  , quotePat :: [Char] -> Q Pat
quotePat  = \[Char]
_ -> [Char] -> Q Pat
forall a. HasCallStack => [Char] -> Q a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"quotePat: not implemented"
  , quoteType :: [Char] -> Q Type
quoteType = \[Char]
_ -> [Char] -> Q Type
forall a. HasCallStack => [Char] -> Q a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"quoteType: not implemented"
  , quoteDec :: [Char] -> Q [Dec]
quoteDec  = \[Char]
_ -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> Q a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"quoteDec: not implemented"
  }
----------------------------------------------------------------------------
inlineJS :: String -> Maybe (Q Exp)
inlineJS :: [Char] -> Maybe (Q Exp)
inlineJS [Char]
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 <- [Text] -> Q [(Text, Text)]
typeCheck [Text]
vars
  kvs <- forM found $ \(Text
var, Text
key) -> do
    k <- [| MS.pack $([Char] -> Q Exp
forall (m :: * -> *). Quote m => [Char] -> m Exp
stringE (Text -> [Char]
MS.unpack Text
key)) |]
    let v = [Char] -> Name
mkName (Text -> [Char]
MS.unpack Text
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 :: [Text]
vars = Text -> [Text]
getVariables ([Char] -> Text
MS.pack [Char]
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 = [Char] -> m Exp
forall (m :: * -> *). Quote m => [Char] -> m Exp
liftString ([Char] -> m Exp) -> Maybe [Char] -> Maybe (m Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe [Char]
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 :: Text -> [(Text, Text)] -> Text
formatVars Text
s [] = Text
s
formatVars Text
s table :: [(Text, Text)]
table@((Text
var,Text
key):[(Text, Text)]
xs) =
  case Text -> Maybe (Char, Text)
MS.uncons Text
s of
    Maybe (Char, Text)
Nothing ->
      Text
forall a. Monoid a => a
mempty
    Just (Char
'$', Text
cs) -> do
      let needle :: Text
needle = Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
      if Text
needle Text -> Text -> Bool
`MS.isPrefixOf` Text
cs
        then
          Text -> [(Text, Text)] -> Text
formatVars (Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
MS.drop (Text -> Int
MS.length Text
needle) Text
cs) [(Text, Text)]
xs
        else
          Text -> [(Text, Text)] -> Text
formatVars Text
cs [(Text, Text)]
table
    Just (Char
c,Text
cs) ->
      Char -> Text -> Text
MS.cons Char
c (Text -> [(Text, Text)] -> Text
formatVars Text
cs [(Text, Text)]
table)
----------------------------------------------------------------------------
keys :: [MisoString]
keys :: [Text]
keys = do
  (x,y) <- (,) (Char -> Char -> (Char, Char)) -> [Char] -> [Char -> (Char, Char)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char
'a'..Char
'z'] [Char -> (Char, Char)] -> [Char] -> [(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 :: [Text] -> Q [(Text, Text)]
typeCheck [Text]
vars = do
  [(Text, Text)]
-> ((Text, Text) -> Q (Text, Text)) -> Q [(Text, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
Prelude.zip [Text]
vars [Text]
keys) (((Text, Text) -> Q (Text, Text)) -> Q [(Text, Text)])
-> ((Text, Text) -> Q (Text, Text)) -> Q [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ \(Text
var, Text
key) ->
    [Char] -> Q (Maybe Name)
lookupValueName (Text -> [Char]
MS.unpack Text
var) Q (Maybe Name) -> (Maybe Name -> Q (Text, Text)) -> Q (Text, Text)
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 -> [Char] -> Q (Text, Text)
forall a. HasCallStack => [Char] -> Q a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail (Text -> [Char]
MS.unpack Text
var [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" is not in scope")
      Just Name
_ -> (Text, Text) -> Q (Text, Text)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
var, Text
key)
---------------------------------------------------------------------------
getVariables :: MisoString -> [MisoString]
getVariables :: Text -> [Text]
getVariables Text
s =
  case Lexer [Text] -> Stream -> Either LexerError ([Text], Stream)
forall token.
Lexer token -> Stream -> Either LexerError (token, Stream)
runLexer Lexer [Text]
lexer (Text -> Stream
mkStream Text
s) of
    Left LexerError
_ -> [Text]
forall a. Monoid a => a
mempty
    Right ([Text]
xs,Stream
_) -> [Text]
xs
  where
    varLexer :: Lexer MisoString
    varLexer :: Lexer Text
varLexer = do
      Lexer Text -> Lexer ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> Lexer Text
string Text
"${")
      xs <- Lexer Char -> Lexer [Char]
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Lexer Char -> Lexer [Char]) -> Lexer Char -> Lexer [Char]
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 Text
anything = Text
forall a. Monoid a => a
mempty Text -> Lexer Char -> Lexer Text
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 [Text]
lexer = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/=Text
"") ([Text] -> [Text]) -> Lexer [Text] -> Lexer [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Lexer Text -> Lexer [Text]
forall a. Lexer a -> Lexer [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Lexer Text
varLexer Lexer Text -> Lexer Text -> Lexer Text
forall a. Lexer a -> Lexer a -> Lexer a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Lexer Text
anything)
----------------------------------------------------------------------------