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

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

import Control.Applicative
import Control.Monad
import Data.Generics.Uniplate.DataOnly
import Data.Char
import Data.Data
import Data.List.Extra
import Util

import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Utils.Outputable hiding ((<>))
import GHC.Types.Name.Reader

import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import GHC.Util.HsExpr
import GHC.Util.View
import Data.Maybe
import GHC.Data.FastString

isUnifyVar :: String -> Bool
isUnifyVar :: String -> Bool
isUnifyVar [Char
x] = Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?' Bool -> Bool -> Bool
|| Char -> Bool
isAlpha Char
x
isUnifyVar [] = Bool
False
isUnifyVar 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
== Char
'?') 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 (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
$c<> :: forall a. Subst a -> Subst a -> Subst a
<> :: Subst a -> Subst a -> Subst a
$csconcat :: forall a. NonEmpty (Subst a) -> Subst a
sconcat :: NonEmpty (Subst a) -> Subst a
$cstimes :: forall a b. Integral b => b -> Subst a -> Subst a
stimes :: forall b. Integral b => b -> 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
$cmempty :: forall a. Subst a
mempty :: Subst a
$cmappend :: forall a. Subst a -> Subst a -> Subst a
mappend :: Subst a -> Subst a -> Subst a
$cmconcat :: forall a. [Subst a] -> Subst a
mconcat :: [Subst a] -> Subst a
Monoid, (forall a b. (a -> b) -> Subst a -> Subst b)
-> (forall a b. a -> Subst b -> Subst a) -> Functor Subst
forall a b. a -> Subst b -> Subst a
forall a b. (a -> b) -> Subst a -> Subst 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) -> Subst a -> Subst b
fmap :: forall a b. (a -> b) -> Subst a -> Subst b
$c<$ :: forall a b. a -> Subst b -> Subst a
<$ :: forall a b. a -> Subst b -> Subst a
Functor)

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

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

