ref: b4de01c8450f853712aba91d186a6e4db64d3060
parent: 2542d34a72bd5109733027d863d23458a5699d7d
author: Lennart Augustsson <lennart@augustsson.net>
date: Sun Oct 29 19:36:30 EDT 2023
More Ord
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1173
-((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _128) ((B _12) _1)) _235))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _234))) ((A :10 (((S' P) _2) (((C' _13) _1) _939))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _125) _12) _117))) ((A :20 (((S' B) _14) (((C' _128) _12) _118))) ((A :21 _1011) ((A :22 ((B _1053) _21)) ((A :23 (((S' _1053) _21) I)) ((A :24 _981) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1010) ((C _116) _26))) ((A :28 (((C' _27) ((_124 _1024) _106)) ((_116 (_34 _1026)) _105))) ((A :29 ((B ((S _1053) (_34 _1026))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _234)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _235)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _939)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _939))) ((A :46 ((C _43) _117)) ((A :47 ((B _119) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _119) _48)) ((A :50 T) ((A :51 ((_123 ((B (B (_114 _50))) ((B ((C' C) _54)) (B P)))) (_127 _51))) ((A :52 (((((_11 _51) ((B (_114 _50)) P)) (_38 _53)) ((B (B (_114 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_114 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_116 _264)) _54)) ((A :56 ((B (_114 _50)) (B (P _939)))) ((A :57 ((B (_114 _50)) (BK (P _939)))) ((A :58 ((_114 _50) ((S P) I))) ((A :59 ((B (_114 _50)) ((C (S' P)) I))) ((A :60 ((_109 ((C ((C S') _63)) I)) (_113 _60))) ((A :61 (R _68)) ((A :62 (T _67)) ((A :63 ((P _68) _67)) ((A :64 _68) ((A :65 ((C ((C S') _63)) I)) ((A :66 ((C S) _63)) ((A :67 K) ((A :68 A) ((A :69 ((_109 _975) _976)) ((A :70 ((((((((_243 _69) (_252 _70)) _977) _978) _979) _980) (_257 _70)) (_258 _70))) ((A :71 ((_109 _985) (_113 _71))) ((A :72 ((((((((_243 _71) _984) (((C' (C' (_110 _259))) _984) _261)) (((C' (C' (_111 _259))) _984) _263)) (((C' (C' (_110 _259))) _984) _263)) (((C' (C' (_111 _259))) _984) _263)) (_257 _72)) (_258 _72))) ((A :73 _986) ((A :74 _987) ((A :75 (((S' _62) (_978 #97)) ((C _978) #122))) ((A :76 (((S' _62) (_978 #65)) ((C _978) #90))) ((A :77 (((S' _61) _75) _76)) ((A :78 (((S' _62) (_978 #48)) ((C _978) #57))) ((A :79 (((S' _61) _77) _78)) ((A :80 (((S' _62) (_978 #32)) ((C _978) #126))) ((A :81 (((S' _61) ((C (_110 _69)) #32)) (((S' _61) ((C (_110 _69)) #9)) ((C (_110 _69)) #10)))) ((A :82 ((S ((S (((S' _62) (_978 #65)) ((C _978) #90))) (_68 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _73) (((C' _129) (((C' _130) _74) (_74 #65))) (_74 #97))))) ((A :83 ((S ((S (((S' _62) (_978 #97)) ((C _978) #97))) (_68 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _73) (((C' _129) (((C' _130) _74) (_74 #97))) (_74 #65))))) ((A :84 _946) ((A :85 _947) ((A :86 _948) ((A :87 _949) ((A :88 (_85 %0.0)) ((A :89 _84) ((A :90 _85) ((A :91 _86) ((A :92 _87) ((A :93 ((_109 _950) _951)) ((A :94 (_110 _93)) ((A :95 (_111 _93)) ((A :96 _952) ((A :97 _953) ((A :98 _954) ((A :99 _955) ((A :100 _96) ((A :101 _97) ((A :102 _98) ((A :103 _99) ((A :104 _956) ((A :105 ((B BK) T)) ((A :106 (BK T)) ((A :107 (((S' _109) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _110) (T K)))) (K _67)))) ((B ((C' B) (T (K _67)))) ((B _110) (T
\ No newline at end of file
+1172
+((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _128) ((B _12) _1)) _235))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _234))) ((A :10 (((S' P) _2) (((C' _13) _1) _938))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _125) _12) _117))) ((A :20 (((S' B) _14) (((C' _128) _12) _118))) ((A :21 _1010) ((A :22 ((B _1052) _21)) ((A :23 (((S' _1052) _21) I)) ((A :24 _980) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1009) ((C _116) _26))) ((A :28 (((C' _27) ((_124 _1023) _106)) ((_116 (_34 _1025)) _105))) ((A :29 ((B ((S _1052) (_34 _1025))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _234)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _235)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _938)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _938))) ((A :46 ((C _43) _117)) ((A :47 ((B _119) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _119) _48)) ((A :50 T) ((A :51 ((_123 ((B (B (_114 _50))) ((B ((C' C) _54)) (B P)))) (_127 _51))) ((A :52 (((((_11 _51) ((B (_114 _50)) P)) (_38 _53)) ((B (B (_114 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_114 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_116 _264)) _54)) ((A :56 ((B (_114 _50)) (B (P _938)))) ((A :57 ((B (_114 _50)) (BK (P _938)))) ((A :58 ((_114 _50) ((S P) I))) ((A :59 ((B (_114 _50)) ((C (S' P)) I))) ((A :60 ((_109 ((C ((C S') _63)) I)) (_113 _60))) ((A :61 (R _68)) ((A :62 (T _67)) ((A :63 ((P _68) _67)) ((A :64 _68) ((A :65 ((C ((C S') _63)) I)) ((A :66 ((C S) _63)) ((A :67 K) ((A :68 A) ((A :69 ((_109 _974) _975)) ((A :70 ((((((((_243 _69) (_252 _70)) _976) _977) _978) _979) (_257 _70)) (_258 _70))) ((A :71 ((_109 _984) (_113 _71))) ((A :72 ((((((((_243 _71) _983) (((C' (C' (_110 _259))) _983) _261)) (((C' (C' (_111 _259))) _983) _263)) (((C' (C' (_110 _259))) _983) _263)) (((C' (C' (_111 _259))) _983) _263)) (_257 _72)) (_258 _72))) ((A :73 _985) ((A :74 _986) ((A :75 (((S' _62) (_977 #97)) ((C _977) #122))) ((A :76 (((S' _62) (_977 #65)) ((C _977) #90))) ((A :77 (((S' _61) _75) _76)) ((A :78 (((S' _62) (_977 #48)) ((C _977) #57))) ((A :79 (((S' _61) _77) _78)) ((A :80 (((S' _62) (_977 #32)) ((C _977) #126))) ((A :81 (((S' _61) ((C (_110 _69)) #32)) (((S' _61) ((C (_110 _69)) #9)) ((C (_110 _69)) #10)))) ((A :82 ((S ((S (((S' _62) (_977 #65)) ((C _977) #90))) (_68 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _73) (((C' _129) (((C' _130) _74) (_74 #65))) (_74 #97))))) ((A :83 ((S ((S (((S' _62) (_977 #97)) ((C _977) #97))) (_68 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _73) (((C' _129) (((C' _130) _74) (_74 #97))) (_74 #65))))) ((A :84 _945) ((A :85 _946) ((A :86 _947) ((A :87 _948) ((A :88 (_85 %0.0)) ((A :89 _84) ((A :90 _85) ((A :91 _86) ((A :92 _87) ((A :93 ((_109 _949) _950)) ((A :94 (_110 _93)) ((A :95 (_111 _93)) ((A :96 _951) ((A :97 _952) ((A :98 _953) ((A :99 _954) ((A :100 _96) ((A :101 _97) ((A :102 _98) ((A :103 _99) ((A :104 _955) ((A :105 ((B BK) T)) ((A :106 (BK T)) ((A :107 (((S' _109) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _110) (T K)))) (K _67)))) ((B ((C' B) (T (K _67)))) ((B _110) (T
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -129,7 +129,7 @@
ds = concat $ zipWith dsBind pvs ads
node ie@(i, e) = (ie, i, freeVars e)
gr = map node $ checkDup ds
- asccs = stronglyConnComp leIdent gr
+ asccs = stronglyConnComp (<=) gr
loop _ [] = ret
loop vs (AcyclicSCC (i, e) : sccs) =
letE i e $ loop vs sccs
--- 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, isIdent,
+ mkIdent, mkIdentLoc, unIdent, isIdent,
qualIdent, showIdent, getSLocIdent, setSLocIdent,
ppIdent,
mkIdentSLoc,
@@ -40,6 +40,13 @@
instance Eq Ident where
Ident _ i == Ident _ j = i == j
+instance Ord Ident where
+ compare (Ident _ i) (Ident _ j) = compare i j
+ Ident _ i < Ident _ j = i < j
+ Ident _ i <= Ident _ j = i <= j
+ Ident _ i > Ident _ j = i > j
+ Ident _ i >= Ident _ j = i >= j
+
noSLoc :: SLoc
noSLoc = SLoc "" 0 0
@@ -74,11 +81,13 @@
isIdent :: String -> Ident -> Bool
isIdent s (Ident _ i) = s == i
+{-leIdent :: Ident -> Ident -> Bool
leIdent (Ident _ i) (Ident _ j) = i <= j
eqIdent :: Ident -> Ident -> Bool
eqIdent (Ident _ i) (Ident _ j) = i == j
+-}
qualIdent :: --XHasCallStack =>
Ident -> Ident -> Ident
--- a/src/MicroHs/IdentMap.hs
+++ b/src/MicroHs/IdentMap.hs
@@ -64,10 +64,12 @@
lookup k = look
where
look Nil = Nothing
- look (One key val) | isEQ (compareIdent k key) = Just val
- | otherwise = Nothing
+ look (One key val) =
+ case compare k key of
+ EQ -> Just val
+ _ -> Nothing
look (Node left _ key val right) =
- case k `compareIdent` key of
+ case k `compare` key of
LT -> look left
EQ -> Just val
GT -> look right
@@ -81,7 +83,7 @@
ins Nil = One k v
ins (One a v) = ins (Node Nil 1 a v Nil)
ins (Node left _ key val right) =
- case k `compareIdent` key of
+ case k `compare` key of
LT -> balance (ins left) key val right
EQ -> node left k (comb v val) right
GT -> balance left key val (ins right)
@@ -90,10 +92,10 @@
delete k = del
where
del Nil = Nil
- del t@(One a _) | isEQ (k `compareIdent` a) = Nil
+ del t@(One a _) | isEQ (k `compare` a) = Nil
| otherwise = t
del (Node left _ key val right) =
- case k `compareIdent` key of
+ case k `compare` key of
LT -> balance (del left) key val right
EQ -> glue left right
GT -> balance left key val (del right)
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -74,7 +74,7 @@
(==) = eqEntry
eqEntry :: Entry -> Entry -> Bool
-eqEntry (Entry x _) (Entry y _) = eqIdent (getIdent x) (getIdent y)
+eqEntry (Entry x _) (Entry y _) = (getIdent x) == (getIdent y)
entryType :: Entry -> EType
@@ -149,7 +149,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 /= hide
ivs = [ i | ImpValue i <- is ]
vs' = filter (\ (ValueExport i _) -> keep i ivs) vs
cts = [ i | ImpTypeCon i <- is ]
@@ -1793,7 +1793,7 @@
T.return (EForall new_bndrs_kind ty')
where
used_bndrs = tyVarBndrs ty -- Avoid quantified type variables in use
- new_bndrs = deleteFirstsBy eqIdent allBinders used_bndrs
+ new_bndrs = allBinders \\ used_bndrs
bind (tv, name) = writeTcRef tv (EVar name)
new_bndrs_kind = map (\ i -> IdKind i undefined) new_bndrs
@@ -1860,7 +1860,7 @@
tyVarBndrs :: Rho -> [TyVar]
-- Get all the binders used in ForAlls in the type, so that
-- when quantifying an outer for-all we can avoid these inner ones
-tyVarBndrs ty = nubBy eqIdent (bndrs ty)
+tyVarBndrs ty = nub (bndrs ty)
where
bndrs (EForall tvs body) = map idKindIdent tvs ++ bndrs body
bndrs (EApp arg res) = bndrs arg ++ bndrs res
@@ -1873,7 +1873,7 @@
env_tys <- getEnvTypes
env_tvs <- getMetaTyVars env_tys
res_tvs <- getMetaTyVars [exp_ty]
- let forall_tvs = deleteFirstsBy eqInt res_tvs env_tvs
+ let forall_tvs = res_tvs \\ env_tvs
(e',) <$> quantify forall_tvs exp_ty
-}
@@ -2112,7 +2112,7 @@
stLookup :: --forall a . --XShow a =>
String -> Ident -> SymTab Entry -> Either String Entry
stLookup msg i (SymTab genv lenv) =
- case lookupBy eqIdent i lenv of
+ case lookup i lenv of
Just e -> Right e
Nothing ->
case M.lookup i genv of
--
⑨