Parse.hs

{-# 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
  { 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 :: 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 _ = 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 KnownChar c => Reflect (c :: Char) where
  reflect = charVal
instance (Reflect d, Reflect i, Reflect l) => Reflect ('Flags d i l) where
  reflect _ =
    Flags
      (reflect (Proxy @d))
      (reflect (Proxy @i))
      (reflect (Proxy @l))
instance
  (Reflect flags, Reflect width, Reflect prec, Reflect mods, Reflect chr) =>
  Reflect ('FF flags width prec mods chr)
  where
  reflect _ = P.FieldFormat{..}
    where
      Flags{..} = reflect (Proxy @flags)
      fmtWidth = fromIntegral <$> reflect (Proxy @width)
      fmtPrecision = fromIntegral <$> reflect (Proxy @prec)
      fmtAdjust = fAdjust
      fmtSign = fSign
      fmtAlternate = fAlternate
      fmtModifiers = foldMap modString (reflect (Proxy @mods))
      fmtChar = 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` 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 = \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 :: 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