GHC Trac #12001: Add pattern synonyms to base

12001.markdown

Ticket #12001.

Data.List.NonEmpty

pattern Singleton :: a -> NonEmpty a
pattern Singleton a <- (uncons -> (a, Nothing))
  where Singleton a = a N.:| []

infixr 5 :|
pattern (:|) :: a -> NonEmpty a -> NonEmpty a
pattern a:|as          <- (uncons -> (a, Just as))
  where a:|(a' N.:| as) = a N.:| a':as

matches inductive type

-- Control.Monad.Cofree.Cofree Maybe
data NonEmpty a = Singleton a | a :| NonEmpty a

Compare this to the solution using NonEmpty

-- gcd' :: GCDDomain r => NonEmpty r -> r
-- gcd' (x :| [])          = normalize x
-- gcd' (x :| [y])         = gcd x y
-- gcd' (x :| NonEmpty ys) = gcd x (gcd' ys)

gcd' :: GCDDomain a => NonEmpty a -> a
gcd' (Singleton x) = normalize x
gcd' (x :| xs)     = gcd x (gcd' xs)

-- unwrap (_ N.:| [])          = Nothing
-- unwrap (_ N.:| NonEmpty as) = Just as

unwrap :: NonEmpty a -> Maybe (NonEmpty a)
unwrap Singleton{} = Nothing
unwrap (_:|as)     = Just as

Maybe add a fold for good measure

foldNonEmpty :: NonEmpty a -> (a -> r) -> (a -> r -> r) -> r
foldNonEmpty (Singleton a) f _   = f a
foldNonEmpty (a:|as)       f (·) = a · foldNonEmpty as f (·)

ghc' :: GCDDomain a => NonEmpty a -> a
gcd' = foldNonEmpty normalize ghc 

foldr1_ :: (a -> Maybe b -> b) -> (NonEmpty a -> b)
foldr1_ f = \case
  Singleton a -> f a Nothing
  a:|as       -> 
    f a $ Just $ foldr1_ f as

heh :: (a -> b) -> (a -> b -> b) -> (NonEmpty a -> b)
heh f g = \case
  Singleton a -> 
    f a

  a :| as -> 
    g a (heh f g as)

data EOO a = EVEN a | ODD a

evenOrOdd :: Integral a => a -> EOO a
evenOrOdd n
  | even n = EVEN (n     `quot` 2)
  | odd  n = ODD  ((n-1) `quot` 2)

{-# Complete Even, Odd #-}
pattern Even n <- (evenOrOdd -> EVEN n)
pattern Odd  n <- (evenOrOdd -> ODD  n)

This makes code like this

(^) :: (Num a, Integral b) => a -> b -> a
x0 ^ y0 | y0 < 0    = error "Negative exponent"
        | y0 == 0   = 1
        | otherwise = f x0 y0
    where f x y | even y    = f (x * x) (y `quot` 2)
                | y == 1    = x
                | otherwise = g (x * x) ((y - 1) `quot` 2) x
          g x y z | even y = g (x * x) (y `quot` 2) z
                  | y == 1 = x * z
                  | otherwise = g (x * x) ((y - 1) `quot` 2) (x * z)

(^) :: (Num a, Integral b) => a -> b -> a
x0 ^ y0 | y0 < 0    = error "Negative exponent"
          | y0 == 0   = 1
          | otherwise = f x0 y0
    where f x = \case
            1      -> x
            Even y -> f (x * x)   y
            Odd  y -> g (x * x) x y 

          g x z = \case
            1      -> x * z
            Even y -> g (x * x) z       y
            Odd  y -> g (x * x) (x * z) y

With

data NZP = N | Z | P

nzp :: (Num a, Ord a) => a -> NZP
nzp 0 = Z
nzp n 
  | n < 0 = N
  | 0 < n = P

pattern Neg <- (nzp -> P)
pattern Pos <- (nzp -> P)

(^) :: forall a b. (Num a, Integral b) => a -> b -> a
_ ^ Neg   = error "Negative exponent"
_ ^ 0     = 1
x ^ y@Pos = f x y where
  f :: a -> b -> a
  f x = \case
    1      -> x
    Even y -> f (x * x)   y
    Odd  y -> g (x * x) x y 

  g :: a -> a -> b -> a
  g x z = \case
    1      -> x * z
    Even y -> g (x * x) z       y
    Odd  y -> g (x * x) (x * z) y