{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      : Data.Pattern.Any
-- Description : A module to work with a 'QuasiQuoter' to use different patterns in the head same function clause.
-- Maintainer  : hapytexeu+gh@gmail.com
-- Stability   : experimental
-- Portability : POSIX
--
-- The module exposes two 'QuasiQuoter's named 'anypat' and 'maypat' that allow compiling separate patterns into a single (view) pattern that
-- will fire in case any of the patterns matches. If there are any variable names, it will match these. For the 'anypat' it requires that all
-- variables occur in all patterns. For 'maypat' that is not a requirement. For both 'QuasiQuoter's, it is however required that the variables
-- have the same type in each pattern.
module Data.Pattern.Any
  ( -- * Quasiquoters
    anypat,
    maypat,
    rangepat,

    -- * derive variable names names from patterns
    patVars,
    patVars',

    -- * Range objects
    RangeObj (FromRange, FromThenRange, FromToRange, FromThenToRange),
    rangeToList,
    inRange,
  )
where

import Control.Arrow (first)
import Control.Monad ((>=>))
# if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif
import Data.List (sort)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Language.Haskell.Exts.Parser (ParseResult (ParseFailed, ParseOk), parseExp, parsePat)
import Language.Haskell.Meta (toExp, toPat)
import Language.Haskell.TH (Body (NormalB), Exp (AppE, ArithSeqE, ConE, LamCaseE, TupE, VarE), Match (Match), Name, Pat (AsP, BangP, ConP, InfixP, ListP, LitP, ParensP, RecP, SigP, TildeP, TupP, UInfixP, UnboxedSumP, UnboxedTupP, VarP, ViewP, WildP), Q, Range (FromR, FromThenR, FromThenToR, FromToR))
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))

data HowPass = Simple | AsJust | AsNothing deriving (HowPass -> HowPass -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HowPass -> HowPass -> Bool
$c/= :: HowPass -> HowPass -> Bool
== :: HowPass -> HowPass -> Bool
$c== :: HowPass -> HowPass -> Bool
Eq, Eq HowPass
HowPass -> HowPass -> Bool
HowPass -> HowPass -> Ordering
HowPass -> HowPass -> HowPass
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HowPass -> HowPass -> HowPass
$cmin :: HowPass -> HowPass -> HowPass
max :: HowPass -> HowPass -> HowPass
$cmax :: HowPass -> HowPass -> HowPass
>= :: HowPass -> HowPass -> Bool
$c>= :: HowPass -> HowPass -> Bool
> :: HowPass -> HowPass -> Bool
$c> :: HowPass -> HowPass -> Bool
<= :: HowPass -> HowPass -> Bool
$c<= :: HowPass -> HowPass -> Bool
< :: HowPass -> HowPass -> Bool
$c< :: HowPass -> HowPass -> Bool
compare :: HowPass -> HowPass -> Ordering
$ccompare :: HowPass -> HowPass -> Ordering
Ord, ReadPrec [HowPass]
ReadPrec HowPass
Int -> ReadS HowPass
ReadS [HowPass]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HowPass]
$creadListPrec :: ReadPrec [HowPass]
readPrec :: ReadPrec HowPass
$creadPrec :: ReadPrec HowPass
readList :: ReadS [HowPass]
$creadList :: ReadS [HowPass]
readsPrec :: Int -> ReadS HowPass
$creadsPrec :: Int -> ReadS HowPass
Read, Int -> HowPass -> ShowS
[HowPass] -> ShowS
HowPass -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HowPass] -> ShowS
$cshowList :: [HowPass] -> ShowS
show :: HowPass -> String
$cshow :: HowPass -> String
showsPrec :: Int -> HowPass -> ShowS
$cshowsPrec :: Int -> HowPass -> ShowS
Show)

