Fixed Monadfail issue

.github/workflows/haskell-ci.yml

@@ -37,12 +37,12 @@ jobs:
             compilerKind: ghc
             compilerVersion: 9.4.5
             setup-method: ghcup
-            allow-failure: true   # TODO: fix MonadFail instance for ST
+            allow-failure: false  
           - compiler: ghc-9.6.2
             compilerKind: ghc
             compilerVersion: 9.6.2
             setup-method: ghcup
-            allow-failure: true   # TODO: fix MonadFail instance for ST
+            allow-failure: false
       fail-fast: false
     steps:
       - name: apt

README.md

@@ -628,3 +628,7 @@ Here are some ideas for possible future extensions and improvements.
 - Add support for implicit and explicit parallelism of the graph-reduction engine.
   (implicit parallelism for strict operations, and an explicit `P`-combinator)
 
+## TODO:
+
+- OptEta und Bulk beide zu laufen bringen, aufräumen
+- benchmarks überprüfen!

src/CLTerm.hs

@@ -17,9 +17,13 @@ data CL = Com Combinator | INT Integer | CL :@ CL
 instance Show CL where
   showsPrec :: Int -> CL -> ShowS
   showsPrec p = \case
-    Com s -> (if p > 0 then (' ':) else id) . (show s ++)
+    Com c -> (if p > 0 then (' ':) else id) . (toString c ++)
     INT i -> ((' ': show i )++)
-    t :@ u -> showParen (p > 0) $ shows t . showsPrec 1 u   
+    t :@ u -> showParen (p > 0) $ shows t . showsPrec 1 u  
+    where 
+      toString :: Combinator -> String
+      toString (BulkCom c n) = c ++ show n
+      toString c = show c
 
 type LeftAncestors = [CL]
 

src/GraphReduction.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module GraphReduction
   ( toString,
     mToString,
@@ -18,6 +19,12 @@ import           Data.STRef       (STRef, newSTRef, readSTRef,
 import           Parser           (Expr (..))
 import CLTerm
 
+#if MIN_VERSION_base(4,17,0)
+-- explicit MonadFail declaration required for newer base versions
+instance MonadFail (ST s) where
+  fail :: String -> ST s a
+  fail = error
+#endif  
 
 infixl 5 :@:
 

src/Kiselyov.hs

@@ -5,7 +5,7 @@ module Kiselyov
     --convert,
     --plain,
     --bulkPlain,
-    breakBulkLinear,
+    --breakBulkLinear,
     breakBulkLog,
     bulkOpt,
     compileKi,
@@ -74,7 +74,7 @@ bulkPlain bulk = convert (#) where
 --}
 bulk :: Combinator -> Int -> CL
 bulk c 1 = Com c
-bulk c n = Com $ BulkCom (show c) n --(fromString (show c ++ show n)) -- TODO: this is a hack and will work onlx upto 2.
+bulk c n = Com $ BulkCom (show c) n
 
 compileKiEither :: Environment -> (Environment -> DB -> ([Bool],CL)) -> Either String CL
 compileKiEither env convertFun = case lookup "main" env of
@@ -146,23 +146,23 @@ zipWithDefault d f     xs     [] = flip f d <$> xs
 zipWithDefault d f (x:xt) (y:yt) = f x y : zipWithDefault d f xt yt
 
 
-breakBulkLinear :: Combinator -> Int -> CL
-breakBulkLinear B n = iterate (comB' :@) (Com B) !! (n - 1)
-breakBulkLinear C n = iterate (comC' :@) (Com C) !! (n - 1)
-breakBulkLinear S n = iterate (comS' :@) (Com S) !! (n - 1)
+-- breakBulkLinear :: Combinator -> Int -> CL
+-- breakBulkLinear B n = iterate (comB' :@) (Com B) !! (n - 1)
+-- breakBulkLinear C n = iterate (comC' :@) (Com C) !! (n - 1)
+-- breakBulkLinear S n = iterate (comS' :@) (Com S) !! (n - 1)
 
-comB' :: CL
-comB' = Com B:@ Com B
-comC' :: CL
-comC' = Com B :@ (Com B :@ Com C) :@ Com B
-comS' :: CL
-comS' = Com B :@ (Com B :@ Com S) :@ Com B
+-- comB' :: CL
+-- comB' = Com B:@ Com B
+-- comC' :: CL
+-- comC' = Com B :@ (Com B :@ Com C) :@ Com B
+-- comS' :: CL
+-- comS' = Com B :@ (Com B :@ Com S) :@ Com B
 
 bits n = r:if q == 0 then [] else bits q where (q, r) = divMod n 2
 
 breakBulkLog :: Combinator -> Int -> CL
 breakBulkLog c 1 = Com c
-breakBulkLog B n = foldr (:@) (Com B) $ map (bs!!) $ init $ bits n where
+breakBulkLog B n = foldr (((:@)) . (bs!!)) (Com B) (init $ bits n) where
   bs = [sbi, Com B :@ (Com B :@ Com B) :@ sbi]
 breakBulkLog c n = (foldr (:@) (prime c) $ map (bs!!) $ init $ bits n) :@ Com I where
   bs = [sbi, Com B :@ (Com B :@ prime c) :@ sbi]

stack.yaml

@@ -18,7 +18,7 @@
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
 resolver:
-  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml
+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/11.yaml
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.

test/ReducerKiselyovSpec.hs

@@ -41,7 +41,7 @@ loadTestCase name = readFile $ "test/" ++ name ++ ".ths"
 showCode :: SourceCode -> IO ()
 showCode src = do
   let pEnv = parseEnvironment src
-      aExp = compileBulk pEnv --compileKi pEnv optEta
+      aExp = compileBulk pEnv 
   putStrLn "The source: "
   putStrLn src
   putStrLn "The result of the kiselyov compiler:"
@@ -50,7 +50,7 @@ showCode src = do
 runTest :: SourceCode -> Bool
 runTest src =
   let pEnv = parseEnvironment src
-      aExp = compileBulk pEnv  --compileKi pEnv optEta --compile pEnv abstractToSKI
+      aExp = compileBulk pEnv
       tExp = translate aExp
       expected = translate $ toCL $ fromJust (lookup "expected" pEnv)
       actual = link primitives tExp