@@ -53,7 +53,7 @@ type Cond = Set Node
53data VarInfo = VI
53data VarInfo = VI
54 { viDeps :: DepSet -- dependencies drawn in by the variable
54 { viDeps :: DepSet -- dependencies drawn in by the variable
55 , viFunArg :: Maybe Int -- which function argument this variable came from (defined only for patvars)
55 , viFunArg :: Maybe Int -- which function argument this variable came from (defined only for patvars)
56− , viMethod :: Maybe Name -- name of the method represented by the var, if any
56+ , viMethod :: Maybe Name -- name of the metamethod represented by the var, if any
58 deriving Show
58 deriving Show
@@ -297,26 +297,17 @@ buildDepMap ci ctx mainName = addPostulates $ dfs S.empty M.empty [mainName]
297 vs' = M.fromList [(v, VI
297 vs' = M.fromList [(v, VI
298 { viDeps = M.insertWith S.union (n, Arg j) (S.singleton (fn, varIdx)) (viDeps var)
298 { viDeps = M.insertWith S.union (n, Arg j) (S.singleton (fn, varIdx)) (viDeps var)
299 , viFunArg = viFunArg var
299 , viFunArg = viFunArg var
300− , viMethod = m
300+ , viMethod = meth j
302− | (v, j, m) <- zip3 ns [0..] methodNames]
302+ | (v, j) <- zip ns [0..]]
304 -- this is safe because it's certainly a patvar
304 -- this is safe because it's certainly a patvar
305 varIdx = fromJust (viFunArg var)
305 varIdx = fromJust (viFunArg var)
307− -- figure out method names, if "n" is an instance ctor
307+ -- generate metamethod names, "n" is the instance ctor
308− methodNames :: [Maybe Name]
308+ meth :: Int -> Maybe Name
309− methodNames = case n of
310− SN (InstanceCtorN className)
309+ meth | SN (InstanceCtorN className) <- n = \j -> Just (mkField n j)
311− | Just cinfo <- lookupCtxtExact className ci
312− -> let methNames = map fst $ class_methods cinfo
313− in replicate (length ns - length methNames) Nothing -- initial type args to the instance ctor
314− ++ map Just methNames -- methods proper
316− | otherwise
310+ | otherwise = \j -> Nothing
317− -> error $ "could not find class for the instance ctor " ++ show n
321 -- Named variables -> DeBruijn variables -> Conds/guards -> Term -> Deps
312 -- Named variables -> DeBruijn variables -> Conds/guards -> Term -> Deps
322 getDepsTerm :: Vars -> [Cond -> Deps] -> Cond -> Term -> Deps
313 getDepsTerm :: Vars -> [Cond -> Deps] -> Cond -> Term -> Deps
@@ -427,6 +418,15 @@ buildDepMap ci ctx mainName = addPostulates $ dfs S.empty M.empty [mainName]
428 -- Get the number of arguments that might be considered for erasure.
419 -- Get the number of arguments that might be considered for erasure.
429 getArity :: Name -> Int
420 getArity :: Name -> Int
421+ getArity (SN (WhereN i' ctorName (MN i field)))
422+ | [TyDecl (DCon _ _) ty] <- lookupDef ctorName ctx
423+ = let argTys = map snd $ getArgTys ty
424+ in if i <= length argTys
425+ then length $ getArgTys (argTys !! i)
426+ else error $ "invalid field number " ++ show i ++ " for " ++ show ctorName
428+ | otherwise = error $ "unknown instance constructor: " ++ show ctorName
430 getArity n = case lookupDef n ctx of
430 getArity n = case lookupDef n ctx of
431 [CaseOp ci ty tys def tot cdefs] -> length tys
431 [CaseOp ci ty tys def tot cdefs] -> length tys
432 [TyDecl (DCon tag arity) _] -> arity
432 [TyDecl (DCon tag arity) _] -> arity