-- | A 'RangeObj' that specifies a range with a start value and optionally a step value and end value.
data RangeObj a
  = -- | A 'RangeObj' object that only has a start value, in Haskell specified as @[b ..]@.
    FromRange a
  | -- | A 'RangeObj' object that has a start value and end value, in Haskell specified as @[b .. e]@.
    FromThenRange a a
  | -- | A 'RangeObj' object with a start and next value, in Haskell specified as @[b, s ..]@.
    FromToRange a a
  | -- | A 'RangeObj' object with a start, next value and end value, in Haskell specified as @[b, s .. e]@.
    FromThenToRange a a a
  deriving (RangeObj a -> RangeObj a -> Bool
forall a. Eq a => RangeObj a -> RangeObj a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RangeObj a -> RangeObj a -> Bool
$c/= :: forall a. Eq a => RangeObj a -> RangeObj a -> Bool
== :: RangeObj a -> RangeObj a -> Bool
$c== :: forall a. Eq a => RangeObj a -> RangeObj a -> Bool
Eq, forall a b. a -> RangeObj b -> RangeObj a
forall a b. (a -> b) -> RangeObj a -> RangeObj b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RangeObj b -> RangeObj a
$c<$ :: forall a b. a -> RangeObj b -> RangeObj a
fmap :: forall a b. (a -> b) -> RangeObj a -> RangeObj b
$cfmap :: forall a b. (a -> b) -> RangeObj a -> RangeObj b
Functor, ReadPrec [RangeObj a]
ReadPrec (RangeObj a)
ReadS [RangeObj a]
forall a. Read a => ReadPrec [RangeObj a]
forall a. Read a => ReadPrec (RangeObj a)
forall a. Read a => Int -> ReadS (RangeObj a)
forall a. Read a => ReadS [RangeObj a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RangeObj a]
$creadListPrec :: forall a. Read a => ReadPrec [RangeObj a]
readPrec :: ReadPrec (RangeObj a)
$creadPrec :: forall a. Read a => ReadPrec (RangeObj a)
readList :: ReadS [RangeObj a]
$creadList :: forall a. Read a => ReadS [RangeObj a]
readsPrec :: Int -> ReadS (RangeObj a)
$creadsPrec :: forall a. Read a => Int -> ReadS (RangeObj a)
Read, Int -> RangeObj a -> ShowS
forall a. Show a => Int -> RangeObj a -> ShowS
forall a. Show a => [RangeObj a] -> ShowS
forall a. Show a => RangeObj a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RangeObj a] -> ShowS
$cshowList :: forall a. Show a => [RangeObj a] -> ShowS
show :: RangeObj a -> String
$cshow :: forall a. Show a => RangeObj a -> String
showsPrec :: Int -> RangeObj a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RangeObj a -> ShowS
Show)

-- | Convert the 'RangeObj' to a list of the values defined by the range.
rangeToList ::
  Enum a =>
  -- | The 'RangeObj' item to convert to a list.
  RangeObj a ->
  -- | A list of items the 'RangeObj' spans.
  [a]
rangeToList :: forall a. Enum a => RangeObj a -> [a]
rangeToList (FromRange a
b) = forall a. Enum a => a -> [a]
enumFrom a
b
rangeToList (FromThenRange a
b a
t) = forall a. Enum a => a -> a -> [a]
enumFromThen a
b a
t
rangeToList (FromToRange a
b a
e) = forall a. Enum a => a -> a -> [a]
enumFromTo a
b a
e
rangeToList (FromThenToRange a
b a
t a
e) = forall a. Enum a => a -> a -> a -> [a]
enumFromThenTo a
b a
t a
e

-- | Provides a list of variable names for a given 'Pat'tern. The list is /not/ sorted. If the same variable name occurs multiple times (which does not make much sense), it will be listed multiple times.
patVars' ::
  -- | The 'Pat'tern to inspect.
  Pat ->
  -- | The list of remaining elements that is added as tail.
  [Name] ->
  -- | The list of variable names that is used to collect (fragments) of the pattern.
  [Name]
