diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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). diff --git a/PyF.cabal b/PyF.cabal --- a/PyF.cabal +++ b/PyF.cabal @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/src/PyF.hs b/src/PyF.hs --- a/src/PyF.hs +++ b/src/PyF.hs @@ -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 ++ "!") diff --git a/src/PyF/Class.hs b/src/PyF/Class.hs --- a/src/PyF/Class.hs +++ b/src/PyF/Class.hs @@ -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 diff --git a/src/PyF/Formatters.hs b/src/PyF/Formatters.hs --- a/src/PyF/Formatters.hs +++ b/src/PyF/Formatters.hs @@ -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'') diff --git a/src/PyF/Internal/Extensions.hs b/src/PyF/Internal/Extensions.hs --- a/src/PyF/Internal/Extensions.hs +++ b/src/PyF/Internal/Extensions.hs @@ -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 diff --git a/src/PyF/Internal/PythonSyntax.hs b/src/PyF/Internal/PythonSyntax.hs --- a/src/PyF/Internal/PythonSyntax.hs +++ b/src/PyF/Internal/PythonSyntax.hs @@ -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 . --} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- This module provides a parser for . 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 '%' + ] diff --git a/src/PyF/Internal/QQ.hs b/src/PyF/Internal/QQ.hs --- a/src/PyF/Internal/QQ.hs +++ b/src/PyF/Internal/QQ.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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" diff --git a/test/SpecCustomDelimiters.hs b/test/SpecCustomDelimiters.hs --- a/test/SpecCustomDelimiters.hs +++ b/test/SpecCustomDelimiters.hs @@ -1,8 +1,7 @@ module SpecCustomDelimiters where import Language.Haskell.TH.Quote - import PyF myCustomFormatter :: QuasiQuoter -myCustomFormatter = fmtWithDelimiters ('@','!') +myCustomFormatter = fmtWithDelimiters ('@', '!') diff --git a/test/SpecFail.hs b/test/SpecFail.hs --- a/test/SpecFail.hs +++ b/test/SpecFail.hs @@ -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}" diff --git a/test/SpecOverloaded.hs b/test/SpecOverloaded.hs --- a/test/SpecOverloaded.hs +++ b/test/SpecOverloaded.hs @@ -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) diff --git a/test/SpecUtils.hs b/test/SpecUtils.hs --- a/test/SpecUtils.hs +++ b/test/SpecUtils.hs @@ -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 diff --git a/test/failureCases/bug18.hs b/test/failureCases/bug18.hs --- a/test/failureCases/bug18.hs +++ b/test/failureCases/bug18.hs @@ -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" diff --git a/test/golden/2897849520519503487.golden b/test/golden/2897849520519503487.golden --- a/test/golden/2897849520519503487.golden +++ b/test/golden/2897849520519503487.golden @@ -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 | ^^^^