ref: 438daa9fe8ac25e42c03daa80f47df5cd96df31b
parent: e1b4550f375353697edeab91345f9c1e9dbecdd5
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Thu Nov 23 19:50:22 EST 2023
Get rid of --X. This incurs a small slowdown. :(
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -244,7 +244,7 @@
in App tup (foldr Lam (Var (xs !! m)) xs)
-- Handle special syntax for lists and tuples
-dsPat :: --XHasCallStack =>
+dsPat :: HasCallStack =>
EPat -> EPat
dsPat ap =
case ap of
@@ -346,7 +346,7 @@
-- p21, ..., p2n
-- pm1, ..., pmn -> em
-- Note that the RHSs are of type Exp.
-dsMatrix :: --XHasCallStack =>
+dsMatrix :: HasCallStack =>
Exp -> [Exp] -> Matrix -> M Exp
dsMatrix dflt iis aarms =
if null aarms then
@@ -487,7 +487,7 @@
[_] -> substExp i e b -- single occurrence, substitute XXX could be worse if under lambda
_ -> App (Lam i b) e -- just use a beta redex
-pConOf :: --XHasCallStack =>
+pConOf :: HasCallStack =>
EPat -> Con
pConOf ap =
case ap of
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -123,7 +123,7 @@
| LFromThenTo Expr Expr Expr
--deriving(Show, Eq)
-conIdent :: --XHasCallStack =>
+conIdent :: HasCallStack =>
Con -> Ident
conIdent (ConData _ i) = i
conIdent (ConNew i) = i
@@ -358,7 +358,7 @@
-- Very partial implementation of Expr equality.
-- It is only used to compare instances, so this suffices.
-eqExpr :: --XHasCallStack =>
+eqExpr :: HasCallStack =>
Expr -> Expr -> Bool
eqExpr (EVar i) (EVar i') = i == i'
eqExpr (EVar _) (EApp _ _) = False
@@ -444,8 +444,9 @@
setSLocCon l (ConNew i) = ConNew (setSLocIdent l i)
setSLocCon _ c = c
-errorMessage :: --XHasCallStack =>
- forall a . SLoc -> String -> a
+errorMessage :: forall a .
+ HasCallStack =>
+ SLoc -> String -> a
errorMessage loc msg = error $ showSLoc loc ++ ": " ++ msg
----------------
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -78,7 +78,7 @@
isIdent :: String -> Ident -> Bool
isIdent s (Ident _ i) = s == i
-qualIdent :: --XHasCallStack =>
+qualIdent :: HasCallStack =>
Ident -> Ident -> Ident
qualIdent (Ident _ qi) (Ident loc i) = Ident loc (qi ++ "." ++ i)
@@ -85,7 +85,7 @@
addIdentSuffix :: Ident -> String -> Ident
addIdentSuffix (Ident loc i) s = Ident loc (i ++ s)
-unQualString :: --XHasCallStack =>
+unQualString :: HasCallStack =>
String -> String
unQualString [] = ""
unQualString s@(c:_) =
--- a/src/MicroHs/TCMonad.hs
+++ b/src/MicroHs/TCMonad.hs
@@ -22,8 +22,9 @@
tcRun :: forall s a . TC s a -> s -> (a, s)
tcRun = runState
-tcError :: --XHasCallStack =>
- forall s a . SLoc -> String -> TC s a
+tcError :: forall s a .
+ HasCallStack =>
+ SLoc -> String -> TC s a
tcError = errorMessage
instance MonadFail Identity where fail = error
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -705,12 +705,12 @@
getUVar :: Int -> T (Maybe EType)
getUVar i = gets (IM.lookup i . uvarSubst)
-munify :: --XHasCallStack =>
+munify :: HasCallStack =>
SLoc -> Expected -> EType -> T ()
munify loc (Infer r) b = tSetRefType loc r b
munify loc (Check a) b = unify loc a b
-expandSyn :: --XHasCallStack =>
+expandSyn :: HasCallStack =>
EType -> T EType
expandSyn at =
let
@@ -753,7 +753,7 @@
EForall iks t -> EForall iks <$> derefUVar t
_ -> impossible
-tcErrorTK :: --XHasCallStack =>
+tcErrorTK :: HasCallStack =>
SLoc -> String -> T ()
tcErrorTK loc msg = do
tcm <- gets tcMode
@@ -762,7 +762,7 @@
_ -> "type"
tcError loc $ s ++ " error: " ++ msg
-unify :: --XHasCallStack =>
+unify :: HasCallStack =>
SLoc -> EType -> EType -> T ()
unify loc a b = do
aa <- expandSyn a
@@ -770,7 +770,7 @@
unifyR loc aa bb
-- XXX should do occur check
-unifyR :: --XHasCallStack =>
+unifyR :: HasCallStack =>
SLoc -> EType -> EType -> T ()
unifyR _ (EVar x1) (EVar x2) | x1 == x2 = return ()
unifyR loc (EApp f1 a1) (EApp f2 a2) = do { unifyR loc f1 f2; unifyR loc a1 a2 }@@ -785,7 +785,7 @@
-- XXX needs changing if we have kind equalities.
_ -> addEqConstraint loc t1 t2
-unifyVar :: --XHasCallStack =>
+unifyVar :: HasCallStack =>
SLoc -> TRef -> EType -> T ()
unifyVar loc r t = do
mt <- getUVar r
@@ -793,7 +793,7 @@
Nothing -> unifyUnboundVar loc r t
Just t' -> unify loc t' t
-unifyUnboundVar :: --XHasCallStack =>
+unifyUnboundVar :: HasCallStack =>
SLoc -> TRef -> EType -> T ()
unifyUnboundVar loc r1 at2@(EUVar r2) = do
-- We know r1 /= r2
@@ -831,7 +831,7 @@
u <- newUniq
return $ mkIdentSLoc loc $ s ++ "$" ++ show u
-tLookup :: --XHasCallStack =>
+tLookup :: HasCallStack =>
String -> Ident -> T (Expr, EType)
tLookup msg i = do
env <- gets valueTable
@@ -842,7 +842,7 @@
-- traceM (showListS showIdent (map fst (M.toList m)))
tcError (getSLoc i) e
-tLookupV :: --XHasCallStack =>
+tLookupV :: HasCallStack =>
Ident -> T (Expr, EType)
tLookupV i = do
tcm <- gets tcMode
@@ -873,7 +873,7 @@
tInst' (ae, EForall vks t) = tInstForall ae vks t
tInst' et = return et
-extValE :: --XHasCallStack =>
+extValE :: HasCallStack =>
Ident -> EType -> Expr -> T ()
extValE i t e = do
venv <- gets valueTable
@@ -881,7 +881,7 @@
-- Extend the global symbol table with i = e :: t
-- Add both qualified and unqualified versions of i.
-extValETop :: --XHasCallStack =>
+extValETop :: HasCallStack =>
Ident -> EType -> Expr -> T ()
extValETop i t e = do
mn <- gets moduleName
@@ -894,17 +894,17 @@
-- Extend symbol table with i::t.
-- The translation for i will be the qualified name.
-- Add both qualified and unqualified versions of i.
-extValQTop :: --XHasCallStack =>
+extValQTop :: HasCallStack =>
Ident -> EType -> T ()
extValQTop i t = do
mn <- gets moduleName
extValETop i t (EVar (qualIdent mn i))
-extVal :: --XHasCallStack =>
+extVal :: HasCallStack =>
Ident -> EType -> T ()
extVal i t = extValE i t $ EVar i
-extVals :: --XHasCallStack =>
+extVals :: HasCallStack =>
[(Ident, EType)] -> T ()
extVals = mapM_ (uncurry extVal)
@@ -927,7 +927,7 @@
put $ TC mn n (M.insert i fx fenv) tenv senv venv ast sub m cs is es ds
return ()
-withExtVal :: forall a . --XHasCallStack =>
+withExtVal :: forall a . HasCallStack =>
Ident -> EType -> T a -> T a
withExtVal i t ta = do
venv <- gets valueTable
@@ -936,7 +936,7 @@
putValueTable venv
return a
-withExtVals :: forall a . --XHasCallStack =>
+withExtVals :: forall a . HasCallStack =>
[(Ident, EType)] -> T a -> T a
withExtVals env ta = do
venv <- gets valueTable
@@ -1298,7 +1298,7 @@
unForall t = ([], t)
-}
-tcDefValue :: --XHasCallStack =>
+tcDefValue :: HasCallStack =>
EDef -> T EDef
tcDefValue adef =
case adef of
@@ -1323,18 +1323,18 @@
tInferTypeT t = fst <$> tInfer tcTypeT t
-- Kind check a type while already in type checking mode
-tcTypeT :: --XHasCallStack =>
+tcTypeT :: HasCallStack =>
Expected -> EType -> T EType
tcTypeT mk t = withTCMode TCType (tcExpr mk (dsType t))
-- Kind check a type while in value checking mode
-tcType :: --XHasCallStack =>
+tcType :: HasCallStack =>
Expected -> EType -> T EType
tcType mk = withTypeTable . tcTypeT mk
{--- Sort check a kind while already in type cheking mode
-tcKind :: --XHasCallStack =>
+tcKind :: HasCallStack =>
EKind -> T EKind
tcKind e = fst <$> withTypeTable (tcType (Just kType) e)
-}
@@ -1346,7 +1346,7 @@
data Expected = Infer TRef | Check EType
deriving(Show)
-tInfer :: forall a b . --XHasCallStack =>
+tInfer :: forall a b . HasCallStack =>
(Expected -> a -> T b) -> a -> T (Typed b)
tInfer tc a = do
ref <- newUniq
@@ -1357,11 +1357,11 @@
tCheck :: forall a b . (Expected -> a -> T b) -> EType -> a -> T b
tCheck tc t = tc (Check t)
-tInferExpr :: --XHasCallStack =>
+tInferExpr :: HasCallStack =>
Expr -> T (Typed Expr)
tInferExpr = tInfer tcExpr
-tCheckExpr :: --XHasCallStack =>
+tCheckExpr :: HasCallStack =>
EType -> Expr -> T Expr
tCheckExpr t _e | Just (_ctx, _t') <- getImplies t = do
undefined
@@ -1374,7 +1374,7 @@
-}
tCheckExpr t e = tCheck tcExpr t e
-tGetRefType :: --XHasCallStack =>
+tGetRefType :: HasCallStack =>
TRef -> T EType
tGetRefType ref = do
m <- gets uvarSubst
@@ -1383,7 +1383,7 @@
Just t -> return t
-- Set the type for an Infer
-tSetRefType :: --XHasCallStack =>
+tSetRefType :: HasCallStack =>
SLoc -> TRef -> EType -> T ()
tSetRefType loc ref t = do
m <- gets uvarSubst
@@ -1406,7 +1406,7 @@
return t-}
-}
-tcExpr :: --XHasCallStack =>
+tcExpr :: HasCallStack =>
Expected -> Expr -> T Expr
tcExpr mt ae = do
-- traceM ("tcExpr enter: " ++ showExpr ae)@@ -1413,7 +1413,7 @@
r <- tcExprR mt ae
-- traceM ("tcExpr exit: " ++ showExpr r)return r
-tcExprR :: --XHasCallStack =>
+tcExprR :: HasCallStack =>
Expected -> Expr -> T Expr
tcExprR mt ae =
let { loc = getSLoc ae } in@@ -1605,7 +1605,7 @@
-- tcOper is in T because it has to look up identifiers, and get the fixity table.
-- But there is no type checking happening here.
-tcOper :: --XHasCallStack =>
+tcOper :: HasCallStack =>
Expr -> [(Ident, Expr)] -> T Expr
tcOper ae aies = do
let
@@ -1640,7 +1640,7 @@
ites <- mapM (opfix fixs) aies
return $ calc [ae] [] ites
-unArrow :: --XHasCallStack =>
+unArrow :: HasCallStack =>
SLoc -> EType -> T (EType, EType)
unArrow loc t = do
case getArrow t of
@@ -1753,12 +1753,12 @@
eBinds :: [(Ident, Expr)] -> [EBind]
eBinds ds = [BFcn i [Eqn [] (EAlts [([], e)] [])] | (i, e) <- ds]
-instPatSigma :: --XHasCallStack =>
+instPatSigma :: HasCallStack =>
SLoc -> Sigma -> Expected -> T ()
instPatSigma loc pt (Infer r) = tSetRefType loc r pt
instPatSigma loc pt (Check t) = do { _ <- subsCheck loc undefined t pt; return () } -- XXX really?-subsCheck :: --XHasCallStack =>
+subsCheck :: HasCallStack =>
SLoc -> Expr -> Sigma -> Sigma -> T Expr
-- (subsCheck args off exp) checks that
-- 'off' is at least as polymorphic as 'args -> exp'
@@ -1980,12 +1980,14 @@
tBool :: SLoc -> EType
tBool loc = tConI loc $ boolPrefix ++ "Bool"
-impossible :: --XHasCallStack =>
- forall a . a
+impossible :: forall a .
+ HasCallStack =>
+ a
impossible = error "impossible"
-impossibleShow :: --XHasCallStack =>
- forall a b . (Show a, HasLoc a) => a -> b
+impossibleShow :: forall a b .
+ HasCallStack =>
+ (Show a, HasLoc a) => a -> b
impossibleShow a = error $ "impossible: " ++ show (getSLoc a) ++ " " ++ show a
showTModule :: forall a . (a -> String) -> TModule a -> String
@@ -2038,7 +2040,7 @@
sks <- mapM (newSkolemTyVar . idKindIdent) tvs
return (sks, subst (zip (map idKindIdent tvs) (map EVar sks)) ty)
-skolemise :: --XHasCallStack =>
+skolemise :: HasCallStack =>
Sigma -> T ([TyVar], Rho)
-- Performs deep skolemisation, returning the
-- skolem constants and the skolemised type.
@@ -2113,7 +2115,7 @@
(e',) <$> quantify forall_tvs exp_ty
-}
-checkSigma :: --XHasCallStack =>
+checkSigma :: HasCallStack =>
Expr -> Sigma -> T Expr
checkSigma expr sigma = do
(skol_tvs, rho) <- skolemise sigma
@@ -2129,7 +2131,7 @@
tcErrorTK (getSLoc expr) $ "not polymorphic enough: " ++ unwords (map showIdent bad_tvs)
return expr'
-subsCheckRho :: --XHasCallStack =>
+subsCheckRho :: HasCallStack =>
SLoc -> Expr -> Sigma -> Rho -> T Expr
--subsCheckRho _ e1 t1 t2 | trace ("subsCheckRho: " ++ {-showExpr e1 ++ " :: " ++ -} showEType t1 ++ " = " ++ showEType t2) False = undefinedsubsCheckRho loc exp1 sigma1@(EForall _ _) rho2 = do -- Rule SPEC
@@ -2148,13 +2150,13 @@
unify loc tau1 tau2 -- Revert to ordinary unification
return exp1
-subsCheckFun :: --XHasCallStack =>
+subsCheckFun :: HasCallStack =>
SLoc -> Expr -> Sigma -> Rho -> Sigma -> Rho -> T Expr
subsCheckFun loc e1 a1 r1 a2 r2 = do
_ <- subsCheck loc undefined a2 a1 -- XXX
subsCheckRho loc e1 r1 r2
-instSigma :: --XHasCallStack =>
+instSigma :: HasCallStack =>
SLoc -> Expr -> Sigma -> Expected -> T Expr
instSigma loc e1 t1 (Check t2) = do
-- traceM ("instSigma: Check " ++ showEType t1 ++ " = " ++ showEType t2)@@ -2186,7 +2188,7 @@
insts <- concat <$> mapM (\ (i, sup) -> expandDict (EVar (mkSuperSel iCls i) `EApp` edict) sup) (zip [1 ..] sups')
return $ (edict, [], [], cn, fds) : insts
-mkSuperSel :: --XHasCallStack =>
+mkSuperSel :: HasCallStack =>
Ident -> Int -> Ident
mkSuperSel c i = addIdentSuffix c ("$super" ++ show i)--
⑨