patVars' :: Pat -> [Name] -> [Name]
patVars' (LitP Lit
_) = forall a. a -> a
id
patVars' (VarP Name
n) = (Name
n forall a. a -> [a] -> [a]
:)
patVars' (TupP [Pat]
ps) = [Pat] -> [Name] -> [Name]
patVarsF [Pat]
ps
patVars' (UnboxedTupP [Pat]
ps) = [Pat] -> [Name] -> [Name]
patVarsF [Pat]
ps
patVars' (UnboxedSumP Pat
p Int
_ Int
_) = Pat -> [Name] -> [Name]
patVars' Pat
p
patVars' (InfixP Pat
p₁ Name
_ Pat
p₂) = Pat -> [Name] -> [Name]
patVars' Pat
p₁ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> [Name] -> [Name]
patVars' Pat
p₂
patVars' (UInfixP Pat
p₁ Name
_ Pat
p₂) = Pat -> [Name] -> [Name]
patVars' Pat
p₁ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> [Name] -> [Name]
patVars' Pat
p₂
patVars' (ParensP Pat
p) = Pat -> [Name] -> [Name]
patVars' Pat
p
patVars' (TildeP Pat
p) = Pat -> [Name] -> [Name]
patVars' Pat
p
patVars' (BangP Pat
p) = Pat -> [Name] -> [Name]
patVars' Pat
p
patVars' (AsP Name
n Pat
p) = (Name
n forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> [Name] -> [Name]
patVars' Pat
p
patVars' Pat
WildP = forall a. a -> a
id
patVars' (RecP Name
_ [FieldPat]
ps) = [Pat] -> [Name] -> [Name]
patVarsF (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [FieldPat]
ps)
patVars' (ListP [Pat]
ps) = [Pat] -> [Name] -> [Name]
patVarsF [Pat]
ps
patVars' (SigP Pat
p Type
_) = Pat -> [Name] -> [Name]
patVars' Pat
p
patVars' (ViewP Exp
_ Pat
p) = Pat -> [Name] -> [Name]
patVars' Pat
p
patVars' Pat
x = Pat -> [Name] -> [Name]
patVarsExtra' Pat
x

#if MIN_VERSION_template_haskell(2,18,0)
patVarsExtra' :: Pat -> [Name] -> [Name]
patVarsExtra' :: Pat -> [Name] -> [Name]
patVarsExtra' (ConP Name
_ [Type]
_ [Pat]
ps) = [Pat] -> [Name] -> [Name]
patVarsF [Pat]
ps
patVarsExtra' Pat
_ = forall a. a -> a
id
#else
patVarsExtra' :: Pat -> [Name] -> [Name]
patVarsExtra' (ConP _ ps) = patVarsF ps
patVarsExtra' _ = id
#endif

patVarsF :: [Pat] -> [Name] -> [Name]
patVarsF :: [Pat] -> [Name] -> [Name]
patVarsF = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> [Name] -> [Name]
patVars') forall a. a -> a
id

-- | Provides a list of variable names for a given 'Pat'tern. The list is /not/ sorted. If the same variable name occurs multiple times (which does not make much sense), it will be listed multiple times.
patVars ::
  -- | The 'Pat'tern to inspect.
  Pat ->
  -- | The list of variable names that is used to collect (fragments) of the pattern.
  [Name]
patVars :: Pat -> [Name]
patVars = (Pat -> [Name] -> [Name]
`patVars'` [])

howPass :: Bool -> Bool -> HowPass
howPass :: Bool -> Bool -> HowPass
howPass Bool
False Bool
True = HowPass
AsJust
howPass Bool
False Bool
False = HowPass
AsNothing
howPass Bool
True Bool
True = HowPass
Simple
howPass Bool
True Bool
False = forall a. HasCallStack => String -> a
error String
"This should never happen"

unionPats :: NonEmpty Pat -> ([(Bool, Name)], [[(HowPass, Name)]])
unionPats :: NonEmpty Pat -> ([(Bool, Name)], [[(HowPass, Name)]])
unionPats (Pat
x :| [Pat]
xs) = ([(Bool, Name)]
un, [[(HowPass, Name)]]
un')
  where
    n0 :: [Name]
n0 = Pat -> [Name]
go Pat
x
    ns :: [[Name]]
ns = forall a b. (a -> b) -> [a] -> [b]
map Pat -> [Name]
go [Pat]
xs
    go :: Pat -> [Name]
go = forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> [Name]
patVars
    go' :: [a] -> [(Bool, a)]
go' = forall a b. (a -> b) -> [a] -> [b]
map (Bool
True,)
    un :: [(Bool, Name)]
un = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c d.
Ord a =>
b -> c -> (b -> c -> d) -> [(b, a)] -> [(c, a)] -> [(d, a)]
sortedUnion Bool
False Bool
False Bool -> Bool -> Bool
(&&) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [a] -> [(Bool, a)]
go') (forall {a}. [a] -> [(Bool, a)]
go' [Name]
n0) [[Name]]
ns
    un' :: [[(HowPass, Name)]]
un' = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c d.
Ord a =>
b -> c -> (b -> c -> d) -> [(b, a)] -> [(c, a)] -> [(d, a)]
sortedUnion Bool
False Bool
False Bool -> Bool -> HowPass
howPass [(Bool, Name)]
un forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Bool
True,)) ([Name]
n0 forall a. a -> [a] -> [a]
: [[Name]]
ns)

#if MIN_VERSION_template_haskell(2,18,0)
conP :: Name -> [Pat] -> Pat
conP :: Name -> [Pat] -> Pat
conP = (Name -> [Type] -> [Pat] -> Pat
`ConP` [])
#else
conP :: Name -> [Pat] -> Pat
conP = ConP
#endif

bodyPat :: Bool -> [Name] -> (Exp, Pat)
bodyPat :: Bool -> [Name] -> (Exp, Pat)
bodyPat Bool
_ [] = (Name -> Exp
ConE 'False, Name -> [Pat] -> Pat
conP 'True [])
bodyPat Bool
b [Name
n] = (Name -> Exp
ConE 'Nothing, forall a. (a -> a) -> Bool -> a -> a
wrapIt (Name -> [Pat] -> Pat
conP 'Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) Bool
b (Name -> Pat
VarP Name
n))
bodyPat Bool
b [Name]
ns = (Name -> Exp
ConE 'Nothing, forall a. (a -> a) -> Bool -> a -> a
wrapIt (Name -> [Pat] -> Pat
conP 'Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) Bool
b (Pat -> Pat
TildeP ([Pat] -> Pat
TupP (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
ns))))

transName' :: HowPass -> Name -> Exp
transName' :: HowPass -> Name -> Exp
transName' HowPass
Simple = Name -> Exp
VarE
transName' HowPass
AsNothing = forall a b. a -> b -> a
const (Name -> Exp
ConE 'Nothing)
transName' HowPass
AsJust = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Just) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE

transName :: (HowPass, Name) -> Exp
transName :: (HowPass, Name) -> Exp
transName = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HowPass -> Name -> Exp
transName'

#if MIN_VERSION_template_haskell(2, 16, 0)
_transName :: (HowPass, Name) -> Maybe Exp
_transName :: (HowPass, Name) -> Maybe Exp
_transName = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HowPass, Name) -> Exp
transName
#else
_transName :: (HowPass, Name) -> Exp
_transName = transName
#endif

wrapIt :: (a -> a) -> Bool -> a -> a
wrapIt :: forall a. (a -> a) -> Bool -> a -> a
wrapIt a -> a
f = Bool -> a -> a
go
  where
    go :: Bool -> a -> a
go Bool
False = forall a. a -> a
id
    go Bool
True = a -> a
f

bodyExp :: Bool -> [(HowPass, Name)] -> Exp
bodyExp :: Bool -> [(HowPass, Name)] -> Exp
bodyExp Bool
_ [] = Name -> Exp
ConE 'True
bodyExp Bool
b [(HowPass, Name)
n] = forall a. (a -> a) -> Bool -> a -> a
wrapIt (Name -> Exp
ConE 'Just Exp -> Exp -> Exp
`AppE`) Bool
b ((HowPass, Name) -> Exp
transName (HowPass, Name)
n)
bodyExp Bool
b [(HowPass, Name)]
ns = forall a. (a -> a) -> Bool -> a -> a
wrapIt (Name -> Exp
ConE 'Just Exp -> Exp -> Exp
`AppE`) Bool
b ([Maybe Exp] -> Exp
TupE (forall a b. (a -> b) -> [a] -> [b]
map (HowPass, Name) -> Maybe Exp
_transName [(HowPass, Name)]
ns))

unionCaseFunc' :: [Pat] -> [Name] -> [[(HowPass, Name)]] -> (Exp, Pat)
unionCaseFunc' :: [Pat] -> [Name] -> [[(HowPass, Name)]] -> (Exp, Pat)
unionCaseFunc' [Pat]
ps [Name]
ns [[(HowPass, Name)]]
ns' = ([Match] -> Exp
LamCaseE (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Pat
p' [(HowPass, Name)]
n -> Pat -> Body -> [Dec] -> Match
Match Pat
p' (Exp -> Body
NormalB (Bool -> [(HowPass, Name)] -> Exp
bodyExp Bool
partial [(HowPass, Name)]
n)) []) [Pat]
ps [[(HowPass, Name)]]
ns' forall a. [a] -> [a] -> [a]
++ [Match]
add), Pat
p)
  where
    ~(Exp
ef, Pat
p) = Bool -> [Name] -> (Exp, Pat)
bodyPat Bool
partial [Name]
ns
    partial :: Bool
