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
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
From b128412ecee9677b788abecbbf1fd1edd447eea2 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 28 Feb 2013 23:35:59 -0400
Subject: [PATCH] remove TH
---
Text/Shakespeare/I18N.hs | 130 +---------------------------------------------
1 file changed, 1 insertion(+), 129 deletions(-)
diff --git a/Text/Shakespeare/I18N.hs b/Text/Shakespeare/I18N.hs
index 1b486ed..aa5e358 100644
--- a/Text/Shakespeare/I18N.hs
+++ b/Text/Shakespeare/I18N.hs
@@ -51,10 +51,7 @@
--
-- You can also adapt those instructions for use with other systems.
module Text.Shakespeare.I18N
- ( mkMessage
- , mkMessageFor
- , mkMessageVariant
- , RenderMessage (..)
+ ( RenderMessage (..)
, ToMessage (..)
, SomeMessage (..)
, Lang
@@ -115,133 +112,8 @@ type Lang = Text
--
-- 3. create a 'RenderMessage' instance
--
-mkMessage :: String -- ^ base name to use for translation type
- -> FilePath -- ^ subdirectory which contains the translation files
- -> Lang -- ^ default translation language
- -> Q [Dec]
-mkMessage dt folder lang =
- mkMessageCommon True "Msg" "Message" dt dt folder lang
--- | create 'RenderMessage' instance for an existing data-type
-mkMessageFor :: String -- ^ master translation data type
- -> String -- ^ existing type to add translations for
- -> FilePath -- ^ path to translation folder
- -> Lang -- ^ default language
- -> Q [Dec]
-mkMessageFor master dt folder lang = mkMessageCommon False "" "" master dt folder lang
-
--- | create an additional set of translations for a type created by `mkMessage`
-mkMessageVariant :: String -- ^ master translation data type
- -> String -- ^ existing type to add translations for
- -> FilePath -- ^ path to translation folder
- -> Lang -- ^ default language
- -> Q [Dec]
-mkMessageVariant master dt folder lang = mkMessageCommon False "Msg" "Message" master dt folder lang
-
--- |used by 'mkMessage' and 'mkMessageFor' to generate a 'RenderMessage' and possibly a message data type
-mkMessageCommon :: Bool -- ^ generate a new datatype from the constructors found in the .msg files
- -> String -- ^ string to append to constructor names
- -> String -- ^ string to append to datatype name
- -> String -- ^ base name of master datatype
- -> String -- ^ base name of translation datatype
- -> FilePath -- ^ path to translation folder
- -> Lang -- ^ default lang
- -> Q [Dec]
-mkMessageCommon genType prefix postfix master dt folder lang = do
- files <- qRunIO $ getDirectoryContents folder
- (_files', contents) <- qRunIO $ fmap (unzip . catMaybes) $ mapM (loadLang folder) files
-#ifdef GHC_7_4
- mapM_ qAddDependentFile _files'
-#endif
- sdef <-
- case lookup lang contents of
- Nothing -> error $ "Did not find main language file: " ++ unpack lang
- Just def -> toSDefs def
- mapM_ (checkDef sdef) $ map snd contents
- let mname = mkName $ dt ++ postfix
- c1 <- fmap concat $ mapM (toClauses prefix dt) contents
- c2 <- mapM (sToClause prefix dt) sdef
- c3 <- defClause
- return $
- ( if genType
- then ((DataD [] mname [] (map (toCon dt) sdef) []) :)
- else id)
- [ InstanceD
- []
- (ConT ''RenderMessage `AppT` (ConT $ mkName master) `AppT` ConT mname)
- [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]
- ]
- ]
-
-toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause]
-toClauses prefix dt (lang, defs) =
- mapM go defs
- where
- go def = do
- a <- newName "lang"
- (pat, bod) <- mkBody dt (prefix ++ constr def) (map fst $ vars def) (content def)
- guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]
- return $ Clause
- [WildP, ConP (mkName ":") [VarP a, WildP], pat]
- (GuardedB [(guard, bod)])
- []
-
-mkBody :: String -- ^ datatype
- -> String -- ^ constructor
- -> [String] -- ^ variable names
- -> [Content]
- -> Q (Pat, Exp)
-mkBody dt cs vs ct = do
- vp <- mapM go vs
- let pat = RecP (mkName cs) (map (varName dt *** VarP) vp)
- let ct' = map (fixVars vp) ct
- pack' <- [|Data.Text.pack|]
- tomsg <- [|toMessage|]
- let ct'' = map (toH pack' tomsg) ct'
- mapp <- [|mappend|]
- let app a b = InfixE (Just a) mapp (Just b)
- e <-
- case ct'' of
- [] -> [|mempty|]
- [x] -> return x
- (x:xs) -> return $ foldl' app x xs
- return (pat, e)
- where
- toH pack' _ (Raw s) = pack' `AppE` SigE (LitE (StringL s)) (ConT ''String)
- toH _ tomsg (Var d) = tomsg `AppE` derefToExp [] d
- go x = do
- let y = mkName $ '_' : x
- return (x, y)
- fixVars vp (Var d) = Var $ fixDeref vp d
- fixVars _ (Raw s) = Raw s
- fixDeref vp (DerefIdent (Ident i)) = DerefIdent $ Ident $ fixIdent vp i
- fixDeref vp (DerefBranch a b) = DerefBranch (fixDeref vp a) (fixDeref vp b)
- fixDeref _ d = d
- fixIdent vp i =
- case lookup i vp of
- Nothing -> i
- Just y -> nameBase y
-
-sToClause :: String -> String -> SDef -> Q Clause
-sToClause prefix dt sdef = do
- (pat, bod) <- mkBody dt (prefix ++ sconstr sdef) (map fst $ svars sdef) (scontent sdef)
- return $ Clause
- [WildP, ConP (mkName "[]") [], pat]
- (NormalB bod)
- []
-
-defClause :: Q Clause
-defClause = do
- a <- newName "sub"
- c <- newName "langs"
- d <- newName "msg"
- rm <- [|renderMessage|]
- return $ Clause
- [VarP a, ConP (mkName ":") [WildP, VarP c], VarP d]
- (NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE d)
- []
-
toCon :: String -> SDef -> Con
toCon dt (SDef c vs _) =
RecC (mkName $ "Msg" ++ c) $ map go vs
--
1.7.10.4
|
