{-# LANGUAGE DefaultSignatures, FlexibleContexts, FlexibleInstances, TypeFamilies,
             TypeSynonymInstances, UndecidableInstances #-}

-- | The only good reason to import this module is if you intend to add another instance of the classes it exports.

module Construct.Classes where

import qualified Rank2
import qualified Text.ParserCombinators.Incremental as Incremental

import Control.Applicative (Alternative ((<|>), empty))
import qualified Data.Attoparsec.ByteString as Attoparsec
import Text.Parser.Input (InputParsing (ParserInput))

-- | Subclass of 'Alternative' that carries an error message in case of failure
class Alternative m => AlternativeFail m where
   -- | Equivalent to 'empty' except it takes an error message it may carry or drop on the floor. The grammatical form
   --  of the argument should be a noun representing the unexpected value.
   failure :: String -> m a
   -- | Sets or modifies the expected value.
   expectedName :: String -> m a -> m a

   failure = m a -> String -> m a
forall a b. a -> b -> a
const m a
forall (f :: * -> *) a. Alternative f => f a
empty
   expectedName = (m a -> m a) -> String -> m a -> m a
forall a b. a -> b -> a
const m a -> m a
forall a. a -> a
id

-- | A subclass of 'InputParsing' for parsers that can switch the input stream type
class InputMappableParsing m where
   -- | Converts a parser accepting one input stream type to another. The functions @forth@ and @back@ must be
   -- inverses of each other and they must distribute through '<>':
   --
   -- > f (s1 <> s2) == f s1 <> f s2
   mapParserInput :: (InputParsing (m s), s ~ ParserInput (m s), Monoid s, Monoid s') =>
                     (s -> s') -> (s' -> s) -> m s a -> m s' a
   -- | Converts a parser accepting one input stream type to another just like 'mapParserInput', except the argument
   -- functions can return @Nothing@ to indicate they need more input.
   
   mapMaybeParserInput :: (InputParsing (m s), s ~ ParserInput (m s), Monoid s, Monoid s') =>
                          (s -> Maybe s') -> (s' -> Maybe s) -> m s a -> m s' a

-- | A subclass of 'MonadFix' for monads that can fix a function that handles higher-kinded data
class Monad m => FixTraversable m where
   -- | This specialized form of 'Rank2.traverse' can be used inside 'mfix'.
   fixSequence :: (Rank2.Traversable g, Applicative n) => g m -> m (g n)
   fixSequence = (forall a. m a -> m (n a)) -> g m -> m (g n)
forall k (g :: (k -> *) -> *) (m :: * -> *) (p :: k -> *)
       (q :: k -> *).
(Traversable g, Applicative m) =>
(forall (a :: k). p a -> m (q a)) -> g p -> m (g q)
Rank2.traverse (a -> n a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> n a) -> m a -> m (n a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

------------------------------------------------------------
--                       Instances
------------------------------------------------------------

data Error = Error [String] (Maybe String) deriving (Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

instance Semigroup Error where
   Error [String]
expected1 Maybe String
encountered1 <> :: Error -> Error -> Error
<> Error [String]
expected2 Maybe String
encountered2 =
      [String] -> Maybe String -> Error
Error ([String]
expected1 [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
expected2) (Maybe String
-> (String -> Maybe String) -> Maybe String -> Maybe String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe String
encountered2 String -> Maybe String
forall a. a -> Maybe a
Just Maybe String
encountered1)

instance AlternativeFail Maybe

instance AlternativeFail []

instance {-# OVERLAPS #-} Alternative (Either Error) where
   empty :: Either Error a
empty = Error -> Either Error a
forall a b. a -> Either a b
Left ([String] -> Maybe String -> Error
Error [] Maybe String
forall a. Maybe a
Nothing)
   Right a
a <|> :: Either Error a -> Either Error a -> Either Error a
<|> Either Error a
_ = a -> Either Error a
forall a b. b -> Either a b
Right a
a
   Either Error a
_ <|> Right a
a = a -> Either Error a
forall a b. b -> Either a b
Right a
a
   Left Error
e1 <|> Left Error
e2 = Error -> Either Error a
forall a b. a -> Either a b
Left (Error
e1 Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
e2)

instance AlternativeFail (Either Error) where
   failure :: String -> Either Error a
failure String
encountered = Error -> Either Error a
forall a b. a -> Either a b
Left ([String] -> Maybe String -> Error
Error [] (String -> Maybe String
forall a. a -> Maybe a
Just String
encountered))
   expectedName :: String -> Either Error a -> Either Error a
expectedName String
expected (Left (Error [String]
_ Maybe String
encountered)) = Error -> Either Error a
forall a b. a -> Either a b
Left ([String] -> Maybe String -> Error
Error [String
expected] Maybe String
encountered)
   expectedName String
_ Either Error a
success = Either Error a
success

errorString :: Error -> String
errorString :: Error -> String
errorString (Error [String]
ex Maybe String
Nothing) = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
"expected " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ([String] -> Maybe String
concatExpected [String]
ex)
errorString (Error [] (Just String
en)) = String
"encountered " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
en
errorString (Error [String]
ex (Just String
en)) = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
"expected " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ([String] -> Maybe String
concatExpected [String]
ex) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", encountered " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
en

concatExpected :: [String] -> Maybe String
concatExpected :: [String] -> Maybe String
concatExpected [] = Maybe String
forall a. Maybe a
Nothing
concatExpected [String
e] = String -> Maybe String
forall a. a -> Maybe a
Just String
e
concatExpected [String
e1, String
e2] = String -> Maybe String
forall a. a -> Maybe a
Just (String
e1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" or " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e2)
concatExpected (String
e:[String]
es) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> [String] -> String
oxfordComma String
e [String]
es)

oxfordComma :: String -> [String] -> String
oxfordComma :: String -> [String] -> String
oxfordComma String
e [] = String
"or " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e
oxfordComma String
e (String
e':[String]
es) = String
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
oxfordComma String
e' [String]
es

instance FixTraversable Attoparsec.Parser

instance Monoid s => FixTraversable (Incremental.Parser t s) where
   fixSequence :: g (Parser t s) -> Parser t s (g n)
fixSequence = g (Parser t s) -> Parser t s (g n)
forall (g :: (* -> *) -> *) (m :: * -> *) s t.
(Traversable g, Applicative m, Monoid s) =>
g (Parser t s) -> Parser t s (g m)
Incremental.record

instance InputMappableParsing (Incremental.Parser t) where
   mapParserInput :: (s -> s') -> (s' -> s) -> Parser t s a -> Parser t s' a
mapParserInput = (s -> s') -> (s' -> s) -> Parser t s a -> Parser t s' a
forall s s' t r.
(Monoid s, Monoid s') =>
(s -> s') -> (s' -> s) -> Parser t s r -> Parser t s' r
Incremental.mapInput
   mapMaybeParserInput :: (s -> Maybe s') -> (s' -> Maybe s) -> Parser t s a -> Parser t s' a
mapMaybeParserInput = (s -> Maybe s') -> (s' -> Maybe s) -> Parser t s a -> Parser t s' a
forall s s' t r.
(Monoid s, Monoid s') =>
(s -> Maybe s') -> (s' -> Maybe s) -> Parser t s r -> Parser t s' r
Incremental.mapMaybeInput