Yesod.Message moved to shakespeare-i18n
This commit is contained in:
Michael Snoyman
parent
a1dc16b364
commit
7e643d6848
@ -1,259 +1,5 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
|
||||||
{-# LANGUAGE ExistentialQuantification #-}
|
|
||||||
module Yesod.Message
|
module Yesod.Message
|
||||||
( mkMessage
|
( module Text.Shakespeare.I18N
|
||||||
, RenderMessage (..)
|
|
||||||
, ToMessage (..)
|
|
||||||
, SomeMessage (..)
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Language.Haskell.TH.Syntax
|
import Text.Shakespeare.I18N
|
||||||
import Data.Text (Text, pack, unpack)
|
|
||||||
import System.Directory
|
|
||||||
import Data.Maybe (catMaybes)
|
|
||||||
import Data.List (isSuffixOf, sortBy, foldl')
|
|
||||||
import qualified Data.ByteString as S
|
|
||||||
import Data.Text.Encoding (decodeUtf8)
|
|
||||||
import Data.Char (isSpace, toLower, toUpper)
|
|
||||||
import Data.Ord (comparing)
|
|
||||||
import Text.Shakespeare.Base (Deref (..), Ident (..), parseHash, derefToExp)
|
|
||||||
import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>))
|
|
||||||
import Control.Arrow ((***))
|
|
||||||
import Data.Monoid (mempty, mappend)
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Data.String (IsString (fromString))
|
|
||||||
|
|
||||||
class ToMessage a where
|
|
||||||
toMessage :: a -> Text
|
|
||||||
instance ToMessage Text where
|
|
||||||
toMessage = id
|
|
||||||
instance ToMessage String where
|
|
||||||
toMessage = Data.Text.pack
|
|
||||||
|
|
||||||
class RenderMessage master message where
|
|
||||||
renderMessage :: master
|
|
||||||
-> [Text] -- ^ languages
|
|
||||||
-> message
|
|
||||||
-> Text
|
|
||||||
|
|
||||||
instance RenderMessage master Text where
|
|
||||||
renderMessage _ _ = id
|
|
||||||
|
|
||||||
type Lang = Text
|
|
||||||
|
|
||||||
mkMessage :: String
|
|
||||||
-> FilePath
|
|
||||||
-> Lang
|
|
||||||
-> Q [Dec]
|
|
||||||
mkMessage dt folder lang = do
|
|
||||||
files <- qRunIO $ getDirectoryContents folder
|
|
||||||
contents <- qRunIO $ fmap catMaybes $ mapM (loadLang folder) files
|
|
||||||
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 dt' = ConT $ mkName dt
|
|
||||||
let mname = mkName $ dt ++ "Message"
|
|
||||||
c1 <- fmap concat $ mapM (toClauses dt) contents
|
|
||||||
c2 <- mapM (sToClause dt) sdef
|
|
||||||
c3 <- defClause
|
|
||||||
return
|
|
||||||
[ DataD [] mname [] (map (toCon dt) sdef) []
|
|
||||||
, InstanceD
|
|
||||||
[]
|
|
||||||
(ConT ''RenderMessage `AppT` dt' `AppT` ConT mname)
|
|
||||||
[ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
toClauses :: String -> (Lang, [Def]) -> Q [Clause]
|
|
||||||
toClauses dt (lang, defs) =
|
|
||||||
mapM go defs
|
|
||||||
where
|
|
||||||
go def = do
|
|
||||||
a <- newName "lang"
|
|
||||||
(pat, bod) <- mkBody dt (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 $ "Msg" ++ 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 -> SDef -> Q Clause
|
|
||||||
sToClause dt sdef = do
|
|
||||||
(pat, bod) <- mkBody dt (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
|
|
||||||
where
|
|
||||||
go (n, t) = (varName dt n, NotStrict, ConT $ mkName t)
|
|
||||||
|
|
||||||
varName :: String -> String -> Name
|
|
||||||
varName a y =
|
|
||||||
mkName $ concat [lower a, "Message", upper y]
|
|
||||||
where
|
|
||||||
lower (x:xs) = toLower x : xs
|
|
||||||
lower [] = []
|
|
||||||
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
|
|
||||||
, svars :: [(String, String)]
|
|
||||||
, scontent :: [Content]
|
|
||||||
}
|
|
||||||
|
|
||||||
data Def = Def
|
|
||||||
{ constr :: String
|
|
||||||
, vars :: [(String, Maybe String)]
|
|
||||||
, content :: [Content]
|
|
||||||
}
|
|
||||||
|
|
||||||
loadLang :: FilePath -> FilePath -> IO (Maybe (Lang, [Def]))
|
|
||||||
loadLang folder file = do
|
|
||||||
let file' = folder ++ '/' : file
|
|
||||||
e <- doesFileExist file'
|
|
||||||
if e && ".msg" `isSuffixOf` file
|
|
||||||
then do
|
|
||||||
let lang = pack $ reverse $ drop 4 $ reverse file
|
|
||||||
bs <- S.readFile file'
|
|
||||||
let s = unpack $ decodeUtf8 bs
|
|
||||||
defs <- fmap catMaybes $ mapM parseDef $ lines s
|
|
||||||
return $ Just (lang, defs)
|
|
||||||
else return Nothing
|
|
||||||
|
|
||||||
parseDef :: String -> IO (Maybe Def)
|
|
||||||
parseDef "" = return Nothing
|
|
||||||
parseDef ('#':_) = return Nothing
|
|
||||||
parseDef s =
|
|
||||||
case end of
|
|
||||||
':':end' -> do
|
|
||||||
content' <- fmap compress $ parseContent $ dropWhile isSpace end'
|
|
||||||
case words begin of
|
|
||||||
[] -> error $ "Missing constructor: " ++ s
|
|
||||||
(w:ws) -> return $ Just Def
|
|
||||||
{ constr = w
|
|
||||||
, vars = map parseVar ws
|
|
||||||
, content = content'
|
|
||||||
}
|
|
||||||
_ -> error $ "Missing colon: " ++ s
|
|
||||||
where
|
|
||||||
(begin, end) = break (== ':') s
|
|
||||||
|
|
||||||
data Content = Var Deref | Raw String
|
|
||||||
|
|
||||||
compress :: [Content] -> [Content]
|
|
||||||
compress [] = []
|
|
||||||
compress (Raw a:Raw b:rest) = compress $ Raw (a ++ b) : rest
|
|
||||||
compress (x:y) = x : compress y
|
|
||||||
|
|
||||||
parseContent :: String -> IO [Content]
|
|
||||||
parseContent s =
|
|
||||||
either (error . show) return $ parse go s s
|
|
||||||
where
|
|
||||||
go = do
|
|
||||||
x <- many go'
|
|
||||||
eof
|
|
||||||
return x
|
|
||||||
go' = (Raw `fmap` many1 (noneOf "#")) <|> (fmap (either Raw Var) parseHash)
|
|
||||||
|
|
||||||
parseVar :: String -> (String, Maybe String)
|
|
||||||
parseVar s =
|
|
||||||
case break (== '@') s of
|
|
||||||
(x, '@':y) -> (x, Just y)
|
|
||||||
_ -> (s, Nothing)
|
|
||||||
|
|
||||||
data SomeMessage master = forall msg. RenderMessage master msg => SomeMessage msg
|
|
||||||
|
|
||||||
instance IsString (SomeMessage master) where
|
|
||||||
fromString = SomeMessage . T.pack
|
|
||||||
|
|||||||
@ -56,6 +56,7 @@ library
|
|||||||
, shakespeare >= 0.10 && < 0.11
|
, shakespeare >= 0.10 && < 0.11
|
||||||
, shakespeare-js >= 0.10 && < 0.11
|
, shakespeare-js >= 0.10 && < 0.11
|
||||||
, shakespeare-css >= 0.10 && < 0.11
|
, shakespeare-css >= 0.10 && < 0.11
|
||||||
|
, shakespeare-i18n >= 0.0 && < 0.1
|
||||||
, blaze-builder >= 0.2.1.4 && < 0.4
|
, blaze-builder >= 0.2.1.4 && < 0.4
|
||||||
, transformers >= 0.2.2 && < 0.3
|
, transformers >= 0.2.2 && < 0.3
|
||||||
, clientsession >= 0.7.3.1 && < 0.8
|
, clientsession >= 0.7.3.1 && < 0.8
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user