{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module Parser where

import Control.Applicative hiding ((<|>))
import Control.Monad (when)
import Control.Monad.Fix
import Control.Monad.RWS
import Data.Char
import Data.CharSet hiding (map)
import Data.Maybe
import qualified Data.Set as S
import Lens.Micro.Platform
import Parser.Types
import Text.Parsec hiding (many)
import Text.ParserCombinators.ReadP (readP_to_S)
import Text.Read.Lex (lexChar)

type Warning = String

parseStr :: String -> Either ParseError ([Atom], [[Warning]])
parseStr :: [Char] -> Either ParseError ([Atom], [[[Char]]])
parseStr = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Atom -> (Atom, [[Char]])
normalizeAndWarn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m [Atom]
printfStr [Char]
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
lexChars
 where
  lexChars :: [Char] -> [Char]
lexChars [Char]
x = (forall a. (a -> a) -> a
`fix` [Char]
x) forall a b. (a -> b) -> a -> b
$ \[Char] -> [Char]
f [Char]
s ->
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null [Char]
s
      then []
      else case forall a. ReadP a -> ReadS a
readP_to_S ReadP Char
lexChar [Char]
s of
        ((Char
c, [Char]
rest) : [(Char, [Char])]
_) -> Char
c forall a. a -> [a] -> [a]
: [Char] -> [Char]
f [Char]
rest
        [] -> forall a. HasCallStack => [Char] -> a
error [Char]
"malformed input"

normalizeAndWarn :: Atom -> (Atom, [Warning])
normalizeAndWarn :: Atom -> (Atom, [[Char]])
normalizeAndWarn s :: Atom
s@Str{} = (Atom
s, [])
normalizeAndWarn (Arg FormatArg
f) = (FormatArg -> Atom
Arg FormatArg
a, [[Char]]
b)
 where
  (()
_, FormatArg
a, [[Char]]
b) = forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS (forall {m :: * -> *}. MonadWriter [[Char]] m => FormatArg -> m ()
warnLength FormatArg
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {m :: * -> *}.
(MonadWriter [[Char]] m, MonadState FormatArg m) =>
Char -> m ()
go (FormatArg -> Char
spec FormatArg
f)) () FormatArg
f
  go :: Char -> m ()
go Char
c | Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"aAeEfFgGxXo" = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  go Char
c | Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"csqQ?" = forall {m :: * -> *}.
(MonadWriter [[Char]] m, MonadState FormatArg m) =>
m ()
warnSign forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {m :: * -> *}.
(MonadWriter [[Char]] m, MonadState FormatArg m) =>
m ()
warnPrefix forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {m :: * -> *}.
(MonadWriter [[Char]] m, MonadState FormatArg m) =>
m ()
warnZero forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {m :: * -> *}.
(MonadWriter [[Char]] m, MonadState FormatArg m) =>
m ()
warnSpace
  go Char
c | Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"diu" = forall {m :: * -> *}.
(MonadWriter [[Char]] m, MonadState FormatArg m) =>
m ()
warnPrefix
  go Char
'p' = forall {m :: * -> *}.
(MonadWriter [[Char]] m, MonadState FormatArg m) =>
m ()
warnSign forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {m :: * -> *}.
(MonadWriter [[Char]] m, MonadState FormatArg m) =>
m ()
warnPrefix forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {m :: * -> *}.
(MonadWriter [[Char]] m, MonadState FormatArg m) =>
m ()
warnZero
  go Char
_ = forall a. HasCallStack => a
undefined
  warnFlag ::
    (Eq a, MonadWriter [String] m, MonadState FormatArg m) =>
    Lens' FlagSet a ->
    a ->
    a ->
    Char ->
    m ()
  warnFlag :: forall a (m :: * -> *).
(Eq a, MonadWriter [[Char]] m, MonadState FormatArg m) =>
Lens' FlagSet a -> a -> a -> Char -> m ()
warnFlag Lens' FlagSet a
lens' a
bad a
good Char
flagName = do
    a
oldVal <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' FormatArg FlagSet
flags_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' FlagSet a
lens')
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
oldVal forall a. Eq a => a -> a -> Bool
== a
bad) forall a b. (a -> b) -> a -> b
$ do
      Char
