PyF 0.9.0.0 → 0.9.0.1
raw patch · 16 files changed
+664/−791 lines, 16 filesdep ~basedep ~containersdep ~megaparsecsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, containers, megaparsec, template-haskell, text
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- PyF.cabal +5/−5
- Setup.hs +1/−0
- src/PyF.hs +16/−16
- src/PyF/Class.hs +28/−12
- src/PyF/Formatters.hs +121/−99
- src/PyF/Internal/Extensions.hs +10/−120
- src/PyF/Internal/PythonSyntax.hs +162/−161
- src/PyF/Internal/QQ.hs +84/−95
- test/Spec.hs +111/−123
- test/SpecCustomDelimiters.hs +1/−2
- test/SpecFail.hs +64/−93
- test/SpecOverloaded.hs +7/−8
- test/SpecUtils.hs +37/−45
- test/failureCases/bug18.hs +9/−8
- test/golden/2897849520519503487.golden +4/−4
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for PyF +## 0.9.0.1 -- 2020-03-25++- Fixs for GHC 8.10+ ## 0.9.0.0 -- 2019-12-29 - Any type with `Show` instance can be formatted using `:s` formatter. For example, `[fmt|hello {(True, 10):s}|]`. This breaks compatibility because previous version of PyF was generating an error when try to format to string anything which was not a string, now it accepts roughly anything (with a `Show` instance).
PyF.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: PyF-version: 0.9.0.0+version: 0.9.0.1 synopsis: Quasiquotations for a python like interpolated string formater description: Quasiquotations for a python like interpolated string formater. license: BSD-3-Clause@@ -20,13 +20,13 @@ PyF.Internal.Extensions PyF.Formatters - build-depends: base >= 4.9 && < 5.0- , template-haskell >= 2.14 && < 2.16+ build-depends: base >= 4.9 && < 5.0+ , template-haskell+ , text+ , containers -- Parsec and some transitive deps , megaparsec >= 7.0 && < 9.0- , text >= 0.11 && < 1.3- , containers >= 0.5 && < 0.7 , mtl -- haskell-src-meta < 0.8.2 does not correctly handle TypeApplication
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
src/PyF.hs view
@@ -1,27 +1,27 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeApplications #-}-{- | A lot of quasiquoters to format and interpolate string expression--}++-- | A lot of quasiquoters to format and interpolate string expression module PyF- ( fmt- -- * With custom delimiters- , fmtWithDelimiters- , module PyF.Class+ ( fmt,++ -- * With custom delimiters+ fmtWithDelimiters,+ module PyF.Class, ) where -import Language.Haskell.TH.Quote (QuasiQuoter(..))-import PyF.Internal.QQ (toExp)+import Language.Haskell.TH.Quote (QuasiQuoter (..)) import PyF.Class+import PyF.Internal.QQ (toExp) templateF :: (Char, Char) -> String -> QuasiQuoter-templateF delimiters fName = QuasiQuoter {- quoteExp = \s -> (toExp delimiters s)- , quotePat = err "pattern"- , quoteType = err "type"- , quoteDec = err "declaration"- }+templateF delimiters fName =+ QuasiQuoter+ { quoteExp = toExp delimiters,+ quotePat = err "pattern",+ quoteType = err "type",+ quoteDec = err "declaration"+ } where err name = error (fName ++ ": This QuasiQuoter can not be used as a " ++ name ++ "!")
src/PyF/Class.hs view
@@ -1,26 +1,25 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+ module PyF.Class where import Data.Int+import qualified Data.Text as SText+import qualified Data.Text.Lazy as LText import Data.Word import Numeric.Natural -import qualified Data.Text.Lazy as LText-import qualified Data.Text as SText- -- | The three categories of formatting in 'PyF' data PyFCategory- = PyFIntegral- -- ^ Format as an integral, no fractional part, precise value- | PyFFractional- -- ^ Format as a fractional, approximate value with a fractional part- | PyFString- -- ^ Format as a string+ = -- | Format as an integral, no fractional part, precise value+ PyFIntegral+ | -- | Format as a fractional, approximate value with a fractional part+ PyFFractional+ | -- | Format as a string+ PyFString -- | Classify a type to a 'PyFCategory' -- This classification will be used to decide which formatting to@@ -28,23 +27,37 @@ type family PyFClassify t :: PyFCategory type instance PyFClassify Integer = 'PyFIntegral+ type instance PyFClassify Int = 'PyFIntegral+ type instance PyFClassify Int8 = 'PyFIntegral+ type instance PyFClassify Int16 = 'PyFIntegral+ type instance PyFClassify Int32 = 'PyFIntegral+ type instance PyFClassify Int64 = 'PyFIntegral+ type instance PyFClassify Natural = 'PyFIntegral+ type instance PyFClassify Word = 'PyFIntegral+ type instance PyFClassify Word8 = 'PyFIntegral+ type instance PyFClassify Word16 = 'PyFIntegral+ type instance PyFClassify Word32 = 'PyFIntegral+ type instance PyFClassify Word64 = 'PyFIntegral type instance PyFClassify Float = 'PyFFractional+ type instance PyFClassify Double = 'PyFFractional type instance PyFClassify String = 'PyFString+ type instance PyFClassify LText.Text = 'PyFString+ type instance PyFClassify SText.Text = 'PyFString -- | Convert a type to string@@ -55,6 +68,9 @@ pyfToString = show instance PyFToString String where pyfToString = id+ instance PyFToString LText.Text where pyfToString = LText.unpack+ instance PyFToString SText.Text where pyfToString = SText.unpack+ instance {-# OVERLAPPABLE #-} Show t => PyFToString t where pyfToString = show
src/PyF/Formatters.hs view
@@ -1,58 +1,67 @@-{-# LANGUAGE DataKinds, KindSignatures, GADTs, ViewPatterns, OverloadedStrings, StandaloneDeriving, LambdaCase #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-}-{- |--Formatters for integral / fractional and strings.--Is support:--For all types:-- * Grouping of the integral part (i.e: adding a custom char to separate groups of digits)- * Padding (left, right, around, and between the sign and the number)- * Sign handling (i.e: display the positive sign or not)--For floating:-- * Precision- * Fixed / Exponential / Generic formatting--For integrals:-- * Binary / Hexa / Octal / Character representation--}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-} +-- |+--+-- Formatters for integral / fractional and strings.+--+-- Is support:+--+-- For all types:+--+-- * Grouping of the integral part (i.e: adding a custom char to separate groups of digits)+-- * Padding (left, right, around, and between the sign and the number)+-- * Sign handling (i.e: display the positive sign or not)+--+-- For floating:+--+-- * Precision+-- * Fixed / Exponential / Generic formatting+--+-- For integrals:+--+-- * Binary / Hexa / Octal / Character representation module PyF.Formatters- (- -- * Generic formating function- formatString- , formatIntegral- , formatFractional+ ( -- * Generic formating function+ formatString,+ formatIntegral,+ formatFractional,+ -- * Formatter details- , AltStatus(..)- , UpperStatus(..)- , FormatType (..)- , Format(..)- , SignMode(..)- , AnyAlign(..)+ AltStatus (..),+ UpperStatus (..),+ FormatType (..),+ Format (..),+ SignMode (..),+ AnyAlign (..),+ -- * Internal usage only- , AlignMode(..)- , getAlignForString- , AlignForString(..)-)+ AlignMode (..),+ getAlignForString,+ AlignForString (..),+ ) where +import Data.Char (chr, toUpper) import Data.List (intercalate)-import Data.Char (toUpper, chr)-import qualified Numeric import Language.Haskell.TH.Syntax+import qualified Numeric -- ADT for API+ -- | Sign handling-data SignMode = Plus -- ^ Display '-' sign and '+' sign- | Minus -- ^ Only display '-' sign- | Space -- ^ Display '-' sign and a space for positive numbers+data SignMode+ = -- | Display '-' sign and '+' sign+ Plus+ | -- | Only display '-' sign+ Minus+ | -- | Display '-' sign and a space for positive numbers+ Space deriving (Show) data AlignForString = AlignAll | AlignNumber@@ -72,11 +81,13 @@ deriving instance Show (AlignMode k) -- The generic version+ -- | Existential version of 'AlignMode' data AnyAlign where AnyAlign :: AlignMode (k :: AlignForString) -> AnyAlign deriving instance Show AnyAlign+ deriving instance Lift AnyAlign -- I hate how a must list all cases, any solution ?@@ -104,13 +115,11 @@ Binary :: Format 'CanAlt 'NoUpper 'Integral Hexa :: Format 'CanAlt 'CanUpper 'Integral Octal :: Format 'CanAlt 'NoUpper 'Integral- -- Fractionals Fixed :: Format 'CanAlt 'CanUpper 'Fractional Exponent :: Format 'CanAlt 'CanUpper 'Fractional Generic :: Format 'CanAlt 'CanUpper 'Fractional Percent :: Format 'CanAlt 'NoUpper 'Fractional- -- Meta formats Alternate :: Format 'CanAlt u f -> Format 'NoAlt u f -- Upper should come AFTER Alt, so this disallow any future alt@@ -131,7 +140,6 @@ Upper fmt' -> map toUpper $ format fmt' Character -> [chr (fromIntegral i)] Alternate fmt' -> format fmt'- (sign, iAbs) = splitSign i prefixIntegral :: Format t t' 'Integral -> String@@ -149,17 +157,16 @@ reprFractional fmt precision f | isInfinite f = Infinite sign (upperIt "inf") | isNaN f = NaN (upperIt "nan")- | isNegativeZero f = let (FractionalRepr Positive aa bb cc) = reprFractional fmt precision (abs f)- in FractionalRepr Negative aa bb cc+ | isNegativeZero f =+ let (FractionalRepr Positive aa bb cc) = reprFractional fmt precision (abs f)+ in FractionalRepr Negative aa bb cc | otherwise = FractionalRepr sign decimalPart fractionalPart suffixPart where upperIt s = case fmt of Upper _ -> toUpper <$> s _ -> s- (sign, iAbs) = splitSign f (decimalPart, fractionalPart, suffixPart) = format fmt- format :: Format t t' 'Fractional -> (String, String, String) format = \case Fixed -> splitFractional (Numeric.showFFloatAlt precision iAbs "")@@ -167,29 +174,35 @@ Generic -> splitFractionalExp (Numeric.showGFloatAlt precision iAbs "") Percent -> let (a, b, "") = splitFractional (Numeric.showFFloatAlt precision (iAbs * 100) "") in (a, b, "%") Alternate fmt' -> format fmt'- Upper fmt' -> let (a, b, c) = format fmt'- in (a, b, map toUpper c)-+ Upper fmt' ->+ let (a, b, c) = format fmt'+ in (a, b, map toUpper c) splitFractional :: String -> (String, String, String)- splitFractional s = let (a, b) = break (=='.') s- in (a, drop 1 b, "")+ splitFractional s =+ let (a, b) = break (== '.') s+ in (a, drop 1 b, "") overrideExponent :: Maybe Int -> (String, String, String) -> (String, String, String) overrideExponent (Just 0) (a, "0", c) = (a, "", c) overrideExponent _ o = o splitFractionalExp :: String -> (String, String, String)-splitFractionalExp s = let (a, b') = break (\c -> c == '.' || c == 'e' ) s- b = drop 1 b'- (fpart, e) = case b' of- 'e':_ -> ("", b')- _ -> break (=='e') b- in (a, fpart, case e of- 'e':'-':n -> "e-" ++ pad n- 'e':n -> "e+" ++ pad n- leftover -> leftover)- where pad n@[_] = '0':n- pad n = n+splitFractionalExp s =+ let (a, b') = break (\c -> c == '.' || c == 'e') s+ b = drop 1 b'+ (fpart, e) = case b' of+ 'e' : _ -> ("", b')+ _ -> break (== 'e') b+ in ( a,+ fpart,+ case e of+ 'e' : '-' : n -> "e-" ++ pad n+ 'e' : n -> "e+" ++ pad n+ leftover -> leftover+ )+ where+ pad n@[_] = '0' : n+ pad n = n -- Cases Integral / Fractional @@ -207,17 +220,16 @@ Infinite s str -> (formatSign s sign, str) NaN str -> ("", str) prefixStr = signStr <> prefix- len = length prefixStr + length content (leftAlignMode, rightAlignMode, middleAlignMode) = case padding of Nothing -> ("", "", "")- Just (pad, padMode, padC) -> let- padNeeded = max 0 (pad - len)- in case padMode of- AlignLeft -> ("", replicate padNeeded padC, "")- AlignRight -> (replicate padNeeded padC, "", "")- AlignCenter -> (replicate (padNeeded `div` 2) padC, replicate (padNeeded - padNeeded `div` 2) padC, "")- AlignInside -> ("", "", replicate padNeeded padC)+ Just (pad, padMode, padC) ->+ let padNeeded = max 0 (pad - len)+ in case padMode of+ AlignLeft -> ("", replicate padNeeded padC, "")+ AlignRight -> (replicate padNeeded padC, "", "")+ AlignCenter -> (replicate (padNeeded `div` 2) padC, replicate (padNeeded - padNeeded `div` 2) padC, "")+ AlignInside -> ("", "", replicate padNeeded padC) joinPoint :: Format t t' t'' -> String -> String -> String joinPoint (Upper f) a b = joinPoint f a b@@ -251,49 +263,59 @@ -- Final formatters -- | Format an integral number-formatIntegral :: (Show i, Integral i)- => Format t t' 'Integral- -> SignMode- -> Maybe (Int, AlignMode k, Char) -- ^ Padding- -> Maybe (Int, Char) -- ^ Grouping- -> i- -> String+formatIntegral ::+ (Show i, Integral i) =>+ Format t t' 'Integral ->+ SignMode ->+ -- | Padding+ Maybe (Int, AlignMode k, Char) ->+ -- | Grouping+ Maybe (Int, Char) ->+ i ->+ String formatIntegral f sign padding grouping i = padAndSign f (prefixIntegral f) sign padding (group (reprIntegral f i) grouping) -- | Format a fractional number-formatFractional- :: (RealFloat f)- => Format t t' 'Fractional- -> SignMode- -> Maybe (Int, AlignMode k, Char) -- ^ Padding- -> Maybe (Int, Char) -- ^ Grouping- -> Maybe Int -- ^ Precision- -> f- -> String+formatFractional ::+ (RealFloat f) =>+ Format t t' 'Fractional ->+ SignMode ->+ -- | Padding+ Maybe (Int, AlignMode k, Char) ->+ -- | Grouping+ Maybe (Int, Char) ->+ -- | Precision+ Maybe Int ->+ f ->+ String formatFractional f sign padding grouping precision i = padAndSign f "" sign padding (group (reprFractional f precision i) grouping) -- | Format a string-formatString- :: Maybe (Int, AlignMode 'AlignAll, Char) -- ^ Padding- -> Maybe Int -- ^ Precision (will truncate before padding)- -> String- -> String+formatString ::+ -- | Padding+ Maybe (Int, AlignMode 'AlignAll, Char) ->+ -- | Precision (will truncate before padding)+ Maybe Int ->+ String ->+ String formatString Nothing Nothing s = s formatString Nothing (Just i) s = take i s formatString (Just (padSize, padMode, padC)) size s = padLeft <> str <> padRight where str = formatString Nothing size s- paddingLength = max 0 (padSize - length str) (padLeft, padRight) = case padMode of- AlignLeft -> ("", replicate paddingLength padC)- AlignRight -> (replicate paddingLength padC, "")- AlignCenter -> (replicate (paddingLength `div` 2) padC, replicate (paddingLength - paddingLength `div` 2) padC)+ AlignLeft -> ("", replicate paddingLength padC)+ AlignRight -> (replicate paddingLength padC, "")+ AlignCenter -> (replicate (paddingLength `div` 2) padC, replicate (paddingLength - paddingLength `div` 2) padC)+ -- TODO {- the . -} deriving instance Lift (AlignMode k)+ deriving instance Lift SignMode+ deriving instance Lift (Format k k' k'')
src/PyF/Internal/Extensions.hs view
@@ -1,128 +1,18 @@ module PyF.Internal.Extensions- ( thExtToMetaExt- ) where+ ( thExtToMetaExt,+ )+where import qualified Language.Haskell.Exts.Extension as Exts import qualified Language.Haskell.TH as TH - -- | Associate a template haskell extension to an haskell-src-ext extension thExtToMetaExt :: TH.Extension -> Maybe Exts.Extension thExtToMetaExt e = Exts.EnableExtension <$> case e of- TH.Cpp -> Just Exts.CPP -- LOL, different case ;)- TH.OverlappingInstances -> Just Exts.OverlappingInstances- TH.UndecidableInstances -> Just Exts.UndecidableInstances- TH.IncoherentInstances -> Just Exts.IncoherentInstances- TH.MonomorphismRestriction -> Just Exts.MonomorphismRestriction- TH.MonoPatBinds -> Just Exts.MonoPatBinds- TH.MonoLocalBinds -> Just Exts.MonoLocalBinds- TH.RelaxedPolyRec -> Just Exts.RelaxedPolyRec- TH.ExtendedDefaultRules -> Just Exts.ExtendedDefaultRules- TH.ForeignFunctionInterface -> Just Exts.ForeignFunctionInterface- TH.UnliftedFFITypes -> Just Exts.UnliftedFFITypes- TH.InterruptibleFFI -> Just Exts.InterruptibleFFI- TH.CApiFFI -> Just Exts.CApiFFI- TH.GHCForeignImportPrim -> Just Exts.GHCForeignImportPrim- TH.JavaScriptFFI -> Just Exts.JavaScriptFFI- TH.ParallelArrays -> Just Exts.ParallelArrays- TH.Arrows -> Just Exts.Arrows- TH.TemplateHaskell -> Just Exts.TemplateHaskell- TH.QuasiQuotes -> Just Exts.QuasiQuotes- TH.ImplicitParams -> Just Exts.ImplicitParams- TH.ImplicitPrelude -> Just Exts.ImplicitPrelude- TH.ScopedTypeVariables -> Just Exts.ScopedTypeVariables- TH.UnboxedSums -> Just Exts.UnboxedSums- TH.BangPatterns -> Just Exts.BangPatterns- TH.TypeFamilies -> Just Exts.TypeFamilies- TH.TypeFamilyDependencies -> Just Exts.TypeFamilyDependencies- TH.OverloadedStrings -> Just Exts.OverloadedStrings- TH.DisambiguateRecordFields -> Just Exts.DisambiguateRecordFields- TH.RecordWildCards -> Just Exts.RecordWildCards- TH.RecordPuns -> Just Exts.RecordPuns- TH.ViewPatterns -> Just Exts.ViewPatterns- TH.GADTs -> Just Exts.GADTs- TH.NPlusKPatterns -> Just Exts.NPlusKPatterns- TH.DoAndIfThenElse -> Just Exts.DoAndIfThenElse- TH.RebindableSyntax -> Just Exts.RebindableSyntax- TH.ConstraintKinds -> Just Exts.ConstraintKinds- TH.PolyKinds -> Just Exts.PolyKinds- TH.DataKinds -> Just Exts.DataKinds- TH.InstanceSigs -> Just Exts.InstanceSigs- TH.StandaloneDeriving -> Just Exts.StandaloneDeriving- TH.DeriveDataTypeable -> Just Exts.DeriveDataTypeable- TH.DeriveFunctor -> Just Exts.DeriveFunctor- TH.DeriveTraversable -> Just Exts.DeriveTraversable- TH.DeriveFoldable -> Just Exts.DeriveFoldable- TH.DeriveGeneric -> Just Exts.DeriveGeneric- TH.DefaultSignatures -> Just Exts.DefaultSignatures- TH.DeriveAnyClass -> Just Exts.DeriveAnyClass- TH.DerivingStrategies -> Just Exts.DerivingStrategies- TH.TypeSynonymInstances -> Just Exts.TypeSynonymInstances- TH.FlexibleContexts -> Just Exts.FlexibleContexts- TH.FlexibleInstances -> Just Exts.FlexibleInstances- TH.ConstrainedClassMethods -> Just Exts.ConstrainedClassMethods- TH.MultiParamTypeClasses -> Just Exts.MultiParamTypeClasses- TH.FunctionalDependencies -> Just Exts.FunctionalDependencies- TH.UnicodeSyntax -> Just Exts.UnicodeSyntax- TH.ExistentialQuantification -> Just Exts.ExistentialQuantification- TH.MagicHash -> Just Exts.MagicHash- TH.EmptyDataDecls -> Just Exts.EmptyDataDecls- TH.KindSignatures -> Just Exts.KindSignatures- TH.RoleAnnotations -> Just Exts.RoleAnnotations- TH.ParallelListComp -> Just Exts.ParallelListComp- TH.TransformListComp -> Just Exts.TransformListComp- TH.GeneralizedNewtypeDeriving -> Just Exts.GeneralizedNewtypeDeriving- TH.RecursiveDo -> Just Exts.RecursiveDo- TH.PostfixOperators -> Just Exts.PostfixOperators- TH.TupleSections -> Just Exts.TupleSections- TH.PatternGuards -> Just Exts.PatternGuards- TH.LiberalTypeSynonyms -> Just Exts.LiberalTypeSynonyms- TH.RankNTypes -> Just Exts.RankNTypes- TH.ImpredicativeTypes -> Just Exts.ImpredicativeTypes- TH.TypeOperators -> Just Exts.TypeOperators- TH.ExplicitNamespaces -> Just Exts.ExplicitNamespaces- TH.PackageImports -> Just Exts.PackageImports- TH.ExplicitForAll -> Just Exts.ExplicitForAll- TH.DatatypeContexts -> Just Exts.DatatypeContexts- TH.NondecreasingIndentation -> Just Exts.NondecreasingIndentation- TH.LambdaCase -> Just Exts.LambdaCase- TH.MultiWayIf -> Just Exts.MultiWayIf- TH.BinaryLiterals -> Just Exts.BinaryLiterals- TH.OverloadedLabels -> Just Exts.OverloadedLabels- TH.EmptyCase -> Just Exts.EmptyCase- TH.PatternSynonyms -> Just Exts.PatternSynonyms- TH.PartialTypeSignatures -> Just Exts.PartialTypeSignatures- TH.NamedWildCards -> Just Exts.NamedWildCards- TH.TypeApplications -> Just Exts.TypeApplications-- -- Theses extensions have no associated extensions in haskell-src-exts- TH.UndecidableSuperClasses -> Nothing- TH.TemplateHaskellQuotes -> Nothing- TH.AllowAmbiguousTypes -> Nothing- TH.UnboxedTuples -> Nothing- TH.TypeInType -> Nothing- TH.OverloadedLists -> Nothing- TH.NumDecimals -> Nothing- TH.GADTSyntax -> Nothing- TH.BlockArguments -> Nothing- TH.ApplicativeDo -> Nothing- TH.AutoDeriveTypeable -> Nothing- TH.DeriveLift -> Nothing- TH.DerivingVia -> Nothing- TH.NullaryTypeClasses -> Nothing- TH.MonadComprehensions -> Nothing- TH.AlternativeLayoutRule -> Nothing- TH.AlternativeLayoutRuleTransitional -> Nothing- TH.RelaxedLayout -> Nothing- TH.TraditionalRecordSyntax -> Nothing- TH.NegativeLiterals -> Nothing- TH.HexFloatLiterals -> Nothing- TH.DuplicateRecordFields -> Nothing- TH.StaticPointers -> Nothing- TH.Strict -> Nothing- TH.StrictData -> Nothing- TH.MonadFailDesugaring -> Nothing- TH.EmptyDataDeriving -> Nothing- TH.NumericUnderscores -> Nothing- TH.QuantifiedConstraints -> Nothing- TH.StarIsType -> Nothing+ -- For some reason, the casing is different between TH and haskell-src-exts+ TH.Cpp -> Just Exts.CPP+ -- Hope for the best, if haskell-src-ext knows the extension or not+ _ -> case Exts.parseExtension (show e) of+ Exts.EnableExtension ext -> Just ext+ Exts.DisableExtension ext -> Just ext+ Exts.UnknownExtension _ -> Nothing
src/PyF/Internal/PythonSyntax.hs view
@@ -1,53 +1,48 @@-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DataKinds #-}-{- |-This module provides a parser for <https://docs.python.org/3.4/library/string.html#formatspec python format string mini language>.--}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++-- |+-- This module provides a parser for <https://docs.python.org/3.4/library/string.html#formatspec python format string mini language>. module PyF.Internal.PythonSyntax- ( parseGenericFormatString- , Item(..)- , FormatMode(..)- , Padding(..)- , Precision(..)- , TypeFormat(..)- , AlternateForm(..)- , pattern DefaultFormatMode- , Parser- , ParsingContext(..)- , ExprOrValue(..)+ ( parseGenericFormatString,+ Item (..),+ FormatMode (..),+ Padding (..),+ Precision (..),+ TypeFormat (..),+ AlternateForm (..),+ pattern DefaultFormatMode,+ Parser,+ ParsingContext (..),+ ExprOrValue (..), ) where -import Language.Haskell.TH.Syntax--import Text.Megaparsec-import qualified Text.Megaparsec.Char.Lexer as L-import Text.Megaparsec.Char-import Data.Void (Void) import Control.Monad.Reader- import qualified Data.Char- import Data.Maybe (fromMaybe)- import qualified Data.Set as Set -- For fancyFailure-import qualified Language.Haskell.Meta.Syntax.Translate as SyntaxTranslate-import qualified Language.Haskell.Exts.Parser as ParseExp+import Data.Void (Void) import qualified Language.Haskell.Exts.Extension as ParseExtension+import qualified Language.Haskell.Exts.Parser as ParseExp import qualified Language.Haskell.Exts.SrcLoc as SrcLoc+import qualified Language.Haskell.Meta.Syntax.Translate as SyntaxTranslate+import Language.Haskell.TH.Syntax import PyF.Formatters+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L type Parser t = ParsecT Void String (Reader ParsingContext) t -data ParsingContext = ParsingContext- { delimiters :: (Char, Char)- , enabledExtensions :: [ParseExtension.Extension]- }+data ParsingContext+ = ParsingContext+ { delimiters :: (Char, Char),+ enabledExtensions :: [ParseExtension.Extension]+ } deriving (Show) {-@@ -59,7 +54,6 @@ - types: n -} - {- f_string ::= (literal_char | "{{" | "}}" | replacement_field)* replacement_field ::= "{" f_expression ["!" conversion] [":" format_spec] "}"@@ -72,33 +66,34 @@ -} -- | A format string is composed of many chunks of raw string or replacement-data Item = Raw String -- ^ A raw string- | Replacement Exp (Maybe FormatMode) -- ^ A replacement string, composed of an arbitrary Haskell expression followed by an optional formatter- deriving (Show)--{- |-Parse a string, returns a list of raw string or replacement fields-->>> import Text.Megaparsec->>> parse parsePythonFormatString "" "hello {1+1:>10.2f}"-Right [- Raw "hello ",- Replacement "1+1"- (- Just (FormatMode- (Padding 10 (Just (Nothing,AnyAlign AlignRight)))- (FixedF (Precision 2) NormalForm Minus)- Nothing))]--}+data Item+ = -- | A raw string+ Raw String+ | -- | A replacement string, composed of an arbitrary Haskell expression followed by an optional formatter+ Replacement Exp (Maybe FormatMode)+ deriving (Show) +-- |+-- Parse a string, returns a list of raw string or replacement fields+--+-- >>> import Text.Megaparsec+-- >>> parse parsePythonFormatString "" "hello {1+1:>10.2f}"+-- Right [+-- Raw "hello ",+-- Replacement "1+1"+-- (+-- Just (FormatMode+-- (Padding 10 (Just (Nothing,AnyAlign AlignRight)))+-- (FixedF (Precision 2) NormalForm Minus)+-- Nothing))] parseGenericFormatString :: Parser [Item]-parseGenericFormatString = do+parseGenericFormatString = many (rawString <|> escapedParenthesis <|> replacementField) <* eof rawString :: Parser Item rawString = do- (openingChar, closingChar) <- delimiters <$> ask- chars <- some (noneOf ([openingChar, closingChar]))+ (openingChar, closingChar) <- asks delimiters+ chars <- some (noneOf [openingChar, closingChar]) case escapeChars chars of Left remaining -> do offset <- getOffset@@ -108,39 +103,36 @@ escapedParenthesis :: Parser Item escapedParenthesis = do- (openingChar, closingChar) <- delimiters <$> ask-+ (openingChar, closingChar) <- asks delimiters Raw <$> (parseRaw openingChar <|> parseRaw closingChar)- where parseRaw c = c:[] <$ string (replicate 2 c)+ where+ parseRaw c = [c] <$ string (replicate 2 c) -{- | Replace escape chars with their value. Results in a Left with the-remainder of the string on encountering a lexical error (such as a bad escape-sequence).->>> escapeChars "hello \\n"-Right "hello \n"->>> escapeChars "hello \\x"-Left "\\x"--}+-- | Replace escape chars with their value. Results in a Left with the+-- remainder of the string on encountering a lexical error (such as a bad escape+-- sequence).+-- >>> escapeChars "hello \\n"+-- Right "hello \n"+-- >>> escapeChars "hello \\x"+-- Left "\\x" escapeChars :: String -> Either String String escapeChars "" = Right ""-escapeChars ('\\':'\n':xs) = escapeChars xs-escapeChars ('\\':'\\':xs) = ('\\' :) <$> escapeChars xs+escapeChars ('\\' : '\n' : xs) = escapeChars xs+escapeChars ('\\' : '\\' : xs) = ('\\' :) <$> escapeChars xs escapeChars s = case Data.Char.readLitChar s of- ((c, xs):_) -> (c :) <$> escapeChars xs- _ -> Left s+ ((c, xs) : _) -> (c :) <$> escapeChars xs+ _ -> Left s replacementField :: Parser Item replacementField = do- exts <- enabledExtensions <$> ask- (charOpening, charClosing) <- delimiters <$> ask-+ exts <- asks enabledExtensions+ (charOpening, charClosing) <- asks delimiters _ <- char charOpening- expr <- evalExpr exts (many (noneOf (charClosing:":" :: [Char])))+ expr <- evalExpr exts (many (noneOf (charClosing : ":" :: String))) fmt <- optional $ do _ <- char ':'- format_spec+ formatSpec _ <- char charClosing- pure (Replacement expr fmt) -- | Default formating mode, no padding, default precision, no grouping, no sign handling@@ -149,12 +141,13 @@ -- | A Formatter, listing padding, format and and grouping char data FormatMode = FormatMode Padding TypeFormat (Maybe Char)- deriving (Show)+ deriving (Show) -- | Padding, containing the padding width, the padding char and the alignement mode-data Padding = PaddingDefault- | Padding Integer (Maybe (Maybe Char, AnyAlign))- deriving (Show)+data Padding+ = PaddingDefault+ | Padding Integer (Maybe (Maybe Char, AnyAlign))+ deriving (Show) -- | Represents a value of type @t@ or an Haskell expression supposed to represents that value data ExprOrValue t@@ -163,9 +156,11 @@ deriving (Show) -- | Floating point precision-data Precision = PrecisionDefault- | Precision (ExprOrValue Integer)- deriving (Show)+data Precision+ = PrecisionDefault+ | Precision (ExprOrValue Integer)+ deriving (Show)+ {- Python format mini language@@ -184,22 +179,37 @@ deriving (Show) -- | All formating type-data TypeFormat =- DefaultF Precision SignMode -- ^ Default, depends on the infered type of the expression- | BinaryF AlternateForm SignMode -- ^ Binary, such as `0b0121`- | CharacterF -- ^ Character, will convert an integer to its character representation- | DecimalF SignMode -- ^ Decimal, base 10 integer formatting- | ExponentialF Precision AlternateForm SignMode -- ^ Exponential notation for floatting points- | ExponentialCapsF Precision AlternateForm SignMode -- ^ Exponential notation with capitalised @e@- | FixedF Precision AlternateForm SignMode -- ^ Fixed number of digits floating point- | FixedCapsF Precision AlternateForm SignMode -- ^ Capitalized version of the previous- | GeneralF Precision AlternateForm SignMode -- ^ General formatting: `FixedF` or `ExponentialF` depending on the number magnitude- | GeneralCapsF Precision AlternateForm SignMode -- ^ Same as `GeneralF` but with upper case @E@ and infinite / NaN- | OctalF AlternateForm SignMode -- ^ Octal, such as 00245- | StringF Precision -- ^ Simple string- | HexF AlternateForm SignMode -- ^ Hexadecimal, such as 0xaf3e- | HexCapsF AlternateForm SignMode -- ^ Hexadecimal with capitalized letters, such as 0XAF3E- | PercentF Precision AlternateForm SignMode -- ^ Percent representation+data TypeFormat+ = -- | Default, depends on the infered type of the expression+ DefaultF Precision SignMode+ | -- | Binary, such as `0b0121`+ BinaryF AlternateForm SignMode+ | -- | Character, will convert an integer to its character representation+ CharacterF+ | -- | Decimal, base 10 integer formatting+ DecimalF SignMode+ | -- | Exponential notation for floatting points+ ExponentialF Precision AlternateForm SignMode+ | -- | Exponential notation with capitalised @e@+ ExponentialCapsF Precision AlternateForm SignMode+ | -- | Fixed number of digits floating point+ FixedF Precision AlternateForm SignMode+ | -- | Capitalized version of the previous+ FixedCapsF Precision AlternateForm SignMode+ | -- | General formatting: `FixedF` or `ExponentialF` depending on the number magnitude+ GeneralF Precision AlternateForm SignMode+ | -- | Same as `GeneralF` but with upper case @E@ and infinite / NaN+ GeneralCapsF Precision AlternateForm SignMode+ | -- | Octal, such as 00245+ OctalF AlternateForm SignMode+ | -- | Simple string+ StringF Precision+ | -- | Hexadecimal, such as 0xaf3e+ HexF AlternateForm SignMode+ | -- | Hexadecimal with capitalized letters, such as 0XAF3E+ HexCapsF AlternateForm SignMode+ | -- | Percent representation+ PercentF Precision AlternateForm SignMode deriving (Show) -- | If the formatter use its alternate form@@ -210,25 +220,20 @@ lastCharFailed err = do offset <- getOffset setOffset (offset - 1)- fancyFailure (Set.singleton (ErrorFail err)) evalExpr :: [ParseExtension.Extension] -> Parser String -> Parser Exp evalExpr exts exprParser = do offset <- getOffset s <- exprParser- -- Setup the parser using the provided list of extensions -- Which are detected by template haskell at splice position- let parseMode = ParseExp.defaultParseMode { ParseExp.extensions = exts }-+ let parseMode = ParseExp.defaultParseMode {ParseExp.extensions = exts} case SyntaxTranslate.toExp <$> ParseExp.parseExpWithMode parseMode s of ParseExp.ParseOk expr -> pure expr ParseExp.ParseFailed (SrcLoc.SrcLoc _name' line col) err -> do- let- linesBefore = take (line - 1) (lines s)- currentOffset = length (unlines linesBefore) + col - 1-+ let linesBefore = take (line - 1) (lines s)+ currentOffset = length (unlines linesBefore) + col - 1 setOffset (offset + currentOffset) fancyFailure (Set.singleton (ErrorFail err)) @@ -237,50 +242,42 @@ overrideAlignmentIfZero True (Just (Nothing, al)) = Just (Just '0', al) overrideAlignmentIfZero _ v = v -format_spec :: Parser FormatMode-format_spec = do+formatSpec :: Parser FormatMode+formatSpec = do al' <- optional alignment s <- optional sign alternateForm <- option NormalForm (AlternateForm <$ char '#')- hasZero <- option False (True <$ char '0')- let al = overrideAlignmentIfZero hasZero al'- w <- optional width-- grouping <- optional grouping_option-+ grouping <- optional groupingOption prec <- option PrecisionDefault parsePrecision t <- optional type_- let padding = case w of Just p -> Padding p al Nothing -> PaddingDefault- case t of Nothing -> pure (FormatMode padding (DefaultF prec (fromMaybe Minus s)) grouping) Just flag -> case evalFlag flag padding grouping prec alternateForm s of Right fmt -> pure (FormatMode padding fmt grouping)- Left typeError -> do+ Left typeError -> lastCharFailed typeError parsePrecision :: Parser Precision parsePrecision = do- exts <- enabledExtensions <$> ask- (charOpening, charClosing) <- delimiters <$> ask-+ exts <- asks enabledExtensions+ (charOpening, charClosing) <- asks delimiters _ <- char '.'- choice [- Precision . Value <$> precision,- char charOpening *> (Precision . HaskellExpr <$> evalExpr exts (manyTill anySingle (char charClosing)))+ choice+ [ Precision . Value <$> precision,+ char charOpening *> (Precision . HaskellExpr <$> evalExpr exts (manyTill anySingle (char charClosing))) ] evalFlag :: TypeFlag -> Padding -> Maybe Char -> Precision -> AlternateForm -> Maybe SignMode -> Either String TypeFormat evalFlag Flagb _pad _grouping prec alt s = failIfPrec prec (BinaryF alt (defSign s)) evalFlag Flagc _pad _grouping prec alt s = failIfS s =<< failIfPrec prec =<< failIfAlt alt CharacterF evalFlag Flagd _pad _grouping prec alt s = failIfPrec prec =<< failIfAlt alt (DecimalF (defSign s))-evalFlag Flage _pad _grouping prec alt s = pure $ExponentialF prec alt (defSign s)+evalFlag Flage _pad _grouping prec alt s = pure $ ExponentialF prec alt (defSign s) evalFlag FlagE _pad _grouping prec alt s = pure $ ExponentialCapsF prec alt (defSign s) evalFlag Flagf _pad _grouping prec alt s = pure $ FixedF prec alt (defSign s) evalFlag FlagF _pad _grouping prec alt s = pure $ FixedCapsF prec alt (defSign s)@@ -288,7 +285,7 @@ evalFlag FlagG _pad _grouping prec alt s = pure $ GeneralCapsF prec alt (defSign s) evalFlag Flagn _pad _grouping _prec _alt _s = Left ("Type 'n' not handled (yet). " ++ errgGn) evalFlag Flago _pad _grouping prec alt s = failIfPrec prec $ OctalF alt (defSign s)-evalFlag Flags pad grouping prec alt s = failIfGrouping grouping =<< failIfInsidePadding pad =<< failIfS s =<< (failIfAlt alt $ StringF prec)+evalFlag Flags pad grouping prec alt s = failIfGrouping grouping =<< failIfInsidePadding pad =<< failIfS s =<< failIfAlt alt (StringF prec) evalFlag Flagx _pad _grouping prec alt s = failIfPrec prec $ HexF alt (defSign s) evalFlag FlagX _pad _grouping prec alt s = failIfPrec prec $ HexCapsF alt (defSign s) evalFlag FlagPercent _pad _grouping prec alt s = pure $ PercentF prec alt (defSign s)@@ -330,12 +327,13 @@ toSignMode Space = ' ' alignment :: Parser (Maybe Char, AnyAlign)-alignment = choice [- try $ do+alignment =+ choice+ [ try $ do c <- fill mode <- align- pure (Just c, mode)- , do+ pure (Just c, mode),+ do mode <- align pure (Nothing, mode) ]@@ -344,19 +342,21 @@ fill = anySingle align :: Parser AnyAlign-align = choice [- AnyAlign AlignLeft <$ char '<',- AnyAlign AlignRight <$ char '>',- AnyAlign AlignCenter <$ char '^',- AnyAlign AlignInside <$ char '='- ]+align =+ choice+ [ AnyAlign AlignLeft <$ char '<',+ AnyAlign AlignRight <$ char '>',+ AnyAlign AlignCenter <$ char '^',+ AnyAlign AlignInside <$ char '='+ ] sign :: Parser SignMode-sign = choice- [Plus <$ char '+',- Minus <$ char '-',- Space <$ char ' '- ]+sign =+ choice+ [ Plus <$ char '+',+ Minus <$ char '-',+ Space <$ char ' '+ ] width :: Parser Integer width = integer@@ -364,27 +364,28 @@ integer :: Parser Integer integer = L.decimal -- incomplete: see: https://docs.python.org/3/reference/lexical_analysis.html#grammar-token-integer -grouping_option :: Parser Char-grouping_option = oneOf ("_," :: [Char])+groupingOption :: Parser Char+groupingOption = oneOf ("_," :: String) precision :: Parser Integer precision = integer type_ :: Parser TypeFlag-type_ = choice [- Flagb <$ char 'b',- Flagc <$ char 'c',- Flagd <$ char 'd',- Flage <$ char 'e',- FlagE <$ char 'E',- Flagf <$ char 'f',- FlagF <$ char 'F',- Flagg <$ char 'g',- FlagG <$ char 'G',- Flagn <$ char 'n',- Flago <$ char 'o',- Flags <$ char 's',- Flagx <$ char 'x',- FlagX <$ char 'X',- FlagPercent <$ char '%'- ]+type_ =+ choice+ [ Flagb <$ char 'b',+ Flagc <$ char 'c',+ Flagd <$ char 'd',+ Flage <$ char 'e',+ FlagE <$ char 'E',+ Flagf <$ char 'f',+ FlagF <$ char 'F',+ Flagg <$ char 'g',+ FlagG <$ char 'G',+ Flagn <$ char 'n',+ Flago <$ char 'o',+ Flags <$ char 's',+ Flagx <$ char 'x',+ FlagX <$ char 'X',+ FlagPercent <$ char '%'+ ]
src/PyF/Internal/QQ.hs view
@@ -1,60 +1,51 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-}--{- | This module uses the python mini language detailed in-'PyF.Internal.PythonSyntax' to build an template haskell expression-representing a formatted string.+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} --}-module PyF.Internal.QQ (- toExp,- toExpPython)+-- | 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,+ toExpPython,+ ) where -import Text.Megaparsec--import Language.Haskell.TH-+import Control.Monad.Reader import Data.Maybe (fromMaybe)- import qualified Data.Maybe-import Control.Monad.Reader--import PyF.Internal.PythonSyntax-import PyF.Internal.Extensions--import qualified PyF.Formatters as Formatters-import PyF.Formatters (AnyAlign(..)) import Data.Proxy+import Data.String (fromString) import GHC.TypeLits+import Language.Haskell.TH import PyF.Class-import Data.String (fromString)+import qualified PyF.Formatters as Formatters+import PyF.Formatters (AnyAlign (..))+import PyF.Internal.Extensions+import PyF.Internal.PythonSyntax+import Text.Megaparsec -- Be Careful: empty format string+ -- | Parse a string and return a formatter for it-toExp:: (Char, Char) -> String -> Q Exp+toExp :: (Char, Char) -> String -> Q Exp toExp expressionDelimiters s = do filename <- loc_filename <$> location- thExts <- extsEnabled let exts = Data.Maybe.mapMaybe thExtToMetaExt thExts-- let- wrapFromString e = if OverloadedStrings `elem` thExts- then [| fromString $(e) |]- else e-+ let wrapFromString e =+ if OverloadedStrings `elem` thExts+ then [|fromString $(e)|]+ else e let context = ParsingContext expressionDelimiters exts case runReader (runParserT parseGenericFormatString filename s) context of Left err -> do@@ -74,22 +65,21 @@ overrideErrorForFile filename err = do (line, col) <- loc_start <$> location fileContent <- runIO (readFile filename)-- let- -- drop the first lines of the file up to the line containing the quasiquote- -- then, split in what is before the QQ and what is after.- -- e.g. blablabla [fmt|hello|] will split to- -- "blablabla [fmt|" and "hello|]"- (prefix, postfix) = splitAt (col - 1) $ unlines $ drop (line - 1) (lines fileContent)--- pure $ err {- bundlePosState = (bundlePosState err) {- pstateInput = postfix,- pstateSourcePos = SourcePos filename (mkPos line) (mkPos col),- pstateOffset = 0,- pstateLinePrefix = prefix- }}+ let -- drop the first lines of the file up to the line containing the quasiquote+ -- then, split in what is before the QQ and what is after.+ -- e.g. blablabla [fmt|hello|] will split to+ -- "blablabla [fmt|" and "hello|]"+ (prefix, postfix) = splitAt (col - 1) $ unlines $ drop (line - 1) (lines fileContent)+ pure $+ err+ { bundlePosState =+ (bundlePosState err)+ { pstateInput = postfix,+ pstateSourcePos = SourcePos filename (mkPos line) (mkPos col),+ pstateOffset = 0,+ pstateLinePrefix = prefix+ }+ } toExpPython :: String -> Q Exp toExpPython = toExp ('{', '}')@@ -102,7 +92,7 @@ goFormat :: [Item] -> Q Exp goFormat [] = pure $ LitE (StringL "") -- see [Empty String Lifting]-goFormat items = foldl1 fofo <$> (mapM toFormat items)+goFormat items = foldl1 fofo <$> mapM toFormat items fofo :: Exp -> Exp -> Exp fofo s0 s1 = InfixE (Just s0) (VarE '(<>)) (Just s1)@@ -121,63 +111,63 @@ -- | Precision to maybe splicePrecision :: Maybe Int -> Precision -> Q Exp-splicePrecision def PrecisionDefault = [| def |]+splicePrecision def PrecisionDefault = [|def|] splicePrecision _ (Precision p) = case p of- Value n -> [| Just n |]- HaskellExpr e -> [| Just $(pure e) |]+ Value n -> [|Just n|]+ HaskellExpr e -> [|Just $(pure e)|] toGrp :: Maybe Char -> Int -> Q Exp-toGrp mb a = [| grp |]- where grp = (a,) <$> mb+toGrp mb a = [|grp|]+ where+ grp = (a,) <$> mb withAlt :: AlternateForm -> Formatters.Format t t' t'' -> Q Exp-withAlt NormalForm e = [| e |]-withAlt AlternateForm e = [| Formatters.Alternate e |]+withAlt NormalForm e = [|e|]+withAlt AlternateForm e = [|Formatters.Alternate e|] padAndFormat :: FormatMode -> Q Exp padAndFormat (FormatMode padding tf grouping) = case tf of -- Integrals- BinaryF alt s -> [| formatAnyIntegral $(withAlt alt Formatters.Binary) s $(newPaddingQ padding) $(toGrp grouping 4) |]- CharacterF -> [| formatAnyIntegral Formatters.Character Formatters.Minus $(newPaddingQ padding) Nothing |]- DecimalF s -> [| formatAnyIntegral Formatters.Decimal s $(newPaddingQ padding) $(toGrp grouping 3) |]- HexF alt s -> [| formatAnyIntegral $(withAlt alt Formatters.Hexa) s $(newPaddingQ padding) $(toGrp grouping 4) |]- OctalF alt s -> [| formatAnyIntegral $(withAlt alt Formatters.Octal) s $(newPaddingQ padding) $(toGrp grouping 4) |]- HexCapsF alt s -> [| formatAnyIntegral (Formatters.Upper $(withAlt alt Formatters.Hexa)) s $(newPaddingQ padding) $(toGrp grouping 4) |]-+ BinaryF alt s -> [|formatAnyIntegral $(withAlt alt Formatters.Binary) s $(newPaddingQ padding) $(toGrp grouping 4)|]+ CharacterF -> [|formatAnyIntegral Formatters.Character Formatters.Minus $(newPaddingQ padding) Nothing|]+ DecimalF s -> [|formatAnyIntegral Formatters.Decimal s $(newPaddingQ padding) $(toGrp grouping 3)|]+ HexF alt s -> [|formatAnyIntegral $(withAlt alt Formatters.Hexa) s $(newPaddingQ padding) $(toGrp grouping 4)|]+ OctalF alt s -> [|formatAnyIntegral $(withAlt alt Formatters.Octal) s $(newPaddingQ padding) $(toGrp grouping 4)|]+ HexCapsF alt s -> [|formatAnyIntegral (Formatters.Upper $(withAlt alt Formatters.Hexa)) s $(newPaddingQ padding) $(toGrp grouping 4)|] -- Floating- ExponentialF prec alt s -> [| formatAnyFractional $(withAlt alt Formatters.Exponent) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision 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 -> [| formatAnyFractional $(withAlt alt Formatters.Generic) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision 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 -> [| formatAnyFractional $(withAlt alt Formatters.Fixed) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision 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 -> [| formatAnyFractional $(withAlt alt Formatters.Percent) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec) |]-+ ExponentialF prec alt s -> [|formatAnyFractional $(withAlt alt Formatters.Exponent) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision 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 -> [|formatAnyFractional $(withAlt alt Formatters.Generic) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision 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 -> [|formatAnyFractional $(withAlt alt Formatters.Fixed) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision 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 -> [|formatAnyFractional $(withAlt alt Formatters.Percent) s $(newPaddingQ padding) $(toGrp grouping 3) $(splicePrecision defaultFloatPrecision prec)|] -- Default / String- DefaultF prec s -> [| formatAny s $(paddingToPaddingK padding) $(toGrp grouping 3) $(splicePrecision Nothing prec) |]- StringF prec -> [| Formatters.formatString (newPaddingKForString $(paddingToPaddingK padding)) $(splicePrecision Nothing prec) . pyfToString |]+ DefaultF prec s -> [|formatAny s $(paddingToPaddingK padding) $(toGrp grouping 3) $(splicePrecision Nothing prec)|]+ StringF prec -> [|Formatters.formatString (newPaddingKForString $(paddingToPaddingK padding)) $(splicePrecision Nothing prec) . pyfToString|] newPaddingQ :: Padding -> Q Exp-newPaddingQ pad = [| pad' |]- where pad' = newPaddingUnQ pad+newPaddingQ pad = [|pad'|]+ where+ pad' = newPaddingUnQ pad newPaddingUnQ :: Padding -> Maybe (Integer, AnyAlign, Char) newPaddingUnQ padding = case padding of- PaddingDefault -> Nothing- (Padding i al) -> case al of- Nothing -> Just (i, AnyAlign Formatters.AlignRight, ' ') -- Right align and space is default for any object, except string- Just (Nothing, a) -> Just (i, a, ' ')- Just (Just c, a) -> Just (i, a, c)+ PaddingDefault -> Nothing+ (Padding i al) -> case al of+ Nothing -> Just (i, AnyAlign Formatters.AlignRight, ' ') -- Right align and space is default for any object, except string+ Just (Nothing, a) -> Just (i, a, ' ')+ Just (Just c, a) -> Just (i, a, c) data PaddingK k where PaddingDefaultK :: PaddingK 'Formatters.AlignAll- PaddingK :: Integer -> (Maybe (Maybe Char, Formatters.AlignMode k)) -> PaddingK k+ PaddingK :: Integer -> Maybe (Maybe Char, Formatters.AlignMode k) -> PaddingK k paddingToPaddingK :: Padding -> Q Exp paddingToPaddingK p = case p of- PaddingDefault -> [| PaddingDefaultK |]- Padding i Nothing -> [| PaddingK i Nothing :: PaddingK 'Formatters.AlignAll |]- Padding i (Just (c, AnyAlign a)) -> [| PaddingK i (Just (c, a)) |]+ PaddingDefault -> [|PaddingDefaultK|]+ Padding i Nothing -> [|PaddingK i Nothing :: PaddingK 'Formatters.AlignAll|]+ Padding i (Just (c, AnyAlign a)) -> [|PaddingK i (Just (c, a))|] paddingKToPadding :: PaddingK k -> Padding paddingKToPadding p = case p of@@ -203,17 +193,16 @@ formatAny2 :: Proxy c -> Formatters.SignMode -> PaddingK k -> Maybe (Int, Char) -> Maybe Int -> i -> String instance (Show t, Integral t) => FormatAny2 'PyFIntegral t k where- formatAny2 _ s a p _precision i = formatAnyIntegral Formatters.Decimal s (newPaddingUnQ (paddingKToPadding a)) p i+ formatAny2 _ s a p _precision = formatAnyIntegral Formatters.Decimal s (newPaddingUnQ (paddingKToPadding a)) p instance (RealFloat t) => FormatAny2 'PyFFractional t k where- formatAny2 _ s a p precision t = formatAnyFractional Formatters.Generic s (newPaddingUnQ (paddingKToPadding a)) p precision t+ formatAny2 _ s a = formatAnyFractional Formatters.Generic s (newPaddingUnQ (paddingKToPadding a)) newPaddingKForString :: PaddingK 'Formatters.AlignAll -> Maybe (Int, Formatters.AlignMode 'Formatters.AlignAll, Char) newPaddingKForString padding = case padding of- PaddingDefaultK -> Nothing- PaddingK i Nothing -> Just (fromIntegral i, Formatters.AlignLeft, ' ') -- default align left and fill with space for string- PaddingK i (Just (mc, a)) -> Just (fromIntegral i, a, fromMaybe ' ' mc)-+ PaddingDefaultK -> Nothing+ PaddingK i Nothing -> Just (fromIntegral i, Formatters.AlignLeft, ' ') -- default align left and fill with space for string+ PaddingK i (Just (mc, a)) -> Just (fromIntegral i, a, fromMaybe ' ' mc) -- TODO: _s(ign) and _grouping should trigger errors instance (PyFToString t) => FormatAny2 'PyFString t 'Formatters.AlignAll where
test/Spec.hs view
@@ -1,18 +1,19 @@-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveAnyClass, GeneralizedNewtypeDeriving, DerivingStrategies #-} -import Test.Hspec-+import Data.Text import PyF-import SpecUtils import SpecCustomDelimiters-import Data.Text+import SpecUtils+import Test.Hspec {- - Normal tests are done using the recommanded API: [fmt|.....|]@@ -41,17 +42,19 @@ pyfToString Foo = "I'm a Foo" type instance PyFClassify Foo = 'PyFString+ type instance PyFClassify FooFloating = 'PyFFractional+ type instance PyFClassify FooIntegral = 'PyFIntegral+ type instance PyFClassify FooDefault = 'PyFString spec :: Spec spec = do describe "simple with external variable" $ do- let- anInt = 123- aFloat = 0.234- aString = "hello"+ let anInt = 123+ aFloat = 0.234+ aString = "hello" it "int" $ [fmt|{anInt}|] `shouldBe` "123" it "float" $ [fmt|{aFloat}|] `shouldBe` "0.234" it "string" $ [fmt|{aString}|] `shouldBe` "hello"@@ -69,7 +72,7 @@ it "simple" $(checkExample "{123:b}" "1111011") it "alt" $(checkExample "{123:#b}" "0b1111011") it "sign" $(checkExample "{123:+#b}" "+0b1111011")- describe "character" $ do+ describe "character" $ it "simple" $(checkExample "{123:c}" "{") describe "decimal" $ do it "simple" $(checkExample "{123:d}" "123")@@ -115,10 +118,8 @@ describe "percent" $ do it "simple" $(checkExample "{0.234:%}" "23.400000%") it "precision" $(checkExample "{0.234:.2%}" "23.40%")-- describe "string truncating" $ do- it "works" $ $(checkExample "{\"hello\":.3}" "hel")-+ describe "string truncating" $+ it "works" $(checkExample "{\"hello\":.3}" "hel") describe "padding" $ do describe "default char" $ do it "left" $(checkExample "{\"hello\":<10}" "hello ")@@ -142,43 +143,42 @@ it "default" $(checkExample "{1.0:10}" " 1.0") it "default" $(checkExample "{\"h\":10}" "h ") describe "NaN" $ do- let nan = 0.0 / 0- it "nan" $(checkExample "{nan}" "nan")- it "nan f" $(checkExample "{nan:f}" "nan")- it "nan e" $(checkExample "{nan:e}" "nan")- it "nan g" $(checkExample "{nan:g}" "nan")- it "nan F" $(checkExample "{nan:F}" "NAN")- it "nan G" $(checkExample "{nan:G}" "NAN")- it "nan E" $(checkExample "{nan:E}" "NAN")+ let nan = 0.0 / 0+ it "nan" $(checkExample "{nan}" "nan")+ it "nan f" $(checkExample "{nan:f}" "nan")+ it "nan e" $(checkExample "{nan:e}" "nan")+ it "nan g" $(checkExample "{nan:g}" "nan")+ it "nan F" $(checkExample "{nan:F}" "NAN")+ it "nan G" $(checkExample "{nan:G}" "NAN")+ it "nan E" $(checkExample "{nan:E}" "NAN") describe "Infinite" $ do- let inf = 1.0 / 0- it "infinite" $(checkExample "{inf}" "inf")- it "infinite f" $(checkExample "{inf:f}" "inf")- it "infinite e" $(checkExample "{inf:e}" "inf")- it "infinite g" $(checkExample "{inf:g}" "inf")- it "infinite F" $(checkExample "{inf:F}" "INF")- it "infinite G" $(checkExample "{inf:G}" "INF")- it "infinite E" $(checkExample "{inf:E}" "INF")+ let inf = 1.0 / 0+ it "infinite" $(checkExample "{inf}" "inf")+ it "infinite f" $(checkExample "{inf:f}" "inf")+ it "infinite e" $(checkExample "{inf:e}" "inf")+ it "infinite g" $(checkExample "{inf:g}" "inf")+ it "infinite F" $(checkExample "{inf:F}" "INF")+ it "infinite G" $(checkExample "{inf:G}" "INF")+ it "infinite E" $(checkExample "{inf:E}" "INF") describe "Grouping" $ do- it "groups int" $(checkExample "{123456789:,d}" "123,456,789")- it "groups int with _" $(checkExample "{123456789:_d}" "123_456_789")- it "groups float" $(checkExample "{123456789.234:,f}" "123,456,789.234000")- it "groups bin" $(checkExample "{123456789:_b}" "111_0101_1011_1100_1101_0001_0101")- it "groups hex" $(checkExample "{123456789:_x}" "75b_cd15")- it "groups oct" $(checkExample "{123456789:_o}" "7_2674_6425")+ it "groups int" $(checkExample "{123456789:,d}" "123,456,789")+ it "groups int with _" $(checkExample "{123456789:_d}" "123_456_789")+ it "groups float" $(checkExample "{123456789.234:,f}" "123,456,789.234000")+ it "groups bin" $(checkExample "{123456789:_b}" "111_0101_1011_1100_1101_0001_0101")+ it "groups hex" $(checkExample "{123456789:_x}" "75b_cd15")+ it "groups oct" $(checkExample "{123456789:_o}" "7_2674_6425") describe "negative zero" $ do- it "f" $(checkExample "{-0.0:f}" "-0.000000")- it "e" $(checkExample "{-0.0:e}" "-0.000000e+00")- it "g" $(checkExampleDiff "{-0.0:g}" "-0.000000")- it "F" $(checkExample "{-0.0:F}" "-0.000000")- it "G" $(checkExampleDiff "{-0.0:G}" "-0.000000")- it "E" $(checkExample "{-0.0:E}" "-0.000000E+00")+ it "f" $(checkExample "{-0.0:f}" "-0.000000")+ it "e" $(checkExample "{-0.0:e}" "-0.000000e+00")+ it "g" $(checkExampleDiff "{-0.0:g}" "-0.000000")+ it "F" $(checkExample "{-0.0:F}" "-0.000000")+ it "G" $(checkExampleDiff "{-0.0:G}" "-0.000000")+ it "E" $(checkExample "{-0.0:E}" "-0.000000E+00") describe "0" $ do- it "works" $(checkExample "{123:010}" "0000000123")- it "works with sign" $(checkExample "{-123:010}" "-000000123")- it "accept mode override" $(checkExample "{-123:<010}" "-123000000")- it "accept mode and char override" $(checkExample "{-123:.<010}" "-123......")-+ it "works" $(checkExample "{123:010}" "0000000123")+ it "works with sign" $(checkExample "{-123:010}" "-000000123")+ it "accept mode override" $(checkExample "{-123:<010}" "-123000000")+ it "accept mode and char override" $(checkExample "{-123:.<010}" "-123......") describe "no digit no dot" $ do it "f" $(checkExample "{1.0:.0f}" "1") it "e" $(checkExample "{1.0:.0e}" "1e+00")@@ -193,99 +193,87 @@ it "E" $(checkExample "{1.0:#.0E}" "1.E+00") it "G" $(checkExample "{1.0:#.0G}" "1.") it "percent" $(checkExample "{1.0:#.0%}" "100.%")-- describe "complex" $ do- it "works with many things at once" $- let- name = "Guillaume"- age = 31- euroToFrancs = 6.55957- in- [fmt|hello {name} you are {age} years old and the conversion rate of euro is {euroToFrancs:.2}|] `shouldBe` ("hello Guillaume you are 31 years old and the conversion rate of euro is 6.56")--- describe "error reporting" $ do+ describe "complex"+ $ it "works with many things at once"+ $ let name = "Guillaume"+ age = 31+ euroToFrancs = 6.55957+ in [fmt|hello {name} you are {age} years old and the conversion rate of euro is {euroToFrancs:.2}|] `shouldBe` "hello Guillaume you are 31 years old and the conversion rate of euro is 6.56"+ describe "error reporting" $ pure () -- TODO: find a way to test error reporting-- describe "sub expressions" $ do- it "works" $ do- [fmt|2pi = {2 * pi:.2}|] `shouldBe` "2pi = 6.28"-- describe "escape strings" $ do- it "works" $ do- [fmt|hello \n\b|] `shouldBe` "hello \n\b"-- describe "variable precision" $ do- it "works" $ do+ describe "sub expressions"+ $ it "works"+ $ [fmt|2pi = {2 * pi:.2}|] `shouldBe` "2pi = 6.28"+ describe "escape strings"+ $ it "works"+ $ [fmt|hello \n\b|] `shouldBe` "hello \n\b"+ describe "variable precision"+ $ it "works"+ $ do let n = 3 :: Int [fmt|{pi:.{n}}|] `shouldBe` "3.142"-- it "escape chars" $ do- [fmt|}}{{}}{{|] `shouldBe` "}{}{"--+ it "escape chars" $+ [fmt|}}{{}}{{|] `shouldBe` "}{}{" describe "custom delimiters" $ do- it "works" $ do+ it "works" $ [myCustomFormatter|2 * pi = @2*pi:.2f!|] `shouldBe` "2 * pi = 6.28"- it "escape chars" $ do- [myCustomFormatter|@@!!@@!!|] `shouldBe` "@!@!"- it "works for custom precision" $ do- [myCustomFormatter|@pi:.@2!!|] `shouldBe` "3.14"-- describe "empty line" $ do- it "works" $ do- [fmt||] `shouldBe` ""-+ it "escape chars" $+ [myCustomFormatter|@@!!@@!!|] `shouldBe` "@!@!"+ it "works for custom precision" $+ [myCustomFormatter|@pi:.@2!!|] `shouldBe` "3.14"+ describe "empty line"+ $ it "works"+ $ [fmt||] `shouldBe` "" describe "multi line escape" $ do- it "works" $ do+ it "works" $ [fmt|\ - a - b \-|] `shouldBe` "- a\n- b\n"-- it "escapes in middle of line" $ do+|]+ `shouldBe` "- a\n- b\n"+ it "escapes in middle of line" $ [fmt|Example goes \-here!|] `shouldBe` "Example goes here!"-- it "escapes a lot of things" $ do+here!|]+ `shouldBe` "Example goes here!"+ it "escapes a lot of things" $ [fmt|\ I'm a line with \n and \\ and a correct line ending, but that one is escaped\ And I'm escaping before and after: \\{pi:.3f}\\ yeah\-|] `shouldBe` "I'm a line with \n and \\ and a correct line\nending, but that one is escapedAnd I'm escaping before and after: \\3.142\\\nyeah"-- it "escapes" $ do+|]+ `shouldBe` "I'm a line with \n and \\ and a correct line\nending, but that one is escapedAnd I'm escaping before and after: \\3.142\\\nyeah"+ it "escapes" $ [fmt|\\ - a - b \-|] `shouldBe` "\\\n- a\n- b\n"-- describe "empty trailing value" $ do- it "String" $ do- ([fmt|\+|]+ `shouldBe` "\\\n- a\n- b\n"+ describe "empty trailing value"+ $ it "String"+ $ ( [fmt|\ {pi:.0}-|] :: String) `shouldBe` "3\n"-+|] ::+ String+ )+ `shouldBe` "3\n" describe "language extensions" $ do- it "parses @Int" $ do- [fmt|hello {show @Int 10}|] `shouldBe` "hello 10"- it "parses BinaryLiterals" $ do- [fmt|hello {0b1111}|] `shouldBe` "hello 15"--+ it "parses @Int" $+ [fmt|hello {show @Int 10}|] `shouldBe` "hello 10"+ it "parses BinaryLiterals" $+ [fmt|hello {0b1111}|] `shouldBe` "hello 15" describe "custom types" $ do- it "works with integral" $ do- [fmt|{FooIntegral 10:d}|] `shouldBe` "10"- it "works with floating" $ do- [fmt|{FooFloating 25.123:f}|] `shouldBe` "25.123000"- it "works with string" $ do- [fmt|{Foo:s}|] `shouldBe` "I'm a Foo"- [fmt|{FooDefault:s}|] `shouldBe` "FooDefault"- it "works with classify" $ do- [fmt|{Foo}|] `shouldBe` "I'm a Foo"- [fmt|{FooIntegral 100}|] `shouldBe` "100"- [fmt|{FooFloating 100.123}|] `shouldBe` "100.123"- [fmt|{FooDefault}|] `shouldBe` "FooDefault"+ it "works with integral" $+ [fmt|{FooIntegral 10:d}|] `shouldBe` "10"+ it "works with floating" $+ [fmt|{FooFloating 25.123:f}|] `shouldBe` "25.123000"+ it "works with string" $ do+ [fmt|{Foo:s}|] `shouldBe` "I'm a Foo"+ [fmt|{FooDefault:s}|] `shouldBe` "FooDefault"+ it "works with classify" $ do+ [fmt|{Foo}|] `shouldBe` "I'm a Foo"+ [fmt|{FooIntegral 100}|] `shouldBe` "100"+ [fmt|{FooFloating 100.123}|] `shouldBe` "100.123"+ [fmt|{FooDefault}|] `shouldBe` "FooDefault"
test/SpecCustomDelimiters.hs view
@@ -1,8 +1,7 @@ module SpecCustomDelimiters where import Language.Haskell.TH.Quote- import PyF myCustomFormatter :: QuasiQuoter-myCustomFormatter = fmtWithDelimiters ('@','!')+myCustomFormatter = fmtWithDelimiters ('@', '!')
test/SpecFail.hs view
@@ -1,29 +1,24 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-}--import Test.Hspec-import Test.HUnit.Lang--import System.Process (readProcessWithExitCode)-import System.Exit--import qualified Data.Text as Text- -import System.IO.Temp-import qualified System.IO as IO+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE ScopedTypeVariables #-} +import Control.DeepSeq+import Control.Exception import Data.Hashable+import qualified Data.Text as Text+import System.Exit import System.FilePath-import Control.Exception-import Control.DeepSeq+import qualified System.IO as IO+import System.IO.Temp+import System.Process (readProcessWithExitCode)+import Test.HUnit.Lang+import Test.Hspec -- * Check compilation with external GHC (this is usefull to test compilation failure) data CompilationStatus- = CompileError String -- ^ Fails during compilation (with error)+ = -- | Fails during compilation (with error)+ CompileError String | RuntimeError String | Ok String deriving (Show, Eq)@@ -31,41 +26,43 @@ makeTemplate :: String -> String makeTemplate s = "{-# LANGUAGE QuasiQuotes, ExtendedDefaultRules, TypeApplications #-}\nimport PyF\ntruncate' = truncate @Float @Int\nhello = \"hello\"\nnumber = 3.14 :: Float\nmain :: IO ()\nmain = putStrLn [fmt|" ++ s ++ "|]\n" -{- | Compile a formatting string-->>> checkCompile fileContent-CompileError "Bla bla bla, Floating cannot be formatted as hexa (`x`)--}+-- | Compile a formatting string+--+-- >>> checkCompile fileContent+-- CompileError "Bla bla bla, Floating cannot be formatted as hexa (`x`) checkCompile :: HasCallStack => String -> IO CompilationStatus checkCompile content = withSystemTempFile "PyFTest.hs" $ \path fd -> do IO.hPutStr fd content IO.hFlush fd-- (ecode, _stdout, stderr) <- readProcessWithExitCode "ghc" [path,- -- Include all PyF files- "-isrc",- -- Disable the usage of the annoying .ghc environment file- "-package-env", "-",- -- Tests use a filename in a temporary directory which may have a long filename which triggers- -- line wrapping, reducing the reproducibility of error message- -- By setting the column size to a high value, we ensure reproducible error messages- "-dppr-cols=10000000000000",- -- Clean package environment- "-hide-all-packages",- "-package base",- "-package megaparsec",- "-package text",- "-package template-haskell",- "-package haskell-src-exts",- "-package haskell-src-meta",- "-package mtl",- "-package containers"- ] ""+ (ecode, _stdout, stderr) <-+ readProcessWithExitCode+ "ghc"+ [ path,+ -- Include all PyF files+ "-isrc",+ -- Disable the usage of the annoying .ghc environment file+ "-package-env",+ "-",+ -- Tests use a filename in a temporary directory which may have a long filename which triggers+ -- line wrapping, reducing the reproducibility of error message+ -- By setting the column size to a high value, we ensure reproducible error messages+ "-dppr-cols=10000000000000",+ -- Clean package environment+ "-hide-all-packages",+ "-package base",+ "-package megaparsec",+ "-package text",+ "-package template-haskell",+ "-package haskell-src-exts",+ "-package haskell-src-meta",+ "-package mtl",+ "-package containers"+ ]+ "" case ecode of ExitFailure _ -> pure (CompileError (sanitize path stderr)) ExitSuccess -> do (ecode', stdout', stderr') <- readProcessWithExitCode (take (length path - 3) path) [] ""- case ecode' of ExitFailure _ -> pure (RuntimeError stderr') ExitSuccess -> pure (Ok stdout')@@ -75,49 +72,36 @@ sanitize :: FilePath -> String -> String sanitize path s = -- strip the filename- let- t = Text.pack s- in Text.unpack (Text.replace (Text.pack path) (Text.pack "INITIALPATH") t)+ let t = Text.pack s+ in Text.unpack (Text.replace (Text.pack path) (Text.pack "INITIALPATH") t) golden :: HasCallStack => String -> String -> IO () golden name output = do- let- goldenFile = "test/golden" </> (name <> ".golden")- actualFile = "test/golden" </> (name <> ".actual")-+ let goldenFile = "test/golden" </> (name <> ".golden")+ actualFile = "test/golden" </> (name <> ".actual") -- It can fail if the golden file does not exists goldenContentE :: Either SomeException String <- try $ readFile goldenFile-- let- -- if no golden file, the golden file is the content- goldenContent = case goldenContentE of- Right e -> e- Left _ -> output-+ let -- if no golden file, the golden file is the content+ goldenContent = case goldenContentE of+ Right e -> e+ Left _ -> output -- Flush lazy IO _ <- evaluate (force goldenContent)- if output /= goldenContent then do writeFile actualFile output (_, diffOutput, _) <- readProcessWithExitCode "diff" [goldenFile, actualFile] ""- putStrLn diffOutput- -- Update golden file writeFile goldenFile output- assertFailure diffOutput- else do- writeFile goldenFile output-+ else writeFile goldenFile output -- if the compilation fails, runs a golden test on compilation output -- else, fails the test fileFailCompile :: HasCallStack => FilePath -> Spec fileFailCompile path = do fileContent <- runIO $ readFile path- -- I'm using the hash of the path, considering that the file content can evolve failCompileContent (hash path) path fileContent @@ -125,16 +109,16 @@ failCompile s = failCompileContent (hash s) s (makeTemplate s) failCompileContent :: HasCallStack => Int -> String -> String -> Spec-failCompileContent h caption fileContent = do+failCompileContent h caption fileContent = before (checkCompile fileContent) $ it (show caption) $ \res -> case res of- CompileError output -> golden (show h) output- _ -> assertFailure (show $ ".golden/" <> show h <> "\n" <>show res)+ CompileError output -> golden (show h) output+ _ -> assertFailure (show $ ".golden/" <> show h <> "\n" <> show res) main :: IO () main = hspec spec spec :: Spec-spec = do+spec = describe "error reporting" $ do describe "string" $ do describe "integral / fractional qualifiers" $ do@@ -149,20 +133,16 @@ failCompile "{hello:x}" failCompile "{hello:X}" failCompile "{hello:o}"- describe "padding center" $ do failCompile "{hello:=100s}" failCompile "{hello:=100}"- describe "grouping" $ do failCompile "{hello:_s}" failCompile "{hello:,s}"- describe "sign" $ do failCompile "{hello:+s}" failCompile "{hello: s}" failCompile "{hello:-s}"- describe "number" $ do failCompile "{truncate' number:f}" failCompile "{truncate' number:g}"@@ -170,20 +150,17 @@ failCompile "{truncate' number:e}" failCompile "{truncate' number:E}" failCompile "{truncate' number:%}"- describe "number with precision" $ do failCompile "{truncate number:.3d}" failCompile "{truncate number:.3o}" failCompile "{truncate number:.3b}" failCompile "{truncate number:.3x}"- describe "floats" $ do failCompile "{number:o}" failCompile "{number:b}" failCompile "{number:x}" failCompile "{number:X}" failCompile "{number:d}"- -- XXX: this are not failing for now, it should be fixed xdescribe "not specified" $ do failCompile "{truncate number:.3}"@@ -193,31 +170,25 @@ failCompile "{hello:-}" failCompile "{hello:_}" failCompile "{hello:,}"-- describe "multiples lines" $ do+ describe "multiples lines" $ failCompile "hello\n\n\n{pi:l}"- describe "on haskell expression parsing" $ do- describe "single line" $ do+ describe "single line" $ failCompile "{1 + - / lalalal}"- describe "multiples lines" $ do+ describe "multiples lines" $ failCompile "hello\n {\nlet a = 5\n b = 10\nin 1 + - / lalalal}"- describe "non-doubled delimiters" $ do failCompile "hello } world" failCompile "hello { world"-- describe "fail is not enabled extension" $ do+ describe "fail is not enabled extension" $ failCompile "{0b0001}"-- describe "lexical errors" $ do+ describe "lexical errors" $ failCompile "foo\\Pbar"-- describe "fileFailures" $ do- mapM_ fileFailCompile [- "test/failureCases/bug18.hs"+ describe "fileFailures" $+ mapM_+ fileFailCompile+ [ "test/failureCases/bug18.hs" ]- describe "Wrong type" $ do failCompile "{True}" failCompile "{True:f}"
test/SpecOverloaded.hs view
@@ -1,12 +1,11 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-} -import Test.Hspec--import PyF-import Data.Text import Data.ByteString+import Data.Text+import PyF+import Test.Hspec main :: IO () main = hspec spec@@ -15,9 +14,9 @@ spec = do let ten = 10 :: Int describe "Test formatting with different types" $ do- it "String" $ do+ it "String" $ [fmt|hello {ten:d}|] `shouldBe` ("hello 10" :: String)- it "Text" $ do+ it "Text" $ [fmt|hello {ten:d}|] `shouldBe` ("hello 10" :: Text)- it "ByteString" $ do+ it "ByteString" $ [fmt|hello {ten:d}|] `shouldBe` ("hello 10" :: ByteString)
test/SpecUtils.hs view
@@ -1,79 +1,71 @@ {-# LANGUAGE TemplateHaskell #-}+ module SpecUtils- ( checkExample- , checkExampleDiff- , check-)+ ( checkExample,+ checkExampleDiff,+ check,+ ) where -import Test.Hspec-import PyF.Internal.QQ- import Language.Haskell.TH import Language.Haskell.TH.Syntax--import System.Process+import PyF.Internal.QQ import System.Exit+import System.Process+import Test.Hspec -- * Utils -{- | Runs a python formatter example--For conveniance, it exports a few python symbols, `inf`, `nan` and pi.-->>> runPythonExample "{3.14159:.1f}-"3.1--}+-- | Runs a python formatter example+--+-- For conveniance, it exports a few python symbols, `inf`, `nan` and pi.+--+-- >>> runPythonExample "{3.14159:.1f}+-- "3.1 runPythonExample :: String -> IO (Maybe String) runPythonExample s = do- let- pythonPath = "python3"- args = ["-c", "from math import pi;nan = float('NaN');inf = float('inf');print(f\'''" ++ s ++ "''', end='')"]+ let pythonPath = "python3"+ args = ["-c", "from math import pi;nan = float('NaN');inf = float('inf');print(f\'''" ++ s ++ "''', end='')"] (ecode, stdout, _stderr) <- readProcessWithExitCode pythonPath args "" pure $ case ecode of ExitSuccess -> Just stdout ExitFailure _ -> Nothing -{- | `pyCheck formatString reference` compares a format string against-a reference (if `Just`) and against the python implementation--This TH expression will return an expression compatible with `Hspec` `SpecM`.--This expression is a failure if python cannot format this formatString-or if the python result does not match the (provided) reference.--}-+-- | `pyCheck formatString reference` compares a format string against+-- a reference (if `Just`) and against the python implementation+--+-- This TH expression will return an expression compatible with `Hspec` `SpecM`.+--+-- This expression is a failure if python cannot format this formatString+-- or if the python result does not match the (provided) reference. pyCheck :: String -> Maybe String -> Q Exp pyCheck s exampleStr = do pythonRes <- Language.Haskell.TH.Syntax.runIO (runPythonExample s)- case pythonRes of- Nothing -> [| expectationFailure $ "Expression: `" ++ s ++ "` fails in python" |]+ Nothing -> [|expectationFailure $ "Expression: `" ++ s ++ "` fails in python"|] Just res -> do- let qexp = [| $(toExpPython s) `shouldBe` res |]+ let qexp = [|$(toExpPython s) `shouldBe` res|] case exampleStr of Nothing -> qexp- Just e -> if res == e- then qexp- else [| expectationFailure $ "Provided result `" ++ e ++ "` does not match the python result `" ++ res ++ "`" |]+ Just e ->+ if res == e+ then qexp+ else [|expectationFailure $ "Provided result `" ++ e ++ "` does not match the python result `" ++ res ++ "`"|] -- * Exported -{- | `checkExample formatString result` checks if, once formated,- `formatString` is equal to result. It also checks that the result is- the same as the one provided by python.--}+-- | `checkExample formatString result` checks if, once formated,+-- `formatString` is equal to result. It also checks that the result is+-- the same as the one provided by python. checkExample :: String -> String -> Q Exp checkExample s res = pyCheck s (Just res) -{- | `checkExampleDiff formatString result` checks if, once formated,- `formatString` is equal to result. It does not check the result- against the python implementation--}+-- | `checkExampleDiff formatString result` checks if, once formated,+-- `formatString` is equal to result. It does not check the result+-- against the python implementation checkExampleDiff :: String -> String -> Q Exp-checkExampleDiff s res = [| $(toExpPython s) `shouldBe` res |]+checkExampleDiff s res = [|$(toExpPython s) `shouldBe` res|] -{- | `check formatString` checks only with the python implementation--}+-- | `check formatString` checks only with the python implementation check :: String -> Q Exp check s = pyCheck s Nothing
test/failureCases/bug18.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+ {-# OPTIONS -Wall -Werror #-} {-@@ -14,18 +15,18 @@ import qualified Data.Text as T import PyF -data Foo =- Foo- { fieldA :: ()- , fieldB :: T.Text- }+data Foo+ = Foo+ { fieldA :: (),+ fieldB :: T.Text+ } deriving (Show) yolo :: Foo yolo = Foo- { fieldB = [fmt|hello what's up {x}|]- }+ { fieldB = [fmt|hello what's up {x}|]+ } where x :: T.Text x = T.pack "hi"
test/golden/2897849520519503487.golden view
@@ -1,5 +1,5 @@ -INITIALPATH:26:3: error: [-Wmissing-fields, -Werror=missing-fields]+INITIALPATH:27:3: error: [-Wmissing-fields, -Werror=missing-fields] • Fields of ‘Foo’ not initialised: fieldA • In the expression: Foo {fieldB = (Data.String.fromString ("hello what's up " <> ((((PyF.Internal.QQ.formatAny PyF.Formatters.Minus) PyF.Internal.QQ.PaddingDefaultK) Nothing) Nothing) x))} In an equation for ‘yolo’:@@ -9,10 +9,10 @@ x :: T.Text x = T.pack "hi" |-26 | Foo+27 | Foo | ^^^... -INITIALPATH:33:1: error: [-Wmissing-signatures, -Werror=missing-signatures] Top-level binding with no type signature: main :: IO ()+INITIALPATH:34:1: error: [-Wmissing-signatures, -Werror=missing-signatures] Top-level binding with no type signature: main :: IO () |-33 | main = print yolo+34 | main = print yolo | ^^^^