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 f774337..c60a355 100644 --- a/src/PyF.hs +++ b/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) + 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/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..3ac2665 100644 --- a/src/PyF/Internal/QQ.hs +++ b/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 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