partial = Pat
WildP forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Pat]
ps
    add :: [Match]
add = [Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB Exp
ef) [] | Bool
partial]

sortedUnion :: Ord a => b -> c -> (b -> c -> d) -> [(b, a)] -> [(c, a)] -> [(d, a)]
sortedUnion :: forall a b c d.
Ord a =>
b -> c -> (b -> c -> d) -> [(b, a)] -> [(c, a)] -> [(d, a)]
sortedUnion b
v0 c
v1 b -> c -> d
f = forall {b}. Ord b => [(b, b)] -> [(c, b)] -> [(d, b)]
go
  where
    go :: [(b, b)] -> [(c, b)] -> [(d, b)]
go [] [(c, b)]
ys = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (b -> c -> d
f b
v0)) [(c, b)]
ys
    go xa :: [(b, b)]
xa@((b
b0, b
x) : [(b, b)]
xs) ya :: [(c, b)]
ya@((c
b1, b
y) : [(c, b)]
ys) = case forall a. Ord a => a -> a -> Ordering
compare b
x b
y of
      Ordering
EQ -> (b -> c -> d
f b
b0 c
b1, b
x) forall a. a -> [a] -> [a]
: [(b, b)] -> [(c, b)] -> [(d, b)]
go [(b, b)]
xs [(c, b)]
ys
      Ordering
GT -> (b -> c -> d
f b
v0 c
b1, b
y) forall a. a -> [a] -> [a]
: [(b, b)] -> [(c, b)] -> [(d, b)]
go [(b, b)]
xa [(c, b)]
ys
      Ordering
LT -> (b -> c -> d
f b
b0 c
v1, b
x) forall a. a -> [a] -> [a]
: [(b, b)] -> [(c, b)] -> [(d, b)]
go [(b, b)]
xs [(c, b)]
ya
    go [(b, b)]
xs [] = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (b -> c -> d
`f` c
v1)) [(b, b)]
xs

unionCaseFuncWith :: MonadFail m => ((Exp, Pat) -> a) -> Bool -> NonEmpty Pat -> m a
unionCaseFuncWith :: forall (m :: * -> *) a.
MonadFail m =>
((Exp, Pat) -> a) -> Bool -> NonEmpty Pat -> m a
unionCaseFuncWith (Exp, Pat) -> a
f Bool
chk ps :: NonEmpty Pat
ps@(Pat
p0 :| [Pat]
ps')
  | Bool -> Bool
not Bool
chk Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. (a, b) -> a
fst [(Bool, Name)]
ns = forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Exp, Pat) -> a
f ([Pat] -> [Name] -> [[(HowPass, Name)]] -> (Exp, Pat)
unionCaseFunc' (Pat
p0 forall a. a -> [a] -> [a]
: [Pat]
ps') (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, Name)]
ns) [[(HowPass, Name)]]
ns'))
  | Bool
