@@ -1,11 +1,17 @@
11{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeOperators, GADTs, EmptyDataDecls, PatternGuards #-}
2−module Reflex.Dynamic.TH (qDyn, unqDyn) where
2+module Reflex.Dynamic.TH (qDyn, unqDyn, mkDyn) where
33
44import Reflex.Dynamic
55
66import Language.Haskell.TH
7+import qualified Language.Haskell.TH.Syntax as TH
8+import Language.Haskell.TH.Quote
79import Data.Data
810import Control.Monad.State
11+import qualified Language.Haskell.Exts as Hs
12+import qualified Language.Haskell.Meta.Syntax.Translate as Hs
13+import Data.Monoid
14+import Data.Generics
915
1016-- | 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'
1117qDyn :: Q Exp -> Q Exp
@@ -36,3 +42,26 @@ data UnqDyn
3642--TODO: It would be much nicer if the TH AST was extensible to support this kind of thing without trickery
3743unqMarker :: a -> UnqDyn
3844unqMarker = error "An unqDyn expression was used outside of a qDyn expression"
45+
46+mkDyn :: QuasiQuoter
47+mkDyn = QuasiQuoter
48+ { quoteExp = mkDynExp
49+ , quotePat = error "mkDyn: pattern splices are not supported"
50+ , quoteType = error "mkDyn: type splices are not supported"
51+ , quoteDec = error "mkDyn: declaration splices are not supported"
52+ }
53+
54+mkDynExp :: String -> Q Exp
55+mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of
56+ Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err
57+ Hs.ParseOk e -> qDyn $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e
58+ where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker
59+ antiE x = case x of
60+ Hs.SpliceExp se ->
61+ Hs.App (Hs.Var $ Hs.Qual (Hs.ModuleName modName) (Hs.Ident occName)) $ case se of
62+ Hs.IdSplice v -> Hs.Var $ Hs.UnQual $ Hs.Ident v
63+ Hs.ParenSplice ps -> ps
64+ _ -> x
65+ reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))
66+ | modName == modName' && occName == occName' = 'unqMarker
67+ reinstateUnqDyn x = x