module MatchSigs.Matching
( MatchedSigs(..)
) where
import Control.Monad.State.Strict
import Data.List
import GHC.Api
import MatchSigs.Matching.Env
import MatchSigs.Sig
type SigMatches = ( [Sig FreeVarIdx]
, String
, [Name]
)
newtype MatchedSigs =
MatchedSigs { MatchedSigs -> [SigMatches]
getMatchedSigs :: [SigMatches] }
instance Semigroup MatchedSigs where
<> :: MatchedSigs -> MatchedSigs -> MatchedSigs
(<>) = MatchedSigs -> MatchedSigs -> MatchedSigs
unionMatchedSigs
instance Monoid MatchedSigs where
mempty :: MatchedSigs
mempty = [SigMatches] -> MatchedSigs
MatchedSigs forall a. Monoid a => a
mempty
unionMatchedSigs :: MatchedSigs -> MatchedSigs -> MatchedSigs
unionMatchedSigs :: MatchedSigs -> MatchedSigs -> MatchedSigs
unionMatchedSigs (MatchedSigs [SigMatches]
a) (MatchedSigs [SigMatches]
b)
= [SigMatches] -> MatchedSigs
MatchedSigs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++)
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {t :: * -> *}.
Foldable t =>
(t SigMatches, [SigMatches])
-> SigMatches -> ([SigMatches], [SigMatches])
go ([SigMatches]
a, []) [SigMatches]
b
where
go :: (t SigMatches, [SigMatches])
-> SigMatches -> ([SigMatches], [SigMatches])
go (t SigMatches
aSigs, [SigMatches]
nonMatches) SigMatches
bSig
= let check :: ([SigMatches], Bool) -> SigMatches -> ([SigMatches], Bool)
check ([SigMatches]
ss, Bool
False) SigMatches
aSig
= case SigMatches -> SigMatches -> Maybe SigMatches
compatibleSigs SigMatches
aSig SigMatches
bSig of
Just SigMatches
s' -> (SigMatches
s' forall a. a -> [a] -> [a]
: [SigMatches]
ss, Bool
True)
Maybe SigMatches
Nothing -> (SigMatches
aSig forall a. a -> [a] -> [a]
: [SigMatches]
ss, Bool
False)
check ([SigMatches]
ss, Bool
True) SigMatches
aSig = (SigMatches
aSig forall a. a -> [a] -> [a]
: [SigMatches]
ss, Bool
True)
in case forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([SigMatches], Bool) -> SigMatches -> ([SigMatches], Bool)
check ([], Bool
False) t SigMatches
aSigs of
([SigMatches]
res, Bool
False) -> ([SigMatches]
res, SigMatches
bSig forall a. a -> [a] -> [a]
: [SigMatches]
nonMatches)
([SigMatches]
res, Bool
True) -> ([SigMatches]
res, [SigMatches]
nonMatches)
compatibleSigs :: SigMatches -> SigMatches -> Maybe SigMatches
compatibleSigs :: SigMatches -> SigMatches -> Maybe SigMatches
compatibleSigs ([Sig Int]
sigA, String
str, [Name]
namesA) ([Sig Int]
sigB, String
_, [Name]
namesB) =
if forall s a. State s a -> s -> a
evalState ([Sig Int] -> [Sig Int] -> State Env Bool
checkMatch [Sig Int]
sigA [Sig Int]
sigB) Env
initEnv
then forall a. a -> Maybe a
Just ([Sig Int]
sigA, String
str, [Name]
namesA forall a. [a] -> [a] -> [a]
++ [Name]
namesB)
else forall a. Maybe a
Nothing
checkMatch :: [Sig FreeVarIdx]
-> [Sig FreeVarIdx]
-> State Env Bool
checkMatch :: [Sig Int] -> [Sig Int] -> State Env Bool
checkMatch (VarCtx [Int]
va : [Sig Int]
restA) (VarCtx [Int]
vb : [Sig Int]
restB)
= [Int] -> [Int] -> State Env Bool
introVars [Int]
va [Int]
vb
forall env. State env Bool -> State env Bool -> State env Bool
/\ [Sig Int] -> [Sig Int] -> State Env Bool
checkMatch [Sig Int]
restA [Sig Int]
restB
checkMatch (VarCtx [Int]
_ : [Sig Int]
_) [Sig Int]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
checkMatch [Sig Int]
_ (VarCtx [Int]
_ : [Sig Int]
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
checkMatch (Qual [Sig Int]
qa : [Sig Int]
restA) bs :: [Sig Int]
bs@(Qual [Sig Int]
_ : [Sig Int]
_) =
let ([Sig Int]
qualsB, [Sig Int]
restB) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span forall a. Sig a -> Bool
isQual [Sig Int]
bs
splits :: [([Sig Int], [Sig Int])]
splits = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [[a]]
inits [Sig Int]
qualsB) (forall a. [a] -> [[a]]
tails [Sig Int]
qualsB)
go :: ([Sig Int], [Sig Int]) -> State Env Bool
go ([Sig Int]
i, Qual [Sig Int]
f : [Sig Int]
rest)
= [Sig Int] -> [Sig Int] -> State Env Bool
checkMatch [Sig Int]
qa [Sig Int]
f
forall env. State env Bool -> State env Bool -> State env Bool
/\ [Sig Int] -> [Sig Int] -> State Env Bool
checkMatch [Sig Int]
restA ([Sig Int]
i forall a. [a] -> [a] -> [a]
++ [Sig Int]
rest forall a. [a] -> [a] -> [a]
++ [Sig Int]
restB)
go ([Sig Int], [Sig Int])
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
in forall env. [State env Bool] -> State env Bool
checkOr forall a b. (a -> b) -> a -> b
$ ([Sig Int], [Sig Int]) -> State Env Bool
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([Sig Int], [Sig Int])]
splits
checkMatch (Qual [Sig Int]
_ : [Sig Int]
_) [Sig Int]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
checkMatch [Sig Int]
_ (Qual [Sig Int]
_ : [Sig Int]
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
checkMatch [Sig Int]
sa [Sig Int]
sb = [Sig Int] -> [Sig Int] -> State Env Bool
checkResult [Sig Int]
sa [Sig Int]
sb
checkResult :: [Sig FreeVarIdx]
-> [Sig FreeVarIdx]
-> State Env Bool
checkResult :: [Sig Int] -> [Sig Int] -> State Env Bool
checkResult [Sig Int]
sa [Sig Int]
sb
| Sig Int
ra : [Sig Int]
restA <- forall a. [a] -> [a]
reverse [Sig Int]
sa
, Sig Int
rb : [Sig Int]
restB <- forall a. [a] -> [a]
reverse [Sig Int]
sb
= [Sig Int] -> [Sig Int] -> State Env Bool
checkArguments [Sig Int
ra] [Sig Int
rb]
forall env. State env Bool -> State env Bool -> State env Bool
/\ [Sig Int] -> [Sig Int] -> State Env Bool
checkArguments [Sig Int]
restA [Sig Int]
restB
checkResult [Sig Int]
_ [Sig Int]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
checkArguments :: [Sig FreeVarIdx]
-> [Sig FreeVarIdx]
-> State Env Bool
checkArguments :: [Sig Int] -> [Sig Int] -> State Env Bool
checkArguments [] [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
checkArguments (FreeVar Int
ai : [Sig Int]
restA) (FreeVar Int
bi : [Sig Int]
restB)
= Int -> Int -> State Env Bool
tryAssignVar Int
ai Int
bi
forall env. State env Bool -> State env Bool -> State env Bool
/\ [Sig Int] -> [Sig Int] -> State Env Bool
checkArguments [Sig Int]
restA [Sig Int]
restB
checkArguments (TyDescriptor ByteString
sa Maybe Name
na : [Sig Int]
restA) (TyDescriptor ByteString
sb Maybe Name
nb : [Sig Int]
restB)
| ByteString
sa forall a. Eq a => a -> a -> Bool
== ByteString
sb
, Maybe Name
na forall a. Eq a => a -> a -> Bool
== Maybe Name
nb
= [Sig Int] -> [Sig Int] -> State Env Bool
checkArguments [Sig Int]
restA [Sig Int]
restB
| Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
checkArguments (Arg [Sig Int]
aa : [Sig Int]
restA) [Sig Int]
sb =
let splits :: [([Sig Int], [Sig Int])]
splits = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [[a]]
inits [Sig Int]
sb) (forall a. [a] -> [[a]]
tails [Sig Int]
sb)
go :: ([Sig Int], [Sig Int]) -> State Env Bool
go ([Sig Int]
i, Arg [Sig Int]
ab : [Sig Int]
rest)
= [Sig Int] -> [Sig Int] -> State Env Bool
checkMatch [Sig Int]
aa [Sig Int]
ab
forall env. State env Bool -> State env Bool -> State env Bool
/\ [Sig Int] -> [Sig Int] -> State Env Bool
checkArguments [Sig Int]
restA ([Sig Int]
i forall a. [a] -> [a] -> [a]
++ [Sig Int]
rest)
go ([Sig Int], [Sig Int])
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
in forall env. [State env Bool] -> State env Bool
checkOr forall a b. (a -> b) -> a -> b
$ ([Sig Int], [Sig Int]) -> State Env Bool
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([Sig Int], [Sig Int])]
splits
checkArguments (Apply [Sig Int]
ca [[Sig Int]]
aa : [Sig Int]
restA) (Apply [Sig Int]
cb [[Sig Int]]
ab : [Sig Int]
restB)
| forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Sig Int]]
aa forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Sig Int]]
ab
= [Sig Int] -> [Sig Int] -> State Env Bool
checkMatch [Sig Int]
ca [Sig Int]
cb
forall env. State env Bool -> State env Bool -> State env Bool
/\ [State Env Bool] -> State Env Bool
checkAnd (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Sig Int] -> [Sig Int] -> State Env Bool
checkMatch [[Sig Int]]
aa [[Sig Int]]
ab)
forall env. State env Bool -> State env Bool -> State env Bool
/\ [Sig Int] -> [Sig Int] -> State Env Bool
checkArguments [Sig Int]
restA [Sig Int]
restB
| Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
checkArguments (Tuple [] : [Sig Int]
restA) (Tuple [] : [Sig Int]
restB)
= [Sig Int] -> [Sig Int] -> State Env Bool
checkArguments [Sig Int]
restA [Sig Int]
restB
checkArguments (Tuple ([Sig Int]
a : [[Sig Int]]
as) : [Sig Int]
restA) (Tuple [[Sig Int]]
bs : [Sig Int]
restB)
| forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Sig Int]]
as forall a. Num a => a -> a -> a
+ Int
1 forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Sig Int]]
bs
, let splits :: [([[Sig Int]], [[Sig Int]])]
splits = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [[a]]
inits [[Sig Int]]
bs) (forall a. [a] -> [[a]]
tails [[Sig Int]]
bs)
go :: ([[Sig Int]], [[Sig Int]]) -> State Env Bool
go ([[Sig Int]]
i, [Sig Int]
b : [[Sig Int]]
rest)
= [Sig Int] -> [Sig Int] -> State Env Bool
checkMatch [Sig Int]
a [Sig Int]
b
forall env. State env Bool -> State env Bool -> State env Bool
/\ [Sig Int] -> [Sig Int] -> State Env Bool
checkArguments [forall varIx. [[Sig varIx]] -> Sig varIx
Tuple [[Sig Int]]
as] [forall varIx. [[Sig varIx]] -> Sig varIx
Tuple forall a b. (a -> b) -> a -> b
$ [[Sig Int]]
i forall a. [a] -> [a] -> [a]
++ [[Sig Int]]
rest]
forall env. State env Bool -> State env Bool -> State env Bool
/\ [Sig Int] -> [Sig Int] -> State Env Bool
checkArguments [Sig Int]
restA [Sig Int]
restB
go ([[Sig Int]], [[Sig Int]])
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
= forall env. [State env Bool] -> State env Bool
checkOr forall a b. (a -> b) -> a -> b
$ ([[Sig Int]], [[Sig Int]]) -> State Env Bool
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([[Sig Int]], [[Sig Int]])]
splits
| Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
checkArguments (KindSig [Sig Int]
ta [Sig Int]
ka : [Sig Int]
restA) (KindSig [Sig Int]
tb [Sig Int]
kb : [Sig Int]
restB)
= [Sig Int] -> [Sig Int] -> State Env Bool
checkMatch [Sig Int]
ta [Sig Int]
tb
forall env. State env Bool -> State env Bool -> State env Bool
/\ [Sig Int] -> [Sig Int] -> State Env Bool
checkMatch [Sig Int]
ka [Sig Int]
kb
forall env. State env Bool -> State env Bool -> State env Bool
/\ [Sig Int] -> [Sig Int] -> State Env Bool
checkArguments [Sig Int]
restA [Sig Int]
restB
checkArguments [Sig Int]
_ [Sig Int]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False