shakespeare 2.1.4 → 2.1.7
raw patch · 5 files changed
+182/−54 lines, 5 filesdep ~bytestring
Dependency ranges changed: bytestring
Files
- ChangeLog.md +13/−0
- Text/Hamlet.hs +4/−2
- Text/Shakespeare/I18N.hs +126/−34
- shakespeare.cabal +3/−2
- test/Text/Shakespeare/I18NSpec.hs +36/−16
ChangeLog.md view
@@ -1,5 +1,18 @@ # ChangeLog for shakespeare +### 2.1.7++* Use ByteString’s Lift for Hamlet code generation [#298](https://github.com/yesodweb/shakespeare/pull/298)++### 2.1.6++* Introduce options type for i18n, add ability to stop using record types for messages [#290](https://github.com/yesodweb/shakespeare/pull/290)++### 2.1.5++* Add better support for `mkMessage`ing data types with params.[#295](https://github.com/yesodweb/shakespeare/pull/295)++ ### 2.1.4 * [#292](https://github.com/yesodweb/shakespeare/pull/292)
Text/Hamlet.hs view
@@ -48,6 +48,7 @@ , hamletFromString ) where +import Text.Blaze.Internal (unsafeByteString) import Text.Shakespeare.Base import Text.Hamlet.Parse import Language.Haskell.TH.Syntax hiding (Module)@@ -55,6 +56,7 @@ import Data.Char (isUpper, isDigit) import Data.Maybe (fromMaybe) import Data.Text (Text, pack)+import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Internal (preEscapedText)@@ -263,8 +265,8 @@ contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp contentToExp _ hr _ (ContentRaw s) = do- os <- [|preEscapedText . pack|]- let s' = LitE $ StringL s+ os <- [|unsafeByteString|]+ s' <- lift $ TE.encodeUtf8 (pack s) return $ hrFromHtml hr `AppE` (os `AppE` s') contentToExp _ hr scope (ContentVar d) = do str <- [|toHtml|]
Text/Shakespeare/I18N.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ExistentialQuantification #-} -----------------------------------------------------------------------------@@ -60,6 +59,15 @@ , ToMessage (..) , SomeMessage (..) , Lang++ , mkMessageOpts++ , MakeMessageOpts+ , defMakeMessageOpts+ , setGenType+ , setConPrefix+ , setTypeSuffix+ , setUseRecordCons ) where import Language.Haskell.TH.Syntax hiding (makeRelativeToProject)@@ -124,8 +132,8 @@ -> 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+mkMessage dt =+ mkMessageCommon True "Msg" "Message" dt dt -- | create 'RenderMessage' instance for an existing data-type@@ -134,7 +142,7 @@ -> FilePath -- ^ path to translation folder -> Lang -- ^ default language -> Q [Dec]-mkMessageFor master dt folder lang = mkMessageCommon False "" "" master dt folder lang+mkMessageFor = mkMessageCommon False "" "" -- | create an additional set of translations for a type created by `mkMessage` mkMessageVariant :: String -- ^ master translation data type@@ -142,7 +150,7 @@ -> FilePath -- ^ path to translation folder -> Lang -- ^ default language -> Q [Dec]-mkMessageVariant master dt folder lang = mkMessageCommon False "Msg" "Message" master dt folder lang+mkMessageVariant = mkMessageCommon False "Msg" "Message" -- |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@@ -153,42 +161,66 @@ -> FilePath -- ^ path to translation folder -> Lang -- ^ default lang -> Q [Dec]-mkMessageCommon genType prefix postfix master dt rawFolder lang = do+mkMessageCommon genType prefix postfix =+ mkMessageOpts opts+ where+ opts = defMakeMessageOpts+ { mmGenType = genType+ , mmConPrefix = prefix+ , mmTypeSuffix = postfix+ }++-- | used by 'mkMessage', 'mkMessageFor' to generate a 'RenderMessage' and possibly a message data type+--+-- @since 2.1.6+mkMessageOpts :: MakeMessageOpts -- ^ options+ -> String -- ^ base name of master datatype+ -> String -- ^ base name of translation datatype+ -> FilePath -- ^ path to translation folder+ -> Lang -- ^ default lang+ -> Q [Dec]+mkMessageOpts opts@(MkMakeMessageOpts {mmGenType = genType, mmTypeSuffix = postfix}) master dt rawFolder lang = do folder <- makeRelativeToProject rawFolder files <- qRunIO $ getDirectoryContents folder let files' = filter (`notElem` [".", ".."]) files- (filess, contents) <- qRunIO $ fmap (unzip . catMaybes) $ mapM (loadLang folder) files'+ (filess, contents) <- qRunIO $ unzip . catMaybes <$> mapM (loadLang folder) files' (mapM_.mapM_) addDependentFile filess let contents' = Map.toList $ Map.fromListWith (++) contents 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'+ mapM_ (checkDef sdef . snd) contents' let mname = mkName $ dt2 ++ postfix- c1 <- fmap concat $ mapM (toClauses prefix dt2 ) contents'- c2 <- mapM (sToClause prefix dt2) sdef+ c1 <- concat <$> mapM (toClauses opts dt2 ) contents'+ c2 <- mapM (sToClause opts dt2) sdef c3 <- defClause return $ ( if genType- then ((DataD [] mname [] Nothing (map (toCon dt2) sdef) []) :)+ then (DataD [] mname [] Nothing (map (toCon opts dt2) sdef) [] :) else id) [ instanceD cxt -- Here the parsed context should be added, otherwise [] (ConT ''RenderMessage `AppT` (if ' ' `elem` master' then let (ts, us) = break (== ' ') . - filter (\x -> x /= '(' && x /= ')') $ master' - us1 = filter (/= ' ') us in ParensT (ConT (mkName ts) - `AppT` VarT (mkName us1)) + filter (\x -> x /= '(' && x /= ')') $ master'+ combineArgs typeName p xs' = foldl1 AppT . (typeName :) . fmap (VarT . mkName) . filter (not . null) $ go xs' (id, id)+ where+ go :: String -> ([String] -> [String], String -> String) -> [String]+ go [] (endList, currList) = endList [currList []]+ go (x : xs) (endList, currList)+ | p x = go xs (endList . (currList [] :), id)+ | otherwise = go xs (endList, currList . (x :))+ in ParensT (combineArgs (ConT (mkName ts)) (== ' ') us) else ConT $ mkName master') `AppT` ConT mname) [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3] ] ]- where (dt1, cxt0) = case (parse parseName "" dt) of+ where (dt1, cxt0) = case parse parseName "" dt of Left err -> error $ show err Right x -> x dt2 = concat . take 1 $ dt1- master' | cxt0 == [] = master+ master' | null cxt0 = master | otherwise = (\xss -> if length xss > 1 then '(':unwords xss ++ ")" else concat . take 1 $ xss) . fst $ @@ -237,27 +269,30 @@ parseContexts = sepBy1 (many1 parseWord) (spaces >> char ',' >> return ()) -toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause] -toClauses prefix dt (lang, defs) =+toClauses :: MakeMessageOpts -> String -> (Lang, [Def]) -> Q [Clause] +toClauses opts@(MkMakeMessageOpts {mmConPrefix = 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)+ (pat, bod) <- mkBody opts 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+mkBody :: MakeMessageOpts+ -> String -- ^ datatype -> String -- ^ constructor -> [String] -- ^ variable names -> [Content] -> Q (Pat, Exp)-mkBody dt cs vs ct = do+mkBody (MkMakeMessageOpts {mmUseRecordCons = useRecord}) dt cs vs ct = do vp <- mapM go vs- let pat = RecP (mkName cs) (map (varName dt *** VarP) vp)+ let pat = if useRecord+ then RecP (mkName cs) (map (varName dt *** VarP) vp)+ else ConP (mkName cs) [] (map (VarP . snd) vp) let ct' = map (fixVars vp) ct pack' <- [|Data.Text.pack|] tomsg <- [|toMessage|]@@ -281,14 +316,11 @@ 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+ fixIdent vp i = maybe i nameBase (lookup i vp) -sToClause :: String -> String -> SDef -> Q Clause-sToClause prefix dt sdef = do- (pat, bod) <- mkBody dt (prefix ++ sconstr sdef) (map fst $ svars sdef) (scontent sdef)+sToClause :: MakeMessageOpts -> String -> SDef -> Q Clause+sToClause opts@(MkMakeMessageOpts {mmConPrefix = prefix}) dt sdef = do+ (pat, bod) <- mkBody opts dt (prefix ++ sconstr sdef) (map fst $ svars sdef) (scontent sdef) return $ Clause [WildP, conP (mkName "[]") [], pat] (NormalB bod)@@ -312,11 +344,15 @@ conP = ConP #endif -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)+toCon :: MakeMessageOpts -> String -> SDef -> Con+toCon (MkMakeMessageOpts {mmConPrefix = prefix, mmUseRecordCons = useRecord}) dt (SDef c vs _) =+ if useRecord+ then RecC nm $ map goRec vs+ else NormalC nm $ map goNorm vs+ where+ goRec (n, t) = (varName dt n, notStrict, ConT $ mkName t)+ goNorm (_, t) = (notStrict, ConT $ mkName t)+ nm = mkName $ prefix ++ c varName :: String -> String -> Name varName a y =@@ -471,3 +507,59 @@ instanceD :: Cxt -> Type -> [Dec] -> Dec instanceD = InstanceD Nothing++-- | Opaque options type for 'mkMessage'+-- This is used to pass options to the 'mkMessage' function.+-- The options are not exposed directly to the user, but can be set using+-- the 'set*' functions, and the default can be made using 'defMakeMessageOpts'.+--+-- @since 2.1.6+data MakeMessageOpts = MkMakeMessageOpts+-- don't export constructor so that we can freely manipulate internals+ { mmGenType :: Bool+ , mmConPrefix :: String+ , mmTypeSuffix :: String+ , mmUseRecordCons :: Bool+ }++-- | Default options for 'mkMessage' are:+-- * @mmGenType@ = @True@+-- * @mmConPrefix@ = @\"Msg\"@+-- * @mmTypeSuffix@ = @\"Message\"@+-- * @mmUseRecordCons@ = @True@+--+-- @since 2.1.6+defMakeMessageOpts :: MakeMessageOpts+defMakeMessageOpts = MkMakeMessageOpts+ { mmGenType = True+ , mmConPrefix = "Msg"+ , mmTypeSuffix = "Message"+ , mmUseRecordCons = True+ }++-- | Whether to generate a new datatype from the constructors found in the .msg+-- files+--+-- @since 2.1.6+setGenType :: Bool -> MakeMessageOpts -> MakeMessageOpts+setGenType x opts = opts { mmGenType = x }++-- | Set the prefix for the constructor names+--+-- @since 2.1.6+setConPrefix :: String -> MakeMessageOpts -> MakeMessageOpts+setConPrefix x opts = opts { mmConPrefix = x }++-- | Set the suffix for the datatype name+--+-- @since 2.1.6+setTypeSuffix :: String -> MakeMessageOpts -> MakeMessageOpts+setTypeSuffix x opts = opts { mmTypeSuffix = x }++-- | Set whether to use record constructors or normal constructors.+-- If you are getting partial-fields warnings you want to remove, set this to+-- 'False'. If you want to use record syntax, set this to 'True'.+--+-- @since 2.1.6+setUseRecordCons :: Bool -> MakeMessageOpts -> MakeMessageOpts+setUseRecordCons x opts = opts { mmUseRecordCons = x }
shakespeare.cabal view
@@ -1,5 +1,5 @@ name: shakespeare-version: 2.1.4+version: 2.1.7 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -43,7 +43,7 @@ , text >= 0.7 , process >= 1.0 , ghc-prim- , bytestring+ , bytestring >= 0.11.2 , directory >= 1.2 , aeson < 3 , blaze-markup@@ -128,6 +128,7 @@ type: exitcode-stdio-1.0 ghc-options: -Wall+ build-tool-depends: hspec-discover:hspec-discover build-depends: base >= 4.9 && < 5 , shakespeare , time >= 1
test/Text/Shakespeare/I18NSpec.hs view
@@ -9,29 +9,49 @@ import Data.Text (Text) import Text.Shakespeare.I18N-import Language.Haskell.TH.Syntax import Test.Hspec -class Lift master => YesodSubApp master where- data YesodSubAppData master :: *--newtype SubApp master = SubApp- {- getOrdering :: Ordering- }+class YesodSubApp master where -data Test = Test+instance YesodSubApp () -class Testable a where- isTestable :: a -> Bool +newtype SubApp master = SubApp master -instance Testable Test where - isTestable Test = True+instance YesodSubApp (SubApp master) -spec :: Monad m => m ()-spec = return ()+data Test a b mkMessage "(YesodSubApp master) => SubApp master" "other-messages" "en" -mkMessage "Test" "test-messages" "en"+mkMessage "Test a b" "test-messages" "en" +newtype SubAppNoRec master = SubAppNoRec master++instance YesodSubApp (SubAppNoRec master)++data TestNoRec++mkMessageOpts+ (setConPrefix "MsgNR" $ setUseRecordCons False defMakeMessageOpts)+ "(YesodSubApp master) => SubAppNoRec master"+ "(YesodSubApp master) => SubAppNoRec master"+ "other-messages"+ "en"++mkMessageOpts+ (setConPrefix "MsgNR" $ setUseRecordCons False defMakeMessageOpts)+ "TestNoRec"+ "TestNoRec"+ "test-messages"+ "en"++spec :: Spec+spec = do+ describe "I18N" $ do+ it "should generate messages with record constructors" $ do+ let msg = MsgEntryCreatedRR { subAppMessageTitle = "foo" }+ renderMessage (SubApp ()) [] msg `shouldBe` "Your new blog post, foo, has been created"++ it "should generate messages without record constructors" $ do+ let msg = MsgNREntryCreatedRR "bar"+ renderMessage (SubAppNoRec ()) [] msg `shouldBe` "Your new blog post, bar, has been created"