ref: ac7f6ceeaa737ca72c0a414d0709e84b86ef06c2
parent: 3bf37ac6467745a4fa52474a628786f2c3022f6a
author: Lennart Augustsson <lennart@augustsson.net>
date: Sun Oct 29 08:26:14 EDT 2023
Use overloading in the compiler. Very slow!
--- a/Makefile
+++ b/Makefile
@@ -62,6 +62,9 @@
$(GHCC) -c lib/Data/Maybe.hs
$(GHCC) -c lib/Data/Ord.hs
$(GHCC) -c lib/Data/List.hs
+ $(GHCC) -c lib/Data/Functor.hs
+ $(GHCC) -c lib/Control/Applicative.hs
+ $(GHCC) -c lib/Control/Monad.hs
$(GHCC) -c lib/Text/String.hs
$(GHCC) -c lib/Data/Word.hs
$(GHCC) -c lib/System/IO.hs
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1132
-((A :0 _955) ((A :1 ((B _1001) _0)) ((A :2 (((S' _1001) _0) I)) ((A :3 _925) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _954) ((C _84) _5))) ((A :7 (((C' _6) (_972 _73)) ((_84 _970) _72))) ((A :8 ((B ((S _1001) _970)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_84 _210)) _10)) ((A :12 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_82 _9)) P)) ((A :15 ((B (B (_82 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_82 _9)) (B (P _883)))) ((A :19 ((B (_82 _9)) (BK (P _883)))) ((A :20 ((_82 _9) ((S P) I))) ((A :21 ((B (_82 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _122)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _123)))))) ((A :23 ((B Y) ((B (B (P (_14 _883)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _883))) ((A :26 (_22 _85)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 ((_76 _919) _920)) ((A :36 ((_76 _929) (_80 _36))) ((A :37 _930) ((A :38 _931) ((A :39 (((S' _28) (_922 #97)) ((C _922) #122))) ((A :40 (((S' _28) (_922 #65)) ((C _922) #90))) ((A :41 (((S' _27) _39) _40)) ((A :42 (((S' _28) (_922 #48)) ((C _922) #57))) ((A :43 (((S' _28) (_922 #32)) ((C _922) #126))) ((A :44 _919) ((A :45 _920) ((A :46 _922) ((A :47 _921) ((A :48 (((S' _27) ((C (_77 _35)) #32)) (((S' _27) ((C (_77 _35)) #9)) ((C (_77 _35)) #10)))) ((A :49 ((S ((S (((S' _28) (_46 #65)) ((C _46) #90))) (_34 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #65))) (_38 #97))))) ((A :50 ((S ((S (((S' _28) (_46 #97)) ((C _46) #97))) (_34 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #97))) (_38 #65))))) ((A :51 _890) ((A :52 _891) ((A :53 _892) ((A :54 _893) ((A :55 (_52 %0.0)) ((A :56 _51) ((A :57 _52) ((A :58 _53) ((A :59 _54) ((A :60 ((_76 _894) _895)) ((A :61 (_77 _60)) ((A :62 (_78 _60)) ((A :63 _896) ((A :64 _897) ((A :65 _898) ((A :66 _899) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _66) ((A :71 _900) ((A :72 ((B BK) T)) ((A :73 (BK T)) ((A :74 (((S' _76) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _77) (T K)))) (K _33)))) ((B ((C' B) (T (K _33)))) ((B _77) (T A))))) ((B _80) ((B _74) (((S' P) (T K)) (T A)))))) ((A :75 P) ((A :76 P) ((A :77 (T K)) ((A :78 (T A)) ((A :79 (K (noDefault "Eq.=="))) ((A :80 ((B (B (B _29))) _77)) ((A :81 ((_76 ((C ((C S') _29)) I)) (_80 _81))) ((A :82 I) ((A :83 (S _927)) ((A :84 B) ((A :85 I) ((A :86 K) ((A :87 C) ((A :88 _926) ((A :89 ((C ((C S') _210)) _211)) ((A :90 (((C' (S' (C' B))) B) I)) ((A :91 _884) ((A :92 _885) ((A :93 _886) ((A :94 _887) ((A :95 _888) ((A :96 _889) ((A :97 (_92 #0)) ((A :98 ((_76 _907) _908)) ((A :99 _909) ((A :100 _910) ((A :101 _911) ((A :102 _912) ((A :103 (BK K)) ((A :104 ((B BK) ((B (B BK)) P))) ((A :105 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :106 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_100 #0))) ((C (_77 _98)) #0)))) ((B (B ((C' P) (_96 #1)))) _91))) (C P))) _94)) _95)) ((A :107 _103) ((A :108 (((S' C) ((B (P _197)) (((C' (C' B)) (((C' C) (_77 _98)) _197)) _198))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') ((C (_77 _98)) #0))))) ((B ((C' (C' C)) ((B (B ((S' S') ((C (_77 _98)) #1)))) ((B ((C' C) ((B ((C' S') ((C (_77 _98)) #2))) (C _108)))) (C _108))))) (C _108))))) (C _108)))) (T K))) (T A)))) ((C _106) #4)))) ((A :109 (_115 _86)) ((A :110 ((_131 (_89 _109)) _107)) ((A :111 ((C (((C' B) ((P _122) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _112)))) (((S' (C' (C' B))) ((B (B (B _112))) (((S' (C' B)) ((B (B _112)) (((C' B) ((B _129) (T #0))) _111))) (((C' B) ((B _129) (T #1))) _111)))) (((C' B) ((B _129) (T #2))) _111)))) (((C' B) ((B _129) (T #3))) _111)))) ((B T) ((B (B P)) ((C' _91) (_93 #4)))))) ((A :112 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (
\ No newline at end of file
+1145
+((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 "Applicative.pure"))) ((A :7 (K (noDefault "Applicative.<*>"))) ((A :8 (((S' B) _3) (((C' _112) _1) _104))) ((A :9 (((S' B) _3) (((C' _115) _1) _105))) ((A :10 _977) ((A :11 ((B _1019) _10)) ((A :12 (((S' _1019) _10) I)) ((A :13 _947) ((A :14 (_13 "undefined")) ((A :15 I) ((A :16 (((C' B) _976) ((C _103) _15))) ((A :17 (((C' _16) ((_111 _990) _92)) ((_103 (_23 _992)) _91))) ((A :18 ((B ((S _1019) (_23 _992))) _13)) ((A :19 ((B (B (B C))) ((B (B C)) P))) ((A :20 (T (BK (BK K)))) ((A :21 (T (K (BK K)))) ((A :22 (T (K (K K)))) ((A :23 (T (K (K A)))) ((A :24 (K (noDefault "Monad.>>="))) ((A :25 (((C' (C' B)) _21) K)) ((A :26 ((B _2) _20)) ((A :27 (((S' (C' B)) _21) (((S' (C' B)) _21) (B' _23)))) ((A :28 P) ((A :29 (T K)) ((A :30 (T A)) ((A :31 (K _13)) ((A :32 ((B (B Y)) (((S' B) (B' ((B P) ((C _23) _147)))) (((S' (C' B)) ((B (B (C' B))) (B' _21))) (((S' (C' (C' B))) (B' _21)) (((C' B) (B' _23)) _148)))))) ((A :33 ((B (B Y)) (((S' B) (B' ((B P) ((C _23) _905)))) (((C' (C' B)) ((B (B (C' B))) (B' _21))) BK)))) ((A :34 ((B T) ((C _23) _905))) ((A :35 ((C _32) _104)) ((A :36 T) ((A :37 ((_110 ((B (B (_101 _36))) ((B ((C' C) _40)) (B P)))) (_114 _37))) ((A :38 (((((_0 _37) ((B (_101 _36)) P)) (_27 _39)) ((B (B (_101 _36))) (((C' B) ((B C) _40)) (BK _40)))) (_9 _38))) ((A :39 ((((_19 _38) ((B (B (_101 _36))) (((C' B) ((B C) _40)) (B _40)))) (_4 _38)) (_2 _38))) ((A :40 (T I)) ((A :41 ((B (_103 _235)) _40)) ((A :42 ((B (_101 _36)) (B (P _905)))) ((A :43 ((B (_101 _36)) (BK (P _905)))) ((A :44 ((_101 _36) ((S P) I))) ((A :45 ((B (_101 _36)) ((C (S' P)) I))) ((A :46 (R _53)) ((A :47 (T _52)) ((A :48 ((P _53) _52)) ((A :49 _53) ((A :50 ((C ((C S') _48)) I)) ((A :51 ((C S) _48)) ((A :52 K) ((A :53 A) ((A :54 ((_95 _941) _942)) ((A :55 ((_95 _951) (_99 _55))) ((A :56 _952) ((A :57 _953) ((A :58 (((S' _47) (_944 #97)) ((C _944) #122))) ((A :59 (((S' _47) (_944 #65)) ((C _944) #90))) ((A :60 (((S' _46) _58) _59)) ((A :61 (((S' _47) (_944 #48)) ((C _944) #57))) ((A :62 (((S' _47) (_944 #32)) ((C _944) #126))) ((A :63 _941) ((A :64 _942) ((A :65 _944) ((A :66 _943) ((A :67 (((S' _46) ((C (_96 _54)) #32)) (((S' _46) ((C (_96 _54)) #9)) ((C (_96 _54)) #10)))) ((A :68 ((S ((S (((S' _47) (_65 #65)) ((C _65) #90))) (_53 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _56) (((C' _116) (((C' _117) _57) (_57 #65))) (_57 #97))))) ((A :69 ((S ((S (((S' _47) (_65 #97)) ((C _65) #97))) (_53 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _56) (((C' _116) (((C' _117) _57) (_57 #97))) (_57 #65))))) ((A :70 _912) ((A :71 _913) ((A :72 _914) ((A :73 _915) ((A :74 (_71 %0.0)) ((A :75 _70) ((A :76 _71) ((A :77 _72) ((A :78 _73) ((A :79 ((_95 _916) _917)) ((A :80 (_96 _79)) ((A :81 (_97 _79)) ((A :82 _918) ((A :83 _919) ((A :84 _920) ((A :85 _921) ((A :86 _82) ((A :87 _83) ((A :88 _84) ((A :89 _85) ((A :90 _922) ((A :91 ((B BK) T)) ((A :92 (BK T)) ((A :93 (((S' _95) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _96) (T K)))) (K _52)))) ((B ((C' B) (T (K _52)))) ((B _96) (T A))))) ((B _99) ((B _93) (((S' P) (T K)) (T A)))))) ((A :94 P) ((A :95 P) ((A :96 (T K)) ((A :97 (T A)) ((A :98 (K (noDefault "Eq.=="))) ((A :99 ((B (B (B _48))) _96)) ((A :100 ((_95 ((C ((C S') _48)) I)) (_99 _100))) ((A :101 I) ((A :102 (S _949)) ((A :103 B) ((A :104 I) ((A :105 K) ((A :106 C) ((A :107 _948) ((A :108 ((C ((C S') _235)) _236)) ((A :109 (((C' (S' (C' B))) B) I)) ((A :110 P) ((A :111 (T K)) ((A :112 (T A)) ((A :113 (K (noDefault "Functor.fmap"))) ((A :114 (((C' _103) _111) _105)) ((A :115 _111) ((A :116 _906) ((A :117 _907) ((A :118 _908) ((A :119 _909) ((A :120 _910) ((A :121 _911) ((A :122 (_117 #0)) ((A :123 ((_95 _929) _930)) ((A :124 _931) ((A :125 _932) ((A :126 _933) ((A :127 _934) ((A :128 (BK K)) ((A :129 ((B BK) ((B (B BK)) P))) ((A :130 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :131 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B)
\ No newline at end of file
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -8,6 +8,7 @@
IO,
Word,
NFData(..),
+ Type,
) where
import Control.DeepSeq
import Control.Exception(try)
@@ -18,7 +19,7 @@
import System.IO.Unsafe
import System.Environment
import Unsafe.Coerce
-import GHC.Types(Any)
+import GHC.Types(Any, Type)
primIntAdd :: Int -> Int -> Int
primIntAdd = (+)
--- a/lib/Control/Applicative.hs
+++ b/lib/Control/Applicative.hs
@@ -1,9 +1,16 @@
module Control.Applicative(module Control.Applicative) where
import Primitives -- for fixity
import Data.Functor
+import Data.Function
infixl 4 <*>
+infixl 4 *>
+infixl 4 <*
class Functor f => Applicative (f :: Type -> Type) where
pure :: forall a . a -> f a
(<*>) :: forall a b . f (a -> b) -> f a -> f b
+ (*>) :: forall a b . f a -> f b -> f b
+ (<*) :: forall a b . f a -> f b -> f a
+ a1 *> a2 = (id <$ a1) <*> a2
+ a1 <* a2 = (const <$> a1) <*> a2
--- a/lib/Control/Monad.hs
+++ b/lib/Control/Monad.hs
@@ -1,6 +1,11 @@
module Control.Monad(module Control.Monad) where
import Primitives -- for fixity
import Control.Applicative
+import Control.Error
+import Data.Bool
+import Data.Char
+import Data.Function
+import Data.List
infixl 1 >>
infixl 1 >>=
@@ -13,3 +18,43 @@
-- Maybe remove this
return :: forall a . a -> m a
return = pure
+
+ap :: forall (m :: Type -> Type) a b . Monad m => m (a -> b) -> m a -> m b
+ap f a = do
+ f' <- f
+ a' <- a
+ return (f' a')
+
+class Monad m => MonadFail (m :: Type -> Type) where
+ fail :: forall a . String -> m a
+ fail = error
+
+mapM :: forall (m :: Type -> Type) a b . Monad m => (a -> m b) -> [a] -> m [b]
+mapM f =
+ let
+ rec arg =
+ case arg of
+ [] -> return []
+ a : as -> do
+ b <- f a
+ bs <- rec as
+ return (b : bs)
+ in rec
+
+mapM_ :: forall (m :: Type -> Type) a b . Monad m => (a -> m b) -> [a] -> m ()
+mapM_ f =
+ let
+ rec arg =
+ case arg of
+ [] -> return ()
+ a : as -> do
+ _ <- f a
+ rec as
+ in rec
+
+when :: forall (m :: Type -> Type) . Monad m => Bool -> m () -> m ()
+when False _ = return ()
+when True ma = ma
+
+sequence :: forall (m :: Type -> Type) a . Monad m => [m a] -> m [a]
+sequence = mapM id
--- a/lib/Control/Monad/State/Strict.hs
+++ b/lib/Control/Monad/State/Strict.hs
@@ -1,9 +1,32 @@
{-# LANGUAGE QualifiedDo #-}-module Control.Monad.State.Strict(module Control.Monad.State.Strict) where
+module Control.Monad.State.Strict(
+ module Control.Monad.State.Strict,
+ module Control.Monad,
+ ) where
import Prelude
+import Control.Monad
data State s a = S (s -> (a, s))
+instance forall s . Functor (State s) where
+ fmap f sa = S $ \ s ->
+ case runState sa s of
+ (a, ss) -> (f a, ss)
+
+instance forall s . Applicative (State s) where
+ pure a = S $ \ s -> (a, s)
+ (<*>) = ap
+ (*>) m k = S $ \ s ->
+ case runState m s of
+ (_, ss) -> runState k ss
+
+instance forall s . Monad (State s) where
+ (>>=) m k = S $ \ s ->
+ case runState m s of
+ (a, ss) -> runState (k a) ss
+ (>>) = (*>)
+ return = pure
+
runState :: forall s a . State s a -> (s -> (a,s))
runState (S x) = x
@@ -10,6 +33,7 @@
evalState :: forall s a . State s a -> (s -> a)
evalState sa = fst . runState sa
+{-(>>=) :: forall s a b . State s a -> (a -> State s b) -> State s b
(>>=) m k = S $ \ s ->
case runState m s of
@@ -36,6 +60,7 @@
f <- sf
a <- sa
Control.Monad.State.Strict.return (f a)
+-}
modify :: forall s . (s -> s) -> State s ()
modify f = S $ \ s -> ((), f s)
@@ -49,6 +74,7 @@
gets :: forall s a . (s -> a) -> State s a
gets f = S $ \ s -> (f s, s)
+{-mapM :: forall s a b . (a -> State s b) -> [a] -> State s [b]
mapM f =
let
@@ -81,3 +107,4 @@
sequence :: forall s a . [State s a] -> State s [a]
sequence = Control.Monad.State.Strict.mapM id
+-}
--- a/lib/Data/Functor.hs
+++ b/lib/Data/Functor.hs
@@ -1,8 +1,11 @@
module Data.Functor(module Data.Functor) where
import Primitives -- for fixity
+import Data.Function
class Functor (f :: Type -> Type) where
fmap :: forall a b . (a -> b) -> f a -> f b
+ (<$) :: forall a b . a -> f b -> f a
+ (<$) = fmap . const
infixl 4 <$>
(<$>) :: forall (f :: Type -> Type) a b . Functor f => (a -> b) -> f a -> f b
--- a/lib/Prelude.hs
+++ b/lib/Prelude.hs
@@ -1,12 +1,15 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
module Prelude(
+ module Control.Applicative,
module Control.Error,
+ module Control.Monad,
module Data.Bool,
module Data.Char,
module Data.Either,
module Data.Eq,
module Data.Function,
+ module Data.Functor,
module Data.Int,
module Data.List,
module Data.Maybe,
@@ -15,12 +18,15 @@
module System.IO,
module Text.String,
) where
+import Control.Applicative
import Control.Error
+import Control.Monad
import Data.Bool
import Data.Char
import Data.Either
import Data.Eq
import Data.Function
+import Data.Functor
import Data.Int
import Data.List
import Data.Maybe
--- a/lib/System/IO.hs
+++ b/lib/System/IO.hs
@@ -1,13 +1,21 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module System.IO(module System.IO, Handle, IO) where
+module System.IO(
+ module System.IO, Handle, IO,
+ module Data.Functor,
+ module Control.Applicative,
+ module Control.Monad,
+ ) where
import Primitives
+import Control.Applicative
import Control.Error
+import Control.Monad
import Data.Bool
import Data.Char
import Data.Eq
import Data.Int
import Data.List
+import Data.Functor
import Data.Maybe
import Data.Tuple
@@ -15,6 +23,19 @@
data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
+instance Functor IO where
+ fmap f ioa = ioa `primBind` \ a -> primReturn (f a)
+instance Applicative IO where
+ pure = primReturn
+ (<*>) = ap
+instance Monad IO where
+ (>>=) = primBind
+ (>>) = primThen
+ return = primReturn
+instance MonadFail IO where
+ fail = error
+
+{-infixl 1 >>=
(>>=) :: forall a b . IO a -> (a -> IO b) -> IO b
(>>=) = primBind
@@ -31,6 +52,7 @@
fmap :: forall a b . (a -> b) -> IO a -> IO b
fmap f ioa = ioa >>= \ a -> return (f a)
+-}
hSerialize :: forall a . Handle -> a -> IO ()
hSerialize = primHSerialize
@@ -88,6 +110,7 @@
print :: forall a . a -> IO ()
print = primHPrint stdout
+{-mapM :: forall a b . (a -> IO b) -> [a] -> IO [b]
mapM f =
let
@@ -109,6 +132,7 @@
when :: Bool -> IO () -> IO ()
when b io = if b then io else return ()
+-}
putStr :: String -> IO ()
putStr = hPutStr stdout
--- a/src/Compat.hs
+++ b/src/Compat.hs
@@ -6,7 +6,7 @@
import qualified Data.Function as F
import Data.Time
import Data.Time.Clock.POSIX
-import qualified Control.Monad as M
+--import qualified Control.Monad as M
import Control.Exception
import Data.List
import System.Environment
@@ -126,8 +126,8 @@
Left _ -> return Nothing
Right h -> return (Just h)
-when :: Bool -> IO () -> IO ()
-when = M.when
+--when :: Bool -> IO () -> IO ()
+--when = M.when
on :: (a -> a -> b) -> (c -> a) -> (c -> c -> b)
on = F.on
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -3,13 +3,14 @@
{-# OPTIONS_GHC -Wno-unused-do-bind #-}module MicroHs.Main(main) where
import Prelude
-import qualified MicroHs.IdentMap as M
--Ximport Data.List
+import Control.Monad
import Data.Maybe
import System.Environment
import MicroHs.Compile
import MicroHs.Exp
import MicroHs.Ident
+import qualified MicroHs.IdentMap as M
import MicroHs.Translate
import MicroHs.Interactive
--Ximport Compat
--- a/src/MicroHs/StateIO.hs
+++ b/src/MicroHs/StateIO.hs
@@ -2,9 +2,17 @@
-- See LICENSE file for full license.
{-# OPTIONS_GHC -Wno-unused-imports #-}-- State monad over IO
-module MicroHs.StateIO(module MicroHs.StateIO) where
-import Prelude --Xhiding (Monad(..), mapM)
-import qualified System.IO as IO
+module MicroHs.StateIO(
+ module MicroHs.StateIO,
+ module Control.Applicative,
+ module Control.Monad,
+ module Data.Functor,
+ ) where
+import Prelude
+import Control.Applicative
+import Control.Monad
+import Data.Functor
+--import qualified System.IO as IO
--Ximport qualified CompatIO as IO
data StateIO s a = S (s -> IO (a,s))
@@ -22,6 +30,28 @@
(_, ss) -> IO.return ss
-}
+instance forall s . Functor (StateIO s) where
+ fmap f sa = S $ \ s -> do
+ (a, ss) <- runStateIO sa s
+ return (f a, ss)
+
+instance forall s . Applicative (StateIO s) where
+ pure a = S $ \ s -> return (a, s)
+ (<*>) = ap
+ (*>) m k = S $ \ s -> do
+ (_, ss) <- runStateIO m s
+ runStateIO k ss
+
+instance forall s . Monad (StateIO s) where
+ (>>=) m k = S $ \ s -> do
+ (a, ss) <- runStateIO m s
+ runStateIO (k a) ss
+ (>>) = (*>)
+
+instance forall s . MonadFail (StateIO s) where
+ fail = error
+
+{-(>>=) :: forall s a b . StateIO s a -> (a -> StateIO s b) -> StateIO s b
(>>=) m k = S $ \ s -> IO.do
(a, ss) <- runStateIO m s
@@ -40,37 +70,27 @@
(a, ss) <- runStateIO sa s
IO.return (f a, ss)
-gets :: forall s a . (s -> a) -> StateIO s a
-gets f = S $ \ s -> IO.return (f s, s)
+fail :: forall s a . String -> StateIO s a
+fail = error
when :: forall s . Bool -> StateIO s () -> StateIO s ()
-when b s = if b then s else MicroHs.StateIO.return ()
+when b s = if b then s else return ()
+-}
+
+gets :: forall s a . (s -> a) -> StateIO s a
+gets f = S $ \ s -> return (f s, s)
+
modify :: forall s . (s -> s) -> StateIO s ()
-modify f = S $ \ s -> IO.return ((), f s)
+modify f = S $ \ s -> return ((), f s)
put :: forall s . s -> StateIO s ()
-put s = S $ \ _ -> IO.return ((), s)
+put s = S $ \ _ -> return ((), s)
get :: forall s . StateIO s s
-get = S $ \ s -> IO.return (s, s)
+get = S $ \ s -> return (s, s)
liftIO :: forall s a . IO a -> StateIO s a
-liftIO io = S $ \ s -> IO.do
+liftIO io = S $ \ s -> do
a <- io
- IO.return (a, s)
-
-mapM :: forall s a b . (a -> StateIO s b) -> [a] -> StateIO s [b]
-mapM f =
- let
- rec arg =
- case arg of
- [] -> MicroHs.StateIO.return []
- a : as -> MicroHs.StateIO.do
- b <- f a
- bs <- rec as
- MicroHs.StateIO.return (b : bs)
- in rec
-
-fail :: forall s a . String -> StateIO s a
-fail = error
+ return (a, s)
--- a/src/MicroHs/TCMonad.hs
+++ b/src/MicroHs/TCMonad.hs
@@ -13,7 +13,9 @@
--Ximport Data.Functor.Identity
--Ximport GHC.Stack
import Data.Char -- for String
+import Control.Applicative
import Control.Monad.State.Strict --Xhiding(ap)
+import Data.Functor
import MicroHs.Ident
import MicroHs.Expr
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -55,7 +55,7 @@
type ClsDef = (Ident, ClassInfo)
type InstDef= (Ident, InstInfo)
-type ClassInfo = ([IdKind], [EConstraint], [Ident]) -- class tyvars, superclasses, methods
+type ClassInfo = ([IdKind], [EConstraint], EType, [Ident]) -- class tyvars, superclasses, methods
-- Symbol table entry for symbol i.
data Entry = Entry
@@ -109,7 +109,7 @@
typeCheck :: forall a . [(ImportSpec, TModule a)] -> EModule -> TModule [EDef]
typeCheck aimps (EModule mn exps defs) =
--- trace (show amdl) $
+-- trace (unlines $ map (showTModuleExps . snd) aimps) $
let
imps = map filterImports aimps
(fs, ts, ss, cs, is, vs, as) = mkTables imps
@@ -132,7 +132,7 @@
tModule :: IdentModule -> [FixDef] -> [TypeExport] -> [SynDef] -> [ClsDef] -> [InstDef] -> [ValueExport] -> [EDef] ->
TModule [EDef]
tModule mn fs ts ss cs is vs ds =
--- trace ("tmodule " ++ showIdent mn ++ ": " ++ show ts) $+-- trace ("tmodule " ++ showIdent mn ++ ":\n" ++ show vs) $seqL ts `seq` seqL vs `seq` TModule mn fs ts ss cs is vs ds
where
seqL :: forall a . [a] -> ()
@@ -268,10 +268,13 @@
allValues :: ValueTable
allValues =
let
- syms (is, TModule mn _ tes _ _ _ ves _) =
+ syms (is, TModule mn _ tes _ cls _ ves _) =
+-- trace ("allValues: mn=" ++ showIdent mn ++ " cls=" ++ showList showIdentClassInfo cls) $[ (v, [e]) | ValueExport i e <- ves, v <- qns is mn i ] ++
- [ (v, [e]) | TypeExport _ _ cs <- tes, ValueExport i e <- cs, v <- qns is mn i ]
- in stFromListWith (unionBy eqEntry) $ concatMap syms mdls
+ [ (v, [e]) | TypeExport _ _ cs <- tes, ValueExport i e <- cs, v <- qns is mn i ] ++
+ [ (v, [Entry (EVar v) t]) | (i, (_, _, t, _)) <- cls, let { v = mkClassConstructor i } ]+ in --(\ t -> trace ("allValues: " ++ showSymTab t) t) $+ stFromListWith (unionBy eqEntry) $ concatMap syms mdls
allSyns =
let
syns (_, TModule _ _ _ ses _ _ _ _) = ses
@@ -297,7 +300,8 @@
allClasses =
let
clss (_, TModule _ _ _ _ ces _ _ _) = ces
- in M.fromList $ concatMap clss mdls
+ in --(\ m -> trace ("allClasses: " ++ showList showIdentClassInfo (M.toList m)) m) $+ M.fromList $ concatMap clss mdls
allInsts :: InstTable
allInsts =
let
@@ -448,7 +452,7 @@
TC mn n fx tt st vt ast sub m cs is es <- get
put $ TC mn n fx tt st vt (M.insert i ids ast) sub m cs is es
-addClassTable :: Ident -> ([IdKind], [EConstraint], [Ident]) -> T ()
+addClassTable :: Ident -> ClassInfo -> T ()
addClassTable i x = T.do
TC mn n fx tt st vt ast sub m cs is es <- get
put $ TC mn n fx tt st vt ast sub m (M.insert i x cs) is es
@@ -928,8 +932,8 @@
Type lhs t -> addLHSKind lhs (getTypeKind t)
Class _ lhs@(i, _) ms -> T.do
addLHSKind lhs kConstraint
- addAssoc i (mkClassConstructor i : [ m | BSign m _ <- ms ])
- _ -> T.return ()
+ addAssoc i ({-mkClassConstructor i : -} [ m | BSign m _ <- ms ])+ _ -> T.return ()
getTypeKind :: EType -> EKind
getTypeKind (ESign _ k) = k
@@ -1036,8 +1040,8 @@
expandClass dcls@(Class ctx (iCls, vks) ms) = T.do
mn <- gets moduleName
let
- methIds = [ i | (BSign i _) <- ms ]
meths = [ b | b@(BSign _ _) <- ms ]
+ methIds = map (\ (BSign i _) -> i) meths
mdflts = [ (i, eqns) | BFcn i eqns <- ms ]
tCtx = tApps (qualIdent mn iCls) (map (EVar . idKindIdent) vks)
mkDflt (BSign methId t) = [ Sign iDflt $ EForall vks $ tCtx `tImplies` t, def $ lookup methId mdflts ]
@@ -1048,7 +1052,7 @@
noDflt = EApp noDefaultE (ELit noSLoc (LStr (unIdent iCls ++ "." ++ unIdent methId)))
mkDflt _ = impossible
dDflts = concatMap mkDflt meths
- addClassTable (qualIdent mn iCls) (vks, ctx, methIds)
+ addClassTable (qualIdent mn iCls) (vks, ctx, EUVar 0, methIds) -- Initial entry, no type needed.
T.return $ dcls : dDflts
expandClass d = T.return [d]
@@ -1081,13 +1085,13 @@
expandInst :: EDef -> T [EDef]
expandInst dinst@(Instance vks ctx cc bs) = T.do
let loc = getSLocExpr cc
- iCls = getAppCon cc
+ qiCls = getAppCon cc
iInst <- newIdent loc "inst"
let sign = Sign iInst (eForall vks $ addConstraints ctx cc)
- (e, _) <- tLookupV iCls
+-- (e, _) <- tLookupV iCls
ct <- gets classTable
- let qiCls = getAppCon e
- (_, supers, mis) <-
+-- let qiCls = getAppCon e
+ (_, supers, _, mis) <-
case M.lookup qiCls ct of
Nothing -> tcError loc $ "not a class " ++ showIdent qiCls
Just x -> T.return x
@@ -1098,7 +1102,7 @@
meths = map meth mis
sups = map (const (EVar $ mkIdentSLoc loc "dict$")) supers
args = sups ++ meths
- let bind = Fcn iInst $ eEqns [] $ foldl EApp (EVar $ mkClassConstructor iCls) args
+ let bind = Fcn iInst $ eEqns [] $ foldl EApp (EVar $ mkClassConstructor qiCls) args
mn <- gets moduleName
addInstTable [(EVar $ qualIdent mn iInst, vks, ctx, cc)]
T.return [dinst, sign, bind]
@@ -1143,6 +1147,7 @@
let
meths = [ b | b@(BSign _ _) <- ms ]
methTys = map (\ (BSign _ t) -> t) meths
+ methIds = map (\ (BSign i _) -> i) meths
supTys = ctx -- XXX should do some checking
targs = supTys ++ methTys
qiCls = qualIdent mn iCls
@@ -1149,11 +1154,14 @@
tret = tApps qiCls (map tVarK vks)
cti = [ (qualIdent mn iCon, length targs) ]
iCon = mkClassConstructor iCls
- extValETop iCon (EForall vks $ foldr tArrow tret targs) (ECon $ ConData cti (qualIdent mn iCon))
+ iConTy = EForall vks $ foldr tArrow tret targs
+ extValETop iCon iConTy (ECon $ ConData cti (qualIdent mn iCon))
let addMethod (BSign i t) = extValETop i (EForall vks $ tApps qiCls (map (EVar . idKindIdent) vks) `tImplies` t) (EVar $ qualIdent mn i)
addMethod _ = impossible
-- traceM ("addValueClass " ++ showEType (ETuple ctx))T.mapM_ addMethod meths
+ -- Update class table, now with actual constructor type.
+ addClassTable qiCls (vks, ctx, iConTy, methIds)
{-bundleConstraints :: [EConstraint] -> EType -> EType
@@ -1920,7 +1928,7 @@
Just _ -> concat <$> T.mapM (\ (i, a) -> expandDict (mkTupleSel i (length args) `EApp` edict) a) (zip [0..] args)
Nothing -> T.do
ct <- gets classTable
- let (iks, sups, _) = fromMaybe impossible $ M.lookup iCls ct
+ let (iks, sups, _, _) = fromMaybe impossible $ M.lookup iCls ct
sub = zip (map idKindIdent iks) args
sups' = map (subst sub) sups
mn <- gets moduleName
@@ -2088,8 +2096,8 @@
data SymTab a = SymTab (M.Map [a]) [(Ident, a)]
--Xderiving(Show)
-stLookup :: forall a . --XShow a =>
- String -> Ident -> SymTab a -> Either String a
+stLookup :: --forall a . --XShow a =>
+ String -> Ident -> SymTab Entry -> Either String Entry
stLookup msg i (SymTab genv lenv) =
case lookupBy eqIdent i lenv of
Just e -> Right e
@@ -2096,7 +2104,7 @@
Nothing ->
case M.lookup i genv of
Just [e] -> Right e
- Just _ -> Left $ "ambiguous " ++ msg ++ ": " ++ showIdent i
+ Just es -> Left $ "ambiguous " ++ msg ++ ": " ++ showIdent i ++ " " ++ showList showExpr [ e | Entry e _ <- es ]
Nothing -> Left $ "undefined " ++ msg ++ ": " ++ showIdent i
-- ++ "\n" ++ show lenv ++ "\n" ++ show genv
@@ -2115,3 +2123,28 @@
-- XXX Use insertWith to follow Haskell semantics.
stInsertGlb :: forall a . Ident -> [a] -> SymTab a -> SymTab a
stInsertGlb i as (SymTab genv lenv) = SymTab (M.insert i as genv) lenv
+
+-----------------------------
+{-+showSymTab :: SymTab Entry -> String
+showSymTab (SymTab im ies) = showList showIdent (map fst (M.toList im) ++ map fst ies)
+
+showTModuleExps :: TModule a -> String
+showTModuleExps (TModule mn _fxs tys _syns _clss _insts vals _defs) =
+ showIdent mn ++ ":\n" ++
+ unlines (map ((" " ++) . showValueExport) vals) +++ unlines (map ((" " ++) . showTypeExport) tys)+
+showValueExport :: ValueExport -> String
+showValueExport (ValueExport i (Entry qi t)) =
+ showIdent i ++ " = " ++ showExpr qi ++ " :: " ++ showEType t
+
+showTypeExport :: TypeExport -> String
+showTypeExport (TypeExport i (Entry qi t) vs) =
+ showIdent i ++ " = " ++ showExpr qi ++ " :: " ++ showEType t ++ " assoc=" ++ showList showValueExport vs
+
+showIdentClassInfo :: (Ident, ClassInfo) -> String
+showIdentClassInfo (i, (_vks, _ctx, cc, ms)) =
+ showIdent i ++ " :: " ++ showEType cc ++
+ " has " ++ showList showIdent ms
+-}
--- a/src/Text/ParserComb.hs
+++ b/src/Text/ParserComb.hs
@@ -21,7 +21,8 @@
LastFail(..),
) where
--Ximport Prelude()
-import PreludeNoIO
+import Prelude
+import Control.Monad --Xhiding(guard)
data LastFail t
= LastFail Int [t] [String]
@@ -55,6 +56,29 @@
runP :: forall s t a . Prsr s t a -> (([t], s) -> Res s t a)
runP (P p) = p
+instance forall s t . Functor (Prsr s t) where
+ fmap f p = P $ \ t ->
+ case runP p t of
+ Many aus lf -> Many [ (f a, u) | (a, u) <- aus ] lf
+
+instance forall s t . Applicative (Prsr s t) where
+ pure a = P $ \ t -> Many [(a, t)] noFail
+ (<*>) = ap
+ (*>) p k = p >>= \ _ -> k
+
+instance forall s t . Monad (Prsr s t) where
+ (>>=) p k = P $ \ t ->
+ case runP p t of
+ Many aus plf ->
+ let { xss = [ runP (k a) u | au <- aus, let { (a, u) = au } ] }+ in case unzip [ (rs, lf) | xs <- xss, let { Many rs lf = xs } ] of+ (rss, lfs) -> Many (concat rss) (longests (plf : lfs))
+ return = pure
+
+instance forall s t . MonadFail (Prsr s t) where
+ fail m = P $ \ (ts, _) -> Many [] (LastFail (length ts) (take 1 ts) [m])
+
+{-pure :: forall s t a . a -> Prsr s t a
pure a = P $ \ t -> Many [(a, t)] noFail
@@ -92,6 +116,7 @@
infixl 4 <$
(<$) :: forall s t a b . a -> Prsr s t b -> Prsr s t a
(<$) a p = p >> pure a
+-}
guard :: forall s t . Bool -> Prsr s t ()
guard b = if b then pure () else empty
@@ -107,8 +132,10 @@
case runP q t of
Many b lfb -> Many (a ++ b) (longest lfa lfb)
+{-fail :: forall s t a . String -> Prsr s t a
fail m = P $ \ (ts, _) -> Many [] (LastFail (length ts) (take 1 ts) [m])
+-}
get :: forall s t . Prsr s t s
get = P $ \ t@(_, s) -> Many [(s, t)] noFail
--- a/tests/IOTest.hs
+++ b/tests/IOTest.hs
@@ -8,7 +8,7 @@
f x = x*2+1
foo :: IO ()
-foo = IO.do
+foo = do
putStrLn "foo 1"
putStrLn "foo 2"
--
⑨