-- Check the unification is valid and simplify it.
validSubst :: (a -> a -> Bool) -> Subst a -> Maybe (Subst a)
validSubst :: forall a. (a -> a -> Bool) -> Subst a -> Maybe (Subst a)
validSubst a -> a -> Bool
eq = ([(String, a)] -> Subst a)
-> Maybe [(String, a)] -> Maybe (Subst a)
forall a b. (a -> b) -> Maybe a -> Maybe b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 (a
x, a
y : [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 (a, [a])
_ = Maybe (a, a)
forall a. Maybe a
Nothing

-- Remove unnecessary brackets from a Subst. The first argument is a list of unification variables
-- for which brackets should be removed from their substitutions.
removeParens :: [String] -> Subst (LHsExpr GhcPs) -> Subst (LHsExpr GhcPs)
removeParens :: [String] -> Subst (LHsExpr GhcPs) -> Subst (LHsExpr GhcPs)
removeParens [String]
noParens (Subst [(String, LHsExpr GhcPs)]
xs) = [(String, LHsExpr GhcPs)] -> Subst (LHsExpr GhcPs)
forall a. [(String, a)] -> Subst a
Subst ([(String, LHsExpr GhcPs)] -> Subst (LHsExpr GhcPs))
-> [(String, LHsExpr GhcPs)] -> Subst (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
  ((String, GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> (String, GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
x, GenLocated SrcSpanAnnA (HsExpr GhcPs)
y) -> if String
x String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
noParens then (String
x, GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
y) else (String
x, GenLocated SrcSpanAnnA (HsExpr GhcPs)
y)) [(String, LHsExpr GhcPs)]
[(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
xs

-- Perform a substitution.
-- Returns (suggested replacement, (refactor template, no bracket vars)). It adds/removes brackets
-- for both the suggested replacement and the refactor template appropriately. The "no bracket vars"
-- is a list of substitution variables which, when expanded, should have the brackets stripped.
--
-- Examples:
--   (traverse foo (bar baz), (traverse f (x), []))
--   (zipWith foo bar baz, (f a b, [f]))
substitute :: Subst (LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
substitute :: Subst (LHsExpr GhcPs)
-> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
substitute (Subst [(String, LHsExpr GhcPs)]
bind) = (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))
-> LHsExpr GhcPs -> (LHsExpr GhcPs, (LHsExpr GhcPs, [String]))
transformBracketOld LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
exp (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> (GenLocated SrcSpanAnnA (HsExpr GhcPs),
     (GenLocated SrcSpanAnnA (HsExpr GhcPs), [String])))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs),
    (GenLocated SrcSpanAnnA (HsExpr GhcPs), [String]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (Pat GhcPs)
 -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi LPat GhcPs -> LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
pat (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi LHsType GhcPs -> LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
typ
  where
    exp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
    -- Variables.
    exp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
exp (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ LIdP GhcPs
x)) = String
-> [(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (LocatedN RdrName -> String
rdrNameStr LIdP GhcPs
LocatedN RdrName
x) [(String, LHsExpr GhcPs)]
[(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
bind
    -- Operator applications.
    exp (L SrcSpanAnnA
loc (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ LIdP GhcPs
x)) LHsExpr GhcPs
rhs))
      | Just GenLocated SrcSpanAnnA (HsExpr GhcPs)
y <- String
-> [(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (LocatedN RdrName -> String
rdrNameStr LIdP GhcPs
LocatedN RdrName
x) [(String, LHsExpr GhcPs)]
[(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
bind = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> Maybe a
Just (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
lhs LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y LHsExpr GhcPs
rhs))
    -- Left sections.
    exp (L SrcSpanAnnA
loc (SectionL XSectionL GhcPs
_ LHsExpr GhcPs
exp (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ LIdP GhcPs
x))))
      | Just GenLocated SrcSpanAnnA (HsExpr GhcPs)
y <- String
-> [(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (LocatedN RdrName -> String
rdrNameStr LIdP GhcPs
LocatedN RdrName
x) [(String, LHsExpr GhcPs)]
[(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
bind = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> Maybe a
Just (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XSectionL GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL XSectionL GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
exp LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y))
    -- Right sections.
    exp (L SrcSpanAnnA
loc (SectionR XSectionR GhcPs
_ (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ LIdP GhcPs
x)) LHsExpr GhcPs
exp))
      | Just GenLocated SrcSpanAnnA (HsExpr GhcPs)
y <- String
-> [(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (LocatedN RdrName -> String
rdrNameStr LIdP GhcPs
LocatedN RdrName
x) [(String, LHsExpr GhcPs)]
[(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
bind = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> Maybe a
Just (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XSectionR GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y LHsExpr GhcPs
exp))
    exp LHsExpr GhcPs
_ = Maybe (LHsExpr GhcPs)
Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Maybe a
Nothing

    pat :: LPat GhcPs -> LPat GhcPs
    -- Pattern variables.
    pat :: LPat GhcPs -> LPat GhcPs
pat (L SrcSpanAnnA
_ (VarPat XVarPat GhcPs
_ LIdP GhcPs
x))
      | Just y :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
y@(L SrcSpanAnnA
_ HsVar{}) <- String
-> [(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (LocatedN RdrName -> String
rdrNameStr LIdP GhcPs
LocatedN RdrName
x) [(String, LHsExpr GhcPs)]
[(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
bind = String -> LPat GhcPs
strToPat (String -> LPat GhcPs) -> String -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y
    pat LPat GhcPs
x = LPat GhcPs
x :: LPat GhcPs

    typ :: LHsType GhcPs -> LHsType GhcPs
    -- Type variables.
    typ :: LHsType GhcPs -> LHsType GhcPs
typ (L SrcSpanAnnA
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ LIdP GhcPs
x))
      | Just (L SrcSpanAnnA
_ (HsAppType XAppTypeE GhcPs
_ LHsExpr GhcPs
_ LHsToken "@" GhcPs
_ (HsWC XHsWC (NoGhcTc GhcPs) (LHsType (NoGhcTc GhcPs))
_ LHsType (NoGhcTc GhcPs)
y))) <- String
-> [(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (LocatedN RdrName -> String
rdrNameStr LIdP GhcPs
LocatedN RdrName
x) [(String, LHsExpr GhcPs)]
[(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
bind = LHsType (NoGhcTc GhcPs)
LHsType GhcPs
y
    typ LHsType GhcPs
x = LHsType GhcPs
x :: LHsType GhcPs


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

type NameMatch = LocatedN RdrName -> LocatedN 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' :: forall a.
Data a =>
NameMatch -> Bool -> a -> a -> Maybe (Subst (LHsExpr GhcPs))
unify' NameMatch
nm Bool
root a
x a
y
    | Just (GenLocated SrcSpanAnnA (HsExpr GhcPs)
x, GenLocated SrcSpanAnnA (HsExpr GhcPs)
y) <- (a, a)
-> Maybe
     (GenLocated SrcSpanAnnA (HsExpr GhcPs),
      GenLocated SrcSpanAnnA (HsExpr 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
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y
    | Just (GenLocated SrcSpanAnnA (Pat GhcPs)
x, GenLocated SrcSpanAnnA (Pat GhcPs)
y) <- (a, a)
-> Maybe
     (GenLocated SrcSpanAnnA (Pat GhcPs),
      GenLocated SrcSpanAnnA (Pat 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
GenLocated SrcSpanAnnA (Pat GhcPs)
x LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
y
    | Just (GenLocated SrcSpanAnnA (HsType GhcPs)
x, GenLocated SrcSpanAnnA (HsType GhcPs)
y) <- (a, a)
-> Maybe
     (GenLocated SrcSpanAnnA (HsType GhcPs),
      GenLocated SrcSpanAnnA (HsType 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
GenLocated SrcSpanAnnA (HsType GhcPs)
x LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
y
    | Just (FastString
x, FastString
y) <- (a, a) -> Maybe (FastString, FastString)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (a
x, a
y) = if (FastString
x :: FastString) FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
y then Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty else Maybe (Subst (LHsExpr GhcPs))
Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a
Nothing

    -- We need some type magic to reduce this.
    | Just (EpAnn Anchor
x :: EpAnn Anchor) <- a -> Maybe (EpAnn Anchor)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn AnnContext
x :: EpAnn AnnContext) <- a -> Maybe (EpAnn AnnContext)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn AnnExplicitSum
x :: EpAnn AnnExplicitSum) <- a -> Maybe (EpAnn AnnExplicitSum)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn AnnFieldLabel
x :: EpAnn AnnFieldLabel) <- a -> Maybe (EpAnn AnnFieldLabel)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn AnnList
x :: EpAnn AnnList) <- a -> Maybe (EpAnn AnnList)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn AnnListItem
x :: EpAnn AnnListItem) <- a -> Maybe (EpAnn AnnListItem)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn AnnParen
x :: EpAnn AnnParen) <- a -> Maybe (EpAnn AnnParen)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn AnnPragma
x :: EpAnn AnnPragma) <- a -> Maybe (EpAnn AnnPragma)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn AnnProjection
x :: EpAnn AnnProjection) <- a -> Maybe (EpAnn AnnProjection)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn AnnsIf
x :: EpAnn AnnsIf) <- a -> Maybe (EpAnn AnnsIf)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn AnnSig
x :: EpAnn AnnSig) <- a -> Maybe (EpAnn AnnSig)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn AnnsModule
x :: EpAnn AnnsModule) <- a -> Maybe (EpAnn AnnsModule)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn EpaLocation
x :: EpAnn EpaLocation) <- a -> Maybe (EpAnn EpaLocation)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn EpAnnHsCase
x :: EpAnn EpAnnHsCase) <- a -> Maybe (EpAnn EpAnnHsCase)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn EpAnnImportDecl
x :: EpAnn EpAnnImportDecl) <- a -> Maybe (EpAnn EpAnnImportDecl)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn EpAnnSumPat
x :: EpAnn EpAnnSumPat) <- a -> Maybe (EpAnn EpAnnSumPat)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn EpAnnUnboundVar
x :: EpAnn EpAnnUnboundVar) <- a -> Maybe (EpAnn EpAnnUnboundVar)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn GrhsAnn
x :: EpAnn GrhsAnn) <- a -> Maybe (EpAnn GrhsAnn)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn HsRuleAnn
x :: EpAnn HsRuleAnn) <- a -> Maybe (EpAnn HsRuleAnn)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn NameAnn
x :: EpAnn NameAnn) <- a -> Maybe (EpAnn NameAnn)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn NoEpAnns
x :: EpAnn NoEpAnns) <- a -> Maybe (EpAnn NoEpAnns)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn [AddEpAnn]
x :: EpAnn [AddEpAnn]) <- a -> Maybe (EpAnn [AddEpAnn])
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (EpAnn (AddEpAnn, AddEpAnn)
x :: EpAnn (AddEpAnn, AddEpAnn)) <- a -> Maybe (EpAnn (AddEpAnn, AddEpAnn))
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (TokenLocation
x :: TokenLocation) <- a -> Maybe TokenLocation
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty
    | Just (SrcSpan
y :: SrcSpan) <- a -> Maybe SrcSpan
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
y = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr 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' :: forall a.
Data a =>
NameMatch -> a -> a -> Maybe (Subst (LHsExpr GhcPs))
unifyDef' NameMatch
nm a
x a
y =
  ([Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
 -> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe [Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => [a] -> a
mconcat (Maybe [Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
 -> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> ([Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
    -> Maybe [Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> [Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Maybe [Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Maybe [Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall b.
 Data b =>
 b -> b -> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> a
-> a
-> Maybe [Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr 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

unifyComposed' :: NameMatch
               -> LHsExpr GhcPs
               -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
               -> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyComposed' :: NameMatch
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyComposed' NameMatch
nm LHsExpr GhcPs
x1 LHsExpr GhcPs
y11 LHsExpr GhcPs
dot LHsExpr GhcPs
y12 =
  ((, GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> Maybe a
Just LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y11) (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
     Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr 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
x1 LHsExpr GhcPs
y12)
    Maybe
  (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
   Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> case LHsExpr GhcPs
y12 of
          (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
y121 LHsExpr GhcPs
dot' LHsExpr GhcPs
y122)) | LHsExpr GhcPs -> Bool
isDot LHsExpr GhcPs
dot' ->
            NameMatch
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyComposed' NameMatch
nm LHsExpr GhcPs
x1 (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
y11 LHsExpr GhcPs
dot LHsExpr GhcPs
y121)) LHsExpr GhcPs
dot' LHsExpr GhcPs
y122
          LHsExpr GhcPs
_ -> Maybe
  (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
   Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a
Nothing

-- unifyExp handles the cases where both x and y are HsApp, or y is OpApp. Otherwise,
-- delegate to unifyExp'. These are the cases where we potentially need to call
-- unifyComposed' to handle left composition.
--
-- y is allowed to partially match x (the lhs of the hint), if y is a function application where
-- the function is a composition of functions. In this case the second component of the result is
-- the unmatched part of y, which will be attached to the rhs of the hint after substitution.
--
-- Example:
--   x = head (drop n x)
--   y = foo . bar . baz . head $ drop 2 xs
--   result = (Subst [(n, 2), (x, xs)], Just (foo . bar . baz))
unifyExp :: NameMatch -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-- Match wildcard operators.
unifyExp :: NameMatch
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyExp NameMatch
nm Bool
root (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs1 (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (LIdP GhcPs -> String
LocatedN RdrName -> String
rdrNameStr -> String
v))) LHsExpr GhcPs
rhs1))
                 (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs2 (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (LIdP GhcPs -> String
LocatedN RdrName -> String
rdrNameStr -> String
op2))) LHsExpr GhcPs
rhs2))
    | String -> Bool
isUnifyVar String
v =
        (, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Maybe a
Nothing) (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
     Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    -> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
    Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. [(String, a)] -> Subst a
Subst [(String
v, String -> LHsExpr GhcPs
strToVar String
op2)] Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Semigroup a => a -> a -> a
<>) (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
     Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr 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)

-- Options: match directly, and expand through '.'
unifyExp NameMatch
nm Bool
root x :: LHsExpr GhcPs
x@(L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x1 LHsExpr GhcPs
x2)) (L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
y1 LHsExpr GhcPs
y2)) =
    ((, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Maybe a
Nothing) (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
     Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr 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 (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
   Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe
  (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
   Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
unifyComposed
  where
    -- Unify a function application where the function is a composition of functions.
    unifyComposed :: Maybe
  (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
   Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
unifyComposed
      | (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
y11 LHsExpr GhcPs
dot LHsExpr GhcPs
y12)) <- GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y1, LHsExpr GhcPs -> Bool
isDot LHsExpr GhcPs
dot =
          if Bool -> Bool
not Bool
root then
              -- Attempt #1: rewrite '(fun1 . fun2) arg' as 'fun1 (fun2 arg)', and unify it with 'x'.
              -- The guard ensures that you don't get duplicate matches because the matching engine
              -- auto-generates hints in dot-form.
              (, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Maybe a
Nothing) (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
     Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr 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
root LHsExpr GhcPs
x (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
y11 (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
y12 LHsExpr GhcPs
y2))))
          else do
              -- Attempt #2: rewrite '(fun1 . fun2 ... funn) arg' as 'fun1 $ (fun2 ... funn) arg',
              -- 'fun1 . fun2 $ (fun3 ... funn) arg', 'fun1 . fun2 . fun3 $ (fun4 ... funn) arg',
              -- and so on, unify the rhs of '$' with 'x', and store the lhs of '$' into 'extra'.
              -- You can only add to extra if you are at the root (otherwise 'extra' has nowhere to go).
              Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs <- NameMatch
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs))
unifyExp' NameMatch
nm Bool
False LHsExpr GhcPs
x2 LHsExpr GhcPs
y2
              (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
lhs, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
extra) <- NameMatch
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyComposed' NameMatch
nm LHsExpr GhcPs
x1 LHsExpr GhcPs
y11 LHsExpr GhcPs
dot LHsExpr GhcPs
y12
              (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
 Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
lhs Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Semigroup a => a -> a -> a
<> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
extra)
      | Bool
otherwise = Maybe
  (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
   Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a
Nothing

-- Options: match directly, then expand through '$', then desugar infix.
unifyExp NameMatch
nm Bool
root LHsExpr GhcPs
x (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs2 op2 :: LHsExpr GhcPs
op2@(L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ LIdP GhcPs
op2')) LHsExpr GhcPs
rhs2))
    | (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs1 op1 :: LHsExpr GhcPs
op1@(L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ LIdP GhcPs
op1')) LHsExpr GhcPs
rhs1)) <- LHsExpr GhcPs
x =
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (NameMatch
nm LIdP GhcPs
LocatedN RdrName
op1' LIdP GhcPs
LocatedN RdrName
op2') Maybe ()
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Maybe a
Nothing) (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
     Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr 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), Maybe (LHsExpr GhcPs))
unifyExp NameMatch
nm Bool
root LHsExpr GhcPs
x (LHsExpr GhcPs
 -> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)))
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
lhs2 LHsExpr GhcPs
rhs2)
    | LHsExpr GhcPs -> Bool
isAmp LHsExpr GhcPs
op2 = NameMatch
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyExp NameMatch
nm Bool
root LHsExpr GhcPs
x (LHsExpr GhcPs
 -> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)))
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
rhs2 LHsExpr GhcPs
lhs2)
    | Bool
otherwise  = NameMatch
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyExp NameMatch
nm Bool
root LHsExpr GhcPs
x (LHsExpr GhcPs
 -> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)))
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcPs
op2 (LHsExpr GhcPs -> LHsExpr GhcPs
addPar LHsExpr GhcPs
lhs2))) (LHsExpr GhcPs -> LHsExpr GhcPs
addPar LHsExpr GhcPs
rhs2))
        where
          -- add parens around when desugaring the expression, if necessary
          addPar :: LHsExpr GhcPs -> LHsExpr GhcPs
          addPar :: LHsExpr GhcPs -> LHsExpr GhcPs
addPar LHsExpr GhcPs
x = if GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
forall a. Brackets a => a -> Bool
isAtom LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x then LHsExpr GhcPs
x else GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a. Brackets a => a -> a
addParen LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x

unifyExp NameMatch
nm Bool
root LHsExpr GhcPs
x LHsExpr GhcPs
y = (, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Maybe a
Nothing) (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
     Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe
     (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)),
      Maybe (GenLocated SrcSpanAnnA (HsExpr 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
root LHsExpr GhcPs
x LHsExpr GhcPs
y

isAmp :: LHsExpr GhcPs -> Bool
isAmp :: LHsExpr GhcPs -> Bool
isAmp (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ LIdP GhcPs
x)) = LocatedN RdrName -> String
rdrNameStr LIdP GhcPs
LocatedN RdrName
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"&"
isAmp LHsExpr GhcPs
_ = Bool
False

-- | If we "throw away" the extra than we have no where to put it, and the substitution is wrong
noExtra :: Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)) -> Maybe (Subst (LHsExpr GhcPs))
noExtra :: Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs))
noExtra (Just (Subst (LHsExpr GhcPs)
x, Maybe (LHsExpr GhcPs)
Nothing)) = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (LHsExpr GhcPs)
Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
x
noExtra Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
_ = Maybe (Subst (LHsExpr GhcPs))
Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a
Nothing

-- 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))
-- Don't substitute for type apps, since no one writes rules imagining
-- they exist.
unifyExp' :: NameMatch
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs))
unifyExp' NameMatch
nm Bool
root (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (LIdP GhcPs -> String
LocatedN RdrName -> String
rdrNameStr -> String
v))) 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, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. [(String, a)] -> Subst a
Subst [(String
v, LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y)]
unifyExp' NameMatch
nm Bool
root (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ LIdP GhcPs
x)) (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ LIdP GhcPs
y)) | NameMatch
nm LIdP GhcPs
LocatedN RdrName
x LIdP GhcPs
LocatedN RdrName
y = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Monoid a => a
mempty