otherwise = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not all patterns have the same variable names"
  where
    ([(Bool, Name)]
ns, [[(HowPass, Name)]]
ns') = NonEmpty Pat -> ([(Bool, Name)], [[(HowPass, Name)]])
unionPats NonEmpty Pat
ps

unionCaseFunc :: MonadFail m => Bool -> NonEmpty Pat -> m Pat
unionCaseFunc :: forall (m :: * -> *). MonadFail m => Bool -> NonEmpty Pat -> m Pat
unionCaseFunc = forall (m :: * -> *) a.
MonadFail m =>
((Exp, Pat) -> a) -> Bool -> NonEmpty Pat -> m a
unionCaseFuncWith (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Exp -> Pat -> Pat
ViewP)

unionCaseExp :: MonadFail m => Bool -> NonEmpty Pat -> m Exp
unionCaseExp :: forall (m :: * -> *). MonadFail m => Bool -> NonEmpty Pat -> m Exp
unionCaseExp = forall (m :: * -> *) a.
MonadFail m =>
((Exp, Pat) -> a) -> Bool -> NonEmpty Pat -> m a
unionCaseFuncWith forall a b. (a, b) -> a
fst

#if MIN_VERSION_template_haskell(2,18,0)
parsePatternSequence :: String -> ParseResult (NonEmpty Pat)
parsePatternSequence :: String -> ParseResult (NonEmpty Pat)
parsePatternSequence String
s = ParseResult Pat -> ParseResult (NonEmpty Pat)
go (forall a. ToPat a => a -> Pat
toPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ParseResult (Pat SrcSpanInfo)
parsePat (Char
'(' forall a. a -> [a] -> [a]
: String
s forall a. [a] -> [a] -> [a]
++ String
")"))
  where
    go :: ParseResult Pat -> ParseResult (NonEmpty Pat)
go (ParseOk (ConP Name
n [] [])) | Name
n forall a. Eq a => a -> a -> Bool
== '() = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no patterns specified"
    go (ParseOk (ParensP Pat
p)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat
p forall a. a -> [a] -> NonEmpty a
:| [])
    go (ParseOk (TupP [])) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no patterns specified"
    go (ParseOk (TupP (Pat
p : [Pat]
ps))) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat
p forall a. a -> [a] -> NonEmpty a
:| [Pat]
ps)
    go (ParseOk Pat
_) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not a sequence of patterns"
    go (ParseFailed SrcLoc
l String
m) = forall a. SrcLoc -> String -> ParseResult a
ParseFailed SrcLoc
l String
m
#else
parsePatternSequence :: String -> ParseResult (NonEmpty Pat)
parsePatternSequence s = go (toPat <$> parsePat ('(' : s ++ ")"))
  where
    go (ParseOk (ConP n [])) | n == '() = fail "no patterns specified"
    go (ParseOk (ParensP p)) = pure (p :| [])
    go (ParseOk (TupP [])) = fail "no patterns specified"
    go (ParseOk (TupP (p : ps))) = pure (p :| ps)
    go (ParseOk _) = fail "not a sequence of patterns"
    go (ParseFailed l m) = ParseFailed l m

#endif

