git.iko.soy/patch
on bc216da help sign in
patch/src/Reflex/Dynamic/TH.hs
130 lines 5.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 -- * Deprecated functions
17 , qDyn
18 , mkDyn
19 ) where
21import Reflex.Dynamic
23import Control.Monad.State
24import Data.Data
25import Data.Generics
26import Data.Monoid
27import qualified Language.Haskell.Exts as Hs
28import qualified Language.Haskell.Meta.Syntax.Translate as Hs
29import Language.Haskell.TH
30import Language.Haskell.TH.Quote
31import qualified Language.Haskell.TH.Syntax as TH
33-- | Quote a 'Dynamic' expression. Within the quoted expression, you can use
34-- @$(unqDyn [| x |])@ to refer to any expression @x@ of type @Dynamic t a@; the
35-- unquoted result will be of type @a@
36qDynPure :: Q Exp -> Q Exp
37qDynPure qe = do
38 e <- qe
39 let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d
40 f d = case eqT of
41 Just (Refl :: d :~: Exp)
42 | AppE (VarE m) eInner <- d
43 , m == 'unqMarker
44 -> do n <- lift $ newName "dynamicQuotedExpressionVariable"
45 modify ((n, eInner):)
46 return $ VarE n
47 _ -> gmapM f d
48 (e', exprsReversed) <- runStateT (gmapM f e) []
49 let exprs = reverse exprsReversed
50 arg = foldr (\a b -> ConE 'FHCons `AppE` snd a `AppE` b) (ConE 'FHNil) exprs
51 param = foldr (\a b -> ConP 'HCons [VarP (fst a), b]) (ConP 'HNil []) exprs
52 [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]
54-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a
55-- 'qDyn' quotation.
56unqDyn :: Q Exp -> Q Exp
57unqDyn e = [| unqMarker $e |]
59-- | This type represents an occurrence of unqDyn before it has been processed
60-- by qDyn. If you see it in a type error, it probably means that unqDyn has
61-- been used outside of a qDyn context.
62data UnqDyn
64-- unqMarker must not be exported; it is used only as a way of smuggling data
65-- from unqDyn to qDyn
67--TODO: It would be much nicer if the TH AST was extensible to support this kind of thing without trickery
68unqMarker :: a -> UnqDyn
69unqMarker = error "An unqDyn expression was used outside of a qDyn expression"
71-- | Create a 'Dynamic' value using other 'Dynamic's as inputs. The result is
72-- sometimes more concise and readable than the equivalent 'Applicative'-based
73-- expression. For example:
74--
75-- > [mkDyn| $x + $v * $t + 1/2 * $a * $t ^ 2 |]
76--
77-- would have a very cumbersome 'Applicative' encoding.
78mkDynPure :: QuasiQuoter
79mkDynPure = QuasiQuoter
80 { quoteExp = mkDynExp
81 , quotePat = error "mkDyn: pattern splices are not supported"
82 , quoteType = error "mkDyn: type splices are not supported"
83 , quoteDec = error "mkDyn: declaration splices are not supported"
84 }
86mkDynExp :: String -> Q Exp
87mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of
88 Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err
89 Hs.ParseOk e -> qDynPure $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e
90 where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker
91#if MIN_VERSION_haskell_src_exts(1,18,0)
92 antiE :: Hs.Exp Hs.SrcSpanInfo -> Hs.Exp Hs.SrcSpanInfo
93 antiE x = case x of
94 Hs.SpliceExp l se ->
95 Hs.App l (Hs.Var l $ Hs.Qual l (Hs.ModuleName l modName) (Hs.Ident l occName)) $ case se of
96 Hs.IdSplice l2 v -> Hs.Var l2 $ Hs.UnQual l2 $ Hs.Ident l2 v
97 Hs.ParenSplice _ ps -> ps
98 _ -> x
99#else
100 antiE x = case x of
101 Hs.SpliceExp se ->
102 Hs.App (Hs.Var $ Hs.Qual (Hs.ModuleName modName) (Hs.Ident occName)) $ case se of
103 Hs.IdSplice v -> Hs.Var $ Hs.UnQual $ Hs.Ident v
104 Hs.ParenSplice ps -> ps
105 _ -> x
106#endif
107 reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))
108 | modName == modName' && occName == occName' = 'unqMarker
109 reinstateUnqDyn x = x
111--------------------------------------------------------------------------------
112-- Deprecated
113--------------------------------------------------------------------------------
115{-# DEPRECATED qDyn "Instead of $(qDyn x), use return $(qDynPure x)" #-}
116-- | Like 'qDynPure', but wraps its result monadically using 'return'. This is
117-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'.
118qDyn :: Q Exp -> Q Exp
119qDyn qe = [| return $(qDynPure qe) |]
121{-# DEPRECATED mkDyn "Instead of [mkDyn| x |], use return [mkDynPure| x |]" #-}
122-- | Like 'mkDynPure', but wraps its result monadically using 'return'. This is
123-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'.
124mkDyn :: QuasiQuoter
125mkDyn = QuasiQuoter
126 { quoteExp = \s -> [| return $(mkDynExp s) |]
127 , quotePat = error "mkDyn: pattern splices are not supported"
128 , quoteType = error "mkDyn: type splices are not supported"
129 , quoteDec = error "mkDyn: declaration splices are not supported"
130 }