shithub: MicroHs

--- a/MicroHs.cabal

+++ b/MicroHs.cabal

@@ -38,7 +38,7 @@

   hs-source-dirs:      src ghc

   ghc-options:         -Wall -Wno-unrecognised-warning-flags -Wno-x-partial -F -pgmF ./Tools/convertX.sh -main-is MicroHs.Main

   main-is:             MicroHs/Main.hs

-  default-extensions:  ScopedTypeVariables PatternGuards TupleSections

+  default-extensions:  ScopedTypeVariables PatternGuards TupleSections TypeSynonymInstances

   other-modules:       MicroHs.Compile

                        MicroHs.Desugar

                        MicroHs.Exp

@@ -53,15 +53,12 @@

                        MicroHs.TCMonad

                        MicroHs.Translate

                        MicroHs.TypeCheck

-                       PreludeNoIO

                        Text.ParserComb

                        System.Console.SimpleReadline

                        Control.Alternative

                        Data.Double

                        Compat

-                       CompatIO

                        PrimTable

-                       Primitives

   build-depends:       base         >= 4.10 && < 4.20,

                        containers   >= 0.5 && < 0.8,

                        deepseq      >= 1.1 && < 1.6,

--- a/ghc/Compat.hs

+++ b/ghc/Compat.hs

@@ -3,7 +3,6 @@

 -- Functions for GHC that are defined in the UHS libs.

 module Compat(module Compat) where

 --import Control.Exception

-import qualified Data.Function as F

 import Data.Char

 import Data.Time

 import Data.Time.Clock.POSIX

@@ -12,39 +11,12 @@

 import Data.List

 import System.Environment

 import System.IO

-import GHC.Types(Any)

--- Functions needed for ghc

-eqChar :: Char -> Char -> Bool

-eqChar = (==)

+------- Int --------

-neChar :: Char -> Char -> Bool

-neChar = (/=)

-ltChar :: Char -> Char -> Bool

-ltChar = (<)

-eqString :: String -> String -> Bool

-eqString = (==)

-leString :: String -> String -> Bool

-leString = (<=)

-readInt :: String -> Int

-readInt = read

-readInteger :: String -> Integer

-readInteger = read

-readDouble :: String -> Double

-readDouble = read

 _integerToInt :: Integer -> Int

 _integerToInt = fromInteger

-_intToInteger :: Int -> Integer

-_intToInteger = fromIntegral

 _integerToDouble :: Integer -> Double

 _integerToDouble = fromIntegral

@@ -55,9 +27,17 @@

   where to 0 = []

         to n = fromInteger r : to q  where (q, r) = quotRem n 2147483648

-xshowChar :: Char -> String

-xshowChar = show

+------- List --------

+elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool

+elemBy eq a = any (eq a)

+-- A simple "quicksort" for now.

+sortLE :: forall a . (a -> a -> Bool) -> [a] -> [a]

+sortLE _  [] = []

+sortLE le (x:xs) = sortLE le lt ++ (x : sortLE le ge)

+  where (ge, lt) = partition (le x) xs

 showListS :: (a -> String) -> [a] -> String

 showListS sa arg =

let

@@ -70,28 +50,31 @@

       [] -> "[]"

       a : as -> "[" ++ sa a ++ showRest as

-showPairS :: (a -> String) -> (b -> String) -> (a, b) -> String

-showPairS f g (a, b) = "(" ++ f a ++ "," ++ g b ++ ")"

+anySame :: (Eq a) => [a] -> Bool

+anySame = anySameBy (==)

-elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool

-elemBy eq a = any (eq a)

+anySameBy :: (a -> a -> Bool) -> [a] -> Bool

+anySameBy _ [] = False

+anySameBy eq (x:xs) = elemBy eq x xs || anySameBy eq xs

-stripPrefixBy :: (a -> a -> Bool) -> [a] -> [a] -> Maybe [a]

-stripPrefixBy eq p s =

-  case p of

-    [] -> Just s

-    c : cs ->

-      case s of

-        [] -> Nothing

-        d : ds ->

-          if eq c d then

-            stripPrefixBy eq cs ds

-          else

-            Nothing

+deleteAllBy :: forall a . (a -> a -> Bool) -> a -> [a] -> [a]

+deleteAllBy _ _ [] = []

+deleteAllBy eq x (y:ys) = if eq x y then deleteAllBy eq x ys else y : deleteAllBy eq x ys

-lookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b

-lookupBy eq x xys = fmap snd (find (eq x . fst) xys)

+deleteAllsBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]

+deleteAllsBy eq = foldl (flip (deleteAllBy eq))

+padLeft :: Int -> String -> String

+padLeft n s = replicate (n - length s) ' ' ++ s

+------- Exception --------

+newtype Exn = Exn String

+  deriving (Show)

+instance Exception Exn

+------- IO --------

 openFileM :: FilePath -> IOMode -> IO (Maybe Handle)

 openFileM path m = do

   r <- (try $ openFile path m) :: IO (Either IOError Handle)

@@ -99,25 +82,9 @@

     Left _ -> return Nothing

     Right h -> return (Just h)

---when :: Bool -> IO () -> IO ()

---when = M.when

-on :: (a -> a -> b) -> (c -> a) -> (c -> c -> b)