liftFail :: MonadFail m => ParseResult a -> m a
liftFail :: forall (m :: * -> *) a. MonadFail m => ParseResult a -> m a
liftFail (ParseOk a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
liftFail (ParseFailed SrcLoc
_ String
s) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
s

failQ :: a -> Q b
failQ :: forall a b. a -> Q b
failQ = forall a b. a -> b -> a
const (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The QuasiQuoter can only work to generate code as pattern or expression.")

parseRange :: String -> ParseResult Range
parseRange :: String -> ParseResult Range
parseRange String
s = forall {f :: * -> *}. MonadFail f => ParseResult Exp -> f Range
go (forall a. ToExp a => a -> Exp
toExp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ParseResult (Exp SrcSpanInfo)
parseExp (Char
'[' forall a. a -> [a] -> [a]
: String
s forall a. [a] -> [a] -> [a]
++ String
"]"))
  where
    go :: ParseResult Exp -> f Range
go (ParseOk (ArithSeqE Range
r)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Range
r
    go ParseResult Exp
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not a range expression"

-- | Convert a 'Range' objects from the 'Language.Haskell.TH' module to a 'RangeObj' with 'Exp' as parameters.
rangeToRangeObj ::
  -- | The 'Range' object to convert.
  Range ->
  -- | The equivalent 'RangeObj' with the 'Exp'ressions as parameters.
  RangeObj Exp
rangeToRangeObj :: Range -> RangeObj Exp
rangeToRangeObj (FromR Exp
b) = forall a. a -> RangeObj a
FromRange Exp
b
rangeToRangeObj (FromThenR Exp
b Exp
s) = forall a. a -> a -> RangeObj a
FromThenRange Exp
b Exp
s
rangeToRangeObj (FromToR Exp
b Exp
e) = forall a. a -> a -> RangeObj a
FromToRange Exp
b Exp
e
rangeToRangeObj (FromThenToR Exp
b Exp
s Exp
e) = forall a. a -> a -> a -> RangeObj a
FromThenToRange Exp
b Exp
s Exp
e

-- | Convert a 'RangeObj' to the corresponding 'Exp'ression. This will all the appropriate 'RangeObj' data constructor with the parameters.
rangeObjToExp ::
  -- | A 'RangeObj' with 'Exp'ressions as parameters.
  RangeObj Exp ->
  -- | An 'Exp'ression that contains the data constructor applied to the parameters.
  Exp
rangeObjToExp :: RangeObj Exp -> Exp
rangeObjToExp (FromRange Exp
b) = Name -> Exp
ConE 'FromRange Exp -> Exp -> Exp
`AppE` Exp
b
rangeObjToExp (FromThenRange Exp
b Exp
s) = Name -> Exp
ConE 'FromThenRange Exp -> Exp -> Exp
`AppE` Exp
b Exp -> Exp -> Exp
`AppE` Exp
s
rangeObjToExp (FromToRange Exp
b Exp
e) = Name -> Exp
ConE 'FromToRange Exp -> Exp -> Exp
`AppE` Exp
b Exp -> Exp -> Exp
`AppE` Exp
e
rangeObjToExp (FromThenToRange Exp
b Exp
s Exp
e) = Name -> Exp
ConE 'FromThenToRange Exp -> Exp -> Exp
`AppE` Exp
b Exp -> Exp -> Exp
`AppE` Exp
s Exp -> Exp -> Exp
`AppE` Exp
e

-- | A quasquoter to specify multiple patterns that will succeed if any of the patterns match. All patterns should have the same set of variables and these should
-- have the same type, otherwise a variable would have two different types, and if a variable is absent in one of the patterns, the question is what to pass as value.
anypat ::
  -- | The quasiquoter that can be used as expression and pattern.
  QuasiQuoter
anypat :: QuasiQuoter
anypat = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter ((forall (m :: * -> *) a. MonadFail m => ParseResult a -> m a
liftFail forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *). MonadFail m => Bool -> NonEmpty Pat -> m Exp
unionCaseExp Bool
True) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseResult (NonEmpty Pat)
parsePatternSequence) ((forall (m :: * -> *) a. MonadFail m => ParseResult a -> m a
liftFail forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *). MonadFail m => Bool -> NonEmpty Pat -> m Pat
unionCaseFunc Bool
True) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseResult (NonEmpty Pat)
parsePatternSequence) forall a b. a -> Q b
failQ forall a b. a -> Q b
failQ

-- | A quasiquoter to specify multiple patterns that will succeed if any of these patterns match. Patterns don't have to have the same variable names but if a variable is shared over the
-- different patterns, it should have the same type. In case a variable name does not appear in all patterns, it will be passed as a 'Maybe' to the clause with 'Nothing' if a pattern matched
-- without that variable name, and a 'Just' if the (first) pattern that matched had such variable.
maypat ::
  -- | The quasiquoter that can be used as expression and pattern.
  QuasiQuoter
maypat :: QuasiQuoter
maypat = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter ((forall (m :: * -> *) a. MonadFail m => ParseResult a -> m a
liftFail forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *). MonadFail m => Bool -> NonEmpty Pat -> m Exp
unionCaseExp Bool
False) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseResult (NonEmpty Pat)
parsePatternSequence) ((forall (m :: * -> *) a. MonadFail m => ParseResult a -> m a
liftFail forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *). MonadFail m => Bool -> NonEmpty Pat -> m Pat
unionCaseFunc Bool
False) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseResult (NonEmpty Pat)
parsePatternSequence) forall a b. a -> Q b
failQ forall a b. a -> Q b
failQ

_rangeCheck :: Int -> Int -> Int -> Bool
_rangeCheck :: Int -> Int -> Int -> Bool
_rangeCheck Int
b Int
e Int
x = Int
b forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x forall a. Ord a => a -> a -> Bool
<= Int
e

_modCheck :: Int -> Int -> Int -> Bool
_modCheck :: Int -> Int -> Int -> Bool
_modCheck Int
b Int
t Int
x = (Int
x forall a. Num a => a -> a -> a
- Int
b) forall a. Integral a => a -> a -> a
`mod` (Int
t forall a. Num a => a -> a -> a
- Int
b) forall a. Eq a => a -> a -> Bool
== Int
0