-- Brackets are not added when expanding '$' in user code, so tolerate
-- them in the match even if they aren't in the user code.
-- Also, allow the user to put in more brackets than they strictly need (e.g. with infix).
unifyExp' NameMatch
nm Bool
root LHsExpr GhcPs
x LHsExpr GhcPs
y | Bool -> Bool
not Bool
root, Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
x2 Bool -> Bool -> Bool
|| Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
y2 = NameMatch
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs))
unifyExp' NameMatch
nm Bool
root (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a. a -> Maybe a -> a
fromMaybe LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
x2) (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a. a -> Maybe a -> a
fromMaybe LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
y2)
    where
        -- Make sure we deal with the weird brackets that can't be removed around sections
        x2 :: Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
x2 = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Brackets a => a -> Maybe a
remParen LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x
        y2 :: Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
y2 = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Brackets a => a -> Maybe a
remParen LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y

unifyExp' NameMatch
nm Bool
root x :: LHsExpr GhcPs
x@(L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs1 (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (LIdP GhcPs -> String
LocatedN RdrName -> String
rdrNameStr -> String
v))) LHsExpr GhcPs
rhs1))
                  y :: LHsExpr GhcPs
y@(L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs2 (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ LIdP GhcPs
op2)) LHsExpr GhcPs
rhs2)) =
  Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs))
