{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternSynonyms #-}
{-# 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,
    hashpat,
    ϵ,

    -- * compile hash patterns
    combineHashViewPats,

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

    -- * Range objects
    RangeObj (RangeObj, rangeBegin, rangeThen, rangeEnd),
    pattern FromRange,
    pattern FromThenRange,
    pattern FromToRange,
    pattern FromThenToRange,
    rangeToList,
    inRange,
    (∈),
    (∋),
    rangeLength,
    rangeDirection,
    rangeLastValue,
  )
where

import Control.Arrow (first)
import Control.Monad ((>=>))
# if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif
import Data.HashMap.Strict (lookup)
import Data.List (sort)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Language.Haskell.Exts.Extension (Extension (EnableExtension), KnownExtension (ViewPatterns))
import Language.Haskell.Exts.Parser (ParseMode (extensions), ParseResult (ParseFailed, ParseOk), defaultParseMode, parseExp, parsePatWithMode)
import Language.Haskell.Meta (toExp, toPat)
import Language.Haskell.TH (Body (NormalB), Exp (AppE, ArithSeqE, ConE, LamCaseE, LamE, LitE, TupE, VarE), Lit (StringL), 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), nameBase, newName)
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))

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

-- | A 'RangeObj' that specifies a range with a start value and optionally a step value and end value.
data RangeObj a = RangeObj {forall a. RangeObj a -> a
rangeBegin :: a, forall a. RangeObj a -> Maybe a
rangeThen :: Maybe a, forall a. RangeObj a -> Maybe a
rangeEnd :: Maybe a}
  deriving (RangeObj a -> RangeObj a -> Bool
(RangeObj a -> RangeObj a -> Bool)
-> (RangeObj a -> RangeObj a -> Bool) -> Eq (RangeObj a)
forall a. Eq a => RangeObj a -> RangeObj a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: RangeObj a -> RangeObj a -> Bool
Eq, (forall a b. (a -> b) -> RangeObj a -> RangeObj b)
-> (forall a b. a -> RangeObj b -> RangeObj a) -> Functor RangeObj
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
$cfmap :: forall a b. (a -> b) -> RangeObj a -> RangeObj b
fmap :: forall a b. (a -> b) -> RangeObj a -> RangeObj b
$c<$ :: forall a b. a -> RangeObj b -> RangeObj a
<$ :: forall a b. a -> RangeObj b -> RangeObj a
Functor, ReadPrec [RangeObj a]
ReadPrec (RangeObj a)
Int -> ReadS (RangeObj a)
ReadS [RangeObj a]
(Int -> ReadS (RangeObj a))
-> ReadS [RangeObj a]
-> ReadPrec (RangeObj a)
-> ReadPrec [RangeObj a]
-> Read (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
$creadsPrec :: forall a. Read a => Int -> ReadS (RangeObj a)
readsPrec :: Int -> ReadS (RangeObj a)
$creadList :: forall a. Read a => ReadS [RangeObj a]
readList :: ReadS [RangeObj a]
$creadPrec :: forall a. Read a => ReadPrec (RangeObj a)
readPrec :: ReadPrec (RangeObj a)
$creadListPrec :: forall a. Read a => ReadPrec [RangeObj a]
readListPrec :: ReadPrec [RangeObj a]
Read, Int -> RangeObj a -> ShowS
[RangeObj a] -> ShowS
RangeObj a -> String
(Int -> RangeObj a -> ShowS)
-> (RangeObj a -> String)
-> ([RangeObj a] -> ShowS)
-> Show (RangeObj a)
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
$cshowsPrec :: forall a. Show a => Int -> RangeObj a -> ShowS
showsPrec :: Int -> RangeObj a -> ShowS
$cshow :: forall a. Show a => RangeObj a -> String
show :: RangeObj a -> String
$cshowList :: forall a. Show a => [RangeObj a] -> ShowS
showList :: [RangeObj a] -> ShowS
Show)

-- | A 'RangeObj' object that only has a start value, in Haskell specified as @[b ..]@.
pattern FromRange :: a -> RangeObj a
pattern $mFromRange :: forall {r} {a}. RangeObj a -> (a -> r) -> ((# #) -> r) -> r
$bFromRange :: forall a. a -> RangeObj a
FromRange b = RangeObj b Nothing Nothing

-- | A 'RangeObj' object that has a start value and end value, in Haskell specified as @[b .. e]@.
pattern FromThenRange :: a -> a -> RangeObj a
pattern $mFromThenRange :: forall {r} {a}. RangeObj a -> (a -> a -> r) -> ((# #) -> r) -> r
$bFromThenRange :: forall a. a -> a -> RangeObj a
FromThenRange b e = RangeObj b (Just e) Nothing

-- | A 'RangeObj' object with a start and next value, in Haskell specified as @[b, s ..]@.
pattern FromToRange :: a -> a -> RangeObj a
pattern $mFromToRange :: forall {r} {a}. RangeObj a -> (a -> a -> r) -> ((# #) -> r) -> r
$bFromToRange :: forall a. a -> a -> RangeObj a
FromToRange b t = RangeObj b Nothing (Just t)

-- | A 'RangeObj' object with a start, next value and end value, in Haskell specified as @[b, s .. e]@.
pattern FromThenToRange :: a -> a -> a -> RangeObj a
pattern $mFromThenToRange :: forall {r} {a}.
RangeObj a -> (a -> a -> a -> r) -> ((# #) -> r) -> r
$bFromThenToRange :: forall a. a -> a -> a -> RangeObj a
FromThenToRange b t e = RangeObj b (Just t) (Just e)

-- | Determine the last value of a 'RangeObj', given the 'RangeObj' has an /explicit/ end value.
-- The last value is /not/ per se the end value. For example for @[0, 3 .. 10]@, the last value will
-- be @9@. If the 'RangeObj' is empty, or has no (explicit) end value, 'Nothing' is returned.
rangeLastValue :: Enum a => RangeObj a -> Maybe a
rangeLastValue :: forall a. Enum a => RangeObj a -> Maybe a
rangeLastValue (RangeObj a
b Maybe a
Nothing e :: Maybe a
e@(Just a
e'))
  | a -> Int
forall a. Enum a => a -> Int
fromEnum a
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= a -> Int
forall a. Enum a => a -> Int
fromEnum a
e' = Maybe a
e
rangeLastValue (RangeObj a
b' jt :: Maybe a
jt@(Just a
t') (Just a
e'))
  | Ordering
EQ <- Ordering
c, Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
b = Maybe a
jt -- we reuse the item in the 'RangeObj' to save memory
  | Ordering
LT <- Ordering
c, Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
e = a -> Maybe a
forall a. a -> Maybe a
Just (Int -> a
forall a. Enum a => Int -> a
toEnum (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- ((Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
d)))
  | Ordering
GT <- Ordering
c, Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
e = a -> Maybe a
forall a. a -> Maybe a
Just (Int -> a
forall a. Enum a => Int -> a
toEnum (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- ((Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
d)))
  where
    c :: Ordering
c = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
b Int
t
    b :: Int
b = a -> Int
forall a. Enum a => a -> Int
fromEnum a
b'
    t :: Int
t = a -> Int
forall a. Enum a => a -> Int
fromEnum a
t'
    e :: Int
e = a -> Int
forall a. Enum a => a -> Int
fromEnum a
e'
    d :: Int
d = Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b
rangeLastValue RangeObj a
_ = Maybe a
forall a. Maybe a
Nothing

-- | 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 (RangeObj a
b Maybe a
Nothing Maybe a
Nothing) = a -> [a]
forall a. Enum a => a -> [a]
enumFrom a
b
rangeToList (RangeObj a
b (Just a
t) Maybe a
Nothing) = a -> a -> [a]
forall a. Enum a => a -> a -> [a]
enumFromThen a
b a
t
rangeToList (RangeObj a
b Maybe a
Nothing (Just a
e)) = a -> a -> [a]
forall a. Enum a => a -> a -> [a]
enumFromTo a
b a
e
rangeToList (RangeObj a
b (Just a
t) (Just a
e)) = a -> a -> a -> [a]
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
_) = [Name] -> [Name]
forall a. a -> a
id
patVars' (VarP Name
n) = (Name
n Name -> [Name] -> [Name]
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₁ ([Name] -> [Name]) -> ([Name] -> [Name]) -> [Name] -> [Name]
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₁ ([Name] -> [Name]) -> ([Name] -> [Name]) -> [Name] -> [Name]
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 Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:) ([Name] -> [Name]) -> ([Name] -> [Name]) -> [Name] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> [Name] -> [Name]
patVars' Pat
p
patVars' Pat
WildP = [Name] -> [Name]
forall a. a -> a
id
patVars' (RecP Name
_ [FieldPat]
ps) = [Pat] -> [Name] -> [Name]
patVarsF ((FieldPat -> Pat) -> [FieldPat] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map FieldPat -> Pat
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
_ = [Name] -> [Name]
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 = (Pat -> ([Name] -> [Name]) -> [Name] -> [Name])
-> ([Name] -> [Name]) -> [Pat] -> [Name] -> [Name]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([Name] -> [Name]) -> ([Name] -> [Name]) -> [Name] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (([Name] -> [Name]) -> ([Name] -> [Name]) -> [Name] -> [Name])
-> (Pat -> [Name] -> [Name])
-> Pat
-> ([Name] -> [Name])
-> [Name]
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> [Name] -> [Name]
patVars') [Name] -> [Name]
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 = String -> HowPass
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 = (Pat -> [Name]) -> [Pat] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> [Name]
go [Pat]
xs
    go :: Pat -> [Name]
go = [Name] -> [Name]
forall a. Ord a => [a] -> [a]
sort ([Name] -> [Name]) -> (Pat -> [Name]) -> Pat -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> [Name]
patVars
    go' :: [a] -> [(Bool, a)]
go' = (a -> (Bool, a)) -> [a] -> [(Bool, a)]
forall a b. (a -> b) -> [a] -> [b]
map (Bool
True,)
    un :: [(Bool, Name)]
un = ([Name] -> [(Bool, Name)] -> [(Bool, Name)])
-> [(Bool, Name)] -> [[Name]] -> [(Bool, Name)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool
-> Bool
-> (Bool -> Bool -> Bool)
-> [(Bool, Name)]
-> [(Bool, Name)]
-> [(Bool, Name)]
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
(&&) ([(Bool, Name)] -> [(Bool, Name)] -> [(Bool, Name)])
-> ([Name] -> [(Bool, Name)])
-> [Name]
-> [(Bool, Name)]
-> [(Bool, Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> [(Bool, Name)]
forall {a}. [a] -> [(Bool, a)]
go') ([Name] -> [(Bool, Name)]
forall {a}. [a] -> [(Bool, a)]
go' [Name]
n0) [[Name]]
ns
    un' :: [[(HowPass, Name)]]
un' = ([Name] -> [(HowPass, Name)]) -> [[Name]] -> [[(HowPass, Name)]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool
-> Bool
-> (Bool -> Bool -> HowPass)
-> [(Bool, Name)]
-> [(Bool, Name)]
-> [(HowPass, Name)]
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 ([(Bool, Name)] -> [(HowPass, Name)])
-> ([Name] -> [(Bool, Name)]) -> [Name] -> [(HowPass, Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> (Bool, Name)) -> [Name] -> [(Bool, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (Bool
True,)) ([Name]
n0 [Name] -> [[Name]] -> [[Name]]
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, (Pat -> Pat) -> Bool -> Pat -> Pat
forall a. (a -> a) -> Bool -> a -> a
wrapIt (Name -> [Pat] -> Pat
conP 'Just ([Pat] -> Pat) -> (Pat -> [Pat]) -> Pat -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> [Pat]
forall a. a -> [a]
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, (Pat -> Pat) -> Bool -> Pat -> Pat
forall a. (a -> a) -> Bool -> a -> a
wrapIt (Name -> [Pat] -> Pat
conP 'Just ([Pat] -> Pat) -> (Pat -> [Pat]) -> Pat -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> [Pat]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Bool
b ([Pat] -> Pat
TupP ((Name -> Pat) -> [Name] -> [Pat]
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 = Exp -> Name -> Exp
forall a b. a -> b -> a
const (Name -> Exp
ConE 'Nothing)
transName' HowPass
AsJust = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Just) (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE

transName :: (HowPass, Name) -> Exp
transName :: (HowPass, Name) -> Exp
transName = (HowPass -> Name -> Exp) -> (HowPass, Name) -> Exp
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 = Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp)
-> ((HowPass, Name) -> Exp) -> (HowPass, Name) -> Maybe Exp
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 = a -> a
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] = (Exp -> Exp) -> Bool -> Exp -> Exp
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 = (Exp -> Exp) -> Bool -> Exp -> Exp
forall a. (a -> a) -> Bool -> a -> a
wrapIt (Name -> Exp
ConE 'Just Exp -> Exp -> Exp
`AppE`) Bool
b ([Maybe Exp] -> Exp
TupE (((HowPass, Name) -> Maybe Exp) -> [(HowPass, Name)] -> [Maybe Exp]
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 ((Pat -> [(HowPass, Name)] -> Match)
-> [Pat] -> [[(HowPass, Name)]] -> [Match]
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' [Match] -> [Match] -> [Match]
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 Pat -> [Pat] -> Bool
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 = [(b, a)] -> [(c, a)] -> [(d, a)]
forall {b}. Ord b => [(b, b)] -> [(c, b)] -> [(d, b)]
go
  where
    go :: [(b, b)] -> [(c, b)] -> [(d, b)]
go [] [(c, b)]
ys = ((c, b) -> (d, b)) -> [(c, b)] -> [(d, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((c -> d) -> (c, b) -> (d, b)
forall b c d. (b -> c) -> (b, d) -> (c, d)
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 b -> b -> Ordering
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) (d, b) -> [(d, b)] -> [(d, b)]
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) (d, b) -> [(d, b)] -> [(d, b)]
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) (d, b) -> [(d, b)] -> [(d, b)]
forall a. a -> [a] -> [a]
: [(b, b)] -> [(c, b)] -> [(d, b)]
go [(b, b)]
xs [(c, b)]
ya
    go [(b, b)]
xs [] = ((b, b) -> (d, b)) -> [(b, b)] -> [(d, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> d) -> (b, b) -> (d, b)
forall b c d. (b -> c) -> (b, d) -> (c, d)
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
|| ((Bool, Name) -> Bool) -> [(Bool, Name)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, Name) -> Bool
forall a b. (a, b) -> a
fst [(Bool, Name)]
ns = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Exp, Pat) -> a
f ([Pat] -> [Name] -> [[(HowPass, Name)]] -> (Exp, Pat)
unionCaseFunc' (Pat
p0 Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
: [Pat]
ps') (((Bool, Name) -> Name) -> [(Bool, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Name) -> Name
forall a b. (a, b) -> b
snd [(Bool, Name)]
ns) [[(HowPass, Name)]]
ns'))
  | Bool
otherwise = String -> m a
forall a. String -> m a
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 = ((Exp, Pat) -> Pat) -> Bool -> NonEmpty Pat -> m Pat
forall (m :: * -> *) a.
MonadFail m =>
((Exp, Pat) -> a) -> Bool -> NonEmpty Pat -> m a
unionCaseFuncWith ((Exp -> Pat -> Pat) -> (Exp, Pat) -> Pat
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 = ((Exp, Pat) -> Exp) -> Bool -> NonEmpty Pat -> m Exp
forall (m :: * -> *) a.
MonadFail m =>
((Exp, Pat) -> a) -> Bool -> NonEmpty Pat -> m a
unionCaseFuncWith (Exp, Pat) -> Exp
forall a b. (a, b) -> a
fst

parsePatternSequence :: String -> ParseResult (NonEmpty Pat)
parsePatternSequence :: String -> ParseResult (NonEmpty Pat)
parsePatternSequence String
s = ParseMode -> String -> ParseResult (Pat SrcSpanInfo)
parsePatWithMode (ParseMode
defaultParseMode {extensions = [EnableExtension ViewPatterns]}) (Char
'(' Char -> ShowS
forall a. a -> [a] -> [a]
: String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")") ParseResult (Pat SrcSpanInfo)
-> (Pat SrcSpanInfo -> ParseResult (NonEmpty Pat))
-> ParseResult (NonEmpty Pat)
forall a b. ParseResult a -> (a -> ParseResult b) -> ParseResult b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pat -> ParseResult (NonEmpty Pat)
_getPats (Pat -> ParseResult (NonEmpty Pat))
-> (Pat SrcSpanInfo -> Pat)
-> Pat SrcSpanInfo
-> ParseResult (NonEmpty Pat)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat SrcSpanInfo -> Pat
forall a. ToPat a => a -> Pat
toPat

#if MIN_VERSION_template_haskell(2,18,0)
_getPats :: Pat -> ParseResult (NonEmpty Pat)
_getPats :: Pat -> ParseResult (NonEmpty Pat)
_getPats (ConP Name
n [] []) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== '() = String -> ParseResult (NonEmpty Pat)
forall a. String -> ParseResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no patterns specified"
_getPats (ParensP Pat
p) = NonEmpty Pat -> ParseResult (NonEmpty Pat)
forall a. a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat
p Pat -> [Pat] -> NonEmpty Pat
forall a. a -> [a] -> NonEmpty a
:| [])
_getPats (TupP []) = String -> ParseResult (NonEmpty Pat)
forall a. String -> ParseResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no patterns specified"
_getPats (TupP (Pat
p : [Pat]
ps)) = NonEmpty Pat -> ParseResult (NonEmpty Pat)
forall a. a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat
p Pat -> [Pat] -> NonEmpty Pat
forall a. a -> [a] -> NonEmpty a
:| [Pat]
ps)
_getPats Pat
_ = String -> ParseResult (NonEmpty Pat)
forall a. String -> ParseResult a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not a sequence of patterns"
#else
_getPats :: Pat -> ParseResult (NonEmpty Pat)
_getPats (ConP n []) | n == '() = fail "no patterns specified"
_getPats (ParensP p) = pure (p :| [])
_getPats (TupP []) = fail "no patterns specified"
_getPats (TupP (p : ps)) = pure (p :| ps)
_getPats _ = fail "not a sequence of patterns"
#endif

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

failQ :: a -> Q b
failQ :: forall a b. a -> Q b
failQ = Q b -> a -> Q b
forall a b. a -> b -> a
const (String -> Q b
forall a. String -> Q a
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 = ParseResult Exp -> ParseResult Range
forall {f :: * -> *}. MonadFail f => ParseResult Exp -> f Range
go (Exp SrcSpanInfo -> Exp
forall a. ToExp a => a -> Exp
toExp (Exp SrcSpanInfo -> Exp)
-> ParseResult (Exp SrcSpanInfo) -> ParseResult Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ParseResult (Exp SrcSpanInfo)
parseExp (Char
'[' Char -> ShowS
forall a. a -> [a] -> [a]
: String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"))
  where
    go :: ParseResult Exp -> f Range
go (ParseOk (ArithSeqE Range
r)) = Range -> f Range
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Range
r
    go ParseResult Exp
_ = String -> f Range
forall a. String -> f a
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) = Exp -> RangeObj Exp
forall a. a -> RangeObj a
FromRange Exp
b
rangeToRangeObj (FromThenR Exp
b Exp
s) = Exp -> Exp -> RangeObj Exp
forall a. a -> a -> RangeObj a
FromThenRange Exp
b Exp
s
rangeToRangeObj (FromToR Exp
b Exp
e) = Exp -> Exp -> RangeObj Exp
forall a. a -> a -> RangeObj a
FromToRange Exp
b Exp
e
rangeToRangeObj (FromThenToR Exp
b Exp
s Exp
e) = Exp -> Exp -> Exp -> RangeObj Exp
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 (RangeObj Exp
b Maybe Exp
t Maybe Exp
e) = Name -> Exp
ConE 'RangeObj Exp -> Exp -> Exp
`AppE` Exp
b Exp -> Exp -> Exp
`AppE` Maybe Exp -> Exp
go Maybe Exp
t Exp -> Exp -> Exp
`AppE` Maybe Exp -> Exp
go Maybe Exp
e
  where
    go :: Maybe Exp -> Exp
go (Just Exp
v) = Name -> Exp
ConE 'Just Exp -> Exp -> Exp
`AppE` Exp
v
    go Maybe Exp
Nothing = Name -> Exp
ConE 'Nothing

-- | 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.
--
-- __Examples__:
--
-- @
-- {-# LANGUAGE ViewPatterns, QuasiQuotes #-}
--
-- example :: (Bool, a, a) -> a
-- example [anypat|(False, a, _), (True, _, a)|] = a
-- @
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 ((ParseResult (NonEmpty Pat) -> Q (NonEmpty Pat)
forall (m :: * -> *) a. MonadFail m => ParseResult a -> m a
liftFail (ParseResult (NonEmpty Pat) -> Q (NonEmpty Pat))
-> (NonEmpty Pat -> Q Exp) -> ParseResult (NonEmpty Pat) -> Q Exp
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Bool -> NonEmpty Pat -> Q Exp
forall (m :: * -> *). MonadFail m => Bool -> NonEmpty Pat -> m Exp
unionCaseExp Bool
True) (ParseResult (NonEmpty Pat) -> Q Exp)
-> (String -> ParseResult (NonEmpty Pat)) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseResult (NonEmpty Pat)
parsePatternSequence) ((ParseResult (NonEmpty Pat) -> Q (NonEmpty Pat)
forall (m :: * -> *) a. MonadFail m => ParseResult a -> m a
liftFail (ParseResult (NonEmpty Pat) -> Q (NonEmpty Pat))
-> (NonEmpty Pat -> Q Pat) -> ParseResult (NonEmpty Pat) -> Q Pat
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Bool -> NonEmpty Pat -> Q Pat
forall (m :: * -> *). MonadFail m => Bool -> NonEmpty Pat -> m Pat
unionCaseFunc Bool
True) (ParseResult (NonEmpty Pat) -> Q Pat)
-> (String -> ParseResult (NonEmpty Pat)) -> String -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseResult (NonEmpty Pat)
parsePatternSequence) String -> Q Type
forall a b. a -> Q b
failQ String -> Q [Dec]
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.
--
-- __Examples__:
--
-- @
-- {-# LANGUAGE ViewPatterns, QuasiQuotes #-}
--
-- example :: (Bool, a) -> Maybe a
-- example [maypat|(True, a), _|] = a
-- @
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 ((ParseResult (NonEmpty Pat) -> Q (NonEmpty Pat)
forall (m :: * -> *) a. MonadFail m => ParseResult a -> m a
liftFail (ParseResult (NonEmpty Pat) -> Q (NonEmpty Pat))
-> (NonEmpty Pat -> Q Exp) -> ParseResult (NonEmpty Pat) -> Q Exp
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Bool -> NonEmpty Pat -> Q Exp
forall (m :: * -> *). MonadFail m => Bool -> NonEmpty Pat -> m Exp
unionCaseExp Bool
False) (ParseResult (NonEmpty Pat) -> Q Exp)
-> (String -> ParseResult (NonEmpty Pat)) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseResult (NonEmpty Pat)
parsePatternSequence) ((ParseResult (NonEmpty Pat) -> Q (NonEmpty Pat)
forall (m :: * -> *) a. MonadFail m => ParseResult a -> m a
liftFail (ParseResult (NonEmpty Pat) -> Q (NonEmpty Pat))
-> (NonEmpty Pat -> Q Pat) -> ParseResult (NonEmpty Pat) -> Q Pat
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Bool -> NonEmpty Pat -> Q Pat
forall (m :: * -> *). MonadFail m => Bool -> NonEmpty Pat -> m Pat
unionCaseFunc Bool
False) (ParseResult (NonEmpty Pat) -> Q Pat)
-> (String -> ParseResult (NonEmpty Pat)) -> String -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseResult (NonEmpty Pat)
parsePatternSequence) String -> Q Type
forall a b. a -> Q b
failQ String -> Q [Dec]
forall a b. a -> Q b
failQ

#if MIN_VERSION_template_haskell(2, 16, 0)
tupE :: [Exp] -> Exp
tupE :: [Exp] -> Exp
tupE = [Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> ([Exp] -> [Maybe Exp]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
#else
tupE :: [Exp] -> Exp
tupE = TupE
#endif

_makeTupleExpressions :: [Pat] -> Q ([Exp], [Pat])
_makeTupleExpressions :: [Pat] -> Q ([Exp], [Pat])
_makeTupleExpressions = [Exp] -> [Pat] -> [Pat] -> Q ([Exp], [Pat])
forall {f :: * -> *}.
MonadFail f =>
[Exp] -> [Pat] -> [Pat] -> f ([Exp], [Pat])
go [] [] ([Pat] -> Q ([Exp], [Pat]))
-> ([Pat] -> [Pat]) -> [Pat] -> Q ([Exp], [Pat])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> [Pat]
forall a. [a] -> [a]
reverse
  where
    go :: [Exp] -> [Pat] -> [Pat] -> f ([Exp], [Pat])
go [Exp]
es [Pat]
ps [] = ([Exp], [Pat]) -> f ([Exp], [Pat])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Exp]
es, [Pat]
ps)
    go [Exp]
es [Pat]
ps (p :: Pat
p@(VarP Name
n) : [Pat]
xs) = [Exp] -> [Pat] -> [Pat] -> f ([Exp], [Pat])
go [Exp]
es [Pat]
ps (Exp -> Pat -> Pat
ViewP (Lit -> Exp
LitE (String -> Lit
StringL (Name -> String
nameBase Name
n))) Pat
p Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
: [Pat]
xs)
    go [Exp]
es [Pat]
ps (ViewP Exp
e Pat
p : [Pat]
xs) = [Exp] -> [Pat] -> [Pat] -> f ([Exp], [Pat])
go (Name -> Exp
VarE 'Data.HashMap.Strict.lookup Exp -> Exp -> Exp
`AppE` Exp
e Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
es) (Name -> [Pat] -> Pat
conP 'Just [Pat
p] Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
: [Pat]
ps) [Pat]
xs
    go [Exp]
_ [Pat]
_ [Pat]
_ = String -> f ([Exp], [Pat])
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"all items in the hashpat should look like view patterns or simple variables."

-- | Create a view pattern that maps a HashMap with a locally scoped @hm@ parameter to a the patterns. It thus basically implicitly adds 'Data.HashMap.Strict.lookup'
-- to all expressions and matches these with the given patterns. The compilation fails if not all elements are view patterns.
combineHashViewPats ::
  -- | The non-empty list of view patterns that are compiled into a viw pattern.
  NonEmpty Pat ->
  -- | A 'Pat' that is a view pattern that will map a 'Data.HashMap.Strict.HashMap' to make lookups and matches these with the given patterns.
  Q Pat
combineHashViewPats :: NonEmpty Pat -> Q Pat
combineHashViewPats (ViewP Exp
e Pat
p :| []) = Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Pat -> Pat
ViewP (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Data.HashMap.Strict.lookup) Exp
e) (Name -> [Pat] -> Pat
conP 'Just [Pat
p]))
combineHashViewPats (Pat
x :| [Pat]
xs) = do
  Name
hm <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"hm"
  ([Exp] -> [Pat] -> Pat) -> ([Exp], [Pat]) -> Pat
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (((Pat -> Pat) -> ([Pat] -> Pat) -> [Pat] -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> Pat
TupP) ((Pat -> Pat) -> [Pat] -> Pat)
-> ([Exp] -> Pat -> Pat) -> [Exp] -> [Pat] -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Pat -> Pat
ViewP (Exp -> Pat -> Pat) -> ([Exp] -> Exp) -> [Exp] -> Pat -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
hm] (Exp -> Exp) -> ([Exp] -> Exp) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
tupE ([Exp] -> Exp) -> ([Exp] -> [Exp]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Exp) -> [Exp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
hm))) (([Exp], [Pat]) -> Pat) -> Q ([Exp], [Pat]) -> Q Pat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pat] -> Q ([Exp], [Pat])
_makeTupleExpressions (Pat
x Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
: [Pat]
xs)

-- | A quasiquoter to make 'Data.HashMap.Strict.HashMap' lookups more convenient. This can only be used as a pattern. It takes a sequence of
-- view patterns, where it will perform the lookup on the expression part of the view pattern, and match the /successful/ lookup with the pattern.
-- The `Just` part is thus not used in the pattern part to indicate a successful lookup. If a single variable is used, it will make a lookup with
-- a string literal with the same variable.
--
-- __Examples__:
--
-- @
-- {-# LANGUAGE ViewPatterns, QuasiQuotes #-}
--
-- sumab :: HashMap String Int -> Int
-- sumab [rangepat|"a" -> a, "b" -> b|] = a + b
-- sumab _ = 0
-- @
--
-- This will sum up the values for `"a"` and `"b"` in the 'Data.HashMap.Strict.HashMap', given these /both/ exist. Otherwise, it returns `0`.
--
-- @
-- {-# LANGUAGE ViewPatterns, QuasiQuotes #-}
--
-- sumab :: HashMap String Int -> Int
-- sumab [rangepat|a, b|] = a + b
-- sumab _ = 0
-- @
--
-- This will sum up the values for `"a"` and `"b"` in the 'Data.HashMap.Strict.HashMap', given these /both/ exist. Otherwise, it returns `0`.
hashpat :: QuasiQuoter
hashpat :: QuasiQuoter
hashpat = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter String -> Q Exp
forall a b. a -> Q b
failQ ((ParseResult (NonEmpty Pat) -> Q (NonEmpty Pat)
forall (m :: * -> *) a. MonadFail m => ParseResult a -> m a
liftFail (ParseResult (NonEmpty Pat) -> Q (NonEmpty Pat))
-> (NonEmpty Pat -> Q Pat) -> ParseResult (NonEmpty Pat) -> Q Pat
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> NonEmpty Pat -> Q Pat
combineHashViewPats) (ParseResult (NonEmpty Pat) -> Q Pat)
-> (String -> ParseResult (NonEmpty Pat)) -> String -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseResult (NonEmpty Pat)
parsePatternSequence) String -> Q Type
forall a b. a -> Q b
failQ String -> Q [Dec]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0

-- | Determine the number of items for a 'RangeObj', given that can be determined /easily/. This is only for ranges that
-- have an /end/ and where the next item is different from the previous (otherwise this generates an endless list).
rangeLength ::
  Enum a =>
  -- | The 'RangeObj' to determine the number of elements from.
  RangeObj a ->
  -- | The number of elements of the range object, given that can be determined easily; 'Nothing' otherwise.
  Maybe Int
rangeLength :: forall a. Enum a => RangeObj a -> Maybe Int
rangeLength = (Int -> Int) -> Maybe Int -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0) (Maybe Int -> Maybe Int)
-> (RangeObj a -> Maybe Int) -> RangeObj a -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RangeObj Int -> Maybe Int
forall {b}. Integral b => RangeObj b -> Maybe b
go (RangeObj Int -> Maybe Int)
-> (RangeObj a -> RangeObj Int) -> RangeObj a -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Int) -> RangeObj a -> RangeObj Int
forall a b. (a -> b) -> RangeObj a -> RangeObj b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Int
forall a. Enum a => a -> Int
fromEnum
  where
    go :: RangeObj b -> Maybe b
go (RangeObj b
b Maybe b
t (Just b
e))
      | Just b
t' <- Maybe b
t, b
b b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
t' = Maybe b
go'
      | Bool
otherwise = b -> Maybe b
forall a. a -> Maybe a
Just ((b -> b) -> (b -> b -> b) -> Maybe b -> b -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b -> b
forall a. a -> a
id ((b -> b -> b) -> b -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> b -> b
forall a. Integral a => a -> a -> a
div (b -> b -> b) -> (b -> b) -> b -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b -> b
forall a. Num a => a -> a -> a
subtract b
b) Maybe b
t (b
e b -> b -> b
forall a. Num a => a -> a -> a
- b
b) b -> b -> b
forall a. Num a => a -> a -> a
+ b
1)
      where
        go' :: Maybe b
go'
          | b
b b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= b
e = Maybe b
forall a. Maybe a
Nothing
          | Bool
otherwise = b -> Maybe b
forall a. a -> Maybe a
Just b
0
    go RangeObj b
_ = Maybe b
forall a. Maybe a
Nothing

_forOrdering :: a -> a -> a -> Ordering -> a
_forOrdering :: forall a. a -> a -> a -> Ordering -> a
_forOrdering a
lt a
eq a
gt = Ordering -> a
go
  where
    go :: Ordering -> a
go Ordering
LT = a
lt
    go Ordering
EQ = a
eq
    go Ordering
GT = a
gt

-- | Determine the direction of the range through an 'Ordering' object. For an increasing sequence, 'LT' is used, for a sequence that repeats the element, 'Eq' is returned,
-- and for a descreasing sequence 'GT' is used.
rangeDirection ::
  Ord a =>
  -- | The 'RangeObj' to determine the direction.
  RangeObj a ->
  -- | The direction of the 'RangeObj' as an 'Ordering' object.
  Ordering
rangeDirection :: forall a. Ord a => RangeObj a -> Ordering
rangeDirection (RangeObj a
_ Maybe a
Nothing Maybe a
_) = Ordering
LT
rangeDirection (RangeObj a
b (Just a
t) Maybe a
_) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
b a
t

_incCheck :: Ord a => a -> Maybe a -> Bool
_incCheck :: forall a. Ord a => a -> Maybe a -> Bool
_incCheck a
_ Maybe a
Nothing = Bool
True
_incCheck a
m (Just a
n) = a
m a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
n

-- | 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 (a -> Int
forall a. Enum a => a -> Int
fromEnum (a -> Int) -> RangeObj a -> RangeObj Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RangeObj a
r') (Int -> Bool) -> (a -> Int) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum
  where
    rangeCheck :: RangeObj Int -> Ordering -> Int -> Bool
rangeCheck (RangeObj Int
b Maybe Int
_ Maybe Int
Nothing) = (Int -> Bool)
-> (Int -> Bool) -> (Int -> Bool) -> Ordering -> Int -> Bool
forall a. a -> a -> a -> Ordering -> a
_forOrdering (Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=) (Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=)
    rangeCheck (RangeObj Int
b Maybe Int
_ (Just Int
e)) = (Int -> Bool)
-> (Int -> Bool) -> (Int -> Bool) -> Ordering -> Int -> Bool
forall a. a -> a -> a -> Ordering -> a
_forOrdering (Int -> Int -> Int -> Bool
_rangeCheck Int
b Int
e) (Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int -> Int -> Int -> Bool
_rangeCheck Int
e Int
b)
    go :: RangeObj Int -> Int -> Bool
go r :: RangeObj Int
r@(RangeObj Int
_ Maybe Int
Nothing Maybe Int
_) = RangeObj Int -> Ordering -> Int -> Bool
rangeCheck RangeObj Int
r Ordering
LT
    go r :: RangeObj Int
r@(RangeObj Int
b (Just Int
t) Maybe Int
e)
      | Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
t, Int -> Maybe Int -> Bool
forall a. Ord a => a -> Maybe a -> Bool
_incCheck Int
b Maybe Int
e = RangeObj Int -> Ordering -> Int -> Bool
rangeCheck RangeObj Int
r (RangeObj Int -> Ordering
forall a. Ord a => RangeObj a -> Ordering
rangeDirection RangeObj Int
r)
      | Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
t = Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False
      | Bool
otherwise = (Int -> Bool) -> (Int -> Bool) -> Int -> Bool
forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
_both (RangeObj Int -> Ordering -> Int -> Bool
rangeCheck RangeObj Int
r (RangeObj Int -> Ordering
forall a. Ord a => RangeObj a -> Ordering
rangeDirection RangeObj Int
r)) (Int -> Int -> Int -> Bool
_modCheck Int
b Int
t)

-- | Flipped alias of 'inRange' that checks if an element is in range of a given 'RangeObj'.
(∈) ::
  Enum a =>
  -- | The given element to check membership for.
  a ->
  -- | The 'RangeObj' object for which we check membership.
  RangeObj a ->
  -- | 'True' if the given element is an element of the given 'RangeObj' object; 'False' otherwise.
  Bool
∈ :: forall a. Enum a => a -> RangeObj a -> Bool
(∈) = (RangeObj a -> a -> Bool) -> a -> RangeObj a -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip RangeObj a -> a -> Bool
forall a. Enum a => RangeObj a -> a -> Bool
inRange

-- | Alias of 'inRange' that checks if an element is in range of a given 'RangeObj'.
(∋) ::
  Enum a =>
  -- | The 'RangeObj' object for which we check membership.
  RangeObj a ->
  -- | The given element to check membership for.
  a ->
  -- | 'True' if the given element is an element of the given 'RangeObj' object; 'False' otherwise.
  Bool
∋ :: forall a. Enum a => RangeObj a -> a -> Bool
(∋) = RangeObj a -> a -> Bool
forall a. Enum a => RangeObj a -> a -> Bool
inRange

_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'.
--
-- __Examples__:
--
-- @
-- {-# LANGUAGE ViewPatterns, QuasiQuotes #-}
--
-- positiveEven :: Int -> Bool
-- positiveEven [rangepat|0, 2 ..|] = True
-- positiveEven _ = False
-- @
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 ((Exp -> Exp) -> String -> Q Exp
forall {m :: * -> *} {c}.
MonadFail m =>
(Exp -> c) -> String -> m c
parsefun Exp -> Exp
forall a. a -> a
id) ((Exp -> Pat) -> String -> Q Pat
forall {m :: * -> *} {c}.
MonadFail m =>
(Exp -> c) -> String -> m c
parsefun ((Exp -> Pat -> Pat
`ViewP` Name -> [Pat] -> Pat
conP 'True []) (Exp -> Pat) -> (Exp -> Exp) -> Exp -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Exp
VarE 'inRange Exp -> Exp -> Exp
`AppE`))) String -> Q Type
forall a b. a -> Q b
failQ String -> Q [Dec]
forall a b. a -> Q b
failQ
  where
    parsefun :: (Exp -> c) -> String -> m c
parsefun Exp -> c
pp = (ParseResult Range -> m Range
forall (m :: * -> *) a. MonadFail m => ParseResult a -> m a
liftFail (ParseResult Range -> m Range)
-> (Range -> m c) -> ParseResult Range -> m c
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (c -> m c
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c -> m c) -> (Range -> c) -> Range -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> c
pp (Exp -> c) -> (Range -> Exp) -> Range -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RangeObj Exp -> Exp
rangeObjToExp (RangeObj Exp -> Exp) -> (Range -> RangeObj Exp) -> Range -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> RangeObj Exp
rangeToRangeObj)) (ParseResult Range -> m c)
-> (String -> ParseResult Range) -> String -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseResult Range
parseRange

-- | An alias of the 'rangepat' 'QuasiQuoter', this is used since it looks quite similar to @∊ [a .. b]@,
-- beware that the @ϵ@ in @[ϵ|a .. b|]@ is not an /element of/ character, but the /Greek lunate epsilon/ character
-- which only /looks/ similar. The reason we use an epsiolon is because this can be used as an identifier, whereas
-- the element of is an operator.
--
-- __Examples__:
--
-- @
-- {-# LANGUAGE ViewPatterns, QuasiQuotes #-}
--
-- positiveEven :: Int -> Bool
-- positiveEven [ϵ|2, 4 ..|] = True
-- positiveEven _ = False
-- @
ϵ ::
  -- | The quasiquoter that can be used as expression and pattern.
  QuasiQuoter
ϵ :: QuasiQuoter
ϵ = QuasiQuoter
rangepat