descriptive-0.1.0: src/Descriptive.hs
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- | Descriptive parsers.
module Descriptive
(-- * Consuming and describing
consume
,describe
-- * Lower-level runners
,runConsumer
,runDescription
-- * Types
,Description(..)
,Bound(..)
,Consumer(..)
,Result(..)
-- * Combinators
,consumer
,wrap
,sequencing)
where
import Control.Applicative
import Data.Bifunctor
import Data.Function
import Data.Monoid
--------------------------------------------------------------------------------
-- Running
-- | Run a consumer.
consume :: Consumer s d a -- ^ The consumer to run.
-> s -- ^ Initial state.
-> Result (Description d) a
consume (Consumer _ m) = fst . m
-- | Describe a consumer.
describe :: Consumer s d a -- ^ The consumer to run.
-> s -- ^ Initial state. Can be empty if you don't use it for
-- generating descriptions.
-> Description d -- ^ A description and resultant state.
describe (Consumer desc _) = fst . desc
-- | Run a consumer.
runConsumer :: Consumer s d a -- ^ The consumer to run.
-> s -- ^ Initial state.
-> (Result (Description d) a,s)
runConsumer (Consumer _ m) = m
-- | Describe a consumer.
runDescription :: Consumer s d a -- ^ The consumer to run.
-> s -- ^ Initial state. Can be empty if you don't use it for
-- generating descriptions.
-> (Description d,s) -- ^ A description and resultant state.
runDescription (Consumer desc _) = desc
--------------------------------------------------------------------------------
-- Types
-- | Description of a consumable thing.
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
-- | The bounds of a many-consumable thing.
data Bound
= NaturalBound !Integer
| UnlimitedBound
deriving (Show,Eq)
-- | A consumer.
data Consumer s d a =
Consumer {consumerDesc :: s -> (Description d,s)
,consumerParse :: s -> (Result (Description d) a,s)}
-- | Some result.
data Result e a
= Failed e -- ^ The whole process failed.
| Succeeded a -- ^ The whole process succeeded.
| Continued e -- ^ There were errors but we continued to collect all the errors.
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
-- | An internal sequence maker which describes itself better than
-- regular Alternative, and is strict, not lazy.
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
--------------------------------------------------------------------------------
-- Combinators
-- | Make a consumer.
consumer :: (s -> (Description d,s)) -- ^ Produce description based on the state.
-> (s -> (Result (Description d) a,s)) -- ^ Parse the state and maybe transform it if desired.
-> Consumer s d a
consumer d p =
Consumer d p
-- | Wrap a consumer with another consumer.
wrap :: (s -> (t -> (Description d,t)) -> (Description d,s)) -- ^ Transformer the description.
-> (s -> (t -> (Description d,t)) -> (t -> (Result (Description d) a,t)) -> (Result (Description d) b,s)) -- ^ Transform the parser. Can re-run the parser if desired.
-> Consumer t d a -- ^ The consumer to transform.
-> Consumer s d b -- ^ A new consumer with a potentially new state type.
wrap redescribe reparse (Consumer d p) =
Consumer (\s -> redescribe s d)
(\s -> reparse s d p)
-- | Compose contiguous items into one sequence. Similar to 'sequenceA'.
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