From 5197f7efa0627413342de1a721e845b422be80c8 Mon Sep 17 00:00:00 2001 From: Melanie Brown Date: Mon, 6 May 2024 15:51:59 -0400 Subject: [PATCH 1/3] parse type applications in Deref --- Text/Shakespeare/Base.hs | 58 +++++++++++++++++++++++++------ test/Text/Shakespeare/BaseSpec.hs | 20 ++++++++++- 2 files changed, 67 insertions(+), 11 deletions(-) diff --git a/Text/Shakespeare/Base.hs b/Text/Shakespeare/Base.hs index 8545bfb..cbe3262 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) +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 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) @@ -55,6 +57,7 @@ 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@. @@ -93,7 +96,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 @@ -103,7 +106,9 @@ parseDeref = do derefInfix x = try $ do _ <- delim xs <- many $ try $ derefSingle >>= \x' -> delim >> return x' - op <- many1 (satisfy isOperatorChar) "operator" + op <- + (try $ liftA2 (:) (satisfy isOperatorChar) (many (satisfy isOperatorChar <|> char '@')) + <|> liftA2 (:) (char '@') (many1 (satisfy isOperatorChar <|> char '@'))) "operator" -- special handling for $, which we don't deal with when (op == "$") $ fail "don't handle $" let op' = DerefIdent $ Ident op @@ -111,9 +116,21 @@ parseDeref = do 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 '@' + 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 +156,8 @@ parseDeref = do 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 +187,31 @@ 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) = 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 +221,7 @@ 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/test/Text/Shakespeare/BaseSpec.hs b/test/Text/Shakespeare/BaseSpec.hs index 580acb3..1a8b05f 100644 --- a/test/Text/Shakespeare/BaseSpec.hs +++ b/test/Text/Shakespeare/BaseSpec.hs @@ -33,6 +33,25 @@ 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 expressions with record dot" $ do runParser parseDeref () "" "x.y" `shouldBe` Right (DerefGetField (DerefIdent (Ident "x")) "y") @@ -106,4 +125,3 @@ spec = do eShowErrors :: Either ParseError c -> c eShowErrors = either (error . show) id - From 8aec47ec68518a817980457888f3068913aa2a42 Mon Sep 17 00:00:00 2001 From: Melanie Brown Date: Mon, 6 May 2024 16:19:16 -0400 Subject: [PATCH 2/3] fix and test single @ as operator --- Text/Shakespeare/Base.hs | 6 ++---- test/Text/Shakespeare/BaseSpec.hs | 6 ++++++ 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/Text/Shakespeare/Base.hs b/Text/Shakespeare/Base.hs index cbe3262..726d9b6 100644 --- a/Text/Shakespeare/Base.hs +++ b/Text/Shakespeare/Base.hs @@ -106,9 +106,7 @@ parseDeref = do derefInfix x = try $ do _ <- delim xs <- many $ try $ derefSingle >>= \x' -> delim >> return x' - op <- - (try $ liftA2 (:) (satisfy isOperatorChar) (many (satisfy isOperatorChar <|> char '@')) - <|> liftA2 (:) (char '@') (many1 (satisfy isOperatorChar <|> char '@'))) "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 @@ -121,7 +119,7 @@ parseDeref = do pure $ foldl DerefGetField x fields tyNameOrVar = liftA2 (:) (alphaNum <|> char '\'') (many (alphaNum <|> char '_' <|> char '\'')) derefType = try $ do - _ <- char '@' + _ <- char '@' >> notFollowedBy (oneOf " \t") x <- try tyNameOrVar <|> try (string "()") diff --git a/test/Text/Shakespeare/BaseSpec.hs b/test/Text/Shakespeare/BaseSpec.hs index 1a8b05f..7be4d2b 100644 --- a/test/Text/Shakespeare/BaseSpec.hs +++ b/test/Text/Shakespeare/BaseSpec.hs @@ -51,6 +51,12 @@ spec = do (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` From 43fcf413a81d2f728da63081200397f500311b81 Mon Sep 17 00:00:00 2001 From: Melanie Brown Date: Mon, 13 May 2024 15:52:04 -0400 Subject: [PATCH 3/3] version bump + changelog --- ChangeLog.md | 4 ++++ shakespeare.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index c49c9bf..e384711 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # 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/shakespeare.cabal b/shakespeare.cabal index 6156971..0c3925f 100644 --- a/shakespeare.cabal +++ b/shakespeare.cabal @@ -1,5 +1,5 @@ name: shakespeare -version: 2.1.0 +version: 2.1.1 license: MIT license-file: LICENSE author: Michael Snoyman