ref: 5adafcfcd69e953c2a8119659a63e62e59eb9f93
parent: e30c1f64330c04c4a587dff80c171416a18acf74
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Mon Oct 23 07:25:30 EDT 2023
Get rid of eqIdent.
--- a/src/Compat.hs
+++ b/src/Compat.hs
@@ -205,6 +205,9 @@
compareString :: String -> String -> Ordering
compareString = compare
+anySame :: (Eq a) => [a] -> Bool
+anySame = anySameBy (==)
+
anySameBy :: (a -> a -> Bool) -> [a] -> Bool
anySameBy _ [] = False
anySameBy eq (x:xs) = elemBy eq x xs || anySameBy eq xs
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -92,7 +92,7 @@
case M.lookup nm ch of
Nothing -> S.do
ws <- gets working
- S.when (elemBy eqIdent nm ws) $
+ S.when (elem nm ws) $
error $ "recursive module: " ++ showIdent nm
modify $ \ c -> updWorking (nm : working c) c
S.when (verbose flags > 0) $
@@ -120,7 +120,7 @@
let mdl@(EModule nmn _ defs) = parseDie pTop pathfn file
-- liftIO $ putStrLn $ showEModule mdl
-- liftIO $ putStrLn $ showEDefs defs
- S.when (not (eqIdent nm nmn)) $
+ S.when (nm /= nmn) $
error $ "module name does not agree with file name: " ++ showIdent nm ++ " " ++ showIdent nmn
let
specs = [ s | Import s <- defs ]
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -115,7 +115,7 @@
dsAlt :: Expr -> [EStmt] -> Expr -> Expr
dsAlt _ [] rhs = rhs
dsAlt dflt (SBind p e : ss) rhs = ECase e [(p, EAlts [(ss, rhs)] []), (EVar dummyIdent, oneAlt dflt)]
-dsAlt dflt (SThen (EVar i) : ss) rhs | eqIdent i (mkIdent "Data.Bool.otherwise") = dsAlt dflt ss rhs
+dsAlt dflt (SThen (EVar i) : ss) rhs | i == mkIdent "Data.Bool.otherwise" = dsAlt dflt ss rhs
dsAlt dflt (SThen e : ss) rhs = EIf e (dsAlt dflt ss rhs) dflt
dsAlt dflt (SLet bs : ss) rhs = ELet bs (dsAlt dflt ss rhs)
@@ -273,7 +273,7 @@
apps f = foldl App f
newVars :: String -> [Ident] -> [Ident]
-newVars s is = deleteAllsBy eqIdent [ mkIdent (s ++ showInt i) | i <- enumFrom 1 ] is
+newVars s is = deleteAllsBy (==) [ mkIdent (s ++ showInt i) | i <- enumFrom 1 ] is
newVar :: [Ident] -> Ident
newVar = head . newVars "q"
@@ -430,7 +430,7 @@
arm ck =
let
(c, k) = ck
- (vs, rhs) = head $ [ (xs, e) | (SPat (ConData _ i) xs, e) <- pes, eqIdent c i ] ++
+ (vs, rhs) = head $ [ (xs, e) | (SPat (ConData _ i) xs, e) <- pes, c == i ] ++
[ (replicate k dummyIdent, dflt) ]
in (SPat (ConData cs c) vs, rhs)
in eCase var (map arm cs)
@@ -460,7 +460,7 @@
-- Change from x to y inside e.
substAlpha :: Ident -> Exp -> Exp -> Exp
substAlpha x y e =
- if eqIdent x dummyIdent then
+ if x == dummyIdent then
e
else
substExp x y e
@@ -467,13 +467,13 @@
eLet :: Ident -> Exp -> Exp -> Exp
eLet i e b =
- if eqIdent i dummyIdent then
+ if i == dummyIdent then
b
else
case b of
- Var j | eqIdent i j -> e
+ Var j | i == j -> e
_ ->
- case filter (eqIdent i) (freeVars b) of
+ case filter (== i) (freeVars b) of
[] -> b -- no occurences, no need to bind
[_] -> substExp i e b -- single occurrence, substitute XXX could be worse if under lambda
_ -> App (Lam i b) e -- just use a beta redex
@@ -510,7 +510,7 @@
checkDup :: [LDef] -> [LDef]
checkDup ds =
- case getDups eqIdent (filter (not . eqIdent dummyIdent) $ map fst ds) of
+ case getDups (==) (filter (/= dummyIdent) $ map fst ds) of
[] -> ds
(i1:_i2:_) : _ ->
errorMessage (getSLocIdent i1) $ "duplicate definition " ++ showIdent i1
--- a/src/MicroHs/Exp.hs
+++ b/src/MicroHs/Exp.hs
@@ -59,9 +59,9 @@
--Winstance NFData Exp where rnf (Var i) = rnf i; rnf (App f a) = rnf f `seq` rnf a; rnf (Lam i e) = rnf i `seq` rnf e; rnf (Lit l) = rnf l
eqExp :: Exp -> Exp -> Bool
-eqExp (Var i1) (Var i2) = eqIdent i1 i2
+eqExp (Var i1) (Var i2) = i1 == i2
eqExp (App f1 a1) (App f2 a2) = eqExp f1 f2 && eqExp a1 a2
-eqExp (Lam i1 e1) (Lam i2 e2) = eqIdent i1 i2 && eqExp e1 e2
+eqExp (Lam i1 e1) (Lam i2 e2) = i1 == i2 && eqExp e1 e2
eqExp (Lit l1) (Lit l2) = eqLit l1 l2
eqExp _ _ = False
@@ -202,7 +202,7 @@
abstract :: Ident -> Exp -> Exp
abstract x ae =
case ae of
- Var y -> if eqIdent x y then cId else cK (Var y)
+ Var y -> if x == y then cId else cK (Var y)
App f a -> cS (abstract x f) (abstract x a)
Lam y e -> abstract x $ abstract y e
Lit _ -> cK ae
@@ -298,7 +298,7 @@
case getVar a1 of
Nothing -> r
Just op ->
- case lookupBy eqIdent op flipOps of
+ case lookup op flipOps of
Just oq -> App (Var oq) a2
Nothing -> r
{-@@ -453,15 +453,15 @@
substExp :: Ident -> Exp -> Exp -> Exp
substExp si se ae =
case ae of
- Var i -> if eqIdent i si then se else ae
+ Var i -> if i == si then se else ae
App f a -> App (substExp si se f) (substExp si se a)
- Lam i e -> if eqIdent si i then
+ Lam i e -> if si == i then
ae
- else if elemBy eqIdent i (freeVars se) then
+ else if elem i (freeVars se) then
let
fe = allVarsExp e
ase = allVarsExp se
- j = head [ v | n <- enumFrom 0, let { v = mkIdent ("a" ++ showInt n) }, not (elemBy eqIdent v ase), not (elemBy eqIdent v fe) ]+ j = head [ v | n <- enumFrom 0, let { v = mkIdent ("a" ++ showInt n) }, not (elem v ase), not (elem v fe) ]in
--trace ("substExp " ++ unwords [si, i, j]) $Lam j (substExp si se (substExp i (Var j) e))
@@ -474,7 +474,7 @@
case ae of
Var i -> [i]
App f a -> freeVars f ++ freeVars a
- Lam i e -> deleteAllBy eqIdent i (freeVars e)
+ Lam i e -> deleteAllBy (==) i (freeVars e)
Lit _ -> []
allVarsExp :: Exp -> [Ident]
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -124,13 +124,13 @@
conIdent _ = error "conIdent"
conArity :: Con -> Int
-conArity (ConData cs i) = fromMaybe (error "conArity") $ lookupBy eqIdent i cs
+conArity (ConData cs i) = fromMaybe (error "conArity") $ lookup i cs
conArity (ConNew _) = 1
conArity (ConLit _) = 0
eqCon :: Con -> Con -> Bool
-eqCon (ConData _ i) (ConData _ j) = eqIdent i j
-eqCon (ConNew i) (ConNew j) = eqIdent i j
+eqCon (ConData _ i) (ConData _ j) = i == j
+eqCon (ConNew i) (ConNew j) = i == j
eqCon (ConLit l) (ConLit k) = eqLit l k
eqCon _ _ = False
@@ -251,11 +251,11 @@
let
sub ae =
case ae of
- EVar i -> fromMaybe ae $ lookupBy eqIdent i s
+ EVar i -> fromMaybe ae $ lookup i s
EApp f a -> EApp (sub f) (sub a)
ESign e t -> ESign (sub e) t
EUVar _ -> ae
- EForall iks t -> EForall iks $ subst [ x | x@(i, _) <- s, not (elemBy eqIdent i is) ] t
+ EForall iks t -> EForall iks $ subst [ x | x@(i, _) <- s, not (elem i is) ] t
where is = map idKindIdent iks
_ -> error "subst unimplemented"
in sub
@@ -264,7 +264,7 @@
-- XXX needs more?
eqEType :: EType -> EType -> Bool
-eqEType (EVar i) (EVar i') = eqIdent i i'
+eqEType (EVar i) (EVar i') = i == i'
eqEType (EApp f a) (EApp f' a') = eqEType f f' && eqEType a a'
eqEType _ _ = False
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -3,7 +3,7 @@
module MicroHs.Ident(
Line, Col, Loc,
Ident(..),
- mkIdent, mkIdentLoc, unIdent, eqIdent, leIdent, qualIdent, showIdent, getSLocIdent, setSLocIdent,
+ mkIdent, mkIdentLoc, unIdent, leIdent, qualIdent, showIdent, getSLocIdent, setSLocIdent,
ppIdent,
mkIdentSLoc,
isLower_, isIdentChar, isOperChar, isConIdent,
@@ -15,11 +15,12 @@
showSLoc,
compareIdent,
) where
+import Data.Eq
import Prelude --Xhiding(showString)
---Ximport Control.DeepSeq
---Yimport Primitives(NFData(..))
import Data.Char
import Text.PrettyPrint.HughesPJ
+--Ximport Control.DeepSeq
+--Yimport Primitives(NFData(..))
--Ximport Compat
--Ximport GHC.Stack
@@ -31,9 +32,12 @@
--Xderiving (Show, Eq)
data Ident = Ident SLoc String
- --Xderiving (Show, Eq)
+ --Xderiving (Show)
--Winstance NFData Ident where rnf (Ident _ s) = rnf s
+instance Eq Ident where
+ Ident _ i == Ident _ j = i == j
+
noSLoc :: SLoc
noSLoc = SLoc "" 0 0
@@ -64,9 +68,6 @@
ppIdent :: Ident -> Doc
ppIdent (Ident _ i) = text i
-
-eqIdent :: Ident -> Ident -> Bool
-eqIdent (Ident _ i) (Ident _ j) = i == j
leIdent :: Ident -> Ident -> Bool
leIdent (Ident _ i) (Ident _ j) = leString i j
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -390,7 +390,7 @@
-- don't collect equations when of the form 'i = e'
P.pure (name, [eqn])
_ -> P.do
- neqns <- emany (pSpec ';' *> pEqn (\ n l -> eqIdent n name && l == length ps))
+ neqns <- emany (pSpec ';' *> pEqn (\ n l -> n == name && l == length ps))
P.pure (name, eqn : map snd neqns)
pEqn :: (Ident -> Int -> Bool) -> P (Ident, Eqn)
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -116,7 +116,7 @@
sexps = M.toList (synTable tcs)
cexps = [ ce | TModule _ _ _ _ ce _ _ _ <- M.elems impMap ]
iexps = M.toList (instTable tcs)
- in tModule mn (nubBy (eqIdent `on` fst) (concat fexps)) (concat texps) sexps (concat cexps) iexps (concat vexps) tds
+ in tModule mn (nubBy ((==) `on` fst) (concat fexps)) (concat texps) sexps (concat cexps) iexps (concat vexps) tds
-- A hack to force evaluation of errors.
-- This should be redone to all happen in the T monad.
@@ -134,7 +134,7 @@
filterImports it@(ImportSpec _ _ _ Nothing, _) = it
filterImports (imp@(ImportSpec _ _ _ (Just (hide, is))), TModule mn fx ts ss cs ins vs a) =
let
- keep x xs = elemBy eqIdent x xs `neBool` hide
+ keep x xs = elem x xs `neBool` hide
ivs = [ i | ImpValue i <- is ]
vs' = filter (\ (ValueExport i _) -> keep i ivs) vs
cts = [ i | ImpTypeCon i <- is ]
@@ -312,7 +312,7 @@
case x of
Entry ix _ ->
case y of
- Entry iy _ -> eqIdent (getIdent ix) (getIdent iy)
+ Entry iy _ -> (getIdent ix) == (getIdent iy)
getIdent :: Expr -> Ident
getIdent ae =
@@ -332,7 +332,7 @@
-- Very partial implementation of Expr equality.
-- It is only used to compare instances, so this suffices.
eqExpr :: Expr -> Expr -> Bool
-eqExpr (EVar i) (EVar i') = eqIdent i i'
+eqExpr (EVar i) (EVar i') = i == i'
eqExpr (EApp f a) (EApp f' a') = eqExpr f f' && eqExpr a a'
eqExpr _ _ = False
@@ -587,12 +587,12 @@
getArrow :: EType -> Maybe (EType, EType)
getArrow (EApp (EApp (EVar n) a) b) =
- if eqIdent n (mkIdent "->") || eqIdent n (mkIdent "Primitives.->") then Just (a, b) else Nothing
+ if n == mkIdent "->" || n == mkIdent "Primitives.->" then Just (a, b) else Nothing
getArrow _ = Nothing
getImplies :: EType -> Maybe (EType, EType)
getImplies (EApp (EApp (EVar n) a) b) =
- if eqIdent n (mkIdent "=>") || eqIdent n (mkIdent "Primitives.=>") then Just (a, b) else Nothing
+ if n == mkIdent "=>" || n == mkIdent "Primitives.=>" then Just (a, b) else Nothing
getImplies _ = Nothing
{-@@ -679,7 +679,7 @@
-- XXX should do occur check
unifyR :: --XHasCallStack =>
SLoc -> EType -> EType -> T ()
-unifyR _ (EVar x1) (EVar x2) | eqIdent x1 x2 = T.return ()
+unifyR _ (EVar x1) (EVar x2) | x1 == x2 = T.return ()
unifyR loc (EApp f1 a1) (EApp f2 a2) = T.do { unifyR loc f1 f2; unifyR loc a1 a2 }unifyR _ (EUVar r1) (EUVar r2) | r1 == r2 = T.return ()
unifyR loc (EUVar r1) t2 = unifyVar loc r1 t2
@@ -922,7 +922,7 @@
case adef of
Data lhs@(i, _) cs -> T.do
addLHSKind lhs kType
- addAssoc i (nubBy eqIdent $ concatMap assocData cs)
+ addAssoc i (nub $ concatMap assocData cs)
Newtype lhs@(i, _) c -> T.do
addLHSKind lhs kType
addAssoc i (assocData c)
@@ -1041,7 +1041,7 @@
meths = [ b | b@(BSign _ _) <- ms ]
mdflts = [ (i, eqns) | BFcn i eqns <- ms ]
tCtx = tApps (qualIdent mn iCls) (map (EVar . idKindIdent) vks)
- mkDflt (BSign methId t) = [ Sign iDflt $ EForall vks $ tCtx `tImplies` t, def $ lookupBy eqIdent methId mdflts ]
+ mkDflt (BSign methId t) = [ Sign iDflt $ EForall vks $ tCtx `tImplies` t, def $ lookup methId mdflts ]
where def Nothing = Fcn iDflt [Eqn [] $ EAlts [([], noDflt)] []]
def (Just eqns) = Fcn iDflt eqns
iDflt = mkDefaultMethodId methId
@@ -1101,7 +1101,7 @@
f b = S.return b
in S.runState (S.mapM f bs) (1, [])
meths = map meth mis
- where meth i = EVar $ fromMaybe (mkDefaultMethodId i) $ lookupBy eqIdent i ims
+ where meth i = EVar $ fromMaybe (mkDefaultMethodId i) $ lookup i ims
sups = map (const (EVar $ mkIdentSLoc loc "dict$")) supers
args = sups ++ meths
let bind = Fcn iInst [Eqn [] $ EAlts [([], foldl EApp (EVar $ mkClassConstructor iCls) args)] bs']
@@ -1317,7 +1317,7 @@
_ -> impossible
T.return p
- _ | eqIdent i (mkIdent "dict$") -> T.do
+ _ | i == mkIdent "dict$" -> T.do
-- Magic variable that just becomes the dictionary
d <- newIdent (getSLocIdent i) "dict$"
case mt of
@@ -1623,7 +1623,7 @@
(skol_tvs, rho2) <- skolemise sigma2
exp1' <- subsCheckRho loc exp1 sigma1 rho2
esc_tvs <- getFreeTyVars [sigma1,sigma2]
- let bad_tvs = filter (\ i -> elemBy eqIdent i esc_tvs) skol_tvs
+ let bad_tvs = filter (\ i -> elem i esc_tvs) skol_tvs
T.when (not (null bad_tvs)) $
tcErrorTK loc "Subsumption check failed"
T.return exp1'
@@ -1643,7 +1643,7 @@
multCheck :: [Ident] -> T ()
multCheck vs =
- T.when (anySameBy eqIdent vs) $ T.do
+ T.when (anySame vs) $ T.do
let v = head vs
tcError (getSLocIdent v) $ "Multiply defined: " ++ showIdent v
@@ -1821,8 +1821,8 @@
-> [TyVar] -- Accumulates result
-> [TyVar]
go bound (EVar tv) acc
- | elemBy eqIdent tv bound = acc
- | elemBy eqIdent tv acc = acc
+ | elem tv bound = acc
+ | elem tv acc = acc
| otherwise = tv : acc
go bound (EForall tvs ty) acc = go (map idKindIdent tvs ++ bound) ty acc
go bound (EApp fun arg) acc = go bound fun (go bound arg acc)
@@ -1872,7 +1872,7 @@
else T.do
env_tys <- getEnvTypes
esc_tvs <- getFreeTyVars (sigma : env_tys)
- let bad_tvs = filter (\ i -> elemBy eqIdent i esc_tvs) skol_tvs
+ let bad_tvs = filter (\ i -> elem i esc_tvs) skol_tvs
T.when (not (null bad_tvs)) $
tcErrorTK (getSLocExpr expr) "not polymorphic enough"
T.return expr'
@@ -2042,7 +2042,7 @@
freshSubst iks = zipWith (\ ik j -> (idKindIdent ik, EUVar j)) iks [1000000000 ..] -- make sure the variables are unique
-- Match two types, instantiate variables in the first type.
- matchType r (EVar i) (EVar i') | eqIdent i i' = Just r
+ matchType r (EVar i) (EVar i') | i == i' = Just r
matchType r (EApp f a) (EApp f' a') = -- XXX should use Maybe monad
case matchType r f f' of
Nothing -> Nothing
--
⑨