-on = F.on

 getTimeMilli :: IO Int

 getTimeMilli  = floor . (1000 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds <$> getCurrentTime

-padLeft :: Int -> String -> String

-padLeft n s = replicate (n - length s) ' ' ++ s

-spanUntil :: forall a . (a -> Bool) -> [a] -> ([a], [a])

-spanUntil p =

-  let

-    rec r [] = (reverse r, [])

-    rec r (x:xs) = if p x then rec (x:r) xs else (reverse (x:r), xs)

-  in rec []

 -- A hack until we have a real withArgs

 withDropArgs :: Int -> IO a -> IO a

 withDropArgs i ioa = do

@@ -124,66 +91,10 @@

   as <- getArgs

   withArgs (drop i as) ioa

--- A simple "quicksort" for now.

-sortLE :: forall a . (a -> a -> Bool) -> [a] -> [a]

-sortLE _  [] = []

-sortLE le (x:xs) = sortLE le lt ++ (x : sortLE le ge)

-  where (ge, lt) = partition (le x) xs

+------- Read --------

-deleteAllBy :: forall a . (a -> a -> Bool) -> a -> [a] -> [a]

-deleteAllBy _ _ [] = []

-deleteAllBy eq x (y:ys) = if eq x y then deleteAllBy eq x ys else y : deleteAllBy eq x ys

-deleteAllsBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> [a]

-deleteAllsBy eq = foldl (flip (deleteAllBy eq))

-forceString :: String -> ()

-forceString [] = ()

-forceString (c:cs) = c `seq` forceString cs

-forceList :: forall a . (a -> ()) -> [a] -> ()

-forceList _ [] = ()

-forceList f (a:as) = case f a of { () -> forceList f as }

-writeSerialized :: FilePath -> a -> IO ()

-writeSerialized _ _ = error "writeSerialized"

-eqBool :: Bool -> Bool -> Bool

-eqBool True  x = x

-eqBool False x = not x

-neBool :: Bool -> Bool -> Bool

-neBool True  x = not x

-neBool False x = x

--- Temporary until overloading

-primIsInt        :: Any -> Bool

-primIsInt         = error "isInt"

-primIsIO         :: Any -> Bool

-primIsIO          = error "isIO"

-newtype Exn = Exn String

-  deriving (Show)

-instance Exception Exn

-isPrefixOfBy :: forall a . (a -> a -> Bool) -> [a] -> [a] -> Bool

-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

-anySame :: (Eq a) => [a] -> Bool

-anySame = anySameBy (==)

-anySameBy :: (a -> a -> Bool) -> [a] -> Bool

-anySameBy _ [] = False

-anySameBy eq (x:xs) = elemBy eq x xs || anySameBy eq xs

+readInteger :: String -> Integer

+readInteger = read

 -- Convert string in scientific notation to a rational number.

 readRational :: String -> Rational

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

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

@@ -20,19 +20,6 @@

 import Data.Tuple

 import Text.Show

-xshowChar :: Char -> String

-xshowChar c = "'" ++ xencodeChar c ++ "'"

-xencodeChar :: Char -> String

-xencodeChar c =

-  let

-    spec = [('\n', "\\n"), ('\r', "\\r"), ('\t', "\\t"), ('\b', "\\b"),

-            ('\\', "\\\\"), ('\'', "\\'"), ('"', "\"")]

-  in

-    case lookup c spec of

-      Nothing -> if isPrint c then [c] else "'\\" ++ show (ord c) ++ "'"

-      Just s  -> s

 readInt :: String -> Int

 readInt cs =

let

--- a/src/MicroHs/Desugar.hs

+++ b/src/MicroHs/Desugar.hs

@@ -8,6 +8,7 @@

   ) where

 import Prelude

 import Data.Char

+import Data.Function

 import Data.List

 import Data.Maybe

 import Data.Ratio

--- a/src/MicroHs/Expr.hs

+++ b/src/MicroHs/Expr.hs

@@ -38,7 +38,6 @@

 import Data.Maybe

 import MicroHs.Ident

 import Text.PrettyPrint.HughesPJ

---Ximport Compat

 --Ximport GHC.Stack

 --Ximport Control.DeepSeq

@@ -600,7 +599,7 @@

     LInteger i -> '#' : '#' : show i

     LDouble d  -> '&' : show d

     LRat r     -> '%' : show r

-    LChar c    -> xshowChar c

+    LChar c    -> show c

     LStr s     -> show s

     LPrim s    -> s

     LForImp s  -> '^' : s

--- a/src/MicroHs/IdentMap.hs

+++ b/src/MicroHs/IdentMap.hs

@@ -16,7 +16,6 @@

   ) where

 import Prelude hiding(lookup)

 import MicroHs.Ident

---Ximport Compat

 data Map a

   = Nil           -- empty tree

@@ -92,7 +91,7 @@

 delete k = del

   where

     del Nil = Nil

-    del t@(One a _) | isEQ (k `compare` a) = Nil

+    del t@(One a _) | (k `compare` a) == EQ = Nil

                     | otherwise        = t

     del (Node left _ key val right) =

       case k `compare` key of

--- a/src/MicroHs/Lex.hs

+++ b/src/MicroHs/Lex.hs

@@ -102,7 +102,7 @@

       tchar _ = TError loc "Illegal Char literal"

   in  case takeChars loc tchar '\'' 0 [] cs of  -- XXX head of

         (t, n, rs) -> t : lex (addCol loc $ 2 + n) rs

-lex loc (d:_) = [TError loc $ "Unrecognized input: " ++ xshowChar d]

+lex loc (d:_) = [TError loc $ "Unrecognized input: " ++ show d]

 lex _ [] = []

 hexNumber :: Loc -> String -> [Token]

--- a/src/MicroHs/TypeCheck.hs

+++ b/src/MicroHs/TypeCheck.hs

@@ -15,6 +15,7 @@

 import Data.Eq -- XXX why needed?

 import Prelude

 import Data.Char

+import Data.Function

 import Data.List

 import Data.Maybe

 import qualified Data.IntMap as IM

--

⑨