-- | Check if the given value is in the given 'RangeObj'. This function has some caveats, especially with floating points or other 'Enum' instances
-- where 'fromEnum' and 'toEnum' are no bijections. For example for floating points, `12.5` and `12.2` both map on the same item, as a result, the enum
-- will fail to work properly.
inRange ::
  Enum a =>
  -- | The 'RangeObj' for which we check membership.
  RangeObj a ->
  -- | The element for which we check the membership.
  a ->
  -- 'True' if the element is an element of the 'RangeObj'; 'False' otherwise.
  Bool
inRange :: forall a. Enum a => RangeObj a -> a -> Bool
inRange RangeObj a
r = RangeObj Int -> Int -> Bool
go (forall a. Enum a => a -> Int
fromEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RangeObj a
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
  where
    go :: RangeObj Int -> Int -> Bool
go (FromRange Int
b) = (Int
b forall a. Ord a => a -> a -> Bool
<=)
    go (FromToRange Int
b Int
e) = Int -> Int -> Int -> Bool
_rangeCheck Int
b Int
e
    go (FromThenRange Int
b Int
t)
      | Ordering
EQ <- Ordering
cmp = (Int
b forall a. Eq a => a -> a -> Bool
==)
      | Ordering
LT <- Ordering
cmp = forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
_both (Int
b forall a. Ord a => a -> a -> Bool
<=) (Int -> Int -> Int -> Bool
_modCheck Int
b Int
t)
      | Bool
otherwise = forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
_both (Int
b forall a. Ord a => a -> a -> Bool
>=) (Int -> Int -> Int -> Bool
_modCheck Int
b Int
t)
      where
        cmp :: Ordering
cmp = forall a. Ord a => a -> a -> Ordering
compare Int
b Int
t
    go (FromThenToRange Int
b Int
t Int
e)
      | Ordering
EQ <- Ordering
cmp, Int
e forall a. Ord a => a -> a -> Bool
>= Int
b = (Int
b forall a. Eq a => a -> a -> Bool
==)
      | Ordering
LT <- Ordering
cmp, Int
e forall a. Ord a => a -> a -> Bool
>= Int
b = forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
_both (Int -> Int -> Int -> Bool
_rangeCheck Int
b Int
e) (Int -> Int -> Int -> Bool
_modCheck Int
b Int
t)
      | Ordering
GT <- Ordering
cmp, Int
e forall a. Ord a => a -> a -> Bool
<= Int
b = forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
_both (Int -> Int -> Int -> Bool
_rangeCheck Int
e Int
b) (Int -> Int -> Int -> Bool
_modCheck Int
b Int
t)
      | Bool
otherwise = forall a b. a -> b -> a
const Bool
False -- empty range
      where
        cmp :: Ordering
cmp = forall a. Ord a => a -> a -> Ordering
compare Int
b Int
t

_both :: (a -> Bool) -> (a -> Bool) -> a -> Bool
_both :: forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
_both a -> Bool
f a -> Bool
g a
x = a -> Bool
f a
x Bool -> Bool -> Bool
&& a -> Bool
g a
x

-- | A 'QuasiQuoter' to parse a range expression to a 'RangeObj'. In case the 'QuasiQuoter' is used for a pattern,
-- it compiles into a /view pattern/ that will work if the element is a member of the 'RangeObj'.
rangepat ::
  -- | The quasiquoter that can be used as expression and pattern.
  QuasiQuoter
rangepat :: QuasiQuoter
rangepat = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter (forall {m :: * -> *} {c}.
MonadFail m =>
(Exp -> c) -> String -> m c
parsefun forall a. a -> a
id) (forall {m :: * -> *} {c}.
MonadFail m =>
(Exp -> c) -> String -> m c
parsefun ((Exp -> Pat -> Pat
`ViewP` Name -> [Pat] -> Pat
conP 'True []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Exp
VarE 'inRange Exp -> Exp -> Exp
`AppE`))) forall a b. a -> Q b
failQ forall a b. a -> Q b
failQ
  where
    parsefun :: (Exp -> c) -> String -> m c
parsefun Exp -> c
pp = (forall (m :: * -> *) a. MonadFail m => ParseResult a -> m a
liftFail forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> c
pp forall b c a. (b -> c) -> (a -> b) -> a -> c
. RangeObj Exp -> Exp
rangeObjToExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> RangeObj Exp
rangeToRangeObj)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseResult Range
parseRange