{-# 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 SrcLoc
import Outputable hiding ((<>))
import RdrName
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 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
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, a -> Subst b -> Subst a
(a -> b) -> Subst a -> Subst b
(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
<$ :: a -> Subst b -> Subst a
$c<$ :: forall a b. a -> Subst b -> Subst a
fmap :: (a -> b) -> Subst a -> Subst b
$cfmap :: forall a b. (a -> b) -> Subst a -> Subst b
Functor)
fromSubst :: Subst a -> [(String, a)]
fromSubst :: 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]
validSubst :: (a -> a -> Bool) -> Subst a -> Maybe (Subst a)
validSubst :: (a -> a -> Bool) -> Subst a -> Maybe (Subst a)
validSubst 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 (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
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, LHsExpr GhcPs) -> (String, LHsExpr GhcPs))
-> [(String, LHsExpr GhcPs)] -> [(String, LHsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
x, LHsExpr GhcPs
y) -> if String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
noParens then (String
x, LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
y) else (String
x, LHsExpr GhcPs
y)) [(String, LHsExpr GhcPs)]
xs
substitute :: Subst (LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)
substitute :: Subst (LHsExpr GhcPs)
-> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs)
substitute (Subst [(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
. (Located (Pat GhcPs) -> Located (Pat GhcPs))
-> LHsExpr GhcPs -> LHsExpr GhcPs
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi LPat GhcPs -> LPat GhcPs
Located (Pat GhcPs) -> Located (Pat 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)
exp :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
exp (L SrcSpan
_ (HsVar XVar GhcPs
_ Located (IdP GhcPs)
x)) = String -> [(String, LHsExpr GhcPs)] -> Maybe (LHsExpr GhcPs)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Located RdrName -> String
rdrNameStr Located (IdP GhcPs)
Located RdrName
x) [(String, LHsExpr GhcPs)]
bind
exp (L SrcSpan
loc (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs (L SrcSpan
_ (HsVar XVar GhcPs
_ Located (IdP GhcPs)
x)) LHsExpr GhcPs
rhs))
| Just 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 (IdP GhcPs)
Located RdrName
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 NoExtField
XOpApp GhcPs
noExtField LHsExpr GhcPs
lhs LHsExpr GhcPs
y LHsExpr GhcPs
rhs))
exp (L SrcSpan
loc (SectionL XSectionL GhcPs
_ LHsExpr GhcPs
exp (L SrcSpan
_ (HsVar XVar GhcPs
_ Located (IdP GhcPs)
x))))
| Just 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 (IdP GhcPs)
Located RdrName
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 NoExtField
XSectionL GhcPs
noExtField LHsExpr GhcPs
exp LHsExpr GhcPs
y))
exp (L SrcSpan
loc (SectionR XSectionR GhcPs
_ (L SrcSpan
_ (HsVar XVar GhcPs
_ Located (IdP GhcPs)
x)) LHsExpr GhcPs
exp))
| Just 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 (IdP GhcPs)
Located RdrName
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 NoExtField
XSectionR GhcPs
noExtField LHsExpr GhcPs
y LHsExpr GhcPs
exp))
exp LHsExpr GhcPs
_ = Maybe (LHsExpr GhcPs)
forall a. Maybe a
Nothing
pat :: LPat GhcPs -> LPat GhcPs
pat :: LPat GhcPs -> LPat GhcPs
pat (L _ (VarPat _ x))
| Just y :: LHsExpr GhcPs
y@(L SrcSpan
_ HsVar{}) <- String -> [(String, LHsExpr GhcPs)] -> Maybe (LHsExpr GhcPs)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Located RdrName -> String
rdrNameStr Located (IdP GhcPs)
Located RdrName
x) [(String, LHsExpr 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
y
pat LPat GhcPs
x = LPat GhcPs
x :: LPat GhcPs
typ :: LHsType GhcPs -> LHsType GhcPs
typ :: LHsType GhcPs -> LHsType GhcPs
typ (L SrcSpan
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ Located (IdP GhcPs)
x))
| Just (L SrcSpan
_ (HsAppType XAppTypeE GhcPs
_ LHsExpr GhcPs
_ (HsWC XHsWC (NoGhcTc GhcPs) (LHsType (NoGhcTc GhcPs))
_ LHsType (NoGhcTc 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 (IdP GhcPs)
Located RdrName
x) [(String, LHsExpr GhcPs)]
bind = LHsType GhcPs
LHsType (NoGhcTc GhcPs)
y
typ LHsType GhcPs
x = LHsType GhcPs
x :: LHsType GhcPs
type NameMatch = Located RdrName -> Located RdrName -> Bool
unify' :: Data a => NameMatch -> Bool -> a -> a -> Maybe (Subst (LHsExpr GhcPs))
unify' :: NameMatch -> Bool -> a -> a -> Maybe (Subst (LHsExpr GhcPs))
unify' NameMatch
nm Bool
root a
x a
y
| Just (LHsExpr GhcPs
x, 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 (Located (Pat GhcPs)
x, Located (Pat GhcPs)
y) <- (a, a) -> Maybe (Located (Pat GhcPs), Located (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
Located (Pat GhcPs)
x LPat GhcPs
Located (Pat GhcPs)
y
| Just (LHsType GhcPs
x, 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 (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 (LHsExpr GhcPs) -> Maybe (Subst (LHsExpr GhcPs))
forall a. a -> Maybe a
Just Subst (LHsExpr GhcPs)
forall a. Monoid a => a
mempty else Maybe (Subst (LHsExpr GhcPs))
forall a. Maybe a
Nothing
| Just (SrcSpan
x :: 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' NameMatch
nm a
x 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
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 =
((, LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a. a -> Maybe a
Just LHsExpr GhcPs
y11) (Subst (LHsExpr GhcPs)
-> (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)))
-> Maybe (Subst (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (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
x1 LHsExpr GhcPs
y12)
Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> case LHsExpr GhcPs
y12 of
(L SrcSpan
_ (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 (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExtField
XOpApp GhcPs
noExtField LHsExpr GhcPs
y11 LHsExpr GhcPs
dot LHsExpr GhcPs
y121)) LHsExpr GhcPs
dot' LHsExpr GhcPs
y122
LHsExpr GhcPs
_ -> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
forall a. Maybe a
Nothing
unifyExp :: NameMatch -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyExp :: NameMatch
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyExp NameMatch
nm Bool
root (L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs1 (L SrcSpan
_ (HsVar XVar GhcPs
_ (Located (IdP GhcPs) -> String
Located RdrName -> String
rdrNameStr -> String
v))) LHsExpr GhcPs
rhs1))
(L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs2 (L SrcSpan
_ (HsVar XVar GhcPs
_ (Located (IdP GhcPs) -> String
Located RdrName -> String
rdrNameStr -> String
op2))) LHsExpr GhcPs
rhs2))
| String -> Bool
isUnifyVar String
v =
(, Maybe (LHsExpr GhcPs)
forall a. Maybe a
Nothing) (Subst (LHsExpr GhcPs)
-> (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)))
-> (Subst (LHsExpr GhcPs) -> Subst (LHsExpr GhcPs))
-> Subst (LHsExpr GhcPs)
-> (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(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 (LHsExpr GhcPs)))
-> Maybe (Subst (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (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 (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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 NameMatch
nm Bool
root x :: LHsExpr GhcPs
x@(L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x1 LHsExpr GhcPs
x2)) (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
y1 LHsExpr GhcPs
y2)) =
((, Maybe (LHsExpr GhcPs)
forall a. Maybe a
Nothing) (Subst (LHsExpr GhcPs)
-> (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)))
-> Maybe (Subst (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (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 (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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 (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyComposed
where
unifyComposed :: Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
unifyComposed
| (L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
y11 LHsExpr GhcPs
dot LHsExpr GhcPs
y12)) <- LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
y1, LHsExpr GhcPs -> Bool
isDot LHsExpr GhcPs
dot =
if Bool -> Bool
not Bool
root then
(, Maybe (LHsExpr GhcPs)
forall a. Maybe a
Nothing) (Subst (LHsExpr GhcPs)
-> (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)))
-> Maybe (Subst (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (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
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 NoExtField
XApp GhcPs
noExtField 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 NoExtField
XApp GhcPs
noExtField LHsExpr GhcPs
y12 LHsExpr GhcPs
y2))))
else do
Subst (LHsExpr GhcPs)
rhs <- NameMatch
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs))
unifyExp' NameMatch
nm Bool
False LHsExpr GhcPs
x2 LHsExpr GhcPs
y2
(Subst (LHsExpr GhcPs)
lhs, Maybe (LHsExpr 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 (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Subst (LHsExpr GhcPs)
lhs Subst (LHsExpr GhcPs)
-> Subst (LHsExpr GhcPs) -> Subst (LHsExpr GhcPs)
forall a. Semigroup a => a -> a -> a
<> Subst (LHsExpr GhcPs)
rhs, Maybe (LHsExpr GhcPs)
extra)
| Bool
otherwise = Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
forall a. Maybe a
Nothing
unifyExp NameMatch
nm Bool
root LHsExpr GhcPs
x (L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs2 op2 :: LHsExpr GhcPs
op2@(L SrcSpan
_ (HsVar XVar GhcPs
_ Located (IdP GhcPs)
op2')) LHsExpr GhcPs
rhs2))
| (L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs1 op1 :: LHsExpr GhcPs
op1@(L SrcSpan
_ (HsVar XVar GhcPs
_ Located (IdP GhcPs)
op1')) LHsExpr GhcPs
rhs1)) <- LHsExpr GhcPs
x =
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (NameMatch
nm Located (IdP GhcPs)
Located RdrName
op1' Located (IdP GhcPs)
Located RdrName
op2') Maybe ()
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (, Maybe (LHsExpr GhcPs)
forall a. Maybe a
Nothing) (Subst (LHsExpr GhcPs)
-> (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)))
-> Maybe (Subst (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (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 (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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), 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
$ 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 NoExtField
XApp GhcPs
noExtField LHsExpr GhcPs
lhs2 LHsExpr GhcPs
rhs2)
| 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
$ 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 NoExtField
XApp GhcPs
noExtField (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 NoExtField
XApp GhcPs
noExtField LHsExpr GhcPs
op2 LHsExpr GhcPs
lhs2)) LHsExpr GhcPs
rhs2)
unifyExp NameMatch
nm Bool
root LHsExpr GhcPs
x LHsExpr GhcPs
y = (, Maybe (LHsExpr GhcPs)
forall a. Maybe a
Nothing) (Subst (LHsExpr GhcPs)
-> (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)))
-> Maybe (Subst (LHsExpr GhcPs))
-> Maybe (Subst (LHsExpr GhcPs), Maybe (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
root LHsExpr GhcPs
x LHsExpr GhcPs
y
noExtra :: Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs)) -> Maybe (Subst (LHsExpr GhcPs))
(Just (Subst (LHsExpr GhcPs)
x, Maybe (LHsExpr GhcPs)
Nothing)) = Subst (LHsExpr GhcPs) -> Maybe (Subst (LHsExpr GhcPs))
forall a. a -> Maybe a
Just Subst (LHsExpr GhcPs)
x
noExtra Maybe (Subst (LHsExpr GhcPs), Maybe (LHsExpr GhcPs))
_ = Maybe (Subst (LHsExpr GhcPs))
forall a. Maybe a
Nothing
unifyExp' :: NameMatch -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst (LHsExpr GhcPs))
unifyExp' :: NameMatch
-> Bool
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Maybe (Subst (LHsExpr GhcPs))
unifyExp' NameMatch
nm Bool
root LHsExpr GhcPs
x 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
unifyExp' NameMatch
nm Bool
root (L SrcSpan
_ (HsVar XVar GhcPs
_ (Located (IdP GhcPs) -> String
Located 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, LHsExpr GhcPs)] -> Subst (LHsExpr GhcPs)
forall a. [(String, a)] -> Subst a
Subst [(String
v, LHsExpr GhcPs
y)]
unifyExp' NameMatch
nm Bool
root (L SrcSpan
_ (HsVar XVar GhcPs
_ Located (IdP GhcPs)
x)) (L SrcSpan
_ (HsVar XVar GhcPs
_ Located (IdP GhcPs)
y)) | NameMatch
nm Located (IdP GhcPs)
Located RdrName
x Located (IdP GhcPs)
Located RdrName
y = Subst (LHsExpr GhcPs) -> Maybe (Subst (LHsExpr GhcPs))
forall a. a -> Maybe a
Just Subst (LHsExpr GhcPs)
forall a. Monoid a => a
mempty
unifyExp' NameMatch
nm Bool
root x :: LHsExpr GhcPs
x@(L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs1 (L SrcSpan
_ (HsVar XVar GhcPs
_ (Located (IdP GhcPs) -> String
Located RdrName -> String
rdrNameStr -> String
v))) LHsExpr GhcPs
rhs1))
y :: LHsExpr GhcPs
y@(L SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs2 (L SrcSpan
_ (HsVar XVar GhcPs
_ Located (IdP 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 SrcSpan
_ (SectionL XSectionL GhcPs
_ LHsExpr GhcPs
exp1 (L SrcSpan
_ (HsVar XVar GhcPs
_ (Located (IdP GhcPs) -> String
Located RdrName -> String
rdrNameStr -> String
v)))))
(L SrcSpan
_ (SectionL XSectionL GhcPs
_ LHsExpr GhcPs
exp2 (L SrcSpan
_ (HsVar XVar GhcPs
_ (Located (IdP GhcPs) -> String
Located RdrName -> String
rdrNameStr -> String
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' NameMatch
nm Bool
root (L SrcSpan
_ (SectionR XSectionR GhcPs
_ (L SrcSpan
_ (HsVar XVar GhcPs
_ (Located (IdP GhcPs) -> String
Located RdrName -> String
rdrNameStr -> String
v))) LHsExpr GhcPs
exp1))
(L SrcSpan
_ (SectionR XSectionR GhcPs
_ (L SrcSpan
_ (HsVar XVar GhcPs
_ (Located (IdP GhcPs) -> String
Located RdrName -> String
rdrNameStr -> String
op2))) LHsExpr GhcPs
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
unifyExp' NameMatch
nm Bool
root x :: LHsExpr GhcPs
x@(L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
x1 LHsExpr GhcPs
x2)) y :: LHsExpr GhcPs
y@(L SrcSpan
_ (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 SrcSpan
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs2 op2 :: LHsExpr GhcPs
op2@(L SrcSpan
_ (HsVar XVar GhcPs
_ Located (IdP 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 LHsExpr GhcPs
x 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
{-# INLINE isOther #-}
isOther :: LHsExpr GhcPs -> Bool
isOther :: LHsExpr GhcPs -> Bool
isOther (L SrcSpan
_ HsVar{}) = Bool
False
isOther (L SrcSpan
_ HsApp{}) = Bool
False
isOther (L SrcSpan
_ OpApp{}) = Bool
False
isOther LHsExpr GhcPs
_ = Bool
True
unifyExp' NameMatch
_ Bool
_ LHsExpr GhcPs
_ LHsExpr GhcPs
_ = 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' NameMatch
nm (L _ (VarPat _ x)) (L _ (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 (IdP GhcPs)
Located RdrName
x, String -> LHsExpr GhcPs
strToVar(Located RdrName -> String
rdrNameStr Located (IdP GhcPs)
Located RdrName
y))]
unifyPat' NameMatch
nm (L _ (VarPat _ x)) (L _ (WildPat _)) =
let s :: String
s = Located RdrName -> String
rdrNameStr Located (IdP GhcPs)
Located 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, LHsExpr GhcPs)] -> Subst (LHsExpr 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 _ (ConPatIn x _)) (L _ (ConPatIn y _)) | Located RdrName -> String
rdrNameStr Located (IdP GhcPs)
Located RdrName
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= Located RdrName -> String
rdrNameStr Located (IdP GhcPs)
Located RdrName
y =
Maybe (Subst (LHsExpr GhcPs))
forall a. Maybe a
Nothing
unifyPat' NameMatch
nm LPat GhcPs
x LPat GhcPs
y =
NameMatch
-> Located (Pat GhcPs)
-> Located (Pat GhcPs)
-> Maybe (Subst (LHsExpr GhcPs))
forall a.
Data a =>
NameMatch -> a -> a -> Maybe (Subst (LHsExpr GhcPs))
unifyDef' NameMatch
nm LPat GhcPs
Located (Pat GhcPs)
x LPat GhcPs
Located (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 SrcSpan
loc (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ Located (IdP GhcPs)
x)) LHsType GhcPs
y =
let wc :: HsWildCardBndrs (NoGhcTc GhcPs) (LHsType (NoGhcTc GhcPs))
wc = XHsWC GhcPs (LHsType GhcPs)
-> LHsType GhcPs -> HsWildCardBndrs GhcPs (LHsType GhcPs)
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC NoExtField
XHsWC GhcPs (LHsType GhcPs)
noExtField LHsType GhcPs
y :: LHsWcType (NoGhcTc GhcPs)
unused :: LHsExpr GhcPs
unused = String -> LHsExpr GhcPs
strToVar String
"__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
-> HsWildCardBndrs (NoGhcTc GhcPs) (LHsType (NoGhcTc GhcPs))
-> HsExpr GhcPs
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExtField
XAppTypeE GhcPs
noExtField LHsExpr GhcPs
unused HsWildCardBndrs GhcPs (LHsType GhcPs)
HsWildCardBndrs (NoGhcTc GhcPs) (LHsType (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 (IdP GhcPs)
Located RdrName
x, LHsExpr GhcPs
appType)]
unifyType' NameMatch
nm LHsType GhcPs
x 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