ref: 2542d34a72bd5109733027d863d23458a5699d7d
parent: de950d251f376d1f6eb3c76a16f005b0349eef3b
author: Lennart Augustsson <lennart@augustsson.net>
date: Sun Oct 29 19:25:42 EDT 2023
More use of Ord
--- a/TODO
+++ b/TODO
@@ -40,3 +40,7 @@
* Just put exported classes in class export
* Implement two level tables for instances even in the tricky cases
* Handle tupled dictionaries better for recursive calls
+
+Bugs
+ * Eq String, Ord String no synonym expansion
+ * Removing [] from prim table
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1164
-((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' _130) ((B _12) _1)) _240))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _239))) ((A :10 (((S' P) _2) (((C' _13) _1) _928))) ((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' _127) _12) _119))) ((A :20 (((S' B) _14) (((C' _130) _12) _120))) ((A :21 _1000) ((A :22 ((B _1042) _21)) ((A :23 (((S' _1042) _21) I)) ((A :24 _970) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _999) ((C _118) _26))) ((A :28 (((C' _27) ((_126 _1013) _108)) ((_118 (_34 _1015)) _107))) ((A :29 ((B ((S _1042) (_34 _1015))) _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) _239)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _240)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _928)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _928))) ((A :46 ((C _43) _119)) ((A :47 ((B _121) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _121) _48)) ((A :50 T) ((A :51 ((_125 ((B (B (_116 _50))) ((B ((C' C) _54)) (B P)))) (_129 _51))) ((A :52 (((((_11 _51) ((B (_116 _50)) P)) (_38 _53)) ((B (B (_116 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_116 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_118 _253)) _54)) ((A :56 ((B (_116 _50)) (B (P _928)))) ((A :57 ((B (_116 _50)) (BK (P _928)))) ((A :58 ((_116 _50) ((S P) I))) ((A :59 ((B (_116 _50)) ((C (S' P)) I))) ((A :60 ((_111 ((C ((C S') _63)) I)) (_115 _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 ((_111 _964) _965)) ((A :70 ((_111 _974) (_115 _70))) ((A :71 _975) ((A :72 _976) ((A :73 (((S' _62) (_967 #97)) ((C _967) #122))) ((A :74 (((S' _62) (_967 #65)) ((C _967) #90))) ((A :75 (((S' _61) _73) _74)) ((A :76 (((S' _62) (_967 #48)) ((C _967) #57))) ((A :77 (((S' _61) _75) _76)) ((A :78 (((S' _62) (_967 #32)) ((C _967) #126))) ((A :79 _964) ((A :80 _965) ((A :81 _967) ((A :82 _966) ((A :83 (((S' _61) ((C (_112 _69)) #32)) (((S' _61) ((C (_112 _69)) #9)) ((C (_112 _69)) #10)))) ((A :84 ((S ((S (((S' _62) (_81 #65)) ((C _81) #90))) (_68 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _71) (((C' _131) (((C' _132) _72) (_72 #65))) (_72 #97))))) ((A :85 ((S ((S (((S' _62) (_81 #97)) ((C _81) #97))) (_68 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _71) (((C' _131) (((C' _132) _72) (_72 #97))) (_72 #65))))) ((A :86 _935) ((A :87 _936) ((A :88 _937) ((A :89 _938) ((A :90 (_87 %0.0)) ((A :91 _86) ((A :92 _87) ((A :93 _88) ((A :94 _89) ((A :95 ((_111 _939) _940)) ((A :96 (_112 _95)) ((A :97 (_113 _95)) ((A :98 _941) ((A :99 _942) ((A :100 _943) ((A :101 _944) ((A :102 _98) ((A :103 _99) ((A :104 _100) ((A :105 _101) ((A :106 _945) ((A :107 ((B BK) T)) ((A :108 (BK T)) ((A :109 (((S' _111) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _112) (T K)))) (K _67)))) ((B ((C' B) (T (K _67)))) ((B _112) (T A))))) ((B _115) ((B _109) (((S' P) (T K)) (T A)))))) ((A :110 P) ((A :111 P) ((A :112 (T K)) ((A :113 (T A)) ((A :114 (K (noDefault "Eq.=="))) ((A :115 (((C' (C' C)) (((C' (C' C)) _112) _68)) _67)) ((A :116 I) ((A :117 (S _972)) ((A :1
\ No newline at end of file
+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
--- a/lib/Data/Char.hs
+++ b/lib/Data/Char.hs
@@ -9,16 +9,28 @@
import Data.Char_Type
import Data.Eq
import Data.Int
+import Data.Ord
instance Eq Char where
(==) = primCharEQ
(/=) = primCharNE
---Y{- Overlapping instance for ghc+instance Ord Char where
+ (<) = primCharLT
+ (<=) = primCharLE
+ (>) = primCharGT
+ (>=) = primCharGE
+
instance Eq [Char] where
(==) = primStringEQ
---Y-}
+instance Ord [Char] where
+ compare = primCompare
+ x < y = primCompare x y == LT
+ x <= y = primCompare x y /= GT
+ x > y = primCompare x y == GT
+ x >= y = primCompare x y /= GT
+
chr :: Int -> Char
chr = primChr
@@ -43,6 +55,7 @@
isPrint :: Char -> Bool
isPrint c = primCharLE ' ' c && primCharLE c '~'
+{-eqChar :: Char -> Char -> Bool
eqChar = primCharEQ
@@ -54,14 +67,15 @@
ltChar :: Char -> Char -> Bool
ltChar = primCharLT
+-}
isSpace :: Char -> Bool
isSpace c = c == ' ' || c == '\t' || c == '\n'
toLower :: Char -> Char
-toLower c | leChar 'A' c && leChar c 'Z' = chr (ord c - ord 'A' + ord 'a')
+toLower c | primCharLE 'A' c && primCharLE c 'Z' = chr (ord c - ord 'A' + ord 'a')
| True = c
toUpper :: Char -> Char
-toUpper c | leChar 'a' c && leChar c 'a' = chr (ord c - ord 'a' + ord 'A')
+toUpper c | primCharLE 'a' c && primCharLE c 'a' = chr (ord c - ord 'a' + ord 'A')
| True = c
--- a/lib/Data/Int.hs
+++ b/lib/Data/Int.hs
@@ -4,6 +4,7 @@
import Primitives
import Data.Bool_Type
import Data.Eq
+import Data.Ord
infixl 6 +,-
infixl 7 *,`quot`,`rem`
@@ -29,7 +30,7 @@
--------------------------------
-- infix 4 ==,/=
-infix 4 <,<=,>,>=
+--infix 4 <,<=,>,>=
-- Comparison
{-@@ -42,6 +43,7 @@
(==) = primIntEQ
(/=) = primIntNE
+{-(<) :: Int -> Int -> Bool
(<) = primIntLT
(<=) :: Int -> Int -> Bool
@@ -50,5 +52,11 @@
(>) = primIntGT
(>=) :: Int -> Int -> Bool
(>=) = primIntGE
+-}
+instance Ord Int where
+ (<) = primIntLT
+ (<=) = primIntLE
+ (>) = primIntGT
+ (>=) = primIntGE
--------------------------------
--- a/lib/Data/List.hs
+++ b/lib/Data/List.hs
@@ -14,12 +14,13 @@
import Data.Functor
import Data.Int
import Data.List_Type
+import Data.Ord
import Data.Maybe
import Data.Tuple
--Yimport Data.Char
-instance forall a . Eq a => Eq [a] where
+instance {-# OVERLAPPABLE #-} forall a . Eq a => Eq [a] where[] == [] = True
(x:xs) == (y:ys) = x == y && xs == ys
_ == _ = False
--- a/lib/Data/Ord.hs
+++ b/lib/Data/Ord.hs
@@ -1,18 +1,37 @@
module Data.Ord(
- Ordering(..),
- eqOrdering,
- isEQ,
+ module Data.Ord,
+ module Data.Ordering_Type,
) where
+import Primitives
import Data.Bool_Type
import Data.Ordering_Type
-import Data.Int
+import Data.Eq
+infix 4 <,<=,>,>=
+
+class Eq a => Ord a where
+ compare :: a -> a -> Ordering
+ (<) :: a -> a -> Bool
+ (<=) :: a -> a -> Bool
+ (>) :: a -> a -> Bool
+ (>=) :: a -> a -> Bool
+ max :: a -> a -> a
+ min :: a -> a -> a
+ -- XXX Check with the Haskell report
+ compare x y = if x <= y then (if y <= x then EQ else LT) else GT
+ x < y = if y <= x then False else True
+ x > y = if x <= y then False else True
+ x >= y = x <= y
+ min x y = if x <= y then x else y
+ max x y = if x <= y then y else x
+
+instance Eq Ordering where
+ LT == LT = True
+ EQ == EQ = True
+ GT == GT = True
+ _ == _ = False
+
isEQ :: Ordering -> Bool
isEQ EQ = True
isEQ _ = False
-eqOrdering :: Ordering -> Ordering -> Bool
-eqOrdering LT LT = True
-eqOrdering EQ EQ = True
-eqOrdering GT GT = True
-eqOrdering _ _ = False
--- a/lib/Text/String.hs
+++ b/lib/Text/String.hs
@@ -108,12 +108,15 @@
unwords :: [String] -> String
unwords ss = intercalate " " ss
+{--- Using a primitive for string equality makes a huge speed difference.
eqString :: String -> String -> Bool
eqString = primStringEQ
leString :: String -> String -> Bool
-leString s t = not (eqOrdering GT (compareString s t))
+leString s t = compareString s t /= GT
+ --not (eqOrdering GT (compareString s t))
+-}
padLeft :: Int -> String -> String
padLeft n s = replicate (n - length s) ' ' ++ s
--- a/src/MicroHs/Exp.hs
+++ b/src/MicroHs/Exp.hs
@@ -179,7 +179,7 @@
quoteString s =
let
achar c =
- if c == '"' || c == '\\' || ltChar c ' ' || ltChar '~' c then
+ if c == '"' || c == '\\' || c < ' ' || c > '~' then
'\\' : showInt (ord c) ++ ['&']
else
[c]
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -75,10 +75,10 @@
isIdent s (Ident _ i) = s == i
leIdent :: Ident -> Ident -> Bool
-leIdent (Ident _ i) (Ident _ j) = leString i j
+leIdent (Ident _ i) (Ident _ j) = i <= j
eqIdent :: Ident -> Ident -> Bool
-eqIdent (Ident _ i) (Ident _ j) = eqString i j
+eqIdent (Ident _ i) (Ident _ j) = i == j
qualIdent :: --XHasCallStack =>
Ident -> Ident -> Ident
@@ -103,7 +103,7 @@
unQualString [] = ""
unQualString s@(c:_) =
if isIdentChar c then
- case dropWhile (neChar '.') s of
+ case dropWhile (/= '.') s of
"" -> s
'.':r -> unQualString r
_ -> undefined -- This cannot happen, but GHC doesn't know that
--- a/src/MicroHs/StateIO.hs
+++ b/src/MicroHs/StateIO.hs
@@ -1,6 +1,6 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# OPTIONS_GHC -Wno-unused-imports -Wno-dodgy-imports #-}-- State monad over IO
module MicroHs.StateIO(
module MicroHs.StateIO,
@@ -11,7 +11,7 @@
import Prelude
import Control.Applicative
import Control.Monad
-import Data.Functor
+import Data.Functor --Xhiding(unzip)
--import qualified System.IO as IO
--Ximport qualified CompatIO as IO
--- a/tests/StringTest.hs
+++ b/tests/StringTest.hs
@@ -3,8 +3,8 @@
main :: IO ()
main = do
- putStrLn $ if eqString "abc" "abc" then "yes" else "no"
- putStrLn $ if eqString "abc" "adc" then "yes" else "no"
+ putStrLn $ if (==) "abc" "abc" then "yes" else "no"
+ putStrLn $ if (==) "abc" "adc" then "yes" else "no"
putStrLn $ showInt 1234
putStrLn $ showInt 0
putStrLn $ showInt (negate 567)
--
⑨