git.iko.soy/reflex
on ae@dev-script help sign in
reflex/src/Reflex/Dynamic/TH.hs
106 lines 4.3 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE EmptyDataDecls #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE PatternGuards #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TemplateHaskell #-}
7{-# LANGUAGE TypeOperators #-}
8#ifdef USE_REFLEX_OPTIMIZER
9{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
10#endif
11-- | Template Haskell helper functions for building complex 'Dynamic' values.
12module Reflex.Dynamic.TH
13 ( qDynPure
14 , unqDyn
15 , mkDynPure
16 ) where
18import Reflex.Dynamic
20import Control.Monad.State
21import Data.Data
22import Data.Generics
23import Data.Monoid ((<>))
24import qualified Language.Haskell.Exts as Hs
25import qualified Language.Haskell.Meta.Syntax.Translate as Hs
26import Language.Haskell.TH
27import Language.Haskell.TH.Quote
28import qualified Language.Haskell.TH.Syntax as TH
30-- | Quote a 'Dynamic' expression. Within the quoted expression, you can use
31-- @$(unqDyn [| x |])@ to refer to any expression @x@ of type @Dynamic t a@; the
32-- unquoted result will be of type @a@
33qDynPure :: Q Exp -> Q Exp
34qDynPure qe = do
35 e <- qe
36 let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d
37 f d = case eqT of
38 Just (Refl :: d :~: Exp)
39 | AppE (VarE m) eInner <- d
40 , m == 'unqMarker
41 -> do n <- lift $ newName "dynamicQuotedExpressionVariable"
42 modify ((n, eInner):)
43 return $ VarE n
44 _ -> gmapM f d
45 (e', exprsReversed) <- runStateT (gmapM f e) []
46 let exprs = reverse exprsReversed
47 arg = foldr (\a b -> ConE 'FHCons `AppE` snd a `AppE` b) (ConE 'FHNil) exprs
48 param = foldr (\a b -> ConP 'HCons [VarP (fst a), b]) (ConP 'HNil []) exprs
49 [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]
51-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a
52-- 'qDyn' quotation.
53unqDyn :: Q Exp -> Q Exp
54unqDyn e = [| unqMarker $e |]
56-- | This type represents an occurrence of unqDyn before it has been processed
57-- by qDyn. If you see it in a type error, it probably means that unqDyn has
58-- been used outside of a qDyn context.
59data UnqDyn
61-- unqMarker must not be exported; it is used only as a way of smuggling data
62-- from unqDyn to qDyn
64--TODO: It would be much nicer if the TH AST was extensible to support this kind of thing without trickery
65unqMarker :: a -> UnqDyn
66unqMarker = error "An unqDyn expression was used outside of a qDyn expression"
68-- | Create a 'Dynamic' value using other 'Dynamic's as inputs. The result is
69-- sometimes more concise and readable than the equivalent 'Applicative'-based
70-- expression. For example:
71--
72-- > [mkDyn| $x + $v * $t + 1/2 * $a * $t ^ 2 |]
73--
74-- would have a very cumbersome 'Applicative' encoding.
75mkDynPure :: QuasiQuoter
76mkDynPure = QuasiQuoter
77 { quoteExp = mkDynExp
78 , quotePat = error "mkDyn: pattern splices are not supported"
79 , quoteType = error "mkDyn: type splices are not supported"
80 , quoteDec = error "mkDyn: declaration splices are not supported"
81 }
83mkDynExp :: String -> Q Exp
84mkDynExp s = case Hs.parseExpWithMode Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] } s of
85 Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err
86 Hs.ParseOk e -> qDynPure $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e
87 where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker
88#if MIN_VERSION_haskell_src_exts(1,18,0)
89 antiE :: Hs.Exp Hs.SrcSpanInfo -> Hs.Exp Hs.SrcSpanInfo
90 antiE x = case x of
91 Hs.SpliceExp l se ->
92 Hs.App l (Hs.Var l $ Hs.Qual l (Hs.ModuleName l modName) (Hs.Ident l occName)) $ case se of
93 Hs.IdSplice l2 v -> Hs.Var l2 $ Hs.UnQual l2 $ Hs.Ident l2 v
94 Hs.ParenSplice _ ps -> ps
95 _ -> x
96#else
97 antiE x = case x of
98 Hs.SpliceExp se ->
99 Hs.App (Hs.Var $ Hs.Qual (Hs.ModuleName modName) (Hs.Ident occName)) $ case se of
100 Hs.IdSplice v -> Hs.Var $ Hs.UnQual $ Hs.Ident v
101 Hs.ParenSplice ps -> ps
102 _ -> x
103#endif
104 reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))
105 | modName == modName' && occName == occName' = 'unqMarker
106 reinstateUnqDyn x = x