shakespeare 2.1.0.1 → 2.1.1
raw patch · 4 files changed
+74/−14 lines, 4 files
Files
- ChangeLog.md +2/−2
- Text/Shakespeare/Base.hs +46/−10
- shakespeare.cabal +1/−1
- test/Text/Shakespeare/BaseSpec.hs +25/−1
ChangeLog.md view
@@ -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
Text/Shakespeare/Base.hs view
@@ -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)
shakespeare.cabal view
@@ -1,5 +1,5 @@ name: shakespeare-version: 2.1.0.1+version: 2.1.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>
test/Text/Shakespeare/BaseSpec.hs view
@@ -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-