ref: 8f7bd08f3e3c947ac0ec0d2787b4ff5d383d0782
parent: fdc6a7cb63f1f6949ac1096c08ed873197b8bc32
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Thu Oct 26 09:29:42 EDT 2023
Minor improvements
--- a/Makefile
+++ b/Makefile
@@ -49,7 +49,7 @@
$(GHCB) -c ghc/Data/Bool_Type.hs
$(GHCB) -c ghc/Data/Ordering_Type.hs
$(GHCB) -c ghc/Data/Double.hs
- $(GHCB) -c src/PrimTable.hs
+ $(GHCB) -c ghc/PrimTable.hs
$(GHCC) -c lib/Control/Error.hs
$(GHCC) -c lib/Data/Bool.hs
$(GHCC) -c lib/Data/Eq.hs
--- /dev/null
+++ b/ghc/PrimTable.hs
@@ -1,0 +1,91 @@
+module PrimTable(module PrimTable) where
+import Data.Char
+import Data.Maybe
+import System.IO
+import Unsafe.Coerce
+import GHC.Types(Any)
+
+primitive :: String -> Any
+primitive s = fromMaybe (error $ "primitive: " ++ s) $ lookup s primOps
+
+newtype DIO a = DIO { unDIO :: IO a }+
+primOps :: [(String, Any)]
+primOps =
+ [ comb "S" (\ f g x -> f x (g x))
+ , comb "S'" (\ k f g x -> k f x (g x))
+ , comb "K" (\ x _y -> x)
+ , comb "A" (\ _x y -> y)
+ , comb "T" (\ x y -> y x)
+ , comb "I" (\ x -> x)
+ , comb "Y" (\ f -> let r = f r in r)
+ , comb "B" (\ f g x -> f (g x))
+ , comb "B'" (\ k f g x -> k f (g x))
+ , comb "BK" (\ f g _x -> f g)
+ , comb "C" (\ f g x -> f x g)
+ , comb "C'" (\ k f g x -> k f x g)
+ , comb "P" (\ x y f -> f x y)
+ , comb "O" (\ x y _g f -> f x y)
+
+ , arith "+" (+)
+ , arith "-" (-)
+ , arith "*" (*)
+ , arith "quot" quot
+ , arith "rem" rem
+ , arith "subtract" subtract
+ , farith "fadd" (+)
+ , farith "fsub" (-)
+ , farith "fmul" (*)
+ , cmp "feq" (==)
+ , cmp "fne" (/=)
+ , cmp "flt" (<)
+ , cmp "fle" (<=)
+ , cmp "fgt" (>)
+ , cmp "fge" (>=)
+ , comb "fshow" (show :: Double -> String)
+ , cmp "==" (==)
+ , cmp "/=" (/=)
+ , cmp "<" (<)
+ , cmp "<=" (<=)
+ , cmp ">" (>)
+ , cmp ">=" (>=)
+ , cmp "error" err
+ , comb "ord" ord
+ , comb "chr" chr
+ , comb "IO.>>=" iobind
+ , comb "IO.>>" iothen
+ , comb "IO.return" ioret
+-- , comb "IO.getChar" getc
+ , comb "IO.putChar" putc
+ , comb "IO.stdin" stdin
+ , comb "IO.stdout" stdout
+ , comb "IO.stderr" stderr
+ ]
+ where
+ comb n f = (n, unsafeCoerce f)
+ arith :: String -> (Int -> Int -> Int) -> (String, Any)
+ arith = comb
+ farith :: String -> (Double -> Double -> Double) -> (String, Any)
+ farith = comb
+ cmp :: String -> (Int -> Int -> Bool) -> (String, Any)
+ cmp n f = comb n (\ x y -> if f x y then cTrue else cFalse)
+ cTrue _x y = y
+ cFalse x _y = x
+ iobind :: DIO a -> (a -> DIO b) -> DIO b
+ iobind a k = DIO (unDIO a >>= \ x -> unDIO (k x))
+ iothen :: DIO a -> DIO b -> DIO b
+ iothen a b = DIO (unDIO a >> unDIO b)
+ ioret :: a -> DIO a
+ ioret a = DIO (return a)
+-- getc h = undefined -- fromEnum <$> hGetChar h -- XXX
+ putc :: Handle -> Int -> DIO ()
+ putc h c = DIO $ do
+-- let h = unsafeCoerce hh :: Handle
+-- c = unsafeCoerce cc :: Int
+-- print (h, c)
+ hPutChar h (toEnum c)
+-- open = undefined
+-- close = undefined
+-- isnull = undefined
+
+ err _ = error "ERROR"
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -256,7 +256,8 @@
_ -> impossible
in map (\ qi -> ValueExport (unQualIdent qi) (val qi)) qis
-mkTables :: forall a . [(ImportSpec, TModule a)] -> (FixTable, TypeTable, SynTable, ClassTable, InstTable, ValueTable, AssocTable)
+mkTables :: forall a . [(ImportSpec, TModule a)] ->
+ (FixTable, TypeTable, SynTable, ClassTable, InstTable, ValueTable, AssocTable)
mkTables mdls =
let
qns (ImportSpec q _ mas _) mn i =
@@ -1810,7 +1811,7 @@
newSkolemTyVar :: Ident -> T Ident
newSkolemTyVar tv = T.do
uniq <- newUniq
- T.return (mkIdentSLoc (getSLocIdent tv) (showInt uniq ++ unIdent tv))
+ T.return (mkIdentSLoc (getSLocIdent tv) (unIdent tv ++ "#" ++ showInt uniq))
freeTyVars :: [EType] -> [TyVar]
-- Get the free TyVars from a type; no duplicates in result
@@ -1823,6 +1824,7 @@
go bound (EVar tv) acc
| elem tv bound = acc
| elem tv acc = acc
+ | isConIdent tv = acc
| otherwise = tv : acc
go bound (EForall tvs ty) acc = go (map idKindIdent tvs ++ bound) ty acc
go bound (EApp fun arg) acc = go bound fun (go bound arg acc)
@@ -1862,7 +1864,8 @@
(e',) <$> quantify forall_tvs exp_ty
-}
-checkSigma :: Expr -> Sigma -> T Expr
+checkSigma :: --XHasCallStack =>
+ Expr -> Sigma -> T Expr
checkSigma expr sigma = T.do
(skol_tvs, rho) <- skolemise sigma
expr' <- tCheckExpr rho expr
@@ -1874,7 +1877,7 @@
esc_tvs <- getFreeTyVars (sigma : env_tys)
let bad_tvs = filter (\ i -> elem i esc_tvs) skol_tvs
T.when (not (null bad_tvs)) $
- tcErrorTK (getSLocExpr expr) "not polymorphic enough"
+ tcErrorTK (getSLocExpr expr) $ "not polymorphic enough: " ++ unwords (map showIdent bad_tvs)
T.return expr'
subsCheckRho :: --XHasCallStack =>
@@ -1893,7 +1896,8 @@
unify loc tau1 tau2 -- Revert to ordinary unification
T.return exp1
-subsCheckFun :: SLoc -> Expr -> Sigma -> Rho -> Sigma -> Rho -> T Expr
+subsCheckFun :: --XHasCallStack =>
+ SLoc -> Expr -> Sigma -> Rho -> Sigma -> Rho -> T Expr
subsCheckFun loc e1 a1 r1 a2 r2 = T.do
_ <- subsCheck loc undefined a2 a1 -- XXX
subsCheckRho loc e1 r1 r2
@@ -1900,7 +1904,9 @@
instSigma :: --XHasCallStack =>
SLoc -> Expr -> Sigma -> Expected -> T Expr
-instSigma loc e1 t1 (Check t2) = subsCheckRho loc e1 t1 t2
+instSigma loc e1 t1 (Check t2) = T.do
+-- traceM ("instSigma: " ++ showEType t1 ++ " = " ++ showEType t2)+ subsCheckRho loc e1 t1 t2
instSigma _ e1 t1 (Infer r) = T.do
(e1', t1') <- tInst (e1, t1)
tSetRefType r t1'
--- a/src/PrimTable.hs
+++ /dev/null
@@ -1,91 +1,0 @@
-module PrimTable(module PrimTable) where
-import Data.Char
-import Data.Maybe
-import System.IO
-import Unsafe.Coerce
-import GHC.Types(Any)
-
-primitive :: String -> Any
-primitive s = fromMaybe (error $ "primitive: " ++ s) $ lookup s primOps
-
-newtype DIO a = DIO { unDIO :: IO a }-
-primOps :: [(String, Any)]
-primOps =
- [ comb "S" (\ f g x -> f x (g x))
- , comb "S'" (\ k f g x -> k f x (g x))
- , comb "K" (\ x _y -> x)
- , comb "A" (\ _x y -> y)
- , comb "T" (\ x y -> y x)
- , comb "I" (\ x -> x)
- , comb "Y" (\ f -> let r = f r in r)
- , comb "B" (\ f g x -> f (g x))
- , comb "B'" (\ k f g x -> k f (g x))
- , comb "BK" (\ f g _x -> f g)
- , comb "C" (\ f g x -> f x g)
- , comb "C'" (\ k f g x -> k f x g)
- , comb "P" (\ x y f -> f x y)
- , comb "O" (\ x y _g f -> f x y)
-
- , arith "+" (+)
- , arith "-" (-)
- , arith "*" (*)
- , arith "quot" quot
- , arith "rem" rem
- , arith "subtract" subtract
- , farith "fadd" (+)
- , farith "fsub" (-)
- , farith "fmul" (*)
- , cmp "feq" (==)
- , cmp "fne" (/=)
- , cmp "flt" (<)
- , cmp "fle" (<=)
- , cmp "fgt" (>)
- , cmp "fge" (>=)
- , comb "fshow" (show :: Double -> String)
- , cmp "==" (==)
- , cmp "/=" (/=)
- , cmp "<" (<)
- , cmp "<=" (<=)
- , cmp ">" (>)
- , cmp ">=" (>=)
- , cmp "error" err
- , comb "ord" ord
- , comb "chr" chr
- , comb "IO.>>=" iobind
- , comb "IO.>>" iothen
- , comb "IO.return" ioret
--- , comb "IO.getChar" getc
- , comb "IO.putChar" putc
- , comb "IO.stdin" stdin
- , comb "IO.stdout" stdout
- , comb "IO.stderr" stderr
- ]
- where
- comb n f = (n, unsafeCoerce f)
- arith :: String -> (Int -> Int -> Int) -> (String, Any)
- arith = comb
- farith :: String -> (Double -> Double -> Double) -> (String, Any)
- farith = comb
- cmp :: String -> (Int -> Int -> Bool) -> (String, Any)
- cmp n f = comb n (\ x y -> if f x y then cTrue else cFalse)
- cTrue _x y = y
- cFalse x _y = x
- iobind :: DIO a -> (a -> DIO b) -> DIO b
- iobind a k = DIO (unDIO a >>= \ x -> unDIO (k x))
- iothen :: DIO a -> DIO b -> DIO b
- iothen a b = DIO (unDIO a >> unDIO b)
- ioret :: a -> DIO a
- ioret a = DIO (return a)
--- getc h = undefined -- fromEnum <$> hGetChar h -- XXX
- putc :: Handle -> Int -> DIO ()
- putc h c = DIO $ do
--- let h = unsafeCoerce hh :: Handle
--- c = unsafeCoerce cc :: Int
--- print (h, c)
- hPutChar h (toEnum c)
--- open = undefined
--- close = undefined
--- isnull = undefined
-
- err _ = error "ERROR"
--
⑨