ccef06da41
Was able to reuse many of the android patches, but several had to be re-done. On Android, ghc is a stage2 build, so can compile, but not run TH code. But debian's ghc on armel cannot even compile TH code, so it has to be patched out. Some haskell packages have been updated to new versions, including yesod and DAV, and their patches had to be redone. The Makefile now has 2 new targets. The first is run on a companion x86 system to do the build and get TH splices. Then the second target is run the same source tree on the arm system to build without needing TH. This commit was sponsored by Svenne Krap.
215 lines
7.6 KiB
Diff
215 lines
7.6 KiB
Diff
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
|
|
|