From a98d919801aab1a2e50f1b2c75f12e02091582fd Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Fri, 3 Jan 2025 17:44:03 +0400 Subject: [PATCH 01/17] chore: fix upper bound for cabal upload --- PyF.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PyF.cabal b/PyF.cabal index 6b90c4c..c047ed0 100644 --- a/PyF.cabal +++ b/PyF.cabal @@ -33,7 +33,7 @@ library build-depends: , base >=4.12 && <4.22 , bytestring >=0.10.8 && <0.13 - , ghc >=8.6.1 + , ghc >=8.6.1 && <9.14 , mtl >=2.2.2 && <2.4 , parsec >=3.1.13 && <3.2 , template-haskell >=2.14.0 && <2.24 From 1700ceaab208eb5fe4f21b1f0ae9e822e1071eae Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Sat, 4 Jan 2025 15:45:41 +0400 Subject: [PATCH 02/17] feat: Introduction of a PyF plugin The new plugin, activable with `-fplugin=PyF.Plugin` can detect the usage of `fmt` and replace the template haskell by pure haskell code at plugin time. In the future, it could be possible to simplify the code (e.g. no more template Haskell, no more `Meta.hs`), give nicer feedbacks (instance errors can be localized on the real expression) and it should be faster because plugin do not require the dynamic logic required for template haskell. --- PyF.cabal | 20 ++++ src/PyF.hs | 9 +- src/PyF/Formatters.hs | 2 + src/PyF/Internal/PythonSyntax.hs | 9 +- src/PyF/Internal/QQ.hs | 8 +- src/PyF/Plugin.hs | 191 +++++++++++++++++++++++++++++++ test/SpecPlugin.hs | 8 ++ 7 files changed, 237 insertions(+), 10 deletions(-) create mode 100644 src/PyF/Plugin.hs create mode 100644 test/SpecPlugin.hs diff --git a/PyF.cabal b/PyF.cabal index c047ed0..acd906d 100644 --- a/PyF.cabal +++ b/PyF.cabal @@ -29,6 +29,7 @@ library PyF.Internal.ParserEx PyF.Internal.PythonSyntax PyF.Internal.QQ + PyF.Plugin build-depends: , base >=4.12 && <4.22 @@ -39,6 +40,7 @@ library , template-haskell >=2.14.0 && <2.24 , text >=1.2.3 && <2.2 , time >=1.8.0 && <1.15 + , syb if impl(ghc <9.2.1) build-depends: ghc-boot >=8.6.1 && <9.7 @@ -67,6 +69,24 @@ test-suite pyf-test default-language: Haskell2010 +test-suite pyf-test-plugin + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: SpecPlugin.hs + build-depends: + , base + , bytestring + , hspec + , PyF + , template-haskell + , text + , time + + ghc-options: + -Wall -threaded -rtsopts -with-rtsopts=-N -Wunused-packages + + default-language: Haskell2010 + test-suite pyf-overloaded type: exitcode-stdio-1.0 hs-source-dirs: test diff --git a/src/PyF.hs b/src/PyF.hs index f774337..2633a0d 100644 --- a/src/PyF.hs +++ b/src/PyF.hs @@ -22,6 +22,12 @@ module PyF strConfig, addTrim, addFormatting, + + -- This is reexported so plugin can use them once PyF is imported. + -- TODO: find a way to HIDE this. Maybe the source plugin can explicitly + -- qualified the symbols. + module PyF.Formatters, + module PyF.Internal.QQ ) where @@ -29,7 +35,8 @@ 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.Formatters +import PyF.Internal.QQ -- | Generic formatter, can format an expression to any @t@ as long as -- @t@ is an instance of 'IsString'. diff --git a/src/PyF/Formatters.hs b/src/PyF/Formatters.hs index cc15d38..029525a 100644 --- a/src/PyF/Formatters.hs +++ b/src/PyF/Formatters.hs @@ -131,6 +131,8 @@ data Format (k :: AltStatus) (k' :: UpperStatus) (k'' :: FormatType) where -- Upper should come AFTER Alt, so this disallow any future alt Upper :: Format alt 'CanUpper f -> Format 'NoAlt 'NoUpper f +deriving instance Show (Format k k' k'') + newtype ShowIntegral i = ShowIntegral i deriving (Real, Enum, Ord, Eq, Num, Integral) diff --git a/src/PyF/Internal/PythonSyntax.hs b/src/PyF/Internal/PythonSyntax.hs index 0950445..2c0e595 100644 --- a/src/PyF/Internal/PythonSyntax.hs +++ b/src/PyF/Internal/PythonSyntax.hs @@ -49,6 +49,7 @@ import Control.Monad (replicateM_) #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc import GHC.Data.FastString +import GHC.Utils.Outputable (Outputable) #else import SrcLoc import FastString @@ -192,11 +193,15 @@ data ExprOrValue t | HaskellExpr (HsExpr GhcPs, Exp) deriving (Data) +instance Show t => Show (ExprOrValue t) where + show (Value v) = "Value " <> show v + show (HaskellExpr (eh, e)) = "HaskellExpr " <> show e + -- | Floating point precision data Precision = PrecisionDefault | Precision (ExprOrValue Int) - deriving (Data) + deriving (Data, Show) {- @@ -247,7 +252,7 @@ data TypeFormat HexCapsF AlternateForm SignMode | -- | Percent representation PercentF Precision AlternateForm SignMode - deriving (Data) + deriving (Data, Show) -- | If the formatter use its alternate form data AlternateForm = AlternateForm | NormalForm diff --git a/src/PyF/Internal/QQ.hs b/src/PyF/Internal/QQ.hs index 88c90f9..4e57964 100644 --- a/src/PyF/Internal/QQ.hs +++ b/src/PyF/Internal/QQ.hs @@ -19,13 +19,7 @@ -- | 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, - ) -where +module PyF.Internal.QQ where import Control.Monad.Reader import Data.Data (Data (gmapQ), Typeable, cast) diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs new file mode 100644 index 0000000..1a54ab5 --- /dev/null +++ b/src/PyF/Plugin.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} + +module PyF.Plugin (plugin) where + +import Data.Data + +-- import Data.Generics + +#if MIN_VERSION_ghc(9,0,0) +import GHC.Hs +import GHC.Plugins +#else +import GHC +import GhcPlugins +#endif + +import Control.Monad.Reader (runReader) +import Data.Generics +import Data.Maybe (fromMaybe) +import qualified GHC.Types.Name.Occurrence as GHC.Types.Name.Occurence +import GHC.Types.SourceText (SourceText (..), mkIntegralLit) +import PyF (Format (..), defaultFloatPrecision, fmtConfig) +import PyF.Formatters (SignMode (..)) +import PyF.Internal.PythonSyntax + ( AlternateForm (..), + ExprOrValue (..), + FormatMode (..), + Item (..), + Padding (..), + ParsingContext (..), + Precision (..), + TypeFormat (..), + parseGenericFormatString, + pattern DefaultFormatMode, + ) +import PyF.Internal.QQ (Config (..)) +import Text.Parsec (runParserT) + +plugin :: Plugin +plugin = + defaultPlugin + { pluginRecompile = purePlugin, + parsedResultAction = \_ _ parsedResult -> do + m <- action $ parsedResultModule parsedResult + pure $ parsedResult {parsedResultModule = m} + } + +action :: HsParsedModule -> Hsc HsParsedModule +action parsed@HsParsedModule {hpm_module = m} = + (\m' -> parsed {hpm_module = m'}) + <$> gmapM (everywhereM (mkM sayYes)) m + +sayYes :: HsExpr GhcPs -> Hsc (HsExpr GhcPs) +sayYes e = do + case e of + HsUntypedSplice _xsplit (HsQuasiQuote _xquasi (Unqual name) s) + | mkVarOcc "fmt" == name -> do + liftIO $ print $ (showPprUnsafe name) + let items = map toString $ pyf (unpackFS $ unLoc s) + pure $ + HsApp + noExtField' + ( L + noSrcSpanA + ( HsVar + NoExtField + ( L noSrcSpanA $ + mkUnqual GHC.Types.Name.Occurence.varName (mkFastString "mconcat") + ) + ) + ) + (L noSrcSpanA $ ExplicitList emptyAnnList $ map (L noSrcSpanA) items) + _ -> do + pure e + +toString :: Item -> HsExpr GhcPs +toString (Raw s) = HsLit noExtField' $ HsString NoSourceText (mkFastString s) +toString (Replacement (expr, _unusedThExp) formatMode) = do + let formatExpr = padAndFormat (fromMaybe DefaultFormatMode formatMode) + app formatExpr expr + +pyf :: String -> [Item] +pyf s = case runReader (runParserT (parseGenericFormatString) () filename s) context of + Right r -> r + Left e -> error $ show e + where + filename = "TODO" + Config {..} = fmtConfig + context = ParsingContext {enabledExtensions = [], ..} + +-- TODO: +-- - missing fileposition for correct error reporting +-- - Maybe we can leverage the current "Hsc" in order to parser the internal values? +-- - correct filename during parsing +-- - todo: list the extensions (maybe not useful, if we leverage the +-- current Hsc for parsing) +-- + +app :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs +app a b = HsApp noExtField' (L noSrcSpanA a) (L noSrcSpanA b) + +var :: String -> HsExpr GhcPs +var name = + ( HsVar + NoExtField + ( L noSrcSpanA $ + mkUnqual GHC.Types.Name.Occurence.varName (mkFastString name) + ) + ) + +ctor :: String -> HsExpr GhcPs +ctor name = + ( HsVar + NoExtField + ( L noSrcSpanA $ + mkUnqual GHC.Types.Name.Occurence.dataName (mkFastString name) + ) + ) + +padAndFormat :: FormatMode -> HsExpr GhcPs +padAndFormat (FormatMode padding tf grouping) = case tf of + -- Integrals + BinaryF alt s -> var "formatAnyIntegral" `app` withAlt alt Binary `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + CharacterF -> var "formatAnyIntegral" `app` ctor "Character" `app` ctor "Minus" `app` mkPadding padding `app` ctor "Nothing" + DecimalF s -> var "formatAnyIntegral" `app` ctor "Decimal" `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 + HexF alt s -> var "formatAnyIntegral" `app` withAlt alt Hexa `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + OctalF alt s -> var "formatAnyIntegral" `app` withAlt alt Octal `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + {- + HexCapsF alt s -> [|formatAnyIntegral (Formatters.Upper $(withAlt alt Formatters.Hexa)) s $(newPaddingQ padding) $(toGrp grouping 4)|] + -} + -- Floating + GeneralF prec alt s -> var "formatAnyFractional" `app` withAlt alt Exponent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + {- + ExponentialCapsF prec alt s -> [|formatAnyFractional (Formatters.Upper $(withAlt alt Formatters.Exponent)) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|] + -} + GeneralF prec alt s -> var "formatAnyFractional" `app` withAlt alt Generic `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + {- + GeneralCapsF prec alt s -> [|formatAnyFractional (Formatters.Upper $(withAlt alt Formatters.Generic)) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|] + -} + FixedF prec alt s -> var "formatAnyFractional" `app` withAlt alt Fixed `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + {- + FixedCapsF prec alt s -> [|formatAnyFractional (Formatters.Upper $(withAlt alt Formatters.Fixed)) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|] + -} + PercentF prec alt s -> var "formatAnyFractional" `app` withAlt alt Percent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + -- Default / String + DefaultF prec s -> var "formatAny" `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec + StringF prec -> (var ".") `app` (var "formatString" `app` mkPadding padding `app` mkPrecision Nothing prec) `app` (var "pyfToString") + e -> error $ "Not handled: " Prelude.<> show e + +toSignMode :: SignMode -> HsExpr GhcPs +toSignMode Plus = ctor "Plus" +toSignMode Minus = ctor "Minus" +toSignMode Space = ctor "Space" + +toGrp :: Maybe Char -> Int -> HsExpr GhcPs +toGrp Nothing _ = ctor "Nothing" + +withAlt :: AlternateForm -> Format a b c -> HsExpr GhcPs +withAlt NormalForm formatter = var $ show formatter + +-- toGrp (Just v) a = ctor "Just" `app` (error "not done to grp") +-- where +-- grp = (a,v) + +mkPadding :: Padding -> HsExpr GhcPs +mkPadding PaddingDefault = ctor "Nothing" + +mkPrecision :: Maybe Int -> Precision -> HsExpr GhcPs +mkPrecision Nothing PrecisionDefault = ctor "Nothing" +mkPrecision (Just v) PrecisionDefault = ctor "Just" `app` (HsLit noExtField' $ HsInt NoExtField (mkIntegralLit v)) +mkPrecision _ (Precision p) = ctor "Just" `app` exprToInt p + +exprToInt :: ExprOrValue Int -> HsExpr GhcPs +exprToInt (Value i) = HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) +exprToInt (HaskellExpr (expr, _)) = expr + +#if MIN_VERSION_ghc(9,10,0) +noExtField' :: NoExtField +noExtField' = NoExtField + +emptyAnnList :: AnnList +emptyAnnList = AnnList Nothing Nothing Nothing [] [] +#else +noExtField' :: EpAnn ann +noExtField' = EpAnnNotUsed + +emptyAnnList :: EpAnn ann +emptyAnnList = EpAnnNotUsed +#endif diff --git a/test/SpecPlugin.hs b/test/SpecPlugin.hs new file mode 100644 index 0000000..a4215c7 --- /dev/null +++ b/test/SpecPlugin.hs @@ -0,0 +1,8 @@ +{-# OPTIONS -fplugin=PyF.Plugin #-} +{-# LANGUAGE QuasiQuotes #-} +module Main where +import PyF + +main = do + putStrLn [fmt|Hello world! {(1 :: Int) + 1:s} is a nice value.|] + From 83b1760fdadad0857cdf6b662d0691de0f4082fe Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Sat, 4 Jan 2025 20:31:42 +0400 Subject: [PATCH 03/17] refactor: WIP: parse the haskell expression AFTER the parse, having a `String` inside the AST. TODO: restore correct locations. --- src/PyF/Internal/PythonSyntax.hs | 27 ++++++++---------------- src/PyF/Internal/QQ.hs | 35 +++++++++++++++++++++++++------- 2 files changed, 36 insertions(+), 26 deletions(-) diff --git a/src/PyF/Internal/PythonSyntax.hs b/src/PyF/Internal/PythonSyntax.hs index 2c0e595..9be0c7d 100644 --- a/src/PyF/Internal/PythonSyntax.hs +++ b/src/PyF/Internal/PythonSyntax.hs @@ -42,14 +42,11 @@ import Text.Parsec #elif MIN_VERSION_ghc(9,6,0) -- For some reasons, theses function are not exported anymore by some others -import Data.Functor (void) -import Control.Monad (replicateM_) #endif #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc import GHC.Data.FastString -import GHC.Utils.Outputable (Outputable) #else import SrcLoc import FastString @@ -58,8 +55,7 @@ import FastString type Parser t = ParsecT String () (Reader ParsingContext) t data ParsingContext = ParsingContext - { delimiters :: Maybe (Char, Char), - enabledExtensions :: [Extension] + { delimiters :: Maybe (Char, Char) } deriving (Show) @@ -88,7 +84,7 @@ data Item = -- | A raw string Raw String | -- | A replacement string, composed of an arbitrary Haskell expression followed by an optional formatter - Replacement (HsExpr GhcPs, Exp) (Maybe FormatMode) + Replacement String (Maybe FormatMode) -- | -- Parse a string, returns a list of raw string or replacement fields @@ -165,10 +161,9 @@ parseExpressionString = do replacementField :: Parser Item replacementField = do - exts <- asks enabledExtensions Just (charOpening, charClosing) <- asks delimiters _ <- char charOpening - expr <- evalExpr exts (parseExpressionString "an haskell expression") + expr <- parseExpressionString "an haskell expression" fmt <- optionMaybe $ do _ <- char ':' formatSpec @@ -190,12 +185,8 @@ data Padding -- | Represents a value of type @t@ or an Haskell expression supposed to represents that value data ExprOrValue t = Value t - | HaskellExpr (HsExpr GhcPs, Exp) - deriving (Data) - -instance Show t => Show (ExprOrValue t) where - show (Value v) = "Value " <> show v - show (HaskellExpr (eh, e)) = "HaskellExpr " <> show e + | HaskellExpr String + deriving (Data, Show) -- | Floating point precision data Precision @@ -318,21 +309,19 @@ formatSpec = do parseWidth :: Parser (ExprOrValue Int) parseWidth = do - exts <- asks enabledExtensions Just (charOpening, charClosing) <- asks delimiters choice [ Value <$> width, - char charOpening *> (HaskellExpr <$> evalExpr exts (someTill (satisfy (/= charClosing)) (char charClosing) "an haskell expression")) + char charOpening *> (HaskellExpr <$> (someTill (satisfy (/= charClosing)) (char charClosing) "an haskell expression")) ] parsePrecision :: Parser Precision parsePrecision = do - exts <- asks enabledExtensions Just (charOpening, charClosing) <- asks delimiters _ <- char '.' choice [ Precision . Value <$> precision, - char charOpening *> (Precision . HaskellExpr <$> evalExpr exts (someTill (satisfy (/= charClosing)) (char charClosing) "an haskell expression")) + char charOpening *> (Precision . HaskellExpr <$> (someTill (satisfy (/= charClosing)) (char charClosing) "an haskell expression")) ] -- | Similar to 'manyTill' but always parse one element. @@ -378,7 +367,7 @@ failIfPrec (Precision e) _ = Left ("Type incompatible with precision (." ++ show where showExpr = case e of Value v -> show v - HaskellExpr (_, expr) -> show expr + HaskellExpr s -> s failIfAlt :: AlternateForm -> TypeFormat -> Either String TypeFormat failIfAlt NormalForm i = Right i diff --git a/src/PyF/Internal/QQ.hs b/src/PyF/Internal/QQ.hs index 4e57964..a00d92e 100644 --- a/src/PyF/Internal/QQ.hs +++ b/src/PyF/Internal/QQ.hs @@ -28,6 +28,8 @@ import Data.List (intercalate) import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.Proxy import Data.String (fromString) +import PyF.Internal.PythonSyntax +import qualified PyF.Internal.Meta #if MIN_VERSION_ghc(9,0,0) import GHC.Tc.Utils.Monad (addErrAt) @@ -89,8 +91,7 @@ import Language.Haskell.TH.Syntax (Q (Q)) import PyF.Class import PyF.Formatters (AnyAlign (..)) import qualified PyF.Formatters as Formatters -import PyF.Internal.Meta (toName) -import PyF.Internal.PythonSyntax +import PyF.Internal.Meta (toName, baseDynFlags) import Text.Parsec import Text.Parsec.Error ( errorMessages, @@ -100,6 +101,8 @@ import Text.Parsec.Error import Text.Parsec.Pos (initialPos) import Text.ParserCombinators.Parsec.Error (Message (..)) import Unsafe.Coerce (unsafeCoerce) +import GHC.Data.FastString (mkFastString) +import qualified PyF.Internal.Parser as ParseExp -- | Configuration for the quasiquoter data Config = Config @@ -138,8 +141,7 @@ wrapFromString e = do toExp :: Config -> String -> Q Exp toExp Config {delimiters = expressionDelimiters, postProcess} s = do loc <- location - exts <- extsEnabled - let context = ParsingContext expressionDelimiters exts + let context = ParsingContext expressionDelimiters -- Setup the parser so it matchs the real original position in the source -- code. @@ -166,9 +168,27 @@ findFreeVariablesInFormatMode (Just (FormatMode padding tf _)) = PaddingDefault -> [] Padding eoi _ -> findFreeVariables eoi +toHsExpr :: String -> Q (HsExpr GhcPs) +toHsExpr s = do + exts <- extsEnabled + let dynFlags = baseDynFlags exts + -- TODO + let initLoc = mkRealSrcLoc (mkFastString "file") 10 10 + + case ParseExp.parseExpression initLoc s dynFlags of + Right res -> pure res + Left e -> error $ show e + +hsExprToTh :: HsExpr GhcPs -> Q Exp +hsExprToTh e = do + exts <- extsEnabled + let dynFlags = baseDynFlags exts + pure $ PyF.Internal.Meta.toExp dynFlags e + checkOneItem :: Item -> Q (Maybe (SrcSpan, String)) checkOneItem (Raw _) = pure Nothing -checkOneItem (Replacement (hsExpr, _) formatMode) = do +checkOneItem (Replacement s formatMode) = do + hsExpr <- toHsExpr s let allNames = findFreeVariables hsExpr <> findFreeVariablesInFormatMode formatMode res <- mapM doesExists allNames let resFinal = catMaybes res @@ -329,7 +349,8 @@ sappendQ s0 s1 = InfixE (Just s0) (VarE '(<>)) (Just s1) toFormat :: Item -> Q Exp toFormat (Raw x) = pure $ LitE (StringL x) -- see [Empty String Lifting] -toFormat (Replacement (_, expr) y) = do +toFormat (Replacement s y) = do + expr <- toHsExpr s >>= hsExprToTh formatExpr <- padAndFormat (fromMaybe DefaultFormatMode y) pure (formatExpr `AppE` expr) @@ -383,7 +404,7 @@ newPaddingQ padding = case padding of exprToInt :: ExprOrValue Int -> Q Exp -- Note: this is a literal provided integral. We use explicit case to ::Int so it won't warn about defaulting exprToInt (Value i) = [|$(pure $ LitE (IntegerL (fromIntegral i))) :: Int|] -exprToInt (HaskellExpr (_, e)) = [|$(pure e)|] +exprToInt (HaskellExpr e) = toHsExpr e >>= hsExprToTh data PaddingK k i where PaddingDefaultK :: PaddingK 'Formatters.AlignAll Int From 0ca985b2a2282f662b6cd6b8d3236bbc4152822b Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Sat, 4 Jan 2025 20:32:44 +0400 Subject: [PATCH 04/17] WIP plugin: set the correct dynflags --- src/PyF/Plugin.hs | 37 ++++++++++++++++++++++++++----------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs index 1a54ab5..d9aa239 100644 --- a/src/PyF/Plugin.hs +++ b/src/PyF/Plugin.hs @@ -37,7 +37,10 @@ import PyF.Internal.PythonSyntax ) import PyF.Internal.QQ (Config (..)) import Text.Parsec (runParserT) +import qualified PyF.Internal.Parser as ParseExp +-- | A plugin which replaces all [fmt|...] from PyF by a pure haskell code +-- without template haskell. plugin :: Plugin plugin = defaultPlugin @@ -50,15 +53,15 @@ plugin = action :: HsParsedModule -> Hsc HsParsedModule action parsed@HsParsedModule {hpm_module = m} = (\m' -> parsed {hpm_module = m'}) - <$> gmapM (everywhereM (mkM sayYes)) m + <$> gmapM (everywhereM (mkM replaceSplice)) m -sayYes :: HsExpr GhcPs -> Hsc (HsExpr GhcPs) -sayYes e = do +-- | Replace a splice entry +replaceSplice :: HsExpr GhcPs -> Hsc (HsExpr GhcPs) +replaceSplice e = do case e of HsUntypedSplice _xsplit (HsQuasiQuote _xquasi (Unqual name) s) | mkVarOcc "fmt" == name -> do - liftIO $ print $ (showPprUnsafe name) - let items = map toString $ pyf (unpackFS $ unLoc s) + items <- mapM toString $ pyf (unpackFS $ unLoc s) pure $ HsApp noExtField' @@ -75,11 +78,12 @@ sayYes e = do _ -> do pure e -toString :: Item -> HsExpr GhcPs -toString (Raw s) = HsLit noExtField' $ HsString NoSourceText (mkFastString s) -toString (Replacement (expr, _unusedThExp) formatMode) = do +toString :: Item -> Hsc (HsExpr GhcPs) +toString (Raw s) = pure $ HsLit noExtField' $ HsString NoSourceText (mkFastString s) +toString (Replacement s formatMode) = do + expr <- toHsExpr s let formatExpr = padAndFormat (fromMaybe DefaultFormatMode formatMode) - app formatExpr expr + pure $ app formatExpr expr pyf :: String -> [Item] pyf s = case runReader (runParserT (parseGenericFormatString) () filename s) context of @@ -88,7 +92,7 @@ pyf s = case runReader (runParserT (parseGenericFormatString) () filename s) con where filename = "TODO" Config {..} = fmtConfig - context = ParsingContext {enabledExtensions = [], ..} + context = ParsingContext {..} -- TODO: -- - missing fileposition for correct error reporting @@ -174,7 +178,18 @@ mkPrecision _ (Precision p) = ctor "Just" `app` exprToInt p exprToInt :: ExprOrValue Int -> HsExpr GhcPs exprToInt (Value i) = HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) -exprToInt (HaskellExpr (expr, _)) = expr +-- exprToInt (HaskellExpr s) = toHsExpr s + +toHsExpr :: String -> Hsc (HsExpr GhcPs) +toHsExpr s = do + dynFlags <- getDynFlags + -- TODO + let initLoc = mkRealSrcLoc (mkFastString "file") 10 10 + + case ParseExp.parseExpression initLoc s dynFlags of + Right res -> pure res + Left e -> error $ show e + #if MIN_VERSION_ghc(9,10,0) noExtField' :: NoExtField From f8214531a116b55396bb0b033a466321850bbbe0 Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Sat, 4 Jan 2025 21:16:19 +0400 Subject: [PATCH 05/17] Plugin: progress: handle most constructors --- src/PyF/Plugin.hs | 38 +++++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 17 deletions(-) diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs index d9aa239..2101ddd 100644 --- a/src/PyF/Plugin.hs +++ b/src/PyF/Plugin.hs @@ -22,7 +22,7 @@ import Data.Maybe (fromMaybe) import qualified GHC.Types.Name.Occurrence as GHC.Types.Name.Occurence import GHC.Types.SourceText (SourceText (..), mkIntegralLit) import PyF (Format (..), defaultFloatPrecision, fmtConfig) -import PyF.Formatters (SignMode (..)) +import PyF.Formatters (SignMode (..), AnyAlign (..)) import PyF.Internal.PythonSyntax ( AlternateForm (..), ExprOrValue (..), @@ -131,27 +131,31 @@ padAndFormat (FormatMode padding tf grouping) = case tf of DecimalF s -> var "formatAnyIntegral" `app` ctor "Decimal" `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 HexF alt s -> var "formatAnyIntegral" `app` withAlt alt Hexa `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 OctalF alt s -> var "formatAnyIntegral" `app` withAlt alt Octal `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 - {- - HexCapsF alt s -> [|formatAnyIntegral (Formatters.Upper $(withAlt alt Formatters.Hexa)) s $(newPaddingQ padding) $(toGrp grouping 4)|] - -} + HexCapsF alt s -> var "formatAnyIntegral" `app` (ctor "Upper" `app` (withAlt alt Hexa)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 -- Floating - GeneralF prec alt s -> var "formatAnyFractional" `app` withAlt alt Exponent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - {- - ExponentialCapsF prec alt s -> [|formatAnyFractional (Formatters.Upper $(withAlt alt Formatters.Exponent)) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|] - -} GeneralF prec alt s -> var "formatAnyFractional" `app` withAlt alt Generic `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - {- - GeneralCapsF prec alt s -> [|formatAnyFractional (Formatters.Upper $(withAlt alt Formatters.Generic)) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|] - -} + GeneralCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Generic)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + ExponentialF prec alt s -> var "formatAnyFractional" `app` withAlt alt Exponent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + ExponentialCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Exponent)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec FixedF prec alt s -> var "formatAnyFractional" `app` withAlt alt Fixed `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - {- - FixedCapsF prec alt s -> [|formatAnyFractional (Formatters.Upper $(withAlt alt Formatters.Fixed)) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|] - -} + FixedCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Fixed)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec PercentF prec alt s -> var "formatAnyFractional" `app` withAlt alt Percent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec -- Default / String - DefaultF prec s -> var "formatAny" `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec - StringF prec -> (var ".") `app` (var "formatString" `app` mkPadding padding `app` mkPrecision Nothing prec) `app` (var "pyfToString") - e -> error $ "Not handled: " Prelude.<> show e + DefaultF prec s -> var "formatAny" `app` toSignMode s `app` mkPaddingToPaddingK padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec + StringF prec -> (var ".") `app` (var "formatString" `app` (newPaddingKForString padding) `app` mkPrecision Nothing prec) `app` (var "pyfToString") + +mkPaddingToPaddingK :: Padding -> HsExpr GhcPs +mkPaddingToPaddingK p = case p of + PaddingDefault -> ctor "PaddingDefaultK" + Padding i Nothing -> ctor "PaddingK" `app` exprToInt i `app` ctor "Nothing" + Padding i (Just (c, AnyAlign a)) -> ctor "PaddingK" `app` exprToInt i `app` (ctor "Just" `app` (error "tuple (c, a)")) + + +newPaddingKForString :: Padding -> HsExpr GhcPs +newPaddingKForString padding = case padding of + PaddingDefault -> ctor "Nothing" + Padding i Nothing -> ctor "Just" `app` (error "(fromIntegral i, Formatters.AlignLeft, ' ')") -- default align left and fill with space for string + Padding i (Just (c, AnyAlign a)) -> ctor "Just" `app` (error "(fromIntegral i, a, fromMaybe ' ' mc)") toSignMode :: SignMode -> HsExpr GhcPs toSignMode Plus = ctor "Plus" From 46ade661f2b541a7db8c28b48442df1548cfa7cc Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Sat, 4 Jan 2025 21:40:01 +0400 Subject: [PATCH 06/17] Cleanup and handle the other PyF QQ --- src/PyF/Plugin.hs | 49 +++++++++++++++++++++++++++-------------------- 1 file changed, 28 insertions(+), 21 deletions(-) diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs index 2101ddd..9991e7a 100644 --- a/src/PyF/Plugin.hs +++ b/src/PyF/Plugin.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} module PyF.Plugin (plugin) where @@ -21,8 +22,9 @@ import Data.Generics import Data.Maybe (fromMaybe) import qualified GHC.Types.Name.Occurrence as GHC.Types.Name.Occurence import GHC.Types.SourceText (SourceText (..), mkIntegralLit) -import PyF (Format (..), defaultFloatPrecision, fmtConfig) -import PyF.Formatters (SignMode (..), AnyAlign (..)) +import PyF (Format (..), defaultFloatPrecision, fmtConfig, trimIndent) +import PyF.Formatters (AnyAlign (..), SignMode (..)) +import qualified PyF.Internal.Parser as ParseExp import PyF.Internal.PythonSyntax ( AlternateForm (..), ExprOrValue (..), @@ -37,7 +39,6 @@ import PyF.Internal.PythonSyntax ) import PyF.Internal.QQ (Config (..)) import Text.Parsec (runParserT) -import qualified PyF.Internal.Parser as ParseExp -- | A plugin which replaces all [fmt|...] from PyF by a pure haskell code -- without template haskell. @@ -59,25 +60,32 @@ action parsed@HsParsedModule {hpm_module = m} = replaceSplice :: HsExpr GhcPs -> Hsc (HsExpr GhcPs) replaceSplice e = do case e of - HsUntypedSplice _xsplit (HsQuasiQuote _xquasi (Unqual name) s) - | mkVarOcc "fmt" == name -> do - items <- mapM toString $ pyf (unpackFS $ unLoc s) - pure $ - HsApp - noExtField' - ( L - noSrcSpanA - ( HsVar - NoExtField - ( L noSrcSpanA $ - mkUnqual GHC.Types.Name.Occurence.varName (mkFastString "mconcat") - ) - ) - ) - (L noSrcSpanA $ ExplicitList emptyAnnList $ map (L noSrcSpanA) items) + HsUntypedSplice _xsplit (HsQuasiQuote _xquasi (Unqual name) (unLoc -> s)) + | mkVarOcc "fmt" == name -> applyPyf $ unpackFS s + | mkVarOcc "fmtTrim" == name -> applyPyf (trimIndent $ unpackFS s) + | mkVarOcc "str" == name -> pure $ HsLit noExtField' (HsString NoSourceText s) + | mkVarOcc "strTrim" == name -> pure $ HsLit noExtField' (HsString NoSourceText (mkFastString $ trimIndent $ unpackFS s)) + _ -> do pure e +applyPyf :: String -> Hsc (HsExpr GhcPs) +applyPyf s = do + items <- mapM toString $ pyf s + pure $ + HsApp + noExtField' + ( L + noSrcSpanA + ( HsVar + NoExtField + ( L noSrcSpanA $ + mkUnqual GHC.Types.Name.Occurence.varName (mkFastString "mconcat") + ) + ) + ) + (L noSrcSpanA $ ExplicitList emptyAnnList $ map (L noSrcSpanA) items) + toString :: Item -> Hsc (HsExpr GhcPs) toString (Raw s) = pure $ HsLit noExtField' $ HsString NoSourceText (mkFastString s) toString (Replacement s formatMode) = do @@ -150,7 +158,6 @@ mkPaddingToPaddingK p = case p of Padding i Nothing -> ctor "PaddingK" `app` exprToInt i `app` ctor "Nothing" Padding i (Just (c, AnyAlign a)) -> ctor "PaddingK" `app` exprToInt i `app` (ctor "Just" `app` (error "tuple (c, a)")) - newPaddingKForString :: Padding -> HsExpr GhcPs newPaddingKForString padding = case padding of PaddingDefault -> ctor "Nothing" @@ -182,6 +189,7 @@ mkPrecision _ (Precision p) = ctor "Just" `app` exprToInt p exprToInt :: ExprOrValue Int -> HsExpr GhcPs exprToInt (Value i) = HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) + -- exprToInt (HaskellExpr s) = toHsExpr s toHsExpr :: String -> Hsc (HsExpr GhcPs) @@ -194,7 +202,6 @@ toHsExpr s = do Right res -> pure res Left e -> error $ show e - #if MIN_VERSION_ghc(9,10,0) noExtField' :: NoExtField noExtField' = NoExtField From e9598be9a8a2d4fe2ca625c8cbf5b8ebe3017b81 Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Sat, 4 Jan 2025 21:40:15 +0400 Subject: [PATCH 07/17] DO NOT INTEGRATE: hack to test complete removal of QQ at nova By replacing the remaining QQ we have in the source code of nova in silico, I aim at having faster and more robust HLS. ``` git grep -o -h '\[[a-zA-Z0-9]\+|' **/*.hs | sort | uniq -c | sort -n -k1 2 [strTrim| 6 [fmtTrim| 23 [duration| 51 [aesonQQ| 231 [fmt| ``` --- src/PyF/Plugin.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs index 9991e7a..a69d551 100644 --- a/src/PyF/Plugin.hs +++ b/src/PyF/Plugin.hs @@ -66,6 +66,11 @@ replaceSplice e = do | mkVarOcc "str" == name -> pure $ HsLit noExtField' (HsString NoSourceText s) | mkVarOcc "strTrim" == name -> pure $ HsLit noExtField' (HsString NoSourceText (mkFastString $ trimIndent $ unpackFS s)) + -- Hack for novainsilico + | mkVarOcc "aesonQQ" == name -> pure $ var "undefined" + | mkVarOcc "re" == name -> pure $ var "undefined" + | mkVarOcc "duration" == name -> pure $ var "undefined" + _ -> do pure e From 25ae166f813f3d0e3e44c668b525cf1b290c3b2c Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Sat, 4 Jan 2025 23:23:11 +0400 Subject: [PATCH 08/17] WIP: change the prefix of the pyf elements in TH --- test/golden96/{TrueCLd}.12627313193367841398.golden | 8 ++++---- test/golden96/{TrueCLf}.18281408089045870326.golden | 8 ++++---- test/golden96/{True}.16254223077612353942.golden | 8 ++++---- test/golden96/{helloCL%}.1257653362598537778.golden | 8 ++++---- test/golden96/{helloCL=100}.9444838110946424370.golden | 6 +++--- test/golden96/{helloCLE}.15676531368138664498.golden | 8 ++++---- test/golden96/{helloCLG}.17442699390234010162.golden | 8 ++++---- test/golden96/{helloCLX}.8447528333473699378.golden | 8 ++++---- test/golden96/{helloCLb}.14869862508711808562.golden | 8 ++++---- test/golden96/{helloCLd}.1892681375540151858.golden | 8 ++++---- test/golden96/{helloCLe}.13933826712837941810.golden | 8 ++++---- test/golden96/{helloCLf}.14332487603622862386.golden | 8 ++++---- test/golden96/{helloCLg}.9607247906229690930.golden | 8 ++++---- test/golden96/{helloCLo}.9389880575827657266.golden | 8 ++++---- test/golden96/{helloCLx}.14710080644372944434.golden | 8 ++++---- test/golden96/{numberCLX}.4609648040604121432.golden | 8 ++++---- test/golden96/{numberCLb}.8801685868342243288.golden | 8 ++++---- test/golden96/{numberCLd}.13336740346716692056.golden | 8 ++++---- test/golden96/{numberCLo}.12467189151987896600.golden | 8 ++++---- test/golden96/{numberCLx}.14457861675063419224.golden | 8 ++++---- 20 files changed, 79 insertions(+), 79 deletions(-) diff --git a/test/golden96/{TrueCLd}.12627313193367841398.golden b/test/golden96/{TrueCLd}.12627313193367841398.golden index f354cb7..9a27791 100644 --- a/test/golden96/{TrueCLd}.12627313193367841398.golden +++ b/test/golden96/{TrueCLd}.12627313193367841398.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Integral Bool’ arising from a use of ‘PyF.Internal.QQ.formatAnyIntegral’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Decimal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing True)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Decimal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing True) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Decimal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing True) + • No instance for ‘Integral Bool’ arising from a use of ‘formatAnyIntegral’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyIntegral Decimal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing True)’ + In the expression: putStrLn (formatAnyIntegral Decimal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing True) + In an equation for ‘main’: main = putStrLn (formatAnyIntegral Decimal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing True) | 7 | main = putStrLn [fmt|{True:d}|] | ^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{TrueCLf}.18281408089045870326.golden b/test/golden96/{TrueCLf}.18281408089045870326.golden index bf6f0c9..a60ff2a 100644 --- a/test/golden96/{TrueCLf}.18281408089045870326.golden +++ b/test/golden96/{TrueCLf}.18281408089045870326.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Real Bool’ arising from a use of ‘PyF.Internal.QQ.formatAnyFractional’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Fixed PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) True)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Fixed PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) True) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Fixed PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) True) + • No instance for ‘Real Bool’ arising from a use of ‘formatAnyFractional’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyFractional Fixed Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) True)’ + In the expression: putStrLn (formatAnyFractional Fixed Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) True) + In an equation for ‘main’: main = putStrLn (formatAnyFractional Fixed Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) True) | 7 | main = putStrLn [fmt|{True:f}|] | ^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{True}.16254223077612353942.golden b/test/golden96/{True}.16254223077612353942.golden index 990b9bd..48b320a 100644 --- a/test/golden96/{True}.16254223077612353942.golden +++ b/test/golden96/{True}.16254223077612353942.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘PyF.Internal.QQ.FormatAny2 (PyFClassify Bool) Bool PyF.Formatters.AlignAll’ arising from a use of ‘PyF.Internal.QQ.formatAny’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAny PyF.Formatters.Minus PyF.Internal.QQ.PaddingDefaultK Nothing (Nothing :: Maybe Int) True)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAny PyF.Formatters.Minus PyF.Internal.QQ.PaddingDefaultK Nothing (Nothing :: Maybe Int) True) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAny PyF.Formatters.Minus PyF.Internal.QQ.PaddingDefaultK Nothing (Nothing :: Maybe Int) True) + • No instance for ‘FormatAny2 (PyFClassify Bool) Bool AlignAll’ arising from a use of ‘formatAny’ + • In the first argument of ‘putStrLn’, namely ‘(formatAny Minus PaddingDefaultK Nothing (Nothing :: Maybe Int) True)’ + In the expression: putStrLn (formatAny Minus PaddingDefaultK Nothing (Nothing :: Maybe Int) True) + In an equation for ‘main’: main = putStrLn (formatAny Minus PaddingDefaultK Nothing (Nothing :: Maybe Int) True) | 7 | main = putStrLn [fmt|{True}|] | ^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{helloCL%}.1257653362598537778.golden b/test/golden96/{helloCL%}.1257653362598537778.golden index e28cd7c..3e36c1f 100644 --- a/test/golden96/{helloCL%}.1257653362598537778.golden +++ b/test/golden96/{helloCL%}.1257653362598537778.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Real String’ arising from a use of ‘PyF.Internal.QQ.formatAnyFractional’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Percent PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Percent PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Percent PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) + • No instance for ‘Real String’ arising from a use of ‘formatAnyFractional’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyFractional Percent Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello)’ + In the expression: putStrLn (formatAnyFractional Percent Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) + In an equation for ‘main’: main = putStrLn (formatAnyFractional Percent Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) | 7 | main = putStrLn [fmt|{hello:%}|] | ^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{helloCL=100}.9444838110946424370.golden b/test/golden96/{helloCL=100}.9444838110946424370.golden index 762ab93..0091be1 100644 --- a/test/golden96/{helloCL=100}.9444838110946424370.golden +++ b/test/golden96/{helloCL=100}.9444838110946424370.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-64725] • String type is incompatible with inside padding (=). - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAny PyF.Formatters.Minus (PyF.Internal.QQ.PaddingK (100 :: Int) (Just (Nothing, PyF.Formatters.AlignInside))) Nothing (Nothing :: Maybe Int) hello)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAny PyF.Formatters.Minus (PyF.Internal.QQ.PaddingK (100 :: Int) (Just (Nothing, PyF.Formatters.AlignInside))) Nothing (Nothing :: Maybe Int) hello) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAny PyF.Formatters.Minus (PyF.Internal.QQ.PaddingK (100 :: Int) (Just (Nothing, PyF.Formatters.AlignInside))) Nothing (Nothing :: Maybe Int) hello) + • In the first argument of ‘putStrLn’, namely ‘(formatAny Minus (PaddingK (100 :: Int) (Just (Nothing, AlignInside))) Nothing (Nothing :: Maybe Int) hello)’ + In the expression: putStrLn (formatAny Minus (PaddingK (100 :: Int) (Just (Nothing, AlignInside))) Nothing (Nothing :: Maybe Int) hello) + In an equation for ‘main’: main = putStrLn (formatAny Minus (PaddingK (100 :: Int) (Just (Nothing, AlignInside))) Nothing (Nothing :: Maybe Int) hello) | 7 | main = putStrLn [fmt|{hello:=100}|] | ^^^^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{helloCLE}.15676531368138664498.golden b/test/golden96/{helloCLE}.15676531368138664498.golden index 28b95f7..3b7174e 100644 --- a/test/golden96/{helloCLE}.15676531368138664498.golden +++ b/test/golden96/{helloCLE}.15676531368138664498.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Real String’ arising from a use of ‘PyF.Internal.QQ.formatAnyFractional’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyFractional (PyF.Formatters.Upper PyF.Formatters.Exponent) PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyFractional (PyF.Formatters.Upper PyF.Formatters.Exponent) PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyFractional (PyF.Formatters.Upper PyF.Formatters.Exponent) PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) + • No instance for ‘Real String’ arising from a use of ‘formatAnyFractional’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyFractional (Upper Exponent) Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello)’ + In the expression: putStrLn (formatAnyFractional (Upper Exponent) Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) + In an equation for ‘main’: main = putStrLn (formatAnyFractional (Upper Exponent) Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) | 7 | main = putStrLn [fmt|{hello:E}|] | ^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{helloCLG}.17442699390234010162.golden b/test/golden96/{helloCLG}.17442699390234010162.golden index 492403e..5c87749 100644 --- a/test/golden96/{helloCLG}.17442699390234010162.golden +++ b/test/golden96/{helloCLG}.17442699390234010162.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Real String’ arising from a use of ‘PyF.Internal.QQ.formatAnyFractional’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyFractional (PyF.Formatters.Upper PyF.Formatters.Generic) PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyFractional (PyF.Formatters.Upper PyF.Formatters.Generic) PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyFractional (PyF.Formatters.Upper PyF.Formatters.Generic) PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) + • No instance for ‘Real String’ arising from a use of ‘formatAnyFractional’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyFractional (Upper Generic) Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello)’ + In the expression: putStrLn (formatAnyFractional (Upper Generic) Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) + In an equation for ‘main’: main = putStrLn (formatAnyFractional (Upper Generic) Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) | 7 | main = putStrLn [fmt|{hello:G}|] | ^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{helloCLX}.8447528333473699378.golden b/test/golden96/{helloCLX}.8447528333473699378.golden index 090f12a..d732172 100644 --- a/test/golden96/{helloCLX}.8447528333473699378.golden +++ b/test/golden96/{helloCLX}.8447528333473699378.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Integral String’ arising from a use of ‘PyF.Internal.QQ.formatAnyIntegral’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyIntegral (PyF.Formatters.Upper PyF.Formatters.Hexa) PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyIntegral (PyF.Formatters.Upper PyF.Formatters.Hexa) PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyIntegral (PyF.Formatters.Upper PyF.Formatters.Hexa) PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello) + • No instance for ‘Integral String’ arising from a use of ‘formatAnyIntegral’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyIntegral (Upper Hexa) Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello)’ + In the expression: putStrLn (formatAnyIntegral (Upper Hexa) Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello) + In an equation for ‘main’: main = putStrLn (formatAnyIntegral (Upper Hexa) Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello) | 7 | main = putStrLn [fmt|{hello:X}|] | ^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{helloCLb}.14869862508711808562.golden b/test/golden96/{helloCLb}.14869862508711808562.golden index 6cf3d4a..7ea7ac6 100644 --- a/test/golden96/{helloCLb}.14869862508711808562.golden +++ b/test/golden96/{helloCLb}.14869862508711808562.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Integral String’ arising from a use of ‘PyF.Internal.QQ.formatAnyIntegral’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Binary PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Binary PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Binary PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello) + • No instance for ‘Integral String’ arising from a use of ‘formatAnyIntegral’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyIntegral Binary Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello)’ + In the expression: putStrLn (formatAnyIntegral Binary Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello) + In an equation for ‘main’: main = putStrLn (formatAnyIntegral Binary Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello) | 7 | main = putStrLn [fmt|{hello:b}|] | ^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{helloCLd}.1892681375540151858.golden b/test/golden96/{helloCLd}.1892681375540151858.golden index 0e4c20f..0359f56 100644 --- a/test/golden96/{helloCLd}.1892681375540151858.golden +++ b/test/golden96/{helloCLd}.1892681375540151858.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Integral String’ arising from a use of ‘PyF.Internal.QQ.formatAnyIntegral’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Decimal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Decimal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Decimal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello) + • No instance for ‘Integral String’ arising from a use of ‘formatAnyIntegral’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyIntegral Decimal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello)’ + In the expression: putStrLn (formatAnyIntegral Decimal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello) + In an equation for ‘main’: main = putStrLn (formatAnyIntegral Decimal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello) | 7 | main = putStrLn [fmt|{hello:d}|] | ^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{helloCLe}.13933826712837941810.golden b/test/golden96/{helloCLe}.13933826712837941810.golden index 39231d8..d608b74 100644 --- a/test/golden96/{helloCLe}.13933826712837941810.golden +++ b/test/golden96/{helloCLe}.13933826712837941810.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Real String’ arising from a use of ‘PyF.Internal.QQ.formatAnyFractional’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Exponent PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Exponent PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Exponent PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) + • No instance for ‘Real String’ arising from a use of ‘formatAnyFractional’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyFractional Exponent Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello)’ + In the expression: putStrLn (formatAnyFractional Exponent Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) + In an equation for ‘main’: main = putStrLn (formatAnyFractional Exponent Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) | 7 | main = putStrLn [fmt|{hello:e}|] | ^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{helloCLf}.14332487603622862386.golden b/test/golden96/{helloCLf}.14332487603622862386.golden index 2d8d8da..1bd2f83 100644 --- a/test/golden96/{helloCLf}.14332487603622862386.golden +++ b/test/golden96/{helloCLf}.14332487603622862386.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Real String’ arising from a use of ‘PyF.Internal.QQ.formatAnyFractional’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Fixed PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Fixed PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Fixed PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) + • No instance for ‘Real String’ arising from a use of ‘formatAnyFractional’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyFractional Fixed Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello)’ + In the expression: putStrLn (formatAnyFractional Fixed Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) + In an equation for ‘main’: main = putStrLn (formatAnyFractional Fixed Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) | 7 | main = putStrLn [fmt|{hello:f}|] | ^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{helloCLg}.9607247906229690930.golden b/test/golden96/{helloCLg}.9607247906229690930.golden index 72e0fdf..1c148f6 100644 --- a/test/golden96/{helloCLg}.9607247906229690930.golden +++ b/test/golden96/{helloCLg}.9607247906229690930.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Real String’ arising from a use of ‘PyF.Internal.QQ.formatAnyFractional’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Generic PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Generic PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyFractional PyF.Formatters.Generic PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) + • No instance for ‘Real String’ arising from a use of ‘formatAnyFractional’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyFractional Generic Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello)’ + In the expression: putStrLn (formatAnyFractional Generic Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) + In an equation for ‘main’: main = putStrLn (formatAnyFractional Generic Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing (Just 6 :: Maybe Int) hello) | 7 | main = putStrLn [fmt|{hello:g}|] | ^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{helloCLo}.9389880575827657266.golden b/test/golden96/{helloCLo}.9389880575827657266.golden index 1fe353e..293ca9e 100644 --- a/test/golden96/{helloCLo}.9389880575827657266.golden +++ b/test/golden96/{helloCLo}.9389880575827657266.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Integral String’ arising from a use of ‘PyF.Internal.QQ.formatAnyIntegral’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Octal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Octal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Octal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello) + • No instance for ‘Integral String’ arising from a use of ‘formatAnyIntegral’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyIntegral Octal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello)’ + In the expression: putStrLn (formatAnyIntegral Octal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello) + In an equation for ‘main’: main = putStrLn (formatAnyIntegral Octal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello) | 7 | main = putStrLn [fmt|{hello:o}|] | ^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{helloCLx}.14710080644372944434.golden b/test/golden96/{helloCLx}.14710080644372944434.golden index fa4174a..ca49551 100644 --- a/test/golden96/{helloCLx}.14710080644372944434.golden +++ b/test/golden96/{helloCLx}.14710080644372944434.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Integral String’ arising from a use of ‘PyF.Internal.QQ.formatAnyIntegral’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Hexa PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Hexa PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Hexa PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing hello) + • No instance for ‘Integral String’ arising from a use of ‘formatAnyIntegral’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyIntegral Hexa Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello)’ + In the expression: putStrLn (formatAnyIntegral Hexa Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello) + In an equation for ‘main’: main = putStrLn (formatAnyIntegral Hexa Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing hello) | 7 | main = putStrLn [fmt|{hello:x}|] | ^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{numberCLX}.4609648040604121432.golden b/test/golden96/{numberCLX}.4609648040604121432.golden index 5fac5c0..622b3c9 100644 --- a/test/golden96/{numberCLX}.4609648040604121432.golden +++ b/test/golden96/{numberCLX}.4609648040604121432.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Integral Float’ arising from a use of ‘PyF.Internal.QQ.formatAnyIntegral’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyIntegral (PyF.Formatters.Upper PyF.Formatters.Hexa) PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyIntegral (PyF.Formatters.Upper PyF.Formatters.Hexa) PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyIntegral (PyF.Formatters.Upper PyF.Formatters.Hexa) PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number) + • No instance for ‘Integral Float’ arising from a use of ‘formatAnyIntegral’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyIntegral (Upper Hexa) Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number)’ + In the expression: putStrLn (formatAnyIntegral (Upper Hexa) Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number) + In an equation for ‘main’: main = putStrLn (formatAnyIntegral (Upper Hexa) Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number) | 7 | main = putStrLn [fmt|{number:X}|] | ^^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{numberCLb}.8801685868342243288.golden b/test/golden96/{numberCLb}.8801685868342243288.golden index 0b44bf3..69f028c 100644 --- a/test/golden96/{numberCLb}.8801685868342243288.golden +++ b/test/golden96/{numberCLb}.8801685868342243288.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Integral Float’ arising from a use of ‘PyF.Internal.QQ.formatAnyIntegral’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Binary PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Binary PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Binary PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number) + • No instance for ‘Integral Float’ arising from a use of ‘formatAnyIntegral’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyIntegral Binary Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number)’ + In the expression: putStrLn (formatAnyIntegral Binary Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number) + In an equation for ‘main’: main = putStrLn (formatAnyIntegral Binary Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number) | 7 | main = putStrLn [fmt|{number:b}|] | ^^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{numberCLd}.13336740346716692056.golden b/test/golden96/{numberCLd}.13336740346716692056.golden index 2a8ef51..462b9b8 100644 --- a/test/golden96/{numberCLd}.13336740346716692056.golden +++ b/test/golden96/{numberCLd}.13336740346716692056.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Integral Float’ arising from a use of ‘PyF.Internal.QQ.formatAnyIntegral’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Decimal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Decimal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Decimal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number) + • No instance for ‘Integral Float’ arising from a use of ‘formatAnyIntegral’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyIntegral Decimal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number)’ + In the expression: putStrLn (formatAnyIntegral Decimal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number) + In an equation for ‘main’: main = putStrLn (formatAnyIntegral Decimal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number) | 7 | main = putStrLn [fmt|{number:d}|] | ^^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{numberCLo}.12467189151987896600.golden b/test/golden96/{numberCLo}.12467189151987896600.golden index 50a1d5f..57bd762 100644 --- a/test/golden96/{numberCLo}.12467189151987896600.golden +++ b/test/golden96/{numberCLo}.12467189151987896600.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Integral Float’ arising from a use of ‘PyF.Internal.QQ.formatAnyIntegral’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Octal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Octal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Octal PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number) + • No instance for ‘Integral Float’ arising from a use of ‘formatAnyIntegral’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyIntegral Octal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number)’ + In the expression: putStrLn (formatAnyIntegral Octal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number) + In an equation for ‘main’: main = putStrLn (formatAnyIntegral Octal Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number) | 7 | main = putStrLn [fmt|{number:o}|] | ^^^^^^^^^^^^ \ No newline at end of file diff --git a/test/golden96/{numberCLx}.14457861675063419224.golden b/test/golden96/{numberCLx}.14457861675063419224.golden index 5f2a288..4f58cc9 100644 --- a/test/golden96/{numberCLx}.14457861675063419224.golden +++ b/test/golden96/{numberCLx}.14457861675063419224.golden @@ -1,8 +1,8 @@ INITIALPATH:7:22: error: [GHC-39999] - • No instance for ‘Integral Float’ arising from a use of ‘PyF.Internal.QQ.formatAnyIntegral’ - • In the first argument of ‘putStrLn’, namely ‘(PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Hexa PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number)’ - In the expression: putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Hexa PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number) - In an equation for ‘main’: main = putStrLn (PyF.Internal.QQ.formatAnyIntegral PyF.Formatters.Hexa PyF.Formatters.Minus (Nothing :: Maybe (Int, PyF.Formatters.AnyAlign, Char)) Nothing number) + • No instance for ‘Integral Float’ arising from a use of ‘formatAnyIntegral’ + • In the first argument of ‘putStrLn’, namely ‘(formatAnyIntegral Hexa Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number)’ + In the expression: putStrLn (formatAnyIntegral Hexa Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number) + In an equation for ‘main’: main = putStrLn (formatAnyIntegral Hexa Minus (Nothing :: Maybe (Int, AnyAlign, Char)) Nothing number) | 7 | main = putStrLn [fmt|{number:x}|] | ^^^^^^^^^^^^ \ No newline at end of file From 00eb10143b5e2bbf956750ee54f82b92a836da36 Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Sun, 12 Jan 2025 22:24:56 +0400 Subject: [PATCH 09/17] WIP: fix the offset with current logic --- PyF.cabal | 4 +- src/PyF.hs | 14 ++--- src/PyF/Internal/Parser.hs | 26 +++----- src/PyF/Internal/PythonSyntax.hs | 61 ++++++------------ src/PyF/Internal/QQ.hs | 102 ++++++++++++++++--------------- src/PyF/Plugin.hs | 45 ++++++-------- test/Spec.hs | 2 +- test/SpecPlugin.hs | 3 +- 8 files changed, 108 insertions(+), 149 deletions(-) diff --git a/PyF.cabal b/PyF.cabal index acd906d..d82918d 100644 --- a/PyF.cabal +++ b/PyF.cabal @@ -34,13 +34,13 @@ library build-depends: , base >=4.12 && <4.22 , bytestring >=0.10.8 && <0.13 - , ghc >=8.6.1 && <9.14 + , ghc >=8.6.1 && <9.14 , mtl >=2.2.2 && <2.4 , parsec >=3.1.13 && <3.2 + , syb , template-haskell >=2.14.0 && <2.24 , text >=1.2.3 && <2.2 , time >=1.8.0 && <1.15 - , syb if impl(ghc <9.2.1) build-depends: ghc-boot >=8.6.1 && <9.7 diff --git a/src/PyF.hs b/src/PyF.hs index 2633a0d..47200c0 100644 --- a/src/PyF.hs +++ b/src/PyF.hs @@ -22,12 +22,11 @@ module PyF strConfig, addTrim, addFormatting, - -- This is reexported so plugin can use them once PyF is imported. -- TODO: find a way to HIDE this. Maybe the source plugin can explicitly -- qualified the symbols. module PyF.Formatters, - module PyF.Internal.QQ + module PyF.Internal.QQ, ) where @@ -45,9 +44,9 @@ fmt = mkFormatter "fmt" fmtConfig -- | Format with whitespace trimming. fmtTrim :: QuasiQuoter -fmtTrim = let - qq = mkFormatter "fmtTrim" fmtConfig - in qq { quoteExp = \s -> quoteExp qq (trimIndent s) } +fmtTrim = + let qq = mkFormatter "fmtTrim" fmtConfig + in qq {quoteExp = \s -> quoteExp qq (trimIndent s)} -- | Multiline string, no interpolation. str :: QuasiQuoter @@ -55,8 +54,9 @@ str = mkFormatter "str" strConfig -- | Multiline string, no interpolation, but does indentation trimming. strTrim :: QuasiQuoter -strTrim = let qq = mkFormatter "strTrim" strConfig - in qq { quoteExp = \s -> quoteExp qq (trimIndent s) } +strTrim = + let qq = mkFormatter "strTrim" strConfig + in qq {quoteExp = \s -> quoteExp qq (trimIndent s)} -- | Raw string, neither interpolation nor escaping is performed. raw :: QuasiQuoter diff --git a/src/PyF/Internal/Parser.hs b/src/PyF/Internal/Parser.hs index e5910be..ac98d99 100644 --- a/src/PyF/Internal/Parser.hs +++ b/src/PyF/Internal/Parser.hs @@ -52,7 +52,7 @@ import Outputable (showSDoc) import qualified PyF.Internal.ParserEx as ParseExp -parseExpression :: RealSrcLoc -> String -> DynFlags -> Either (Int, Int, String) (HsExpr GhcPs) +parseExpression :: RealSrcLoc -> String -> DynFlags -> Either (RealSrcLoc, String) (HsExpr GhcPs) parseExpression initLoc s dynFlags = case ParseExp.parseExpression initLoc s dynFlags of POk _ locatedExpr -> @@ -81,9 +81,7 @@ parseExpression initLoc s dynFlags = $ map errMsgDiagnostic $ sortMsgBag Nothing $ getMessages $ errorMessages - line' = SrcLoc.srcLocLine srcLoc - col = SrcLoc.srcLocCol srcLoc - in Left (line', col, err) + in Left (srcLoc, err) #elif MIN_VERSION_ghc(9,6,0) let err = renderWithContext defaultSDocContext @@ -93,9 +91,7 @@ parseExpression initLoc s dynFlags = $ map errMsgDiagnostic $ sortMsgBag Nothing $ getMessages $ errorMessages - line' = SrcLoc.srcLocLine srcLoc - col = SrcLoc.srcLocCol srcLoc - in Left (line', col, err) + in Left (srcLoc, err) #elif MIN_VERSION_ghc(9,3,0) let err = renderWithContext defaultSDocContext @@ -105,29 +101,21 @@ parseExpression initLoc s dynFlags = $ map errMsgDiagnostic $ sortMsgBag Nothing $ getMessages $ errorMessages - line = SrcLoc.srcLocLine srcLoc - col = SrcLoc.srcLocCol srcLoc - in Left (line, col, err) + in Left (srcLoc, err) #elif MIN_VERSION_ghc(9,2,0) let psErrToString e = show $ ParserErrorPpr.pprError e err = concatMap psErrToString errorMessages - line = SrcLoc.srcLocLine srcLoc - col = SrcLoc.srcLocCol srcLoc - in Left (line, col, err) + in Left (srcLoc, err) #elif MIN_VERSION_ghc(8,10,0) let -- TODO: do not ignore "warnMessages" -- I have no idea what they can be (_warnMessages, errorMessages) = msgs dynFlags err = concatMap show errorMessages - line = SrcLoc.srcLocLine srcLoc - col = SrcLoc.srcLocCol srcLoc - in Left (line, col, err) + in Left (srcLoc, err) #else let err = showSDoc dynFlags doc - line = SrcLoc.srcLocLine srcLoc - col = SrcLoc.srcLocCol srcLoc - in Left (line, col, err) + in Left (srcLoc, err) #endif #if MIN_VERSION_ghc(8,10,0) diff --git a/src/PyF/Internal/PythonSyntax.hs b/src/PyF/Internal/PythonSyntax.hs index 9be0c7d..c546e2e 100644 --- a/src/PyF/Internal/PythonSyntax.hs +++ b/src/PyF/Internal/PythonSyntax.hs @@ -25,17 +25,12 @@ module PyF.Internal.PythonSyntax where import Control.Applicative (some) -import Control.Monad (replicateM_, void) +import Control.Monad (void) import Control.Monad.Reader (Reader, asks) import qualified Data.Char import Data.Data (Data) import Data.Maybe (fromMaybe) -import GHC (GhcPs, HsExpr) -import Language.Haskell.TH.LanguageExtensions (Extension (..)) -import Language.Haskell.TH.Syntax (Exp) import PyF.Formatters -import PyF.Internal.Meta -import qualified PyF.Internal.Parser as ParseExp import Text.Parsec #if MIN_VERSION_ghc(9,7,0) @@ -45,8 +40,6 @@ import Text.Parsec #endif #if MIN_VERSION_ghc(9,0,0) -import GHC.Types.SrcLoc -import GHC.Data.FastString #else import SrcLoc import FastString @@ -84,7 +77,7 @@ data Item = -- | A raw string Raw String | -- | A replacement string, composed of an arbitrary Haskell expression followed by an optional formatter - Replacement String (Maybe FormatMode) + Replacement SourcePos String (Maybe FormatMode) -- | -- Parse a string, returns a list of raw string or replacement fields @@ -163,12 +156,13 @@ replacementField :: Parser Item replacementField = do Just (charOpening, charClosing) <- asks delimiters _ <- char charOpening + exprPos <- getPosition expr <- parseExpressionString "an haskell expression" fmt <- optionMaybe $ do _ <- char ':' formatSpec _ <- char charClosing - pure (Replacement expr fmt) + pure (Replacement exprPos expr fmt) -- | Default formatting mode, no padding, default precision, no grouping, no sign handling pattern DefaultFormatMode :: FormatMode @@ -183,9 +177,10 @@ data Padding | Padding (ExprOrValue Int) (Maybe (Maybe Char, AnyAlign)) -- | Represents a value of type @t@ or an Haskell expression supposed to represents that value +-- TODO: why the `t`? data ExprOrValue t = Value t - | HaskellExpr String + | HaskellExpr SourcePos String deriving (Data, Show) -- | Floating point precision @@ -249,34 +244,6 @@ data TypeFormat data AlternateForm = AlternateForm | NormalForm deriving (Show, Data) -evalExpr :: [Extension] -> Parser String -> Parser (HsExpr GhcPs, Exp) -evalExpr exts exprParser = do - exprPos <- getPosition - -- Inject the correct source location in the GHC parser, so it already match - -- the input source file. - let initLoc = mkRealSrcLoc (mkFastString (sourceName exprPos)) (sourceLine exprPos) (sourceColumn exprPos) - s <- lookAhead exprParser - -- Setup the dyn flags using the provided list of extensions - let dynFlags = baseDynFlags exts - case ParseExp.parseExpression initLoc s dynFlags of - Right expr -> do - -- Consume the expression - void exprParser - pure (expr, toExp dynFlags expr) - Left (lineError, colError, err) -> do - -- In case of error, we just advance the parser to the error location. - -- Note: we have to remove what was introduced in `initLoc` - -- Skip lines - replicateM_ (lineError - sourceLine exprPos) (manyTill anyChar newline) - -- Skip columns - -- This is a bit more counter intuitive. If we have skipped not lines, we - -- must remove the introduced column offset, otherwise no. - let columnSkip - | lineError - sourceLine exprPos == 0 = colError - 1 - sourceColumn exprPos - | otherwise = colError - 2 - void $ count columnSkip anyChar - fail $ err <> " in haskell expression" - overrideAlignmentIfZero :: Bool -> Maybe (Maybe Char, AnyAlign) -> Maybe (Maybe Char, AnyAlign) overrideAlignmentIfZero True Nothing = Just (Just '0', AnyAlign AlignInside) overrideAlignmentIfZero True (Just (Nothing, al)) = Just (Just '0', al) @@ -312,7 +279,11 @@ parseWidth = do Just (charOpening, charClosing) <- asks delimiters choice [ Value <$> width, - char charOpening *> (HaskellExpr <$> (someTill (satisfy (/= charClosing)) (char charClosing) "an haskell expression")) + char charOpening + *> ( do + pos <- getPosition + HaskellExpr pos <$> (someTill (satisfy (/= charClosing)) (char charClosing) "an haskell expression") + ) ] parsePrecision :: Parser Precision @@ -321,7 +292,13 @@ parsePrecision = do _ <- char '.' choice [ Precision . Value <$> precision, - char charOpening *> (Precision . HaskellExpr <$> (someTill (satisfy (/= charClosing)) (char charClosing) "an haskell expression")) + char charOpening + *> ( Precision + <$> ( do + pos <- getPosition + HaskellExpr pos <$> someTill (satisfy (/= charClosing)) (char charClosing) "an haskell expression" + ) + ) ] -- | Similar to 'manyTill' but always parse one element. @@ -367,7 +344,7 @@ failIfPrec (Precision e) _ = Left ("Type incompatible with precision (." ++ show where showExpr = case e of Value v -> show v - HaskellExpr s -> s + HaskellExpr _ s -> s failIfAlt :: AlternateForm -> TypeFormat -> Either String TypeFormat failIfAlt NormalForm i = Right i diff --git a/src/PyF/Internal/QQ.hs b/src/PyF/Internal/QQ.hs index a00d92e..01b4a04 100644 --- a/src/PyF/Internal/QQ.hs +++ b/src/PyF/Internal/QQ.hs @@ -28,8 +28,8 @@ import Data.List (intercalate) import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.Proxy import Data.String (fromString) -import PyF.Internal.PythonSyntax import qualified PyF.Internal.Meta +import PyF.Internal.PythonSyntax #if MIN_VERSION_ghc(9,0,0) import GHC.Tc.Utils.Monad (addErrAt) @@ -84,6 +84,8 @@ import SrcLoc import GHC.Hs #endif +import GHC.Data.FastString (mkFastString) +import qualified GHC.Data.Strict import GHC.TypeLits import Language.Haskell.TH hiding (Type) import Language.Haskell.TH.Quote @@ -91,7 +93,8 @@ import Language.Haskell.TH.Syntax (Q (Q)) import PyF.Class import PyF.Formatters (AnyAlign (..)) import qualified PyF.Formatters as Formatters -import PyF.Internal.Meta (toName, baseDynFlags) +import PyF.Internal.Meta (baseDynFlags, toName) +import qualified PyF.Internal.Parser as ParseExp import Text.Parsec import Text.Parsec.Error ( errorMessages, @@ -101,8 +104,6 @@ import Text.Parsec.Error import Text.Parsec.Pos (initialPos) import Text.ParserCombinators.Parsec.Error (Message (..)) import Unsafe.Coerce (unsafeCoerce) -import GHC.Data.FastString (mkFastString) -import qualified PyF.Internal.Parser as ParseExp -- | Configuration for the quasiquoter data Config = Config @@ -154,48 +155,48 @@ toExp Config {delimiters = expressionDelimiters, postProcess} s = do -- executed anyway, there is an error [|()|] Right items -> do - checkResult <- checkVariables items - case checkResult of - Nothing -> postProcess (goFormat items) - Just (srcSpan, msg) -> do - reportErrorAt srcSpan msg + result <- goFormat items + case result of + Just exp -> postProcess (pure exp) + Nothing -> do + -- goFormat took care of emiting the error messages [|()|] -findFreeVariablesInFormatMode :: Maybe FormatMode -> [(SrcSpan, RdrName)] -findFreeVariablesInFormatMode Nothing = [] -findFreeVariablesInFormatMode (Just (FormatMode padding tf _)) = - findFreeVariables tf <> case padding of - PaddingDefault -> [] - Padding eoi _ -> findFreeVariables eoi - -toHsExpr :: String -> Q (HsExpr GhcPs) -toHsExpr s = do +toHsExpr :: SourcePos -> String -> Q (Maybe (HsExpr GhcPs)) +toHsExpr sourcePos s = do exts <- extsEnabled let dynFlags = baseDynFlags exts - -- TODO - let initLoc = mkRealSrcLoc (mkFastString "file") 10 10 - case ParseExp.parseExpression initLoc s dynFlags of - Right res -> pure res - Left e -> error $ show e + let srcLoc = mkRealSrcLoc (mkFastString (sourceName sourcePos)) (sourceLine sourcePos) (sourceColumn sourcePos) + case ParseExp.parseExpression srcLoc s dynFlags of + Right hsExpr -> do + check <- checkVariables hsExpr + case check of + Right hsExpr' -> pure $ Just hsExpr' + Left (span, err) -> do + reportErrorAt span err + pure Nothing + Left (srcLocError', msg) -> do + -- I have no idea what is happening here, but the srcLocError is off by 1 column + let srcLocError = mkRealSrcLoc (mkFastString (sourceName sourcePos)) (srcLocLine srcLocError' + 0) (srcLocCol srcLocError' - 1) + reportErrorAt (srcLocSpan (RealSrcLoc srcLocError GHC.Data.Strict.Nothing)) (msg ++ " in haskell expression") + pure Nothing hsExprToTh :: HsExpr GhcPs -> Q Exp hsExprToTh e = do exts <- extsEnabled let dynFlags = baseDynFlags exts - pure $ PyF.Internal.Meta.toExp dynFlags e + pure $ PyF.Internal.Meta.toExp dynFlags e -checkOneItem :: Item -> Q (Maybe (SrcSpan, String)) -checkOneItem (Raw _) = pure Nothing -checkOneItem (Replacement s formatMode) = do - hsExpr <- toHsExpr s - let allNames = findFreeVariables hsExpr <> findFreeVariablesInFormatMode formatMode +checkVariables :: HsExpr GhcPs -> Q (Either (SrcSpan, String) (HsExpr GhcPs)) +checkVariables hsExpr = do + let allNames = findFreeVariables hsExpr res <- mapM doesExists allNames let resFinal = catMaybes res case resFinal of - [] -> pure Nothing - ((err, span) : _) -> pure $ Just (span, err) + [] -> pure $ Right hsExpr + ((err, span) : _) -> pure $ Left (span, err) {- ORMOLU_DISABLE -} findFreeVariables :: Data a => a -> [(SrcSpan, RdrName)] @@ -264,15 +265,6 @@ doesExists (loc, name) = do then pure Nothing else pure (Just ("Variable not in scope: " <> show (toName name), loc)) --- | Check that all variables used in 'Item' exists, otherwise, fail. -checkVariables :: [Item] -> Q (Maybe (SrcSpan, String)) -checkVariables [] = pure Nothing -checkVariables (x : xs) = do - r <- checkOneItem x - case r of - Nothing -> checkVariables 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, @@ -336,10 +328,12 @@ Note: Empty String Lifting Empty string are lifted as [] instead of "", so I'm using LitE (String L) instead -} -goFormat :: [Item] -> Q Exp +goFormat :: [Item] -> Q (Maybe Exp) -- We special case on empty list in order to generate an empty string -goFormat [] = pure $ LitE (StringL "") -- see [Empty String Lifting] -goFormat items = foldl1 sappendQ <$> mapM toFormat items +goFormat [] = pure $ Just $ LitE (StringL "") -- see [Empty String Lifting] +goFormat items = do + exprs <- mapM toFormat items + pure $ (foldl1 sappendQ <$> (sequenceA exprs)) -- | call `<>` between two 'Exp' sappendQ :: Exp -> Exp -> Exp @@ -347,12 +341,16 @@ sappendQ s0 s1 = InfixE (Just s0) (VarE '(<>)) (Just s1) -- Real formatting is here -toFormat :: Item -> Q Exp -toFormat (Raw x) = pure $ LitE (StringL x) -- see [Empty String Lifting] -toFormat (Replacement s y) = do - expr <- toHsExpr s >>= hsExprToTh - formatExpr <- padAndFormat (fromMaybe DefaultFormatMode y) - pure (formatExpr `AppE` expr) +toFormat :: Item -> Q (Maybe Exp) +toFormat (Raw x) = pure $ Just $ LitE (StringL x) -- see [Empty String Lifting] +toFormat (Replacement loc s y) = do + exprM <- toHsExpr loc s + case exprM of + Nothing -> pure Nothing + Just expr -> do + thExpr <- hsExprToTh expr + formatExpr <- padAndFormat (fromMaybe DefaultFormatMode y) + pure (Just $ formatExpr `AppE` thExpr) -- | Default precision for floating point defaultFloatPrecision :: Maybe Int @@ -404,7 +402,11 @@ newPaddingQ padding = case padding of exprToInt :: ExprOrValue Int -> Q Exp -- Note: this is a literal provided integral. We use explicit case to ::Int so it won't warn about defaulting exprToInt (Value i) = [|$(pure $ LitE (IntegerL (fromIntegral i))) :: Int|] -exprToInt (HaskellExpr e) = toHsExpr e >>= hsExprToTh +exprToInt (HaskellExpr srcLoc e) = do + exprM <- toHsExpr srcLoc e + case exprM of + Nothing -> [|()|] + Just e -> hsExprToTh e data PaddingK k i where PaddingDefaultK :: PaddingK 'Formatters.AlignAll Int diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs index a69d551..d391d07 100644 --- a/src/PyF/Plugin.hs +++ b/src/PyF/Plugin.hs @@ -38,7 +38,9 @@ import PyF.Internal.PythonSyntax pattern DefaultFormatMode, ) import PyF.Internal.QQ (Config (..)) -import Text.Parsec (runParserT) +import Text.Parsec (SourcePos, runParserT, setSourceLine) +import Text.Parsec.Pos +import Text.Parsec.Prim (setPosition) -- | A plugin which replaces all [fmt|...] from PyF by a pure haskell code -- without template haskell. @@ -60,23 +62,17 @@ action parsed@HsParsedModule {hpm_module = m} = replaceSplice :: HsExpr GhcPs -> Hsc (HsExpr GhcPs) replaceSplice e = do case e of - HsUntypedSplice _xsplit (HsQuasiQuote _xquasi (Unqual name) (unLoc -> s)) - | mkVarOcc "fmt" == name -> applyPyf $ unpackFS s - | mkVarOcc "fmtTrim" == name -> applyPyf (trimIndent $ unpackFS s) + HsUntypedSplice _xsplit (HsQuasiQuote _xquasi (Unqual name) (L loc s)) + | mkVarOcc "fmt" == name -> applyPyf loc $ unpackFS s + | mkVarOcc "fmtTrim" == name -> applyPyf loc (trimIndent $ unpackFS s) | mkVarOcc "str" == name -> pure $ HsLit noExtField' (HsString NoSourceText s) | mkVarOcc "strTrim" == name -> pure $ HsLit noExtField' (HsString NoSourceText (mkFastString $ trimIndent $ unpackFS s)) - - -- Hack for novainsilico - | mkVarOcc "aesonQQ" == name -> pure $ var "undefined" - | mkVarOcc "re" == name -> pure $ var "undefined" - | mkVarOcc "duration" == name -> pure $ var "undefined" - _ -> do pure e -applyPyf :: String -> Hsc (HsExpr GhcPs) -applyPyf s = do - items <- mapM toString $ pyf s +applyPyf :: SrcAnn NoEpAnns -> String -> Hsc (HsExpr GhcPs) +applyPyf loc s = do + items <- mapM toString $ pyf loc s pure $ HsApp noExtField' @@ -93,27 +89,22 @@ applyPyf s = do toString :: Item -> Hsc (HsExpr GhcPs) toString (Raw s) = pure $ HsLit noExtField' $ HsString NoSourceText (mkFastString s) -toString (Replacement s formatMode) = do - expr <- toHsExpr s +toString (Replacement loc s formatMode) = do + expr <- toHsExpr loc s let formatExpr = padAndFormat (fromMaybe DefaultFormatMode formatMode) pure $ app formatExpr expr -pyf :: String -> [Item] -pyf s = case runReader (runParserT (parseGenericFormatString) () filename s) context of +pyf :: SrcAnn NoEpAnns -> String -> [Item] +pyf (SrcSpanAnn _ srcSpan) s = case runReader (runParserT (setPosition initPos >> parseGenericFormatString) () filename s) context of Right r -> r Left e -> error $ show e where - filename = "TODO" + filename = unpackFS $ srcLocFile start Config {..} = fmtConfig context = ParsingContext {..} --- TODO: --- - missing fileposition for correct error reporting --- - Maybe we can leverage the current "Hsc" in order to parser the internal values? --- - correct filename during parsing --- - todo: list the extensions (maybe not useful, if we leverage the --- current Hsc for parsing) --- + initPos = setSourceColumn (setSourceLine (initialPos filename) (srcLocLine start)) (srcLocCol start) + RealSrcLoc start _ = srcSpanStart srcSpan app :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs app a b = HsApp noExtField' (L noSrcSpanA a) (L noSrcSpanA b) @@ -197,8 +188,8 @@ exprToInt (Value i) = HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) -- exprToInt (HaskellExpr s) = toHsExpr s -toHsExpr :: String -> Hsc (HsExpr GhcPs) -toHsExpr s = do +toHsExpr :: SourcePos -> String -> Hsc (HsExpr GhcPs) +toHsExpr loc s = do dynFlags <- getDynFlags -- TODO let initLoc = mkRealSrcLoc (mkFastString "file") 10 10 diff --git a/test/Spec.hs b/test/Spec.hs index 2b3dff0..49314b1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -493,7 +493,7 @@ yeah\ [fmtTrim| Cannot convert formula 2.0 * exponent(unit=s, value=1.0) which has unit dimensionless to\ unit dimensionless for they have different dimensions|] - `shouldBe` "Cannot convert formula 2.0 * exponent(unit=s, value=1.0) which has unit dimensionless to unit dimensionless for they have different dimensions" + `shouldBe` "Cannot convert formula 2.0 * exponent(unit=s, value=1.0) which has unit dimensionless to unit dimensionless for they have different dimensions" describe "raw" $ do it "does not escape anything" $ [raw|hello diff --git a/test/SpecPlugin.hs b/test/SpecPlugin.hs index a4215c7..c7bc34f 100644 --- a/test/SpecPlugin.hs +++ b/test/SpecPlugin.hs @@ -1,8 +1,9 @@ {-# OPTIONS -fplugin=PyF.Plugin #-} {-# LANGUAGE QuasiQuotes #-} + module Main where + import PyF main = do putStrLn [fmt|Hello world! {(1 :: Int) + 1:s} is a nice value.|] - From 1be252413e7daf707d7d868784c2f4fc1c8b4a5a Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Mon, 13 Jan 2025 09:46:05 +0400 Subject: [PATCH 10/17] Gros WIP du plugin --- PyF.cabal | 1 + src/PyF/Plugin.hs | 113 +++++++++++++++++++++++++++-------- test/Spec.hs | 3 +- test/SpecCustomDelimiters.hs | 1 - 4 files changed, 90 insertions(+), 28 deletions(-) diff --git a/PyF.cabal b/PyF.cabal index d82918d..552de6b 100644 --- a/PyF.cabal +++ b/PyF.cabal @@ -35,6 +35,7 @@ library , base >=4.12 && <4.22 , bytestring >=0.10.8 && <0.13 , ghc >=8.6.1 && <9.14 + , ghc-boot >=8.6.1 && <9.14 , mtl >=2.2.2 && <2.4 , parsec >=3.1.13 && <3.2 , syb diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs index d391d07..e9db933 100644 --- a/src/PyF/Plugin.hs +++ b/src/PyF/Plugin.hs @@ -1,11 +1,15 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module PyF.Plugin (plugin) where import Data.Data +import qualified GHC.LanguageExtensions as LangExt -- import Data.Generics @@ -22,8 +26,8 @@ import Data.Generics import Data.Maybe (fromMaybe) import qualified GHC.Types.Name.Occurrence as GHC.Types.Name.Occurence import GHC.Types.SourceText (SourceText (..), mkIntegralLit) -import PyF (Format (..), defaultFloatPrecision, fmtConfig, trimIndent) -import PyF.Formatters (AnyAlign (..), SignMode (..)) +import PyF (defaultFloatPrecision, fmtConfig, trimIndent) +import PyF.Formatters import qualified PyF.Internal.Parser as ParseExp import PyF.Internal.PythonSyntax ( AlternateForm (..), @@ -38,7 +42,7 @@ import PyF.Internal.PythonSyntax pattern DefaultFormatMode, ) import PyF.Internal.QQ (Config (..)) -import Text.Parsec (SourcePos, runParserT, setSourceLine) +import Text.Parsec (runParserT) import Text.Parsec.Pos import Text.Parsec.Prim (setPosition) @@ -73,19 +77,24 @@ replaceSplice e = do applyPyf :: SrcAnn NoEpAnns -> String -> Hsc (HsExpr GhcPs) applyPyf loc s = do items <- mapM toString $ pyf loc s + dynFlags <- getDynFlags + let toOverloaded + | xopt LangExt.OverloadedStrings dynFlags = app (var "fromString") + | otherwise = id pure $ - HsApp - noExtField' - ( L - noSrcSpanA - ( HsVar - NoExtField - ( L noSrcSpanA $ - mkUnqual GHC.Types.Name.Occurence.varName (mkFastString "mconcat") - ) - ) - ) - (L noSrcSpanA $ ExplicitList emptyAnnList $ map (L noSrcSpanA) items) + toOverloaded $ + HsApp + noExtField' + ( L + noSrcSpanA + ( HsVar + NoExtField + ( L noSrcSpanA $ + mkUnqual GHC.Types.Name.Occurence.varName (mkFastString "mconcat") + ) + ) + ) + (L noSrcSpanA $ ExplicitList emptyAnnList $ map (L noSrcSpanA) items) toString :: Item -> Hsc (HsExpr GhcPs) toString (Raw s) = pure $ HsLit noExtField' $ HsString NoSourceText (mkFastString s) @@ -106,6 +115,12 @@ pyf (SrcSpanAnn _ srcSpan) s = case runReader (runParserT (setPosition initPos > initPos = setSourceColumn (setSourceLine (initialPos filename) (srcLocLine start)) (srcLocCol start) RealSrcLoc start _ = srcSpanStart srcSpan +appType :: HsExpr GhcPs -> String -> HsExpr GhcPs +appType a name = HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) (HsWC NoExtField (L noSrcSpanA (HsTyVar noExtField' NotPromoted (L noSrcSpanA (mkUnqual dataName (mkFastString name)))))) + +appType' :: HsExpr GhcPs -> String -> HsExpr GhcPs +appType' a name = HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) (HsWC NoExtField (L noSrcSpanA (HsTyVar noExtField' NotPromoted (L noSrcSpanA (mkUnqual tcName (mkFastString name)))))) + app :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs app a b = HsApp noExtField' (L noSrcSpanA a) (L noSrcSpanA b) @@ -151,14 +166,54 @@ padAndFormat (FormatMode padding tf grouping) = case tf of mkPaddingToPaddingK :: Padding -> HsExpr GhcPs mkPaddingToPaddingK p = case p of PaddingDefault -> ctor "PaddingDefaultK" - Padding i Nothing -> ctor "PaddingK" `app` exprToInt i `app` ctor "Nothing" - Padding i (Just (c, AnyAlign a)) -> ctor "PaddingK" `app` exprToInt i `app` (ctor "Just" `app` (error "tuple (c, a)")) + Padding i Nothing -> appType (appType' (ctor "PaddingK") "Int") "AlignAll" `app` exprToInt i `app` ctor "Nothing" + Padding i (Just (c, AnyAlign a)) -> ctor "PaddingK" `app` exprToInt i `app` (liftHsExpr (Just (c, a))) + +class LiftHsExpr a where + liftHsExpr :: a -> HsExpr GhcPs + +instance (LiftHsExpr a, LiftHsExpr b) => LiftHsExpr (a, b) where + liftHsExpr (a, b) = mkTup [liftHsExpr a, liftHsExpr b] + +instance (LiftHsExpr a, LiftHsExpr b, LiftHsExpr c) => LiftHsExpr (a, b, c) where + liftHsExpr (a, b, c) = mkTup [liftHsExpr a, liftHsExpr b, liftHsExpr c] + +instance (LiftHsExpr a) => LiftHsExpr (Maybe a) where + liftHsExpr Nothing = ctor "Nothing" + liftHsExpr (Just v) = ctor "Just" `app` liftHsExpr v + +instance LiftHsExpr (AlignMode k) where + liftHsExpr v = ctor (show v) + +instance LiftHsExpr Char where + liftHsExpr c = HsLit noExtField' (HsChar NoSourceText c) + +instance LiftHsExpr Int where + liftHsExpr i = HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) + +instance LiftHsExpr (Format k k' k'') where + liftHsExpr (Alternate v) = ctor "Alternate" `app` liftHsExpr v + liftHsExpr (Upper v) = ctor "Upper" `app` liftHsExpr v + liftHsExpr v = ctor (show v) + +instance LiftHsExpr AnyAlign where + liftHsExpr (AnyAlign v) = ctor "AnyAlign" `app` liftHsExpr v + +mkTup :: [HsExpr GhcPs] -> HsExpr GhcPs +mkTup l = + ExplicitTuple + noExtField' + ( map + (\x -> Present noExtField' (L noSrcSpanA x)) + l + ) + Boxed newPaddingKForString :: Padding -> HsExpr GhcPs newPaddingKForString padding = case padding of PaddingDefault -> ctor "Nothing" - Padding i Nothing -> ctor "Just" `app` (error "(fromIntegral i, Formatters.AlignLeft, ' ')") -- default align left and fill with space for string - Padding i (Just (c, AnyAlign a)) -> ctor "Just" `app` (error "(fromIntegral i, a, fromMaybe ' ' mc)") + Padding i Nothing -> ctor "Just" `app` (mkTup [exprToInt i, liftHsExpr AlignLeft, liftHsExpr ' ']) -- default align left and fill with space for string + Padding i (Just (mc, AnyAlign a)) -> ctor "Just" `app` mkTup [exprToInt i, liftHsExpr a, liftHsExpr $ fromMaybe ' ' mc] toSignMode :: SignMode -> HsExpr GhcPs toSignMode Plus = ctor "Plus" @@ -167,16 +222,21 @@ toSignMode Space = ctor "Space" toGrp :: Maybe Char -> Int -> HsExpr GhcPs toGrp Nothing _ = ctor "Nothing" +toGrp (Just v) a = liftHsExpr $ Just grp + where + grp = (a, v) -withAlt :: AlternateForm -> Format a b c -> HsExpr GhcPs -withAlt NormalForm formatter = var $ show formatter - --- toGrp (Just v) a = ctor "Just" `app` (error "not done to grp") --- where --- grp = (a,v) +withAlt :: AlternateForm -> Format 'CanAlt b c -> HsExpr GhcPs +withAlt NormalForm e = liftHsExpr e +withAlt AlternateForm e = liftHsExpr (Alternate e) mkPadding :: Padding -> HsExpr GhcPs -mkPadding PaddingDefault = ctor "Nothing" +mkPadding padding = case padding of + PaddingDefault -> ctor "Nothing" -- :: Maybe (Int, AnyAlign, Char)|] + (Padding i al) -> case al of + Nothing -> ctor "Just" `app` mkTup [exprToInt i, liftHsExpr $ AnyAlign AlignRight, liftHsExpr ' '] -- Right align and space is default for any object, except string + Just (Nothing, a) -> ctor "Just" `app` mkTup [exprToInt i, liftHsExpr a, liftHsExpr ' '] + Just (Just c, a) -> ctor "Just" `app` mkTup [exprToInt i, liftHsExpr a, liftHsExpr c] mkPrecision :: Maybe Int -> Precision -> HsExpr GhcPs mkPrecision Nothing PrecisionDefault = ctor "Nothing" @@ -185,6 +245,7 @@ mkPrecision _ (Precision p) = ctor "Just" `app` exprToInt p exprToInt :: ExprOrValue Int -> HsExpr GhcPs exprToInt (Value i) = HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) +exprToInt e = HsLit noExtField' $ HsInt NoExtField (mkIntegralLit 123) -- exprToInt (HaskellExpr s) = toHsExpr s diff --git a/test/Spec.hs b/test/Spec.hs index 49314b1..8ed149a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -17,7 +17,7 @@ {-# LANGUAGE TypeOperators #-} -- This warning is disabled because any expression with literal leads to it. -{-# OPTIONS -Wno-type-defaults #-} +{-# OPTIONS -Wno-type-defaults -fplugin=PyF.Plugin#-} import qualified Data.ByteString import qualified Data.ByteString.Char8 @@ -26,6 +26,7 @@ import qualified Data.ByteString.Lazy.Char8 import qualified Data.List as List import Data.Proxy (Proxy (..)) import qualified Data.Ratio +import Data.String import qualified Data.Text import qualified Data.Text as Text import qualified Data.Text.Lazy diff --git a/test/SpecCustomDelimiters.hs b/test/SpecCustomDelimiters.hs index bf9d693..b0b6d36 100644 --- a/test/SpecCustomDelimiters.hs +++ b/test/SpecCustomDelimiters.hs @@ -2,7 +2,6 @@ module SpecCustomDelimiters where import Language.Haskell.TH.Quote import PyF -import PyF.Internal.QQ myCustomFormatter :: QuasiQuoter myCustomFormatter = From 56267b6d36f413aed491ee22788b20e57c6cf775 Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Mon, 13 Jan 2025 10:43:06 +0400 Subject: [PATCH 11/17] Handling close to everything! --- src/PyF/Internal/PythonSyntax.hs | 50 ++++++---- src/PyF/Plugin.hs | 157 ++++++++++++++++++++++--------- 2 files changed, 141 insertions(+), 66 deletions(-) diff --git a/src/PyF/Internal/PythonSyntax.hs b/src/PyF/Internal/PythonSyntax.hs index c546e2e..afcab8d 100644 --- a/src/PyF/Internal/PythonSyntax.hs +++ b/src/PyF/Internal/PythonSyntax.hs @@ -12,10 +12,14 @@ module PyF.Internal.PythonSyntax ( parseGenericFormatString, Item (..), - FormatMode (..), - Padding (..), - Precision (..), - TypeFormat (..), + FormatMode, + FormatModeT (..), + Padding, + PaddingT (..), + Precision, + PrecisionT (..), + TypeFormat, + TypeFormatT (..), AlternateForm (..), pattern DefaultFormatMode, Parser, @@ -169,12 +173,16 @@ pattern DefaultFormatMode :: FormatMode pattern DefaultFormatMode = FormatMode PaddingDefault (DefaultF PrecisionDefault Minus) Nothing -- | A Formatter, listing padding, format and and grouping char -data FormatMode = FormatMode Padding TypeFormat (Maybe Char) +data FormatModeT t = FormatMode (PaddingT t) (TypeFormatT t) (Maybe Char) + +type FormatMode = FormatModeT (ExprOrValue Int) -- | Padding, containing the padding width, the padding char and the alignement mode -data Padding +data PaddingT t = PaddingDefault - | Padding (ExprOrValue Int) (Maybe (Maybe Char, AnyAlign)) + | Padding t (Maybe (Maybe Char, AnyAlign)) + +type Padding = PaddingT (ExprOrValue Int) -- | Represents a value of type @t@ or an Haskell expression supposed to represents that value -- TODO: why the `t`? @@ -184,11 +192,13 @@ data ExprOrValue t deriving (Data, Show) -- | Floating point precision -data Precision +data PrecisionT t = PrecisionDefault - | Precision (ExprOrValue Int) + | Precision t deriving (Data, Show) +type Precision = PrecisionT (ExprOrValue Int) + {- Python format mini language @@ -206,10 +216,12 @@ type ::= "b" | "c" | "d" | "e" | "E" | "f" | "F" | "g" | "G" | "n" | data TypeFlag = Flagb | Flagc | Flagd | Flage | FlagE | Flagf | FlagF | Flagg | FlagG | Flagn | Flago | Flags | Flagx | FlagX | FlagPercent deriving (Show) +type TypeFormat = TypeFormatT (ExprOrValue Int) + -- | All formatting type -data TypeFormat +data TypeFormatT t = -- | Default, depends on the infered type of the expression - DefaultF Precision SignMode + DefaultF (PrecisionT t) SignMode | -- | Binary, such as `0b0121` BinaryF AlternateForm SignMode | -- | Character, will convert an integer to its character representation @@ -217,27 +229,27 @@ data TypeFormat | -- | Decimal, base 10 integer formatting DecimalF SignMode | -- | Exponential notation for floatting points - ExponentialF Precision AlternateForm SignMode + ExponentialF (PrecisionT t) AlternateForm SignMode | -- | Exponential notation with capitalised @e@ - ExponentialCapsF Precision AlternateForm SignMode + ExponentialCapsF (PrecisionT t) AlternateForm SignMode | -- | Fixed number of digits floating point - FixedF Precision AlternateForm SignMode + FixedF (PrecisionT t) AlternateForm SignMode | -- | Capitalized version of the previous - FixedCapsF Precision AlternateForm SignMode + FixedCapsF (PrecisionT t) AlternateForm SignMode | -- | General formatting: `FixedF` or `ExponentialF` depending on the number magnitude - GeneralF Precision AlternateForm SignMode + GeneralF (PrecisionT t) AlternateForm SignMode | -- | Same as `GeneralF` but with upper case @E@ and infinite / NaN - GeneralCapsF Precision AlternateForm SignMode + GeneralCapsF (PrecisionT t) AlternateForm SignMode | -- | Octal, such as 00245 OctalF AlternateForm SignMode | -- | Simple string - StringF Precision + StringF (PrecisionT t) | -- | Hexadecimal, such as 0xaf3e HexF AlternateForm SignMode | -- | Hexadecimal with capitalized letters, such as 0XAF3E HexCapsF AlternateForm SignMode | -- | Percent representation - PercentF Precision AlternateForm SignMode + PercentF (PrecisionT t) AlternateForm SignMode deriving (Data, Show) -- | If the formatter use its alternate form diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs index e9db933..361ea00 100644 --- a/src/PyF/Plugin.hs +++ b/src/PyF/Plugin.hs @@ -1,7 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -32,12 +35,12 @@ import qualified PyF.Internal.Parser as ParseExp import PyF.Internal.PythonSyntax ( AlternateForm (..), ExprOrValue (..), - FormatMode (..), + FormatModeT (..), Item (..), - Padding (..), + PaddingT (..), ParsingContext (..), - Precision (..), - TypeFormat (..), + PrecisionT (..), + TypeFormatT (..), parseGenericFormatString, pattern DefaultFormatMode, ) @@ -100,7 +103,7 @@ toString :: Item -> Hsc (HsExpr GhcPs) toString (Raw s) = pure $ HsLit noExtField' $ HsString NoSourceText (mkFastString s) toString (Replacement loc s formatMode) = do expr <- toHsExpr loc s - let formatExpr = padAndFormat (fromMaybe DefaultFormatMode formatMode) + formatExpr <- padAndFormat (fromMaybe DefaultFormatMode formatMode) pure $ app formatExpr expr pyf :: SrcAnn NoEpAnns -> String -> [Item] @@ -142,32 +145,104 @@ ctor name = ) ) -padAndFormat :: FormatMode -> HsExpr GhcPs -padAndFormat (FormatMode padding tf grouping) = case tf of +padAndFormat :: FormatModeT (ExprOrValue Int) -> Hsc (HsExpr GhcPs) +padAndFormat formatMode' = do + (FormatMode padding tf grouping) <- evalSubExpression formatMode' + pure $ case tf of + -- Integrals + BinaryF alt s -> var "formatAnyIntegral" `app` withAlt alt Binary `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + CharacterF -> var "formatAnyIntegral" `app` ctor "Character" `app` ctor "Minus" `app` mkPadding padding `app` ctor "Nothing" + DecimalF s -> var "formatAnyIntegral" `app` ctor "Decimal" `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 + HexF alt s -> var "formatAnyIntegral" `app` withAlt alt Hexa `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + OctalF alt s -> var "formatAnyIntegral" `app` withAlt alt Octal `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + HexCapsF alt s -> var "formatAnyIntegral" `app` (ctor "Upper" `app` (withAlt alt Hexa)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + -- Floating + GeneralF prec alt s -> var "formatAnyFractional" `app` withAlt alt Generic `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + GeneralCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Generic)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + ExponentialF prec alt s -> var "formatAnyFractional" `app` withAlt alt Exponent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + ExponentialCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Exponent)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + FixedF prec alt s -> var "formatAnyFractional" `app` withAlt alt Fixed `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + FixedCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Fixed)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + PercentF prec alt s -> var "formatAnyFractional" `app` withAlt alt Percent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + -- Default / String + DefaultF prec s -> var "formatAny" `app` toSignMode s `app` mkPaddingToPaddingK padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec + StringF prec -> (var ".") `app` (var "formatString" `app` (newPaddingKForString padding) `app` mkPrecision Nothing prec) `app` (var "pyfToString") + +evalSubExpression :: FormatModeT (ExprOrValue Int) -> Hsc (FormatModeT (HsExpr GhcPs)) +evalSubExpression (FormatMode padding tf grouping) = do + padding' <- evalPadding padding + tf' <- evalTf tf + pure $ FormatMode padding' tf' grouping + +evalTf :: TypeFormatT (ExprOrValue Int) -> Hsc (TypeFormatT (HsExpr GhcPs)) +evalTf tf = case tf of -- Integrals - BinaryF alt s -> var "formatAnyIntegral" `app` withAlt alt Binary `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 - CharacterF -> var "formatAnyIntegral" `app` ctor "Character" `app` ctor "Minus" `app` mkPadding padding `app` ctor "Nothing" - DecimalF s -> var "formatAnyIntegral" `app` ctor "Decimal" `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 - HexF alt s -> var "formatAnyIntegral" `app` withAlt alt Hexa `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 - OctalF alt s -> var "formatAnyIntegral" `app` withAlt alt Octal `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 - HexCapsF alt s -> var "formatAnyIntegral" `app` (ctor "Upper" `app` (withAlt alt Hexa)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + BinaryF alt s -> pure $ BinaryF alt s + CharacterF -> pure $ CharacterF + DecimalF s -> pure $ DecimalF s + HexF alt s -> pure $ HexF alt s + OctalF alt s -> pure $ OctalF alt s + HexCapsF alt s -> pure $ HexCapsF alt s -- Floating - GeneralF prec alt s -> var "formatAnyFractional" `app` withAlt alt Generic `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - GeneralCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Generic)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - ExponentialF prec alt s -> var "formatAnyFractional" `app` withAlt alt Exponent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - ExponentialCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Exponent)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - FixedF prec alt s -> var "formatAnyFractional" `app` withAlt alt Fixed `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - FixedCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Fixed)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - PercentF prec alt s -> var "formatAnyFractional" `app` withAlt alt Percent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + GeneralF prec alt s -> do + prec' <- evalPrecision prec + pure $ GeneralF prec' alt s + GeneralCapsF prec alt s -> do + prec' <- evalPrecision prec + pure $ GeneralCapsF prec' alt s + ExponentialF prec alt s -> do + prec' <- evalPrecision prec + pure $ ExponentialF prec' alt s + ExponentialCapsF prec alt s -> do + prec' <- evalPrecision prec + pure $ ExponentialCapsF prec' alt s + FixedF prec alt s -> do + prec' <- evalPrecision prec + pure $ FixedF prec' alt s + FixedCapsF prec alt s -> do + prec' <- evalPrecision prec + pure $ FixedCapsF prec' alt s + PercentF prec alt s -> do + prec' <- evalPrecision prec + pure $ PercentF prec' alt s -- Default / String - DefaultF prec s -> var "formatAny" `app` toSignMode s `app` mkPaddingToPaddingK padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec - StringF prec -> (var ".") `app` (var "formatString" `app` (newPaddingKForString padding) `app` mkPrecision Nothing prec) `app` (var "pyfToString") - -mkPaddingToPaddingK :: Padding -> HsExpr GhcPs + DefaultF prec s -> do + prec' <- evalPrecision prec + pure $ DefaultF prec' s + StringF prec -> do + prec' <- evalPrecision prec + pure $ StringF prec' + +evalPrecision :: PrecisionT (ExprOrValue Int) -> Hsc (PrecisionT (HsExpr GhcPs)) +evalPrecision (PrecisionDefault) = pure PrecisionDefault +evalPrecision (Precision e) = Precision <$> exprToInt e + +evalPadding :: PaddingT (ExprOrValue Int) -> Hsc (PaddingT (HsExpr GhcPs)) +evalPadding p = case p of + PaddingDefault -> pure PaddingDefault + Padding i v -> do + i' <- exprToInt i + pure $ Padding i' v + +mkPaddingToPaddingK :: PaddingT (HsExpr GhcPs) -> HsExpr GhcPs mkPaddingToPaddingK p = case p of PaddingDefault -> ctor "PaddingDefaultK" - Padding i Nothing -> appType (appType' (ctor "PaddingK") "Int") "AlignAll" `app` exprToInt i `app` ctor "Nothing" - Padding i (Just (c, AnyAlign a)) -> ctor "PaddingK" `app` exprToInt i `app` (liftHsExpr (Just (c, a))) + Padding i Nothing -> appType (appType' (ctor "PaddingK") "Int") "AlignAll" `app` i `app` (liftHsExpr $ (Nothing :: Maybe (Int, AnyAlign, Char))) + Padding i (Just (c, AnyAlign a)) -> ctor "PaddingK" `app` i `app` liftHsExpr (Just (c, a)) + +newPaddingKForString :: PaddingT (HsExpr GhcPs) -> HsExpr GhcPs +newPaddingKForString padding = case padding of + PaddingDefault -> ctor "Nothing" + Padding i Nothing -> liftHsExpr (Just (i, AlignLeft, ' ')) -- default align left and fill with space for string + Padding i (Just (mc, AnyAlign a)) -> liftHsExpr (Just (i, a, fromMaybe ' ' mc)) + +mkPadding :: PaddingT (HsExpr GhcPs) -> HsExpr GhcPs +mkPadding padding = case padding of + PaddingDefault -> liftHsExpr (Nothing :: Maybe (Int, AnyAlign, Char)) + (Padding i al) -> case al of + Nothing -> liftHsExpr (Just (i, AnyAlign AlignRight, ' ')) -- Right align and space is default for any object, except string + Just (Nothing, a) -> liftHsExpr $ Just (i, a, ' ') + Just (Just c, a) -> liftHsExpr $ Just (i, a, c) class LiftHsExpr a where liftHsExpr :: a -> HsExpr GhcPs @@ -199,6 +274,9 @@ instance LiftHsExpr (Format k k' k'') where instance LiftHsExpr AnyAlign where liftHsExpr (AnyAlign v) = ctor "AnyAlign" `app` liftHsExpr v +instance LiftHsExpr (HsExpr GhcPs) where + liftHsExpr x = x + mkTup :: [HsExpr GhcPs] -> HsExpr GhcPs mkTup l = ExplicitTuple @@ -209,12 +287,6 @@ mkTup l = ) Boxed -newPaddingKForString :: Padding -> HsExpr GhcPs -newPaddingKForString padding = case padding of - PaddingDefault -> ctor "Nothing" - Padding i Nothing -> ctor "Just" `app` (mkTup [exprToInt i, liftHsExpr AlignLeft, liftHsExpr ' ']) -- default align left and fill with space for string - Padding i (Just (mc, AnyAlign a)) -> ctor "Just" `app` mkTup [exprToInt i, liftHsExpr a, liftHsExpr $ fromMaybe ' ' mc] - toSignMode :: SignMode -> HsExpr GhcPs toSignMode Plus = ctor "Plus" toSignMode Minus = ctor "Minus" @@ -230,24 +302,15 @@ withAlt :: AlternateForm -> Format 'CanAlt b c -> HsExpr GhcPs withAlt NormalForm e = liftHsExpr e withAlt AlternateForm e = liftHsExpr (Alternate e) -mkPadding :: Padding -> HsExpr GhcPs -mkPadding padding = case padding of - PaddingDefault -> ctor "Nothing" -- :: Maybe (Int, AnyAlign, Char)|] - (Padding i al) -> case al of - Nothing -> ctor "Just" `app` mkTup [exprToInt i, liftHsExpr $ AnyAlign AlignRight, liftHsExpr ' '] -- Right align and space is default for any object, except string - Just (Nothing, a) -> ctor "Just" `app` mkTup [exprToInt i, liftHsExpr a, liftHsExpr ' '] - Just (Just c, a) -> ctor "Just" `app` mkTup [exprToInt i, liftHsExpr a, liftHsExpr c] - -mkPrecision :: Maybe Int -> Precision -> HsExpr GhcPs +mkPrecision :: Maybe Int -> PrecisionT (HsExpr GhcPs) -> HsExpr GhcPs mkPrecision Nothing PrecisionDefault = ctor "Nothing" mkPrecision (Just v) PrecisionDefault = ctor "Just" `app` (HsLit noExtField' $ HsInt NoExtField (mkIntegralLit v)) -mkPrecision _ (Precision p) = ctor "Just" `app` exprToInt p - -exprToInt :: ExprOrValue Int -> HsExpr GhcPs -exprToInt (Value i) = HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) -exprToInt e = HsLit noExtField' $ HsInt NoExtField (mkIntegralLit 123) +mkPrecision _ (Precision p) = liftHsExpr (Just p) --- exprToInt (HaskellExpr s) = toHsExpr s +exprToInt :: ExprOrValue Int -> Hsc (HsExpr GhcPs) +exprToInt (Value i) = pure $ HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) +exprToInt (HaskellExpr loc s) = do + toHsExpr loc s toHsExpr :: SourcePos -> String -> Hsc (HsExpr GhcPs) toHsExpr loc s = do From b59df6667da7d6119192a9a5b9b60545f3f99740 Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Mon, 13 Jan 2025 11:58:20 +0400 Subject: [PATCH 12/17] Fix perfect localisation --- flake.nix | 13 ++++++------ src/PyF/Internal/Parser.hs | 8 +++---- src/PyF/Internal/QQ.hs | 2 +- src/PyF/Plugin.hs | 43 +++++++++++++++++++++----------------- 4 files changed, 35 insertions(+), 31 deletions(-) diff --git a/flake.nix b/flake.nix index 9408a3a..887f454 100644 --- a/flake.nix +++ b/flake.nix @@ -11,12 +11,11 @@ ]; outputs = - { - self, - nixpkgs, - flake-utils, - treefmt-nix, - ... + { self + , nixpkgs + , flake-utils + , treefmt-nix + , ... }: flake-utils.lib.eachDefaultSystem ( system: @@ -92,6 +91,8 @@ pkgs.nodejs ]; }; + + work_with_pyf = pkgs.mkShell { buildInputs = [ (pkgs.haskellPackages.ghcWithPackages (_: [ (pkgs.haskell.lib.dontCheck packages.default) ])) ]; }; default = packages.default.shell_hls; }; } diff --git a/src/PyF/Internal/Parser.hs b/src/PyF/Internal/Parser.hs index ac98d99..77b7ccd 100644 --- a/src/PyF/Internal/Parser.hs +++ b/src/PyF/Internal/Parser.hs @@ -50,15 +50,13 @@ import HsExtension as Ext import Outputable (showSDoc) #endif +import GHC.Parser.Annotation (LocatedA) import qualified PyF.Internal.ParserEx as ParseExp -parseExpression :: RealSrcLoc -> String -> DynFlags -> Either (RealSrcLoc, String) (HsExpr GhcPs) +parseExpression :: RealSrcLoc -> String -> DynFlags -> Either (RealSrcLoc, String) (LocatedA (HsExpr GhcPs)) parseExpression initLoc s dynFlags = case ParseExp.parseExpression initLoc s dynFlags of - POk _ locatedExpr -> - let expr = SrcLoc.unLoc locatedExpr - in Right - expr + POk _ locatedExpr -> Right locatedExpr {- ORMOLU_DISABLE #-} #if MIN_VERSION_ghc(9,2,0) diff --git a/src/PyF/Internal/QQ.hs b/src/PyF/Internal/QQ.hs index 01b4a04..3e753cc 100644 --- a/src/PyF/Internal/QQ.hs +++ b/src/PyF/Internal/QQ.hs @@ -170,7 +170,7 @@ toHsExpr sourcePos s = do let srcLoc = mkRealSrcLoc (mkFastString (sourceName sourcePos)) (sourceLine sourcePos) (sourceColumn sourcePos) case ParseExp.parseExpression srcLoc s dynFlags of Right hsExpr -> do - check <- checkVariables hsExpr + check <- checkVariables (unLoc hsExpr) case check of Right hsExpr' -> pure $ Just hsExpr' Left (span, err) -> do diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs index 361ea00..56cbec1 100644 --- a/src/PyF/Plugin.hs +++ b/src/PyF/Plugin.hs @@ -104,7 +104,7 @@ toString (Raw s) = pure $ HsLit noExtField' $ HsString NoSourceText (mkFastStrin toString (Replacement loc s formatMode) = do expr <- toHsExpr loc s formatExpr <- padAndFormat (fromMaybe DefaultFormatMode formatMode) - pure $ app formatExpr expr + pure $ formatExpr `app'` expr pyf :: SrcAnn NoEpAnns -> String -> [Item] pyf (SrcSpanAnn _ srcSpan) s = case runReader (runParserT (setPosition initPos >> parseGenericFormatString) () filename s) context of @@ -127,6 +127,9 @@ appType' a name = HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) ( app :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs app a b = HsApp noExtField' (L noSrcSpanA a) (L noSrcSpanA b) +app' :: HsExpr GhcPs -> (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> HsExpr GhcPs +app' a b = HsApp noExtField' (L noSrcSpanA a) b + var :: String -> HsExpr GhcPs var name = ( HsVar @@ -168,13 +171,13 @@ padAndFormat formatMode' = do DefaultF prec s -> var "formatAny" `app` toSignMode s `app` mkPaddingToPaddingK padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec StringF prec -> (var ".") `app` (var "formatString" `app` (newPaddingKForString padding) `app` mkPrecision Nothing prec) `app` (var "pyfToString") -evalSubExpression :: FormatModeT (ExprOrValue Int) -> Hsc (FormatModeT (HsExpr GhcPs)) +evalSubExpression :: FormatModeT (ExprOrValue Int) -> Hsc (FormatModeT (LocatedA (HsExpr GhcPs))) evalSubExpression (FormatMode padding tf grouping) = do padding' <- evalPadding padding tf' <- evalTf tf pure $ FormatMode padding' tf' grouping -evalTf :: TypeFormatT (ExprOrValue Int) -> Hsc (TypeFormatT (HsExpr GhcPs)) +evalTf :: TypeFormatT (ExprOrValue Int) -> Hsc (TypeFormatT (LocatedA (HsExpr GhcPs))) evalTf tf = case tf of -- Integrals BinaryF alt s -> pure $ BinaryF alt s @@ -213,30 +216,30 @@ evalTf tf = case tf of prec' <- evalPrecision prec pure $ StringF prec' -evalPrecision :: PrecisionT (ExprOrValue Int) -> Hsc (PrecisionT (HsExpr GhcPs)) +evalPrecision :: PrecisionT (ExprOrValue Int) -> Hsc (PrecisionT (LocatedA (HsExpr GhcPs))) evalPrecision (PrecisionDefault) = pure PrecisionDefault evalPrecision (Precision e) = Precision <$> exprToInt e -evalPadding :: PaddingT (ExprOrValue Int) -> Hsc (PaddingT (HsExpr GhcPs)) +evalPadding :: PaddingT (ExprOrValue Int) -> Hsc (PaddingT (LocatedA (HsExpr GhcPs))) evalPadding p = case p of PaddingDefault -> pure PaddingDefault Padding i v -> do i' <- exprToInt i pure $ Padding i' v -mkPaddingToPaddingK :: PaddingT (HsExpr GhcPs) -> HsExpr GhcPs +mkPaddingToPaddingK :: PaddingT _ -> HsExpr GhcPs mkPaddingToPaddingK p = case p of PaddingDefault -> ctor "PaddingDefaultK" - Padding i Nothing -> appType (appType' (ctor "PaddingK") "Int") "AlignAll" `app` i `app` (liftHsExpr $ (Nothing :: Maybe (Int, AnyAlign, Char))) - Padding i (Just (c, AnyAlign a)) -> ctor "PaddingK" `app` i `app` liftHsExpr (Just (c, a)) + Padding i Nothing -> appType (appType' (ctor "PaddingK") "Int") "AlignAll" `app'` i `app` (liftHsExpr $ (Nothing :: Maybe (Int, AnyAlign, Char))) + Padding i (Just (c, AnyAlign a)) -> ctor "PaddingK" `app'` i `app` liftHsExpr (Just (c, a)) -newPaddingKForString :: PaddingT (HsExpr GhcPs) -> HsExpr GhcPs +newPaddingKForString :: PaddingT (LocatedA (HsExpr GhcPs)) -> HsExpr GhcPs newPaddingKForString padding = case padding of PaddingDefault -> ctor "Nothing" Padding i Nothing -> liftHsExpr (Just (i, AlignLeft, ' ')) -- default align left and fill with space for string Padding i (Just (mc, AnyAlign a)) -> liftHsExpr (Just (i, a, fromMaybe ' ' mc)) -mkPadding :: PaddingT (HsExpr GhcPs) -> HsExpr GhcPs +mkPadding :: PaddingT (LocatedA (HsExpr GhcPs)) -> HsExpr GhcPs mkPadding padding = case padding of PaddingDefault -> liftHsExpr (Nothing :: Maybe (Int, AnyAlign, Char)) (Padding i al) -> case al of @@ -277,6 +280,9 @@ instance LiftHsExpr AnyAlign where instance LiftHsExpr (HsExpr GhcPs) where liftHsExpr x = x +instance LiftHsExpr (GenLocated SrcSpanAnnA (HsExpr GhcPs)) where + liftHsExpr x = HsPar noExtField' noHsTok x noHsTok + mkTup :: [HsExpr GhcPs] -> HsExpr GhcPs mkTup l = ExplicitTuple @@ -302,23 +308,22 @@ withAlt :: AlternateForm -> Format 'CanAlt b c -> HsExpr GhcPs withAlt NormalForm e = liftHsExpr e withAlt AlternateForm e = liftHsExpr (Alternate e) -mkPrecision :: Maybe Int -> PrecisionT (HsExpr GhcPs) -> HsExpr GhcPs +mkPrecision :: Maybe Int -> PrecisionT (LocatedA (HsExpr GhcPs)) -> HsExpr GhcPs mkPrecision Nothing PrecisionDefault = ctor "Nothing" mkPrecision (Just v) PrecisionDefault = ctor "Just" `app` (HsLit noExtField' $ HsInt NoExtField (mkIntegralLit v)) mkPrecision _ (Precision p) = liftHsExpr (Just p) -exprToInt :: ExprOrValue Int -> Hsc (HsExpr GhcPs) -exprToInt (Value i) = pure $ HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) -exprToInt (HaskellExpr loc s) = do - toHsExpr loc s +exprToInt :: ExprOrValue Int -> Hsc (LocatedA (HsExpr GhcPs)) +exprToInt (Value i) = pure $ noLocA $ HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) +exprToInt (HaskellExpr loc s) = toHsExpr loc s -toHsExpr :: SourcePos -> String -> Hsc (HsExpr GhcPs) -toHsExpr loc s = do +toHsExpr :: SourcePos -> String -> Hsc (LocatedA (HsExpr GhcPs)) +toHsExpr sourcePos s = do dynFlags <- getDynFlags -- TODO - let initLoc = mkRealSrcLoc (mkFastString "file") 10 10 + let srcLoc = mkRealSrcLoc (mkFastString (sourceName sourcePos)) (sourceLine sourcePos) (sourceColumn sourcePos) - case ParseExp.parseExpression initLoc s dynFlags of + case ParseExp.parseExpression srcLoc s dynFlags of Right res -> pure res Left e -> error $ show e From a61980ab6665bce2671d59db9b10d27328729dc4 Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Mon, 13 Jan 2025 13:14:36 +0400 Subject: [PATCH 13/17] WIP: correct error reporting --- src/PyF/Internal/QQ.hs | 17 ++-- src/PyF/Plugin.hs | 217 +++++++++++++++++++++++++---------------- 2 files changed, 144 insertions(+), 90 deletions(-) diff --git a/src/PyF/Internal/QQ.hs b/src/PyF/Internal/QQ.hs index 3e753cc..6a1cdb3 100644 --- a/src/PyF/Internal/QQ.hs +++ b/src/PyF/Internal/QQ.hs @@ -292,24 +292,27 @@ reportErrorAt loc msg = unsafeRunTcM $ addErrAt loc msg' #endif reportParserErrorAt :: ParseError -> Q () -reportParserErrorAt err = reportErrorAt span msg +reportParserErrorAt err = reportErrorAt (RealSrcSpan span mempty) msg where - msg = intercalate "\n" $ formatErrorMessages err + (loc, msg) = parseErrorToLocAndMessage err + span = mkRealSrcSpan loc loc' - span :: SrcSpan - span = mkSrcSpan loc loc' + loc' = srcLocFromParserError (incSourceColumn (errorPos err) 1) +parseErrorToLocAndMessage :: ParseError -> (RealSrcLoc, [Char]) +parseErrorToLocAndMessage err = (loc, msg) + where + msg = intercalate "\n" $ formatErrorMessages err loc = srcLocFromParserError (errorPos err) - loc' = srcLocFromParserError (incSourceColumn (errorPos err) 1) -srcLocFromParserError :: SourcePos -> SrcLoc +srcLocFromParserError :: SourcePos -> RealSrcLoc srcLocFromParserError sourceLoc = srcLoc where line = sourceLine sourceLoc column = sourceColumn sourceLoc name = sourceName sourceLoc - srcLoc = mkSrcLoc (fromString name) line column + srcLoc = mkRealSrcLoc (fromString name) line column formatErrorMessages :: ParseError -> [String] formatErrorMessages err diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs index 56cbec1..f94c9a5 100644 --- a/src/PyF/Plugin.hs +++ b/src/PyF/Plugin.hs @@ -6,10 +6,11 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -module PyF.Plugin (plugin) where +module PyF.Plugin (plugin, forceError) where import Data.Data import qualified GHC.LanguageExtensions as LangExt @@ -18,15 +19,17 @@ import qualified GHC.LanguageExtensions as LangExt #if MIN_VERSION_ghc(9,0,0) import GHC.Hs -import GHC.Plugins +import GHC.Plugins hiding (msg) #else import GHC import GhcPlugins #endif +import Control.Monad (join) import Control.Monad.Reader (runReader) import Data.Generics import Data.Maybe (fromMaybe) +import GHC.TypeLits import qualified GHC.Types.Name.Occurrence as GHC.Types.Name.Occurence import GHC.Types.SourceText (SourceText (..), mkIntegralLit) import PyF (defaultFloatPrecision, fmtConfig, trimIndent) @@ -44,7 +47,7 @@ import PyF.Internal.PythonSyntax parseGenericFormatString, pattern DefaultFormatMode, ) -import PyF.Internal.QQ (Config (..)) +import PyF.Internal.QQ (Config (..), parseErrorToLocAndMessage) import Text.Parsec (runParserT) import Text.Parsec.Pos import Text.Parsec.Prim (setPosition) @@ -77,46 +80,87 @@ replaceSplice e = do _ -> do pure e +{- + - This is not used, the idea was to report the error during the plugin, but it + - actually fails the compilation completly. +reportError theLoc theMsg = do + Hsc $ \env messages -> do + pure + ( (), + addMessage + ( MsgEnvelope + { errMsgSpan = RealSrcSpan (realSrcLocSpan theLoc) mempty, + -- TODO: maybe alwaysqualify can be refined + errMsgContext = alwaysQualify, + errMsgDiagnostic = GhcUnknownMessage (UnknownDiagnostic (mkPlainError noHints (text theMsg))), + errMsgSeverity = SevWarning + } + ) + messages + ) +-} + applyPyf :: SrcAnn NoEpAnns -> String -> Hsc (HsExpr GhcPs) applyPyf loc s = do - items <- mapM toString $ pyf loc s - dynFlags <- getDynFlags - let toOverloaded - | xopt LangExt.OverloadedStrings dynFlags = app (var "fromString") - | otherwise = id - pure $ - toOverloaded $ - HsApp - noExtField' - ( L - noSrcSpanA - ( HsVar - NoExtField - ( L noSrcSpanA $ - mkUnqual GHC.Types.Name.Occurence.varName (mkFastString "mconcat") + let pyfItems = pyf loc s + (join . fmap sequenceA -> itemsM) <- sequenceA (mapM toString <$> pyfItems) + case itemsM of + Left (theLoc, theMsg) -> do + pure $ HsPar noExtField' noHsTok (L ((SrcSpanAnn noExtField' (RealSrcSpan (realSrcLocSpan theLoc) mempty))) $ var "forceError" `app` (ctor "Proxy" `appTypeSymbol` theMsg)) noHsTok + Right items -> do + dynFlags <- getDynFlags + let toOverloaded + | xopt LangExt.OverloadedStrings dynFlags = app (var "fromString") + | otherwise = id + pure $ + toOverloaded $ + HsApp + noExtField' + ( L + noSrcSpanA + ( HsVar + NoExtField + ( L noSrcSpanA $ + mkUnqual GHC.Types.Name.Occurence.varName (mkFastString "mconcat") + ) ) ) - ) - (L noSrcSpanA $ ExplicitList emptyAnnList $ map (L noSrcSpanA) items) + (L noSrcSpanA $ ExplicitList emptyAnnList $ items) -toString :: Item -> Hsc (HsExpr GhcPs) -toString (Raw s) = pure $ HsLit noExtField' $ HsString NoSourceText (mkFastString s) -toString (Replacement loc s formatMode) = do - expr <- toHsExpr loc s - formatExpr <- padAndFormat (fromMaybe DefaultFormatMode formatMode) - pure $ formatExpr `app'` expr +appTypeSymbol :: HsExpr GhcPs -> String -> HsExpr GhcPs +appTypeSymbol a name = HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) (HsWC NoExtField (L noSrcSpanA (HsTyLit NoExtField (HsStrTy NoSourceText (mkFastString name))))) -pyf :: SrcAnn NoEpAnns -> String -> [Item] +-- TODO: a lot of the Either could be "Validation" and generate MULTIPLES +-- errors messages, but for now GHC is not able to handle multiples errors +toString :: Item -> Hsc (Either (RealSrcLoc, String) (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))) +toString (Raw s) = pure $ pure $ L noSrcSpanA (HsLit noExtField' $ HsString NoSourceText (mkFastString s)) -- TODO: restore the correct location for the "raw" string +toString (Replacement loc s formatMode) = do + exprM <- toHsExpr loc s + formatExprM <- padAndFormat (fromMaybe DefaultFormatMode formatMode) + + -- We wrap the formatted expression using the location of the original expression + -- Hence GHC will report type error at that location, if relevant + pure $ do + expr <- exprM + formatExpr <- formatExprM + let loc' = getLoc expr + pure $ L loc' (formatExpr `app'` expr) + +pyf :: SrcAnn NoEpAnns -> String -> Either (RealSrcLoc, String) [Item] pyf (SrcSpanAnn _ srcSpan) s = case runReader (runParserT (setPosition initPos >> parseGenericFormatString) () filename s) context of - Right r -> r - Left e -> error $ show e + Right r -> Right r + Left e -> Left (loc, msg) + where + (loc, msg) = parseErrorToLocAndMessage e where filename = unpackFS $ srcLocFile start Config {..} = fmtConfig context = ParsingContext {..} initPos = setSourceColumn (setSourceLine (initialPos filename) (srcLocLine start)) (srcLocCol start) - RealSrcLoc start _ = srcSpanStart srcSpan + start = case srcSpanStart srcSpan of + RealSrcLoc startLoc _ -> startLoc + _ -> error "Plugin API does not know it's RealSrcLoc" appType :: HsExpr GhcPs -> String -> HsExpr GhcPs appType a name = HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) (HsWC NoExtField (L noSrcSpanA (HsTyVar noExtField' NotPromoted (L noSrcSpanA (mkUnqual dataName (mkFastString name)))))) @@ -148,86 +192,88 @@ ctor name = ) ) -padAndFormat :: FormatModeT (ExprOrValue Int) -> Hsc (HsExpr GhcPs) +padAndFormat :: FormatModeT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (HsExpr GhcPs)) padAndFormat formatMode' = do - (FormatMode padding tf grouping) <- evalSubExpression formatMode' - pure $ case tf of - -- Integrals - BinaryF alt s -> var "formatAnyIntegral" `app` withAlt alt Binary `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 - CharacterF -> var "formatAnyIntegral" `app` ctor "Character" `app` ctor "Minus" `app` mkPadding padding `app` ctor "Nothing" - DecimalF s -> var "formatAnyIntegral" `app` ctor "Decimal" `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 - HexF alt s -> var "formatAnyIntegral" `app` withAlt alt Hexa `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 - OctalF alt s -> var "formatAnyIntegral" `app` withAlt alt Octal `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 - HexCapsF alt s -> var "formatAnyIntegral" `app` (ctor "Upper" `app` (withAlt alt Hexa)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 - -- Floating - GeneralF prec alt s -> var "formatAnyFractional" `app` withAlt alt Generic `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - GeneralCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Generic)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - ExponentialF prec alt s -> var "formatAnyFractional" `app` withAlt alt Exponent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - ExponentialCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Exponent)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - FixedF prec alt s -> var "formatAnyFractional" `app` withAlt alt Fixed `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - FixedCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Fixed)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - PercentF prec alt s -> var "formatAnyFractional" `app` withAlt alt Percent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - -- Default / String - DefaultF prec s -> var "formatAny" `app` toSignMode s `app` mkPaddingToPaddingK padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec - StringF prec -> (var ".") `app` (var "formatString" `app` (newPaddingKForString padding) `app` mkPrecision Nothing prec) `app` (var "pyfToString") - -evalSubExpression :: FormatModeT (ExprOrValue Int) -> Hsc (FormatModeT (LocatedA (HsExpr GhcPs))) + formatModeM <- evalSubExpression formatMode' + pure $ do + FormatMode padding tf grouping <- formatModeM + pure $ case tf of + -- Integrals + BinaryF alt s -> var "formatAnyIntegral" `app` withAlt alt Binary `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + CharacterF -> var "formatAnyIntegral" `app` ctor "Character" `app` ctor "Minus" `app` mkPadding padding `app` ctor "Nothing" + DecimalF s -> var "formatAnyIntegral" `app` ctor "Decimal" `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 + HexF alt s -> var "formatAnyIntegral" `app` withAlt alt Hexa `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + OctalF alt s -> var "formatAnyIntegral" `app` withAlt alt Octal `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + HexCapsF alt s -> var "formatAnyIntegral" `app` (ctor "Upper" `app` (withAlt alt Hexa)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + -- Floating + GeneralF prec alt s -> var "formatAnyFractional" `app` withAlt alt Generic `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + GeneralCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Generic)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + ExponentialF prec alt s -> var "formatAnyFractional" `app` withAlt alt Exponent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + ExponentialCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Exponent)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + FixedF prec alt s -> var "formatAnyFractional" `app` withAlt alt Fixed `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + FixedCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Fixed)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + PercentF prec alt s -> var "formatAnyFractional" `app` withAlt alt Percent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + -- Default / String + DefaultF prec s -> var "formatAny" `app` toSignMode s `app` mkPaddingToPaddingK padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec + StringF prec -> (var ".") `app` (var "formatString" `app` (newPaddingKForString padding) `app` mkPrecision Nothing prec) `app` (var "pyfToString") + +evalSubExpression :: FormatModeT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (FormatModeT (LocatedA (HsExpr GhcPs)))) evalSubExpression (FormatMode padding tf grouping) = do padding' <- evalPadding padding tf' <- evalTf tf - pure $ FormatMode padding' tf' grouping + pure $ FormatMode <$> padding' <*> tf' <*> pure grouping -evalTf :: TypeFormatT (ExprOrValue Int) -> Hsc (TypeFormatT (LocatedA (HsExpr GhcPs))) +evalTf :: TypeFormatT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (TypeFormatT (LocatedA (HsExpr GhcPs)))) evalTf tf = case tf of -- Integrals - BinaryF alt s -> pure $ BinaryF alt s - CharacterF -> pure $ CharacterF - DecimalF s -> pure $ DecimalF s - HexF alt s -> pure $ HexF alt s - OctalF alt s -> pure $ OctalF alt s - HexCapsF alt s -> pure $ HexCapsF alt s + BinaryF alt s -> pure $ pure $ BinaryF alt s + CharacterF -> pure $ pure $ CharacterF + DecimalF s -> pure $ pure $ DecimalF s + HexF alt s -> pure $ pure $ HexF alt s + OctalF alt s -> pure $ pure $ OctalF alt s + HexCapsF alt s -> pure $ pure $ HexCapsF alt s -- Floating GeneralF prec alt s -> do prec' <- evalPrecision prec - pure $ GeneralF prec' alt s + pure $ GeneralF <$> prec' <*> pure alt <*> pure s GeneralCapsF prec alt s -> do prec' <- evalPrecision prec - pure $ GeneralCapsF prec' alt s + pure $ GeneralCapsF <$> prec' <*> pure alt <*> pure s ExponentialF prec alt s -> do prec' <- evalPrecision prec - pure $ ExponentialF prec' alt s + pure $ ExponentialF <$> prec' <*> pure alt <*> pure s ExponentialCapsF prec alt s -> do prec' <- evalPrecision prec - pure $ ExponentialCapsF prec' alt s + pure $ ExponentialCapsF <$> prec' <*> pure alt <*> pure s FixedF prec alt s -> do prec' <- evalPrecision prec - pure $ FixedF prec' alt s + pure $ FixedF <$> prec' <*> pure alt <*> pure s FixedCapsF prec alt s -> do prec' <- evalPrecision prec - pure $ FixedCapsF prec' alt s + pure $ FixedCapsF <$> prec' <*> pure alt <*> pure s PercentF prec alt s -> do prec' <- evalPrecision prec - pure $ PercentF prec' alt s + pure $ PercentF <$> prec' <*> pure alt <*> pure s -- Default / String DefaultF prec s -> do prec' <- evalPrecision prec - pure $ DefaultF prec' s + pure $ DefaultF <$> prec' <*> pure s StringF prec -> do prec' <- evalPrecision prec - pure $ StringF prec' + pure $ StringF <$> prec' -evalPrecision :: PrecisionT (ExprOrValue Int) -> Hsc (PrecisionT (LocatedA (HsExpr GhcPs))) -evalPrecision (PrecisionDefault) = pure PrecisionDefault -evalPrecision (Precision e) = Precision <$> exprToInt e +evalPrecision :: PrecisionT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (PrecisionT (LocatedA (HsExpr GhcPs)))) +evalPrecision (PrecisionDefault) = pure $ pure PrecisionDefault +evalPrecision (Precision e) = fmap Precision <$> exprToInt e -evalPadding :: PaddingT (ExprOrValue Int) -> Hsc (PaddingT (LocatedA (HsExpr GhcPs))) +evalPadding :: PaddingT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (PaddingT (LocatedA (HsExpr GhcPs)))) evalPadding p = case p of - PaddingDefault -> pure PaddingDefault + PaddingDefault -> pure $ pure PaddingDefault Padding i v -> do i' <- exprToInt i - pure $ Padding i' v + pure $ Padding <$> i' <*> pure v -mkPaddingToPaddingK :: PaddingT _ -> HsExpr GhcPs +mkPaddingToPaddingK :: PaddingT (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> HsExpr GhcPs mkPaddingToPaddingK p = case p of PaddingDefault -> ctor "PaddingDefaultK" Padding i Nothing -> appType (appType' (ctor "PaddingK") "Int") "AlignAll" `app'` i `app` (liftHsExpr $ (Nothing :: Maybe (Int, AnyAlign, Char))) @@ -313,19 +359,24 @@ mkPrecision Nothing PrecisionDefault = ctor "Nothing" mkPrecision (Just v) PrecisionDefault = ctor "Just" `app` (HsLit noExtField' $ HsInt NoExtField (mkIntegralLit v)) mkPrecision _ (Precision p) = liftHsExpr (Just p) -exprToInt :: ExprOrValue Int -> Hsc (LocatedA (HsExpr GhcPs)) -exprToInt (Value i) = pure $ noLocA $ HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) +exprToInt :: ExprOrValue Int -> Hsc (Either (RealSrcLoc, String) (LocatedA (HsExpr GhcPs))) +exprToInt (Value i) = pure $ pure $ noLocA $ HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) exprToInt (HaskellExpr loc s) = toHsExpr loc s -toHsExpr :: SourcePos -> String -> Hsc (LocatedA (HsExpr GhcPs)) +toHsExpr :: SourcePos -> String -> Hsc (Either (RealSrcLoc, String) (LocatedA (HsExpr GhcPs))) toHsExpr sourcePos s = do dynFlags <- getDynFlags - -- TODO let srcLoc = mkRealSrcLoc (mkFastString (sourceName sourcePos)) (sourceLine sourcePos) (sourceColumn sourcePos) case ParseExp.parseExpression srcLoc s dynFlags of - Right res -> pure res - Left e -> error $ show e + Right res -> pure $ Right res + Left e -> pure $ Left e + +class ForceError (m :: Symbol) where + forceError :: Proxy m -> t + +instance (TypeError (Text m)) => ForceError m where + forceError = undefined #if MIN_VERSION_ghc(9,10,0) noExtField' :: NoExtField From 22441d0a5818f21dc96f4f241a7445e6a7dc625d Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Mon, 13 Jan 2025 18:05:55 +0400 Subject: [PATCH 14/17] GHC 9.10 --- PyF.cabal | 2 +- flake.nix | 17 ++++++++----- src/PyF/Plugin.hs | 61 ++++++++++++++++++++++++++++++++++++++++------- 3 files changed, 64 insertions(+), 16 deletions(-) diff --git a/PyF.cabal b/PyF.cabal index 552de6b..3514f28 100644 --- a/PyF.cabal +++ b/PyF.cabal @@ -35,7 +35,7 @@ library , base >=4.12 && <4.22 , bytestring >=0.10.8 && <0.13 , ghc >=8.6.1 && <9.14 - , ghc-boot >=8.6.1 && <9.14 + , ghc-boot >=8.6.1 && <9.14 , mtl >=2.2.2 && <2.4 , parsec >=3.1.13 && <3.2 , syb diff --git a/flake.nix b/flake.nix index 887f454..51ccd63 100644 --- a/flake.nix +++ b/flake.nix @@ -11,11 +11,12 @@ ]; outputs = - { self - , nixpkgs - , flake-utils - , treefmt-nix - , ... + { + self, + nixpkgs, + flake-utils, + treefmt-nix, + ... }: flake-utils.lib.eachDefaultSystem ( system: @@ -92,7 +93,11 @@ ]; }; - work_with_pyf = pkgs.mkShell { buildInputs = [ (pkgs.haskellPackages.ghcWithPackages (_: [ (pkgs.haskell.lib.dontCheck packages.default) ])) ]; }; + work_with_pyf = pkgs.mkShell { + buildInputs = [ + (pkgs.haskellPackages.ghcWithPackages (_: [ (pkgs.haskell.lib.dontCheck packages.default) ])) + ]; + }; default = packages.default.shell_hls; }; } diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs index f94c9a5..9765f1c 100644 --- a/src/PyF/Plugin.hs +++ b/src/PyF/Plugin.hs @@ -72,7 +72,11 @@ action parsed@HsParsedModule {hpm_module = m} = replaceSplice :: HsExpr GhcPs -> Hsc (HsExpr GhcPs) replaceSplice e = do case e of - HsUntypedSplice _xsplit (HsQuasiQuote _xquasi (Unqual name) (L loc s)) +#if MIN_VERSION_ghc(9,10,0) + HsUntypedSplice _xsplit (HsQuasiQuote _xquasi (Unqual name) (L (getHasLoc -> loc) s)) +#else + HsUntypedSplice _xsplit (HsQuasiQuote _xquasi (Unqual name) (L (SrcSpanAnn _ loc) s)) +#endif | mkVarOcc "fmt" == name -> applyPyf loc $ unpackFS s | mkVarOcc "fmtTrim" == name -> applyPyf loc (trimIndent $ unpackFS s) | mkVarOcc "str" == name -> pure $ HsLit noExtField' (HsString NoSourceText s) @@ -100,13 +104,17 @@ reportError theLoc theMsg = do ) -} -applyPyf :: SrcAnn NoEpAnns -> String -> Hsc (HsExpr GhcPs) +applyPyf :: SrcSpan -> String -> Hsc (HsExpr GhcPs) applyPyf loc s = do let pyfItems = pyf loc s (join . fmap sequenceA -> itemsM) <- sequenceA (mapM toString <$> pyfItems) case itemsM of Left (theLoc, theMsg) -> do +#if MIN_VERSION_ghc(9,10,0) + pure $ HsPar (NoEpTok, NoEpTok) (L ((EpAnn (EpaSpan $ RealSrcSpan (realSrcLocSpan theLoc) mempty) (AnnListItem []) emptyComments)) $ var "forceError" `app` (ctor "Proxy" `appTypeSymbol` theMsg)) +#else pure $ HsPar noExtField' noHsTok (L ((SrcSpanAnn noExtField' (RealSrcSpan (realSrcLocSpan theLoc) mempty))) $ var "forceError" `app` (ctor "Proxy" `appTypeSymbol` theMsg)) noHsTok +#endif Right items -> do dynFlags <- getDynFlags let toOverloaded @@ -127,12 +135,10 @@ applyPyf loc s = do ) (L noSrcSpanA $ ExplicitList emptyAnnList $ items) -appTypeSymbol :: HsExpr GhcPs -> String -> HsExpr GhcPs -appTypeSymbol a name = HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) (HsWC NoExtField (L noSrcSpanA (HsTyLit NoExtField (HsStrTy NoSourceText (mkFastString name))))) -- TODO: a lot of the Either could be "Validation" and generate MULTIPLES -- errors messages, but for now GHC is not able to handle multiples errors -toString :: Item -> Hsc (Either (RealSrcLoc, String) (GenLocated (SrcAnn AnnListItem) (HsExpr GhcPs))) +toString :: Item -> Hsc (Either (RealSrcLoc, String) (GenLocated _ (HsExpr GhcPs))) toString (Raw s) = pure $ pure $ L noSrcSpanA (HsLit noExtField' $ HsString NoSourceText (mkFastString s)) -- TODO: restore the correct location for the "raw" string toString (Replacement loc s formatMode) = do exprM <- toHsExpr loc s @@ -146,8 +152,8 @@ toString (Replacement loc s formatMode) = do let loc' = getLoc expr pure $ L loc' (formatExpr `app'` expr) -pyf :: SrcAnn NoEpAnns -> String -> Either (RealSrcLoc, String) [Item] -pyf (SrcSpanAnn _ srcSpan) s = case runReader (runParserT (setPosition initPos >> parseGenericFormatString) () filename s) context of +pyf :: SrcSpan -> String -> Either (RealSrcLoc, String) [Item] +pyf srcSpan s = case runReader (runParserT (setPosition initPos >> parseGenericFormatString) () filename s) context of Right r -> Right r Left e -> Left (loc, msg) where @@ -162,11 +168,37 @@ pyf (SrcSpanAnn _ srcSpan) s = case runReader (runParserT (setPosition initPos > RealSrcLoc startLoc _ -> startLoc _ -> error "Plugin API does not know it's RealSrcLoc" +-- Foo @"symbol" +appTypeSymbol :: HsExpr GhcPs -> String -> HsExpr GhcPs +appTypeSymbol a name = appTypeAny a + (HsTyLit NoExtField (HsStrTy NoSourceText (mkFastString name))) + +-- Foo @Bar appType :: HsExpr GhcPs -> String -> HsExpr GhcPs -appType a name = HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) (HsWC NoExtField (L noSrcSpanA (HsTyVar noExtField' NotPromoted (L noSrcSpanA (mkUnqual dataName (mkFastString name)))))) +appType a name = appTypeAny a +#if MIN_VERSION_ghc(9,10,0) + (HsTyVar [] NotPromoted (noLocA (mkUnqual dataName (mkFastString name)))) +#else + (HsTyVar noExtField' NotPromoted (L noSrcSpanA (mkUnqual dataName (mkFastString name)))) +#endif +-- Foo @Int appType' :: HsExpr GhcPs -> String -> HsExpr GhcPs -appType' a name = HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) (HsWC NoExtField (L noSrcSpanA (HsTyVar noExtField' NotPromoted (L noSrcSpanA (mkUnqual tcName (mkFastString name)))))) +appType' a name = appTypeAny a +#if MIN_VERSION_ghc(9,10,0) + (HsTyVar [] NotPromoted (noLocA $ mkUnqual tcName (mkFastString name))) +#else + (HsTyVar noExtField' NotPromoted (L noSrcSpanA (mkUnqual tcName (mkFastString name)))) +#endif + +appTypeAny :: HsExpr GhcPs -> HsType GhcPs -> HsExpr GhcPs +appTypeAny a b = +#if MIN_VERSION_ghc(9,10,0) + HsAppType NoEpTok (L noSrcSpanA a) (HsWC NoExtField (L noSrcSpanA b)) +#else + HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) (HsWC NoExtField (L noSrcSpanA b)) +#endif + app :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs app a b = HsApp noExtField' (L noSrcSpanA a) (L noSrcSpanA b) @@ -327,12 +359,20 @@ instance LiftHsExpr (HsExpr GhcPs) where liftHsExpr x = x instance LiftHsExpr (GenLocated SrcSpanAnnA (HsExpr GhcPs)) where +#if MIN_VERSION_ghc(9,10,0) + liftHsExpr x = HsPar (NoEpTok, NoEpTok) x +#else liftHsExpr x = HsPar noExtField' noHsTok x noHsTok +#endif mkTup :: [HsExpr GhcPs] -> HsExpr GhcPs mkTup l = ExplicitTuple +#if MIN_VERSION_ghc(9,10,0) + [] +#else noExtField' +#endif ( map (\x -> Present noExtField' (L noSrcSpanA x)) l @@ -385,9 +425,12 @@ noExtField' = NoExtField emptyAnnList :: AnnList emptyAnnList = AnnList Nothing Nothing Nothing [] [] #else +-- Tested with 9.6 noExtField' :: EpAnn ann noExtField' = EpAnnNotUsed emptyAnnList :: EpAnn ann emptyAnnList = EpAnnNotUsed #endif + +-- TODO: maybe we can use convertToHsExpr in order to generate the source code we want From 0b79c9c88d7c5785a67f679ee68a11c074f597a4 Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Mon, 13 Jan 2025 18:32:26 +0400 Subject: [PATCH 15/17] Wip --- src/PyF/Plugin.hs | 19 ++++++++++++++----- test/Spec.hs | 2 +- 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs index 9765f1c..74a21de 100644 --- a/src/PyF/Plugin.hs +++ b/src/PyF/Plugin.hs @@ -68,6 +68,7 @@ action parsed@HsParsedModule {hpm_module = m} = (\m' -> parsed {hpm_module = m'}) <$> gmapM (everywhereM (mkM replaceSplice)) m +{- ORMOLU_DISABLE -} -- | Replace a splice entry replaceSplice :: HsExpr GhcPs -> Hsc (HsExpr GhcPs) replaceSplice e = do @@ -83,6 +84,7 @@ replaceSplice e = do | mkVarOcc "strTrim" == name -> pure $ HsLit noExtField' (HsString NoSourceText (mkFastString $ trimIndent $ unpackFS s)) _ -> do pure e +{- ORMOLU_ENABLE -} {- - This is not used, the idea was to report the error during the plugin, but it @@ -104,6 +106,7 @@ reportError theLoc theMsg = do ) -} +{- ORMOLU_DISABLE -} applyPyf :: SrcSpan -> String -> Hsc (HsExpr GhcPs) applyPyf loc s = do let pyfItems = pyf loc s @@ -134,7 +137,7 @@ applyPyf loc s = do ) ) (L noSrcSpanA $ ExplicitList emptyAnnList $ items) - +{- ORMOLU_ENABLE -} -- TODO: a lot of the Either could be "Validation" and generate MULTIPLES -- errors messages, but for now GHC is not able to handle multiples errors @@ -170,8 +173,10 @@ pyf srcSpan s = case runReader (runParserT (setPosition initPos >> parseGenericF -- Foo @"symbol" appTypeSymbol :: HsExpr GhcPs -> String -> HsExpr GhcPs -appTypeSymbol a name = appTypeAny a - (HsTyLit NoExtField (HsStrTy NoSourceText (mkFastString name))) +appTypeSymbol a name = + appTypeAny + a + (HsTyLit NoExtField (HsStrTy NoSourceText (mkFastString name))) -- Foo @Bar appType :: HsExpr GhcPs -> String -> HsExpr GhcPs @@ -191,6 +196,7 @@ appType' a name = appTypeAny a (HsTyVar noExtField' NotPromoted (L noSrcSpanA (mkUnqual tcName (mkFastString name)))) #endif +{- ORMOLU_DISABLE -} appTypeAny :: HsExpr GhcPs -> HsType GhcPs -> HsExpr GhcPs appTypeAny a b = #if MIN_VERSION_ghc(9,10,0) @@ -198,7 +204,7 @@ appTypeAny a b = #else HsAppType NoExtField (L noSrcSpanA a) (L NoTokenLoc (HsTok)) (HsWC NoExtField (L noSrcSpanA b)) #endif - +{- ORMOLU_ENABLE -} app :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs app a b = HsApp noExtField' (L noSrcSpanA a) (L noSrcSpanA b) @@ -358,13 +364,15 @@ instance LiftHsExpr AnyAlign where instance LiftHsExpr (HsExpr GhcPs) where liftHsExpr x = x -instance LiftHsExpr (GenLocated SrcSpanAnnA (HsExpr GhcPs)) where #if MIN_VERSION_ghc(9,10,0) +instance LiftHsExpr (GenLocated SrcSpanAnnA (HsExpr GhcPs)) where liftHsExpr x = HsPar (NoEpTok, NoEpTok) x #else +instance LiftHsExpr (GenLocated SrcSpanAnnA (HsExpr GhcPs)) where liftHsExpr x = HsPar noExtField' noHsTok x noHsTok #endif +{- ORMOLU_DISABLE -} mkTup :: [HsExpr GhcPs] -> HsExpr GhcPs mkTup l = ExplicitTuple @@ -378,6 +386,7 @@ mkTup l = l ) Boxed +{- ORMOLU_ENABLE -} toSignMode :: SignMode -> HsExpr GhcPs toSignMode Plus = ctor "Plus" diff --git a/test/Spec.hs b/test/Spec.hs index 8ed149a..25ee520 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -17,7 +17,7 @@ {-# LANGUAGE TypeOperators #-} -- This warning is disabled because any expression with literal leads to it. -{-# OPTIONS -Wno-type-defaults -fplugin=PyF.Plugin#-} +{-# OPTIONS -Wno-type-defaults #-} import qualified Data.ByteString import qualified Data.ByteString.Char8 From e97e5f39a8e3142688d4fb132046dac2826f8b91 Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Mon, 13 Jan 2025 19:15:59 +0400 Subject: [PATCH 16/17] Export fromSTring --- src/PyF.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/PyF.hs b/src/PyF.hs index 47200c0..0c609cf 100644 --- a/src/PyF.hs +++ b/src/PyF.hs @@ -27,11 +27,13 @@ module PyF -- qualified the symbols. module PyF.Formatters, module PyF.Internal.QQ, + fromString, ) where import Data.Char (isSpace) import Data.List (intercalate) +import Data.String (fromString) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import PyF.Class import PyF.Formatters From 5a0020048004d73592b24c6660f12b361574e9cc Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Mon, 13 Jan 2025 21:39:03 +0400 Subject: [PATCH 17/17] Fixup the naming, no more import crap --- src/PyF.hs | 10 +-- src/PyF/Plugin.hs | 119 ++++++++++++++++++++--------------- test/SpecCustomDelimiters.hs | 1 + 3 files changed, 70 insertions(+), 60 deletions(-) diff --git a/src/PyF.hs b/src/PyF.hs index 0c609cf..bb9a7ca 100644 --- a/src/PyF.hs +++ b/src/PyF.hs @@ -22,22 +22,14 @@ module PyF strConfig, addTrim, addFormatting, - -- This is reexported so plugin can use them once PyF is imported. - -- TODO: find a way to HIDE this. Maybe the source plugin can explicitly - -- qualified the symbols. - module PyF.Formatters, - module PyF.Internal.QQ, - fromString, ) where import Data.Char (isSpace) import Data.List (intercalate) -import Data.String (fromString) import Language.Haskell.TH.Quote (QuasiQuoter (..)) import PyF.Class -import PyF.Formatters -import PyF.Internal.QQ +import PyF.Internal.QQ (Config (..), expQQ, toExp, wrapFromString) -- | Generic formatter, can format an expression to any @t@ as long as -- @t@ is an instance of 'IsString'. diff --git a/src/PyF/Plugin.hs b/src/PyF/Plugin.hs index 74a21de..f2cdea6 100644 --- a/src/PyF/Plugin.hs +++ b/src/PyF/Plugin.hs @@ -7,6 +7,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -29,10 +30,12 @@ import Control.Monad (join) import Control.Monad.Reader (runReader) import Data.Generics import Data.Maybe (fromMaybe) +import Data.String +import GHC.ThToHs (thRdrNameGuesses) import GHC.TypeLits import qualified GHC.Types.Name.Occurrence as GHC.Types.Name.Occurence import GHC.Types.SourceText (SourceText (..), mkIntegralLit) -import PyF (defaultFloatPrecision, fmtConfig, trimIndent) +import PyF (PyFToString (..), fmtConfig, trimIndent) import PyF.Formatters import qualified PyF.Internal.Parser as ParseExp import PyF.Internal.PythonSyntax @@ -47,7 +50,7 @@ import PyF.Internal.PythonSyntax parseGenericFormatString, pattern DefaultFormatMode, ) -import PyF.Internal.QQ (Config (..), parseErrorToLocAndMessage) +import PyF.Internal.QQ (Config (..), PaddingK (..), defaultFloatPrecision, formatAny, formatAnyFractional, formatAnyIntegral, parseErrorToLocAndMessage) import Text.Parsec (runParserT) import Text.Parsec.Pos import Text.Parsec.Prim (setPosition) @@ -114,14 +117,14 @@ applyPyf loc s = do case itemsM of Left (theLoc, theMsg) -> do #if MIN_VERSION_ghc(9,10,0) - pure $ HsPar (NoEpTok, NoEpTok) (L ((EpAnn (EpaSpan $ RealSrcSpan (realSrcLocSpan theLoc) mempty) (AnnListItem []) emptyComments)) $ var "forceError" `app` (ctor "Proxy" `appTypeSymbol` theMsg)) + pure $ HsPar (NoEpTok, NoEpTok) (L ((EpAnn (EpaSpan $ RealSrcSpan (realSrcLocSpan theLoc) mempty) (AnnListItem []) emptyComments)) $ var 'forceError `app` (ctor 'Proxy `appTypeSymbol` theMsg)) #else - pure $ HsPar noExtField' noHsTok (L ((SrcSpanAnn noExtField' (RealSrcSpan (realSrcLocSpan theLoc) mempty))) $ var "forceError" `app` (ctor "Proxy" `appTypeSymbol` theMsg)) noHsTok + pure $ HsPar noExtField' noHsTok (L ((SrcSpanAnn noExtField' (RealSrcSpan (realSrcLocSpan theLoc) mempty))) $ var 'forceError `app` (ctor 'Proxy `appTypeSymbol` theMsg)) noHsTok #endif Right items -> do dynFlags <- getDynFlags let toOverloaded - | xopt LangExt.OverloadedStrings dynFlags = app (var "fromString") + | xopt LangExt.OverloadedStrings dynFlags = app (var 'fromString) | otherwise = id pure $ toOverloaded $ @@ -179,21 +182,21 @@ appTypeSymbol a name = (HsTyLit NoExtField (HsStrTy NoSourceText (mkFastString name))) -- Foo @Bar -appType :: HsExpr GhcPs -> String -> HsExpr GhcPs +appType :: HsExpr GhcPs -> RdrName -> HsExpr GhcPs appType a name = appTypeAny a #if MIN_VERSION_ghc(9,10,0) - (HsTyVar [] NotPromoted (noLocA (mkUnqual dataName (mkFastString name)))) + (HsTyVar [] NotPromoted (noLocA name)) #else - (HsTyVar noExtField' NotPromoted (L noSrcSpanA (mkUnqual dataName (mkFastString name)))) + (HsTyVar noExtField' NotPromoted (L noSrcSpanA name)) #endif -- Foo @Int -appType' :: HsExpr GhcPs -> String -> HsExpr GhcPs +appType' :: HsExpr GhcPs -> _ -> HsExpr GhcPs appType' a name = appTypeAny a #if MIN_VERSION_ghc(9,10,0) - (HsTyVar [] NotPromoted (noLocA $ mkUnqual tcName (mkFastString name))) + (HsTyVar [] NotPromoted (noLocA $ pyfName name)) #else - (HsTyVar noExtField' NotPromoted (L noSrcSpanA (mkUnqual tcName (mkFastString name)))) + (HsTyVar noExtField' NotPromoted (L noSrcSpanA (pyfName name))) #endif {- ORMOLU_DISABLE -} @@ -212,22 +215,18 @@ app a b = HsApp noExtField' (L noSrcSpanA a) (L noSrcSpanA b) app' :: HsExpr GhcPs -> (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> HsExpr GhcPs app' a b = HsApp noExtField' (L noSrcSpanA a) b -var :: String -> HsExpr GhcPs +var :: _ -> HsExpr GhcPs var name = ( HsVar NoExtField - ( L noSrcSpanA $ - mkUnqual GHC.Types.Name.Occurence.varName (mkFastString name) - ) + (L noSrcSpanA $ pyfName name) ) -ctor :: String -> HsExpr GhcPs +ctor :: _ -> HsExpr GhcPs ctor name = ( HsVar NoExtField - ( L noSrcSpanA $ - mkUnqual GHC.Types.Name.Occurence.dataName (mkFastString name) - ) + (L noSrcSpanA $ pyfName name) ) padAndFormat :: FormatModeT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (HsExpr GhcPs)) @@ -237,23 +236,23 @@ padAndFormat formatMode' = do FormatMode padding tf grouping <- formatModeM pure $ case tf of -- Integrals - BinaryF alt s -> var "formatAnyIntegral" `app` withAlt alt Binary `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 - CharacterF -> var "formatAnyIntegral" `app` ctor "Character" `app` ctor "Minus" `app` mkPadding padding `app` ctor "Nothing" - DecimalF s -> var "formatAnyIntegral" `app` ctor "Decimal" `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 - HexF alt s -> var "formatAnyIntegral" `app` withAlt alt Hexa `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 - OctalF alt s -> var "formatAnyIntegral" `app` withAlt alt Octal `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 - HexCapsF alt s -> var "formatAnyIntegral" `app` (ctor "Upper" `app` (withAlt alt Hexa)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + BinaryF alt s -> var 'formatAnyIntegral `app` withAlt alt Binary `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + CharacterF -> var 'formatAnyIntegral `app` ctor 'Character `app` ctor 'Minus `app` mkPadding padding `app` ctor 'Nothing + DecimalF s -> var 'formatAnyIntegral `app` ctor 'Decimal `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 + HexF alt s -> var 'formatAnyIntegral `app` withAlt alt Hexa `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + OctalF alt s -> var 'formatAnyIntegral `app` withAlt alt Octal `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 + HexCapsF alt s -> var 'formatAnyIntegral `app` (ctor 'Upper `app` (withAlt alt Hexa)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 4 -- Floating - GeneralF prec alt s -> var "formatAnyFractional" `app` withAlt alt Generic `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - GeneralCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Generic)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - ExponentialF prec alt s -> var "formatAnyFractional" `app` withAlt alt Exponent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - ExponentialCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Exponent)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - FixedF prec alt s -> var "formatAnyFractional" `app` withAlt alt Fixed `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - FixedCapsF prec alt s -> var "formatAnyFractional" `app` (ctor "Upper" `app` (withAlt alt Fixed)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec - PercentF prec alt s -> var "formatAnyFractional" `app` withAlt alt Percent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + GeneralF prec alt s -> var 'formatAnyFractional `app` withAlt alt Generic `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + GeneralCapsF prec alt s -> var 'formatAnyFractional `app` (ctor 'Upper `app` (withAlt alt Generic)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + ExponentialF prec alt s -> var 'formatAnyFractional `app` withAlt alt Exponent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + ExponentialCapsF prec alt s -> var 'formatAnyFractional `app` (ctor 'Upper `app` (withAlt alt Exponent)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + FixedF prec alt s -> var 'formatAnyFractional `app` withAlt alt Fixed `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + FixedCapsF prec alt s -> var 'formatAnyFractional `app` (ctor 'Upper `app` (withAlt alt Fixed)) `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec + PercentF prec alt s -> var 'formatAnyFractional `app` withAlt alt Percent `app` toSignMode s `app` mkPadding padding `app` toGrp grouping 3 `app` mkPrecision defaultFloatPrecision prec -- Default / String - DefaultF prec s -> var "formatAny" `app` toSignMode s `app` mkPaddingToPaddingK padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec - StringF prec -> (var ".") `app` (var "formatString" `app` (newPaddingKForString padding) `app` mkPrecision Nothing prec) `app` (var "pyfToString") + DefaultF prec s -> var 'formatAny `app` toSignMode s `app` mkPaddingToPaddingK padding `app` toGrp grouping 3 `app` mkPrecision Nothing prec + StringF prec -> (var '(.)) `app` (var 'formatString `app` (newPaddingKForString padding) `app` mkPrecision Nothing prec) `app` (var 'pyfToString) evalSubExpression :: FormatModeT (ExprOrValue Int) -> Hsc (Either (RealSrcLoc, String) (FormatModeT (LocatedA (HsExpr GhcPs)))) evalSubExpression (FormatMode padding tf grouping) = do @@ -311,15 +310,22 @@ evalPadding p = case p of i' <- exprToInt i pure $ Padding <$> i' <*> pure v +pyfName n = head $ thRdrNameGuesses n + mkPaddingToPaddingK :: PaddingT (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> HsExpr GhcPs mkPaddingToPaddingK p = case p of - PaddingDefault -> ctor "PaddingDefaultK" - Padding i Nothing -> appType (appType' (ctor "PaddingK") "Int") "AlignAll" `app'` i `app` (liftHsExpr $ (Nothing :: Maybe (Int, AnyAlign, Char))) - Padding i (Just (c, AnyAlign a)) -> ctor "PaddingK" `app'` i `app` liftHsExpr (Just (c, a)) + PaddingDefault -> ctor 'PaddingDefaultK + Padding i Nothing -> + appType + (appType' (ctor 'PaddingK) ''Int) + (pyfName 'PyF.Formatters.AlignAll) + `app'` i + `app` (liftHsExpr $ (Nothing :: Maybe (Int, AnyAlign, Char))) + Padding i (Just (c, AnyAlign a)) -> ctor 'PaddingK `app'` i `app` liftHsExpr (Just (c, a)) newPaddingKForString :: PaddingT (LocatedA (HsExpr GhcPs)) -> HsExpr GhcPs newPaddingKForString padding = case padding of - PaddingDefault -> ctor "Nothing" + PaddingDefault -> ctor 'Nothing Padding i Nothing -> liftHsExpr (Just (i, AlignLeft, ' ')) -- default align left and fill with space for string Padding i (Just (mc, AnyAlign a)) -> liftHsExpr (Just (i, a, fromMaybe ' ' mc)) @@ -341,11 +347,14 @@ instance (LiftHsExpr a, LiftHsExpr b, LiftHsExpr c) => LiftHsExpr (a, b, c) wher liftHsExpr (a, b, c) = mkTup [liftHsExpr a, liftHsExpr b, liftHsExpr c] instance (LiftHsExpr a) => LiftHsExpr (Maybe a) where - liftHsExpr Nothing = ctor "Nothing" - liftHsExpr (Just v) = ctor "Just" `app` liftHsExpr v + liftHsExpr Nothing = ctor 'Nothing + liftHsExpr (Just v) = ctor 'Just `app` liftHsExpr v instance LiftHsExpr (AlignMode k) where - liftHsExpr v = ctor (show v) + liftHsExpr AlignLeft = ctor 'AlignLeft + liftHsExpr AlignRight = ctor 'AlignRight + liftHsExpr AlignInside = ctor 'AlignInside + liftHsExpr AlignCenter = ctor 'AlignCenter instance LiftHsExpr Char where liftHsExpr c = HsLit noExtField' (HsChar NoSourceText c) @@ -354,12 +363,20 @@ instance LiftHsExpr Int where liftHsExpr i = HsLit noExtField' $ HsInt NoExtField (mkIntegralLit i) instance LiftHsExpr (Format k k' k'') where - liftHsExpr (Alternate v) = ctor "Alternate" `app` liftHsExpr v - liftHsExpr (Upper v) = ctor "Upper" `app` liftHsExpr v - liftHsExpr v = ctor (show v) + liftHsExpr (Alternate v) = ctor 'Alternate `app` liftHsExpr v + liftHsExpr (Upper v) = ctor 'Upper `app` liftHsExpr v + liftHsExpr Decimal = ctor 'Decimal + liftHsExpr Character = ctor 'Character + liftHsExpr Binary = ctor 'Binary + liftHsExpr Hexa = ctor 'Hexa + liftHsExpr Octal = ctor 'Octal + liftHsExpr Fixed = ctor 'Fixed + liftHsExpr Exponent = ctor 'Exponent + liftHsExpr Generic = ctor 'Generic + liftHsExpr Percent = ctor 'Percent instance LiftHsExpr AnyAlign where - liftHsExpr (AnyAlign v) = ctor "AnyAlign" `app` liftHsExpr v + liftHsExpr (AnyAlign v) = ctor 'AnyAlign `app` liftHsExpr v instance LiftHsExpr (HsExpr GhcPs) where liftHsExpr x = x @@ -389,12 +406,12 @@ mkTup l = {- ORMOLU_ENABLE -} toSignMode :: SignMode -> HsExpr GhcPs -toSignMode Plus = ctor "Plus" -toSignMode Minus = ctor "Minus" -toSignMode Space = ctor "Space" +toSignMode Plus = ctor 'Plus +toSignMode Minus = ctor 'Minus +toSignMode Space = ctor 'Space toGrp :: Maybe Char -> Int -> HsExpr GhcPs -toGrp Nothing _ = ctor "Nothing" +toGrp Nothing _ = ctor 'Nothing toGrp (Just v) a = liftHsExpr $ Just grp where grp = (a, v) @@ -404,8 +421,8 @@ withAlt NormalForm e = liftHsExpr e withAlt AlternateForm e = liftHsExpr (Alternate e) mkPrecision :: Maybe Int -> PrecisionT (LocatedA (HsExpr GhcPs)) -> HsExpr GhcPs -mkPrecision Nothing PrecisionDefault = ctor "Nothing" -mkPrecision (Just v) PrecisionDefault = ctor "Just" `app` (HsLit noExtField' $ HsInt NoExtField (mkIntegralLit v)) +mkPrecision Nothing PrecisionDefault = ctor 'Nothing +mkPrecision (Just v) PrecisionDefault = ctor 'Just `app` (HsLit noExtField' $ HsInt NoExtField (mkIntegralLit v)) mkPrecision _ (Precision p) = liftHsExpr (Just p) exprToInt :: ExprOrValue Int -> Hsc (Either (RealSrcLoc, String) (LocatedA (HsExpr GhcPs))) diff --git a/test/SpecCustomDelimiters.hs b/test/SpecCustomDelimiters.hs index b0b6d36..bf9d693 100644 --- a/test/SpecCustomDelimiters.hs +++ b/test/SpecCustomDelimiters.hs @@ -2,6 +2,7 @@ module SpecCustomDelimiters where import Language.Haskell.TH.Quote import PyF +import PyF.Internal.QQ myCustomFormatter :: QuasiQuoter myCustomFormatter =