{-# 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 (
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
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 _ = a -> FieldFormat -> ShowS
forall a. PrintfArg a => a -> FieldFormat -> ShowS
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 "s" -> Text -> FieldFormat -> ShowS
formatArg _ = String -> FieldFormat -> ShowS
forall a. PrintfArg a => a -> FieldFormat -> ShowS
P.formatArg (String -> FieldFormat -> ShowS)
-> (Text -> String) -> Text -> FieldFormat -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
instance FormatType "s" TL.Text where
formatArg :: p "s" -> Text -> FieldFormat -> ShowS
formatArg _ = String -> FieldFormat -> ShowS
forall a. PrintfArg a => a -> FieldFormat -> ShowS
P.formatArg (String -> FieldFormat -> ShowS)
-> (Text -> String) -> Text -> FieldFormat -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack
instance FormatType "v" Char
instance FormatType "v" Int
instance FormatType "v" Int8
instance FormatType "v" Int16
instance FormatType "v" Int32
instance FormatType "v" Int64
instance FormatType "v" Integer
instance FormatType "v" Natural
instance FormatType "v" Word
instance FormatType "v" Word8
instance FormatType "v" Word16
instance FormatType "v" Word32
instance FormatType "v" Word64
instance FormatType "v" Double
instance FormatType "v" Float
instance FormatType "v" String
instance FormatType "v" T.Text where
formatArg :: p "v" -> Text -> FieldFormat -> ShowS
formatArg _ = String -> FieldFormat -> ShowS
forall a. PrintfArg a => a -> FieldFormat -> ShowS
P.formatArg (String -> FieldFormat -> ShowS)
-> (Text -> String) -> Text -> FieldFormat -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
instance FormatType "v" TL.Text where
formatArg :: p "v" -> Text -> FieldFormat -> ShowS
formatArg _ = String -> FieldFormat -> ShowS
forall a. PrintfArg a => a -> FieldFormat -> ShowS
P.formatArg (String -> FieldFormat -> ShowS)
-> (Text -> String) -> Text -> FieldFormat -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack
data PP (c :: SChar) = forall a. FormatType c a => PP a
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 :: p '[] -> FormatArgs '[] -> ShowS
rformat _ _ = ShowS
forall a. a -> a
id
instance (KnownSymbol str, RFormat ffs ps) => RFormat ('Left str ': ffs) ps where
rformat :: p ('Left str : ffs) -> FormatArgs ps -> ShowS
rformat _ r :: FormatArgs ps
r = String -> ShowS
showString (Proxy str -> String
forall (n :: SChar) (proxy :: SChar -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy str
forall k (t :: k). Proxy t
Proxy @str))
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy ffs -> FormatArgs ps -> ShowS
forall (ffs :: [Either SChar FieldFormat]) (ps :: [SChar])
(p :: [Either SChar FieldFormat] -> *).
RFormat ffs ps =>
p ffs -> FormatArgs ps -> ShowS
rformat (Proxy ffs
forall k (t :: k). Proxy t
Proxy @ffs) FormatArgs ps
r
instance (Reflect ff, ff ~ 'FF f w p m c, RFormat ffs ps) => RFormat ('Right ff ': ffs) (c ': ps) where
rformat :: p ('Right ff : ffs) -> FormatArgs (c : ps) -> ShowS
rformat _ (PP x :: a
x :& xs :: Rec PP rs
xs) = Proxy c -> a -> FieldFormat -> ShowS
forall (t :: SChar) a (p :: SChar -> *).
FormatType t a =>
p t -> a -> FieldFormat -> ShowS
formatArg (Proxy c
forall k (t :: k). Proxy t
Proxy @c) a
x FieldFormat
Demote FieldFormat
ff
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy ffs -> Rec PP rs -> ShowS
forall (ffs :: [Either SChar FieldFormat]) (ps :: [SChar])
(p :: [Either SChar FieldFormat] -> *).
RFormat ffs ps =>
p ffs -> FormatArgs ps -> ShowS
rformat (Proxy ffs
forall k (t :: k). Proxy t
Proxy @ffs) Rec PP rs
xs
where
ff :: Demote FieldFormat
ff = Proxy ff -> Demote FieldFormat
forall a (x :: a) (p :: a -> *). Reflect x => p x -> Demote a
reflect (Proxy ff
forall k (t :: k). Proxy t
Proxy @ff)
class RPrintf (str :: Symbol) ps where
rprintf_ :: p str -> FormatArgs ps -> String
instance (Listify str lst, ffs ~ ParseFmtStr_ lst, RFormat ffs ps) => RPrintf str ps where
rprintf_ :: p str -> FormatArgs ps -> String
rprintf_ _ = (ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ "") (ShowS -> String)
-> (FormatArgs ps -> ShowS) -> FormatArgs ps -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy ffs -> FormatArgs ps -> ShowS
forall (ffs :: [Either SChar FieldFormat]) (ps :: [SChar])
(p :: [Either SChar FieldFormat] -> *).
RFormat ffs ps =>
p ffs -> FormatArgs ps -> ShowS
rformat (Proxy ffs
forall k (t :: k). Proxy t
Proxy @ffs)
class FormatFun (ffs :: [Either Symbol FieldFormat]) fun where
formatFun :: p ffs -> String -> fun
newtype PHelp = PHelp {
PHelp -> String
pHelp :: String
}
instance (a ~ Char) => FormatFun '[] [a] where
formatFun :: p '[] -> String -> [a]
formatFun _ = String -> [a]
forall a. a -> a
id
instance (a ~ Char) => FormatFun '[] PHelp where
formatFun :: p '[] -> String -> PHelp
formatFun _ = String -> PHelp
PHelp
instance (a ~ Char) => FormatFun '[] T.Text where
formatFun :: p '[] -> String -> Text
formatFun _ = String -> Text
T.pack
instance (a ~ Char) => FormatFun '[] TL.Text where
formatFun :: p '[] -> String -> Text
formatFun _ = String -> Text
TL.pack
instance (a ~ ()) => FormatFun '[] (IO a) where
formatFun :: p '[] -> String -> IO a
formatFun _ = String -> IO a
String -> IO ()
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 :: p '[] -> String -> ()
formatFun _ = String -> ()
forall a. HasCallStack => String -> a
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 :: p '[] -> String -> a -> b
formatFun _ = String -> a -> b
forall a. HasCallStack => String -> a
error
instance (KnownSymbol str, FormatFun ffs fun) => FormatFun ('Left str ': ffs) fun where
formatFun :: p ('Left str : ffs) -> String -> fun
formatFun _ str :: String
str = Proxy ffs -> String -> fun
forall (ffs :: [Either SChar FieldFormat]) fun
(p :: [Either SChar FieldFormat] -> *).
FormatFun ffs fun =>
p ffs -> String -> fun
formatFun (Proxy ffs
forall k (t :: k). Proxy t
Proxy @ffs) (String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ Proxy str -> String
forall (n :: SChar) (proxy :: SChar -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy str
forall k (t :: k). Proxy t
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 :: p ('Right ff : ffs) -> String -> a -> fun
formatFun _ str :: String
str x :: a
x = Proxy ffs -> String -> fun
forall (ffs :: [Either SChar FieldFormat]) fun
(p :: [Either SChar FieldFormat] -> *).
FormatFun ffs fun =>
p ffs -> String -> fun
formatFun (Proxy ffs
forall k (t :: k). Proxy t
Proxy @ffs) (String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ Proxy c -> a -> FieldFormat -> ShowS
forall (t :: SChar) a (p :: SChar -> *).
FormatType t a =>
p t -> a -> FieldFormat -> ShowS
formatArg (Proxy c
forall k (t :: k). Proxy t
Proxy @c) a
x FieldFormat
Demote FieldFormat
ff "")
where
ff :: Demote FieldFormat
ff = Proxy ff -> Demote FieldFormat
forall a (x :: a) (p :: a -> *). Reflect x => p x -> Demote a
reflect (Proxy ff
forall k (t :: k). Proxy t
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 :: p ('Right ff : ffs) -> ShowS
formatFun _ = ShowS
forall a. HasCallStack => String -> a
error
instance TypeError (MissingError ff) => FormatFun ('Right ff ': ffs) () where
formatFun :: p ('Right ff : ffs) -> String -> ()
formatFun _ = String -> ()
forall a. HasCallStack => String -> a
error
instance TypeError (MissingError ff) => FormatFun ('Right ff ': ffs) T.Text where
formatFun :: p ('Right ff : ffs) -> String -> Text
formatFun _ = String -> Text
forall a. HasCallStack => String -> a
error
instance TypeError (MissingError ff) => FormatFun ('Right ff ': ffs) TL.Text where
formatFun :: p ('Right ff : ffs) -> String -> Text
formatFun _ = String -> Text
forall a. HasCallStack => String -> a
error
instance TypeError (MissingError ff) => FormatFun ('Right ff ': ffs) PHelp where
formatFun :: p ('Right ff : ffs) -> String -> PHelp
formatFun _ = String -> PHelp
forall a. HasCallStack => String -> a
error
instance TypeError (MissingError ff) => FormatFun ('Right ff ': ffs) (IO a) where
formatFun :: p ('Right ff : ffs) -> String -> IO a
formatFun _ = String -> IO a
forall a. HasCallStack => String -> a
error
class Printf (str :: Symbol) fun where
printf_ :: p str -> fun
instance (Listify str lst, ffs ~ ParseFmtStr_ lst, FormatFun ffs fun) => Printf str fun where
printf_ :: p str -> fun
printf_ _ = Proxy ffs -> String -> fun
forall (ffs :: [Either SChar FieldFormat]) fun
(p :: [Either SChar FieldFormat] -> *).
FormatFun ffs fun =>
p ffs -> String -> fun
formatFun (Proxy ffs
forall k (t :: k). Proxy t
Proxy @ffs) ""
newtype PFmt c = PFmt P.FieldFormat
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_ :: p str -> PFmt c
mkPFmt_ _ = FieldFormat -> PFmt c
forall k (c :: k). FieldFormat -> PFmt c
PFmt FieldFormat
Demote FieldFormat
ff
where
ff :: Demote FieldFormat
ff = Proxy ff -> Demote FieldFormat
forall a (x :: a) (p :: a -> *). Reflect x => p x -> Demote a
reflect (Proxy ff
forall k (t :: k). Proxy t
Proxy @ff)
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 :: PFmt c
mkPFmt = Proxy str -> PFmt c
forall (str :: SChar) (lst :: [SChar]) (ff :: FieldFormat)
(f :: Flags) (w :: Maybe Nat) (q :: Maybe Nat)
(m :: Maybe WidthMod) (c :: SChar) (p :: SChar -> *).
(Listify str lst, ff ~ ParseFmt_ lst, Reflect ff,
ff ~ 'FF f w q m c) =>
p str -> PFmt c
mkPFmt_ @str @lst (Proxy str
forall k (t :: k). Proxy t
Proxy @str)
instance (Listify str lst, ff ~ ParseFmt_ lst, Reflect ff, ff ~ 'FF f w p m c) => IsLabel str (PFmt c) where
fromLabel :: PFmt c
fromLabel = forall (str :: SChar) (lst :: [SChar]) (ff :: FieldFormat)
(f :: Flags) (w :: Maybe Nat) (p :: Maybe Nat)
(m :: Maybe WidthMod) (c :: SChar).
(Listify str lst, ff ~ ParseFmt_ lst, Reflect ff,
ff ~ 'FF f w p m c) =>
PFmt c
forall (ff :: FieldFormat) (f :: Flags) (w :: Maybe Nat)
(p :: Maybe Nat) (m :: Maybe WidthMod) (c :: SChar).
(Listify str lst, ff ~ ParseFmt_ lst, Reflect ff,
ff ~ 'FF f w p m c) =>
PFmt c
mkPFmt @str @lst
pfmt :: forall c a. FormatType c a => PFmt c -> a -> String
pfmt :: PFmt c -> a -> String
pfmt (PFmt ff :: FieldFormat
ff) x :: a
x = Proxy c -> a -> FieldFormat -> ShowS
forall (t :: SChar) a (p :: SChar -> *).
FormatType t a =>
p t -> a -> FieldFormat -> ShowS
formatArg (Proxy c
forall k (t :: k). Proxy t
Proxy @c) a
x FieldFormat
ff ""