module Descriptive
(
consume
,describe
,runConsumer
,runDescription
,Description(..)
,Bound(..)
,Consumer(..)
,Result(..)
,consumer
,wrap
,sequencing)
where
import Control.Applicative
import Data.Bifunctor
import Data.Function
import Data.Monoid
consume :: Consumer s d a
-> s
-> Result (Description d) a
consume (Consumer _ m) = fst . m
describe :: Consumer s d a
-> s
-> Description d
describe (Consumer desc _) = fst . desc
runConsumer :: Consumer s d a
-> s
-> (Result (Description d) a,s)
runConsumer (Consumer _ m) = m
runDescription :: Consumer s d a
-> s
-> (Description d,s)
runDescription (Consumer desc _) = desc
data Description a
= Unit !a
| Bounded !Integer !Bound !(Description a)
| And !(Description a) !(Description a)
| Or !(Description a) !(Description a)
| Sequence [Description a]
| Wrap a (Description a)
| None
deriving (Show,Eq)
instance Monoid (Description d) where
mempty = None
mappend = And
data Bound
= NaturalBound !Integer
| UnlimitedBound
deriving (Show,Eq)
data Consumer s d a =
Consumer {consumerDesc :: s -> (Description d,s)
,consumerParse :: s -> (Result (Description d) a,s)}
data Result e a
= Failed e
| Succeeded a
| Continued e
deriving (Show,Eq,Ord)
instance Bifunctor Result where
second f r =
case r of
Succeeded a -> Succeeded (f a)
Failed e -> Failed e
Continued e -> Continued e
first f r =
case r of
Succeeded a -> Succeeded a
Failed e -> Failed (f e)
Continued e -> Continued (f e)
instance Functor (Consumer s d) where
fmap f (Consumer d p) =
Consumer d
(\s ->
case p s of
(Failed e,s') -> (Failed e,s')
(Continued e,s') -> (Continued e,s')
(Succeeded a,s') ->
(Succeeded (f a),s'))
instance Applicative (Consumer s d) where
pure a =
consumer (\s -> (mempty,s))
(\s -> (Succeeded a,s))
Consumer d pf <*> Consumer d' p' =
consumer (\s ->
let !(e,s') = d s
!(e',s'') = d' s'
in (e <> e',s''))
(\s ->
let !(mf,s') = pf s
!(ma,s'') = p' s'
in case mf of
Failed e -> (Failed e,s')
Continued e ->
case ma of
Failed e' ->
(Failed e',s'')
Continued e' ->
(Continued (e <> e'),s'')
Succeeded _ ->
(Continued e,s'')
Succeeded f ->
case ma of
Continued e ->
(Continued e,s'')
Failed e ->
(Failed e,s'')
Succeeded a ->
(Succeeded (f a),s''))
instance Alternative (Consumer s d) where
empty =
Consumer (\s -> (mempty,s))
(\s -> (Failed mempty,s))
a <|> b =
Consumer (\s ->
let !(d1,s') = consumerDesc a s
!(d2,s'') = consumerDesc b s'
in (Or d1 d2,s''))
(\s ->
case consumerParse a s of
(Continued e1,s') ->
case consumerParse b s' of
(Failed e2,s'') ->
(Failed e2,s'')
(Continued e2,s'') ->
(Continued (e1 <> e2),s'')
(Succeeded a',s'') ->
(Succeeded a',s'')
(Failed e1,_) ->
case consumerParse b s of
(Failed e2,s') ->
(Failed (Or e1 e2),s')
(Continued e2,s'') ->
(Continued e2,s'')
(Succeeded a2,s') ->
(Succeeded a2,s')
(Succeeded a1,s') ->
(Succeeded a1,s'))
some = sequenceHelper 1
many = sequenceHelper 0
sequenceHelper :: Integer -> Consumer t d a -> Consumer t d [a]
sequenceHelper minb =
wrap (\s d -> first redescribe (d s))
(\s _ r ->
fix (\go !i s' as ->
case r s' of
(Succeeded a,s'') ->
go (i + 1)
s''
(a : as)
(Continued e,s'') ->
fix (\continue e' s''' ->
case r s''' of
(Continued e'',s'''') ->
continue (e' <> e'') s''''
(Succeeded{},s'''') ->
continue e' s''''
(Failed e'',s'''')
| i >= minb ->
(Continued e',s''')
| otherwise ->
(Failed (redescribe e''),s''''))
e
s''
(Failed e,s'')
| i >= minb ->
(Succeeded (reverse as),s')
| otherwise ->
(Failed (redescribe e),s''))
0
s
[])
where redescribe = Bounded minb UnlimitedBound
instance (Monoid a) => Monoid (Result (Description d) a) where
mempty = Succeeded mempty
mappend x y =
case x of
Failed e -> Failed e
Continued e ->
case y of
Failed e' -> Failed e'
Continued e' -> Continued (e <> e')
Succeeded _ -> Continued e
Succeeded a ->
case y of
Failed e -> Failed e
Continued e -> Continued e
Succeeded b -> Succeeded (a <> b)
instance (Monoid a) => Monoid (Consumer s d a) where
mempty = Consumer (\s -> (mempty,s)) (\s -> (mempty,s))
mappend x y = (<>) <$> x <*> y
consumer :: (s -> (Description d,s))
-> (s -> (Result (Description d) a,s))
-> Consumer s d a
consumer d p =
Consumer d p
wrap :: (s -> (t -> (Description d,t)) -> (Description d,s))
-> (s -> (t -> (Description d,t)) -> (t -> (Result (Description d) a,t)) -> (Result (Description d) b,s))
-> Consumer t d a
-> Consumer s d b
wrap redescribe reparse (Consumer d p) =
Consumer (\s -> redescribe s d)
(\s -> reparse s d p)
sequencing :: [Consumer d s a] -> Consumer d s [a]
sequencing =
wrap (\s d ->
first (Sequence . se)
(d s))
(\s _ p -> p s) .
go
where se (And x y) = x : se y
se None = []
se x = [x]
go (x:xs) = (:) <$> x <*> sequencing xs
go [] = mempty