Unordered applicative

Main.hs

{-# LANGUAGE ApplicativeDo #-}

module Main where

import Data.Void (Void)
import Text.Megaparsec (Parsec, parseTest)
import Text.Megaparsec.Char (char)
import Text.Megaparsec.Char.Lexer (decimal)
import UnordApp (liftApp, runUnord)

type Parser a = Parsec Void String a

unord :: Parser (Char, Char, Int)
unord = runUnord $ do
  a <- liftApp $ char 'a'
  b <- liftApp $ char 'b'
  n <- liftApp decimal
  pure (a, b, n)

main :: IO ()
main =
  mapM_
    (parseTest unord)
    [ "12ab", -- ('a','b',12)
      "ab", -- expecting integer
      "a32b", -- ('a','b',32)
      "2b3a"
      {-
          |
        1 | 2b3a
          |   ^
        expecting 'a'
      -}
    ]

UnordApp.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

module UnordApp
  ( UnordApp,
    runUnord,
    liftApp,
  )
where

import Control.Applicative (Alternative (..), optional)

-- | Unordered Applicative on Alternative
data UnordApp :: (* -> *) -> * -> * where
  Pure :: a -> UnordApp f a
  Lift :: f a -> UnordApp f a
  (:#) :: UnordApp f (u -> a) -> UnordApp f u -> UnordApp f a

liftApp :: f a -> UnordApp f a
liftApp = Lift

instance Functor f => Functor (UnordApp f) where
  fmap f (Pure a) = Pure $ f a
  fmap f (Lift a) = Lift $ f <$> a
  fmap f (vb :# v) = ((f .) <$> vb) :# v

instance Applicative f => Applicative (UnordApp f) where
  pure = Pure
  mab <*> (Pure a) = ($ a) <$> mab
  mab <*> (Lift fa) = mab :# Lift fa
  mab <*> (mua :# mu) = ((.) <$> mab <*> mua) :# mu

step :: Alternative f => UnordApp f a -> f (UnordApp f a, Bool)
step = \case
  Pure a -> pure (Pure a, False)
  Lift fa -> h <$> optional fa
    where
      h Nothing = (Lift fa, False)
      h (Just a) = (Pure a, True)
  mua :# mu -> h <$> step mua <*> step mu
    where
      h (mua', bua') (mu', bu') =
        let res = case mua' of
              Pure ua' -> ua' <$> mu'
              _ -> mua' :# mu'
         in (res, bua' || bu')

runUnord :: (Alternative f, Monad f) => UnordApp f a -> f a
runUnord ma = h =<< step ma
  where
    h = \case
      (Pure a, _) -> pure a
      (ma', True) -> runUnord ma'
      (ma', False) -> empty