git.iko.soy/patch
on e596bab help sign in
patch/src/Reflex/Dynamic/TH.hs
67 lines 3.2 kB history raw
1{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeOperators, GADTs, EmptyDataDecls, PatternGuards #-}
2module Reflex.Dynamic.TH (qDyn, unqDyn, mkDyn) where
4import Reflex.Dynamic
6import Language.Haskell.TH
7import qualified Language.Haskell.TH.Syntax as TH
8import Language.Haskell.TH.Quote
9import Data.Data
10import Control.Monad.State
11import qualified Language.Haskell.Exts as Hs
12import qualified Language.Haskell.Meta.Syntax.Translate as Hs
13import Data.Monoid
14import Data.Generics
16-- | 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'
17qDyn :: Q Exp -> Q Exp
18qDyn qe = do
19 e <- qe
20 let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d
21 f d = case eqT of
22 Just (Refl :: d :~: Exp)
23 | AppE (VarE m) eInner <- d
24 , m == 'unqMarker
25 -> do n <- lift $ newName "dynamicQuotedExpressionVariable"
26 modify ((n, eInner):)
27 return $ VarE n
28 _ -> gmapM f d
29 (e', exprsReversed) <- runStateT (gmapM f e) []
30 let exprs = reverse exprsReversed
31 arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs
32 param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs
33 [| mapDyn $(return $ LamE [param] e') =<< distributeFHListOverDyn $(return arg) |]
35unqDyn :: Q Exp -> Q Exp
36unqDyn e = [| unqMarker $e |]
38-- | 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.
39data UnqDyn
41-- unqMarker must not be exported; it is used only as a way of smuggling data from unqDyn to qDyn
42--TODO: It would be much nicer if the TH AST was extensible to support this kind of thing without trickery
43unqMarker :: a -> UnqDyn
44unqMarker = error "An unqDyn expression was used outside of a qDyn expression"
46mkDyn :: QuasiQuoter
47mkDyn = 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 }
54mkDynExp :: String -> Q Exp
55mkDynExp 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