noExtra (Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
 -> Maybe (Subst (LHsExpr GhcPs)))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ NameMatch
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyExp NameMatch
nm Bool
root LHsExpr GhcPs
x LHsExpr GhcPs
y
unifyExp' NameMatch
nm Bool
root (L SrcSpanAnnA
_ (SectionL XSectionL GhcPs
_ LHsExpr GhcPs
exp1 (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (LIdP GhcPs -> String
LocatedN RdrName -> String
rdrNameStr -> String
v)))))
                  (L SrcSpanAnnA
_ (SectionL XSectionL GhcPs
_ LHsExpr GhcPs
exp2 (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (LIdP GhcPs -> String
LocatedN RdrName -> String
rdrNameStr -> String
op2)))))
    | String -> Bool
isUnifyVar String
v = ([(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. [(String, a)] -> Subst a
Subst [(String
v, String -> LHsExpr GhcPs
strToVar String
op2)] Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Semigroup a => a -> a -> a
<>) (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr 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' NameMatch
nm Bool
root (L SrcSpanAnnA
_ (SectionR XSectionR GhcPs
_ (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (LIdP GhcPs -> String
LocatedN RdrName -> String
rdrNameStr -> String
v))) LHsExpr GhcPs
exp1))
                  (L SrcSpanAnnA
_ (SectionR XSectionR GhcPs
_ (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (LIdP GhcPs -> String
LocatedN RdrName -> String
rdrNameStr -> String
op2))) LHsExpr GhcPs
exp2))
    | String -> Bool
isUnifyVar String
v = ([(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. [(String, a)] -> Subst a
Subst [(String
v, String -> LHsExpr GhcPs
strToVar String
op2)] Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. Semigroup a => a -> a -> a
<>) (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr 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' NameMatch
nm Bool
root x :: LHsExpr GhcPs
x@(L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x1 LHsExpr GhcPs
x2)) y :: LHsExpr GhcPs
y@(L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
y1 LHsExpr GhcPs
y2)) =
  Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs))
