Switch.hs

{-|
Description:    A monad combinator emulating greedy pattern matching.

Copyright:      (c) 2020 Sam May
License:        MPL-2.0
Maintainer:     ag.eitilt@gmail.com

Stability:      provisional
Portability:    portable

'A.Alternative' instances can provide a form of pattern matching if given a
fail-on-false combinator (e.g. 'Control.Monad.when'), however the exact
behaviour isn't guaranteed; an underlying 'Maybe' does provide a greedy match,
but @[]@ will match later overlapping tests even if they are intended to be
masked; compare the masking to standard, cascading pattern guards.  This module
provides a means of formalizing that behaviour into a predictable form, no
matter which 'A.Alternative' winds up being used.
-}
module Web.Willow.Common.Parser.Switch
    ( SwitchCase ( .. )
    , switch
    ) where


import qualified Control.Applicative as A

import qualified Data.Foldable as D
import qualified Data.Either as E


-- | Run a block of 'SwitchCase's, collapsing any masking cases so that only
-- the first matched test remains.  This is strictly more powerful than pattern
-- matching, as it allows interspersing non-masking tests alongside masking
-- ones; for compatibility with refactoring to single-return 'A.Alternative'
-- instances, however (i.e. 'Maybe'), it's best to order everything /as if/
-- every case could mask the ones after it.  Note that the masking only affects
-- the output; the tests themselves may still be run, so expensive computations
-- are best put elsewhere.
-- 
-- Only the first overlapping (maskable) case is selected:
-- 
-- >>> uppercase = If_   isUpper  $ return "uppercase"
-- >>> one       = When_ (== '1') $ return "single '1'"
-- >>> alpha     = If_   isAlpha  $ return "ASCII letter"       -- Matches
-- >>> catchall  = Else_          $ return "none of the above"  -- Matches
-- >>> switch [uppercase, one, alpha, catchall] 'a' :: [String]
-- ["ASCII letter"]
-- 
-- Non-masking cases don't interact with the masking calculations:
-- 
-- >>> uppercase = If_   isUpper  $ return "uppercase"
-- >>> one       = When_ (== '1') $ return "single '1'"         -- Matches
-- >>> alpha     = If_   isAlpha  $ return "ASCII letter"
-- >>> catchall  = Else_          $ return "none of the above"  -- Matches
-- >>> switch [uppercase, one, alpha, catchall] '1' :: [String]
-- ["single '1'", "none of the above"]
-- 
-- 'Maybe' always takes the earliest successful test:
-- 
-- >>> uppercase = If_   isUpper  $ return "uppercase"
-- >>> one       = When_ (== '1') $ return "single '1'"         -- Matches
-- >>> alpha     = If_   isAlpha  $ return "ASCII letter"
-- >>> catchall  = Else_          $ return "none of the above"  -- Matches
-- >>> switch [uppercase, one, alpha, catchall] '1' :: Maybe String
-- Just "single '1'"
-- 
-- 'Always' and 'Always_' function as a standard 'A.Alternative' computation:
-- 
-- >>> switch [Always a, Always b, Always_ c] tok == a tok <|> b tok <|> c
-- True
switch :: A.Alternative m => [SwitchCase test m out] -> test -> m out
switch cases test = D.asum . map (either id id) $
    -- Reduce the list to all 'Right's and only a single (the first) 'Left'.
    headRights ++ take 1 remaining ++ filter E.isRight (drop 1 remaining)
  where (headRights, remaining) = span E.isRight $ foldr switch' [] cases
        switch' (If f p) m
            | f test = Left (p test) : m
            | otherwise = m
        switch' (If_ f p) m
            | f test = Left p : m
            | otherwise = m
        switch' (Else p) m = Left (p test) : m
        switch' (Else_ p) m = Left p : m
        switch' (When f p) m
            | f test = Right (p test) : m
            | otherwise = m
        switch' (When_ f p) m
            | f test = Right p : m
            | otherwise = m
        switch' (Always p) m = Right (p test) : m
        switch' (Always_ p) m = Right p : m


-- | The building blocks for predictable pattern matches over 'A.Alternative'.
-- The constructors are distinguished along three axes (see also the examples
-- in the documentation for 'switch'):
-- 
-- * "masking" vs. "non-masking": only the first "masking" case fulfilled will
--   be returned, while /every/ "non-masking" one is returned
-- * "matching" vs. "catchall": whether the output is gated by a predicate test
--   or not
-- * "piped" vs. "static": whether the output is passed the original test token
data SwitchCase test m out
    = If (test -> Bool) (test -> m out)
        -- ^ Masking, matching, and piped
    | If_ (test -> Bool) (m out)
        -- ^ Masking, matching, and static
    | Else (test -> m out)
        -- ^ Masking, catchall, and piped
    | Else_ (m out)
        -- ^ Masking, catchall, and static
    | When (test -> Bool) (test -> m out)
        -- ^ Non-masking, matching, and piped
    | When_ (test -> Bool) (m out)
        -- ^ Non-masking, matching, and static
    | Always (test -> m out)
        -- ^ Non-masking, catchall, and piped
    | Always_ (m out)
        -- ^ Non-masking, catchall, and static