Skip to content

Instantly share code, notes, and snippets.

@roberth
Last active May 12, 2020 18:39
Show Gist options
  • Save roberth/dc90ba82976d10d75caf2122c6812032 to your computer and use it in GitHub Desktop.
Save roberth/dc90ba82976d10d75caf2122c6812032 to your computer and use it in GitHub Desktop.
Parsing unordered things
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Gather where
import Protolude
-- | Fold over the outcomes of a type that has an 'Alternative'.
--
-- @Gather@ embodies two steps.
--
-- * Getting data using 'many' and '<|>' from 'Alternative'
-- * Postprocessing the data in some way.
--
-- For example, @Gather (Either String) Parser@ is a type that helps you parse a sequence of
-- mixed production, similar to @many (p1 <|> p2 <|> p3)@ but then it also lets you specify
-- what to do with the aggregate result @p1@ and the aggregate result of @p2@ and so on.
--
-- Example:
--
-- > data Vehicle = Vehicle { wheels :: [Wheel], seats :: (Seat, [Seat]) }
-- >
-- > -- | Parse vehicle parts in any order
-- > parseVehicle = join $ runGather (
-- > Vehicle <$> zeroOrMore parseWheel
-- > <*> oneOrMore (fail "A vehicle requires at least one seat.") parseSeat
-- > )
data Gather g f a =
forall m. (Monoid m) =>
Gather
{ items :: f m
, postProcess :: m -> g a
}
instance (Functor g, Functor f) => Functor (Gather g f) where
fmap f (Gather items p) = Gather items (fmap (fmap f) p)
instance (Applicative g, Alternative f) => Applicative (Gather g f) where
pure x = Gather (empty :: f ()) (pure (pure x))
Gather ia pa <*> Gather ib pb = Gather ((l <$> ia) <|> (r <$> ib)) (\(ma, mb) -> pa ma <*> pb mb)
where l x = (x, mempty)
r x = (mempty, x)
runGather :: (Alternative f) => Gather g f a -> f (g a)
runGather (Gather i p) = let x = mconcat <$> many i in fmap p x
gather :: Monoid m => (m -> g a) -> f m -> Gather g f a
gather p i = Gather i p
-- TODO: Use DList in these functions
zeroOrMore :: (Functor f, Applicative g)
=> f a
-> Gather g f [a]
zeroOrMore item = Gather (fmap (:[]) item) $ pure
zeroOrMore_ :: (Functor f, Applicative g)
=> f a
-> Gather g f ()
zeroOrMore_ item = Gather (fmap mempty item) $ pure
zeroOrOne :: (Functor f, Applicative g)
=> g (Maybe a) -- ^ on many, typically a 'fail', 'Left' or similar
-> f a
-> Gather g f (Maybe a)
zeroOrOne onMany item = Gather (fmap (:[]) item) $
\l -> case l of
[] -> pure Nothing
[a] -> pure (Just a)
_ -> onMany
oneOrMore :: (Functor f, Applicative g)
=> g (a, [a]) -- ^ on zero, typically a 'fail', 'Left' or similar
-> f a
-> Gather g f (a, [a])
oneOrMore onErr item = Gather (fmap (:[]) item) $
\l -> case l of
[] -> onErr
(a: as) -> pure (a, as)
exactlyOne :: (Functor f, Applicative g)
=> g a -- ^ on zero, typically a 'fail', 'Left' or similar
-> g a -- ^ on many, typically a 'fail', 'Left' or similar
-> f a
-> Gather g f a
exactlyOne onNil onMany item = Gather (fmap (:[]) item) $
\l -> case l of
[] -> onNil
[a] -> pure a
_ -> onMany
@roberth
Copy link
Author

roberth commented May 12, 2020

I haven't yet. I'd want to explore the space a bit more before publishing it. For example I'd like to improve the behavior of (,) <$> exactlyOne e e a <$> exactlyOne e e a, to make it not fail and behave like "exactlyTwo a". Not super useful by itself but more so when they're not identical but overlapping. Also the performance is probably not great for large expressions.

@jsoo1
Copy link

jsoo1 commented May 12, 2020

Ok, no problem. I really appreciate this. Do you mind if I used the code in a library? Would you like some attribution?

@roberth
Copy link
Author

roberth commented May 12, 2020

At this point not uploading was getting more complicated than uploading :) It's here: https://hackage.haskell.org/package/gather-0.1.0.0

@jsoo1
Copy link

jsoo1 commented May 12, 2020

Awesome! Thank you for this!

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment