{-# 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
    { 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 -> SChar
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 :: p 'LeftAdjust -> Demote FormatAdjustment
reflect _ = FormatAdjustment
Demote FormatAdjustment
LeftAdjust
instance Reflect 'ZeroPad where
    reflect :: p 'ZeroPad -> Demote FormatAdjustment
reflect _ = FormatAdjustment
Demote FormatAdjustment
ZeroPad
instance Reflect 'SignPlus where
    reflect :: p 'SignPlus -> Demote FormatSign
reflect _ = FormatSign
Demote FormatSign
SignPlus
instance Reflect 'SignSpace where
    reflect :: p 'SignSpace -> Demote FormatSign
reflect _ = FormatSign
Demote FormatSign
SignSpace
instance Reflect 'WMhh where
    reflect :: p 'WMhh -> Demote WidthMod
reflect _ = Demote WidthMod
WidthMod
WMhh
instance Reflect 'WMh where
    reflect :: p 'WMh -> Demote WidthMod
reflect _ = Demote WidthMod
WidthMod
WMh
instance Reflect 'WMl where
    reflect :: p 'WMl -> Demote WidthMod
reflect _ = Demote WidthMod
WidthMod
WMl
instance Reflect 'WMll where
    reflect :: p 'WMll -> Demote WidthMod
reflect _ = Demote WidthMod
WidthMod
WMll
instance Reflect 'WML where
    reflect :: p 'WML -> Demote WidthMod
reflect _ = Demote WidthMod
WidthMod
WML
instance Reflect 'False where
    reflect :: p 'False -> Demote Bool
reflect _ = Bool
Demote Bool
False
instance Reflect 'True where
    reflect :: p 'True -> Demote Bool
reflect _ = Bool
Demote Bool
True
instance Reflect 'Nothing where
    reflect :: p 'Nothing -> Demote (Maybe a)
reflect _ = Demote (Maybe a)
forall a. Maybe a
Nothing
instance Reflect x => Reflect ('Just x) where
    reflect :: p ('Just x) -> Demote (Maybe a)
reflect _ = 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
reflect (Proxy x
forall k (t :: k). Proxy t
Proxy @x))
instance KnownNat n => Reflect (n :: Nat) where
    reflect :: p n -> Demote Nat
reflect = p n -> Demote Nat
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Natural
natVal
instance KnownSymbol n => Reflect (n :: Symbol) where
    reflect :: p n -> Demote SChar
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 :: SChar) (proxy :: SChar -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal
instance (Reflect d, Reflect i, Reflect l) => Reflect ('Flags d i l) where
    reflect :: p ('Flags d i l) -> Demote Flags
reflect _ = 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
reflect (Proxy d
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
reflect (Proxy i
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
reflect (Proxy l
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 :: p ('FF flags width prec mods chr) -> Demote FieldFormat
reflect _ = FieldFormat :: Maybe Int
-> Maybe Int
-> Maybe FormatAdjustment
-> Maybe FormatSign
-> Bool
-> String
-> Char
-> FieldFormat
P.FieldFormat{..}
      where
        Flags{..}    = Proxy flags -> Demote Flags
forall a (x :: a) (p :: a -> Type). Reflect x => p x -> Demote a
reflect (Proxy flags
forall k (t :: k). Proxy t
Proxy @flags)
        fmtWidth :: Maybe Int
fmtWidth     = Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Maybe Natural -> 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
reflect (Proxy width
forall k (t :: k). Proxy t
Proxy @width)
        fmtPrecision :: Maybe Int
fmtPrecision = Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Maybe Natural -> 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
reflect (Proxy prec
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 (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
reflect (Proxy mods
forall k (t :: k). Proxy t
Proxy @mods))
        fmtChar :: Char
fmtChar      = Text -> Char
T.head (Proxy chr -> Demote SChar
forall a (x :: a) (p :: a -> Type). Reflect x => p x -> Demote a
reflect (Proxy chr
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` 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 :: 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