noExtra (Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
 -> Maybe (Subst (LHsExpr GhcPs)))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ NameMatch
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyExp NameMatch
nm Bool
root LHsExpr GhcPs
x LHsExpr GhcPs
y

unifyExp' NameMatch
nm Bool
root LHsExpr GhcPs
x y :: LHsExpr GhcPs
y@(L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs2 op2 :: LHsExpr GhcPs
op2@(L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ LIdP GhcPs
op2')) LHsExpr GhcPs
rhs2)) =
  Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs))
noExtra (Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
 -> Maybe (Subst (LHsExpr GhcPs)))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ NameMatch
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyExp NameMatch
nm Bool
root LHsExpr GhcPs
x LHsExpr GhcPs
y

unifyExp' NameMatch
nm Bool
root (L SrcSpanAnnA
_ (HsUntypedBracket XUntypedBracket GhcPs
_ (VarBr XVarBr GhcPs
_ Bool
b0 (RdrName -> String
occNameStr (RdrName -> String)
-> (LocatedN RdrName -> RdrName) -> LocatedN RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc -> String
v1))))
                  (L SrcSpanAnnA
_ (HsUntypedBracket XUntypedBracket GhcPs
_ (VarBr XVarBr GhcPs
_ Bool
b1 (RdrName -> String
occNameStr (RdrName -> String)
-> (LocatedN RdrName -> RdrName) -> LocatedN RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc -> String
v2))))
    | Bool
