{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
#ifdef USE_REFLEX_OPTIMIZER
{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
#endif
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
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 :: 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 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 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 (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
gmapM 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
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 (\(Name, Exp)
a 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 (\(Name, Exp)
a 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) |]
unqDyn :: Q Exp -> Q Exp
unqDyn :: Q Exp -> Q Exp
unqDyn Q Exp
e = [| unqMarker $e |]
data UnqDyn
unqMarker :: a -> UnqDyn
unqMarker :: a -> UnqDyn
unqMarker = String -> a -> UnqDyn
forall a. HasCallStack => String -> a
error String
"An unqDyn expression was used outside of a qDyn expression"
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 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 (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 (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 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