{-# 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 qe :: Q Exp
qe = do
  Exp
e <- Q Exp
qe
  let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d
      f :: d -> StateT [(Name, Exp)] Q d
f d :: 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 m) 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 (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
newName "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 d
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> StateT [(Name, Exp)] Q d)
-> Exp -> StateT [(Name, Exp)] Q d
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
n
        _ -> (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
gmapM forall d. Data d => d -> StateT [(Name, Exp)] Q d
f d
d
  (e' :: Exp
e', exprsReversed :: [(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
gmapM 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 :: Exp
arg = ((Name, Exp) -> Exp -> Exp) -> Exp -> [(Name, Exp)] -> Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a :: (Name, Exp)
a b :: Exp
b -> Name -> Exp
ConE 'FHCons Exp -> Exp -> Exp
`AppE` (Name, Exp) -> Exp
forall a b. (a, b) -> b
snd (Name, Exp)
a Exp -> Exp -> Exp
`AppE` Exp
b) (Name -> Exp
ConE 'FHNil) [(Name, Exp)]
exprs
      param :: Pat
param = ((Name, Exp) -> Pat -> Pat) -> Pat -> [(Name, Exp)] -> Pat
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a :: (Name, Exp)
a b :: Pat
b -> Name -> [Pat] -> Pat
ConP 'HCons [Name -> Pat
VarP ((Name, Exp) -> Name
forall a b. (a, b) -> a
fst (Name, Exp)
a), Pat
b]) (Name -> [Pat] -> Pat
ConP 'HNil []) [(Name, Exp)]
exprs
  [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return 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 e :: Q Exp
e = [| unqMarker $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 :: a -> UnqDyn
unqMarker = String -> a -> UnqDyn
forall a. HasCallStack => String -> a
error "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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
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 "mkDyn: pattern splices are not supported"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error "mkDyn: type splices are not supported"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error "mkDyn: declaration splices are not supported"
  }

mkDynExp :: String -> Q Exp
mkDynExp :: String -> Q Exp
mkDynExp s :: 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 _ l :: Int
l c :: Int
c) err :: String
err -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "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
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
forall a. Semigroup a => a -> a -> a
<> String
err
  Hs.ParseOk e :: 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 (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) -> Exp SrcSpanInfo -> Exp SrcSpanInfo
(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 occName :: String
occName) (TH.NameG _ _ (TH.ModName 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 x :: Exp SrcSpanInfo
x = case Exp SrcSpanInfo
x of
            Hs.SpliceExp l :: SrcSpanInfo
l se :: 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 l2 :: SrcSpanInfo
l2 v :: 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 _ ps :: Exp SrcSpanInfo
ps -> Exp SrcSpanInfo
ps
            _ -> 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 occName' :: String
occName') (TH.NameQ (TH.ModName 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 x :: Name
x = Name
x