{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{- |
Module: Generic.Match
Copyright: (c) Samuel Schlesinger 2020-2024
License: MIT
Maintainer: sgschlesinger@gmail.com
Stability: experimental
Portability: non-portable
Description: First class pattern matching based on generics-sop.
-}
module Generic.Match
(
-- * Pattern match on a 'Generic' type
  match
-- * Type classes
, Match
, Consume
-- * Type families
, Matcher
, Matcher'
, Consumer
-- * Re-exported from Generics.SOP
, Generic
) where

import Data.Foldable
import Data.Kind
import Data.Void
import Prelude
import Generics.SOP
import qualified GHC.Generics as GHC

-- | A first class pattern matching function for anything 'Generic', in the style of 'either' and
-- 'maybe', but with the first argument being the thing you are pattern
-- matching on, as opposed to the last argument.
--
-- @either f g x == match x f g@
--
-- @maybe r f x == match x r f@
--
-- Beyond working for 'Maybe' or 'Either', this function works on just
-- about any type you give to it, as long as that type has a 'Generic'
-- instance. For example, this code is from the tests which are not
-- exported from this file:
--
-- @
-- data Ploop =
--    Clap Int Bool
--  | Splop [Integer] Float
--  | Flep [Int] [Float] [Bool]
--  deriving (GHC.Generic, Generic)
-- 
-- newtype X = X { unX :: Int } deriving (GHC.Generic, Generic)
--
-- data Klop = Cloop Klop
--  deriving (GHC.Generic, Generic)
--
-- tests :: Bool
-- tests = and
--  [ match True False True
--  , match False True False
--  , match (Left (5 :: Int)) (== 5) undefined
--  , match (Right ([1,2] :: [Int])) undefined ((== 2) . length)
--  , match (Clap 0 True) (\i b -> i == 0 && b) undefined undefined
--  , match (X 1) (\x -> x == 1)
--  , match (let x = Cloop x in x) (\_ -> True)
--  ]
-- @
--
-- There are other tests as well, at the type level, which I used to
-- develop this library, and I think it makes sense to display those as
-- well:
--
-- @
-- facts :: ()
-- facts = fold
--   [ unitMatcher
--   , boolMatcher
--   , thingMatcher
--   , pairMatcher
--   , tripleMatcher
--   , voidMatcher
--   ]
--
-- unitMatcher :: Matcher () r ~ (r -> r) => ()
-- unitMatcher = ()
-- 
-- boolMatcher :: Matcher Bool r ~ (r -> r -> r) => ()
-- boolMatcher = ()
-- 
-- data Thing = Thing Bool
--   deriving (GHC.Generic, Generic)
--
-- thingMatcher :: Matcher Thing r ~ ((Bool -> r) -> r) => ()
-- thingMatcher = ()
-- 
-- pairMatcher :: Matcher (Int, Bool) r ~ ((Int -> Bool -> r) -> r) => ()
-- pairMatcher = ()
-- 
-- tripleMatcher :: Matcher (Int, Int, Int) r ~ ((Int -> Int -> Int -> r) -> r) => ()
-- tripleMatcher = ()
-- 
-- voidMatcher :: Matcher Void r ~ r => ()
-- voidMatcher = ()
-- @
--
-- These may look strange to the reader, but the way to read them is that
-- the constraint to the left of the fat arrow must be true if I can
-- instantiate one of the terms in a context without assuming it. As
-- I instantiate all of them in that 'fold' (possibly the only use of the
-- '()' monoid that I can think of, all of these constraints must be true.
-- This allowed me to develop this library by making instances that made
-- each new constraint I added true.
match :: forall b r xs. (Generic b, Match (Code b) r) => b -> Matcher b r
match :: b -> Matcher b r
match (b -> Rep b
forall a. Generic a => a -> Rep a
from -> SOP NS (NP I) (Code b)
xs) = NS (NP I) (Code b) -> Matcher b r
forall (xs :: [[*]]) r. Match xs r => NS (NP I) xs -> Matcher' xs r
match' @(Code b) @r NS (NP I) (Code b)
xs

-- | The type of a first class pattern match, having consumed the input.
type Matcher b r = Matcher' (Code b) r

-- | The utility family which defines a 'Matcher', after stripping the
-- metadata from the top level of the 'GHC.Generics' 'Rep'resentation..
type family Matcher' (xs :: [[Type]]) r where
  Matcher' '[] r = r
  Matcher' (x ': xs) r = Consumer x r -> Matcher' xs r

-- | The class that is used to inductively define the pattern matching for
-- a particular generic type.
class Match xs r where
  match' :: NS (NP I) xs -> Matcher' xs r
  const' :: r -> Matcher' xs r

instance Match '[] r where
  match' :: NS (NP I) '[] -> Matcher' '[] r
match' NS (NP I) '[]
x = case NS (NP I) '[]
x of
  const' :: r -> Matcher' '[] r
const' = r -> Matcher' '[] r
forall a. a -> a
id

instance (Consume x, Match xs r) => Match (x ': xs) r where
  const' :: r -> Matcher' (x : xs) r
const' r
r Consumer x r
_ = r -> Matcher' xs r
forall (xs :: [[*]]) r. Match xs r => r -> Matcher' xs r
const' @xs r
r
  match' :: NS (NP I) (x : xs) -> Matcher' (x : xs) r
match' (Z NP I x
x) = \Consumer x r
c -> r -> Matcher' xs r
forall (xs :: [[*]]) r. Match xs r => r -> Matcher' xs r
const' @xs @r (NP I x -> Consumer x r -> r
forall (xs :: [*]) r. Consume xs => NP I xs -> Consumer xs r -> r
consume @x NP I x
NP I x
x Consumer x r
c)
  match' (S NS (NP I) xs
