Implementation of arrowised parser from Hughes' paper: "Generalising Monads to Arrows", based on ideas by Swierstra and Duponcheel.

ASD.hs

import Prelude hiding (id, (.))
import Control.Arrow
import Control.Category
import qualified Data.List as List

data StaticParser s = SP Bool [s]
newtype DynamicParser s a b = DP ((a, [s]) -> (b, [s]))
data Parser s a b = P (StaticParser s) (DynamicParser s a b)

instance Eq s => Category (Parser s) where
  id = arr id
  P (SP e1 s1) (DP p1) . P (SP e2 s2) (DP p2) =
    P (SP (e1 && e2)
          (s2 `List.union` if e2 then s1 else []))
      (DP (p1 . p2))

instance Eq s => Arrow (Parser s) where
  arr f = P (SP True []) (DP (\(b, s) -> (f b, s)))
  first (P sp (DP p)) = P sp (DP (\((b, d), s) -> let (c, s') = p (b, s) in ((c, d), s')))

instance Eq s => ArrowZero (Parser s) where
  zeroArrow = P (SP True []) (DP (\(_, s) -> (undefined, s)))

instance Eq s => ArrowPlus (Parser s) where
  P (SP e1 s1) (DP p1) <+> P (SP e2 s2) (DP p2) = -- s1 and s2 must be distinct
    P (SP (e1 || e2) (s1 ++ s2))
      $ DP $ \(a, xs) ->
        case xs of
          []    | e1          -> p1 (a, [])
                | otherwise   -> p2 (a, [])
          x : _ | x `elem` s1 -> p1 (a, xs)
                | x `elem` s2 -> p2 (a, xs)
                | e1          -> p1 (a, xs)
                | otherwise   -> p2 (a, xs)

symbol :: s -> Parser s a s
symbol s = P (SP False [s]) (DP (\(_, _ : xs) -> (s, xs)))

invokeDet :: Eq s => Parser s () a -> [s] -> a
invokeDet (P _ (DP p)) inp = case p ((), inp) of (a, _) -> a

main :: IO ()
main = do
  let p = symbol 'a' >>> (symbol 'b' <+> symbol 'c')
  print $ invokeDet p "ab"
  print $ invokeDet p "ac"
  print $ invokeDet p "ad"