diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,8 @@ # ChangeLog for shakespeare -### 2.1.0.1 +### 2.1.1 -* Fix 100тип slowdown on parsec-3.1.15 [#277](https://github.com/yesodweb/shakespeare/pull/277) +* Add support for `TypeApplications` inside Shakespeare quasiquotes ### 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) +import Data.Char (isUpper, isSymbol, isPunctuation, isAscii, isLower, isNumber) import Data.FileEmbed (makeRelativeToProject) import Text.ParserCombinators.Parsec import Text.Parsec.Prim (Parsec) @@ -41,6 +41,8 @@ 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) @@ -55,6 +57,7 @@ | 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@. @@ -93,7 +96,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 @@ -103,7 +106,7 @@ derefInfix x = try $ do _ <- delim xs <- many $ try $ derefSingle >>= \x' -> delim >> return x' - op <- many1 (satisfy isOperatorChar) "operator" + op <- (many1 (satisfy isOperatorChar) <* lookAhead (oneOf " \t")) "operator" -- special handling for $, which we don't deal with when (op == "$") $ fail "don't handle $" let op' = DerefIdent $ Ident op @@ -111,9 +114,21 @@ skipMany $ oneOf " \t" return $ DerefBranch (DerefBranch op' $ foldl1 DerefBranch $ x : xs) (foldl1 DerefBranch ys) derefSingle = do - x <- derefTuple <|> derefList <|> derefOp <|> derefParens <|> numeric <|> strLit <|> ident + x <- derefType <|> derefTuple <|> derefList <|> derefOp <|> derefParens <|> numeric <|> fmap DerefString 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 '_' @@ -139,11 +154,8 @@ Nothing -> DerefIntegral $ read' "Integral" $ n ++ x Just z -> DerefRational $ toRational (read' "Rational" $ n ++ x ++ '.' : z :: Double) - strLit = do - _ <- char '"' - chars <- many quotedChar - _ <- char '"' - return $ DerefString chars + strLitQuoted = liftA2 (:) (char '"') (many quotedChar) <> fmap pure (char '"') + strLit = char '"' *> many quotedChar <* char '"' quotedChar = (char '\\' >> escapedChar) <|> noneOf "\"" escapedChar = let cecs = [('n', '\n'), ('r', '\r'), ('b', '\b'), ('t', '\t') @@ -173,8 +185,31 @@ 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) = derefToExp s x `AppE` derefToExp s y +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 _ (DerefModulesIdent mods i@(Ident s)) = expType i $ Name (mkOccName s) (NameQ $ mkModName $ intercalate "." mods) derefToExp scope (DerefIdent i@(Ident s)) = @@ -184,6 +219,7 @@ 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/shakespeare.cabal b/shakespeare.cabal --- a/shakespeare.cabal +++ b/shakespeare.cabal @@ -1,5 +1,5 @@ name: shakespeare -version: 2.1.0.1 +version: 2.1.1 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,6 +33,31 @@ (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") @@ -106,4 +131,3 @@ eShowErrors :: Either ParseError c -> c eShowErrors = either (error . show) id -