WIP: initial interpolating quasi quoter via typeclass

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.

Author: Profpatsch

PyF.cabal

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

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)
+

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/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

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