shithub: MicroHs

Info  •  Files  •  Log  •  Branches

Add primCompare, returning -1,0,1

--- a/ghc/Primitives.hs

+++ b/ghc/Primitives.hs

@@ -176,3 +176,11 @@

 primIsInt         = error "primIsInt"

 primIsIO         :: Any -> Bool

 primIsIO          = error "primIsIO"

+

+primCompare      :: String -> String -> Int

+primCompare s t =

+  case compare s t of

+    LT -> -1

+    EQ -> 0

+    GT -> 1

+    

--- a/lib/Prelude.hs

+++ b/lib/Prelude.hs

@@ -9,6 +9,7 @@

   module Data.Int,

   module Data.List,

   module Data.Maybe,

+  module Data.Ord,

   module Data.Tuple,

   module System.IO,

   module Text.String,

@@ -22,6 +23,7 @@

 import Data.Int

 import Data.List

 import Data.Maybe

+import Data.Ord

 import Data.Tuple

 import System.IO

 import Text.String

--- a/lib/Text/String.hs

+++ b/lib/Text/String.hs

@@ -9,6 +9,7 @@

 import Data.Int

 import Data.List

 import Data.Maybe

+import Data.Ord

 import Data.Tuple

 showChar :: Char -> String

@@ -77,6 +78,11 @@

 showEither fa _ (Left  a) = "(Left "  ++ fa a ++ ")"

 showEither _ fb (Right b) = "(Right " ++ fb b ++ ")"

+showOrdering :: Ordering -> String

+showOrdering LT = "LT"

+showOrdering EQ = "EQ"

+showOrdering GT = "GT"

+

 lines :: String -> [String]

 lines "" = []

 lines s =

@@ -120,3 +126,29 @@

 forceString :: String -> ()

 forceString [] = ()

 forceString (c:cs) = c `primSeq` forceString cs

+

+{-

+compareString :: [Char] -> [Char] -> Ordering

+compareString s t =

+  let

+    r1 = compareString1 s t

+    r2 = compareString2 s t

+  in r2

+    if eqOrdering r1 r2 then r1 else

+    primError $ "compareString " ++ showString s ++ showString t ++ showOrdering r1 ++ showOrdering r2

+

+compareString2 :: [Char] -> [Char] -> Ordering

+compareString2 s t =

+  if leString s t then

+    if eqString s t then

+      EQ

+    else

+      LT

+  else

+    GT

+-}

+

+compareString :: [Char] -> [Char] -> Ordering

+compareString s t = if r < 0 then LT else if r > 0 then GT else EQ

+  where r = primCompare s t

+

--- a/src/Compat.hs

+++ b/src/Compat.hs

@@ -191,3 +191,10 @@

 isPrefixOfBy _ [] _ = True

 isPrefixOfBy _ _ [] = False

 isPrefixOfBy eq (c:cs) (d:ds) = eq c d && isPrefixOfBy eq cs ds

+

+isEQ :: Ordering -> Bool

+isEQ EQ = True

+isEQ _  = False

+

+compareString :: String -> String -> Ordering

+compareString = compare

--- a/src/runtime/eval.c

+++ b/src/runtime/eval.c

@@ -1359,8 +1359,14 @@

   POP(1);

   enum node_tag ptag = GETTAG(p);

   enum node_tag qtag = GETTAG(q);

-  if (ptag != qtag)

+  if (ptag != qtag) {

+    /* Hack to make Nil < Cons */

+    if (ptag == T_K && qtag == T_AP)

+      return -1;

+    if (ptag == T_AP && qtag == T_K)

+      return 1;

     return ptag < qtag ? -1 : 1;

+  }

   switch (ptag) {

   case T_AP:

     PUSH(ARG(p));

-- 

⑨