Added support in mkMessage for context parsing #282

.github/workflows/tests.yml

@@ -14,34 +14,29 @@ jobs:
       fail-fast: false
       matrix:
         os: [ubuntu-latest, macos-latest, windows-latest]
-        stack_args:
-          - --resolver=nightly
-          - --resolver=lts-21
-          - --resolver=lts-20
-          - --resolver=lts-19
-          - --resolver=lts-18
-          - --resolver=lts-16
-          - --resolver=lts-14
-          - --resolver=lts-12
-          - --stack-yaml=stack-ghc-9.2.yaml
-        exclude:
-          - os: windows-latest
-            stack_args: "--stack-yaml=stack-ghc-9.2.yaml"
+        args:
+        - "--resolver lts-22"
+        - "--resolver lts-21"
+        - "--resolver lts-20"
 
     steps:
       - name: Clone project
-        uses: actions/checkout@v2
+        uses: actions/checkout@v4
 
-      - name: Build and run tests
+      - name: Install stack if needed
         shell: bash
         run: |
             set -ex
-            stack upgrade
-            stack --version
-            if [[ "${{ runner.os }}" = 'Windows' ]]
+            if [[ "${{ matrix.os }}" == "macos-latest" ]]
             then
-              # Looks like a bug in Stack, this shouldn't break things
-              ls C:/ProgramData/Chocolatey/bin/
-              rm C:/ProgramData/Chocolatey/bin/ghc*
+                # macos-latest does not include Haskell tools as of 2024-05-06.
+              curl -sSL https://get.haskellstack.org/ | sh
             fi
-            stack test --fast --no-terminal ${{ matrix.stack_args }}
+
+      - name: Build and run tests
+        shell: bash
+        run: |
+            set -ex
+            stack --version
+            stack test --fast --no-terminal ${{ matrix.args }}
+

ChangeLog.md

@@ -1,5 +1,9 @@
 # ChangeLog for shakespeare
 
+### 2.1.2
+
+* Add support for context parsing in mkMessage function and related ones [#282](https://github.com/yesodweb/shakespeare/issues/282). Added support for building with LTS versions of 22, 21, 20 and removed older ones.
+
 ### 2.1.0
 
 * Add `OverloadedRecordDot`-style record access in expressions

Text/Shakespeare/I18N.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE ExistentialQuantification #-}
 
@@ -62,7 +63,6 @@ module Text.Shakespeare.I18N
     ) where
 
 import Language.Haskell.TH.Syntax hiding (makeRelativeToProject)
-import Control.Applicative ((<$>))
 import Control.Monad (filterM, forM)
 import Data.Text (Text, pack, unpack)
 import System.Directory
@@ -72,12 +72,12 @@ import Data.List (isSuffixOf, sortBy, foldl')
 import qualified Data.Map as Map
 import qualified Data.ByteString as S
 import Data.Text.Encoding (decodeUtf8)
-import Data.Char (isSpace, toLower, toUpper)
+import Data.Char (isSpace, toLower, toUpper, isLower)
 import Data.Ord (comparing)
 import Text.Shakespeare.Base (Deref (..), Ident (..), parseHash, derefToExp)
-import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>))
+import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>), 
+  string, spaces, char, option, alphaNum, sepBy1, try)
 import Control.Arrow ((***))
-import Data.Monoid (mempty, mappend)
 import qualified Data.Text as T
 import Data.String (IsString (fromString))
 
@@ -165,22 +165,79 @@ mkMessageCommon genType prefix postfix master dt rawFolder lang = do
             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
+    let mname = mkName $ dt2 ++ postfix
+    c1 <- fmap concat $ mapM (toClauses prefix dt2 ) contents'
+    c2 <- mapM (sToClause prefix dt2) sdef
     c3 <- defClause
     return $
      ( if genType
-       then ((DataD [] mname [] Nothing (map (toCon dt) sdef) []) :)
+       then ((DataD [] mname [] Nothing (map (toCon dt2) sdef) []) :)
        else id)
         [ instanceD
-            []
-            (ConT ''RenderMessage `AppT` (ConT $ mkName master) `AppT` ConT mname)
+            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))  
+               else ConT $ mkName master') `AppT` ConT mname)
             [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]
             ]
         ]
