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