Idea: Make interpolation dependent on user-defined instances

PyF.cabal

@@ -21,6 +21,7 @@ extra-source-files:
 
 library
   exposed-modules:
+    Test
     PyF
     PyF.Class
     PyF.Formatters

src/PyF.hs

@@ -2,11 +2,14 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GADTs #-}
 
 -- | A lot of quasiquoters to format and interpolate string expressions.
 module PyF
   ( fmt,
     fmtTrim,
+    int,
     str,
     strTrim,
     raw,
@@ -29,13 +32,23 @@ 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, 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'.
 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 +138,9 @@ 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)
+

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

src/PyF/Internal/PythonSyntax.hs

@@ -11,7 +11,9 @@
 -- This module provides a parser for <https://docs.python.org/3.4/library/string.html#formatspec python format string mini language>.
 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

src/PyF/Internal/QQ.hs

@@ -15,16 +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,
-    Config (..),
-    wrapFromString,
-    expQQ,
-  )
+  -- ( toExp,
+  --   toExpPlain,
+  --   toExpPlain',
+  --   toFormatPlain,
+  --   ItemPlain(..),
+  --   Config (..),
+  --   wrapFromString,
+  --   expQQ,
+  -- )
 where
 
 import Control.Monad.Reader
@@ -106,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
@@ -165,6 +173,35 @@ 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 s = do
+  loc <- location
+  exts <- extsEnabled
+  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 -> goFormatPlain items
+        Just (srcSpan, msg) -> do
+          reportErrorAt srcSpan msg
+          [|interpolateInto Text.empty|]
+
+
 findFreeVariablesInFormatMode :: Maybe FormatMode -> [(SrcSpan, RdrName)]
 findFreeVariablesInFormatMode Nothing = []
 findFreeVariablesInFormatMode (Just (FormatMode padding tf _)) =
@@ -183,6 +220,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 +308,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 +385,17 @@ 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 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
 sappendQ s0 s1 = InfixE (Just s0) (VarE '(<>)) (Just s1)
@@ -339,6 +408,16 @@ toFormat (Replacement (_, expr) y) = do
   formatExpr <- padAndFormat (fromMaybe DefaultFormatMode y)
   pure (formatExpr `AppE` expr)
 
+
+toFormatPlain :: ItemPlain -> Q Exp
+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
 defaultFloatPrecision = Just 6

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 = "<interactive>", 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