Provide context parsing in the mkMessage function

.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,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

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,29 +103,17 @@ 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
         ys <- many1 $ try $ delim >> derefSingle
         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)

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

shakespeare.cabal

@@ -1,5 +1,5 @@
 name:            shakespeare
-version:         2.1.1
+version:         2.1.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -146,8 +146,7 @@ test-suite test
                  , blaze-markup
                  , blaze-html
                  , exceptions
-
-
+
 source-repository head
   type:     git
   location: https://github.com/yesodweb/shakespeare.git

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
+