blob: 2e0076a767fea5db505bd05253030f11436f2aec (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
|
{-# LANGUAGE TemplateHaskellQuotes #-}
module Simplify.TH (simprec) where
import Data.Bifunctor (first)
import Data.Char
import Data.List (foldl1')
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Text.ParserCombinators.ReadP
-- [simprec| EPair ext *a *b |]
-- ~>
-- do a' <- within (\a' -> EPair ext a' b) (simplify' a)
-- b' <- within (\b' -> EPair ext a' b') (simplify' b)
-- pure (EPair ext a' b')
simprec :: QuasiQuoter
simprec = QuasiQuoter
{ quoteDec = \_ -> fail "simprec used outside of expression context"
, quoteType = \_ -> fail "simprec used outside of expression context"
, quoteExp = handler
, quotePat = \_ -> fail "simprec used outside of expression context"
}
handler :: String -> Q Exp
handler str =
case readP_to_S pTemplate str of
[(template, "")] -> generate template
_:_:_ -> fail "simprec: template grammar ambiguous"
_ -> fail "simprec: could not parse template"
generate :: Template -> Q Exp
generate (Template topitems) =
let takePrefix (Plain x : xs) = first (x:) (takePrefix xs)
takePrefix xs = ([], xs)
itemVar "" = error "simprec: empty item name?"
itemVar name@(c:_) | isLower c = VarE (mkName name)
| isUpper c = ConE (mkName name)
| otherwise = error "simprec: non-letter item name?"
loop :: Exp -> [Item] -> Q [Stmt]
loop yet [] = return [NoBindS (VarE 'pure `AppE` yet)]
loop yet (Plain x : xs) = loop (yet `AppE` itemVar x) xs
loop yet (Recurse x : xs) = do
primeName <- newName (x ++ "'")
let appPrePrime e (Plain y) = e `AppE` itemVar y
appPrePrime e (Recurse y) = e `AppE` itemVar y
let stmt = BindS (VarP primeName) $
VarE (mkName "within")
`AppE` LamE [VarP primeName] (foldl' appPrePrime (yet `AppE` VarE primeName) xs)
`AppE` (VarE (mkName "simplify'") `AppE` VarE (mkName x))
stmts <- loop (yet `AppE` VarE primeName) xs
return (stmt : stmts)
(prefix, items') = takePrefix topitems
in DoE Nothing <$> loop (foldl1' AppE (map itemVar prefix)) items'
data Template = Template [Item]
deriving (Show)
data Item = Plain String | Recurse String
deriving (Show)
pTemplate :: ReadP Template
pTemplate = do
items <- many (skipSpaces >> pItem)
skipSpaces
eof
return (Template items)
pItem :: ReadP Item
pItem = (char '*' >> Recurse <$> pName) +++ (Plain <$> pName)
pName :: ReadP String
pName = do
c1 <- satisfy (\c -> isAlpha c || c == '_')
cs <- munch (\c -> isAlphaNum c || c `elem` "_'")
return (c1:cs)
|
