-----------------------------------------------------------------------------
-- |
-- Module:      Data.Pattern.Common
-- License:     BSD3
-- Maintainer:  Reiner Pope <reiner.pope@gmail.com>
-- Stability:   experimental
-- Portability: portable
--
-- Common pattern combinators.
-----------------------------------------------------------------------------


module Data.Pattern.Common (
  -- * Basic patterns
  var, __, (/\), (\/), view, tryView,
  -- * Non-binding patterns
  is, cst,
  -- * Smart constructors for patterns
  -- | These build patterns from a selector function.
  mk0, mk1, mk2, mk3, mk4, mk5,
  -- * Tuple patterns
  tup0, tup1, tup2, tup3, tup4, tup5,
  -- * @Either@ patterns
  left, right,
  -- * List patterns
  nil, cons,
 ) where

import Data.Pattern.Base

import Control.Applicative
import Control.Monad

-- | \"Variable patterns\": always succeeds, and binds the value to a variable.
{-# INLINE var #-}
var :: Pattern (a :*: Nil) a
var = Pattern (Just . one)

-- | \"Wildcard patterns\": always succeeds. (This is written as two underscores.)
{-# INLINE __ #-}
__ :: Pat0 a
__ = is (const True)

-- | \"And patterns\". Succeeds only if both patterns succeed.
--
-- @(/\\) = 'mk2' (\a -> (a,a))@
{-# INLINE (/\) #-}
(/\) :: Pat2 a a a
(/\) = mk2 (\a -> Just (a,a))

-- | \"Or patterns\". If first pattern fails, then tries the second.
{-# INLINE (\/) #-}
(\/) :: Pattern as a -> Pattern as a -> Pattern as a
(Pattern l) \/ (Pattern r) = Pattern (\a -> l a `mplus` r a)

-- | Matches the 'Left' of an 'Either'.
{-# INLINE left #-}
left :: Pat1 a (Either a b)
left = mk1 (either Just (const Nothing))

-- | Matches the 'Right' of an 'Either'.
{-# INLINE right #-}
right :: Pat1 b (Either a b)
right = mk1 (either (const Nothing) Just)

-- | \"View patterns\": do some computation,
-- then pattern match on the result.
{-# INLINE view #-}
view :: (a -> b) -> Pat1 b a
view f = mk1 (Just . f)

-- | \"Partial view patterns\". Synonym for 'mk1'.
{-# INLINE tryView #-}
tryView :: (a -> Maybe b) -> Pat1 b a
tryView = mk1

-- | \"Predicate pattern\". 'mk0' but with 'Bool' instead of @'Maybe' ()@. 
-- Succeeds if function yields 'True', fails otherwise.
--
-- Can be used with @('/\')@ for some uses similar to pattern guards:
-- 
-- @match a $ 
--      left (var /\\ is even) ->> id
--  ||| left __               ->> const 0
--  ||| right __              ->> const 1@
{-# INLINE is #-}
is :: (a -> Bool) -> Pat0 a
is g = mk0 (\a -> if g a then Just () else Nothing)

-- | \"Constant patterns\": tests for equality to the given constant.
-- @cst x = is (==x)@
{-# INLINE cst #-}
cst :: (Eq a) => a -> Pat0 a
cst x = is (==x)

{-# INLINE nil #-}
nil :: Pat0 [a]
nil = is null

{-# INLINE cons #-}
cons :: Pat2 a [a] [a]
cons = mk2 (\l -> case l of { (x:xs) -> Just (x,xs); _ -> Nothing })

-- | \"Failure pattern\": never succeeds.
{-# INLINE fail #-}
fail :: Pat0 a
fail = is (const False)

{-# INLINE mk0 #-}
mk0 :: (a -> Maybe ()) -> Pat0 a
mk0 g = Pattern (fmap (const zero) . g)

{-# INLINE mk1 #-}
mk1 :: (a -> Maybe b) -> Pat1 b a
mk1 g (Pattern p) = Pattern (\a -> g a >>= p)

{-# INLINE mk2 #-}
mk2 :: (a -> Maybe (b,c)) -> Pat2 b c a
mk2 g b c = mk1 g (tup2 b c)

{-# INLINE mk3 #-}
mk3 :: (a -> Maybe (b,c,d)) -> Pat3 b c d a
mk3 g b c d = mk1 g (tup3 b c d)

{-# INLINE mk4 #-}
mk4 :: (a -> Maybe (b,c,d,e)) -> Pat4 b c d e a
mk4 g b c d e = mk1 g (tup4 b c d e)

{-# INLINE mk5 #-}
mk5 :: (a -> Maybe (b,c,d,e,f)) -> Pat5 b c d e f a
mk5 g b c d e f = mk1 g (tup5 b c d e f)


-- | \"0-tuple pattern\". A strict match on the @()@.
{-# INLINE tup0 #-}
tup0 :: Pat0 ()
tup0 = mk0 (\() -> Just ())

-- | \"1-tuple pattern\". Rather useless.
{-# INLINE tup1 #-}
tup1 :: Pat1 a a
tup1 = mk1 Just

-- | \"2-tuple pattern\"
{-# INLINE tup2 #-}
tup2 :: Pat2 a b (a,b)
tup2 (Pattern pa) (Pattern pb) = Pattern (\(a,b) -> (<>) <$> pa a <*> pb b)

-- | \"3-tuple pattern\"
{-# INLINE tup3 #-}
tup3 :: Pat3 a b c (a,b,c)
tup3 (Pattern pa) (Pattern pb) (Pattern pc) = 
   Pattern (\(a,b,c) -> (<>) <$> pa a <*> ((<>) <$> pb b <*> pc c))

-- | \"4-tuple pattern\"
{-# INLINE tup4 #-}
tup4 :: Pat4 a b c d (a,b,c,d)
tup4 (Pattern pa) (Pattern pb) (Pattern pc) (Pattern pd) = 
   Pattern (\(a,b,c,d) -> (<>) <$> pa a <*> ((<>) <$> pb b <*> ((<>) <$> pc c <*> pd d)))

-- | \"5-tuple pattern\"
{-# INLINE tup5 #-}
tup5 :: Pat5 a b c d e (a,b,c,d,e)
tup5 (Pattern pa) (Pattern pb) (Pattern pc) (Pattern pd) (Pattern pe) = 
   Pattern (\(a,b,c,d,e) -> (<>) <$> pa a <*> ((<>) <$> pb b <*> ((<>) <$> pc c <*> ((<>) <$> pd d <*> pe e))))