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