diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,13 @@ # ChangeLog for shakespeare -### 2.1.1 +### 2.1.3 -* Add support for `TypeApplications` inside Shakespeare quasiquotes +* [#292](https://github.com/yesodweb/shakespeare/pull/292) + * Add support for multi-line attributes. An example use of this is [here](https://github.com/yesodweb/shakespeare/issues/291). + +### 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 diff --git a/Text/Shakespeare/Base.hs b/Text/Shakespeare/Base.hs --- a/Text/Shakespeare/Base.hs +++ b/Text/Shakespeare/Base.hs @@ -29,7 +29,7 @@ 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 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 @@ | 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 @@ -- 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 @@ 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 @@ 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 @@ 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 (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 _ (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 --- 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 @@ ) 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 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 @@ 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] ] ] + 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 -toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause] + 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 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 --- a/shakespeare.cabal +++ b/shakespeare.cabal @@ -1,5 +1,5 @@ name: shakespeare -version: 2.1.1 +version: 2.1.3 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/test/Text/Shakespeare/BaseSpec.hs b/test/Text/Shakespeare/BaseSpec.hs --- a/test/Text/Shakespeare/BaseSpec.hs +++ b/test/Text/Shakespeare/BaseSpec.hs @@ -33,31 +33,6 @@ (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 @@ eShowErrors :: Either ParseError c -> c eShowErrors = either (error . show) id + diff --git a/test/Text/Shakespeare/I18NSpec.hs b/test/Text/Shakespeare/I18NSpec.hs --- a/test/Text/Shakespeare/I18NSpec.hs +++ b/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" +