{-# LANGUAGE LambdaCase #-}

-- | Parsing library. Implements a simple 'Parser' type, and some basic parsers, e.g. 'ws', 'dbl'.
module ConditionalRestriction.Internal.Parse.ParserLib where

import ConditionalRestriction.Result (Result (..))
import Control.Applicative (Alternative (empty, many, (<|>)))
import Control.Monad (replicateM, (>=>))
import Data.Bifunctor (Bifunctor (first))

-- | A generic parser. Takes an input type @i@ and returns an output type @a@.
newtype Parser i a = Parser
  { forall i a. Parser i a -> i -> Result String (a, i)
parse :: i -> Result String (a, i)
  }

instance Functor (Parser i) where
  fmap :: forall a b. (a -> b) -> Parser i a -> Parser i b
fmap a -> b
f (Parser i -> Result String (a, i)
p) = forall i a. (i -> Result String (a, i)) -> Parser i a
Parser forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Result String (a, i)
p

instance Applicative (Parser i) where
  pure :: forall a. a -> Parser i a
pure a
x = forall i a. (i -> Result String (a, i)) -> Parser i a
Parser forall a b. (a -> b) -> a -> b
$ \i
i -> forall e a. a -> Result e a
Ok (a
x, i
i)
  (Parser i -> Result String (a -> b, i)
pf) <*> :: forall a b. Parser i (a -> b) -> Parser i a -> Parser i b
<*> (Parser i -> Result String (a, i)
px) = forall i a. (i -> Result String (a, i)) -> Parser i a
Parser forall a b. (a -> b) -> a -> b
$ i -> Result String (a -> b, i)
pf forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \(a -> b
f, i
i') -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> i -> Result String (a, i)
px i
i'

instance Alternative (Parser i) where
  empty :: forall a. Parser i a
empty = forall i a. (i -> Result String (a, i)) -> Parser i a
Parser forall a b. (a -> b) -> a -> b
$ \i
i -> forall e a. e -> Result e a
Err String
"No parsing possibilities left."
  (Parser i -> Result String (a, i)
a) <|> :: forall a. Parser i a -> Parser i a -> Parser i a
<|> (Parser i -> Result String (a, i)
b) = forall i a. (i -> Result String (a, i)) -> Parser i a
Parser forall a b. (a -> b) -> a -> b
$ \i
i -> case i -> Result String (a, i)
a i
i of
    res :: Result String (a, i)
res@(Ok (a, i)
_) -> Result String (a, i)
res
    Err String
msg -> i -> Result String (a, i)
b i
i

instance Monad (Parser i) where
  return :: forall a. a -> Parser i a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (Parser i -> Result String (a, i)
pa) >>= :: forall a b. Parser i a -> (a -> Parser i b) -> Parser i b
>>= a -> Parser i b
f = forall i a. (i -> Result String (a, i)) -> Parser i a
Parser forall a b. (a -> b) -> a -> b
$ \i
i -> case i -> Result String (a, i)
pa i
i of
    Ok (a
a, i
i') -> forall i a. Parser i a -> i -> Result String (a, i)
parse (a -> Parser i b
f a
a) i
i'
    Err String
msg -> forall e a. e -> Result e a
Err String
msg

str :: String -> Parser String String
str :: String -> Parser String String
str String
s = forall i a. (i -> Result String (a, i)) -> Parser i a
Parser forall a b. (a -> b) -> a -> b
$ \String
i ->
  if forall a. Int -> [a] -> [a]
take Int
len String
i forall a. Eq a => a -> a -> Bool
== String
s
    then forall e a. a -> Result e a
Ok (String
s, forall a. Int -> [a] -> [a]
drop Int
len String
i)
    else forall e a. e -> Result e a
Err forall a b. (a -> b) -> a -> b
$ String
"Input does not match '" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"': " forall a. [a] -> [a] -> [a]
++ Int -> String -> String
shorten Int
16 String
i
  where
    len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s

anyOf :: [Char] -> Parser String Char
anyOf :: String -> Parser String Char
anyOf String
cs = forall i a. (i -> Result String (a, i)) -> Parser i a
Parser forall a b. (a -> b) -> a -> b
$ \case
  [] -> forall e a. e -> Result e a
Err String
"Empty input."
  (Char
i : String
is) ->
    if Char
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
cs
      then forall e a. a -> Result e a
Ok (Char
i, String
is)
      else forall e a. e -> Result e a
Err forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Char
i forall a. [a] -> [a] -> [a]
++ String
" does not match any of '" forall a. [a] -> [a] -> [a]
++ String
cs forall a. [a] -> [a] -> [a]
++ String
"'"

noneOf :: [Char] -> Parser String Char
noneOf :: String -> Parser String Char
noneOf String
cs = forall i a. (i -> Result String (a, i)) -> Parser i a
Parser forall a b. (a -> b) -> a -> b
$ \case
  [] -> forall e a. e -> Result e a
Err String
"Empty input."
  (Char
i : String
is) ->
    if Char
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
cs
      then forall e a. e -> Result e a
Err forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Char
i forall a. [a] -> [a] -> [a]
++ String
" matches '" forall a. [a] -> [a] -> [a]
++ String
cs forall a. [a] -> [a] -> [a]
++ String
"'"
      else forall e a. a -> Result e a
Ok (Char
i, String
is)

ws :: Parser String String
ws :: Parser String String
ws = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (String -> Parser String Char
anyOf String
"\t\n ")

word :: String -> Parser String String
word :: String -> Parser String String
word String
s = String -> Parser String String
str String
s forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser String String
ws

tok :: Parser String String
tok :: Parser String String
tok = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (String -> Parser String Char
noneOf String
"\t\n ") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser String String
ws

dbl :: Parser String Double
dbl :: Parser String Double
dbl = forall i a. (i -> Result String (a, i)) -> Parser i a
Parser forall a b. (a -> b) -> a -> b
$ \String
i -> case forall a. Read a => ReadS a
reads String
i of
  [(Double
x, String
rem)] -> forall e a. a -> Result e a
Ok (Double
x, String
rem)
  [(Double, String)]
_ -> forall e a. e -> Result e a
Err forall a b. (a -> b) -> a -> b
$ String
"No double: " forall a. [a] -> [a] -> [a]
++ Int -> String -> String
shorten Int
16 String
i

bint :: Int -> Parser String Int
bint :: Int -> Parser String Int
bint Int
max =
  forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case forall {a}. Integral a => a -> [a]
digits Int
max of
    [] -> String -> Parser String String
str String
"0"
    (Int
x : [Int]
xs) ->
      (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser String Char
anyOf [Char
'0' .. Int -> Char
d2c (Int
x forall a. Num a => a -> a -> a
- Int
1)] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs) (String -> Parser String Char
anyOf [Char
'0' .. Char
'9'])
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser String Char
anyOf [Int -> Char
d2c Int
x] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
x' -> String -> Parser String Char
anyOf [Char
'0' .. Int -> Char
d2c Int
x']) [Int]
xs
  where
    digits :: a -> [a]
digits a
0 = []
    digits a
x = a -> [a]
digits (a
x forall a. Integral a => a -> a -> a
`div` a
10) forall a. [a] -> [a] -> [a]
++ [a
x forall a. Integral a => a -> a -> a
`mod` a
10]
    d2c :: Int -> Char
d2c = forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

end :: Parser String ()
end :: Parser String ()
end = forall i a. (i -> Result String (a, i)) -> Parser i a
Parser forall a b. (a -> b) -> a -> b
$ \case
  [] -> forall e a. a -> Result e a
Ok ((), String
"")
  String
i -> forall e a. e -> Result e a
Err forall a b. (a -> b) -> a -> b
$ String
"There is still input left: " forall a. [a] -> [a] -> [a]
++ String
i

shorten :: Int -> String -> String
shorten :: Int -> String -> String
shorten Int
len String
str
  | Int
len forall a. Ord a => a -> a -> Bool
> Int
3 =
    if forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str forall a. Ord a => a -> a -> Bool
> Int
len
      then forall a. Int -> [a] -> [a]
take (Int
len forall a. Num a => a -> a -> a
- Int
3) String
str forall a. [a] -> [a] -> [a]
++ String
"..."
      else String
str
shorten Int
len String
str = forall a. Int -> [a] -> [a]
take Int
len String
str

strip :: String -> String
strip :: String -> String
strip = String -> String
drop_ws forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
drop_ws forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
  where
    drop_ws :: String -> String
drop_ws = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"\t\n ")