c <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' FormatArg Char
spec_
      Lens' FormatArg FlagSet
flags_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' FlagSet a
lens' forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= a
good
      forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
        [ [Char]
"`"
            forall a. [a] -> [a] -> [a]
++ [Char
flagName]
            forall a. [a] -> [a] -> [a]
++ [Char]
"` flag has no effect on `"
            forall a. [a] -> [a] -> [a]
++ [Char
c]
            forall a. [a] -> [a] -> [a]
++ [Char]
"` specifier"
        ]
  warnSign :: m ()
warnSign = forall a (m :: * -> *).
(Eq a, MonadWriter [[Char]] m, MonadState FormatArg m) =>
Lens' FlagSet a -> a -> a -> Char -> m ()
warnFlag Lens' FlagSet Bool
signed_ Bool
True Bool
False Char
'+'
  warnPrefix :: m ()
warnPrefix = forall a (m :: * -> *).
(Eq a, MonadWriter [[Char]] m, MonadState FormatArg m) =>
Lens' FlagSet a -> a -> a -> Char -> m ()
warnFlag Lens' FlagSet Bool
prefixed_ Bool
True Bool
False Char
'#'
  warnSpace :: m ()
warnSpace = forall a (m :: * -> *).
(Eq a, MonadWriter [[Char]] m, MonadState FormatArg m) =>
Lens' FlagSet a -> a -> a -> Char -> m ()
warnFlag Lens' FlagSet Bool
spaced_ Bool
True Bool
False Char
' '
  warnZero :: m ()
warnZero = forall a (m :: * -> *).
(Eq a, MonadWriter [[Char]] m, MonadState FormatArg m) =>
Lens' FlagSet a -> a -> a -> Char -> m ()
warnFlag Lens' FlagSet (Maybe Adjustment)
adjustment_ (forall a. a -> Maybe a
Just Adjustment
ZeroPadded) forall a. Maybe a
Nothing Char
'0'
  phonyLengthSpec :: Set (Char, [Char])
phonyLengthSpec =
    forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$
      [(Char
x, [Char]
y) | Char
x <- [Char]
"diuoxX", [Char]
y <- [[Char]
"L"]]
        forall a. [a] -> [a] -> [a]
++ [ (Char
x, [Char]
y)
           | Char
x <- [Char]
"fFeEgGaA"
           , [Char]
y <- [[Char]
"hh", [Char]
"h", [Char]
"l", [Char]
"ll", [Char]
"j", [Char]
"z", [Char]
"t"]
           ]
        forall a. [a] -> [a] -> [a]
++ [(Char
x, [Char]
y) | Char
x <- [Char]
"csqQ", [Char]
y <- [[Char]
"hh", [Char]
"h", [Char]
"ll", [Char]
"j", [Char]
"z", [Char]
"t", [Char]
"L"]]
        forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Char
'p',) [[Char]
"hh", [Char]
"h", [Char]
"l", [Char]
"ll", [Char]
"j", [Char]
"z", [Char]
"t", [Char]
"L"]
  warnLength :: FormatArg -> m ()
warnLength FormatArg{Char
spec :: Char
spec :: FormatArg -> Char
spec, lengthSpec :: FormatArg -> Maybe LengthSpecifier
lengthSpec = Just LengthSpecifier
l}
    | (Char
spec, forall a. Show a => a -> [Char]
show LengthSpecifier
l) forall a. Ord a => a -> Set a -> Bool
`S.member` Set (Char, [Char])
phonyLengthSpec =
        forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
          [ [Char]
"`"
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show LengthSpecifier
l
              forall a. [a] -> [a] -> [a]
++ [Char]
"` length modifier has no effect when combined with `"
              forall a. [a] -> [a] -> [a]
++ [Char
spec]
              forall a. [a] -> [a] -> [a]
++ [Char]
"` specifier"
          ]
  warnLength FormatArg
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

flagSet :: CharSet
flagSet :: CharSet
flagSet = [Char] -> CharSet
fromList [Char]
"-+ #0"

specSet :: CharSet
specSet :: CharSet
specSet = [Char] -> CharSet
fromList [Char]
"diuoxXfFeEaAgGpcsQq?"

