@@ -1,46 +1,19 @@
11{-# LANGUAGE TemplateHaskell #-}
22{-# LANGUAGE MagicHash #-}
3−{-# LANGUAGE CPP #-}
43
54-- | Template Haskell utilities.
65
7−module Control.Ether.TH
8− ( ethereal
9− ) where
6+module Control.Ether.TH (tag) where
107
118import qualified Language.Haskell.TH as TH
9+import qualified Language.Haskell.TH.Quote as TH
1210
1311import GHC.Prim (Proxy#, proxy#)
1412
15−emptyDataDecl :: TH.Name -> TH.DecQ
16−#if __GLASGOW_HASKELL__ < 800
17−emptyDataDecl name = TH.dataD (return []) name [] [] []
18−#else
19−emptyDataDecl name = TH.dataD (return []) name [] Nothing [] (return [])
20−#endif
21−
22−funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
23−funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
24−
25−proxySimple :: TH.Name -> TH.TypeQ -> TH.Q (TH.Dec, TH.Dec)
26−proxySimple name ty = do
27− sig <- TH.sigD name [t| Proxy# $ty |]
28− val <- funSimple name [e| proxy# |]
29− return (sig, val)
30−
31−-- |
32−-- Creates a tag and a value-level proxy for it.
33−--
34−-- @'ethereal' \"Foo\" \"foo\"@ generates the following code:
35−--
36−-- > data Foo
37−-- > foo :: Proxy Foo
38−-- > foo = Proxy
39−ethereal :: String -> String -> TH.DecsQ
40−ethereal strTagName strTagProxyName = do
41− let tagName = TH.mkName strTagName
42− tag = TH.conT tagName
43− tagProxyName = TH.mkName strTagProxyName
44− tagDecl <- emptyDataDecl tagName
45− (tagProxySig, tagProxyVal) <- proxySimple tagProxyName tag
46− return [tagDecl, tagProxySig, tagProxyVal]
13+tag :: TH.QuasiQuoter
14+tag = TH.QuasiQuoter proxyExpQ undefined undefined undefined
15+ where
16+ proxyExpQ :: String -> TH.ExpQ
17+ proxyExpQ nameStr =
18+ let ty = TH.conT (TH.mkName nameStr)
19+ in [e| proxy# :: Proxy# $ty |]