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] -- Sig shared by these 'Name's
                  , String -- rendered sig
                  , [Name] -- Names that share this signature
                  )

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

-- | Create the union of two 'MatchedSigs' by checking if there a match in one
-- group for each sig in the other.
-- This is O(n^2) since there is no suitable ordering for sigs due to different
-- potential ordering of free vars.
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]
(++)
  -- fold compatible sigs from b in a, append the ones that are not compatible
  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)

-- | Combines the names in two 'SigMatches' if the sigs match
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

-- | Check that two sigs are isomorphic
-- First step is to check that the contexts match.
checkMatch :: [Sig FreeVarIdx]
           -> [Sig FreeVarIdx]
           -> State Env Bool
-- VarCtx and Qual are both expected to occur at the front of the list
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

-- Appearance order of quals not significant
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

-- | Extract the result types and make sure they match before going any further.
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

-- | After the result type has been removed, check the argument types.
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

-- this is where we need to check for a failure and rotate the list
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