{-# Language BlockArguments, ViewPatterns, LambdaCase, TypeFamilies, TypeOperators #-}
{-|
Module      : Advent.ReadS
Description : Newtype for parsing with ReadS
Copyright   : (c) Eric Mertens, 2021
License     : ISC
Maintainer  : emertens@gmail.com

Make it easier to use ReadS.

-}
module Advent.ReadS where

import Control.Applicative (Alternative((<|>), empty), many)
import Control.Monad (ap, liftM)
import Data.Functor (void)
import Data.String (IsString(..))

-- | Wrapper for 'ReadS'
newtype P a = P { forall a. P a -> ReadS a
unP :: ReadS a }

-- | Parse a string or throw an error
runP :: P a -> String -> a
runP :: forall a. P a -> String -> a
runP (P ReadS a
f) (ReadS a
f -> (a
x,String
_):[(a, String)]
_) = a
x
runP P a
_ String
x = String -> a
forall a. HasCallStack => String -> a
error (String
"failed to parse: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x)

-- | Match a specific string token and return it.
tok :: String -> P String
tok :: String -> P String
tok String
t = do u <- ReadS String -> P String
forall a. ReadS a -> P a
P ReadS String
lex; if t == u then pure u else empty

-- | Match a leading character
char :: Char -> P ()
char :: Char -> P ()
char Char
c = ReadS () -> P ()
forall a. ReadS a -> P a
P \case
  Char
x:String
xs | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
x -> [((),String
xs)]
  String
_             -> []

instance Functor P where
    fmap :: forall a b. (a -> b) -> P a -> P b
fmap = (a -> b) -> P a -> P b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative P where
    <*> :: forall a b. P (a -> b) -> P a -> P b
(<*>) = P (a -> b) -> P a -> P b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    pure :: forall a. a -> P a
pure a
x = ReadS a -> P a
forall a. ReadS a -> P a
P \String
s -> [(a
x,String
s)]

instance Monad P where
    P ReadS a
m >>= :: forall a b. P a -> (a -> P b) -> P b
>>= a -> P b
f = ReadS b -> P b
forall a. ReadS a -> P a
P \String
s -> do (x,s') <- ReadS a
m String
s; case f x of P ReadS b
g -> ReadS b
g String
s'

instance Alternative P where
    P ReadS a
x <|> :: forall a. P a -> P a -> P a
<|> P ReadS a
y = ReadS a -> P a
forall a. ReadS a -> P a
P \String
s -> ReadS a
x String
s [(a, String)] -> [(a, String)] -> [(a, String)]
forall a. [a] -> [a] -> [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadS a
y String
s
    empty :: forall a. P a
empty = ReadS a -> P a
forall a. ReadS a -> P a
P ([(a, String)] -> ReadS a
forall a b. a -> b -> a
const [])

instance MonadFail P where
    fail :: forall a. String -> P a
fail String
_ = P a
forall a. P a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | String literals match with 'tok'
instance a ~ String => IsString (P a) where
    fromString :: String -> P a
fromString = String -> P a
String -> P String
tok

-- * Combinators

-- | Parse a separated, nonempty list.
sepBy1 :: P a {- ^ element -} -> P b {- ^ separator -} -> P [a]
sepBy1 :: forall a b. P a -> P b -> P [a]
sepBy1 P a
p P b
q = (:) (a -> [a] -> [a]) -> P a -> P ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P a
p P ([a] -> [a]) -> P [a] -> P [a]
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P a -> P [a]
forall a. P a -> P [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (P b
q P b -> P a -> P a
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P a
p)

-- | Parse a separated list.
sepBy :: P a {- ^ element -} -> P b {- ^ separator -} -> P [a]
sepBy :: forall a b. P a -> P b -> P [a]
sepBy P a
p P b
q = [a] -> P [a]
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] P [a] -> P [a] -> P [a]
forall a. P a -> P a -> P a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P a -> P b -> P [a]
forall a b. P a -> P b -> P [a]
sepBy1 P a
p P b
q

-- | Convenience function for surrounding a parser with other other parsers.
between :: P a {- ^ open -} -> P b {- ^ close -} -> P c {- ^ body -} -> P c
between :: forall a b c. P a -> P b -> P c -> P c
between P a
p P b
q P c
x = P a
p P a -> P c -> P c
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P c
x P c -> P b -> P c
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P b
q

-- | Parser that succeeds at end of input string.
eof :: P ()
eof :: P ()
eof = P String -> P ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (String -> P String
tok String
"")

-- | Parse using a 'Read' instance.
pread :: Read a => P a
pread :: forall a. Read a => P a
pread = ReadS a -> P a
forall a. ReadS a -> P a
P ReadS a
forall a. Read a => ReadS a
reads

-- | Wrapper for 'readParen'
preadParen :: Bool -> P a -> P a
preadParen :: forall a. Bool -> P a -> P a
preadParen Bool
req (P ReadS a
p) = ReadS a -> P a
forall a. ReadS a -> P a
P (Bool -> ReadS a -> ReadS a
forall a. Bool -> ReadS a -> ReadS a
readParen Bool
req ReadS a
p)

-- | Left-biased choice. Uses righthand-side if lefthand-side fails.
(<++) :: P a -> P a -> P a
P ReadS a
f <++ :: forall a. P a -> P a -> P a
<++ P ReadS a
g = ReadS a -> P a
forall a. ReadS a -> P a
P \String
s -> ReadS a
f String
s [(a, String)] -> [(a, String)] -> [(a, String)]
forall a. [a] -> [a] -> [a]
`orElse` ReadS a
g String
s
  where
    orElse :: [a] -> [a] -> [a]
orElse [] [a]
ys = [a]
ys
    orElse [a]
xs [a]
_  = [a]
xs

infixr 3 <++