typelits-printf 0.2.0.0 → 0.3.0.0
raw patch · 10 files changed
+828/−671 lines, 10 filesdep +hspecdep +typelits-printfdep −symbolsdep ~basesetup-changed
Dependencies added: hspec, typelits-printf
Dependencies removed: symbols
Dependency ranges changed: base
Files
- CHANGELOG.md +25/−0
- README.md +31/−25
- Setup.hs +1/−0
- src/GHC/TypeLits/Printf.hs +70/−46
- src/GHC/TypeLits/Printf/Internal.hs +275/−250
- src/GHC/TypeLits/Printf/Internal/Parser.hs +136/−136
- src/GHC/TypeLits/Printf/Internal/Unsatisfiable.hs +21/−0
- src/GHC/TypeLits/Printf/Parse.hs +191/−176
- test/spec.hs +23/−0
- typelits-printf.cabal +55/−38
CHANGELOG.md view
@@ -1,6 +1,31 @@ Changelog ========= +Version 0.3.0.0+---------------++*September 11, 2024*++<https://github.com/mstksg/typelits-printf/releases/tag/v0.3.0.0>++* Use `-XRequiredTypeArguments` in GHC 9.10. You can directly pass+ the `Symbol` without needing `@`:++ ```+ >>> putStrLn $ printf "You have %.2f dollars, %s" 3.62 "Luigi"+ You have 3.62 dollars, Luigi+ ```++ If you are on GHC 9.8 or lower, this is exported identically to+ `Text.Printf.printf`, which kind of looks identical, syntactically, if you+ use a string literal.++ If you still want the type-safe printf in GHC 9.8 or lower, use `printf'`+ for now.+* Move to directly using `UnconsSymbol` and type-level `Char` literals from+ GHC, available only GHC 9.2+. This means we can support unicode in strings,+ and could be faster potentially.+ Version 0.2.0.0 ---------------
README.md view
@@ -5,28 +5,39 @@ [symbols]: https://hackage.haskell.org/package/symbols-0.3.0.0/docs/Data-Symbol-Examples-Printf.html ```haskell-ghci> putStrLn $ printf @"You have %.2f dollars, %s" 3.62 "Luigi"+ghci> putStrLn $ printf "You have %.2f dollars, %s" 3.62 "Luigi" You have 3.62 dollars, Luigi ``` An extensible and type-safe printf from parsing GHC TypeLits Symbol literals,-matching the semantics of *[Text.Printf][]* in *base*. The difference is that-your `printf`s will always fail to compile if given arguments of the wrong type-(or too many or too little arguments). It also allows you to use types to help+matching the semantics of *[Text.Printf][]* in *base* (it actually uses the+same formatting function under the hood). The difference is that your+`printf`s will always fail to compile if given arguments of the wrong type (or+too many or too little arguments). It also allows you to use types to help your development, by telling you the type of arguments it expects and how many when queried with `:t` or with typed holes. [Text.Printf]: https://hackage.haskell.org/package/base/docs/Text-Printf.html -```haskell-ghci> putStrLn $ printf @"You have %.2f dollars, %s" 3.62 "Luigi"-You have 3.62 dollars, Luigi-```+As of GHC 9.10 and later (and version 0.3.0.0 of this library), it uses+`-XRequiredTypeArguments` to allow you to pass in the printf spec literal+directly as if it were a normal String literal. +> [!NOTE]+> The `printf` function here is only type-safe in GHC 9.10 and higher. If you are+> before GHC 9.10, you should use `printf'` instead and `-XTypeApplications`+> syntax:+>+> ```+> printf' @"You have %.2f dollars, %s" 3.62 "Luigi"+> ```+>+> Note the `@` before the string literal.+ Looking at its type: ```haskell-ghci> :t printf @"You have %.2f dollars, %s"+ghci> :t printf "You have %.2f dollars, %s" (FormatType "f" arg1, FormatType "s" arg2) => arg1 -> arg2 -> String ```@@ -39,10 +50,10 @@ We can see this in action by progressively applying arguments: ```haskell-ghci> :t printf @"You have %.2f dollars, %s" 3.62+ghci> :t printf "You have %.2f dollars, %s" 3.62 FormatType "s" arg1 => arg1 -> String -ghci> :t printf @"You have %.2f dollars, %s" 3.62 "Luigi"+ghci> :t printf "You have %.2f dollars, %s" 3.62 "Luigi" String ``` @@ -50,20 +61,20 @@ arguments) are pretty clear: ```haskell-ghci> putStrLn $ printf @"You have %.2f dollars, %s"+ghci> putStrLn $ printf "You have %.2f dollars, %s" -- ERROR: Call to printf missing argument fulfilling "%.2f" -- Either provide an argument or rewrite the format string to not expect -- one. -ghci> putStrLn $ printf @"You have %.2f dollars, %s" 3.62+ghci> putStrLn $ printf "You have %.2f dollars, %s" 3.62 -- ERROR: Call to printf missing argument fulfilling "%s" -- Either provide an argument or rewrite the format string to not expect -- one. -ghci> putStrLn $ printf @"You have %.2f dollars, %s" 3.62 "Luigi"+ghci> putStrLn $ printf "You have %.2f dollars, %s" 3.62 "Luigi" You have 3.62 dollars, Luigi -ghci> putStrLn $ printf @"You have %.2f dollars, %s" 3.62 "Luigi" 72+ghci> putStrLn $ printf "You have %.2f dollars, %s" 3.62 "Luigi" 72 -- ERROR: An extra argument of type Integer was given to a call to printf -- Either remove the argument, or rewrite the format string to include the -- appropriate hole.@@ -74,11 +85,11 @@ ## Caveats -For medium-length or long strings, the parsing can be fairly slow and cause-slow compile times. This might be due to the underlying mechanism that the-*[symbols][]* package exploits...or just GHC performance issues in general.--[symbols]: https://hackage.haskell.org/package/symbols+You will most likely need to add `-freduction-depth=0` for most strings longer+than 30 characters-ish or so. Be aware that there is a compile-time cost per+string, so if you notice your compile times getting long, try investigating+this. It is written to be fully compatible with the `Text.Printf` module from+*base*. Moving to typechecker plugin based parsing *does* improve performance ... however, I'm not sure how to get around requiring every module using `printf`@@ -93,10 +104,6 @@ all differ in a few key ways. Some, like *[th-printf][]* and *[safe-printf][]*, offer Template Haskell-based ways to generate your printf functions. This package is intended as a "template-haskell free" alternative.-However, it is notable that with a Template-Haskell based approach, we can-solve the "pick two" situation above: *[th-printf][]*'s printf fulfills all-three requirements in the table above, with the only potential drawback being-Template Haskell usage. Some others, like *[safe-printf][]*, *[formatting][]*, *[printf-safe][]*, *[xformat][]*, and *[category-printf][]*, require manually constructing your@@ -125,7 +132,6 @@ ## Todo -* Make faster * Tests * Support for localization/dynamic strings. Should be possible, but we'd have to re-implement a subset of singletons.
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
src/GHC/TypeLits/Printf.hs view
@@ -1,21 +1,21 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} +#if MIN_VERSION_base(4,20,0)+{-# LANGUAGE RequiredTypeArguments #-}+#endif+ -- | -- Module : GHC.TypeLits.Printf -- Copyright : (c) Justin Le 2019@@ -35,39 +35,50 @@ -- "Text.Printf" for details on how this formats items of various types, -- and the differences with C @printf(3)@. ----- See 'printf' for the main function.+-- See 'printf' for the main function, or 'printf'' if you are on GHC 9.10 and+-- later. -- -- You can extend functionality with formatting for your own types by providing -- instances of 'FormatType'. -- -- Also in this module is 'pfmt', which allows you to format individual -- items according to a single format specifier.--- module GHC.TypeLits.Printf ( -- * Printf- printf, printf_- , PHelp, pHelp- , FormatFun+ printf,+ printf',+ printf_,+ PHelp,+ pHelp,+ FormatFun,+ -- * Formattable things- , FormatType(..)- , SChar+ FormatType (..),+ -- * Single item- , pfmt- , PFmt- , mkPFmt, mkPFmt_- ) where+ pfmt,+ PFmt,+ mkPFmt,+ mkPFmt_,+) where -import Data.Proxy-import GHC.TypeLits.Printf.Internal+import Data.Proxy+import GHC.TypeLits.Printf.Internal+import qualified Text.Printf as P --- | "Type-safe printf". Call it like @'printf' \@"you have %.02f dollars, %s"@.+-- | "Type-safe printf". Call it like @'printf' "you have %.02f dollars, %s"@. ----- >>> putStrLn $ printf @"You have %.2f dollars, %s" 3.62 "Luigi"+-- >>> putStrLn $ printf "You have %.2f dollars, %s" 3.62 "Luigi" -- You have 3.62 dollars, Luigi ----- Looking at its type:+-- __NOTE__: This is only type-safe in GHC 9.10 and above. A compatible+-- version is provided in earlier versions that compiles (as long as you+-- provide a string literal). For a type-safe version before GHC 9.10, use+-- 'printf'. ----- >>> :t printf @"You have %.2f dollars, %s"+-- Anyway, looking at its type:+--+-- >>> :t printf "You have %.2f dollars, %s" -- (FormatType "f" arg1, FormatType "s" arg2) -- => arg1 -> arg2 -> String --@@ -78,25 +89,25 @@ -- -- We can see this in action by progressively applying arguments: ----- >>> :t printf @"You have %.2f dollars, %s" 3.62+-- >>> :t printf "You have %.2f dollars, %s" 3.62 -- FormatType "s" arg1 => arg1 -> String--- >>> :t printf @"You have %.2f dollars, %s" 3.62 "Luigi"+-- >>> :t printf "You have %.2f dollars, %s" 3.62 "Luigi" -- String -- -- The type errors for forgetting to apply an argument (or applying too many -- arguments) are pretty clear: ----- >>> putStrLn $ printf @"You have %.2f dollars, %s"+-- >>> putStrLn $ printf "You have %.2f dollars, %s" -- -- ERROR: Call to printf missing argument fulfilling "%.2f" -- -- Either provide an argument or rewrite the format string to not expect -- -- one.--- >>> putStrLn $ printf @"You have %.2f dollars, %s" 3.62+-- >>> putStrLn $ printf "You have %.2f dollars, %s" 3.62 -- -- ERROR: Call to printf missing argument fulfilling "%s" -- -- Either provide an argument or rewrite the format string to not expect -- -- one.--- >>> putStrLn $ printf @"You have %.2f dollars, %s" 3.62 "Luigi"+-- >>> putStrLn $ printf "You have %.2f dollars, %s" 3.62 "Luigi" -- You have 3.62 dollars, Luigi--- >>> putStrLn $ printf @"You have %.2f dollars, %s" 3.62 "Luigi" 72+-- >>> putStrLn $ printf "You have %.2f dollars, %s" 3.62 "Luigi" 72 -- -- ERROR: An extra argument of type Integer was given to a call to printf -- -- Either remove the argument, or rewrite the format string to include the -- -- appropriate hole.@@ -104,15 +115,28 @@ -- If you want to see some useful error messages for feedback, 'pHelp' can -- be useful: ----- >>> pHelp $ printf @"You have %.2f dollars, %s" 3.62+-- >>> pHelp $ printf "You have %.2f dollars, %s" 3.62 -- -- ERROR: Call to printf missing argument fulfilling "%s" -- -- Either provide an argument or rewrite the format string to not expect -- -- one. -- -- Note that this also supports the "interpret as an IO action to print out--- results" functionality that "Text.Printf" supports. This also supports--- returning strict 'Data.Text.Text' and lazy 'Data.Text.Lazy.Text' as--- well.-printf :: forall str fun. Printf str fun => fun-printf = printf_ (Proxy @str)+-- results" functionality that "Text.Printf" supports. And, in GHC 9.10 and+-- higher, this also supports returning strict 'Data.Text.Text' and lazy+-- 'Data.Text.Lazy.Text' as well.+#if MIN_VERSION_base(4,20,0)+printf :: forall fun. forall str -> Printf str fun => fun+printf str = printf_ (Proxy @str)+#else+printf :: P.PrintfType r => String -> r+printf = P.printf+{-# WARNING printf "This only does type-safe printf GHC 9.10 or later, but will still compile (unsafely) in earlier GHC as long as you use a string literal. For a type-safe version before 9.10, use printf' instead." #-}+#endif +-- | A version of 'printf' that uses @-XTypeApplications@ syntax to provide+-- the type-level string. Available since GHC 9.2 and higher.+--+-- >>> putStrLn $ printf @"You have %.2f dollars, %s" 3.62 "Luigi"+-- You have 3.62 dollars, Luigi+printf' :: forall str fun. Printf str fun => fun+printf' = printf_ (Proxy @str)
src/GHC/TypeLits/Printf/Internal.hs view
@@ -1,21 +1,19 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-} -- | -- Module : GHC.TypeLits.Printf.Internal@@ -32,203 +30,217 @@ -- Please do not use this module for anything besides debugging, as is -- definitely very unstable and might go away or change dramatically -- between versions.- module GHC.TypeLits.Printf.Internal (- ParseFmtStr- , ParseFmtStr_- , ParseFmt- , ParseFmt_- , FormatAdjustment(..)- , ShowFormat- , FormatSign(..)- , WidthMod(..)- , Flags(..)- , EmptyFlags- , FieldFormat(..)- , SChar- , Demote- , Reflect(..)- , FormatType(..)- , Printf(..)- , FormatFun(..)- , PFmt(..)- , pfmt- , mkPFmt, mkPFmt_- , PHelp(..)- ) where+ ParseFmtStr,+ ParseFmtStr_,+ ParseFmt,+ ParseFmt_,+ FormatAdjustment (..),+ ShowFormat,+ FormatSign (..),+ WidthMod (..),+ Flags (..),+ EmptyFlags,+ FieldFormat (..),+ Demote,+ Reflect (..),+ FormatType (..),+ Printf (..),+ FormatFun (..),+ PFmt (..),+ pfmt,+ mkPFmt,+ mkPFmt_,+ PHelp (..),+) where -import Data.Int-import Data.Proxy-import Data.Symbol.Utils-import Data.Word-import GHC.OverloadedLabels-import GHC.TypeLits-import GHC.TypeLits.Printf.Parse-import Numeric.Natural-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Text.Printf as P+import Data.Int+import Data.Proxy+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Word+import GHC.OverloadedLabels+import GHC.TypeLits+import GHC.TypeLits.Printf.Internal.Unsatisfiable+import GHC.TypeLits.Printf.Parse+import qualified Text.Printf as P -- | Typeclass associating format types (@d@, @f@, etc.) with the types -- that can be formatted by them. -- -- You can extend the printf methods here for your own types by writing -- your instances here.-class FormatType (t :: SChar) a where- formatArg :: p t -> a -> P.FieldFormat -> ShowS-- default formatArg :: P.PrintfArg a => p t -> a -> P.FieldFormat -> ShowS- formatArg _ = P.formatArg+class FormatType (t :: Char) a where+ formatArg :: p t -> a -> P.FieldFormat -> ShowS+ default formatArg :: P.PrintfArg a => p t -> a -> P.FieldFormat -> ShowS+ formatArg _ = P.formatArg -instance FormatType "c" Char-instance FormatType "c" Word8-instance FormatType "c" Word16+instance FormatType 'c' Char+instance FormatType 'c' Word8+instance FormatType 'c' Word16 -instance FormatType "d" Char-instance FormatType "d" Int-instance FormatType "d" Int8-instance FormatType "d" Int16-instance FormatType "d" Int32-instance FormatType "d" Int64-instance FormatType "d" Integer-instance FormatType "d" Natural-instance FormatType "d" Word-instance FormatType "d" Word8-instance FormatType "d" Word16-instance FormatType "d" Word32-instance FormatType "d" Word64+instance FormatType 'd' Char+instance FormatType 'd' Int+instance FormatType 'd' Int8+instance FormatType 'd' Int16+instance FormatType 'd' Int32+instance FormatType 'd' Int64+instance FormatType 'd' Integer+instance FormatType 'd' Natural+instance FormatType 'd' Word+instance FormatType 'd' Word8+instance FormatType 'd' Word16+instance FormatType 'd' Word32+instance FormatType 'd' Word64 -instance FormatType "o" Char-instance FormatType "o" Int-instance FormatType "o" Int8-instance FormatType "o" Int16-instance FormatType "o" Int32-instance FormatType "o" Int64-instance FormatType "o" Integer-instance FormatType "o" Natural-instance FormatType "o" Word-instance FormatType "o" Word8-instance FormatType "o" Word16-instance FormatType "o" Word32-instance FormatType "o" Word64+instance FormatType 'o' Char+instance FormatType 'o' Int+instance FormatType 'o' Int8+instance FormatType 'o' Int16+instance FormatType 'o' Int32+instance FormatType 'o' Int64+instance FormatType 'o' Integer+instance FormatType 'o' Natural+instance FormatType 'o' Word+instance FormatType 'o' Word8+instance FormatType 'o' Word16+instance FormatType 'o' Word32+instance FormatType 'o' Word64 -instance FormatType "x" Int-instance FormatType "x" Int8-instance FormatType "x" Int16-instance FormatType "x" Int32-instance FormatType "x" Int64-instance FormatType "x" Integer-instance FormatType "x" Natural-instance FormatType "x" Word-instance FormatType "x" Word8-instance FormatType "x" Word16-instance FormatType "x" Word32-instance FormatType "x" Word64+instance FormatType 'x' Int+instance FormatType 'x' Int8+instance FormatType 'x' Int16+instance FormatType 'x' Int32+instance FormatType 'x' Int64+instance FormatType 'x' Integer+instance FormatType 'x' Natural+instance FormatType 'x' Word+instance FormatType 'x' Word8+instance FormatType 'x' Word16+instance FormatType 'x' Word32+instance FormatType 'x' Word64 -instance FormatType "X" Char-instance FormatType "X" Int-instance FormatType "X" Int8-instance FormatType "X" Int16-instance FormatType "X" Int32-instance FormatType "X" Int64-instance FormatType "X" Integer-instance FormatType "X" Natural-instance FormatType "X" Word-instance FormatType "X" Word8-instance FormatType "X" Word16-instance FormatType "X" Word32-instance FormatType "X" Word64+instance FormatType 'X' Char+instance FormatType 'X' Int+instance FormatType 'X' Int8+instance FormatType 'X' Int16+instance FormatType 'X' Int32+instance FormatType 'X' Int64+instance FormatType 'X' Integer+instance FormatType 'X' Natural+instance FormatType 'X' Word+instance FormatType 'X' Word8+instance FormatType 'X' Word16+instance FormatType 'X' Word32+instance FormatType 'X' Word64 -instance FormatType "b" Char-instance FormatType "b" Int-instance FormatType "b" Int8-instance FormatType "b" Int16-instance FormatType "b" Int32-instance FormatType "b" Int64-instance FormatType "b" Integer-instance FormatType "b" Natural-instance FormatType "b" Word-instance FormatType "b" Word8-instance FormatType "b" Word16-instance FormatType "b" Word32-instance FormatType "b" Word64+instance FormatType 'b' Char+instance FormatType 'b' Int+instance FormatType 'b' Int8+instance FormatType 'b' Int16+instance FormatType 'b' Int32+instance FormatType 'b' Int64+instance FormatType 'b' Integer+instance FormatType 'b' Natural+instance FormatType 'b' Word+instance FormatType 'b' Word8+instance FormatType 'b' Word16+instance FormatType 'b' Word32+instance FormatType 'b' Word64 -instance FormatType "u" Char-instance FormatType "u" Int-instance FormatType "u" Int8-instance FormatType "u" Int16-instance FormatType "u" Int32-instance FormatType "u" Int64-instance FormatType "u" Integer-instance FormatType "u" Natural-instance FormatType "u" Word-instance FormatType "u" Word8-instance FormatType "u" Word16-instance FormatType "u" Word32-instance FormatType "u" Word64+instance FormatType 'u' Char+instance FormatType 'u' Int+instance FormatType 'u' Int8+instance FormatType 'u' Int16+instance FormatType 'u' Int32+instance FormatType 'u' Int64+instance FormatType 'u' Integer+instance FormatType 'u' Natural+instance FormatType 'u' Word+instance FormatType 'u' Word8+instance FormatType 'u' Word16+instance FormatType 'u' Word32+instance FormatType 'u' Word64 -instance FormatType "f" Double-instance FormatType "f" Float+instance FormatType 'f' Double+instance FormatType 'f' Float -instance FormatType "F" Double-instance FormatType "F" Float+instance FormatType 'F' Double+instance FormatType 'F' Float -instance FormatType "g" Double-instance FormatType "g" Float+instance FormatType 'g' Double+instance FormatType 'g' Float -instance FormatType "G" Double-instance FormatType "G" Float+instance FormatType 'G' Double+instance FormatType 'G' Float -instance FormatType "e" Double-instance FormatType "e" Float+instance FormatType 'e' Double+instance FormatType 'e' Float -instance FormatType "E" Double-instance FormatType "E" Float+instance FormatType 'E' Double+instance FormatType 'E' Float -instance FormatType "s" String-instance FormatType "s" T.Text where- formatArg _ = P.formatArg . T.unpack-instance FormatType "s" TL.Text where- formatArg _ = P.formatArg . TL.unpack+instance P.IsChar c => FormatType 's' [c]+instance FormatType 's' T.Text where+ formatArg _ = P.formatArg . T.unpack+instance FormatType 's' TL.Text where+ formatArg _ = P.formatArg . TL.unpack -- | Treats as @c@-instance FormatType "v" Char+instance FormatType 'v' Char+ -- | Treats as @d@-instance FormatType "v" Int+instance FormatType 'v' Int+ -- | Treats as @d@-instance FormatType "v" Int8+instance FormatType 'v' Int8+ -- | Treats as @d@-instance FormatType "v" Int16+instance FormatType 'v' Int16+ -- | Treats as @d@-instance FormatType "v" Int32+instance FormatType 'v' Int32+ -- | Treats as @d@-instance FormatType "v" Int64+instance FormatType 'v' Int64+ -- | Treats as @d@-instance FormatType "v" Integer+instance FormatType 'v' Integer+ -- | Treats as @u@-instance FormatType "v" Natural+instance FormatType 'v' Natural+ -- | Treats as @u@-instance FormatType "v" Word+instance FormatType 'v' Word+ -- | Treats as @u@-instance FormatType "v" Word8+instance FormatType 'v' Word8+ -- | Treats as @u@-instance FormatType "v" Word16+instance FormatType 'v' Word16+ -- | Treats as @u@-instance FormatType "v" Word32+instance FormatType 'v' Word32+ -- | Treats as @u@-instance FormatType "v" Word64+instance FormatType 'v' Word64+ -- | Treats as @g@-instance FormatType "v" Double+instance FormatType 'v' Double+ -- | Treats as @g@-instance FormatType "v" Float+instance FormatType 'v' Float+ -- | Treats as @s@-instance FormatType "v" String+instance FormatType 'v' String+ -- | Treats as @s@-instance FormatType "v" T.Text where- formatArg _ = P.formatArg . T.unpack+instance FormatType 'v' T.Text where+ formatArg _ = P.formatArg . T.unpack+ -- | Treats as @s@-instance FormatType "v" TL.Text where- formatArg _ = P.formatArg . TL.unpack+instance FormatType 'v' TL.Text where+ formatArg _ = P.formatArg . TL.unpack -- | The typeclass supporting polyarity used by -- 'GHC.TypeLits.Printf.printf'. It works in mostly the same way as@@ -248,7 +260,7 @@ -- -- Either provide an argument or rewrite the format string to not expect -- -- one. class FormatFun (ffs :: [Either Symbol FieldFormat]) fun where- formatFun :: p ffs -> String -> fun+ formatFun :: p ffs -> String -> fun -- | A useful tool for helping the type system give useful errors for -- 'GHC.TypeLits.Printf.printf':@@ -262,82 +274,93 @@ -- is going on. -- -- See also 'pHelp'-newtype PHelp = PHelp {- -- | A useful helper function for helping the type system give useful- -- errors for 'printf':- --- -- >>> pHelp $ printf @"You have %.2f dollars, %s" 3.62- -- -- ERROR: Call to printf missing argument fulfilling "%s"- -- -- Either provide an argument or rewrite the format string to not expect- -- -- one.- --- -- Mostly useful if you want to force a useful type error to help see- -- what is going on.- pHelp :: String+newtype PHelp = PHelp+ { pHelp :: String+ -- ^ A useful helper function for helping the type system give useful+ -- errors for 'printf':+ --+ -- >>> pHelp $ printf @"You have %.2f dollars, %s" 3.62+ -- -- ERROR: Call to printf missing argument fulfilling "%s"+ -- -- Either provide an argument or rewrite the format string to not expect+ -- -- one.+ --+ -- Mostly useful if you want to force a useful type error to help see+ -- what is going on. } -instance {-# INCOHERENT #-} (a ~ String) => FormatFun '[] a where- formatFun _ = id-instance (a ~ Char) => FormatFun '[] PHelp where- formatFun _ = PHelp-instance (a ~ Char) => FormatFun '[] T.Text where- formatFun _ = T.pack-instance (a ~ Char) => FormatFun '[] TL.Text where- formatFun _ = TL.pack-instance (a ~ ()) => FormatFun '[] (IO a) where- formatFun _ = putStr+-- What is this incoherent instance for? It serves to make String the *default*+-- result when the result type is entirely ambiguous.+instance {-# INCOHERENT #-} a ~ String => FormatFun '[] a where+ formatFun _ = id+instance FormatFun '[] PHelp where+ formatFun _ = PHelp+instance FormatFun '[] T.Text where+ formatFun _ = T.pack+instance FormatFun '[] TL.Text where+ formatFun _ = TL.pack+instance a ~ () => FormatFun '[] (IO a) where+ formatFun _ = putStr -instance TypeError ( 'Text "Result type of a call to printf not sufficiently inferred."- ':$$: 'Text "Please provide an explicit type annotation or other way to help inference."- )- => FormatFun '[] () where- formatFun _ = error+instance+ Unsatisfiable+ ( 'Text "An extra argument of type "+ ':<>: 'ShowType a+ ':<>: 'Text " was given to a call to printf."+ ':$$: 'Text "Either remove the argument, or rewrite the format string to include the appropriate hole"+ ) =>+ FormatFun '[] (a -> b)+ where+ formatFun = unsatisfiable -instance TypeError ( 'Text "An extra argument of type "- ':<>: 'ShowType a- ':<>: 'Text " was given to a call to printf."- ':$$: 'Text "Either remove the argument, or rewrite the format string to include the appropriate hole"- )- => FormatFun '[] (a -> b) where- formatFun _ = error+instance (KnownSymbol str, FormatFun ffs fun) => FormatFun (Left str ': ffs) fun where+ formatFun _ str = formatFun (Proxy @ffs) (str ++ symbolVal (Proxy @str)) -instance (KnownSymbol str, FormatFun ffs fun) => FormatFun ('Left str ': ffs) fun where- formatFun _ str = formatFun (Proxy @ffs) (str ++ symbolVal (Proxy @str))+type family IsFunction fun where+ IsFunction (_ -> _) = True+ IsFunction _ = False -instance {-# INCOHERENT #-} (afun ~ (arg -> fun), Reflect ff, ff ~ 'FF f w p m c, FormatType c arg, FormatFun ffs fun) => FormatFun ('Right ff ': ffs) afun where- formatFun _ str x = formatFun (Proxy @ffs) (str ++ formatArg (Proxy @c) x ff "")- where- ff = reflect (Proxy @ff)+instance FormatFun' (IsFunction afun) ff ffs afun => FormatFun (Right ff ': ffs) afun where+ formatFun _ = formatFun' @(IsFunction afun) (Proxy @'(ff, ffs)) -type family MissingError ff where- MissingError ff = 'Text "Call to printf missing an argument fulfilling \"%"- ':<>: 'Text (ShowFormat ff)- ':<>: 'Text "\""- ':$$: 'Text "Either provide an argument or rewrite the format string to not expect one."+-- A helper class for the case where we expect to produce a function+class FormatFun' (is_function :: Bool) (ff :: FieldFormat) (ffs :: [Either Symbol FieldFormat]) fun where+ formatFun' :: p '(ff, ffs) -> String -> fun -instance TypeError (MissingError ff) => FormatFun ('Right ff ': ffs) String where- formatFun _ = error-instance TypeError (MissingError ff) => FormatFun ('Right ff ': ffs) () where- formatFun _ = error-instance TypeError (MissingError ff) => FormatFun ('Right ff ': ffs) T.Text where- formatFun _ = error-instance TypeError (MissingError ff) => FormatFun ('Right ff ': ffs) TL.Text where- formatFun _ = error-instance TypeError (MissingError ff) => FormatFun ('Right ff ': ffs) PHelp where- formatFun _ = error-instance TypeError (MissingError ff) => FormatFun ('Right ff ': ffs) (IO a) where- formatFun _ = error+-- What are these INCOHERENT horrors??? They're purely about getting good+-- error messages. If GHC can see that we're definitely expected to produce+-- something other than a function, then we want to get a custom error message+-- rather than the one the compiler would produce. But if the result type is +-- * ambiguous*, then we want to choose the instance that might make progress.+instance+ {-# INCOHERENT #-}+ (afun ~ (arg -> fun), Reflect ff, ff ~ 'FF f w p m c, FormatType c arg, FormatFun ffs fun) =>+ FormatFun' is_function ff ffs afun+ where+ formatFun' _ str x = formatFun (Proxy @ffs) (str ++ formatArg (Proxy @c) x ff "")+ where+ ff = reflect (Proxy @ff)++instance Unsatisfiable (MissingError ff) => FormatFun' False ff ffs notafun where+ formatFun' = unsatisfiable++type family MissingError ff where+ MissingError ff =+ 'Text "Call to printf missing an argument fulfilling \"%"+ ':<>: 'Text (ShowFormat ff)+ ':<>: 'Text "\""+ ':$$: 'Text "Either provide an argument or rewrite the format string to not expect one."+ class Printf (str :: Symbol) fun where- -- | A version of 'GHC.TypeLits.Printf.printf' taking an explicit- -- proxy, which allows usage without /TypeApplications/- --- -- >>> putStrLn $ printf_ (Proxy :: Proxy "You have %.2f dollars, %s") 3.62 "Luigi"- -- You have 3.62 dollars, Luigi- printf_ :: p str -> fun+ -- | A version of 'GHC.TypeLits.Printf.printf' taking an explicit+ -- proxy, which allows usage without /TypeApplications/+ --+ -- >>> putStrLn $ printf_ (Proxy :: Proxy "You have %.2f dollars, %s") 3.62 "Luigi"+ -- You have 3.62 dollars, Luigi+ printf_ :: p str -> fun -instance (Listify str lst, ffs ~ ParseFmtStr_ lst, FormatFun ffs fun) => Printf str fun where- printf_ _ = formatFun (Proxy @ffs) ""+instance (ffs ~ ParseFmtStr_ str, FormatFun ffs fun) => Printf str fun where+ printf_ _ = formatFun (Proxy @ffs) "" -- | Utility type powering 'pfmt'. See documentation for 'pfmt' for more -- information on usage.@@ -352,10 +375,11 @@ -- -- >>> pfmt (mkPFmt_ (Proxy :: Proxy ".2f")) 3.6234124 -- "3.62"-mkPFmt_- :: forall str lst ff f w q m c p. (Listify str lst, ff ~ ParseFmt_ lst, Reflect ff, ff ~ 'FF f w q m c)- => p str- -> PFmt c+mkPFmt_ ::+ forall str ff f w q m c p.+ (ff ~ ParseFmt_ str, Reflect ff, ff ~ 'FF f w q m c) =>+ p str ->+ PFmt c mkPFmt_ _ = PFmt ff where ff = reflect (Proxy @ff)@@ -366,13 +390,14 @@ -- -- >>> pfmt (mkPFmt @".2f") 3.6234124 -- "3.62"-mkPFmt- :: forall str lst ff f w q m c. (Listify str lst, ff ~ ParseFmt_ lst, Reflect ff, ff ~ 'FF f w q m c)- => PFmt c-mkPFmt = mkPFmt_ @str @lst (Proxy @str)+mkPFmt ::+ forall str ff f w q m c.+ (ff ~ ParseFmt_ str, Reflect ff, ff ~ 'FF f w q m c) =>+ PFmt c+mkPFmt = mkPFmt_ @str (Proxy @str) -instance (Listify str lst, ff ~ ParseFmt_ lst, Reflect ff, ff ~ 'FF f w p m c) => IsLabel str (PFmt c) where- fromLabel = mkPFmt @str @lst+instance (ff ~ ParseFmt_ str, Reflect ff, ff ~ 'FF f w p m c) => IsLabel str (PFmt c) where+ fromLabel = mkPFmt @str -- | Parse and run a /single/ format hole on a single vale. Can be useful -- for formatting individual items or for testing your own custom instances of
src/GHC/TypeLits/Printf/Internal/Parser.hs view
@@ -1,85 +1,83 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE NoStarIsType #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoStarIsType #-} module GHC.TypeLits.Printf.Internal.Parser where -import Data.Kind-import Data.Type.Bool-import Data.Type.Equality-import GHC.TypeLits---- | A type synonym for a single-character symbol. Ideally this would just--- be 'Char', but we don't have chars at the type level. So, if you see--- 'SChar' in a type signature, it means that it's expected to be--- a symbol/string with only one single character.-type SChar = Symbol+import Data.Kind+import Data.Type.Bool+import Data.Type.Equality+import GHC.TypeLits type Parser a = a -> Type -type family RunParser (p :: Parser a) (str :: [SChar]) :: Maybe (a, [SChar])+type family RunParser (p :: Parser a) (uncons :: Maybe (Char, Symbol)) :: Maybe (a, Symbol) data Pure :: a -> Parser a-type instance RunParser (Pure x) str = 'Just '(x, str)+type instance RunParser (Pure x) (Just '(c, cs)) = Just '(x, ConsSymbol c cs)+type instance RunParser (Pure x) Nothing = Just '(x, "") -data Sym :: SChar -> Parser SChar-type instance RunParser (Sym c) (d ': cs) = If (c == d) ('Just '(c, cs)) 'Nothing-type instance RunParser (Sym c) '[] = 'Nothing+data AsChar :: Char -> Parser Char+type instance RunParser (AsChar c) (Just '(d, cs)) = If (c == d) (Just '(c, cs)) Nothing+type instance RunParser (AsChar c) Nothing = Nothing -data NotSym :: SChar -> Parser SChar-type instance RunParser (NotSym c) (d ': cs) = If (c == d) 'Nothing ('Just '(d, cs))-type instance RunParser (NotSym c) '[] = 'Nothing+data NotChar :: Char -> Parser Char+type instance RunParser (NotChar c) (Just '(d, cs)) = If (c == d) Nothing (Just '(d, cs))+type instance RunParser (NotChar c) Nothing = Nothing -data AnySym :: Parser SChar-type instance RunParser AnySym (c ': cs) = 'Just '(c, cs)-type instance RunParser AnySym '[] = 'Nothing+data AnyChar :: Parser Char+type instance RunParser AnyChar (Just '(c, cs)) = Just '(c, cs)+type instance RunParser AnyChar Nothing = Nothing -data Alpha :: Parser SChar-type instance RunParser Alpha (c ': cs) = If (IsAlpha c) ('Just '(c, cs)) 'Nothing-type instance RunParser Alpha '[] = 'Nothing+data Alpha :: Parser Char+type instance RunParser Alpha (Just '(c, cs)) = If (IsAlpha c) (Just '(c, cs)) Nothing+type instance RunParser Alpha Nothing = Nothing data (<$) :: b -> Parser a -> Parser b-type family RepHelp (x :: b) (r :: Maybe (a, [SChar])) :: Maybe (b, [SChar]) where- RepHelp x 'Nothing = 'Nothing- RepHelp x ('Just '(y, s)) = 'Just '(x, s)+type family RepHelp (x :: b) (r :: Maybe (a, Symbol)) :: Maybe (b, Symbol) where+ RepHelp x Nothing = Nothing+ RepHelp x (Just '(y, s)) = Just '(x, s) type instance RunParser (x <$ p) str = RepHelp x (RunParser p str) +-- | This is very slow because it goes down both branches data (<|>) :: Parser a -> Parser a -> Parser a+ type family ChoiceMaybe (x :: Maybe a) (y :: Maybe a) :: Maybe a where- ChoiceMaybe ('Just x) y = 'Just x- ChoiceMaybe 'Nothing y = y+ ChoiceMaybe (Just x) y = Just x+ ChoiceMaybe Nothing y = y type instance RunParser (x <|> y) str = ChoiceMaybe (RunParser x str) (RunParser y str) -type Optional p = ('Just <$> p) <|> Pure 'Nothing+type Optional p = (Just <$> p) <|> Pure Nothing data (*>) :: Parser a -> Parser b -> Parser b-type family SeqHelp (p :: Parser b) (r :: Maybe (a, [SChar])) :: Maybe (b, [SChar]) where- SeqHelp p 'Nothing = 'Nothing- SeqHelp p ('Just '(x, str)) = RunParser p str+type family SeqHelp (p :: Parser b) (r :: Maybe (a, Symbol)) :: Maybe (b, Symbol) where+ SeqHelp p Nothing = Nothing+ SeqHelp p (Just '(x, str)) = RunParser p (UnconsSymbol str) type instance RunParser (x *> y) str = SeqHelp y (RunParser x str) -- | Parse a single digit data Digit :: Parser Nat-type family DigitHelp (d :: Maybe Nat) (cs :: [SChar]) :: Maybe (Nat, [SChar]) where- DigitHelp 'Nothing cs = 'Nothing- DigitHelp ('Just d) cs = 'Just '(d, cs)-type instance RunParser Digit '[] = 'Nothing-type instance RunParser Digit (c ': cs) = DigitHelp (CharDigit c) cs +type family DigitHelp (d :: Maybe Nat) (cs :: Symbol) :: Maybe (Nat, Symbol) where+ DigitHelp Nothing cs = Nothing+ DigitHelp (Just d) cs = Just '(d, cs)+type instance RunParser Digit (Just '(c, cs)) = DigitHelp (CharDigit c) cs+type instance RunParser Digit Nothing = Nothing+ data (<$>) :: (a -> b) -> Parser a -> Parser b-type family MapConHelp (f :: a -> b) (r :: Maybe (a, [SChar])) :: Maybe (b, [SChar]) where- MapConHelp f 'Nothing = 'Nothing- MapConHelp f ('Just '(x, str)) = 'Just '(f x, str)+type family MapConHelp (f :: a -> b) (r :: Maybe (a, Symbol)) :: Maybe (b, Symbol) where+ MapConHelp f Nothing = Nothing+ MapConHelp f (Just '(x, str)) = Just '(f x, str) type instance RunParser (f <$> p) str = MapConHelp f (RunParser p str) data (<*>) :: Parser (a -> b) -> Parser a -> Parser b-type family ApHelp (r :: Maybe (a -> b, [SChar])) (q :: Parser a) :: Maybe (b, [SChar]) where- ApHelp 'Nothing q = 'Nothing- ApHelp ('Just '(f, str)) q = RunParser (f <$> q) str+type family ApHelp (r :: Maybe (a -> b, Symbol)) (q :: Parser a) :: Maybe (b, Symbol) where+ ApHelp Nothing q = Nothing+ ApHelp (Just '(f, str)) q = RunParser (f <$> q) (UnconsSymbol str) type instance RunParser (p <*> q) str = ApHelp (RunParser p str) q data Many :: Parser a -> Parser [a]@@ -89,99 +87,101 @@ -- | Parse a number data Number :: Parser Nat-type family NumberHelp (xs :: Maybe ([Nat], [SChar])) :: Maybe (Nat, [SChar]) where- NumberHelp 'Nothing = 'Nothing- NumberHelp ('Just '(ns, str)) = 'Just '(FromDigits ns 0, str)++type family NumberHelp (xs :: Maybe ([Nat], Symbol)) :: Maybe (Nat, Symbol) where+ NumberHelp (Just '(ns, str)) = Just '(FromDigits ns 0, str)+ NumberHelp Nothing = Nothing type instance RunParser Number str = NumberHelp (RunParser (Some Digit) str) -data Cat :: Parser [SChar] -> Parser Symbol-type family CatHelp (xs :: Maybe ([SChar], [SChar])) :: Maybe (Symbol, [SChar]) where- CatHelp 'Nothing = 'Nothing- CatHelp ('Just '(cs, str)) = 'Just '(CatChars cs, str)+data Cat :: Parser [Char] -> Parser Symbol+type family CatHelp (xs :: Maybe ([Char], Symbol)) :: Maybe (Symbol, Symbol) where+ CatHelp Nothing = Nothing+ CatHelp (Just '(cs, str)) = Just '(CatChars cs, str) type instance RunParser (Cat p) str = CatHelp (RunParser p str) -type family EvalHelp (r :: Maybe (a, [SChar])) :: Maybe a where- EvalHelp 'Nothing = 'Nothing- EvalHelp ('Just '(x, str)) = 'Just x-type EvalParser (p :: Parser a) str = EvalHelp (RunParser p str) :: Maybe a+type family EvalHelp (r :: Maybe (a, Symbol)) :: Maybe a where+ EvalHelp (Just '(x, str)) = Just x+ EvalHelp Nothing = Nothing+type EvalParser (p :: Parser a) (str :: Symbol) =+ EvalHelp (RunParser p (UnconsSymbol str)) :: Maybe a -type family EvalHelp_ (r :: Maybe (a, [SChar])) :: a where- EvalHelp_ ('Just '(x, str)) = x- EvalHelp_ 'Nothing = TypeError ('Text "Parse failed")-type EvalParser_ (p :: Parser a) str = EvalHelp_ (RunParser p str) :: a+type family EvalHelp_ (r :: Maybe (a, Symbol)) :: a where+ EvalHelp_ (Just '(x, str)) = x+ EvalHelp_ Nothing = TypeError ('Text "Parse failed")+type EvalParser_ (p :: Parser a) (str :: Symbol) = EvalHelp_ (RunParser p (UnconsSymbol str)) :: a -type family CharDigit (c :: SChar) :: Maybe Nat where- CharDigit "0" = 'Just 0- CharDigit "1" = 'Just 1- CharDigit "2" = 'Just 2- CharDigit "3" = 'Just 3- CharDigit "4" = 'Just 4- CharDigit "5" = 'Just 5- CharDigit "6" = 'Just 6- CharDigit "7" = 'Just 7- CharDigit "8" = 'Just 8- CharDigit "9" = 'Just 9- CharDigit c = 'Nothing+type family CharDigit (c :: Char) :: Maybe Nat where+ CharDigit '0' = Just 0+ CharDigit '1' = Just 1+ CharDigit '2' = Just 2+ CharDigit '3' = Just 3+ CharDigit '4' = Just 4+ CharDigit '5' = Just 5+ CharDigit '6' = Just 6+ CharDigit '7' = Just 7+ CharDigit '8' = Just 8+ CharDigit '9' = Just 9+ CharDigit c = Nothing type family FromDigits (xs :: [Nat]) (n :: Nat) :: Nat where- FromDigits '[] n = n- FromDigits (a ': bs) n = FromDigits bs (n * 10 + a)+ FromDigits '[] n = n+ FromDigits (a ': bs) n = FromDigits bs (n * 10 + a) -type family CatChars (cs :: [SChar]) :: Symbol where- CatChars '[] = ""- CatChars (c ': cs) = AppendSymbol c (CatChars cs)+type family CatChars (cs :: [Char]) :: Symbol where+ CatChars '[] = ""+ CatChars (c ': cs) = ConsSymbol c (CatChars cs) -type family IsAlpha (c :: SChar) :: Bool where- IsAlpha "a" = 'True- IsAlpha "b" = 'True- IsAlpha "c" = 'True- IsAlpha "d" = 'True- IsAlpha "e" = 'True- IsAlpha "f" = 'True- IsAlpha "g" = 'True- IsAlpha "h" = 'True- IsAlpha "i" = 'True- IsAlpha "j" = 'True- IsAlpha "k" = 'True- IsAlpha "l" = 'True- IsAlpha "m" = 'True- IsAlpha "n" = 'True- IsAlpha "o" = 'True- IsAlpha "p" = 'True- IsAlpha "q" = 'True- IsAlpha "r" = 'True- IsAlpha "s" = 'True- IsAlpha "t" = 'True- IsAlpha "u" = 'True- IsAlpha "v" = 'True- IsAlpha "w" = 'True- IsAlpha "x" = 'True- IsAlpha "y" = 'True- IsAlpha "z" = 'True- IsAlpha "A" = 'True- IsAlpha "B" = 'True- IsAlpha "C" = 'True- IsAlpha "D" = 'True- IsAlpha "E" = 'True- IsAlpha "F" = 'True- IsAlpha "G" = 'True- IsAlpha "H" = 'True- IsAlpha "I" = 'True- IsAlpha "J" = 'True- IsAlpha "K" = 'True- IsAlpha "L" = 'True- IsAlpha "M" = 'True- IsAlpha "N" = 'True- IsAlpha "O" = 'True- IsAlpha "P" = 'True- IsAlpha "Q" = 'True- IsAlpha "R" = 'True- IsAlpha "S" = 'True- IsAlpha "T" = 'True- IsAlpha "U" = 'True- IsAlpha "V" = 'True- IsAlpha "W" = 'True- IsAlpha "X" = 'True- IsAlpha "Y" = 'True- IsAlpha "Z" = 'True- IsAlpha a = 'False+type family IsAlpha (c :: Char) :: Bool where+ IsAlpha 'a' = True+ IsAlpha 'b' = True+ IsAlpha 'c' = True+ IsAlpha 'd' = True+ IsAlpha 'e' = True+ IsAlpha 'f' = True+ IsAlpha 'g' = True+ IsAlpha 'h' = True+ IsAlpha 'i' = True+ IsAlpha 'j' = True+ IsAlpha 'k' = True+ IsAlpha 'l' = True+ IsAlpha 'm' = True+ IsAlpha 'n' = True+ IsAlpha 'o' = True+ IsAlpha 'p' = True+ IsAlpha 'q' = True+ IsAlpha 'r' = True+ IsAlpha 's' = True+ IsAlpha 't' = True+ IsAlpha 'u' = True+ IsAlpha 'v' = True+ IsAlpha 'w' = True+ IsAlpha 'x' = True+ IsAlpha 'y' = True+ IsAlpha 'z' = True+ IsAlpha 'A' = True+ IsAlpha 'B' = True+ IsAlpha 'C' = True+ IsAlpha 'D' = True+ IsAlpha 'E' = True+ IsAlpha 'F' = True+ IsAlpha 'G' = True+ IsAlpha 'H' = True+ IsAlpha 'I' = True+ IsAlpha 'J' = True+ IsAlpha 'K' = True+ IsAlpha 'L' = True+ IsAlpha 'M' = True+ IsAlpha 'N' = True+ IsAlpha 'O' = True+ IsAlpha 'P' = True+ IsAlpha 'Q' = True+ IsAlpha 'R' = True+ IsAlpha 'S' = True+ IsAlpha 'T' = True+ IsAlpha 'U' = True+ IsAlpha 'V' = True+ IsAlpha 'W' = True+ IsAlpha 'X' = True+ IsAlpha 'Y' = True+ IsAlpha 'Z' = True+ IsAlpha a = False
+ src/GHC/TypeLits/Printf/Internal/Unsatisfiable.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++-- | A partial mock-up of the proposed Unsatisfiable constraint.+module GHC.TypeLits.Printf.Internal.Unsatisfiable (+ Unsatisfiable,+ unsatisfiable,+) where++import GHC.TypeLits++class Bottom where+ unsatisfiable :: a++class (Bottom, TypeError e) => Unsatisfiable (e :: ErrorMessage)+instance (Bottom, TypeError e) => Unsatisfiable (e :: ErrorMessage)
src/GHC/TypeLits/Printf/Parse.hs view
@@ -1,224 +1,239 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoStarIsType #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoStarIsType #-} module GHC.TypeLits.Printf.Parse (- ParseFmtStr- , ParseFmtStr_- , ParseFmt- , ParseFmt_- , ShowFormat- , FormatAdjustment(..)- , FormatSign(..)- , WidthMod(..)- , Flags(..)- , EmptyFlags- , FieldFormat(..)- , SChar- , Demote- , Reflect(..)- ) where+ ParseFmtStr,+ ParseFmtStr_,+ ParseFmt,+ ParseFmt_,+ ShowFormat,+ FormatAdjustment (..),+ FormatSign (..),+ WidthMod (..),+ Flags (..),+ EmptyFlags,+ FieldFormat (..),+ Demote,+ Reflect (..),+) where -import Data.Proxy-import Data.Text (Text)-import GHC.TypeLits hiding (natVal)-import GHC.TypeLits.Printf.Internal.Parser-import GHC.TypeNats-import Numeric.Natural-import Text.Printf (FormatAdjustment(..), FormatSign(..))-import qualified Data.Text as T-import qualified Text.Printf as P+import Data.Proxy+import Data.Text (Text)+import qualified Data.Text as T+import GHC.TypeLits hiding (natVal)+import GHC.TypeLits.Printf.Internal.Parser+import GHC.TypeNats+import Text.Printf (FormatAdjustment (..), FormatSign (..))+import qualified Text.Printf as P -- hello, we're going to attempt to implement -- https://docs.microsoft.com/en-us/cpp/c-runtime-library/format-specification-syntax-printf-and-wprintf-functions?view=vs-2019 data Flags = Flags- { fAdjust :: Maybe FormatAdjustment- , fSign :: Maybe FormatSign- , fAlternate :: Bool- }+ { fAdjust :: Maybe FormatAdjustment+ , fSign :: Maybe FormatSign+ , fAlternate :: Bool+ } -data WidthMod = WMhh- | WMh- | WMl- | WMll- | WML+data WidthMod+ = WMhh+ | WMh+ | WMl+ | WMll+ | WML data FieldFormat = FF- { fmtFlags :: Flags- , fmtWidth :: Maybe Nat- , fmtPrecision :: Maybe Nat- , fmtWidthMod :: Maybe WidthMod- , fmtChar :: SChar- }+ { fmtFlags :: Flags+ , fmtWidth :: Maybe Nat+ , fmtPrecision :: Maybe Nat+ , fmtWidthMod :: Maybe WidthMod+ , fmtChar :: Char+ } type family Demote k = a | a -> k type instance Demote FormatAdjustment = FormatAdjustment-type instance Demote FormatSign = FormatSign-type instance Demote Bool = Bool-type instance Demote (Maybe a) = Maybe (Demote a)-type instance Demote Nat = Natural-type instance Demote Symbol = Text-type instance Demote Flags = Flags-type instance Demote WidthMod = WidthMod-type instance Demote FieldFormat = P.FieldFormat+type instance Demote FormatSign = FormatSign+type instance Demote Bool = Bool+type instance Demote (Maybe a) = Maybe (Demote a)+type instance Demote Nat = Natural+type instance Demote Symbol = Text+type instance Demote Char = Char+type instance Demote Flags = Flags+type instance Demote WidthMod = WidthMod+type instance Demote FieldFormat = P.FieldFormat class Reflect (x :: a) where- reflect :: p x -> Demote a+ reflect :: p x -> Demote a -instance Reflect 'LeftAdjust where- reflect _ = LeftAdjust-instance Reflect 'ZeroPad where- reflect _ = ZeroPad-instance Reflect 'SignPlus where- reflect _ = SignPlus-instance Reflect 'SignSpace where- reflect _ = SignSpace-instance Reflect 'WMhh where- reflect _ = WMhh-instance Reflect 'WMh where- reflect _ = WMh-instance Reflect 'WMl where- reflect _ = WMl-instance Reflect 'WMll where- reflect _ = WMll-instance Reflect 'WML where- reflect _ = WML-instance Reflect 'False where- reflect _ = False-instance Reflect 'True where- reflect _ = True-instance Reflect 'Nothing where- reflect _ = Nothing-instance Reflect x => Reflect ('Just x) where- reflect _ = Just (reflect (Proxy @x))+instance Reflect LeftAdjust where+ reflect _ = LeftAdjust+instance Reflect ZeroPad where+ reflect _ = ZeroPad+instance Reflect SignPlus where+ reflect _ = SignPlus+instance Reflect SignSpace where+ reflect _ = SignSpace+instance Reflect WMhh where+ reflect _ = WMhh+instance Reflect WMh where+ reflect _ = WMh+instance Reflect WMl where+ reflect _ = WMl+instance Reflect WMll where+ reflect _ = WMll+instance Reflect WML where+ reflect _ = WML+instance Reflect False where+ reflect _ = False+instance Reflect True where+ reflect _ = True+instance Reflect Nothing where+ reflect _ = Nothing+instance Reflect x => Reflect (Just x) where+ reflect _ = Just (reflect (Proxy @x)) instance KnownNat n => Reflect (n :: Nat) where- reflect = natVal+ reflect = natVal instance KnownSymbol n => Reflect (n :: Symbol) where- reflect = T.pack . symbolVal+ reflect = T.pack . symbolVal+instance KnownChar c => Reflect (c :: Char) where+ reflect = charVal instance (Reflect d, Reflect i, Reflect l) => Reflect ('Flags d i l) where- reflect _ = Flags (reflect (Proxy @d))- (reflect (Proxy @i))- (reflect (Proxy @l))-instance (Reflect flags, Reflect width, Reflect prec, Reflect mods, Reflect chr)- => Reflect ('FF flags width prec mods chr) where- reflect _ = P.FieldFormat{..}- where- Flags{..} = reflect (Proxy @flags)- fmtWidth = fromIntegral <$> reflect (Proxy @width)- fmtPrecision = fromIntegral <$> reflect (Proxy @prec)- fmtAdjust = fAdjust- fmtSign = fSign- fmtAlternate = fAlternate- fmtModifiers = foldMap modString (reflect (Proxy @mods))- fmtChar = T.head (reflect (Proxy @chr))+ reflect _ =+ Flags+ (reflect (Proxy @d))+ (reflect (Proxy @i))+ (reflect (Proxy @l))+instance+ (Reflect flags, Reflect width, Reflect prec, Reflect mods, Reflect chr) =>+ Reflect ('FF flags width prec mods chr)+ where+ reflect _ = P.FieldFormat{..}+ where+ Flags{..} = reflect (Proxy @flags)+ fmtWidth = fromIntegral <$> reflect (Proxy @width)+ fmtPrecision = fromIntegral <$> reflect (Proxy @prec)+ fmtAdjust = fAdjust+ fmtSign = fSign+ fmtAlternate = fAlternate+ fmtModifiers = foldMap modString (reflect (Proxy @mods))+ fmtChar = reflect (Proxy @chr) type family ShowFormat (x :: k) :: Symbol -type instance ShowFormat 'LeftAdjust = "-"-type instance ShowFormat 'ZeroPad = "0"-type instance ShowFormat 'SignPlus = "+"-type instance ShowFormat 'SignSpace = " "-type instance ShowFormat 'Nothing = ""-type instance ShowFormat ('Just x) = ShowFormat x-type instance ShowFormat ('Flags a s 'False) = ShowFormat a `AppendSymbol` ShowFormat s-type instance ShowFormat ('Flags a s 'True ) = ShowFormat a `AppendSymbol` ShowFormat s `AppendSymbol` "#"-type instance ShowFormat 'WMhh = "hh"-type instance ShowFormat 'WMh = "h"-type instance ShowFormat 'WMl = "l"-type instance ShowFormat 'WMll = "ll"-type instance ShowFormat 'WML = "L"+type instance ShowFormat LeftAdjust = "-"+type instance ShowFormat ZeroPad = "0"+type instance ShowFormat SignPlus = "+"+type instance ShowFormat SignSpace = " "+type instance ShowFormat Nothing = ""+type instance ShowFormat (Just x) = ShowFormat x+type instance ShowFormat ('Flags a s False) = ShowFormat a `AppendSymbol` ShowFormat s+type instance+ ShowFormat ('Flags a s True) =+ ShowFormat a `AppendSymbol` ShowFormat s `AppendSymbol` "#"+type instance ShowFormat WMhh = "hh"+type instance ShowFormat WMh = "h"+type instance ShowFormat WMl = "l"+type instance ShowFormat WMll = "ll"+type instance ShowFormat WML = "L" type instance ShowFormat (n :: Nat) = ShowNat n-type instance ShowFormat ('FF f w 'Nothing m c) = ShowFormat f- `AppendSymbol` ShowFormat w- `AppendSymbol` ShowFormat m- `AppendSymbol` c-type instance ShowFormat ('FF f w ('Just p) m c) = ShowFormat f- `AppendSymbol` ShowFormat w- `AppendSymbol` "."- `AppendSymbol` ShowFormat p- `AppendSymbol` ShowFormat m- `AppendSymbol` c+type instance+ ShowFormat ('FF f w Nothing m c) =+ ShowFormat f+ `AppendSymbol` ShowFormat w+ `AppendSymbol` ShowFormat m+ `AppendSymbol` ConsSymbol c ""+type instance+ ShowFormat ('FF f w (Just p) m c) =+ ShowFormat f+ `AppendSymbol` ShowFormat w+ `AppendSymbol` "."+ `AppendSymbol` ShowFormat p+ `AppendSymbol` ShowFormat m+ `AppendSymbol` ConsSymbol c "" type family ShowNat (n :: Nat) :: Symbol where- ShowNat 0 = "0"- ShowNat n = ShowNatHelp n+ ShowNat 0 = "0"+ ShowNat n = ShowNatHelp n type family ShowNatHelp (n :: Nat) :: Symbol where- ShowNatHelp 0 = ""- ShowNatHelp n = AppendSymbol (ShowNatHelp (Div n 10)) (ShowDigit (Mod n 10))+ ShowNatHelp 0 = ""+ ShowNatHelp n = AppendSymbol (ShowNatHelp (Div n 10)) (ConsSymbol (ShowDigit (Mod n 10)) "") -type family ShowDigit (n :: Nat) :: SChar where- ShowDigit 0 = "0"- ShowDigit 1 = "1"- ShowDigit 2 = "2"- ShowDigit 3 = "3"- ShowDigit 4 = "4"- ShowDigit 5 = "5"- ShowDigit 6 = "6"- ShowDigit 7 = "7"- ShowDigit 8 = "8"- ShowDigit 9 = "9"+type family ShowDigit (n :: Nat) :: Char where+ ShowDigit 0 = '0'+ ShowDigit 1 = '1'+ ShowDigit 2 = '2'+ ShowDigit 3 = '3'+ ShowDigit 4 = '4'+ ShowDigit 5 = '5'+ ShowDigit 6 = '6'+ ShowDigit 7 = '7'+ ShowDigit 8 = '8'+ ShowDigit 9 = '9' modString :: WidthMod -> String modString = \case- WMhh -> "hh"- WMh -> "h"- WMl -> "l"- WMll -> "ll"- WML -> "L"+ WMhh -> "hh"+ WMh -> "h"+ WMl -> "l"+ WMll -> "ll"+ WML -> "L" data FlagParser :: Parser Flags-type instance RunParser FlagParser str = 'Just (ProcessFlags EmptyFlags str)+type instance RunParser FlagParser str = Just (ProcessFlags EmptyFlags str) -type EmptyFlags = 'Flags 'Nothing 'Nothing 'False+type EmptyFlags = 'Flags Nothing Nothing False -type family ProcessFlags (f :: Flags) (str :: [SChar]) :: (Flags, [SChar]) where- ProcessFlags ('Flags d i l) ("-" ': cs) = '( 'Flags ('Just (UpdateAdjust d 'LeftAdjust)) i l, cs)- ProcessFlags ('Flags d i l) ("0" ': cs) = '( 'Flags ('Just (UpdateAdjust d 'ZeroPad )) i l, cs)- ProcessFlags ('Flags d i l) ("+" ': cs) = '( 'Flags d ('Just (UpdateSign i 'SignPlus )) l, cs)- ProcessFlags ('Flags d i l) (" " ': cs) = '( 'Flags d ('Just (UpdateSign i 'SignSpace)) l, cs)- ProcessFlags ('Flags d i l) ("#" ': cs) = '( 'Flags d i 'True, cs)- ProcessFlags f cs = '(f, cs)+type family ProcessFlags (f :: Flags) (str :: Maybe (Char, Symbol)) :: (Flags, Symbol) where+ ProcessFlags ('Flags d i l) (Just '( '-', cs)) =+ '( 'Flags (Just (UpdateAdjust d LeftAdjust)) i l, cs)+ ProcessFlags ('Flags d i l) (Just '( '0', cs)) = '( 'Flags (Just (UpdateAdjust d ZeroPad)) i l, cs)+ ProcessFlags ('Flags d i l) (Just '( '+', cs)) = '( 'Flags d (Just (UpdateSign i SignPlus)) l, cs)+ ProcessFlags ('Flags d i l) (Just '( ' ', cs)) = '( 'Flags d (Just (UpdateSign i SignSpace)) l, cs)+ ProcessFlags ('Flags d i l) (Just '( '#', cs)) = '( 'Flags d i True, cs)+ ProcessFlags f (Just '(c, cs)) = '(f, ConsSymbol c cs)+ ProcessFlags f Nothing = '(f, "") type family UpdateAdjust d1 d2 where- UpdateAdjust 'Nothing d2 = d2- UpdateAdjust ('Just 'LeftAdjust) d2 = 'LeftAdjust- UpdateAdjust ('Just 'ZeroPad ) d2 = d2+ UpdateAdjust Nothing d2 = d2+ UpdateAdjust (Just LeftAdjust) d2 = LeftAdjust+ UpdateAdjust (Just ZeroPad) d2 = d2 type family UpdateSign i1 i2 where- UpdateSign 'Nothing i2 = i2- UpdateSign ('Just 'SignPlus ) i2 = 'SignPlus- UpdateSign ('Just 'SignSpace) i2 = i2-+ UpdateSign Nothing i2 = i2+ UpdateSign (Just SignPlus) i2 = SignPlus+ UpdateSign (Just SignSpace) i2 = i2 -type WMParser = (Sym "h" *> (('WMhh <$ Sym "h") <|> Pure 'WMh))- <|> (Sym "l" *> (('WMll <$ Sym "l") <|> Pure 'WMl))- <|> ('WML <$ Sym "L")+type WMParser =+ (AsChar 'h' *> ((WMhh <$ AsChar 'h') <|> Pure WMh))+ <|> (AsChar 'l' *> ((WMll <$ AsChar 'l') <|> Pure WMl))+ <|> (WML <$ AsChar 'L') -type FFParser = 'FF <$> FlagParser- <*> Optional Number- <*> Optional (Sym "." *> Number)- <*> Optional WMParser- <*> AnySym- -- <*> Alpha -- which of these is right?+type FFParser =+ 'FF+ <$> FlagParser+ <*> Optional Number+ <*> Optional (AsChar '.' *> Number)+ <*> Optional WMParser+ <*> AnyChar -type FmtStrParser = Many ( ('Left <$> Cat (Some (NotSym "%" <|> (Sym "%" *> Sym "%"))))- <|> ('Right <$> (Sym "%" *> FFParser))- )+type FmtStrParser =+ Many+ ( (Left <$> Cat (Some (NotChar '%' <|> (AsChar '%' *> AsChar '%'))))+ <|> (Right <$> (AsChar '%' *> FFParser))+ ) -type ParseFmtStr str = EvalParser FmtStrParser str+type ParseFmtStr str = EvalParser FmtStrParser str type ParseFmtStr_ str = EvalParser_ FmtStrParser str -type ParseFmt str = EvalParser FFParser str+type ParseFmt str = EvalParser FFParser str type ParseFmt_ str = EvalParser_ FFParser str-
+ test/spec.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import GHC.TypeLits.Printf+import Test.Hspec++-- TODO: test for type errors, stuff like that. For now we just test for+-- parsing long strings+main :: IO ()+main = hspec do+ describe "typelits-printf" do+ it "formats a basic string" do+ printf "Hello %0.2f, %s" (3.26 :: Double) "Luigi" `shouldBe` "Hello 3.26, Luigi"+ printf' @"Hello %0.2f, %s" (3.26 :: Double) "Luigi" `shouldBe` "Hello 3.26, Luigi"+ it "formats a long string" do+ printf+ "This is a long string a very %s in the past this took a long time to compile %d"+ "long string"+ (2 :: Int)+ `shouldBe` "This is a long string a very long string in the past this took a long time to compile 2"
typelits-printf.cabal view
@@ -1,53 +1,70 @@-cabal-version: 1.12+cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.36.1. -- -- see: https://github.com/sol/hpack------ hash: ab8bb88b98e9aefe5c55f593c26d691a8125a6014b60204b85fda8f8ea01e90b -name: typelits-printf-version: 0.2.0.0-synopsis: Type-safe printf from parsing GHC TypeLits Symbol-description: An extensible and type-safe printf from parsing GHC TypeLits Symbol- literals, matching the semantics of 'P.printf' from "Text.Printf" in /base/.- The difference is that the variants here will always fail to compile if- given arguments of the wrong type (or too many or too little arguments).- Most of the variants also provide useful type feedback, telling you the type- of arguments it expects and how many when queried with @:t@ or with typed- holes.- .- See README and documentation of "GHC.TypeLits.Printf" for more information-category: Text-homepage: https://github.com/mstksg/typelits-printf#readme-bug-reports: https://github.com/mstksg/typelits-printf/issues-author: Justin Le-maintainer: justin@jle.im-copyright: (c) Justin Le 2019-license: BSD3-license-file: LICENSE-tested-with: GHC >= 8.8 && < 8.10-build-type: Simple+name: typelits-printf+version: 0.3.0.0+synopsis: Type-safe printf from parsing GHC TypeLits Symbol+description:+ An extensible and type-safe printf from parsing GHC TypeLits Symbol+ literals, matching the semantics of 'P.printf' from "Text.Printf" in /base/.+ The difference is that the variants here will always fail to compile if+ given arguments of the wrong type (or too many or too little arguments).+ Most of the variants also provide useful type feedback, telling you the type+ of arguments it expects and how many when queried with @:t@ or with typed+ holes.+ .+ See README and documentation of "GHC.TypeLits.Printf" for more information++category: Text+homepage: https://github.com/mstksg/typelits-printf#readme+bug-reports: https://github.com/mstksg/typelits-printf/issues+author: Justin Le+maintainer: justin@jle.im+copyright: (c) Justin Le 2019+license: BSD3+license-file: LICENSE+build-type: Simple+tested-with: GHC >=9.2 extra-source-files:- README.md- CHANGELOG.md+ CHANGELOG.md+ README.md source-repository head- type: git+ type: git location: https://github.com/mstksg/typelits-printf library exposed-modules:- GHC.TypeLits.Printf- GHC.TypeLits.Printf.Internal+ GHC.TypeLits.Printf+ GHC.TypeLits.Printf.Internal+ other-modules:- GHC.TypeLits.Printf.Internal.Parser- GHC.TypeLits.Printf.Parse- hs-source-dirs:- src- ghc-options: -Wall -Wcompat -Werror=incomplete-patterns+ GHC.TypeLits.Printf.Internal.Parser+ GHC.TypeLits.Printf.Internal.Unsatisfiable+ GHC.TypeLits.Printf.Parse++ hs-source-dirs: src+ ghc-options: -Wall -Wcompat -Werror=incomplete-patterns build-depends:- base >=4.13 && <5- , symbols >=0.3 && <0.4+ base >=4.16 && <5 , text++ default-language: Haskell2010++test-suite typelits-printf-test+ type: exitcode-stdio-1.0+ main-is: spec.hs+ hs-source-dirs: test+ ghc-options:+ -Wall -Wcompat -Wredundant-constraints -threaded -rtsopts+ -with-rtsopts=-N -O2 -freduction-depth=0++ build-depends:+ base >=4.9 && <5+ , hspec+ , typelits-printf+ default-language: Haskell2010