lengthSpecifiers :: [(String, LengthSpecifier)]
lengthSpecifiers :: [([Char], LengthSpecifier)]
lengthSpecifiers =
  [ ([Char]
"hh", LengthSpecifier
HH)
  , ([Char]
"h", LengthSpecifier
H)
  , ([Char]
"ll", LengthSpecifier
LL)
  , ([Char]
"l", LengthSpecifier
L)
  , ([Char]
"j", LengthSpecifier
J)
  , ([Char]
"z", LengthSpecifier
Z)
  , ([Char]
"t", LengthSpecifier
T)
  , ([Char]
"L", LengthSpecifier
BigL)
  ]

oneOfSet :: Stream s m Char => CharSet -> ParsecT s u m Char
oneOfSet :: forall s (m :: * -> *) u.
Stream s m Char =>
CharSet -> ParsecT s u m Char
oneOfSet CharSet
s = forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Char -> CharSet -> Bool
`member` CharSet
s)

printfStr :: Stream s m Char => ParsecT s u m [Atom]
printfStr :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m [Atom]
printfStr =
  forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$
    [Char] -> Atom
Str [Char]
"%" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"%%")
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> FormatArg -> Atom
Arg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) u.
Stream s m Char =>
ParsecT s u m FormatArg
fmtArg
      forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [Char] -> Atom
Str forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (forall a. Eq a => a -> a -> Bool
/= Char
'%'))

fmtArg :: Stream s m Char => ParsecT s u m FormatArg
fmtArg :: forall s (m :: * -> *) u.
Stream s m Char =>
ParsecT s u m FormatArg
fmtArg = do
  Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'%'
  FlagSet
flags <- do
    [Flag]
fs <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ do
      Char
c <- forall s (m :: * -> *) u.
Stream s m Char =>
CharSet -> ParsecT s u m Char
oneOfSet CharSet
flagSet forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"flag"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Char
c of
        Char
'-' -> Flag
FlagLJust
        Char
'+' -> Flag
FlagSigned
        Char
' ' -> Flag
FlagSpaced
        Char
'#' -> Flag
FlagPrefixed
        Char
'0' -> Flag
FlagZeroPadded
        Char
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"
    let flagSet' :: Set Flag
flagSet' = forall a. Ord a => [a] -> Set a
S.fromList [Flag]
fs
    if forall a. Set a -> Int
S.size Set Flag
flagSet' forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [Flag]
fs
      then forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Duplicate flags specified"
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Set Flag -> FlagSet
toFlagSet Set Flag
flagSet'
  Maybe MaySpecify
width <- forall {s} {m :: * -> *} {u}.
Stream s m Char =>
ParsecT s u m (Maybe MaySpecify)
numArg forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"width"
  Maybe (Maybe MaySpecify)
precision <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall {s} {m :: * -> *} {u}.
Stream s m Char =>
ParsecT s u m (Maybe MaySpecify)
numArg) forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"precision"
  Maybe LengthSpecifier
lengthSpec <-
    forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
Prelude.map (\([Char]
a, LengthSpecifier
b) -> LengthSpecifier
b forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
a) [([Char], LengthSpecifier)]
lengthSpecifiers
  Char
spec <- forall s (m :: * -> *) u.
Stream s m Char =>
CharSet -> ParsecT s u m Char
oneOfSet CharSet
specSet forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"valid specifier"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FlagSet
-> Maybe MaySpecify
-> Maybe MaySpecify
-> Char
-> Maybe LengthSpecifier
-> FormatArg
FormatArg FlagSet
flags Maybe MaySpecify
width (forall a. a -> Maybe a -> a
fromMaybe (Integer -> MaySpecify
Given Integer
0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe MaySpecify)
precision) Char
spec Maybe LengthSpecifier
lengthSpec
 where
  nat :: ParsecT s u m Integer
nat = do
    [Char]
c <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isDigit
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Read a => [Char] -> a
read [Char]
c :: Integer)
  numArg :: ParsecT s u m (Maybe MaySpecify)
numArg = forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (Integer -> MaySpecify
Given forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {s} {m :: * -> *} {u}.
Stream s m Char =>
ParsecT s u m Integer
nat forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> MaySpecify
Need forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'*')