git-annex-5.20131221: standalone/no-th/haskell-patches/shakespeare-i18n_0001-remove-TH.patch
From 57ad7d1512a3144fd0b00f9796d5fd9e0ea86852 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 17 Dec 2013 16:30:59 +0000
Subject: [PATCH] remove TH
---
Text/Shakespeare/I18N.hs | 178 ++---------------------------------------------
1 file changed, 4 insertions(+), 174 deletions(-)
diff --git a/Text/Shakespeare/I18N.hs b/Text/Shakespeare/I18N.hs
index 2077914..2289214 100644
--- a/Text/Shakespeare/I18N.hs
+++ b/Text/Shakespeare/I18N.hs
@@ -51,10 +51,10 @@
--
-- You can also adapt those instructions for use with other systems.
module Text.Shakespeare.I18N
- ( mkMessage
- , mkMessageFor
- , mkMessageVariant
- , RenderMessage (..)
+ --( mkMessage
+ --, mkMessageFor
+ ---, mkMessageVariant
+ ( RenderMessage (..)
, ToMessage (..)
, SomeMessage (..)
, Lang
@@ -105,143 +105,6 @@ instance RenderMessage master Text where
-- | an RFC1766 / ISO 639-1 language code (eg, @fr@, @en-GB@, etc).
type Lang = Text
--- |generate translations from translation files
---
--- This function will:
---
--- 1. look in the supplied subdirectory for files ending in @.msg@
---
--- 2. generate a type based on the constructors found
---
--- 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
@@ -257,39 +120,6 @@ varName a y =
upper (x:xs) = toUpper x : xs
upper [] = []
-checkDef :: [SDef] -> [Def] -> Q ()
-checkDef x y =
- go (sortBy (comparing sconstr) x) (sortBy (comparing constr) y)
- where
- go _ [] = return ()
- go [] (b:_) = error $ "Extra message constructor: " ++ constr b
- go (a:as) (b:bs)
- | sconstr a < constr b = go as (b:bs)
- | sconstr a > constr b = error $ "Extra message constructor: " ++ constr b
- | otherwise = do
- go' (svars a) (vars b)
- go as bs
- go' ((an, at):as) ((bn, mbt):bs)
- | an /= bn = error "Mismatched variable names"
- | otherwise =
- case mbt of
- Nothing -> go' as bs
- Just bt
- | at == bt -> go' as bs
- | otherwise -> error "Mismatched variable types"
- go' [] [] = return ()
- go' _ _ = error "Mistmached variable count"
-
-toSDefs :: [Def] -> Q [SDef]
-toSDefs = mapM toSDef
-
-toSDef :: Def -> Q SDef
-toSDef d = do
- vars' <- mapM go $ vars d
- return $ SDef (constr d) vars' (content d)
- where
- go (a, Just b) = return (a, b)
- go (a, Nothing) = error $ "Main language missing type for " ++ show (constr d, a)
data SDef = SDef
{ sconstr :: String
--
1.8.5.1