1bc5734037
This goes all the way up to Yesod, but everything above Wai is a real hack job, removing TH left and right.
162 lines
5.9 KiB
Diff
162 lines
5.9 KiB
Diff
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
|
|
|