shithub: MicroHs

Download patch

ref: bd6ab1354ae84408758de7c13c2be878865afd75
parent: 9a21178f2650f172f43e82aa74393167104e4047
author: Lennart Augustsson <lennart@augustsson.net>
date: Sun Oct 29 13:54:37 EDT 2023 

Use Alternative.


--- a/Makefile
+++ b/Makefile
@@ -65,6 +65,7 @@
 	$(GHCC) -c lib/Data/Functor.hs
 	$(GHCC) -c lib/Control/Applicative.hs
 	$(GHCC) -c lib/Control/Monad.hs
+	$(GHCC) -c lib/Control/Alternative.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
-1156
-((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' _123) _1) _115))) ((A :9 (((S' B) _3) (((C' _126) _1) _116))) ((A :10 _988) ((A :11 ((B _1030) _10)) ((A :12 (((S' _1030) _10) I)) ((A :13 _958) ((A :14 (_13 "undefined")) ((A :15 I) ((A :16 (((C' B) _987) ((C _114) _15))) ((A :17 (((C' _16) ((_122 _1001) _103)) ((_114 (_23 _1003)) _102))) ((A :18 ((B ((S _1030) (_23 _1003))) _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) _158)))) (((S' (C' B)) ((B (B (C' B))) (B' _21))) (((S' (C' (C' B))) (B' _21)) (((C' B) (B' _23)) _159)))))) ((A :33 ((B (B Y)) (((S' B) (B' ((B P) ((C _23) _916)))) (((C' (C' B)) ((B (B (C' B))) (B' _21))) BK)))) ((A :34 ((B T) ((C _23) _916))) ((A :35 ((C _32) _115)) ((A :36 ((B _117) _21)) ((A :37 ((B C) ((B C') _21))) ((A :38 ((B _117) _37)) ((A :39 ((_121 _165) (_125 _39))) ((A :40 (((((_0 _39) ((C O) K)) (_27 _41)) (_8 _40)) (_9 _40))) ((A :41 ((((_19 _40) (_117 _164)) (_25 _41)) (_26 _41))) ((A :42 ((_28 _41) (K _158))) ((A :43 ((_121 ((B (P _233)) (B _234))) (_125 _43))) ((A :44 (((((_0 _43) _234) (_27 _45)) (_8 _44)) (_9 _44))) ((A :45 ((((_19 _44) (T _233)) (_25 _45)) (_26 _45))) ((A :46 T) ((A :47 ((_121 ((B (B (_112 _46))) ((B ((C' C) _50)) (B P)))) (_125 _47))) ((A :48 (((((_0 _47) ((B (_112 _46)) P)) (_27 _49)) ((B (B (_112 _46))) (((C' B) ((B C) _50)) (BK _50)))) (_9 _48))) ((A :49 ((((_19 _48) ((B (B (_112 _46))) (((C' B) ((B C) _50)) (B _50)))) (_4 _48)) (_2 _48))) ((A :50 (T I)) ((A :51 ((B (_114 _245)) _50)) ((A :52 ((B (_112 _46)) (B (P _916)))) ((A :53 ((B (_112 _46)) (BK (P _916)))) ((A :54 ((_112 _46) ((S P) I))) ((A :55 ((B (_112 _46)) ((C (S' P)) I))) ((A :56 (R _63)) ((A :57 (T _62)) ((A :58 ((P _63) _62)) ((A :59 _63) ((A :60 ((C ((C S') _58)) I)) ((A :61 ((C S) _58)) ((A :62 K) ((A :63 A) ((A :64 ((_106 _952) _953)) ((A :65 ((_106 _962) (_110 _65))) ((A :66 _963) ((A :67 _964) ((A :68 (((S' _57) (_955 #97)) ((C _955) #122))) ((A :69 (((S' _57) (_955 #65)) ((C _955) #90))) ((A :70 (((S' _56) _68) _69)) ((A :71 (((S' _57) (_955 #48)) ((C _955) #57))) ((A :72 (((S' _56) _70) _71)) ((A :73 (((S' _57) (_955 #32)) ((C _955) #126))) ((A :74 _952) ((A :75 _953) ((A :76 _955) ((A :77 _954) ((A :78 (((S' _56) ((C (_107 _64)) #32)) (((S' _56) ((C (_107 _64)) #9)) ((C (_107 _64)) #10)))) ((A :79 ((S ((S (((S' _57) (_76 #65)) ((C _76) #90))) (_63 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _66) (((C' _127) (((C' _128) _67) (_67 #65))) (_67 #97))))) ((A :80 ((S ((S (((S' _57) (_76 #97)) ((C _76) #97))) (_63 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _66) (((C' _127) (((C' _128) _67) (_67 #97))) (_67 #65))))) ((A :81 _923) ((A :82 _924) ((A :83 _925) ((A :84 _926) ((A :85 (_82 %0.0)) ((A :86 _81) ((A :87 _82) ((A :88 _83) ((A :89 _84) ((A :90 ((_106 _927) _928)) ((A :91 (_107 _90)) ((A :92 (_108 _90)) ((A :93 _929) ((A :94 _930) ((A :95 _931) ((A :96 _932) ((A :97 _93) ((A :98 _94) ((A :99 _95) ((A :100 _96) ((A :101 _933) ((A :102 ((B BK) T)) ((A :103 (BK T)) ((A :104 (((S' _106) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _107) (T K)))) (K _62)))) ((B ((C' B) (T (K _62)))) ((B _107) (T A))))) ((B _110) ((B _104) (((S' P) (T K)) (T A)))))) ((A :105 P) ((A :106 P) ((A :107 (T K)) ((A :108 (T A)) ((A :109 (K (noDefault "Eq.=="))) ((A :110 ((B (B (B _58))) _107)) ((A :111 ((_106 ((C ((C S') _58)) I)) (_110 _111))) ((A :112 I) ((A :113 (S _960)) ((A :114 B) ((A :115 I) ((A :116 K) ((A :117 C) ((A :118 _959) ((A :119 ((C ((C S') _245)) _246)) ((A :120 (((C' (S' (C' B))) B) I)) ((A :121 P) ((A :122
\ No newline at end of file
+1163
+((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' _137) ((B _12) _1)) _170))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _169))) ((A :10 (((S' P) _2) (((C' _13) _1) _927))) ((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' _134) _12) _126))) ((A :20 (((S' B) _14) (((C' _137) _12) _127))) ((A :21 _999) ((A :22 ((B _1041) _21)) ((A :23 (((S' _1041) _21) I)) ((A :24 _969) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _998) ((C _125) _26))) ((A :28 (((C' _27) ((_133 _1012) _114)) ((_125 (_34 _1014)) _113))) ((A :29 ((B ((S _1041) (_34 _1014))) _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) _169)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _170)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _927)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _927))) ((A :46 ((C _43) _126)) ((A :47 ((B _128) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _128) _48)) ((A :50 ((_132 _176) (_136 _50))) ((A :51 (((((_11 _50) ((C O) K)) (_38 _52)) (_19 _51)) (_20 _51))) ((A :52 ((((_30 _51) (_128 _175)) (_36 _52)) (_37 _52))) ((A :53 ((_39 _52) (K _169))) ((A :54 ((_132 ((B (P _244)) (B _245))) (_136 _54))) ((A :55 (((((_11 _54) _245) (_38 _56)) (_19 _55)) (_20 _55))) ((A :56 ((((_30 _55) (T _244)) (_36 _56)) (_37 _56))) ((A :57 T) ((A :58 ((_132 ((B (B (_123 _57))) ((B ((C' C) _61)) (B P)))) (_136 _58))) ((A :59 (((((_11 _58) ((B (_123 _57)) P)) (_38 _60)) ((B (B (_123 _57))) (((C' B) ((B C) _61)) (BK _61)))) (_20 _59))) ((A :60 ((((_30 _59) ((B (B (_123 _57))) (((C' B) ((B C) _61)) (B _61)))) (_15 _59)) (_13 _59))) ((A :61 (T I)) ((A :62 ((B (_125 _256)) _61)) ((A :63 ((B (_123 _57)) (B (P _927)))) ((A :64 ((B (_123 _57)) (BK (P _927)))) ((A :65 ((_123 _57) ((S P) I))) ((A :66 ((B (_123 _57)) ((C (S' P)) I))) ((A :67 (R _74)) ((A :68 (T _73)) ((A :69 ((P _74) _73)) ((A :70 _74) ((A :71 ((C ((C S') _69)) I)) ((A :72 ((C S) _69)) ((A :73 K) ((A :74 A) ((A :75 ((_117 _963) _964)) ((A :76 ((_117 _973) (_121 _76))) ((A :77 _974) ((A :78 _975) ((A :79 (((S' _68) (_966 #97)) ((C _966) #122))) ((A :80 (((S' _68) (_966 #65)) ((C _966) #90))) ((A :81 (((S' _67) _79) _80)) ((A :82 (((S' _68) (_966 #48)) ((C _966) #57))) ((A :83 (((S' _67) _81) _82)) ((A :84 (((S' _68) (_966 #32)) ((C _966) #126))) ((A :85 _963) ((A :86 _964) ((A :87 _966) ((A :88 _965) ((A :89 (((S' _67) ((C (_118 _75)) #32)) (((S' _67) ((C (_118 _75)) #9)) ((C (_118 _75)) #10)))) ((A :90 ((S ((S (((S' _68) (_87 #65)) ((C _87) #90))) (_74 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _77) (((C' _138) (((C' _139) _78) (_78 #65))) (_78 #97))))) ((A :91 ((S ((S (((S' _68) (_87 #97)) ((C _87) #97))) (_74 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _77) (((C' _138) (((C' _139) _78) (_78 #97))) (_78 #65))))) ((A :92 _934) ((A :93 _935) ((A :94 _936) ((A :95 _937) ((A :96 (_93 %0.0)) ((A :97 _92) ((A :98 _93) ((A :99 _94) ((A :100 _95) ((A :101 ((_117 _938) _939)) ((A :102 (_118 _101)) ((A :103 (_119 _101)) ((A :104 _940) ((A :105 _941) ((A :106 _942) ((A :107 _943) ((A :108 _104) ((A :109 _105) ((A :110 _106) ((A :111 _107) ((A :112 _944) ((A :113 ((B BK) T)) ((A :114 (BK T)) ((A :115 (((S' _117) (((S' C) ((B (C S')) (((C' C) (
\ No newline at end of file
--- /dev/null
+++ b/ghc/Control/Alternative.hs
@@ -1,0 +1,6 @@
+module Control.Alternative(
+  Alternative(..),
+  guard,
+  ) where
+import Control.Applicative
+import Control.Monad
--- /dev/null
+++ b/lib/Control/Alternative.hs
@@ -1,0 +1,21 @@
+module Control.Alternative(module Control.Alternative) where
+import Primitives
+import Control.Applicative
+import Data.Bool_Type
+import Data.Functor
+import Data.List
+
+infixl 3 <|>
+
+class Applicative f => Alternative (f :: Type -> Type) where
+    empty :: forall a . f a
+    (<|>) :: forall a . f a -> f a -> f a
+
+    some :: forall a . f a -> f [a]
+    some a = (:) <$> a <*> many a
+
+    many :: forall a . f a -> f [a]
+    many a = some a <|> pure []
+
+guard :: forall (f :: Type -> Type) a . Alternative f => Bool -> f ()
+guard b = if b then pure () else empty
--- a/src/Text/ParserComb.hs
+++ b/src/Text/ParserComb.hs
@@ -22,6 +22,7 @@
   ) where
 --Ximport Prelude()
 import Prelude
+import Control.Alternative
 import Control.Monad --Xhiding(guard)
 
 data LastFail t
@@ -78,6 +79,15 @@
 instance forall s t . MonadFail (Prsr s t) where
   fail m = P $ \ (ts, _) -> Many [] (LastFail (length ts) (take 1 ts) [m])
 
+instance forall s t . Alternative (Prsr s t) where
+  empty = P $ \ (ts, _) -> Many [] (LastFail (length ts) (take 1 ts) [])
+
+  (<|>) p q = P $ \ t ->
+    case runP p t of
+      Many a lfa ->
+        case runP q t of
+          Many b lfb -> Many (a ++ b) (longest lfa lfb)
+
 {-
 pure :: forall s t a . a -> Prsr s t a
 pure a = P $ \ t -> Many [(a, t)] noFail
@@ -116,7 +126,6 @@
 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
@@ -132,7 +141,6 @@
         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])
 -}
@@ -156,11 +164,13 @@
          Many b lfb -> Many b (longest lfa lfb)
     r -> r
 
+{-
 many :: forall s t a . Prsr s t a -> Prsr s t [a]
 many p = some p <|> pure []
 
 some :: forall s t a . Prsr s t a -> Prsr s t [a]
 some p = (:) <$> p <*> many p
+-}
 
 optional :: forall s t a . Prsr s t a -> Prsr s t (Maybe a)
 optional p = (Just <$> p) <|> pure Nothing
-- 
⑨