{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
#ifdef USE_REFLEX_OPTIMIZER
{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
#endif
-- | Template Haskell helper functions for building complex 'Dynamic' values.
module Reflex.Dynamic.TH
  ( qDynPure
  , unqDyn
  , mkDynPure
  ) where

import Reflex.Dynamic

import Control.Monad.State
import Data.Data
import Data.Generics
import Data.Monoid ((<>))
import qualified Language.Haskell.Exts as Hs
import qualified Language.Haskell.Meta.Syntax.Translate as Hs
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import qualified Language.Haskell.TH.Syntax as TH

-- | Quote a 'Dynamic' expression.  Within the quoted expression, you can use
-- @$(unqDyn [| x |])@ to refer to any expression @x@ of type @Dynamic t a@; the
-- unquoted result will be of type @a@
qDynPure :: Q Exp -> Q Exp
qDynPure :: Q Exp -> Q Exp
qDynPure Q Exp
qe = do
  Exp
e <- Q Exp
qe
  let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d
      f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d
f d
d = case Maybe (d :~: Exp)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT of
        Just (d :~: Exp
Refl :: d :~: Exp)
          | AppE (VarE Name
m) Exp
eInner <- d
d
          , Name
m Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'unqMarker
          -> do Name
n <- Q Name -> StateT [(Name, Exp)] Q Name
forall (m :: * -> *) a. Monad m => m a -> StateT [(Name, Exp)] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> StateT [(Name, Exp)] Q Name)
-> Q Name -> StateT [(Name, Exp)] Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"dynamicQuotedExpressionVariable"
                ([(Name, Exp)] -> [(Name, Exp)]) -> StateT [(Name, Exp)] Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Name
n, Exp
eInner)(Name, Exp) -> [(Name, Exp)] -> [(Name, Exp)]
forall a. a -> [a] -> [a]
:)
                Exp -> StateT [(Name, Exp)] Q Exp
forall a. a -> StateT [(Name, Exp)] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> StateT [(Name, Exp)] Q Exp)
-> Exp -> StateT [(Name, Exp)] Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
n
        Maybe (d :~: Exp)
_ -> (forall d. Data d => d -> StateT [(Name, Exp)] Q d)
-> d -> StateT [(Name, Exp)] Q d
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> d -> m d
gmapM d -> StateT [(Name, Exp)] Q d
forall d. Data d => d -> StateT [(Name, Exp)] Q d
f d
d
  (Exp
e', [(Name, Exp)]
exprsReversed) <- StateT [(Name, Exp)] Q Exp
-> [(Name, Exp)] -> Q (Exp, [(Name, Exp)])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((forall d. Data d => d -> StateT [(Name, Exp)] Q d)
-> Exp -> StateT [(Name, Exp)] Q Exp
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Exp -> m Exp
gmapM d -> StateT [(Name, Exp)] Q d
forall d. Data d => d -> StateT [(Name, Exp)] Q d
f Exp
e) []
  let exprs :: [(Name, Exp)]
exprs = [(Name, Exp)] -> [(Name, Exp)]
forall a. [a] -> [a]
reverse [(Name, Exp)]
exprsReversed
      arg :: Q Exp
arg = ((Name, Exp) -> Q Exp -> Q Exp) -> Q Exp -> [(Name, Exp)] -> Q Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        (\(Name
_, Exp
expr) Q Exp
rest -> [e| FHCons $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr) $Q Exp
rest |])
        [e| FHNil |]
        [(Name, Exp)]
exprs
      param :: Q Pat
param = ((Name, Exp) -> Q Pat -> Q Pat) -> Q Pat -> [(Name, Exp)] -> Q Pat
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        (\(Name
name, Exp
_) Q Pat
rest -> [p| HCons $(Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Pat
VarP Name
name) $Q Pat
rest |])
        [p| HNil |]
        [(Name, Exp)]
exprs
  [| (\ $Q Pat
param -> $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e')) <$> distributeFHListOverDynPure $Q Exp
arg |]

-- | Antiquote a 'Dynamic' expression.  This can /only/ be used inside of a
-- 'qDyn' quotation.
unqDyn :: Q Exp -> Q Exp
unqDyn :: Q Exp -> Q Exp
unqDyn Q Exp
e = [| unqMarker $Q Exp
e |]

-- | This type represents an occurrence of unqDyn before it has been processed
-- by qDyn.  If you see it in a type error, it probably means that unqDyn has
-- been used outside of a qDyn context.
data UnqDyn

-- unqMarker must not be exported; it is used only as a way of smuggling data
-- from unqDyn to qDyn

--TODO: It would be much nicer if the TH AST was extensible to support this kind of thing without trickery
unqMarker :: a -> UnqDyn
unqMarker :: forall a. a -> UnqDyn
unqMarker = String -> a -> UnqDyn
forall a. HasCallStack => String -> a
error String
"An unqDyn expression was used outside of a qDyn expression"

-- | Create a 'Dynamic' value using other 'Dynamic's as inputs.  The result is
-- sometimes more concise and readable than the equivalent 'Applicative'-based
-- expression.  For example:
--
-- > [mkDyn| $x + $v * $t + 1/2 * $a * $t ^ 2 |]
--
-- would have a very cumbersome 'Applicative' encoding.
mkDynPure :: QuasiQuoter
mkDynPure :: QuasiQuoter
mkDynPure = QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
mkDynExp
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"mkDyn: pattern splices are not supported"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"mkDyn: type splices are not supported"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"mkDyn: declaration splices are not supported"
  }

