From 9d665727ae71eb961e099d8cde324b4c4946941f Mon Sep 17 00:00:00 2001 From: Philip Patsch Date: Mon, 20 Jan 2025 14:51:52 +0100 Subject: [PATCH 1/2] WIP: restricted version of fmt (no formatters, just interpolation) --- src/PyF.hs | 12 ++++++- src/PyF/Internal/PythonSyntax.hs | 41 +++++++++++++++++---- src/PyF/Internal/QQ.hs | 62 ++++++++++++++++++++++++++++++++ 3 files changed, 108 insertions(+), 7 deletions(-) diff --git a/src/PyF.hs b/src/PyF.hs index f774337..2aeda09 100644 --- a/src/PyF.hs +++ b/src/PyF.hs @@ -7,6 +7,7 @@ module PyF ( fmt, fmtTrim, + int, str, strTrim, raw, @@ -29,13 +30,17 @@ import Data.Char (isSpace) import Data.List (intercalate) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import PyF.Class -import PyF.Internal.QQ (Config (..), expQQ, toExp, wrapFromString) +import PyF.Internal.QQ (Config (..), expQQ, toExp, toExpPlain, wrapFromString) -- | Generic formatter, can format an expression to any @t@ as long as -- @t@ is an instance of 'IsString'. fmt :: QuasiQuoter fmt = mkFormatter "fmt" fmtConfig +-- | like fmt, but will only interpolate, no number formatting. +int :: QuasiQuoter +int = mkFormatterPlain "int" fmtConfig + -- | Format with whitespace trimming. fmtTrim :: QuasiQuoter fmtTrim = let @@ -125,3 +130,8 @@ addFormatting delims c = c {delimiters = Just delims} -- 'fmtConfig' and 'strConfig' for examples. mkFormatter :: String -> Config -> QuasiQuoter mkFormatter name config = expQQ name (toExp config) + +-- | Build a formatter. See the 'Config' type for details, as well as +-- 'fmtConfig' and 'strConfig' for examples. +mkFormatterPlain :: String -> Config -> QuasiQuoter +mkFormatterPlain name config = expQQ name (toExpPlain config) diff --git a/src/PyF/Internal/PythonSyntax.hs b/src/PyF/Internal/PythonSyntax.hs index 0950445..ad81922 100644 --- a/src/PyF/Internal/PythonSyntax.hs +++ b/src/PyF/Internal/PythonSyntax.hs @@ -11,7 +11,9 @@ -- This module provides a parser for . module PyF.Internal.PythonSyntax ( parseGenericFormatString, + parseGenericFormatStringPlain, Item (..), + ItemPlain (..), FormatMode (..), Padding (..), Precision (..), @@ -89,6 +91,14 @@ data Item | -- | A replacement string, composed of an arbitrary Haskell expression followed by an optional formatter Replacement (HsExpr GhcPs, Exp) (Maybe FormatMode) +-- | A plain format string is composed of many chunks of raw string or replacement, but no replacement fields +data ItemPlain + = -- | A raw string + RawPlain String + | -- | A replacement string, composed of an arbitrary Haskell expression followed by an optional formatter + ReplacementPlain (HsExpr GhcPs, Exp) + + -- | -- Parse a string, returns a list of raw string or replacement fields -- @@ -107,10 +117,10 @@ parseGenericFormatString = do delimitersM <- asks delimiters case delimitersM of - Nothing -> many (rawString Nothing) - Just _ -> many (rawString delimitersM <|> escapedParenthesis <|> replacementField) <* eof + Nothing -> many (Raw <$> rawString Nothing) + Just _ -> many ((Raw <$> rawString delimitersM) <|> (Raw <$> escapedParenthesis) <|> replacementField) <* eof -rawString :: Maybe (Char, Char) -> Parser Item +rawString :: Maybe (Char, Char) -> Parser [Char] rawString delimsM = do let delims = case delimsM of Nothing -> [] @@ -128,12 +138,21 @@ rawString delimsM = do Right escaped -> do -- Consumne everything void p - return (Raw escaped) + return (escaped) + +parseGenericFormatStringPlain :: Parser [ItemPlain] +parseGenericFormatStringPlain = do + delimitersM <- asks delimiters + + case delimitersM of + Nothing -> many (RawPlain <$> rawString Nothing) + Just _ -> many ((RawPlain <$> rawString delimitersM) <|> (RawPlain <$> escapedParenthesis) <|> replacementFieldPlain) <* eof -escapedParenthesis :: Parser Item + +escapedParenthesis :: Parser [Char] escapedParenthesis = do Just (openingChar, closingChar) <- asks delimiters - Raw <$> (parseRaw openingChar <|> parseRaw closingChar) + (parseRaw openingChar <|> parseRaw closingChar) where parseRaw c = [c] <$ try (string (replicate 2 c)) @@ -174,6 +193,16 @@ replacementField = do _ <- char charClosing pure (Replacement expr fmt) + +replacementFieldPlain :: Parser ItemPlain +replacementFieldPlain = do + exts <- asks enabledExtensions + Just (charOpening, charClosing) <- asks delimiters + _ <- char charOpening + expr <- evalExpr exts (parseExpressionString "an haskell expression") + _ <- char charClosing + pure (ReplacementPlain expr) + -- | Default formatting mode, no padding, default precision, no grouping, no sign handling pattern DefaultFormatMode :: FormatMode pattern DefaultFormatMode = FormatMode PaddingDefault (DefaultF PrecisionDefault Minus) Nothing diff --git a/src/PyF/Internal/QQ.hs b/src/PyF/Internal/QQ.hs index 88c90f9..019a7a9 100644 --- a/src/PyF/Internal/QQ.hs +++ b/src/PyF/Internal/QQ.hs @@ -21,6 +21,7 @@ -- representing a formatted string. module PyF.Internal.QQ ( toExp, + toExpPlain, Config (..), wrapFromString, expQQ, @@ -165,6 +166,32 @@ toExp Config {delimiters = expressionDelimiters, postProcess} s = do reportErrorAt srcSpan msg [|()|] +-- | Parse a string and return a formatter for it +toExpPlain :: Config -> String -> Q Exp +toExpPlain Config {delimiters = expressionDelimiters, postProcess} s = do + loc <- location + exts <- extsEnabled + let context = ParsingContext expressionDelimiters exts + + -- Setup the parser so it matchs the real original position in the source + -- code. + let filename = loc_filename loc + let initPos = setSourceColumn (setSourceLine (initialPos filename) (fst $ loc_start loc)) (snd $ loc_start loc) + case runReader (runParserT (setPosition initPos >> parseGenericFormatStringPlain) () filename s) context of + Left err -> do + reportParserErrorAt err + -- returns a dummy exp, so TH continues its life. This TH code won't be + -- executed anyway, there is an error + [|()|] + Right items -> do + checkResult <- checkVariablesPlain items + case checkResult of + Nothing -> postProcess (goFormatPlain items) + Just (srcSpan, msg) -> do + reportErrorAt srcSpan msg + [|()|] + + findFreeVariablesInFormatMode :: Maybe FormatMode -> [(SrcSpan, RdrName)] findFreeVariablesInFormatMode Nothing = [] findFreeVariablesInFormatMode (Just (FormatMode padding tf _)) = @@ -183,6 +210,18 @@ checkOneItem (Replacement (hsExpr, _) formatMode) = do [] -> pure Nothing ((err, span) : _) -> pure $ Just (span, err) + +checkOneItemPlain :: ItemPlain -> Q (Maybe (SrcSpan, String)) +checkOneItemPlain (RawPlain _) = pure Nothing +checkOneItemPlain (ReplacementPlain (hsExpr, _)) = do + let allNames = findFreeVariables hsExpr <> findFreeVariablesInFormatMode Nothing + res <- mapM doesExists allNames + let resFinal = catMaybes res + + case resFinal of + [] -> pure Nothing + ((err, span) : _) -> pure $ Just (span, err) + {- ORMOLU_DISABLE -} findFreeVariables :: Data a => a -> [(SrcSpan, RdrName)] findFreeVariables item = allNames @@ -259,6 +298,15 @@ checkVariables (x : xs) = do Nothing -> checkVariables xs Just err -> pure $ Just err +-- | Check that all variables used in 'Item' exists, otherwise, fail. +checkVariablesPlain :: [ItemPlain] -> Q (Maybe (SrcSpan, String)) +checkVariablesPlain [] = pure Nothing +checkVariablesPlain (x : xs) = do + r <- checkOneItemPlain x + case r of + Nothing -> checkVariablesPlain xs + Just err -> pure $ Just err + -- Stolen from: https://www.tweag.io/blog/2021-01-07-haskell-dark-arts-part-i/ -- This allows to hack inside the the GHC api and use function not exported by template haskell. -- This may not be always safe, see https://github.com/guibou/PyF/issues/115, @@ -327,6 +375,12 @@ goFormat :: [Item] -> Q Exp goFormat [] = pure $ LitE (StringL "") -- see [Empty String Lifting] goFormat items = foldl1 sappendQ <$> mapM toFormat items +goFormatPlain :: [ItemPlain] -> Q Exp +-- We special case on empty list in order to generate an empty string +goFormatPlain [] = pure $ LitE (StringL "") -- see [Empty String Lifting] +goFormatPlain items = [|mconcat $(ListE <$> mapM toFormatPlain items)|] + + -- | call `<>` between two 'Exp' sappendQ :: Exp -> Exp -> Exp sappendQ s0 s1 = InfixE (Just s0) (VarE '(<>)) (Just s1) @@ -339,6 +393,14 @@ toFormat (Replacement (_, expr) y) = do formatExpr <- padAndFormat (fromMaybe DefaultFormatMode y) pure (formatExpr `AppE` expr) + +toFormatPlain :: ItemPlain -> Q Exp +toFormatPlain (RawPlain x) = pure $ LitE (StringL x) -- see [Empty String Lifting] +toFormatPlain (ReplacementPlain (_, expr)) = do + f <- [|pyfToString|] + pure $ f `AppE` expr + + -- | Default precision for floating point defaultFloatPrecision :: Maybe Int defaultFloatPrecision = Just 6 From 684e681fb84916ea117b6c7bec3760afdbcd8918 Mon Sep 17 00:00:00 2001 From: Philip Patsch Date: Mon, 20 Jan 2025 18:15:36 +0100 Subject: [PATCH 2/2] WIP: initial interpolating quasi quoter via typeclass MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is a WIP idea I’ve had that’s related to I think GHC string interpolation should ultimately work. Instead of defaulting to IsString and having a fixed amount of output formats we can use, we want the user to provide three things: A) The output type `out`, which has to be `Semigroup` for concatenation B) An instance `Interpolate a out` for each type that should be able to be interpolated into `out`. C) An instance `Interpolate Text out` for interpolating raw strings This way the user can provide domain-specific instances and prevent some problematic interpolations. This is just an initial idea, not intended to be merged. --- PyF.cabal | 1 + src/PyF.hs | 11 ++++++++- src/PyF/Class.hs | 15 ++++++++++++ src/PyF/Internal/QQ.hs | 53 ++++++++++++++++++++++++++++-------------- src/Test.hs | 47 +++++++++++++++++++++++++++++++++++++ 5 files changed, 108 insertions(+), 19 deletions(-) create mode 100644 src/Test.hs diff --git a/PyF.cabal b/PyF.cabal index 6b90c4c..e12b65b 100644 --- a/PyF.cabal +++ b/PyF.cabal @@ -21,6 +21,7 @@ extra-source-files: library exposed-modules: + Test PyF PyF.Class PyF.Formatters diff --git a/src/PyF.hs b/src/PyF.hs index 2aeda09..c60a355 100644 --- a/src/PyF.hs +++ b/src/PyF.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} -- | A lot of quasiquoters to format and interpolate string expressions. module PyF @@ -30,7 +32,13 @@ import Data.Char (isSpace) import Data.List (intercalate) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import PyF.Class -import PyF.Internal.QQ (Config (..), expQQ, toExp, toExpPlain, wrapFromString) +import PyF.Internal.QQ (Config (..), expQQ, toExp, toExpPlain, wrapFromString, toExpPlain') +import Language.Haskell.TH (pprint, runQ, extsEnabled, Loc (..)) +import Language.Haskell.TH.Syntax (location) +import qualified Language.Haskell.TH.Syntax as TH +import Language.Haskell.TH (Code(..)) +import Language.Haskell.TH (liftCode) +import Language.Haskell.TH (listE) -- | Generic formatter, can format an expression to any @t@ as long as -- @t@ is an instance of 'IsString'. @@ -135,3 +143,4 @@ mkFormatter name config = expQQ name (toExp config) -- 'fmtConfig' and 'strConfig' for examples. mkFormatterPlain :: String -> Config -> QuasiQuoter mkFormatterPlain name config = expQQ name (toExpPlain config) + diff --git a/src/PyF/Class.hs b/src/PyF/Class.hs index 3c83485..2f0ccd5 100644 --- a/src/PyF/Class.hs +++ b/src/PyF/Class.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification #-} -- | You want to add formatting support for your custom type. This is the right module. -- @@ -48,6 +49,7 @@ import qualified Data.Time import Data.Word import Numeric.Natural import PyF.Formatters +import Data.Data (Proxy (Proxy)) -- * Default formatting classification @@ -203,3 +205,16 @@ instance {-# OVERLAPPABLE #-} (Integral t) => PyfFormatIntegral t where -- 97 instance PyfFormatIntegral Char where pyfFormatIntegral f s p g v = formatIntegral f s p g (ord v) + + + +class Interpolate a into where + interpolateInto :: a -> into + +instance Interpolate a a where + interpolateInto = id + +data Interpolatable into = forall a. (Interpolate a into) => Interpolatable (Proxy into) a + +instance Interpolate (Interpolatable into) into where + interpolateInto (Interpolatable Proxy a) = interpolateInto a diff --git a/src/PyF/Internal/QQ.hs b/src/PyF/Internal/QQ.hs index 019a7a9..3ac2665 100644 --- a/src/PyF/Internal/QQ.hs +++ b/src/PyF/Internal/QQ.hs @@ -15,17 +15,21 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# LANGUAGE LambdaCase #-} -- | This module uses the python mini language detailed in -- 'PyF.Internal.PythonSyntax' to build an template haskell expression -- representing a formatted string. module PyF.Internal.QQ - ( toExp, - toExpPlain, - Config (..), - wrapFromString, - expQQ, - ) + -- ( toExp, + -- toExpPlain, + -- toExpPlain', + -- toFormatPlain, + -- ItemPlain(..), + -- Config (..), + -- wrapFromString, + -- expQQ, + -- ) where import Control.Monad.Reader @@ -107,6 +111,9 @@ import Text.Parsec.Error import Text.Parsec.Pos (initialPos) import Text.ParserCombinators.Parsec.Error (Message (..)) import Unsafe.Coerce (unsafeCoerce) +import qualified Data.Text as Text +import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty) +import Data.Semigroup (Semigroup(sconcat)) -- | Configuration for the quasiquoter data Config = Config @@ -168,28 +175,31 @@ toExp Config {delimiters = expressionDelimiters, postProcess} s = do -- | Parse a string and return a formatter for it toExpPlain :: Config -> String -> Q Exp -toExpPlain Config {delimiters = expressionDelimiters, postProcess} s = do +toExpPlain config s = do loc <- location exts <- extsEnabled - let context = ParsingContext expressionDelimiters exts + toExpPlain' loc s exts config +toExpPlain' :: Loc -> String -> [Extension] -> Config -> Q Exp +toExpPlain' loc s exts Config {delimiters = expressionDelimiters, postProcess} = do -- Setup the parser so it matchs the real original position in the source -- code. let filename = loc_filename loc let initPos = setSourceColumn (setSourceLine (initialPos filename) (fst $ loc_start loc)) (snd $ loc_start loc) + let context = ParsingContext expressionDelimiters exts case runReader (runParserT (setPosition initPos >> parseGenericFormatStringPlain) () filename s) context of Left err -> do reportParserErrorAt err -- returns a dummy exp, so TH continues its life. This TH code won't be -- executed anyway, there is an error - [|()|] + [|interpolateInto Text.empty|] Right items -> do checkResult <- checkVariablesPlain items case checkResult of - Nothing -> postProcess (goFormatPlain items) + Nothing -> goFormatPlain items Just (srcSpan, msg) -> do reportErrorAt srcSpan msg - [|()|] + [|interpolateInto Text.empty|] findFreeVariablesInFormatMode :: Maybe FormatMode -> [(SrcSpan, RdrName)] @@ -377,9 +387,14 @@ goFormat items = foldl1 sappendQ <$> mapM toFormat items goFormatPlain :: [ItemPlain] -> Q Exp -- We special case on empty list in order to generate an empty string -goFormatPlain [] = pure $ LitE (StringL "") -- see [Empty String Lifting] -goFormatPlain items = [|mconcat $(ListE <$> mapM toFormatPlain items)|] +goFormatPlain items = case nonEmpty items of + Nothing -> [|interpolateInto Text.empty|] -- see [Empty String Lifting] + Just items -> do + let items' = fmap toFormatPlain items + [|$(nonEmptyE items')|] +nonEmptyE :: NonEmpty (Q Exp) -> Q Exp +nonEmptyE (x :| xs) = [|sconcat ($(x) :| $(listE xs))|] -- | call `<>` between two 'Exp' sappendQ :: Exp -> Exp -> Exp @@ -395,11 +410,13 @@ toFormat (Replacement (_, expr) y) = do toFormatPlain :: ItemPlain -> Q Exp -toFormatPlain (RawPlain x) = pure $ LitE (StringL x) -- see [Empty String Lifting] -toFormatPlain (ReplacementPlain (_, expr)) = do - f <- [|pyfToString|] - pure $ f `AppE` expr - +toFormatPlain item = do + let tyProxy = SigE (ConE 'Proxy) (AppT (ConT ''Proxy) (ConT ''Text.Text)) + case item of + (RawPlain x) -> [|interpolateInto $[|Text.pack x|]|] + (ReplacementPlain (_, expr)) -> do + exprTyped <- [|$(pure expr)|] + [|interpolateInto $(pure exprTyped)|] -- | Default precision for floating point defaultFloatPrecision :: Maybe Int diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 index 0000000..d0ffd8d --- /dev/null +++ b/src/Test.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Test where +import PyF +import Data.Text +import Language.Haskell.TH (pprint, Loc (..), runQ) +import PyF.Internal.QQ +import Language.Haskell.TH (stringE) +import qualified Data.List.NonEmpty as NE +import Data.Semigroup (All) +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as Builder +import Data.ByteString (ByteString) +import qualified Data.Text.Lazy.Builder.Int as Builder.Int + + +-- test = do +-- let t = "abc" :: Text +-- [int|bac|] :: Text + + +-- foo = do +-- -- res <- runQ $ toExpPlain' Loc { loc_filename = "", loc_package = "main", loc_module = "Main", loc_start = (1, 1), loc_end = (1, 1) } "abc" [] fmtConfig +-- res <- runQ @IO $ toFormatPlain (RawPlain "abc") +-- putStrLn (pprint $ res) + +bar = $( + -- s <- stringE "abc" + -- toFormatPlain (ReplacementPlain (undefined, s)) + nonEmptyE (NE.singleton [| "abc" |]) + + ) :: Text + +baz :: Builder +baz = do + let t = 32 :: Int + [int|abc{t}|] + + +instance Interpolate Text Builder where + interpolateInto = Builder.fromText + +instance Interpolate Int Builder where + interpolateInto = Builder.Int.decimal