{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleContexts, ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module GHC.Util.Unify(
    Subst', fromSubst',
    validSubst', substitute',
    unifyExp'
    ) where

import Control.Monad
import Data.Generics.Uniplate.Operations
import Data.Char
import Data.List.Extra
import Data.Data
import Data.Tuple.Extra
import Util

import HsSyn
import SrcLoc as GHC
import Outputable hiding ((<>))
import RdrName
import OccName

import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import GHC.Util.Outputable
import GHC.Util.HsExpr
import GHC.Util.Pat
import GHC.Util.RdrName
import GHC.Util.View

isUnifyVar :: String -> Bool
isUnifyVar :: String -> Bool
isUnifyVar [x :: Char
x] = Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '?' Bool -> Bool -> Bool
|| Char -> Bool
isAlpha Char
x
isUnifyVar [] = Bool
False
isUnifyVar xs :: String
xs = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '?') String
xs

---------------------------------------------------------------------
-- SUBSTITUTION DATA TYPE

-- A list of substitutions. A key may be duplicated, you need to call
--  'check' to ensure the substitution is valid.
newtype Subst' a = Subst' [(String, a)]
    deriving (b -> Subst' a -> Subst' a
NonEmpty (Subst' a) -> Subst' a
Subst' a -> Subst' a -> Subst' a
(Subst' a -> Subst' a -> Subst' a)
-> (NonEmpty (Subst' a) -> Subst' a)
-> (forall b. Integral b => b -> Subst' a -> Subst' a)
-> Semigroup (Subst' a)
forall b. Integral b => b -> Subst' a -> Subst' a
forall a. NonEmpty (Subst' a) -> Subst' a
forall a. Subst' a -> Subst' a -> Subst' a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> Subst' a -> Subst' a
stimes :: b -> Subst' a -> Subst' a
$cstimes :: forall a b. Integral b => b -> Subst' a -> Subst' a
sconcat :: NonEmpty (Subst' a) -> Subst' a
$csconcat :: forall a. NonEmpty (Subst' a) -> Subst' a
<> :: Subst' a -> Subst' a -> Subst' a
$c<> :: forall a. Subst' a -> Subst' a -> Subst' a
Semigroup, Semigroup (Subst' a)
Subst' a
Semigroup (Subst' a) =>
Subst' a
-> (Subst' a -> Subst' a -> Subst' a)
-> ([Subst' a] -> Subst' a)
-> Monoid (Subst' a)
[Subst' a] -> Subst' a
Subst' a -> Subst' a -> Subst' a
forall a. Semigroup (Subst' a)
forall a. Subst' a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [Subst' a] -> Subst' a
forall a. Subst' a -> Subst' a -> Subst' a
mconcat :: [Subst' a] -> Subst' a
$cmconcat :: forall a. [Subst' a] -> Subst' a
mappend :: Subst' a -> Subst' a -> Subst' a
$cmappend :: forall a. Subst' a -> Subst' a -> Subst' a
mempty :: Subst' a
$cmempty :: forall a. Subst' a
$cp1Monoid :: forall a. Semigroup (Subst' a)
Monoid)

-- Unpack the substitution.
fromSubst' :: Subst' a -> [(String, a)]
fromSubst' :: Subst' a -> [(String, a)]
fromSubst' (Subst' xs :: [(String, a)]
xs) = [(String, a)]
xs

instance Functor Subst' where
    fmap :: (a -> b) -> Subst' a -> Subst' b
fmap f :: a -> b
f (Subst' xs :: [(String, a)]
xs) = [(String, b)] -> Subst' b
forall a. [(String, a)] -> Subst' a
Subst' ([(String, b)] -> Subst' b) -> [(String, b)] -> Subst' b
forall a b. (a -> b) -> a -> b
$ ((String, a) -> (String, b)) -> [(String, a)] -> [(String, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> (String, a) -> (String, b)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second a -> b
f) [(String, a)]
xs -- Interesting.

instance Outputable a => Show (Subst' a) where
    show :: Subst' a -> String
show (Subst' xs :: [(String, a)]
xs) = [String] -> String
unlines [String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ " = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Outputable a => a -> String
unsafePrettyPrint a
b | (a :: String
a,b :: a
b) <- [(String, a)]
xs]

-- Check the unification is valid and simplify it.
validSubst' :: (a -> a -> Bool) -> Subst' a -> Maybe (Subst' a)
validSubst' :: (a -> a -> Bool) -> Subst' a -> Maybe (Subst' a)
validSubst' eq :: a -> a -> Bool
eq = ([(String, a)] -> Subst' a)
-> Maybe [(String, a)] -> Maybe (Subst' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(String, a)] -> Subst' a
forall a. [(String, a)] -> Subst' a
Subst' (Maybe [(String, a)] -> Maybe (Subst' a))
-> (Subst' a -> Maybe [(String, a)])
-> Subst' a
-> Maybe (Subst' a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [a]) -> Maybe (String, a))
-> [(String, [a])] -> Maybe [(String, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, [a]) -> Maybe (String, a)
forall a. (a, [a]) -> Maybe (a, a)
f ([(String, [a])] -> Maybe [(String, a)])
-> (Subst' a -> [(String, [a])]) -> Subst' a -> Maybe [(String, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, a)] -> [(String, [a])]
forall k v. Ord k => [(k, v)] -> [(k, [v])]
groupSort ([(String, a)] -> [(String, [a])])
-> (Subst' a -> [(String, a)]) -> Subst' a -> [(String, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subst' a -> [(String, a)]
forall a. Subst' a -> [(String, a)]
fromSubst'
    where f :: (a, [a]) -> Maybe (a, a)
f (x :: a
x, y :: a
y : ys :: [a]
ys) | (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> Bool
eq a
y) [a]
ys = (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
x, a
y)
          f _ = Maybe (a, a)
forall a. Maybe a
Nothing

-- Peform a substition.
-- Returns (suggested replacement, refactor template), both with brackets added
-- as needed.
-- Example: (traverse foo (bar baz), traverse f (x))
substitute' :: Subst' (LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)
substitute' :: Subst' (LHsExpr GhcPs)
-> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)
substitute' (Subst' bind :: [(String, LHsExpr GhcPs)]
bind) = (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))
-> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)
transformBracketOld' LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
exp (LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs))
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> (LHsExpr GhcPs, LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LPat GhcPs -> LPat GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi LPat GhcPs -> LPat GhcPs
pat (LHsExpr GhcPs -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsType GhcPs -> LHsType GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi LHsType GhcPs -> LHsType GhcPs
typ
  where
    exp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
    -- Variables.
    exp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
exp (LL _ (HsVar _ x)) = String -> [(String, LHsExpr GhcPs)] -> Maybe (LHsExpr GhcPs)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Located RdrName -> String
rdrNameStr' Located RdrName
Located (IdP GhcPs)
x) [(String, LHsExpr GhcPs)]
bind
    -- Operator applications.
    exp (LL loc :: SrcSpan
loc (OpApp _ lhs (LL _ (HsVar _ x)) rhs))
      | Just y :: LHsExpr GhcPs
y <- String -> [(String, LHsExpr GhcPs)] -> Maybe (LHsExpr GhcPs)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Located RdrName -> String
rdrNameStr' Located RdrName
Located (IdP GhcPs)
x) [(String, LHsExpr GhcPs)]
bind = LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExt
XOpApp GhcPs
noExt LHsExpr GhcPs
lhs LHsExpr GhcPs
y LHsExpr GhcPs
rhs))
    -- Left sections.
    exp (LL loc :: SrcSpan
loc (SectionL _ exp (LL _ (HsVar _ x))))
      | Just y :: LHsExpr GhcPs
y <- String -> [(String, LHsExpr GhcPs)] -> Maybe (LHsExpr GhcPs)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Located RdrName -> String
rdrNameStr' Located RdrName
Located (IdP GhcPs)
x) [(String, LHsExpr GhcPs)]
bind = LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XSectionL GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL NoExt
XSectionL GhcPs
noExt LHsExpr GhcPs
exp LHsExpr GhcPs
y))
    -- Right sections.
    exp (LL loc :: SrcSpan
loc (SectionR _ (LL _ (HsVar _ x)) exp))
      | Just y :: LHsExpr GhcPs
y <- String -> [(String, LHsExpr GhcPs)] -> Maybe (LHsExpr GhcPs)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Located RdrName -> String
rdrNameStr' Located RdrName
Located (IdP GhcPs)
x) [(String, LHsExpr GhcPs)]
bind = LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XSectionR GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR NoExt
XSectionR GhcPs
noExt LHsExpr GhcPs
y LHsExpr GhcPs
exp))
    exp _ = Maybe (LHsExpr GhcPs)
forall a. Maybe a
Nothing

    pat :: LPat GhcPs -> LPat GhcPs
    -- Pattern variables.
    pat :: LPat GhcPs -> LPat GhcPs
pat (LL _ (VarPat _ x))
      | Just y :: LHsExpr GhcPs
y@(LL _ HsVar{}) <- String -> [(String, LHsExpr GhcPs)] -> Maybe (LHsExpr GhcPs)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Located RdrName -> String
rdrNameStr' Located RdrName
Located (IdP GhcPs)
x) [(String, LHsExpr GhcPs)]
bind = String -> LPat GhcPs
strToPat' (LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
y)
    pat x :: LPat GhcPs
x = LPat GhcPs
x :: LPat GhcPs

    typ :: LHsType GhcPs -> LHsType GhcPs
    -- Type variables.
    typ :: LHsType GhcPs -> LHsType GhcPs
typ (LL _ (HsTyVar _ _ x))
      | Just (LL _ (HsAppType _ _ (HsWC _ y))) <- String -> [(String, LHsExpr GhcPs)] -> Maybe (LHsExpr GhcPs)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Located RdrName -> String
rdrNameStr' Located RdrName
Located (IdP GhcPs)
x) [(String, LHsExpr GhcPs)]
bind = LHsType GhcPs
LHsType (NoGhcTc GhcPs)
y
    typ x :: LHsType GhcPs
x = LHsType GhcPs
x :: LHsType GhcPs


---------------------------------------------------------------------
-- UNIFICATION

type NameMatch' = Located RdrName -> Located RdrName -> Bool

-- | Unification, obeys the property that if @unify a b = s@, then
-- @substitute s a = b@.
unify' :: Data a => NameMatch' -> Bool -> a -> a -> Maybe (Subst' (LHsExpr GhcPs))
unify' :: NameMatch' -> Bool -> a -> a -> Maybe (Subst' (LHsExpr GhcPs))
unify' nm :: NameMatch'
nm root :: Bool
root x :: a
x y :: a
y
    | Just (x :: LHsExpr GhcPs
x, y :: LHsExpr GhcPs
y) <- (a, a) -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (a
x, a
y) = NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
root LHsExpr GhcPs
x LHsExpr GhcPs
y
    | Just (x :: LPat GhcPs
x, y :: LPat GhcPs
y) <- (a, a) -> Maybe (LPat GhcPs, LPat GhcPs)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (a
x, a
y) = NameMatch'
-> LPat GhcPs -> LPat GhcPs -> Maybe (Subst' (LHsExpr GhcPs))
unifyPat' NameMatch'
nm LPat GhcPs
x LPat GhcPs
y
    | Just (x :: LHsType GhcPs
x, y :: LHsType GhcPs
y) <- (a, a) -> Maybe (LHsType GhcPs, LHsType GhcPs)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (a
x, a
y) = NameMatch'
-> LHsType GhcPs -> LHsType GhcPs -> Maybe (Subst' (LHsExpr GhcPs))
unifyType' NameMatch'
nm LHsType GhcPs
x LHsType GhcPs
y
    | Just (SrcSpan
x :: GHC.SrcSpan) <- a -> Maybe SrcSpan
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs))
forall a. a -> Maybe a
Just Subst' (LHsExpr GhcPs)
forall a. Monoid a => a
mempty
    | Bool
otherwise = NameMatch' -> a -> a -> Maybe (Subst' (LHsExpr GhcPs))
forall a.
Data a =>
NameMatch' -> a -> a -> Maybe (Subst' (LHsExpr GhcPs))
unifyDef' NameMatch'
nm a
x a
y

unifyDef' :: Data a => NameMatch' -> a -> a -> Maybe (Subst' (LHsExpr GhcPs))
unifyDef' :: NameMatch' -> a -> a -> Maybe (Subst' (LHsExpr GhcPs))
unifyDef' nm :: NameMatch'
nm x :: a
x y :: a
y = ([Subst' (LHsExpr GhcPs)] -> Subst' (LHsExpr GhcPs))
-> Maybe [Subst' (LHsExpr GhcPs)] -> Maybe (Subst' (LHsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Subst' (LHsExpr GhcPs)] -> Subst' (LHsExpr GhcPs)
forall a. Monoid a => [a] -> a
mconcat (Maybe [Subst' (LHsExpr GhcPs)] -> Maybe (Subst' (LHsExpr GhcPs)))
-> ([Maybe (Subst' (LHsExpr GhcPs))]
    -> Maybe [Subst' (LHsExpr GhcPs)])
-> [Maybe (Subst' (LHsExpr GhcPs))]
-> Maybe (Subst' (LHsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Subst' (LHsExpr GhcPs))] -> Maybe [Subst' (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Maybe (Subst' (LHsExpr GhcPs))]
 -> Maybe (Subst' (LHsExpr GhcPs)))
-> Maybe [Maybe (Subst' (LHsExpr GhcPs))]
-> Maybe (Subst' (LHsExpr GhcPs))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall b. Data b => b -> b -> Maybe (Subst' (LHsExpr GhcPs)))
-> a -> a -> Maybe [Maybe (Subst' (LHsExpr GhcPs))]
forall a c.
Data a =>
(forall b. Data b => b -> b -> c) -> a -> a -> Maybe [c]
gzip (NameMatch' -> Bool -> b -> b -> Maybe (Subst' (LHsExpr GhcPs))
forall a.
Data a =>
NameMatch' -> Bool -> a -> a -> Maybe (Subst' (LHsExpr GhcPs))
unify' NameMatch'
nm Bool
False) a
x a
y

-- App/InfixApp are analysed specially for performance reasons. If
-- 'root = True', this is the outside of the expr. Do not expand out a
-- dot at the root, since otherwise you get two matches because of
-- 'readRule' (Bug #570).
unifyExp' :: NameMatch' -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst' (LHsExpr GhcPs) )
-- Brackets are not added when expanding '$' in user code, so tolerate
-- them in the match even if they aren't in the user code.
unifyExp' :: NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' nm :: NameMatch'
nm root :: Bool
root x :: LHsExpr GhcPs
x y :: LHsExpr GhcPs
y | Bool -> Bool
not Bool
root, LHsExpr GhcPs -> Bool
isPar LHsExpr GhcPs
x, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
isPar LHsExpr GhcPs
y = NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
root (LHsExpr GhcPs -> LHsExpr GhcPs
fromParen' LHsExpr GhcPs
x) LHsExpr GhcPs
y
-- Don't subsitute for type apps, since no one writes rules imaginging
-- they exist.
unifyExp' nm :: NameMatch'
nm root :: Bool
root (LL _ (HsVar _ (rdrNameStr' -> v))) y :: LHsExpr GhcPs
y | String -> Bool
isUnifyVar String
v, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
isTypeApp LHsExpr GhcPs
y = Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs))
forall a. a -> Maybe a
Just (Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs)))
-> Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ [(String, LHsExpr GhcPs)] -> Subst' (LHsExpr GhcPs)
forall a. [(String, a)] -> Subst' a
Subst' [(String
v, LHsExpr GhcPs
y)]
unifyExp' nm :: NameMatch'
nm root :: Bool
root (LL _ (HsVar _ x)) (LL _ (HsVar _ y)) | NameMatch'
nm Located RdrName
Located (IdP GhcPs)
x Located RdrName
Located (IdP GhcPs)
y = Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs))
forall a. a -> Maybe a
Just Subst' (LHsExpr GhcPs)
forall a. Monoid a => a
mempty

-- Match wildcard operators.
unifyExp' nm :: NameMatch'
nm root :: Bool
root (LL _ (OpApp _ lhs1 (LL _ (HsVar _ (rdrNameStr' -> v))) rhs1))
                  (LL _ (OpApp _ lhs2 (LL _ (HsVar _ (rdrNameStr' -> op2))) rhs2))
    | String -> Bool
isUnifyVar String
v =
        ([(String, LHsExpr GhcPs)] -> Subst' (LHsExpr GhcPs)
forall a. [(String, a)] -> Subst' a
Subst' [(String
v, String -> LHsExpr GhcPs
strToVar String
op2)] Subst' (LHsExpr GhcPs)
-> Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs)
forall a. Semigroup a => a -> a -> a
<>) (Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs)) -> Maybe (Subst' (LHsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Subst' (LHsExpr GhcPs)
 -> Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs))
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Subst' (LHsExpr GhcPs)
-> Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs)
forall a. Semigroup a => a -> a -> a
(<>) (NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
False LHsExpr GhcPs
lhs1 LHsExpr GhcPs
lhs2) (NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
False LHsExpr GhcPs
rhs1 LHsExpr GhcPs
rhs2)
unifyExp' nm :: NameMatch'
nm root :: Bool
root (LL _ (SectionL _ exp1 (LL _ (HsVar _ (rdrNameStr' -> v)))))
                  (LL _ (SectionL _ exp2 (LL _ (HsVar _ (rdrNameStr' -> op2)))))
    | String -> Bool
isUnifyVar String
v = ([(String, LHsExpr GhcPs)] -> Subst' (LHsExpr GhcPs)
forall a. [(String, a)] -> Subst' a
Subst' [(String
v, String -> LHsExpr GhcPs
strToVar String
op2)] Subst' (LHsExpr GhcPs)
-> Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs)
forall a. Semigroup a => a -> a -> a
<>) (Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs)) -> Maybe (Subst' (LHsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
False LHsExpr GhcPs
exp1 LHsExpr GhcPs
exp2
unifyExp' nm :: NameMatch'
nm root :: Bool
root (LL _ (SectionR _ (LL _ (HsVar _ (rdrNameStr' -> v))) exp1))
                  (LL _ (SectionR _ (LL _ (HsVar _ (rdrNameStr' -> op2))) exp2))
    | String -> Bool
isUnifyVar String
v = ([(String, LHsExpr GhcPs)] -> Subst' (LHsExpr GhcPs)
forall a. [(String, a)] -> Subst' a
Subst' [(String
v, String -> LHsExpr GhcPs
strToVar String
op2)] Subst' (LHsExpr GhcPs)
-> Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs)
forall a. Semigroup a => a -> a -> a
<>) (Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs)) -> Maybe (Subst' (LHsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
False LHsExpr GhcPs
exp1 LHsExpr GhcPs
exp2

-- Options: match directly, and expand through '.'
unifyExp' nm :: NameMatch'
nm root :: Bool
root x :: LHsExpr GhcPs
x@(LL _ (HsApp _ x1 x2)) (LL _ (HsApp _ y1 y2)) =
    (Subst' (LHsExpr GhcPs)
 -> Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs))
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Subst' (LHsExpr GhcPs)
-> Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs)
forall a. Semigroup a => a -> a -> a
(<>) (NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
False LHsExpr GhcPs
x1 LHsExpr GhcPs
y1) (NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
False LHsExpr GhcPs
x2 LHsExpr GhcPs
y2) Maybe (Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs)) -> Maybe (Subst' (LHsExpr GhcPs))
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
    (do Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
root
            -- Don't expand '.' f at the root, otherwise you can get
            -- duplicate matches because the matching engine
            -- auto-generates hints in dot-form.
        (LL _ (OpApp _ y11 dot y12)) <- LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))
-> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
fromParen' LHsExpr GhcPs
y1
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Bool
isDot LHsExpr GhcPs
dot
        NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
root LHsExpr GhcPs
x (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExt
XApp GhcPs
noExt LHsExpr GhcPs
y11 (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExt
XApp GhcPs
noExt LHsExpr GhcPs
y12 LHsExpr GhcPs
y2))))
    )

-- Options: match directly, then expand through '$', then desugar infix.
unifyExp' nm :: NameMatch'
nm root :: Bool
root x :: LHsExpr GhcPs
x (LL _ (OpApp _ lhs2 op2@(LL _ (HsVar _ op2')) rhs2))
    | (LL _ (OpApp _ lhs1 op1@(LL _ (HsVar _ op1')) rhs1)) <- LHsExpr GhcPs
x = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (NameMatch'
nm Located RdrName
Located (IdP GhcPs)
op1' Located RdrName
Located (IdP GhcPs)
op2') Maybe ()
-> Maybe (Subst' (LHsExpr GhcPs)) -> Maybe (Subst' (LHsExpr GhcPs))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Subst' (LHsExpr GhcPs)
 -> Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs))
-> Maybe (Subst' (LHsExpr GhcPs))
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Subst' (LHsExpr GhcPs)
-> Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs)
forall a. Semigroup a => a -> a -> a
(<>) (NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
False LHsExpr GhcPs
lhs1 LHsExpr GhcPs
lhs2) (NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
False LHsExpr GhcPs
rhs1 LHsExpr GhcPs
rhs2)
    | LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
op2 = NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
root LHsExpr GhcPs
x (LHsExpr GhcPs -> Maybe (Subst' (LHsExpr GhcPs)))
-> LHsExpr GhcPs -> Maybe (Subst' (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExt
XApp GhcPs
noExt LHsExpr GhcPs
lhs2 LHsExpr GhcPs
rhs2)
    | Bool
otherwise  = NameMatch'
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst' (LHsExpr GhcPs))
unifyExp' NameMatch'
nm Bool
root LHsExpr GhcPs
x (LHsExpr GhcPs -> Maybe (Subst' (LHsExpr GhcPs)))
-> LHsExpr GhcPs -> Maybe (Subst' (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExt
XApp GhcPs
noExt (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExt
XApp GhcPs
noExt LHsExpr GhcPs
op2 LHsExpr GhcPs
lhs2)) LHsExpr GhcPs
rhs2)

unifyExp' nm :: NameMatch'
nm root :: Bool
root x :: LHsExpr GhcPs
x y :: LHsExpr GhcPs
y | LHsExpr GhcPs -> Bool
isOther LHsExpr GhcPs
x, LHsExpr GhcPs -> Bool
isOther LHsExpr GhcPs
y = NameMatch'
-> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst' (LHsExpr GhcPs))
forall a.
Data a =>
NameMatch' -> a -> a -> Maybe (Subst' (LHsExpr GhcPs))
unifyDef' NameMatch'
nm LHsExpr GhcPs
x LHsExpr GhcPs
y
    where
        -- Types that are not already handled in unify.
        {-# INLINE isOther #-}
        isOther :: LHsExpr GhcPs -> Bool
        isOther :: LHsExpr GhcPs -> Bool
isOther (LL _ HsVar{}) = Bool
False
        isOther (LL _ HsApp{}) = Bool
False
        isOther (LL _ OpApp{}) = Bool
False
        isOther _ = Bool
True

unifyExp' _ _ _ _ = Maybe (Subst' (LHsExpr GhcPs))
forall a. Maybe a
Nothing


unifyPat' :: NameMatch' -> LPat GhcPs -> LPat GhcPs -> Maybe (Subst' (LHsExpr GhcPs))
unifyPat' :: NameMatch'
-> LPat GhcPs -> LPat GhcPs -> Maybe (Subst' (LHsExpr GhcPs))
unifyPat' nm :: NameMatch'
nm (LL _ (VarPat _ x)) (LL _ (VarPat _ y)) =
  Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs))
forall a. a -> Maybe a
Just (Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs)))
-> Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ [(String, LHsExpr GhcPs)] -> Subst' (LHsExpr GhcPs)
forall a. [(String, a)] -> Subst' a
Subst' [(Located RdrName -> String
rdrNameStr' Located RdrName
Located (IdP GhcPs)
x, String -> LHsExpr GhcPs
strToVar(Located RdrName -> String
rdrNameStr' Located RdrName
Located (IdP GhcPs)
y))]
unifyPat' nm :: NameMatch'
nm (LL _ (VarPat _ x)) (LL _ (WildPat _)) =
  let s :: String
s = Located RdrName -> String
rdrNameStr' Located RdrName
Located (IdP GhcPs)
x in Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs))
forall a. a -> Maybe a
Just (Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs)))
-> Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ [(String, LHsExpr GhcPs)] -> Subst' (LHsExpr GhcPs)
forall a. [(String, a)] -> Subst' a
Subst' [(String
s, String -> LHsExpr GhcPs
strToVar("_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s))]
unifyPat' nm :: NameMatch'
nm (LL _ (ConPatIn x _)) (LL _ (ConPatIn y _)) | Located RdrName -> String
rdrNameStr' Located RdrName
Located (IdP GhcPs)
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= Located RdrName -> String
rdrNameStr' Located RdrName
Located (IdP GhcPs)
y =
  Maybe (Subst' (LHsExpr GhcPs))
forall a. Maybe a
Nothing
unifyPat' nm :: NameMatch'
nm x :: LPat GhcPs
x y :: LPat GhcPs
y =
  NameMatch'
-> LPat GhcPs -> LPat GhcPs -> Maybe (Subst' (LHsExpr GhcPs))
forall a.
Data a =>
NameMatch' -> a -> a -> Maybe (Subst' (LHsExpr GhcPs))
unifyDef' NameMatch'
nm LPat GhcPs
x LPat GhcPs
y

unifyType' :: NameMatch' -> LHsType GhcPs -> LHsType GhcPs -> Maybe (Subst' (LHsExpr GhcPs))
unifyType' :: NameMatch'
-> LHsType GhcPs -> LHsType GhcPs -> Maybe (Subst' (LHsExpr GhcPs))
unifyType' nm :: NameMatch'
nm (LL loc :: SrcSpan
loc (HsTyVar _ _ x)) y :: LHsType GhcPs
y =
  let wc :: LHsWcType (NoGhcTc GhcPs)
wc = XHsWC GhcPs (LHsType GhcPs)
-> LHsType GhcPs -> HsWildCardBndrs GhcPs (LHsType GhcPs)
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC NoExt
XHsWC GhcPs (LHsType GhcPs)
noExt LHsType GhcPs
y :: LHsWcType (NoGhcTc GhcPs)
      unused :: LHsExpr GhcPs
unused = SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExt
XVar GhcPs
noExt (SrcSpanLess (Located RdrName) -> Located (IdP GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located RdrName) -> Located (IdP GhcPs))
-> SrcSpanLess (Located RdrName) -> Located (IdP GhcPs)
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
mkRdrUnqual (String -> OccName
mkVarOcc "__unused__"))) :: LHsExpr GhcPs
      appType :: LHsExpr GhcPs
appType = SrcSpan -> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XAppTypeE GhcPs
-> LHsExpr GhcPs -> LHsWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExt
XAppTypeE GhcPs
noExt LHsExpr GhcPs
unused HsWildCardBndrs GhcPs (LHsType GhcPs)
LHsWcType (NoGhcTc GhcPs)
wc) :: LHsExpr GhcPs
 in Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs))
forall a. a -> Maybe a
Just (Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs)))
-> Subst' (LHsExpr GhcPs) -> Maybe (Subst' (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ [(String, LHsExpr GhcPs)] -> Subst' (LHsExpr GhcPs)
forall a. [(String, a)] -> Subst' a
Subst' [(Located RdrName -> String
rdrNameStr' Located RdrName
Located (IdP GhcPs)
x, LHsExpr GhcPs
appType)]
unifyType' nm :: NameMatch'
nm x :: LHsType GhcPs
x y :: LHsType GhcPs
y = NameMatch'
-> LHsType GhcPs -> LHsType GhcPs -> Maybe (Subst' (LHsExpr GhcPs))
forall a.
Data a =>
NameMatch' -> a -> a -> Maybe (Subst' (LHsExpr GhcPs))
unifyDef' NameMatch'
nm LHsType GhcPs
x LHsType GhcPs
y