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 e384711..c49c9bf 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,9 +1,5 @@ # ChangeLog for shakespeare -### 2.1.1 - -* Add support for `TypeApplications` inside Shakespeare quasiquotes - ### 2.1.0 * Add `OverloadedRecordDot`-style record access in expressions diff --git a/Text/Shakespeare/Base.hs b/Text/Shakespeare/Base.hs index 726d9b6..8545bfb 100644 --- a/Text/Shakespeare/Base.hs +++ b/Text/Shakespeare/Base.hs @@ -29,7 +29,7 @@ module Text.Shakespeare.Base import Language.Haskell.TH.Syntax hiding (makeRelativeToProject) import Language.Haskell.TH (appE) -import Data.Char (isUpper, isSymbol, isPunctuation, isAscii, isLower, isNumber) +import Data.Char (isUpper, isSymbol, isPunctuation, isAscii) import Data.FileEmbed (makeRelativeToProject) import Text.ParserCombinators.Parsec import Text.Parsec.Prim (Parsec) @@ -41,8 +41,6 @@ import qualified Data.Text.Lazy as TL import qualified System.IO as SIO import qualified Data.Text.Lazy.IO as TIO import Control.Monad (when) -import Data.Maybe (mapMaybe) -import Data.List.NonEmpty (nonEmpty, NonEmpty ((:|))) newtype Ident = Ident String deriving (Show, Eq, Read, Data, Typeable, Ord, Lift) @@ -57,7 +55,6 @@ data Deref = DerefModulesIdent [String] Ident | DerefBranch Deref Deref | DerefList [Deref] | DerefTuple [Deref] - | DerefType String | DerefGetField Deref String -- ^ Record field access via @OverloadedRecordDot@. 'derefToExp' only supports this -- feature on compilers which support @OverloadedRecordDot@. @@ -96,7 +93,7 @@ parseDeref = do -- See: http://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-160002.2 isOperatorChar c - | isAscii c = c `elem` "!#$%&*+./<=>?\\^|-~:" + | isAscii c = c `elem` "!#$%&*+./<=>?@\\^|-~:" | otherwise = isSymbol c || isPunctuation c derefPrefix x = do @@ -106,7 +103,7 @@ parseDeref = do derefInfix x = try $ do _ <- delim xs <- many $ try $ derefSingle >>= \x' -> delim >> return x' - op <- (many1 (satisfy isOperatorChar) <* lookAhead (oneOf " \t")) "operator" + op <- many1 (satisfy isOperatorChar) "operator" -- special handling for $, which we don't deal with when (op == "$") $ fail "don't handle $" let op' = DerefIdent $ Ident op @@ -114,21 +111,9 @@ parseDeref = do skipMany $ oneOf " \t" return $ DerefBranch (DerefBranch op' $ foldl1 DerefBranch $ x : xs) (foldl1 DerefBranch ys) derefSingle = do - x <- derefType <|> derefTuple <|> derefList <|> derefOp <|> derefParens <|> numeric <|> fmap DerefString strLit <|> ident + x <- derefTuple <|> derefList <|> derefOp <|> derefParens <|> numeric <|> strLit <|> ident fields <- many recordDot pure $ foldl DerefGetField x fields - tyNameOrVar = liftA2 (:) (alphaNum <|> char '\'') (many (alphaNum <|> char '_' <|> char '\'')) - derefType = try $ do - _ <- char '@' >> notFollowedBy (oneOf " \t") - x <- - try tyNameOrVar - <|> try (string "()") - <|> try strLit - <|> between - (char '(') - (char ')') - (unwords <$> many ((try tyNameOrVar <|> try strLitQuoted) <* many (oneOf " \t"))) - pure $ DerefType x recordDot = do _ <- char '.' x <- lower <|> char '_' @@ -154,8 +139,11 @@ parseDeref = do Nothing -> DerefIntegral $ read' "Integral" $ n ++ x Just z -> DerefRational $ toRational (read' "Rational" $ n ++ x ++ '.' : z :: Double) - strLitQuoted = liftA2 (:) (char '"') (many quotedChar) <> fmap pure (char '"') - strLit = char '"' *> many quotedChar <* char '"' + strLit = do + _ <- char '"' + chars <- many quotedChar + _ <- char '"' + return $ DerefString chars quotedChar = (char '\\' >> escapedChar) <|> noneOf "\"" escapedChar = let cecs = [('n', '\n'), ('r', '\r'), ('b', '\b'), ('t', '\t') @@ -185,31 +173,8 @@ expType :: Ident -> Name -> Exp expType (Ident (c:_)) = if isUpper c || c == ':' then ConE else VarE expType (Ident "") = error "Bad Ident" -strType :: String -> Type -strType t0 = case t0 of - "" -> ConT ''() - hd : tl - | all isNumber t0 -> LitT (NumTyLit (read t0)) - | isLower hd -> VarT (mkName (hd : tl)) - | otherwise -> ConT (mkName (hd : tl)) - -strTypeWords :: String -> Type -strTypeWords t = case words t of - [] -> ConT ''() - [ty] -> strType ty - ts@(ty : tys) - | not (null ty) - && head ty == '\"' - && not (null (last ts)) - && last (last ts) == '\"' -> - LitT (StrTyLit t) - | otherwise -> foldl AppT (strType ty) (map strType tys) - derefToExp :: Scope -> Deref -> Exp -derefToExp s (DerefBranch x y) = case y of - DerefBranch (DerefType t) y' -> derefToExp s x `AppTypeE` strTypeWords t `AppE` derefToExp s y' - DerefType t -> derefToExp s x `AppTypeE` strTypeWords t - _ -> derefToExp s x `AppE` derefToExp s y +derefToExp s (DerefBranch x y) = derefToExp s x `AppE` derefToExp s y derefToExp _ (DerefModulesIdent mods i@(Ident s)) = expType i $ Name (mkOccName s) (NameQ $ mkModName $ intercalate "." mods) derefToExp scope (DerefIdent i@(Ident s)) = @@ -219,7 +184,6 @@ derefToExp scope (DerefIdent i@(Ident s)) = derefToExp _ (DerefIntegral i) = LitE $ IntegerL i derefToExp _ (DerefRational r) = LitE $ RationalL r derefToExp _ (DerefString s) = LitE $ StringL s -derefToExp _ (DerefType _) = error "exposed type application" derefToExp s (DerefList ds) = ListE $ map (derefToExp s) ds derefToExp s (DerefTuple ds) = TupE $ #if MIN_VERSION_template_haskell(2,16,0) diff --git a/Text/Shakespeare/I18N.hs b/Text/Shakespeare/I18N.hs index 1081ead..111272a 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' in + let 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 @@ -261,7 +318,7 @@ toCon dt (SDef c vs _) = where go (n, t) = (varName dt n, notStrict, ConT $ mkName t) -varName :: String -> String -> Name +varName :: String -> String -> Name varName a y = mkName $ concat [lower a, "Message", upper y] 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 0c3925f..e67d20c 100644 --- a/shakespeare.cabal +++ b/shakespeare.cabal @@ -1,5 +1,5 @@ name: shakespeare -version: 2.1.1 +version: 2.1.2 license: MIT license-file: LICENSE author: Michael Snoyman @@ -146,8 +146,7 @@ test-suite test , blaze-markup , blaze-html , exceptions - - + source-repository head type: git location: https://github.com/yesodweb/shakespeare.git diff --git a/test/Text/Shakespeare/BaseSpec.hs b/test/Text/Shakespeare/BaseSpec.hs index 7be4d2b..580acb3 100644 --- a/test/Text/Shakespeare/BaseSpec.hs +++ b/test/Text/Shakespeare/BaseSpec.hs @@ -33,31 +33,6 @@ spec = do (DerefBranch (DerefIdent (Ident "+")) (DerefIdent (Ident "a"))) (DerefIdent (Ident "b")))) - it "parseDeref parse single type applications" $ do - runParser parseDeref () "" "x @y" `shouldBe` - Right - (DerefBranch - (DerefIdent (Ident "x")) - (DerefType "y")) - it "parseDeref parse unit type applications" $ do - runParser parseDeref () "" "x @()" `shouldBe` - Right - (DerefBranch - (DerefIdent (Ident "x")) - (DerefType "()")) - it "parseDeref parse compound type applications" $ do - runParser parseDeref () "" "x @(Maybe String)" `shouldBe` - Right - (DerefBranch - (DerefIdent (Ident "x")) - (DerefType "Maybe String")) - it "parseDeref parse single @ as operator" $ do - runParser parseDeref () "" "x @ y" `shouldBe` - Right - (DerefBranch - (DerefBranch (DerefIdent (Ident "@")) (DerefIdent (Ident "x"))) - (DerefIdent (Ident "y"))) - it "parseDeref parse expressions with record dot" $ do runParser parseDeref () "" "x.y" `shouldBe` Right (DerefGetField (DerefIdent (Ident "x")) "y") @@ -131,3 +106,4 @@ spec = do eShowErrors :: Either ParseError c -> c eShowErrors = either (error . show) id + 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"