{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoStarIsType #-}

module GHC.TypeLits.Printf.Parse (
  ParseFmtStr,
  ParseFmtStr_,
  ParseFmt,
  ParseFmt_,
  ShowFormat,
  FormatAdjustment (..),
  FormatSign (..),
  WidthMod (..),
  Flags (..),
  EmptyFlags,
  FieldFormat (..),
  Demote,
  Reflect (..),
) where

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
  { Flags -> Maybe FormatAdjustment
fAdjust :: Maybe FormatAdjustment
  , Flags -> Maybe FormatSign
fSign :: Maybe FormatSign
  , Flags -> Bool
fAlternate :: Bool
  }

data WidthMod
  = WMhh
  | WMh
  | WMl
  | WMll
  | WML

data FieldFormat = FF
  { FieldFormat -> Flags
fmtFlags :: Flags
  , FieldFormat -> Maybe Nat
fmtWidth :: Maybe Nat
  , FieldFormat -> Maybe Nat
fmtPrecision :: Maybe Nat
  , FieldFormat -> Maybe WidthMod
fmtWidthMod :: Maybe WidthMod
  , FieldFormat -> Char
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 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

instance Reflect LeftAdjust where
  reflect :: forall (p :: FormatAdjustment -> Type).
p 'LeftAdjust -> Demote FormatAdjustment
reflect p 'LeftAdjust
_ = FormatAdjustment
Demote FormatAdjustment
LeftAdjust
instance Reflect ZeroPad where
  reflect :: forall (p :: FormatAdjustment -> Type).
p 'ZeroPad -> Demote FormatAdjustment
reflect p 'ZeroPad
_ = FormatAdjustment
Demote FormatAdjustment
ZeroPad
instance Reflect SignPlus where
  reflect :: forall (p :: FormatSign -> Type). p 'SignPlus -> Demote FormatSign
reflect p 'SignPlus
_ = FormatSign
Demote FormatSign
SignPlus
instance Reflect SignSpace where
  reflect :: forall (p :: FormatSign -> Type). p 'SignSpace -> Demote FormatSign
reflect p 'SignSpace
_ = FormatSign
Demote FormatSign
SignSpace
instance Reflect WMhh where
  reflect :: forall (p :: WidthMod -> Type). p 'WMhh -> Demote WidthMod
reflect p 'WMhh
_ = Demote WidthMod
WidthMod
WMhh
instance Reflect WMh where
  reflect :: forall (p :: WidthMod -> Type). p 'WMh -> Demote WidthMod
reflect p 'WMh
_ = Demote WidthMod
WidthMod
WMh
instance Reflect WMl where
  reflect :: forall (p :: WidthMod -> Type). p 'WMl -> Demote WidthMod
reflect p 'WMl
_ = Demote WidthMod
WidthMod
WMl
instance Reflect WMll where
  reflect :: forall (p :: WidthMod -> Type). p 'WMll -> Demote WidthMod
reflect p 'WMll
_ = Demote WidthMod
WidthMod
WMll
instance Reflect WML where
  reflect :: forall (p :: WidthMod -> Type). p 'WML -> Demote WidthMod
reflect p 'WML
_ = Demote WidthMod
WidthMod
WML
instance Reflect False where
  reflect :: forall (p :: Bool -> Type). p 'False -> Demote Bool
reflect p 'False
_ = Bool
Demote Bool
False
instance Reflect True where
  reflect :: forall (p :: Bool -> Type). p 'True -> Demote Bool
reflect p 'True
_ = Bool
Demote Bool
True
instance Reflect Nothing where
  reflect :: forall (p :: Maybe a -> Type). p 'Nothing -> Demote (Maybe a)
reflect p 'Nothing
_ = Maybe (Demote a)
Demote (Maybe a)
forall a. Maybe a
Nothing
instance Reflect x => Reflect (Just x) where
  reflect :: forall (p :: Maybe a -> Type). p ('Just x) -> Demote (Maybe a)
reflect p ('Just x)
_ = Demote a -> Maybe (Demote a)
forall a. a -> Maybe a
Just (Proxy x -> Demote a
forall a (x :: a) (p :: a -> Type). Reflect x => p x -> Demote a
forall (p :: a -> Type). p x -> Demote a
reflect (forall (t :: a). Proxy t
forall {k} (t :: k). Proxy t
Proxy @x))
instance KnownNat n => Reflect (n :: Nat) where
  reflect :: forall (p :: Nat -> Type). p n -> Demote Nat
reflect = p n -> Nat
p n -> Demote Nat
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal
instance KnownSymbol n => Reflect (n :: Symbol) where
  reflect :: forall (p :: Symbol -> Type). p n -> Demote Symbol
reflect = String -> Text
T.pack (String -> Text) -> (p n -> String) -> p n -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p n -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal
instance KnownChar c => Reflect (c :: Char) where
  reflect :: forall (p :: Char -> Type). p c -> Demote Char
reflect = p c -> Char
p c -> Demote Char
forall (n :: Char) (proxy :: Char -> Type).
KnownChar n =>
proxy n -> Char
charVal
instance (Reflect d, Reflect i, Reflect l) => Reflect ('Flags d i l) where
  reflect :: forall (p :: Flags -> Type). p ('Flags d i l) -> Demote Flags
reflect p ('Flags d i l)
_ =
    Maybe FormatAdjustment -> Maybe FormatSign -> Bool -> Flags
Flags
      (Proxy d -> Demote (Maybe FormatAdjustment)
forall a (x :: a) (p :: a -> Type). Reflect x => p x -> Demote a
forall (p :: Maybe FormatAdjustment -> Type).
p d -> Demote (Maybe FormatAdjustment)
reflect (forall (t :: Maybe FormatAdjustment). Proxy t
forall {k} (t :: k). Proxy t
Proxy @d))
      (Proxy i -> Demote (Maybe FormatSign)
forall a (x :: a) (p :: a -> Type). Reflect x => p x -> Demote a
forall (p :: Maybe FormatSign -> Type).
p i -> Demote (Maybe FormatSign)
reflect (forall (t :: Maybe FormatSign). Proxy t
forall {k} (t :: k). Proxy t
Proxy @i))
      (Proxy l -> Demote Bool
forall a (x :: a) (p :: a -> Type). Reflect x => p x -> Demote a
forall (p :: Bool -> Type). p l -> Demote Bool
reflect (forall (t :: Bool). Proxy t
forall {k} (t :: k). Proxy t
Proxy @l))
instance
  (Reflect flags, Reflect width, Reflect prec, Reflect mods, Reflect chr) =>
  Reflect ('FF flags width prec mods chr)
  where
  reflect :: forall (p :: FieldFormat -> Type).
p ('FF flags width prec mods chr) -> Demote FieldFormat
reflect p ('FF flags width prec mods chr)
_ = P.FieldFormat{Bool
Char
String
Maybe Int
Maybe FormatSign
Maybe FormatAdjustment
Demote Char
fmtWidth :: Maybe Int
fmtPrecision :: Maybe Int
fmtAdjust :: Maybe FormatAdjustment
fmtSign :: Maybe FormatSign
fmtAlternate :: Bool
fmtModifiers :: String
fmtChar :: Demote Char
fmtChar :: Char
fmtModifiers :: String
fmtAlternate :: Bool
fmtSign :: Maybe FormatSign
fmtAdjust :: Maybe FormatAdjustment
fmtPrecision :: Maybe Int
fmtWidth :: Maybe Int
..}
    where
      Flags{Bool
Maybe FormatSign
Maybe FormatAdjustment
fAdjust :: Flags -> Maybe FormatAdjustment
fSign :: Flags -> Maybe FormatSign
fAlternate :: Flags -> Bool
fAdjust :: Maybe FormatAdjustment
fSign :: Maybe FormatSign
fAlternate :: Bool
..} = Proxy flags -> Demote Flags
forall a (x :: a) (p :: a -> Type). Reflect x => p x -> Demote a
forall (p :: Flags -> Type). p flags -> Demote Flags
reflect (forall {k} (t :: k). Proxy t
forall (t :: Flags). Proxy t
Proxy @flags)
      fmtWidth :: Maybe Int
fmtWidth = Nat -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Nat -> Int) -> Maybe Nat -> Maybe Int
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy width -> Demote (Maybe Nat)
forall a (x :: a) (p :: a -> Type). Reflect x => p x -> Demote a
forall (p :: Maybe Nat -> Type). p width -> Demote (Maybe Nat)
reflect (forall (t :: Maybe Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @width)
      fmtPrecision :: Maybe Int
fmtPrecision = Nat -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Nat -> Int) -> Maybe Nat -> Maybe Int
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy prec -> Demote (Maybe Nat)
forall a (x :: a) (p :: a -> Type). Reflect x => p x -> Demote a
forall (p :: Maybe Nat -> Type). p prec -> Demote (Maybe Nat)
reflect (forall (t :: Maybe Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @prec)
      fmtAdjust :: Maybe FormatAdjustment
fmtAdjust = Maybe FormatAdjustment
fAdjust
      fmtSign :: Maybe FormatSign
fmtSign = Maybe FormatSign
fSign
      fmtAlternate :: Bool
fmtAlternate = Bool
fAlternate
      fmtModifiers :: String
fmtModifiers = (WidthMod -> String) -> Maybe WidthMod -> String
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap WidthMod -> String
modString (Proxy mods -> Demote (Maybe WidthMod)
forall a (x :: a) (p :: a -> Type). Reflect x => p x -> Demote a
forall (p :: Maybe WidthMod -> Type).
p mods -> Demote (Maybe WidthMod)
reflect (forall (t :: Maybe WidthMod). Proxy t
forall {k} (t :: k). Proxy t
Proxy @mods))
      fmtChar :: Demote Char
fmtChar = Proxy chr -> Demote Char
forall a (x :: a) (p :: a -> Type). Reflect x => p x -> Demote a
forall (p :: Char -> Type). p chr -> Demote Char
reflect (forall (t :: Char). Proxy t
forall {k} (t :: k). Proxy t
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` 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

type family ShowNatHelp (n :: Nat) :: Symbol where
  ShowNatHelp 0 = ""
  ShowNatHelp n = AppendSymbol (ShowNatHelp (Div n 10)) (ConsSymbol (ShowDigit (Mod n 10)) "")

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 :: WidthMod -> String
modString = \case
  WidthMod
WMhh -> String
"hh"
  WidthMod
WMh -> String
"h"
  WidthMod
WMl -> String
"l"
  WidthMod
WMll -> String
"ll"
  WidthMod
WML -> String
"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 :: 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

type family UpdateSign i1 i2 where
  UpdateSign Nothing i2 = i2
  UpdateSign (Just SignPlus) i2 = SignPlus
  UpdateSign (Just SignSpace) i2 = i2

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 (AsChar '.' *> Number)
    <*> Optional WMParser
    <*> AnyChar

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 ParseFmt str = EvalParser FFParser str
type ParseFmt_ str = EvalParser_ FFParser str