diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +Changelog +========= + +Version 0.1.0.0 +--------------- + +*February 25, 2020* + + + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Justin Le (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Justin Le nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,152 @@ +# symbols-printf + +(Heavily inspired by *[Data.Symbol.Examples.Printf][symbols]*) + +[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" +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 +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. + +[Text.Printf]: https://hackage.haskell.org/package/base/docs/Text-Printf.html + +There are three main calling conventions offered: + +```haskell +ghci> putStrLn $ printf @"You have %.2f dollars, %s" 3.62 "Luigi" +You have 3.62 dollars, Luigi + +ghci> putStrLn $ pprintf @"You have %.2f dollars, %s" (PP 3.62) (PP "Luigi") +You have 3.62 dollars, Luigi + +ghci> putStrLn $ rprintf @"You have %.2f dollars, %s" (3.62 :% "Luigi" :% RNil) +You have 3.62 dollars, Luigi +``` + +Comparing their types: + +```haskell +ghci> :t printf @"You have %.2f dollars, %s" 3.62 "Luigi" +FormatFun '[ .... ] fun => fun + +ghci> :t pprintf @"You have %.2f dollars, %s" 3.62 "Luigi" +PP "f" -> PP "s" -> String + +ghci> :t rprintf @"You have %.2f dollars, %s" 3.62 "Luigi" +FormatArgs '["f", "s"] -> String +``` + +* The type of `printf` doesn't tell you immediately what you + you need. However, if you do try to use it, the type errors will guide you + along the way, iteratively. + + ```haskell + ghci> 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> 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> printf @"You have %.2f dollars, %s" 3.62 "Luigi" + You have 3.62 dollars, Luigi + + ghci> 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. + ``` + +* For `pprintf`, it shows you need two arguments: A `PP "f"` (which is a + value that supports being formatted by `f`) like `PP 3.62`, and a `PP "s"`, + like `PP "Luigi"`. + +* `rprintf` tells you you need a two-item hlist (from "Data.Vinyl.Core"), + where the first item implements `f` and the second item implements `s`: + `3.62 :% "Luigi" :% RNil` will do. + +The following table summarizes the features and drawbacks of each +method: + +| Method | True Polyarity | Naked Arguments | Type feedback | +| --------- | ---------------- | ------------------ | -------------------- | +| `printf` | Yes | Yes | Partial (via errors) | +| `pprintf` | Yes | No (requires `PP`) | Yes | +| `rprintf` | No (HList-based) | Yes | Yes | + +*Ideally* we would have a solution that has all three. However, as of now, we +have a "pick two" sort of situation. Suggestions are definitely welcome, +however, if you find something that satisfies all three benefits while still +allowing for polymorphism! + +You can extend functionality with formatting for your own types by providing +instances of `FormatType`. + +## 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. + +[symbols]: https://hackage.haskell.org/package/symbols + +Moving to typechecker plugin based parsing *does* improve performance ... +however, I'm not sure how to get around requiring every module using `printf` +to require enabling the typechecker plugin, which isn't too great from a +usability standpoint. Template Haskell based alternatives (like +*[th-printf][]*) already do require an extra pragma (for *QuasiQuotes*), though +so it might not be too bad in comparison. + +## Comparisons + +There are a few other options for type-safe printfs out on hackage, and they +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 +fomatters, and so you always need to duplicate double-quotes for string +literals. This detracts from one of the main convenience aspects of *printf*, +in my opinion. + +```haskell +"You have " % f' 2 % " dollars, " % s +-- vs +"You have %.2f dollars, %s" +``` + +However, calling these libraries "safe printf libraries" does not do them +justice. A library like *[formatting][]* is a feature-rich formatting library, +handling things like dates and other useful formatting features in a +first-class way that embraces Haskell idioms. This library here is merely a +type-safe printf, emulating the features of *base*'s printf and C `printf(3)`. + +[th-printf]: https://hackage.haskell.org/package/th-printf +[safe-printf]: https://hackage.haskell.org/package/safe-printf +[formatting]: https://hackage.haskell.org/package/formatting +[printf-safe]: https://hackage.haskell.org/package/printf-safe +[xformat]: https://hackage.haskell.org/package/xformat +[category-printf]: https://hackage.haskell.org/package/category-printf + +## Todo + +* Make faster +* Tests +* Support for localization/dynamic strings. Should be possible, but we'd + have to re-implement a subset of singletons. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/GHC/TypeLits/Printf.hs b/src/GHC/TypeLits/Printf.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TypeLits/Printf.hs @@ -0,0 +1,259 @@ +{-# 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 #-} + +-- | +-- Module : GHC.TypeLits.Printf +-- Copyright : (c) Justin Le 2019 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- 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 documentation in "Text.Printf" for +-- details on how this formats items of various types, and the differences +-- with C @printf(3)@. +-- +-- There are three main calling conventions supported: +-- +-- >>> putStrLn $ printf @"You have %.2f dollars, %s" 3.62 "Luigi" +-- You have 3.62 dollars, Luigi +-- >>> putStrLn $ pprintf @"You have %.2f dollars, %s" (PP 3.62) (PP "Luigi") +-- You have 3.62 dollars, Luigi +-- >>> putStrLn $ rprintf @"You have %.2f dollars, %s" (3.62 :% "Luigi" :% RNil) +-- You have 3.62 dollars, Luigi +-- +-- Now comparing their types: +-- +-- >>> :t printf @"You have %.2f dollars, %s" 3.62 "Luigi" +-- FormatFun '[ .... ] fun => fun +-- >>> :t pprintf @"You have %.2f dollars, %s" 3.62 "Luigi" +-- PP "f" -> PP "s" -> String +-- >>> :t rprintf @"You have %.2f dollars, %s" 3.62 "Luigi" +-- FormatArgs '["f", "s"] -> String +-- +-- * The type of `printf` doesn't tell you immediately what you you need. +-- However, if you do try to use it, the type errors will guide you +-- along the way, iteratively. +-- +-- >>> 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. +-- +-- >>> 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. +-- +-- >>> printf @"You have %.2f dollars, %s" 3.62 "Luigi" +-- You have 3.62 dollars, Luigi +-- +-- >>> 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. +-- +-- * For 'pprintf', it shows you need two arguments: A @'PP' "f"@ (which +-- is a value that supports being formatted by @f@) like @PP 3.62@, and +-- a @'PP' "s"@, like @PP "Luigi"@. +-- +-- * 'rprintf' tells you you need a two-item hlist (from +-- "Data.Vinyl.Core"), where the first item implements @f@ and the +-- second item implements @s@: @3.62 ':%' "Luigi" :% 'RNil'@ will do. +-- +-- The following table summarizes the features and drawbacks of each +-- method: +-- +-- +-----------+------------------+--------------------+----------------------+ +-- | Method | True Polyarity | Naked Arguments | Type feedback | +-- +===========+==================+====================+======================+ +-- | 'printf' | Yes | Yes | Partial (via errors) | +-- +-----------+------------------+--------------------+----------------------+ +-- | 'pprintf' | Yes | No (requires 'PP') | Yes | +-- +-----------+------------------+--------------------+----------------------+ +-- | 'rprintf' | No (HList-based) | Yes | Yes | +-- +-----------+------------------+--------------------+----------------------+ +-- +-- /Ideally/ we would have a solution that has all three. However, as of +-- now, we have a "pick two" sort of situation. Suggestions are definitely +-- welcome, however, if you find something that satisfies all three +-- benefits while still allowing for polymorphism! +-- +-- 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 ( + -- * Formattable things + FormatType(..) + , SChar + -- * Printf + -- ** Unguarded polyarity + , printf, printf_ + , PHelp, pHelp + , FormatFun + -- ** Guarded polyarity + , pprintf + , pprintf_ + , PP(..) + -- ** List-based polyarity + , rprintf, rprintf_ + , Rec((:%), RNil), FormatArgs + -- * Single item + , pfmt + , PFmt + , mkPFmt, mkPFmt_ + ) where + +import Data.Proxy +import Data.Vinyl +import Data.Vinyl.Curry +import GHC.TypeLits.Printf.Internal + +-- | Type-safe printf with faked polyarity. Pass in a "list" of arguments +-- (using ':%' and 'RNil'), instead of as multiple arguments. Call it like +-- @'rprintf' \@"you have %.02f dollars, %s"@. +-- +-- >>> :t rprintf @"You have %.2f dollars, %s" +-- FormatArgs '["f", "s"] -> String +-- +-- This means that it is expecting something that can be printed with @f@ +-- and something that can be printed with @s@. We can provide a 'Double' +-- and a 'String': +-- +-- >>> putStrLn $ rprintf @"You have %.2f dollars, %s" (3.62 ':%' "Luigi" :% 'RNil') +-- You have 3.62 dollars, Luigi +-- +-- See 'pprintf' for a version with true polyarity and good clear types, +-- but requires wrapping its arguments, and 'printf' for a version with +-- true polyarity but less clear types. Also see top-level module +-- documentation "GHC.TypeLits.Printf" for a more comprehensive summary. +rprintf :: forall str ps. RPrintf str ps => FormatArgs ps -> String +rprintf = rprintf_ (Proxy @str) + +-- | Pattern and constructor allowing you to construct a 'FormatArgs'. +-- +-- To construct a @'FormatArgs' '["f", "s"]@, for instance, you need to +-- give a value formattable by @f@ and a value formattable by @s@, given +-- like a linked list, with ':%' for cons and 'RNil' for nil. +-- +-- @ +-- 3.62 ':%' "Luigi" :% 'RNil' +-- @ +-- +-- (This should evoke the idea of of @3.62 : "Luigi" : []@, even though the +-- latter is not possible in Haskell) +pattern (:%) :: () => FormatType c a => a -> FormatArgs cs -> FormatArgs (c ': cs) +pattern x :% xs = PP x :& xs +infixr 7 :% +{-# COMPLETE (:%) #-} + +-- | A version of 'pprintf' taking an explicit proxy, which allows usage +-- without /TypeApplications/ +-- +-- >>> :t pprintf_ (Proxy :: Proxy "You have %.2f dollars, %s") +-- PP "f" -> PP "s" -> String +pprintf_ :: forall str ps p. (RPrintf str ps, RecordCurry ps) => p str -> CurriedF PP ps String +pprintf_ p = rcurry @ps (rprintf_ p) + +-- | Type-safe printf with true guarded polyarity. Call it like @'pprintf' +-- \@"you have %.02f dollars, %s"@. +-- +-- A call to printf on a valid string will /always/ give a well-defined +-- type for a function in return: +-- +-- >>> :t pprintf @"You have %.2f dollars, %s" +-- PP "f" -> PP "s" -> String +-- +-- You can always query the type, and get a well-defined type back, which +-- you can utilize using typed holes or other type-guided development +-- techniques. +-- +-- To give 'pprintf' its arguments, however, they must be wrapped in 'PP': +-- +-- >>> putStrLn $ pprintf @"You have %.2f dollars, %s" (PP 3.62) (PP "Luigi") +-- You have 3.62 dollars, Luigi +-- +-- See 'printf' for a polyariadic method that doesn't require 'PP' on its +-- inputs, but with a less helpful type signature, and 'rprintf' for +-- a fake-polyariadic method that doesn't require 'PP', but requires +-- arguments in a single list instead. Also see top-level module +-- documentation "GHC.TypeLits.Printf" for a more comprehensive summary. +pprintf :: forall str ps. (RPrintf str ps, RecordCurry ps) => CurriedF PP ps String +pprintf = pprintf_ @str @ps (Proxy @str) + +-- | Type-safe printf with true naked polyarity. Call it like @'printf' +-- \@"you have %.02f dollars, %s"@. +-- +-- >>> putStrLn $ printf @"You have %.2f dollars, %s" 3.62 "Luigi" +-- You have 3.62 dollars, Luigi +-- +-- While the type of @'printf' \@"my fmt string"@ isn't going to be very +-- helpful, the error messages should help guide you along the way: +-- +-- >>> 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. +-- +-- >>> 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. +-- +-- >>> printf @"You have %.2f dollars, %s" 3.62 "Luigi" +-- You have 3.62 dollars, Luigi +-- +-- >>> 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. +-- +-- If you're having problems getting the error messages to give helpful +-- feedback, try using 'pHelp': +-- +-- >>> 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. +-- +-- 'pHelp' can give the type system the nudge it needs to provide good +-- errors. +-- +-- See 'pprintf' for a version of this with nicer types and type errors, +-- but requires wrapping arguments, and 'rprintf' for a version of this +-- with "fake" polyarity, taking a list as input instead. Also see +-- top-level module documentation "GHC.TypeLits.Printf" for a more +-- comprehensive summary. +-- +-- 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) + diff --git a/src/GHC/TypeLits/Printf/Internal.hs b/src/GHC/TypeLits/Printf/Internal.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TypeLits/Printf/Internal.hs @@ -0,0 +1,515 @@ +{-# 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 #-} + +-- | +-- Module : GHC.TypeLits.Printf.Internal +-- Copyright : (c) Justin Le 2019 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Internal workings of the printf mechanisms, exposed for potential +-- debugging purposes. +-- +-- 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(..) + , PP(..) + , RPrintf(..) + , FormatArgs + , RFormat(..) + , Printf(..) + , FormatFun(..) + , PFmt(..) + , pfmt + , mkPFmt, mkPFmt_ + , PHelp(..) + ) where + +import Data.Int +import Data.Proxy +import Data.Symbol.Utils +import Data.Vinyl +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 + +-- | 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 + +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 "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" 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 "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 "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 "s" String +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 +-- | Treats as @d@ +instance FormatType "v" Int +-- | Treats as @d@ +instance FormatType "v" Int8 +-- | Treats as @d@ +instance FormatType "v" Int16 +-- | Treats as @d@ +instance FormatType "v" Int32 +-- | Treats as @d@ +instance FormatType "v" Int64 +-- | Treats as @d@ +instance FormatType "v" Integer +-- | Treats as @u@ +instance FormatType "v" Natural +-- | Treats as @u@ +instance FormatType "v" Word +-- | Treats as @u@ +instance FormatType "v" Word8 +-- | Treats as @u@ +instance FormatType "v" Word16 +-- | Treats as @u@ +instance FormatType "v" Word32 +-- | Treats as @u@ +instance FormatType "v" Word64 +-- | Treats as @g@ +instance FormatType "v" Double +-- | Treats as @g@ +instance FormatType "v" Float +-- | Treats as @s@ +instance FormatType "v" String +-- | Treats as @s@ +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 + +-- | Required wrapper around inputs to 'GHC.TypeLits.Printf.pprintf' +-- (guarded polyarity). See documentation for +-- 'GHC.TypeLits.Printf.pprintf' for examples of usage. +-- +-- You can "wrap" any value in 'PP' as long as it can be formatted as the +-- format type indicated. +-- +-- For example, to make a @'PP' "f"@, you can use @'PP' 3.5@ or @'PP' +-- 94.2@, but not @'PP' (3 :: Int)@ or @'PP' "hello"@. To make a value of +-- type @'PP' c@, you must wrap a value that can be formatted via @c@. +data PP (c :: SChar) = forall a. FormatType c a => PP a + +-- | A heterogeneous list (from "Data.Vinyl.Core") used for calling with +-- 'GHC.TypeLits.Printf.rprintf'. Instead of supplying the inputs as +-- different arguments, we can gather all the inputs into a single list to +-- give to 'GHC.TypeLits.Printf.rprintf'. +-- +-- >>> :t rprintf @"You have %.2f dollars, %s" +-- FormatArgs '["f", "s"] -> String +-- +-- To construct a @'FormatArgs' '["f", "s"]@, you need to give a value +-- formattable by @f@ and a value formattable by @s@, given like a linked +-- list, with 'GHC.TypeLits.Printf.:%' for cons and 'RNil' for nil. +-- +-- >>> putStrLn $ rprintf @"You have %.2f dollars, %s" (3.62 :% "Luigi" :% RNil) +-- You have 3.62 dollars, Luigi +-- +-- (This should evoke the idea of of @3.62 : "Luigi" : []@, even though the +-- latter is not possible in Haskell) +type FormatArgs = Rec PP + +class RFormat (ffs :: [Either Symbol FieldFormat]) (ps :: [SChar]) | ffs -> ps where + rformat :: p ffs -> FormatArgs ps -> ShowS + +instance RFormat '[] '[] where + rformat _ _ = id + +instance (KnownSymbol str, RFormat ffs ps) => RFormat ('Left str ': ffs) ps where + rformat _ r = showString (symbolVal (Proxy @str)) + . rformat (Proxy @ffs) r + +instance (Reflect ff, ff ~ 'FF f w p m c, RFormat ffs ps) => RFormat ('Right ff ': ffs) (c ': ps) where + rformat _ (PP x :& xs) = formatArg (Proxy @c) x ff + . rformat (Proxy @ffs) xs + where + ff = reflect (Proxy @ff) + +class RPrintf (str :: Symbol) ps where + -- | A version of 'GHC.TypeLits.Printf.rprintf' taking an explicit + -- proxy, which allows usage without /TypeApplications/ + -- + -- >>> :t rprintf_ (Proxy :: Proxy "You have %.2f dollars, %s") + -- FormatArgs '["f", "s"] -> String + rprintf_ :: p str -> FormatArgs ps -> String + +instance (Listify str lst, ffs ~ ParseFmtStr_ lst, RFormat ffs ps) => RPrintf str ps where + rprintf_ _ = ($ "") . rformat (Proxy @ffs) + +-- | The typeclass supporting polyarity used by +-- 'GHC.TypeLits.Printf.printf'. It works in mostly the same way as +-- 'P.PrintfType' from "Text.Printf", and similar the same as +-- 'Data.Symbol.Examples.Printf.FormatF'. +-- +-- Ideally, you will never have to run into this typeclass or have to deal +-- with it. It will come up if you ask for the type of +-- 'GHC.TypeLits.Printf.printf', or sometimes if you give the wrong number +-- or type of arguments to it. +-- +-- >>> :t printf @"You have %.2f dollars, %s" +-- FormatFun '[ Right ..., 'Left " dollars ", 'Right ...] fun => fun +-- +-- Every item in the first argument of 'FormatFun' is a chunk of the +-- formatting string, split between format holes ('Right') and string +-- chunks ('Left'). You can successively "eliminate" them by providing +-- more arguments that implement each hole: +-- +-- >>> :t printf @"You have %.2f dollars, %s" 3.62 +-- FormatFun '[ Right ...] fun => fun +-- +-- Until you you finally fill all the holes: +-- +-- >>> :t printf @"You have %.2f dollars, %s" 3.62 "Luigi" +-- FormatFun '[] t => t +-- +-- at which point you may use it as a 'String' or @'IO' ()@, in the same +-- way that "Text.Printf" works. We also support using strict 'T.Text' +-- lazy 'TL.Text' as well. +-- +-- So, while it's possible to reason with this using the types, it's +-- usually more difficult than with 'pprintf' and 'rprintf'. +-- +-- This is why, instead of reasoning with this using its types, it's easier +-- to reason with it using the errors instead: +-- +-- >>> 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. +-- +-- >>> 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. +-- +-- >>> printf @"You have %.2f dollars, %s" 3.62 "Luigi" +-- You have 3.62 dollars, Luigi +-- +-- >>> 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. +-- +-- If you're having problems getting the error messages to give helpful +-- feedback, try using 'pHelp': +-- +-- >>> 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. +-- +-- 'pHelp' can give the type system the nudge it needs to provide good +-- errors. +class FormatFun (ffs :: [Either Symbol FieldFormat]) fun where + formatFun :: p ffs -> String -> fun + +-- | A useful token for helping the type system give useful errors for +-- 'printf': +-- +-- >>> printf @"You have ".2f" dollars, %s" 3.26 :: PHelp +-- -- ERROR: Call to printf missing argument fulfilling "%s" +-- -- Either provide an argument or rewrite the format string to not expect +-- -- one. +-- +-- Usually things should work out on their own without needing this ... but +-- sometimes the type system could need a nudge. +-- +-- 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. + -- + -- Usually things would work out on their own without needing this ... + -- but sometimes the type system could need a nudge. + pHelp :: String + } + +instance (a ~ Char) => 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 + +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 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 (Reflect ff, ff ~ 'FF f w p m c, FormatType c a, FormatFun ffs fun) => FormatFun ('Right ff ': ffs) (a -> fun) where + formatFun _ str x = formatFun (Proxy @ffs) (str ++ formatArg (Proxy @c) x ff "") + where + ff = reflect (Proxy @ff) + +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." + +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 + +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 + +instance (Listify str lst, ffs ~ ParseFmtStr_ lst, FormatFun ffs fun) => Printf str fun where + printf_ _ = formatFun (Proxy @ffs) "" + +-- | Utility type powering 'pfmt'. See dcumentation for 'pfmt' for more +-- information on usage. +-- +-- Using /OverloadedLabels/, you never need to construct this directly +-- can just write @#f@ and a @'PFmt' "f"@ will be generated. You can also +-- create this using 'mkPFmt' or 'mkPFmt_', in the situations where +-- /OverloadedLabels/ doesn't work or is not wanted. +newtype PFmt c = PFmt P.FieldFormat + +-- | A version of 'mkPFmt' that takes an explicit proxy input. +-- +-- >>> 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_ _ = PFmt ff + where + ff = reflect (Proxy @ff) + +-- | Useful for using 'pfmt' without /OverloadedLabels/, or also when +-- passing format specifiers that aren't currently allowed with +-- /OverloadedLabels/ until GHC 8.10+ (like @#.2f@). +-- +-- >>> 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) + +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 + +-- | 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 +-- 'FormatType'. +-- +-- Usually meant to be used with /OverloadedLabels/: +-- +-- >>> pfmt #f 3.62 +-- "3.62" +-- +-- However, current versions of GHC disallow labels that aren't valid +-- identifier names, disallowing things like @'pfmt' #.2f 3.62@. While +-- there is an +-- that allows this, if you are using an earlier GHC +-- version, you can get around this using 'mkPFmt': +-- +-- >>> pfmt (mkPFmt @".2f") 3.6234124 +-- "3.62" +-- +-- Ideally we'd want to be able to write +-- +-- >>> pfmt #.2f 3.6234124 +-- "3.62" +-- +-- (which should be possible in GHC 8.10+) +-- +-- Note that the format string does not include the leading @%@. +pfmt :: forall c a. FormatType c a => PFmt c -> a -> String +pfmt (PFmt ff) x = formatArg (Proxy @c) x ff "" diff --git a/src/GHC/TypeLits/Printf/Internal/Parser.hs b/src/GHC/TypeLits/Printf/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TypeLits/Printf/Internal/Parser.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +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 + +type Parser a = a -> Type + +type family RunParser (p :: Parser a) (str :: [SChar]) :: Maybe (a, [SChar]) + +data Pure :: a -> Parser a +type instance RunParser (Pure x) str = 'Just '(x, str) + +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 NotSym :: SChar -> Parser SChar +type instance RunParser (NotSym c) (d ': cs) = If (c == d) 'Nothing ('Just '(c, cs)) +type instance RunParser (NotSym c) '[] = 'Nothing + +data AnySym :: Parser SChar +type instance RunParser AnySym (c ': cs) = 'Just '(c, cs) +type instance RunParser AnySym '[] = 'Nothing + +data Alpha :: Parser SChar +type instance RunParser Alpha (c ': cs) = If (IsAlpha c) ('Just '(c, cs)) 'Nothing +type instance RunParser Alpha '[] = '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 instance RunParser (x <$ p) str = RepHelp x (RunParser p str) + +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 +type instance RunParser (x <|> y) str = ChoiceMaybe (RunParser x str) (RunParser y str) + +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 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 + +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 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 instance RunParser (p <*> q) str = ApHelp (RunParser p str) q + +data Many :: Parser a -> Parser [a] +type instance RunParser (Many p) str = RunParser (Some p <|> Pure '[]) str +data Some :: Parser a -> Parser [a] +type instance RunParser (Some p) str = RunParser ('(:) <$> p <*> Many p) str + +-- | 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 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) +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, [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 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 FromDigits (xs :: [Nat]) (n :: Nat) :: Nat where + 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 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 diff --git a/src/GHC/TypeLits/Printf/Parse.hs b/src/GHC/TypeLits/Printf/Parse.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TypeLits/Printf/Parse.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHC.TypeLits.Printf.Parse ( + ParseFmtStr + , ParseFmtStr_ + , ParseFmt + , ParseFmt_ + , ShowFormat + , FormatAdjustment(..) + , FormatSign(..) + , WidthMod(..) + , Flags(..) + , EmptyFlags + , FieldFormat(..) + , SChar + , 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 + +-- 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 + } + +data WidthMod = WMhh + | WMh + | WMl + | WMll + | WML + +data FieldFormat = FF + { fmtFlags :: Flags + , fmtWidth :: Maybe Nat + , fmtPrecision :: Maybe Nat + , fmtWidthMod :: Maybe WidthMod + , fmtChar :: SChar + } + +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 + +class Reflect (x :: a) where + 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 KnownNat n => Reflect (n :: Nat) where + reflect = natVal +instance KnownSymbol n => Reflect (n :: Symbol) where + reflect = T.pack . symbolVal +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)) + +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 (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 family ShowNat (n :: Nat) :: Symbol where + 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)) + +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" + +modString :: WidthMod -> String +modString = \case + WMhh -> "hh" + WMh -> "h" + WMl -> "l" + WMll -> "ll" + WML -> "L" + +data FlagParser :: Parser Flags +type instance RunParser FlagParser str = 'Just (ProcessFlags EmptyFlags str) + +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 UpdateAdjust d1 d2 where + 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 + + +type WMParser = (Sym "h" *> (('WMhh <$ Sym "h") <|> Pure 'WMh)) + <|> (Sym "l" *> (('WMll <$ Sym "l") <|> Pure 'WMl)) + <|> ('WML <$ Sym "L") + +type FFParser = 'FF <$> FlagParser + <*> Optional Number + <*> Optional (Sym "." *> Number) + <*> Optional WMParser + <*> AnySym + -- <*> Alpha -- which of these is right? + +type FmtStrParser = Many ( ('Left <$> Cat (Some (NotSym "%" <|> (Sym "%" *> Sym "%")))) + <|> ('Right <$> (Sym "%" *> FFParser)) + ) + +type ParseFmtStr str = EvalParser FmtStrParser str +type ParseFmtStr_ str = EvalParser_ FmtStrParser str + +type ParseFmt str = EvalParser FFParser str +type ParseFmt_ str = EvalParser_ FFParser str + diff --git a/typelits-printf.cabal b/typelits-printf.cabal new file mode 100644 --- /dev/null +++ b/typelits-printf.cabal @@ -0,0 +1,54 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 01b7ef56880a6dc7f4e5a26769e77a08d5991bae7449cd60415d13c82f17929c + +name: typelits-printf +version: 0.1.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 +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/mstksg/typelits-printf + +library + exposed-modules: + 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 + build-depends: + base >=4.13 && <5 + , symbols >=0.3 && <0.4 + , text + , vinyl >=0.12.1 + default-language: Haskell2010