b0 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b1 Bool -> Bool -> Bool
&& String -> Bool
isUnifyVar String
v1 = Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just ([(String, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. [(String, a)] -> Subst a
Subst [(String
v1, String -> LHsExpr GhcPs
strToVar String
v2)])

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

unifyExp' NameMatch
_ Bool
_ LHsExpr GhcPs
_ LHsExpr GhcPs
_ = Maybe (Subst (LHsExpr GhcPs))
Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr 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' NameMatch
nm (L SrcSpanAnnA
_ (VarPat XVarPat GhcPs
_ LIdP GhcPs
x)) (L SrcSpanAnnA
_ (VarPat XVarPat GhcPs
_ LIdP 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, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. [(String, a)] -> Subst a
Subst [(LocatedN RdrName -> String
rdrNameStr LIdP GhcPs
LocatedN RdrName
x, String -> LHsExpr GhcPs
strToVar(LocatedN RdrName -> String
rdrNameStr LIdP GhcPs
LocatedN RdrName
y))]
unifyPat' NameMatch
nm (L SrcSpanAnnA
_ (VarPat XVarPat GhcPs
_ LIdP GhcPs
x)) (L SrcSpanAnnA
_ (WildPat XWildPat GhcPs
_)) =
  let s :: String
s = LocatedN RdrName -> String
rdrNameStr LIdP GhcPs
LocatedN RdrName
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, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. [(String, a)] -> Subst a
Subst [(String
s, String -> LHsExpr GhcPs
strToVar(String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s))]
unifyPat' NameMatch
nm (L SrcSpanAnnA
_ (ConPat XConPat GhcPs
_ XRec GhcPs (ConLikeP GhcPs)
x HsConPatDetails GhcPs
_)) (L SrcSpanAnnA
_ (ConPat XConPat GhcPs
_ XRec GhcPs (ConLikeP GhcPs)
y HsConPatDetails GhcPs
_)) | LocatedN RdrName -> String
rdrNameStr XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= LocatedN RdrName -> String
rdrNameStr XRec GhcPs (ConLikeP GhcPs)
LocatedN RdrName
y =
  Maybe (Subst (LHsExpr GhcPs))
Maybe (Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. Maybe a
Nothing
unifyPat' NameMatch
nm LPat GhcPs
x LPat GhcPs
y =
  NameMatch
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> Maybe (Subst (LHsExpr GhcPs))
forall a.
Data a =>
NameMatch -> a -> a -> Maybe (Subst (LHsExpr GhcPs))
unifyDef' NameMatch
nm LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
x LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
y

unifyType' :: NameMatch -> LHsType GhcPs -> LHsType GhcPs -> Maybe (Subst (LHsExpr GhcPs))
unifyType' :: NameMatch
-> LHsType GhcPs -> LHsType GhcPs -> Maybe (Subst (LHsExpr GhcPs))
unifyType' NameMatch
nm (L SrcSpanAnnA
loc (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ LIdP GhcPs
x)) LHsType GhcPs
y =
  let wc :: HsWildCardBndrs (NoGhcTc GhcPs) (LHsType (NoGhcTc GhcPs))
wc = XHsWC GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC XHsWC GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
NoExtField
noExtField LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
y :: LHsWcType (NoGhcTc GhcPs)
      unused :: LHsExpr GhcPs
unused = String -> LHsExpr GhcPs
strToVar String
"__unused__"
      appType :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
appType = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XAppTypeE GhcPs
-> LHsExpr GhcPs
-> LHsToken "@" GhcPs
-> HsWildCardBndrs (NoGhcTc GhcPs) (LHsType (NoGhcTc GhcPs))
-> HsExpr GhcPs
forall p.
XAppTypeE p
-> LHsExpr p -> LHsToken "@" p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcPs
NoExtField
noExtField LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
unused LHsToken "@" GhcPs
GenLocated TokenLocation (HsToken "@")
forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok HsWildCardBndrs (NoGhcTc GhcPs) (LHsType (NoGhcTc GhcPs))
HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
wc)
 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, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Subst (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. [(String, a)] -> Subst a
Subst [(LocatedN RdrName -> String
rdrNameStr LIdP GhcPs
LocatedN RdrName
x, GenLocated SrcSpanAnnA (HsExpr GhcPs)
appType)]
unifyType' NameMatch
nm LHsType GhcPs
x LHsType GhcPs
y = NameMatch
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> Maybe (Subst (LHsExpr GhcPs))
forall a.
Data a =>
NameMatch -> a -> a -> Maybe (Subst (LHsExpr GhcPs))
unifyDef' NameMatch
nm LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
y