git.iko.soy/patch
on 6dfd512 help sign in
patch/src/Reflex/Dynamic/TH.hs
72 lines 3.3 kB history raw
1{-# LANGUAGE EmptyDataDecls #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE PatternGuards #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE TypeOperators #-}
7module Reflex.Dynamic.TH (qDyn, unqDyn, mkDyn) where
9import Reflex.Dynamic
11import Control.Monad.State
12import Data.Data
13import Data.Generics
14import Data.Monoid
15import qualified Language.Haskell.Exts as Hs
16import qualified Language.Haskell.Meta.Syntax.Translate as Hs
17import Language.Haskell.TH
18import Language.Haskell.TH.Quote
19import qualified Language.Haskell.TH.Syntax as TH
21-- | 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'
22qDyn :: Q Exp -> Q Exp
23qDyn qe = do
24 e <- qe
25 let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d
26 f d = case eqT of
27 Just (Refl :: d :~: Exp)
28 | AppE (VarE m) eInner <- d
29 , m == 'unqMarker
30 -> do n <- lift $ newName "dynamicQuotedExpressionVariable"
31 modify ((n, eInner):)
32 return $ VarE n
33 _ -> gmapM f d
34 (e', exprsReversed) <- runStateT (gmapM f e) []
35 let exprs = reverse exprsReversed
36 arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs
37 param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs
38 [| mapDyn $(return $ LamE [param] e') =<< distributeFHListOverDyn $(return arg) |]
40unqDyn :: Q Exp -> Q Exp
41unqDyn e = [| unqMarker $e |]
43-- | 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.
44data UnqDyn
46-- unqMarker must not be exported; it is used only as a way of smuggling data from unqDyn to qDyn
47--TODO: It would be much nicer if the TH AST was extensible to support this kind of thing without trickery
48unqMarker :: a -> UnqDyn
49unqMarker = error "An unqDyn expression was used outside of a qDyn expression"
51mkDyn :: QuasiQuoter
52mkDyn = QuasiQuoter
53 { quoteExp = mkDynExp
54 , quotePat = error "mkDyn: pattern splices are not supported"
55 , quoteType = error "mkDyn: type splices are not supported"
56 , quoteDec = error "mkDyn: declaration splices are not supported"
57 }
59mkDynExp :: String -> Q Exp
60mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of
61 Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err
62 Hs.ParseOk e -> qDyn $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e
63 where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker
64 antiE x = case x of
65 Hs.SpliceExp se ->
66 Hs.App (Hs.Var $ Hs.Qual (Hs.ModuleName modName) (Hs.Ident occName)) $ case se of
67 Hs.IdSplice v -> Hs.Var $ Hs.UnQual $ Hs.Ident v
68 Hs.ParenSplice ps -> ps
69 _ -> x
70 reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))
71 | modName == modName' && occName == occName' = 'unqMarker
72 reinstateUnqDyn x = x