{-# LANGUAGE DefaultSignatures, FlexibleContexts, FlexibleInstances, TypeFamilies,
             TypeOperators, 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 = forall a b. a -> b -> a
const forall (f :: * -> *) a. Alternative f => f a
empty
   expectedName = forall a b. a -> b -> a
const 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 {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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

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

data Error = Error [String] (Maybe String) deriving (Error -> Error -> Bool
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
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 forall a. Semigroup a => a -> a -> a
<> [String]
expected2) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe String
encountered2 forall a. a -> Maybe a
Just Maybe String
encountered1)

instance AlternativeFail Maybe

instance AlternativeFail []

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

instance AlternativeFail (Either Error) where
   failure :: forall a. String -> Either Error a
failure String
encountered = forall a b. a -> Either a b
Left ([String] -> Maybe String -> Error
Error [] (forall a. a -> Maybe a
Just String
encountered))
   expectedName :: forall a. String -> Either Error a -> Either Error a
expectedName String
expected (Left (Error [String]
_ Maybe String
encountered)) = 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) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
"expected " forall a. Semigroup a => a -> a -> a
<>) ([String] -> Maybe String
concatExpected [String]
ex)
errorString (Error [] (Just String
en)) = String
"encountered " forall a. Semigroup a => a -> a -> a
<> String
en
errorString (Error [String]
ex (Just String
en)) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
"expected " forall a. Semigroup a => a -> a -> a
<>) ([String] -> Maybe String
concatExpected [String]
ex) forall a. Semigroup a => a -> a -> a
<> String
", encountered " forall a. Semigroup a => a -> a -> a
<> String
en

concatExpected :: [String] -> Maybe String
concatExpected :: [String] -> Maybe String
concatExpected [] = forall a. Maybe a
Nothing
concatExpected [String
e] = forall a. a -> Maybe a
Just String
e
concatExpected [String
e1, String
e2] = forall a. a -> Maybe a
Just (String
e1 forall a. Semigroup a => a -> a -> a
<> String
" or " forall a. Semigroup a => a -> a -> a
<> String
e2)
concatExpected (String
e:[String]
es) = 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 " forall a. Semigroup a => a -> a -> a
<> String
e
oxfordComma String
e (String
e':[String]
es) = String
e forall a. Semigroup a => a -> a -> a
<> String
", " 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 :: forall (g :: (* -> *) -> *) (n :: * -> *).
(Traversable g, Applicative n) =>
g (Parser t s) -> Parser t s (g n)
fixSequence = 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 :: forall s s' a.
(InputParsing (Parser t s), s ~ ParserInput (Parser t s), Monoid s,
 Monoid s') =>
(s -> s') -> (s' -> s) -> Parser t s a -> Parser t s' a
mapParserInput = forall s s' t r.
(Monoid s, Monoid s') =>
(s -> s') -> (s' -> s) -> Parser t s r -> Parser t s' r
Incremental.mapInput
   mapMaybeParserInput :: forall s s' a.
(InputParsing (Parser t s), s ~ ParserInput (Parser t s), Monoid s,
 Monoid s') =>
(s -> Maybe s') -> (s' -> Maybe s) -> Parser t s a -> Parser t s' a
mapMaybeParserInput = 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