xs) = \Consumer x r
_ -> NS (NP I) xs -> Matcher' xs r
forall (xs :: [[*]]) r. Match xs r => NS (NP I) xs -> Matcher' xs r
match' @xs @r NS (NP I) xs
NS (NP I) xs
xs

-- | The type family that describes how to consume a product inside of a 'Generic' type.
type family Consumer (xs :: [Type]) (r :: Type) where
  Consumer '[] r = r
  Consumer (x ': xs) r = x -> Consumer xs r

-- | The typeclass used to consume a product inside of a 'Generic' type.
class Consume xs where
  consume :: forall r. NP I xs -> Consumer xs r -> r

instance Consume '[] where
  consume :: NP I '[] -> Consumer '[] r -> r
consume NP I '[]
Nil Consumer '[] r
r = r
Consumer '[] r
r

instance Consume xs => Consume (x ': xs) where
  consume :: NP I (x : xs) -> Consumer (x : xs) r -> r
consume (I x
x :* NP I xs
xs) Consumer (x : xs) r
f = NP I xs -> Consumer xs r -> r
forall (xs :: [*]) r. Consume xs => NP I xs -> Consumer xs r -> r
consume NP I xs
xs (Consumer (x : xs) r
x -> Consumer xs r
f (I x -> x
forall a. I a -> a
unI I x
x))

facts :: ()
facts :: ()
facts = [()] -> ()
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
  [ ()
forall r. (Matcher () r ~ (r -> r)) => ()
unitMatcher
  , ()
forall r. (Matcher Bool r ~ (r -> r -> r)) => ()
boolMatcher
  , ()
forall r. (Matcher Thing r ~ ((Bool -> r) -> r)) => ()
thingMatcher
  , ()
forall r. (Matcher (Int, Bool) r ~ ((Int -> Bool -> r) -> r)) => ()
pairMatcher
  , ()
forall r.
(Matcher (Int, Int, Int) r ~ ((Int -> Int -> Int -> r) -> r)) =>
()
tripleMatcher
  , ()
forall r. (Matcher Void r ~ r) => ()
voidMatcher
  ]

unitMatcher :: Matcher () r ~ (r -> r) => ()
unitMatcher :: ()
unitMatcher = ()

boolMatcher :: Matcher Bool r ~ (r -> r -> r) => ()
boolMatcher :: ()
boolMatcher = ()

data Thing = Thing Bool
  deriving ((forall x. Thing -> Rep Thing x)
-> (forall x. Rep Thing x -> Thing) -> Generic Thing
forall x. Rep Thing x -> Thing
forall x. Thing -> Rep Thing x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Thing x -> Thing
$cfrom :: forall x. Thing -> Rep Thing x
GHC.Generic, All SListI (Code Thing)
All SListI (Code Thing)
-> (Thing -> Rep Thing) -> (Rep Thing -> Thing) -> Generic Thing
Rep Thing -> Thing
Thing -> Rep Thing
forall a.
All SListI (Code a) -> (a -> Rep a) -> (Rep a -> a) -> Generic a
to :: Rep Thing -> Thing
$cto :: Rep Thing -> Thing
from :: Thing -> Rep Thing
$cfrom :: Thing -> Rep Thing
$cp1Generic :: All SListI (Code Thing)
Generic)

thingMatcher :: Matcher Thing r ~ ((Bool -> r) -> r) => ()
thingMatcher :: ()
thingMatcher = ()

pairMatcher :: Matcher (Int, Bool) r ~ ((Int -> Bool -> r) -> r) => ()
pairMatcher :: ()
pairMatcher = ()

tripleMatcher :: Matcher (Int, Int, Int) r ~ ((Int -> Int -> Int -> r) -> r) => ()
tripleMatcher :: ()
tripleMatcher = ()

voidMatcher :: Matcher Void r ~ r => ()
voidMatcher :: ()
voidMatcher = ()

data Ploop = Clap Int Bool | Splop [Integer] Float | Flep [Int] [Float] [Bool] deriving ((forall x. Ploop -> Rep Ploop x)
-> (forall x. Rep Ploop x -> Ploop) -> Generic Ploop
forall x. Rep Ploop x -> Ploop
forall x. Ploop -> Rep Ploop x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Ploop x -> Ploop
$cfrom :: forall x. Ploop -> Rep Ploop x
GHC.Generic, All SListI (Code Ploop)
All SListI (Code Ploop)
-> (Ploop -> Rep Ploop) -> (Rep Ploop -> Ploop) -> Generic Ploop
Rep Ploop -> Ploop
Ploop -> Rep Ploop
forall a.
All SListI (Code a) -> (a -> Rep a) -> (Rep a -> a) -> Generic a
to :: Rep Ploop -> Ploop
$cto :: Rep Ploop -> Ploop
from :: Ploop -> Rep Ploop
$cfrom :: Ploop -> Rep Ploop
$cp1Generic :: All SListI (Code Ploop)
Generic)

newtype X = X { X -> Int
unX :: Int } deriving ((forall x. X -> Rep X x) -> (forall x. Rep X x -> X) -> Generic X
forall x. Rep X x -> X
forall x. X -> Rep X x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep X x -> X
$cfrom :: forall x. X -> Rep X x
GHC.Generic, All SListI (Code X)
All SListI (Code X) -> (X -> Rep X) -> (Rep X -> X) -> Generic X
Rep X -> X
X -> Rep X
forall a.
All SListI (Code a) -> (a -> Rep a) -> (Rep a -> a) -> Generic a
to :: Rep X -> X
$cto :: Rep X -> X
from :: X -> Rep X
$cfrom :: X -> Rep X
$cp1Generic :: All SListI (Code X)
Generic)

data Klop = Cloop Klop deriving ((forall x. Klop -> Rep Klop x)
-> (forall x. Rep Klop x -> Klop) -> Generic Klop
forall x. Rep Klop x -> Klop
forall x. Klop -> Rep Klop x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Klop x -> Klop
$cfrom :: forall x. Klop -> Rep Klop x
GHC.Generic, All SListI (Code Klop)
All SListI (Code Klop)
-> (Klop -> Rep Klop) -> (Rep Klop -> Klop) -> Generic Klop
Rep Klop -> Klop
Klop -> Rep Klop
forall a.
All SListI (Code a) -> (a -> Rep a) -> (Rep a -> a) -> Generic a
to :: Rep Klop -> Klop
$cto :: Rep Klop -> Klop
from :: Klop -> Rep Klop
$cfrom :: Klop -> Rep Klop
$cp1Generic :: All SListI (Code Klop)
Generic)

data Blango = Koooka Bool Int Float Integer Float Bool Integer Int deriving ((forall x. Blango -> Rep Blango x)
-> (forall x. Rep Blango x -> Blango) -> Generic Blango
forall x. Rep Blango x -> Blango
forall x. Blango -> Rep Blango x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Blango x -> Blango
$cfrom :: forall x. Blango -> Rep Blango x
GHC.Generic, All SListI (Code Blango)
All SListI (Code Blango)
-> (Blango -> Rep Blango)
-> (Rep Blango -> Blango)
-> Generic Blango
Rep Blango -> Blango
Blango -> Rep Blango
forall a.
All SListI (Code a) -> (a -> Rep a) -> (Rep a -> a) -> Generic a
to :: Rep Blango -> Blango
$cto :: Rep Blango -> Blango
from :: Blango -> Rep Blango
$cfrom :: Blango -> Rep Blango
$cp1Generic :: All SListI (Code Blango)
Generic)

data Klaka = Pooka Int Bool | Lotis Integer | Undo Int | Podango () deriving ((forall x. Klaka -> Rep Klaka x)
-> (forall x. Rep Klaka x -> Klaka) -> Generic Klaka
forall x. Rep Klaka x -> Klaka
forall x. Klaka -> Rep Klaka x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Klaka x -> Klaka
$cfrom :: forall x. Klaka -> Rep Klaka x
GHC.Generic, All SListI (Code Klaka)
All SListI (Code Klaka)
-> (Klaka -> Rep Klaka) -> (Rep Klaka -> Klaka) -> Generic Klaka
Rep Klaka -> Klaka
Klaka -> Rep Klaka
forall a.
All SListI (Code a) -> (a -> Rep a) -> (Rep a -> a) -> Generic a
to :: Rep Klaka -> Klaka
$cto :: Rep Klaka -> Klaka
from :: Klaka -> Rep Klaka
$cfrom :: Klaka -> Rep Klaka
$cp1Generic :: All SListI (Code Klaka)
Generic)

tests :: Bool
tests :: Bool
tests = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
  [ Bool -> Bool -> Bool -> Bool
forall k b r (xs :: k).
(Generic b, Match (Code b) r) =>
b -> Matcher b r
match Bool
True Bool
False Bool
True
  , Bool -> Bool -> Bool -> Bool
forall k b r (xs :: k).
(Generic b, Match (Code b) r) =>
b -> Matcher b r
match Bool
False Bool
True Bool
False
  , Either Int Any -> (Int -> Bool) -> (Any -> Bool) -> Bool
forall k b r (xs :: k).
(Generic b, Match (Code b) r) =>
b -> Matcher b r
match (Int -> Either Int Any
forall a b. a -> Either a b
Left (Int
5 :: Int)) (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5) Any -> Bool
forall a. HasCallStack => a
undefined
  , Either Any [Int] -> (Any -> Bool) -> ([Int] -> Bool) -> Bool
forall k b r (xs :: k).
(Generic b, Match (Code b) r) =>
b -> Matcher b r
match ([Int] -> Either Any [Int]
forall a b. b -> Either a b
Right ([Int
1,Int
2] :: [Int])) Any -> Bool
forall a. HasCallStack => a
undefined ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Int -> Bool) -> ([Int] -> Int) -> [Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length)
  , Ploop
-> (Int -> Bool -> Bool)
-> ([Integer] -> Float -> Bool)
-> ([Int] -> [Float] -> [Bool] -> Bool)
-> Bool
forall k b r (xs :: k).
(Generic b, Match (Code b) r) =>
b -> Matcher b r
match (Int -> Bool -> Ploop
Clap Int
0 Bool
True) (\Int
i Bool
b -> Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Bool
b) [Integer] -> Float -> Bool
forall a. HasCallStack => a
undefined [Int] -> [Float] -> [Bool] -> Bool
forall a. HasCallStack => a
undefined
  , X -> (Int -> Bool) -> Bool
forall k b r (xs :: k).
(Generic b, Match (Code b) r) =>
b -> Matcher b r
match (Int -> X
X Int
1) (\Int
x -> Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1)
  , Klop -> (Klop -> Bool) -> Bool
forall k b r (xs :: k).
(Generic b, Match (Code b) r) =>
b -> Matcher b r
match (let x :: Klop
x = Klop -> Klop
Cloop Klop
x in Klop
x) (\Klop
_ -> Bool
True)
  , Blango
-> (Bool
    -> Int
    -> Float
    -> Integer
    -> Float
    -> Bool
    -> Integer
    -> Int
    -> Bool)
-> Bool
forall k b r (xs :: k).
(Generic b, Match (Code b) r) =>
b -> Matcher b r
match (Bool
-> Int
-> Float
-> Integer
-> Float
-> Bool
-> Integer
-> Int
-> Blango
Koooka Bool
True Int
0 Float
0 Integer
0 Float
0 Bool
True Integer
0 Int
0) (\Bool
b1 Int
x1 Float
x2 Integer
x3 Float
x4 Bool
b2 Integer
x5 Int
x6 -> Bool
b1 Bool -> Bool -> Bool
&& Bool
b2 Bool -> Bool -> Bool
&& Int
x1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Float
x2 Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 Bool -> Bool -> Bool
&& Integer
x3 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
&& Float
x4 Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 Bool -> Bool -> Bool
&& Integer
x5 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
&& Int
x6 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
  , Klaka
-> (Int -> Bool -> Bool)
-> (Integer -> Bool)
-> (Int -> Bool)
-> (() -> Bool)
-> Bool
forall k b r (xs :: k).
(Generic b, Match (Code b) r) =>
b -> Matcher b r
match (() -> Klaka
Podango ()) Int -> Bool -> Bool
forall a. HasCallStack => a
undefined Integer -> Bool
forall a. HasCallStack => a
undefined Int -> Bool
forall a. HasCallStack => a
undefined (Bool -> () -> Bool
forall a b. a -> b -> a
const Bool
True)
  ]