mkDynExp :: String -> Q Exp
mkDynExp :: String -> Q Exp
mkDynExp String
s = case ParseMode -> String -> ParseResult (Exp SrcSpanInfo)
Hs.parseExpWithMode ParseMode
Hs.defaultParseMode { extensions :: [Extension]
Hs.extensions = [ KnownExtension -> Extension
Hs.EnableExtension KnownExtension
Hs.TemplateHaskell ] } String
s of
  Hs.ParseFailed (Hs.SrcLoc String
_ Int
l Int
c) String
err -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"mkDyn:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
l String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
c String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
  Hs.ParseOk Exp SrcSpanInfo
e -> Q Exp -> Q Exp
qDynPure (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere (a -> a
forall a. a -> a
id (a -> a) -> (Name -> Name) -> a -> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` Name -> Name
reinstateUnqDyn) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp SrcSpanInfo -> Exp
forall a. ToExp a => a -> Exp
Hs.toExp (Exp SrcSpanInfo -> Exp) -> Exp SrcSpanInfo -> Exp
forall a b. (a -> b) -> a -> b
$ (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere (a -> a
forall a. a -> a
id (a -> a) -> (Exp SrcSpanInfo -> Exp SrcSpanInfo) -> a -> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` Exp SrcSpanInfo -> Exp SrcSpanInfo
antiE) Exp SrcSpanInfo
e
    where TH.Name (TH.OccName String
occName) (TH.NameG NameSpace
_ PkgName
_ (TH.ModName String
modName)) = 'unqMarker
#if MIN_VERSION_haskell_src_exts(1,18,0)
          antiE :: Hs.Exp Hs.SrcSpanInfo -> Hs.Exp Hs.SrcSpanInfo
          antiE :: Exp SrcSpanInfo -> Exp SrcSpanInfo
antiE Exp SrcSpanInfo
x = case Exp SrcSpanInfo
x of
            Hs.SpliceExp SrcSpanInfo
l Splice SrcSpanInfo
se ->
              SrcSpanInfo
-> Exp SrcSpanInfo -> Exp SrcSpanInfo -> Exp SrcSpanInfo
forall l. l -> Exp l -> Exp l -> Exp l
Hs.App SrcSpanInfo
l (SrcSpanInfo -> QName SrcSpanInfo -> Exp SrcSpanInfo
forall l. l -> QName l -> Exp l
Hs.Var SrcSpanInfo
l (QName SrcSpanInfo -> Exp SrcSpanInfo)
-> QName SrcSpanInfo -> Exp SrcSpanInfo
forall a b. (a -> b) -> a -> b
$ SrcSpanInfo
-> ModuleName SrcSpanInfo -> Name SrcSpanInfo -> QName SrcSpanInfo
forall l. l -> ModuleName l -> Name l -> QName l
Hs.Qual SrcSpanInfo
l (SrcSpanInfo -> String -> ModuleName SrcSpanInfo
forall l. l -> String -> ModuleName l
Hs.ModuleName SrcSpanInfo
l String
modName) (SrcSpanInfo -> String -> Name SrcSpanInfo
forall l. l -> String -> Name l
Hs.Ident SrcSpanInfo
l String
occName)) (Exp SrcSpanInfo -> Exp SrcSpanInfo)
-> Exp SrcSpanInfo -> Exp SrcSpanInfo
forall a b. (a -> b) -> a -> b
$ case Splice SrcSpanInfo
se of
                Hs.IdSplice SrcSpanInfo
l2 String
v -> SrcSpanInfo -> QName SrcSpanInfo -> Exp SrcSpanInfo
forall l. l -> QName l -> Exp l
Hs.Var SrcSpanInfo
l2 (QName SrcSpanInfo -> Exp SrcSpanInfo)
-> QName SrcSpanInfo -> Exp SrcSpanInfo
forall a b. (a -> b) -> a -> b
$ SrcSpanInfo -> Name SrcSpanInfo -> QName SrcSpanInfo
forall l. l -> Name l -> QName l
Hs.UnQual SrcSpanInfo
l2 (Name SrcSpanInfo -> QName SrcSpanInfo)
-> Name SrcSpanInfo -> QName SrcSpanInfo
forall a b. (a -> b) -> a -> b
$ SrcSpanInfo -> String -> Name SrcSpanInfo
forall l. l -> String -> Name l
Hs.Ident SrcSpanInfo
l2 String
v
                Hs.ParenSplice SrcSpanInfo
_ Exp SrcSpanInfo
ps -> Exp SrcSpanInfo
ps
            Exp SrcSpanInfo
_ -> Exp SrcSpanInfo
x
#else
          antiE x = case x of
            Hs.SpliceExp se ->
              Hs.App (Hs.Var $ Hs.Qual (Hs.ModuleName modName) (Hs.Ident occName)) $ case se of
                Hs.IdSplice v -> Hs.Var $ Hs.UnQual $ Hs.Ident v
                Hs.ParenSplice ps -> ps
            _ -> x
#endif
          reinstateUnqDyn :: Name -> Name
reinstateUnqDyn (TH.Name (TH.OccName String
occName') (TH.NameQ (TH.ModName String
modName')))
            | String
modName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
modName' Bool -> Bool -> Bool
&& String
occName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
occName' = 'unqMarker
          reinstateUnqDyn Name
x = Name
x