-- Copyright 2017 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE DeriveFunctor #-}
-- | 'UntilFail' list.
module Util.UF where
import Prelude hiding (map, concatMap)
import Control.Arrow (first)
import Util.Pretty (Pretty)
import qualified Util.Pretty as Pretty


-- | This is a list, optionally terminated with an error.
data UntilFail err a = a :+ UntilFail err a | Done | Fail err
    deriving (UntilFail err a -> UntilFail err a -> Bool
(UntilFail err a -> UntilFail err a -> Bool)
-> (UntilFail err a -> UntilFail err a -> Bool)
-> Eq (UntilFail err a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall err a.
(Eq a, Eq err) =>
UntilFail err a -> UntilFail err a -> Bool
/= :: UntilFail err a -> UntilFail err a -> Bool
$c/= :: forall err a.
(Eq a, Eq err) =>
UntilFail err a -> UntilFail err a -> Bool
== :: UntilFail err a -> UntilFail err a -> Bool
$c== :: forall err a.
(Eq a, Eq err) =>
UntilFail err a -> UntilFail err a -> Bool
Eq, Int -> UntilFail err a -> ShowS
[UntilFail err a] -> ShowS
UntilFail err a -> String
(Int -> UntilFail err a -> ShowS)
-> (UntilFail err a -> String)
-> ([UntilFail err a] -> ShowS)
-> Show (UntilFail err a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall err a. (Show a, Show err) => Int -> UntilFail err a -> ShowS
forall err a. (Show a, Show err) => [UntilFail err a] -> ShowS
forall err a. (Show a, Show err) => UntilFail err a -> String
showList :: [UntilFail err a] -> ShowS
$cshowList :: forall err a. (Show a, Show err) => [UntilFail err a] -> ShowS
show :: UntilFail err a -> String
$cshow :: forall err a. (Show a, Show err) => UntilFail err a -> String
showsPrec :: Int -> UntilFail err a -> ShowS
$cshowsPrec :: forall err a. (Show a, Show err) => Int -> UntilFail err a -> ShowS
Show, (forall a b. (a -> b) -> UntilFail err a -> UntilFail err b)
-> (forall a b. a -> UntilFail err b -> UntilFail err a)
-> Functor (UntilFail err)
forall a b. a -> UntilFail err b -> UntilFail err a
forall a b. (a -> b) -> UntilFail err a -> UntilFail err b
forall err a b. a -> UntilFail err b -> UntilFail err a
forall err a b. (a -> b) -> UntilFail err a -> UntilFail err b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> UntilFail err b -> UntilFail err a
$c<$ :: forall err a b. a -> UntilFail err b -> UntilFail err a
fmap :: forall a b. (a -> b) -> UntilFail err a -> UntilFail err b
$cfmap :: forall err a b. (a -> b) -> UntilFail err a -> UntilFail err b
Functor)
infixr :+

instance (Pretty err, Pretty a) => Pretty (UntilFail err a) where
    format :: UntilFail err a -> Doc
format = Bool -> Char -> Char -> [Doc] -> Doc
Pretty.delimitedList Bool
False Char
'[' Char
']' ([Doc] -> Doc)
-> (UntilFail err a -> [Doc]) -> UntilFail err a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UntilFail err a -> [Doc]
forall {a} {a}. (Pretty a, Pretty a) => UntilFail a a -> [Doc]
go
        where
        go :: UntilFail a a -> [Doc]
go (a
x :+ UntilFail a a
xs) = a -> Doc
forall a. Pretty a => a -> Doc
Pretty.format a
x Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: UntilFail a a -> [Doc]
go UntilFail a a
xs
        go UntilFail a a
Done = []
        go (Fail a
err) = [a -> Doc
forall a. Pretty a => a -> Doc
Pretty.format a
err]

fromListFail :: [a] -> err -> UntilFail err a
fromListFail :: forall a err. [a] -> err -> UntilFail err a
fromListFail [a]
as err
err = (a -> UntilFail err a -> UntilFail err a)
-> UntilFail err a -> [a] -> UntilFail err a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> UntilFail err a -> UntilFail err a
forall err a. a -> UntilFail err a -> UntilFail err a
(:+) (err -> UntilFail err a
forall err a. err -> UntilFail err a
Fail err
err) [a]
as

fromList :: [a] -> UntilFail err a
fromList :: forall a err. [a] -> UntilFail err a
fromList = (a -> UntilFail err a -> UntilFail err a)
-> UntilFail err a -> [a] -> UntilFail err a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> UntilFail err a -> UntilFail err a
forall err a. a -> UntilFail err a -> UntilFail err a
(:+) UntilFail err a
forall err a. UntilFail err a
Done

singleton :: a -> UntilFail err a
singleton :: forall a err. a -> UntilFail err a
singleton a
x = a
x a -> UntilFail err a -> UntilFail err a
forall err a. a -> UntilFail err a -> UntilFail err a
:+ UntilFail err a
forall err a. UntilFail err a
Done

toList :: UntilFail err a -> ([a], Maybe err)
toList :: forall err a. UntilFail err a -> ([a], Maybe err)
toList (a
x :+ UntilFail err a
xs) = ([a] -> [a]) -> ([a], Maybe err) -> ([a], Maybe err)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (a
x:) (UntilFail err a -> ([a], Maybe err)
forall err a. UntilFail err a -> ([a], Maybe err)
toList UntilFail err a
xs)
toList UntilFail err a
Done = ([], Maybe err
forall a. Maybe a
Nothing)
toList (Fail err
err) = ([], err -> Maybe err
forall a. a -> Maybe a
Just err
err)

map :: (a -> Either err b) -> UntilFail err a -> UntilFail err b
map :: forall a err b.
(a -> Either err b) -> UntilFail err a -> UntilFail err b
map a -> Either err b
f = UntilFail err a -> UntilFail err b
go
    where
    go :: UntilFail err a -> UntilFail err b
go UntilFail err a
Done = UntilFail err b
forall err a. UntilFail err a
Done
    go (Fail err
err) = err -> UntilFail err b
forall err a. err -> UntilFail err a
Fail err
err
    go (a
a :+ UntilFail err a
as) = case a -> Either err b
f a
a of
        Left err
err -> err -> UntilFail err b
forall err a. err -> UntilFail err a
Fail err
err
        Right b
b -> b
b b -> UntilFail err b -> UntilFail err b
forall err a. a -> UntilFail err a -> UntilFail err a
:+ UntilFail err a -> UntilFail err b
go UntilFail err a
as

concatMap :: (a -> UntilFail err b) -> UntilFail err a -> UntilFail err b
concatMap :: forall a err b.
(a -> UntilFail err b) -> UntilFail err a -> UntilFail err b
concatMap a -> UntilFail err b
f = UntilFail err a -> UntilFail err b
go
    where
    go :: UntilFail err a -> UntilFail err b
go UntilFail err a
Done = UntilFail err b
forall err a. UntilFail err a
Done
    go (Fail err
err) = err -> UntilFail err b
forall err a. err -> UntilFail err a
Fail err
err
    go (a
a :+ UntilFail err a
as) = UntilFail err a -> UntilFail err b -> UntilFail err b
append UntilFail err a
as (a -> UntilFail err b
f a
a)
    append :: UntilFail err a -> UntilFail err b -> UntilFail err b
append UntilFail err a
_ (Fail err
err) = err -> UntilFail err b
forall err a. err -> UntilFail err a
Fail err
err
    append UntilFail err a
as UntilFail err b
Done = UntilFail err a -> UntilFail err b
go UntilFail err a
as
    append UntilFail err a
as (b
b :+ UntilFail err b
bs) = b
b b -> UntilFail err b -> UntilFail err b
forall err a. a -> UntilFail err a -> UntilFail err a
:+ UntilFail err a -> UntilFail err b -> UntilFail err b
append UntilFail err a
as UntilFail err b
bs

-- | Like 'concatMap', but consume and produce a variable number of
-- results.
--
-- A more precise type would end with @Done [a]@.
process :: (a -> [a] -> (UntilFail err b, [a])) -> [a] -> UntilFail err b
process :: forall a err b.
(a -> [a] -> (UntilFail err b, [a])) -> [a] -> UntilFail err b
process a -> [a] -> (UntilFail err b, [a])
f = [a] -> UntilFail err b
go
    where
    go :: [a] -> UntilFail err b
go (a
a : [a]
as) = let (UntilFail err b
bs, [a]
remain) = a -> [a] -> (UntilFail err b, [a])
f a
a [a]
as in [a] -> UntilFail err b -> UntilFail err b
append [a]
remain UntilFail err b
bs
    go [] = UntilFail err b
forall err a. UntilFail err a
Done
    append :: [a] -> UntilFail err b -> UntilFail err b
append [a]
as (b
b :+ UntilFail err b
bs) = b
b b -> UntilFail err b -> UntilFail err b
forall err a. a -> UntilFail err a -> UntilFail err a
:+ [a] -> UntilFail err b -> UntilFail err b
append [a]
as UntilFail err b
bs
    append [a]
as UntilFail err b
Done = [a] -> UntilFail err b
go [a]
as
    append [a]
_ (Fail err
err) = err -> UntilFail err b
forall err a. err -> UntilFail err a
Fail err
err

processM :: Monad m => (a -> [a] -> m (UntilFail err b, [a])) -> [a]
    -> m (UntilFail err b)
processM :: forall (m :: * -> *) a err b.
Monad m =>
(a -> [a] -> m (UntilFail err b, [a]))
-> [a] -> m (UntilFail err b)
processM a -> [a] -> m (UntilFail err b, [a])
f = [a] -> m (UntilFail err b)
go
    where
    go :: [a] -> m (UntilFail err b)
go (a
a : [a]
as) = do
        (UntilFail err b
bs, [a]
remain) <- a -> [a] -> m (UntilFail err b, [a])
f a
a [a]
as
        [a] -> UntilFail err b -> m (UntilFail err b)
append [a]
remain UntilFail err b
bs
    go [] = UntilFail err b -> m (UntilFail err b)
forall (m :: * -> *) a. Monad m => a -> m a
return UntilFail err b
forall err a. UntilFail err a
Done
    append :: [a] -> UntilFail err b -> m (UntilFail err b)
append [a]
as (b
b :+ UntilFail err b
bs) = (b
b :+) (UntilFail err b -> UntilFail err b)
-> m (UntilFail err b) -> m (UntilFail err b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> UntilFail err b -> m (UntilFail err b)
append [a]
as UntilFail err b
bs
    append [a]
as UntilFail err b
Done = [a] -> m (UntilFail err b)
go [a]
as
    append [a]
_ (Fail err
err) = UntilFail err b -> m (UntilFail err b)
forall (m :: * -> *) a. Monad m => a -> m a
return (UntilFail err b -> m (UntilFail err b))
-> UntilFail err b -> m (UntilFail err b)
forall a b. (a -> b) -> a -> b
$ err -> UntilFail err b
forall err a. err -> UntilFail err a
Fail err
err