diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index 6392b66..a113ad8 100644 --- a/.github/workflows/tests.yml +++ b/.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 }} + diff --git a/ChangeLog.md b/ChangeLog.md index c49c9bf..bfa7dea 100644 --- a/ChangeLog.md +++ b/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 diff --git a/Text/Shakespeare/I18N.hs b/Text/Shakespeare/I18N.hs index 1081ead..c1ec302 100644 --- a/Text/Shakespeare/I18N.hs +++ b/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 diff --git a/shakespeare.cabal b/shakespeare.cabal index 6156971..4c5f557 100644 --- a/shakespeare.cabal +++ b/shakespeare.cabal @@ -1,5 +1,5 @@ name: shakespeare -version: 2.1.0 +version: 2.1.2 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/test/Text/Shakespeare/I18NSpec.hs b/test/Text/Shakespeare/I18NSpec.hs index 3d403c4..f99c858 100644 --- a/test/Text/Shakespeare/I18NSpec.hs +++ b/test/Text/Shakespeare/I18NSpec.hs @@ -1,16 +1,26 @@ {-# 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 (Lift(..)) spec :: Monad m => m () spec = return () -data Test = Test +class Lift master => YesodSubApp master where + data YesodSubAppData master :: * + +newtype SubApp master = SubApp + { + getOrdering :: Ordering + } + +mkMessage "(YesodSubApp master) => SubApp master" "test-messages" "en" -mkMessage "Test" "test-messages" "en"