@@ -251,7 +251,8 @@ data Phase = CompileTime | RunTime
251251-- Work Right to Left
252252
253253simpleCase :: Bool -> SC -> Bool ->
254− Phase -> FC -> [Int] -> [Type] ->
254+ Phase -> FC -> [Int] ->
255+ [(Type, Bool)] -> -- ^ (Argument type, whether it's canonical)
255256 [([Name], Term, Term)] ->
256257 ErasureInfo ->
257258 TC CaseDef
@@ -273,7 +274,7 @@ simpleCase tc defcase reflect phase fc inacc argtys cs erInfo
273274 OK pats ->
274275 let numargs = length (fst (head pats))
275276 ns = take numargs args
276− (ns', ps') = order [(n, i `elem` inacc) | (i,n) <- zip [0..] ns] pats
277+ (ns', ps') = order phase [(n, i `elem` inacc) | (i,n) <- zip [0..] ns] pats (map snd argtys)
277278 (tree, st) = runCaseBuilder erInfo
278279 (match ns' ps' defcase)
279280 ([], numargs, [])
@@ -431,28 +432,38 @@ partition xs = error $ "Partition " ++ show xs
431432--
432433-- The first argument means [(Name, IsInaccessible)].
433434
434−order :: [(Name, Bool)] -> [Clause] -> ([Name], [Clause])
435−order [] cs = ([], cs)
436−order ns' [] = (map fst ns', [])
437−order ns' cs = let patnames = transpose (map (zip ns') (map fst cs))
438− -- only sort the arguments where there is no clash in
439− -- constructor tags between families, and no constructor/constant
440− -- clash, because otherwise we can't reliable make the
441− -- case distinction on evaluation
442− (patnames_ord, patnames_rest)
443− = Data.List.partition (noClash . map snd) patnames
444− -- note: sortBy . reverse is not nonsense because sortBy is stable
445− pats' = transpose (sortBy moreDistinct (reverse patnames_ord)
446− ++ patnames_rest) in
447− (getNOrder pats', zipWith rebuild pats' cs)
435+order :: Phase -> [(Name, Bool)] -> [Clause] -> [Bool] -> ([Name], [Clause])
436+-- do nothing at compile time: FIXME (EB): Put this in after checking
437+-- implications for Franck's reflection work... see issue 3233
438+-- order CompileTime ns cs _ = (map fst ns, cs)
439+order _ [] cs cans = ([], cs)
440+order _ ns' [] cans = (map fst ns', [])
441+order phase ns' cs cans
442+ = let patnames = transpose (map (zip ns') (map (zip cans) (map fst cs)))
443+ -- only sort the arguments where there is no clash in
444+ -- constructor tags between families, the argument type is canonical,
445+ -- and no constructor/constant
446+ -- clash, because otherwise we can't reliable make the
447+ -- case distinction on evaluation
448+ (patnames_ord, patnames_rest)
449+ = Data.List.partition (noClash . map snd) patnames
450+ patnames_ord' = case phase of
451+ CompileTime -> patnames_ord
452+ -- reversing tends to make better case trees
453+ -- and helps erasure
454+ RunTime -> reverse patnames_ord
455+ pats' = transpose (sortBy moreDistinct patnames_ord'
456+ ++ patnames_rest) in
457+ (getNOrder pats', zipWith rebuild pats' cs)
448458 where
449459 getNOrder [] = error $ "Failed order on " ++ show (map fst ns', cs)
450460 getNOrder (c : _) = map (fst . fst) c
451461
452− rebuild patnames clause = (map snd patnames, snd clause)
462+ rebuild patnames clause = (map (snd . snd) patnames, snd clause)
453463
454464 noClash [] = True
455− noClash (p : ps) = not (any (clashPat p) ps) && noClash ps
465+ noClash ((can, p) : ps) = can && not (any (clashPat p) (map snd ps))
466+ && noClash ps
456467
457468 clashPat (PCon _ _ _ _) (PConst _) = True
458469 clashPat (PConst _) (PCon _ _ _ _) = True
@@ -462,12 +473,13 @@ order ns' cs = let patnames = transpose (map (zip ns') (map fst cs))
462473 clashPat _ _ = False
463474
464475 -- this compares (+isInaccessible, -numberOfCases)
465− moreDistinct xs ys = compare (snd . fst . head $ xs, numNames [] (map snd ys))
466− (snd . fst . head $ ys, numNames [] (map snd xs))
476+ moreDistinct xs ys
477+ = compare (snd . fst . head $ xs, numNames [] (map snd ys))
478+ (snd . fst . head $ ys, numNames [] (map snd xs))
467479
468− numNames xs (PCon _ n _ _ : ps)
480+ numNames xs ((_, PCon _ n _ _) : ps)
469481 | not (Left n `elem` xs) = numNames (Left n : xs) ps
470− numNames xs (PConst c : ps)
482+ numNames xs ((_, PConst c) : ps)
471483 | not (Right c `elem` xs) = numNames (Right c : xs) ps
472484 numNames xs (_ : ps) = numNames xs ps
473485 numNames xs [] = length xs