{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TupleSections #-}
module Data.Pattern.Any
(
anypat,
maypat,
rangepat,
hashpat,
ϵ,
combineHashViewPats,
patVars,
patVars',
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, 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), newName)
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)
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
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)
pattern FromRange :: a -> RangeObj a
pattern $bFromRange :: forall a. a -> RangeObj a
$mFromRange :: forall {r} {a}. RangeObj a -> (a -> r) -> ((# #) -> r) -> r
FromRange b = RangeObj b Nothing Nothing
pattern FromThenRange :: a -> a -> RangeObj a
pattern $bFromThenRange :: forall a. a -> a -> RangeObj a
$mFromThenRange :: forall {r} {a}. RangeObj a -> (a -> a -> r) -> ((# #) -> r) -> r
FromThenRange b e = RangeObj b (Just e) Nothing
pattern FromToRange :: a -> a -> RangeObj a
pattern $bFromToRange :: forall a. a -> a -> RangeObj a
$mFromToRange :: forall {r} {a}. RangeObj a -> (a -> a -> r) -> ((# #) -> r) -> r
FromToRange b t = RangeObj b Nothing (Just t)
pattern FromThenToRange :: a -> a -> a -> RangeObj a
pattern $bFromThenToRange :: forall a. a -> a -> a -> RangeObj a
$mFromThenToRange :: forall {r} {a}.
RangeObj a -> (a -> a -> a -> r) -> ((# #) -> r) -> r
FromThenToRange b t e = RangeObj b (Just t) (Just e)
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'))
| forall a. Enum a => a -> Int
fromEnum a
b forall a. Ord a => a -> a -> Bool
<= 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 forall a. Ord a => a -> a -> Bool
>= Int
b = Maybe a
jt
| Ordering
LT <- Ordering
c, Int
b forall a. Ord a => a -> a -> Bool
< Int
e = forall a. a -> Maybe a
Just (forall a. Enum a => Int -> a
toEnum (Int
e forall a. Num a => a -> a -> a
- ((Int
e forall a. Num a => a -> a -> a
- Int
b) forall a. Integral a => a -> a -> a
`mod` Int
d)))
| Ordering
GT <- Ordering
c, Int
b forall a. Ord a => a -> a -> Bool
> Int
e = forall a. a -> Maybe a
Just (forall a. Enum a => Int -> a
toEnum (Int
e forall a. Num a => a -> a -> a
- ((Int
e forall a. Num a => a -> a -> a
- Int
b) forall a. Integral a => a -> a -> a
`mod` Int
d)))
where
c :: Ordering
c = forall a. Ord a => a -> a -> Ordering
compare Int
b Int
t
b :: Int
b = forall a. Enum a => a -> Int
fromEnum a
b'
t :: Int
t = forall a. Enum a => a -> Int
fromEnum a
t'
e :: Int
e = forall a. Enum a => a -> Int
fromEnum a
e'
d :: Int
d = Int
t forall a. Num a => a -> a -> a
- Int
b
rangeLastValue RangeObj a
_ = forall a. Maybe a
Nothing
rangeToList ::
Enum a =>
RangeObj a ->
[a]
rangeToList :: forall a. Enum a => RangeObj a -> [a]
rangeToList (RangeObj a
b Maybe a
Nothing Maybe a
Nothing) = forall a. Enum a => a -> [a]
enumFrom a
b
rangeToList (RangeObj a
b (Just a
t) Maybe a
Nothing) = forall a. Enum a => a -> a -> [a]
enumFromThen a
b a
t
rangeToList (RangeObj a
b Maybe a
Nothing (Just a
e)) = forall a. Enum a => a -> a -> [a]
enumFromTo a
b a
e
rangeToList (RangeObj a
b (Just a
t) (Just a
e)) = forall a. Enum a => a -> a -> a -> [a]
enumFromThenTo a
b a
t a
e
patVars' ::
Pat ->
[Name] ->
[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]
(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
patVars ::
Pat ->
[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
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
parsePatternSequence :: String -> ParseResult (NonEmpty Pat)
parsePatternSequence :: String -> ParseResult (NonEmpty Pat)
parsePatternSequence String
s = ParseMode -> String -> ParseResult (Pat SrcSpanInfo)
parsePatWithMode (ParseMode
defaultParseMode {extensions :: [Extension]
extensions = [KnownExtension -> Extension
EnableExtension KnownExtension
ViewPatterns]}) (Char
'(' forall a. a -> [a] -> [a]
: String
s forall a. [a] -> [a] -> [a]
++ String
")") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pat -> ParseResult (NonEmpty Pat)
_getPats forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
== '() = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no patterns specified"
_getPats (ParensP Pat
p) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat
p forall a. a -> [a] -> NonEmpty a
:| [])
_getPats (TupP []) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no patterns specified"
_getPats (TupP (Pat
p : [Pat]
ps)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat
p forall a. a -> [a] -> NonEmpty a
:| [Pat]
ps)
_getPats Pat
_ = 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) = 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"
rangeToRangeObj ::
Range ->
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
rangeObjToExp ::
RangeObj Exp ->
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
anypat ::
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
maypat ::
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
#if MIN_VERSION_template_haskell(2, 16, 0)
_makeTupleExpressions :: Name -> [Pat] -> Q ([Maybe Exp], [Pat])
_makeTupleExpressions :: Name -> [Pat] -> Q ([Maybe Exp], [Pat])
_makeTupleExpressions Name
hm = forall {f :: * -> *}.
MonadFail f =>
[Maybe Exp] -> [Pat] -> [Pat] -> f ([Maybe Exp], [Pat])
go [] [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
where
go :: [Maybe Exp] -> [Pat] -> [Pat] -> f ([Maybe Exp], [Pat])
go [Maybe Exp]
es [Pat]
ps [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Maybe Exp]
es, [Pat]
ps)
go [Maybe Exp]
es [Pat]
ps (ViewP Exp
e Pat
p : [Pat]
xs) = [Maybe Exp] -> [Pat] -> [Pat] -> f ([Maybe Exp], [Pat])
go (forall a. a -> Maybe a
Just (Name -> Exp
VarE 'Data.HashMap.Strict.lookup Exp -> Exp -> Exp
`AppE` Exp
e Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
hm) forall a. a -> [a] -> [a]
: [Maybe Exp]
es) (Name -> [Pat] -> Pat
conP 'Just [Pat
p] forall a. a -> [a] -> [a]
: [Pat]
ps) [Pat]
xs
go [Maybe Exp]
_ [Pat]
_ [Pat]
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"all items in the hashpat should look like view patterns."
#else
_makeTupleExpressions :: Name -> [Pat] -> Q ([Exp], [Pat])
_makeTupleExpressions hm = go [] [] . reverse
where
go es ps [] = pure (es, ps)
go es ps (ViewP e p : xs) = go (VarE 'Data.HashMap.Strict.lookup `AppE` e `AppE` VarE hm : es) (conP 'Just [p] : ps) xs
go _ _ _ = fail "all items in the hashpat should look like view patterns."
#endif
combineHashViewPats ::
NonEmpty Pat ->
Q Pat
combineHashViewPats :: NonEmpty Pat -> Q Pat
combineHashViewPats (ViewP Exp
e Pat
p :| []) = 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"hm"
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> Pat
TupP) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Pat -> Pat
ViewP forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
hm] forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Exp] -> Exp
TupE)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [Pat] -> Q ([Maybe Exp], [Pat])
_makeTupleExpressions Name
hm (Pat
x forall a. a -> [a] -> [a]
: [Pat]
xs)
hashpat :: QuasiQuoter
hashpat :: QuasiQuoter
hashpat = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter forall a b. a -> Q b
failQ ((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
>=> NonEmpty Pat -> Q Pat
combineHashViewPats) 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
rangeLength ::
Enum a =>
RangeObj a ->
Maybe Int
rangeLength :: forall a. Enum a => RangeObj a -> Maybe Int
rangeLength = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Ord a => a -> a -> a
max Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. Integral b => RangeObj b -> Maybe b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 forall a. Eq a => a -> a -> Bool
== b
t' = Maybe b
go'
| Bool
otherwise = forall a. a -> Maybe a
Just (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Integral a => a -> a -> a
div forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract b
b) Maybe b
t (b
e forall a. Num a => a -> a -> a
- b
b) forall a. Num a => a -> a -> a
+ b
1)
where
go' :: Maybe b
go'
| b
b forall a. Ord a => a -> a -> Bool
<= b
e = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just b
0
go RangeObj 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
rangeDirection ::
Ord a =>
RangeObj a ->
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
_) = 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 forall a. Ord a => a -> a -> Bool
<= a
n
inRange ::
Enum a =>
RangeObj a ->
a ->
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
rangeCheck :: RangeObj Int -> Ordering -> Int -> Bool
rangeCheck (RangeObj Int
b Maybe Int
_ Maybe Int
Nothing) = forall a. a -> a -> a -> Ordering -> a
_forOrdering (Int
b forall a. Ord a => a -> a -> Bool
<=) (Int
b forall a. Eq a => a -> a -> Bool
==) (Int
b forall a. Ord a => a -> a -> Bool
>=)
rangeCheck (RangeObj Int
b Maybe Int
_ (Just Int
e)) = forall a. a -> a -> a -> Ordering -> a
_forOrdering (Int -> Int -> Int -> Bool
_rangeCheck Int
b Int
e) (Int
b 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 forall a. Eq a => a -> a -> Bool
== Int
t, forall a. Ord a => a -> Maybe a -> Bool
_incCheck Int
b Maybe Int
e = RangeObj Int -> Ordering -> Int -> Bool
rangeCheck RangeObj Int
r (forall a. Ord a => RangeObj a -> Ordering
rangeDirection RangeObj Int
r)
| Int
b forall a. Eq a => a -> a -> Bool
== Int
t = forall a b. a -> b -> a
const Bool
False
| Bool
otherwise = forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
_both (RangeObj Int -> Ordering -> Int -> Bool
rangeCheck RangeObj Int
r (forall a. Ord a => RangeObj a -> Ordering
rangeDirection RangeObj Int
r)) (Int -> Int -> Int -> Bool
_modCheck Int
b Int
t)
(∈) ::
Enum a =>
a ->
RangeObj a ->
Bool
∈ :: forall a. Enum a => a -> RangeObj a -> Bool
(∈) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Enum a => RangeObj a -> a -> Bool
inRange
(∋) ::
Enum a =>
RangeObj a ->
a ->
Bool
∋ :: forall a. Enum a => 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
rangepat ::
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
ϵ ::
QuasiQuoter
ϵ :: QuasiQuoter
ϵ = QuasiQuoter
rangepat