{-|
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 :: [SwitchCase test m out] -> test -> m out
switch [SwitchCase test m out]
cases test
test = [m out] -> m out
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
D.asum ([m out] -> m out)
-> ([Either (m out) (m out)] -> [m out])
-> [Either (m out) (m out)]
-> m out
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either (m out) (m out) -> m out)
-> [Either (m out) (m out)] -> [m out]
forall a b. (a -> b) -> [a] -> [b]
map ((m out -> m out)
-> (m out -> m out) -> Either (m out) (m out) -> m out
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either m out -> m out
forall a. a -> a
id m out -> m out
forall a. a -> a
id) ([Either (m out) (m out)] -> m out)
-> [Either (m out) (m out)] -> m out
forall a b. (a -> b) -> a -> b
$
    -- Reduce the list to all 'Right's and only a single (the first) 'Left'.
    [Either (m out) (m out)]
headRights [Either (m out) (m out)]
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. [a] -> [a] -> [a]
++ Int -> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. Int -> [a] -> [a]
take Int
1 [Either (m out) (m out)]
remaining [Either (m out) (m out)]
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. [a] -> [a] -> [a]
++ (Either (m out) (m out) -> Bool)
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. (a -> Bool) -> [a] -> [a]
filter Either (m out) (m out) -> Bool
forall a b. Either a b -> Bool
E.isRight (Int -> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. Int -> [a] -> [a]
drop Int
1 [Either (m out) (m out)]
remaining)
  where ([Either (m out) (m out)]
headRights, [Either (m out) (m out)]
remaining) = (Either (m out) (m out) -> Bool)
-> [Either (m out) (m out)]
-> ([Either (m out) (m out)], [Either (m out) (m out)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Either (m out) (m out) -> Bool
forall a b. Either a b -> Bool
E.isRight ([Either (m out) (m out)]
 -> ([Either (m out) (m out)], [Either (m out) (m out)]))
-> [Either (m out) (m out)]
-> ([Either (m out) (m out)], [Either (m out) (m out)])
forall a b. (a -> b) -> a -> b
$ (SwitchCase test m out
 -> [Either (m out) (m out)] -> [Either (m out) (m out)])
-> [Either (m out) (m out)]
-> [SwitchCase test m out]
-> [Either (m out) (m out)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SwitchCase test m out
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall (m :: * -> *) out.
SwitchCase test m out
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
switch' [] [SwitchCase test m out]
cases
        switch' :: SwitchCase test m out
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
switch' (If test -> Bool
f test -> m out
p) [Either (m out) (m out)]
m
            | test -> Bool
f test
test = m out -> Either (m out) (m out)
forall a b. a -> Either a b
Left (test -> m out
p test
test) Either (m out) (m out)
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. a -> [a] -> [a]
: [Either (m out) (m out)]
m
            | Bool
otherwise = [Either (m out) (m out)]
m
        switch' (If_ test -> Bool
f m out
p) [Either (m out) (m out)]
m
            | test -> Bool
f test
test = m out -> Either (m out) (m out)
forall a b. a -> Either a b
Left m out
p Either (m out) (m out)
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. a -> [a] -> [a]
: [Either (m out) (m out)]
m
            | Bool
otherwise = [Either (m out) (m out)]
m
        switch' (Else test -> m out
p) [Either (m out) (m out)]
m = m out -> Either (m out) (m out)
forall a b. a -> Either a b
Left (test -> m out
p test
test) Either (m out) (m out)
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. a -> [a] -> [a]
: [Either (m out) (m out)]
m
        switch' (Else_ m out
p) [Either (m out) (m out)]
m = m out -> Either (m out) (m out)
forall a b. a -> Either a b
Left m out
p Either (m out) (m out)
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. a -> [a] -> [a]
: [Either (m out) (m out)]
m
        switch' (When test -> Bool
f test -> m out
p) [Either (m out) (m out)]
m
            | test -> Bool
f test
test = m out -> Either (m out) (m out)
forall a b. b -> Either a b
Right (test -> m out
p test
test) Either (m out) (m out)
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. a -> [a] -> [a]
: [Either (m out) (m out)]
m
            | Bool
otherwise = [Either (m out) (m out)]
m
        switch' (When_ test -> Bool
f m out
p) [Either (m out) (m out)]
m
            | test -> Bool
f test
test = m out -> Either (m out) (m out)
forall a b. b -> Either a b
Right m out
p Either (m out) (m out)
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. a -> [a] -> [a]
: [Either (m out) (m out)]
m
            | Bool
otherwise = [Either (m out) (m out)]
m
        switch' (Always test -> m out
p) [Either (m out) (m out)]
m = m out -> Either (m out) (m out)
forall a b. b -> Either a b
Right (test -> m out
p test
test) Either (m out) (m out)
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. a -> [a] -> [a]
: [Either (m out) (m out)]
m
        switch' (Always_ m out
p) [Either (m out) (m out)]
m = m out -> Either (m out) (m out)
forall a b. b -> Either a b
Right m out
p Either (m out) (m out)
-> [Either (m out) (m out)] -> [Either (m out) (m out)]
forall a. a -> [a] -> [a]
: [Either (m out) (m out)]
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