-
-toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause]
+           where (dt1, cxt0) = case (parse parseName "" dt) of
+                                Left err  -> error $ show err
+                                Right x -> x
+                 dt2 = concat . take 1 $ dt1
+                 master' | cxt0 == [] = master
+                         | otherwise = (\xss -> if length xss > 1 
+                                                  then '(':unwords xss ++ ")" 
+                                                  else concat . take 1 $ xss) . fst $  
+                                         (case parse parseName "" master of
+                                            Left err  -> error $ show err
+                                            Right x -> x)
+                 cxt = fmap (\(c:rest) -> foldl' (\acc v -> acc `AppT` nameToType v) 
+                                             (ConT $ mkName c) rest) cxt0
+
+                 nameToType :: String -> Type  -- Is taken from the 
+-- https://hackage.haskell.org/package/yesod-core-1.6.26.0/docs/src/Yesod.Routes.Parse.html#nameToType
+                 nameToType t = if isTvar t
+                                then VarT $ mkName t
+                                else ConT $ mkName t
+
+                 isTvar :: String -> Bool  -- Is taken from the 
+-- https://hackage.haskell.org/package/yesod-core-1.6.26.0/docs/src/Yesod.Routes.Parse.html#isTvar
+                 isTvar (h:_) = isLower h
+                 isTvar _     = False
+
+                 parseName = do
+                      cxt' <- option [] parseContext
+                      args <- many parseWord
+                      spaces
+                      eof
+                      return (args, cxt')
+
+                 parseWord = do
+                      spaces
+                      many1 alphaNum
+
+                 parseContext = try $ do
+                      cxts <- parseParen parseContexts
+                      spaces
+                      _ <- string "=>"
+                      return cxts
+
+                 parseParen p = do
+                      spaces
+                      _ <- try ( char '(' )
+                      r <- p
+                      spaces
+                      _ <- try ( char ')' )
+                      return r
+
+                 parseContexts =
+                      sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
+
+toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause] 
 toClauses prefix dt (lang, defs) =
     mapM go defs
   where
@@ -358,8 +415,7 @@ loadLangFile :: FilePath -> IO [Def]
 loadLangFile file = do
     bs <- S.readFile file
     let s = unpack $ decodeUtf8 bs
-    defs <- fmap catMaybes $ mapM (parseDef . T.unpack . T.strip . T.pack) $ lines s
-    return defs
+    fmap catMaybes $ mapM (parseDef . T.unpack . T.strip . T.pack) $ lines s
 
 parseDef :: String -> IO (Maybe Def)
 parseDef "" = return Nothing

other-messages/en.msg

@@ -0,0 +1,29 @@
+NotAnAdminRR: You must be an administrator to access this page.
+
+WelcomeHomepageRR: Welcome to the homepage
+SeeArchiveRR: See the archive
+
+NoEntriesRR: There are no entries in the blog
+LoginToPostRR: Admins can login to post
+NewEntryRR: Post to blog
+NewEntryTitleRR: Title
+NewEntryContentRR: Content
+
+PleaseCorrectEntryRR: Your submitted entry had some errors, please correct and try again.
+EntryCreatedRR title@Text: Your new blog post, #{title}, has been created
+
+EntryTitleRR title@Text: Blog postRR: #{title}
+CommentsHeadingRR: Comments
+NoCommentsRR: There are no comments
+AddCommentHeadingRR: Add a Comment
+LoginToCommentRR: You must be logged in to comment
+AddCommentButtonRR: Add comment
+
+CommentNameRR: Your display name
+CommentTextRR: Comment
+CommentAddedRR: Your comment has been added
+PleaseCorrectCommentRR: Your submitted comment had some errors, please correct and try again.
+
+HomepageTitleRR: Yesod Blog Demo
+BlogArchiveTitleRR: Blog Archive
+

shakespeare.cabal

@@ -1,5 +1,5 @@
 name:            shakespeare
-version:         2.1.0
+version:         2.1.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>

test/Text/Shakespeare/I18NSpec.hs

@@ -1,16 +1,37 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+
 module Text.Shakespeare.I18NSpec
     ( spec
     ) where
 
 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
+  }
+
+data Test = Test
+
+class Testable a where
+  isTestable :: a -> Bool 
+
+instance Testable Test where 
+  isTestable Test = True
 
 spec :: Monad m => m ()
 spec = return ()
 
-data Test = Test
+mkMessage "(YesodSubApp master) => SubApp master" "other-messages" "en" 
 
 mkMessage "Test" "test-messages" "en"
+