From 4bd2472b64e6a1b03ac82fc3ff8a84f9ac6b93c4 Mon Sep 17 00:00:00 2001
From: Christian Gram Kalhauge <chrg@dtu.dk>
Date: Tue, 12 Dec 2023 14:03:46 +0100
Subject: [PATCH] Many good changes
---
bin/rtree-c/Main.hs | 366 ++++++++++++++++++++++++++++++++++---------
flake.lock | 6 +-
flake.nix | 5 +-
package.yaml | 9 ++
rtree.cabal | 13 ++
src/Control/RTree.hs | 280 +++++++++++++++++++++------------
test/data/simple1.c | 3 +-
7 files changed, 501 insertions(+), 181 deletions(-)
diff --git a/bin/rtree-c/Main.hs b/bin/rtree-c/Main.hs
index c079c58..7710988 100644
--- a/bin/rtree-c/Main.hs
+++ b/bin/rtree-c/Main.hs
@@ -1,98 +1,322 @@
+{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE OverloadedStrings #-}
import Control.RTree
-import Data.Maybe (catMaybes, fromMaybe)
+import Colog
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.Trans.Maybe
+import Data.Foldable
+import Data.Functor
+import Data.Maybe
import Language.C qualified as C
-import "pretty" Text.PrettyPrint qualified as P
-import "transformers" Control.Monad.Trans.Maybe
-import "typed-process" System.Process.Typed
+import Options.Applicative
+import System.Directory
+import System.Exit
+import System.FilePath
+
+import Data.Text qualified as Text
+
+-- import System.Process.Typed
+
+import Data.Map.Strict qualified as Map
+import GHC.Stack
+import Language.C (CInitializer (CInitExpr))
+import System.IO
+import System.Process.Typed
+import Text.Pretty.Simple
+import Text.PrettyPrint qualified as P
+import Prelude hiding (log)
main :: IO ()
-main = do
- C.parseCFilePre "test/data/file2.c" >>= \case
- Right file -> do
- l <- runMaybeT (reduce' check (reduceC file))
- case l of
- Just l' -> output l'
- Nothing ->
- putStrLn "Failure"
- Left err ->
- print err
+main =
+ join
+ . execParser
+ $ info run
+ . fold
+ $ []
+
+process :: (WithLog env (Msg sev) m, MonadIO m) => sev -> Text.Text -> m a -> m a
+process sev p ma = do
+ msg "Started "
+ a <- ma
+ msg "Done "
+ pure a
where
- output l = do
- writeFile "test.c" (P.render (C.pretty l))
+ s = withFrozenCallStack callStack
+ msg t = Colog.logMsg (Msg sev s (t <> p))
+
+run :: (HasCallStack) => Parser (IO ())
+run = do
+ file <- strArgument $ fold [metavar "FILE"]
+
+ validity <- flag False True $ fold [long "validity"]
+
+ pure
+ $ usingLoggerT (cmap fmtMessage logTextStdout)
+ $ do
+ let
+ test f = process D ("test " <> Text.pack f) do
+ err <- liftIO $ runProcess (proc "clang" ["-O0", "test.c"])
+ log D (Text.pack $ show err)
+ pure (err == ExitSuccess)
+
+ output f c = process D ("writing " <> Text.pack f) do
+ let x = P.render (C.pretty (c $> C.undefNode))
+ liftIO $ writeFile f x
+
+ check f _ c = MaybeT do
+ when validity do
+ liftIO $ copyFile file (file <.> "last")
+ output f c
+ t <- test f
+ if t
+ then pure (Just ())
+ else do
+ liftIO $ when validity do
+ copyFile file (file <.> "fail")
+ copyFile (file <.> "last") file
+ exitFailure
+ pure Nothing
- check l = MaybeT do
- putStrLn "Outputting test"
- output l
- putStrLn "Running test"
- err <- runProcess (proc "clang" ["-O0", "test.c"])
- putStrLn $ "Done test" <> show err
- pure $ if err == ExitSuccess then Just () else Nothing
+ let bak = file <.> "bak"
+
+ process D "backing up file" do
+ liftIO $ copyFile file bak
+
+ process I "check predicate" do
+ t <- test file
+ unless t do
+ liftIO exitFailure
+
+ c <- process D "parsing file" do
+ parseCFile file
+
+ output file c
+
+ process I "sanity checks" do
+ c' <- parseCFile file
+ unless (void c' == void c) do
+ liftIO do
+ withFile "error.1.hs" WriteMode (`pHPrint` void c)
+ withFile "error.2.hs" WriteMode (`pHPrint` void c')
+ logError "Outputted a different file than i read... Please report original file and error.{1,2}.hs"
+ liftIO exitFailure
+
+ t <- test file
+ unless t do
+ liftIO exitFailure
+
+ l <- runMaybeT (reduceFast (check file) (Map.singleton (C.internalIdent "main") True) (reduceC c))
+
+ case l of
+ Just l' -> do
+ output file l'
+ logInfo "Success"
+ Nothing -> do
+ logError "Unable to produce results"
+ liftIO exitFailure
+ where
+ parseCFile file = do
+ res <- liftIO $ C.parseCFilePre file
+ case res of
+ Right c -> pure c
+ Left err -> do
+ logError (Text.pack (show err))
+ liftIO exitFailure
type Lab = C.Ident
-reduceC :: C.CTranslUnit -> RTree' Lab C.CTranslUnit
-reduceC (C.CTranslUnit es _) = do
- es' <- traverse rCExternalDeclaration es
- pure $ C.CTranslUnit (catMaybes es') C.undefNode
+reduceC :: (MonadReduce Lab m) => C.CTranslUnit -> m C.CTranslUnit
+reduceC (C.CTranslUnit es ni) = do
+ es' <- collect mrCExternalDeclaration es
+ pure $ C.CTranslUnit es' ni
-rCExternalDeclaration
- :: C.CExternalDeclaration C.NodeInfo
- -> RTree' Lab (Maybe (C.CExternalDeclaration C.NodeInfo))
-rCExternalDeclaration e = case e of
+mrCExternalDeclaration :: (MonadReduce Lab m) => C.CExternalDeclaration C.NodeInfo -> MaybeT m (C.CExternalDeclaration C.NodeInfo)
+mrCExternalDeclaration = \case
C.CFDefExt fun ->
split
(funName fun)
- (pure Nothing)
- (Just . C.CFDefExt <$> rCFunctionDef fun)
- _ -> pure Nothing <| pure (Just e)
+ empty
+ (C.CFDefExt <$> rCFunctionDef fun)
+ C.CDeclExt decl ->
+ C.CDeclExt <$> mrCDeclaration decl
+ a -> error (show a)
where
funName (C.CFunDef _ (C.CDeclr x _ _ _ _) _ _ _) =
x
-rCFunctionDef :: C.CFunctionDef C.NodeInfo -> RTree' Lab (C.CFunctionDef C.NodeInfo)
-rCFunctionDef (C.CFunDef spc dec cdecls smt _) = do
+mrCDeclarationItem :: (MonadReduce Lab m) => C.CDeclarationItem C.NodeInfo -> MaybeT m (C.CDeclarationItem C.NodeInfo)
+mrCDeclarationItem = \case
+ C.CDeclarationItem d@(C.CDeclr x _ _ _ _) i e ->
+ split x empty do
+ i' <- mtry $ munder i mrCInitializer
+ e' <- mtry $ munder e mrCExpression
+ pure (C.CDeclarationItem d i' e')
+ a -> error (show a)
+
+mrCInitializer :: (MonadReduce Lab m) => C.CInitializer C.NodeInfo -> MaybeT m (C.CInitializer C.NodeInfo)
+mrCInitializer = \case
+ C.CInitExpr e ni -> mrCExpression e <&> \e' -> CInitExpr e' ni
+ C.CInitList (C.CInitializerList items) ni -> do
+ collectNonEmpty' rmCInitializerListItem items <&> \items' ->
+ C.CInitList (C.CInitializerList items') ni
+ where
+ rmCInitializerListItem (pds, is) = do
+ pds' <- lift $ collect rmCPartDesignator pds
+ is' <- mrCInitializer is
+ pure (pds', is')
+
+ rmCPartDesignator :: (MonadReduce Lab m) => C.CPartDesignator C.NodeInfo -> m (C.CPartDesignator C.NodeInfo)
+ rmCPartDesignator = \case
+ a -> error (show a)
+
+mrCDeclaration :: (MonadReduce Lab m) => C.CDeclaration C.NodeInfo -> MaybeT m (C.CDeclaration C.NodeInfo)
+mrCDeclaration = \case
+ C.CDecl spc decl ni -> do
+ decl' <- lift $ collect mrCDeclarationItem decl
+ case decl' of
+ [] -> empty
+ decl'' -> pure $ C.CDecl spc decl'' ni
+ a -> error (show a)
+
+rCFunctionDef :: (MonadReduce Lab m) => C.CFunctionDef C.NodeInfo -> m (C.CFunctionDef C.NodeInfo)
+rCFunctionDef (C.CFunDef spc dec cdecls smt ni) = do
smt' <- rCStatement smt
- pure $ C.CFunDef spc dec cdecls smt' C.undefNode
+ pure $ C.CFunDef spc dec cdecls smt' ni
-rCStatement :: C.CStatement C.NodeInfo -> RTree' Lab (C.CStatement C.NodeInfo)
+rCStatement :: (MonadReduce Lab m) => C.CStatement C.NodeInfo -> m (C.CStatement C.NodeInfo)
rCStatement = \case
- C.CCompound is cbi _ -> do
- cbi' <- traverse rCCompoundBlockItem cbi
- pure $ C.CCompound is (catMaybes cbi') C.undefNode
- C.CExpr (Just e) _ -> do
- e' <- rCExpression e
- pure $ C.CExpr e' C.undefNode
- a -> pure a
-
-rCExpression :: C.CExpression C.NodeInfo -> RTree' Lab (Maybe (C.CExpression C.NodeInfo))
-rCExpression = \case
- C.CVar i _ ->
- splitOn
- i
- (pure Nothing)
- (pure . Just $ C.CVar i C.undefNode)
- C.CCall e es _ -> do
- me' <- rCExpression e
- case me' of
+ C.CCompound is cbi ni -> do
+ cbi' <- collect mrCCompoundBlockItem cbi
+ pure $ C.CCompound is cbi' ni
+ C.CExpr e ni -> do
+ e' <- runMaybeT $ mlift e >>= mrCExpression
+ pure $ C.CExpr e' ni
+ C.CIf e s els ni -> do
+ e' <- runMaybeT $ mrCExpression e
+ s' <- rCStatement s
+ els' <- case els of
+ Just els' -> do
+ pure Nothing <| Just <$> rCStatement els'
+ Nothing -> pure Nothing
+ case (e', els') of
+ (Nothing, Nothing) -> pure s'
+ (Just e'', Nothing) -> pure $ C.CIf e'' s' Nothing ni
+ (Nothing, Just x) -> pure $ C.CIf zeroExp s' (Just x) ni
+ (Just e'', Just x) -> pure $ C.CIf e'' s' (Just x) ni
+ C.CFor e1 e2 e3 s ni -> do
+ rCStatement s <| do
+ e1' <- rCForInit e1
+ e2' <- runMaybeT $ munder e2 mrCExpression
+ e3' <- runMaybeT $ munder e3 mrCExpression
+ s' <- rCStatement s
+ pure $ C.CFor e1' e2' e3' s' ni
+ C.CReturn e ni -> do
+ e' <- case e of
Nothing -> pure Nothing
- Just e' -> do
- es' <-
- traverse
- ( fmap
- ( fromMaybe (C.CConst (C.CIntConst (C.cInteger 0) C.undefNode))
- )
- . rCExpression
- )
- es
- pure . Just $ C.CCall e' es' C.undefNode
- e -> pure Nothing <| pure (Just e)
-
-rCCompoundBlockItem :: C.CCompoundBlockItem C.NodeInfo -> RTree' Lab (Maybe (C.CCompoundBlockItem C.NodeInfo))
-rCCompoundBlockItem a = pure Nothing <| pure (Just a)
+ Just e' -> Just <$> zrCExpression e'
+ pure $ C.CReturn e' ni
+ C.CBreak ni -> pure (C.CBreak ni)
+ C.CCont ni -> pure (C.CCont ni)
+ C.CLabel i s [] ni ->
+ -- todo fix attrs
+ splitOn i (rCStatement s) do
+ s' <- rCStatement s
+ pure $ C.CLabel i s' [] ni
+ C.CGoto i ni ->
+ -- todo fix attrs
+ splitOn i (pure $ C.CExpr Nothing ni) do
+ pure $ C.CGoto i ni
+ a -> error (show a)
+ where
+ rCForInit = \case
+ C.CForDecl decl -> do
+ m <- runMaybeT $ mrCDeclaration decl
+ pure $ case m of
+ Nothing -> C.CForInitializing Nothing
+ Just d' -> C.CForDecl d'
+ C.CForInitializing n -> do
+ C.CForInitializing <$> runMaybeT (munder n mrCExpression)
+
+orZero :: Maybe (C.CExpression C.NodeInfo) -> C.CExpression C.NodeInfo
+orZero = fromMaybe zeroExp
+
+zeroExp :: C.CExpression C.NodeInfo
+zeroExp = C.CConst (C.CIntConst (C.cInteger 0) C.undefNode)
+
+zrCExpression :: (MonadReduce Lab m) => C.CExpression C.NodeInfo -> m (C.CExpression C.NodeInfo)
+zrCExpression e = orZero <$> runMaybeT (mrCExpression e)
+
+mrCExpression :: (MonadReduce Lab m) => C.CExpression C.NodeInfo -> MaybeT m (C.CExpression C.NodeInfo)
+mrCExpression = \case
+ C.CVar i ni ->
+ splitOn i empty (pure $ C.CVar i ni)
+ C.CCall e es ni -> do
+ e' <- mrCExpression e
+ es' <- lift $ traverse zrCExpression es
+ pure $ C.CCall e' es' ni
+ C.CCond ec et ef ni -> do
+ ec' <- mrCExpression ec
+ ef' <- mrCExpression ef
+ et' <- mtry $ munder et mrCExpression
+ pure $ C.CCond ec' et' ef' ni
+ C.CBinary o elhs erhs ni -> ejoin elhs erhs \lhs rhs ->
+ pure $ C.CBinary o lhs rhs ni
+ C.CUnary o elhs ni -> do
+ lhs <- mrCExpression elhs
+ pure $ C.CUnary o lhs ni
+ C.CConst c -> do
+ -- TODO fix
+ pure $ C.CConst c
+ C.CCast cd e ni -> do
+ -- TODO fix
+ cd' <- mrCDeclaration cd
+ e' <- mrCExpression e
+ pure $ C.CCast cd' e' ni
+ C.CAssign op e1 e2 ni -> ejoin e1 e2 \e1' e2' ->
+ pure $ C.CAssign op e1' e2' ni
+ C.CIndex e1 e2 ni -> ejoin e1 e2 \e1' e2' ->
+ pure $ C.CIndex e1' e2' ni
+ C.CMember e i b ni -> do
+ splitOn i empty do
+ e' <- mrCExpression e
+ pure $ C.CMember e' i b ni
+ C.CComma items ni -> do
+ C.CComma <$> collectNonEmpty' mrCExpression items <*> pure ni
+ e -> error (show e)
+ where
+ ejoin elhs erhs = mjoin (mrCExpression elhs) (mrCExpression erhs)
+
+mjoin :: (Monad m) => MaybeT m a -> MaybeT m a -> (a -> a -> MaybeT m a) -> MaybeT m a
+mjoin mlhs mrhs fn = MaybeT do
+ lhs <- runMaybeT mlhs
+ case lhs of
+ Nothing -> runMaybeT mrhs
+ Just l -> do
+ rhs <- runMaybeT mrhs
+ case rhs of
+ Nothing -> pure (Just l)
+ Just r -> runMaybeT (fn l r)
+
+mtry :: (Functor m) => MaybeT m a -> MaybeT m (Maybe a)
+mtry (MaybeT mt) = MaybeT (Just <$> mt)
+
+mlift :: (Applicative m) => Maybe a -> MaybeT m a
+mlift a = MaybeT (pure a)
+
+munder :: (Monad m) => Maybe a -> (a -> MaybeT m b) -> MaybeT m b
+munder a mf = mlift a >>= mf
+
+mrCCompoundBlockItem :: (MonadReduce Lab m) => C.CCompoundBlockItem C.NodeInfo -> MaybeT m (C.CCompoundBlockItem C.NodeInfo)
+mrCCompoundBlockItem = \case
+ C.CBlockStmt s -> empty <| lift (C.CBlockStmt <$> rCStatement s)
+ C.CBlockDecl d -> C.CBlockDecl <$> mrCDeclaration d
+ a -> error (show a)
diff --git a/flake.lock b/flake.lock
index 4a4c323..f37ab3b 100644
--- a/flake.lock
+++ b/flake.lock
@@ -21,11 +21,11 @@
"language-c": {
"flake": false,
"locked": {
- "lastModified": 1701177364,
- "narHash": "sha256-SwRI8+PNfzfHOjFcn7bvgAylJeUMaFsvlJPm2r3QhTY=",
+ "lastModified": 1702044640,
+ "narHash": "sha256-jCpGlWLH6qnsskMnEOCAnYCKCwknpZv46cq2BmA4/cw=",
"owner": "kalhauge",
"repo": "language-c",
- "rev": "bdbf9f641149f5879dc23eb9e153e573d9355cbd",
+ "rev": "cca7c0b315cb0594071a546587bea79292e0c3d7",
"type": "github"
},
"original": {
diff --git a/flake.nix b/flake.nix
index b59c471..eee7af2 100644
--- a/flake.nix
+++ b/flake.nix
@@ -42,7 +42,7 @@
rtree = hpkgs.rtree;
};
devShells = let
- buildInputs = with hpkgs; [
+ nativeBuildInputs = with hpkgs; [
cabal-install
ghcid
haskell-language-server
@@ -56,7 +56,8 @@
{
name = "rtree-shell";
packages = p: [p.rtree];
- inherit buildInputs withHoogle;
+ doBenchmark = true;
+ inherit nativeBuildInputs withHoogle;
};
};
});
diff --git a/package.yaml b/package.yaml
index 6edd0bd..3024540 100644
--- a/package.yaml
+++ b/package.yaml
@@ -13,7 +13,10 @@ dependencies:
- free
- data-fix
- mtl
+ - directory
- containers
+ - text
+ - pretty-simple
library:
source-dirs: src
@@ -24,9 +27,15 @@ executables:
main: Main.hs
dependencies:
- rtree
+ - optparse-applicative
- language-c
- typed-process
+ - directory
- pretty
+ - filepath
+ - co-log
+ - time
+ - text
tests:
rtree-test:
diff --git a/rtree.cabal b/rtree.cabal
index 63f91f5..2a020e9 100644
--- a/rtree.cabal
+++ b/rtree.cabal
@@ -20,8 +20,11 @@ library
base >=4.9 && <5
, containers
, data-fix
+ , directory
, free
, mtl
+ , pretty-simple
+ , text
, transformers
default-language: Haskell2010
@@ -34,13 +37,20 @@ executable rtree-c
ghc-options: -Wall -fno-warn-incomplete-uni-patterns
build-depends:
base >=4.9 && <5
+ , co-log
, containers
, data-fix
+ , directory
+ , filepath
, free
, language-c
, mtl
+ , optparse-applicative
, pretty
+ , pretty-simple
, rtree
+ , text
+ , time
, transformers
, typed-process
default-language: Haskell2010
@@ -62,8 +72,11 @@ test-suite rtree-test
, diagrams-core
, diagrams-lib
, diagrams-svg
+ , directory
, free
, mtl
+ , pretty-simple
, rtree
+ , text
, transformers
default-language: Haskell2010
diff --git a/src/Control/RTree.hs b/src/Control/RTree.hs
index 0fc4b15..de354a9 100644
--- a/src/Control/RTree.hs
+++ b/src/Control/RTree.hs
@@ -3,13 +3,12 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{- |
@@ -17,139 +16,212 @@ Module: Control.RTree
-}
module Control.RTree where
-import Control.Applicative (Alternative ((<|>)))
-import Data.Coerce (coerce)
-import Data.Functor.Classes
+import Control.Applicative
+import Control.Monad.Reader
+import Control.Monad.Trans.Maybe
import qualified Data.List.NonEmpty as NE
+import qualified Data.Map.Strict as Map
+import Data.Maybe
import Data.Void
+import GHC.IORef
-import qualified Data.List as L
-
-import Control.Monad.Reader
-import "free" Control.Monad.Free.Church
-
--- | The base functor for the reduction tree.
-data RTreeF l f
- = Split (Maybe l) f f
- deriving (Show, Eq, Functor)
-
-instance (Show l) => Show1 (RTreeF l) where
- liftShowsPrec = undefined
-
-newtype RTree l i = RTree {rtreeFree :: F (RTreeF l) i}
- deriving (Functor, Applicative, Monad) via (F (RTreeF l))
-
-instance MonadFree (RTreeF l) (RTree l) where
- wrap x = RTree (wrap (fmap rtreeFree x))
+class (Monad m) => MonadReduce l m | m -> l where
+ split :: Maybe l -> m i -> m i -> m i
infixr 3 <|
infixl 3 |>
{-# INLINE (<|) #-}
-(<|) :: (MonadFree (RTreeF l) r) => r i -> r i -> r i
-r1 <| r2 = wrap (Split Nothing r1 r2)
+(<|) :: (MonadReduce l r) => r i -> r i -> r i
+r1 <| r2 = split Nothing r1 r2
{-# INLINE splitOn #-}
-splitOn :: (MonadFree (RTreeF l) r) => l -> r i -> r i -> r i
-splitOn l r1 r2 = wrap (Split (Just l) r1 r2)
-
-{-# INLINE split #-}
-split :: (MonadFree (RTreeF l) r) => Maybe l -> r i -> r i -> r i
-split l r1 r2 = wrap (Split l r1 r2)
+splitOn :: (MonadReduce l r) => l -> r i -> r i -> r i
+splitOn l = split (Just l)
{-# INLINE (|>) #-}
-(|>) :: (MonadFree (RTreeF l) r) => r i -> r i -> r i
+(|>) :: (MonadReduce l r) => r i -> r i -> r i
r1 |> r2 = r2 <| r1
-{-# INLINE foldR #-}
-foldR :: (RTreeF l a -> a) -> RTree l a -> a
-foldR fn = coerce $ iter fn
-
-foldRM :: (Monad m) => (RTreeF l (m a) -> m a) -> RTree l a -> m a
-foldRM fn = coerce $ iterM fn
-
--- | Extract the input from the reducer.
-extract :: RTree l i -> i
-extract = foldR \(Split _ _ e) -> e
-
--- | Remove all labels from a RTree by expanding all choices.
-flatten :: forall i l. (Eq l) => RTree l i -> Maybe (RTree Void i)
-flatten t = foldR go (fmap (const . Just . pure) t) []
- where
- go (Split ml lhs rhs) lst =
- case ml of
- Just l -> case l `L.lookup` lst of
- Nothing -> do
- join' (lhs $ (l, False) : lst) (rhs $ (l, True) : lst)
- Just True ->
- join' (lhs lst) (rhs lst)
- Just False ->
- Nothing
- Nothing -> join' (lhs lst) (rhs lst)
-
- join' mlhs mrhs = do
- case (mlhs, mrhs) of
- (Just lhs', Just rhs') -> pure (lhs' <| rhs')
- _ -> mlhs <|> mrhs
-
--- | Reduce an input using a monad.
-reduce
- :: forall m i
- . (Alternative m)
- => (i -> m ())
- -> RTree Void i
- -> m i
-reduce p t = do
- let (mi, i') = foldR go $ fmap (\i -> (pure i, i)) t
- p i' *> mi
- where
- go :: RTreeF l (m i, i) -> (m i, i)
- go (Split _ (lhs, le) (rhs, re)) =
- ((p le *> lhs) <|> rhs, re)
-{-# INLINE reduce #-}
-
-data RTree' l i
- = RTree' (RTreeF l (RTree' l i))
+data RTree l i
+ = Split (RTree l i) !(RTree l i)
+ | SplitOn !l (RTree l i) !(RTree l i)
| Done i
+ deriving (Functor)
-extract' :: RTree' l i -> i
-extract' = \case
- RTree' (Split _ _ v) -> extract' v
+extract :: RTree l i -> i
+extract = \case
+ Split _ rhs -> extract rhs
+ SplitOn _ _ rhs -> extract rhs
Done v -> v
-instance Functor (RTree' l) where
- fmap f (Done i) = Done (f i)
- fmap f (RTree' r) = RTree' (fmap (fmap f) r)
-
-instance Applicative (RTree' l) where
+instance Applicative (RTree l) where
pure = Done
(<*>) = ap
-instance Monad (RTree' l) where
+instance Monad (RTree l) where
ma >>= f = case ma of
Done i -> f i
- RTree' r ->
- RTree'
- (fmap (>>= f) r)
+ Split lhs rhs ->
+ Split (lhs >>= f) (rhs >>= f)
+ SplitOn l lhs rhs ->
+ SplitOn l (lhs >>= f) (rhs >>= f)
-instance MonadFree (RTreeF l) (RTree' l) where
- wrap = RTree'
- {-# INLINE wrap #-}
+instance MonadReduce l (RTree l) where
+ split = \case
+ Just n -> SplitOn n
+ Nothing -> Split
--- | Reduce an input using a monad.
-reduce'
+reduce
:: forall m l i
. (Alternative m)
=> (i -> m ())
- -> RTree' l i
+ -> RTree l i
-> m i
-reduce' p = checkgo
+reduce p = checkgo
where
go = \case
(Done i) -> pure i
- (RTree' (Split _ lhs rhs)) ->
- (checkgo lhs <|> go rhs)
- checkgo rt = p (extract' rt) *> go rt
+ (Split lhs rhs) ->
+ (checkgo lhs Control.Applicative.<|> go rhs)
+ (SplitOn _ lhs rhs) ->
+ (checkgo lhs Control.Applicative.<|> go rhs)
+ checkgo rt = p (extract rt) *> go rt
+{-# SPECIALIZE reduce :: (i -> MaybeT IO ()) -> RTree l i -> MaybeT IO i #-}
+
+type Valuation l = Map.Map l Bool
+
+extractL :: (Ord l) => Valuation l -> RTree l i -> i
+extractL v = \case
+ Split _ rhs -> extractL v rhs
+ SplitOn l lhs rhs -> case Map.lookup l v of
+ Just False -> extractL v lhs
+ _ -> extractL v rhs
+ Done i -> i
+
+reduceL
+ :: forall m l i
+ . (Alternative m, Ord l)
+ => (Valuation l -> i -> m ())
+ -> Valuation l
+ -> RTree l i
+ -> m i
+reduceL p = checkgo
+ where
+ checkgo v r = p v (extractL v r) *> go v r
+ go v = \case
+ Done i -> pure i
+ SplitOn l lhs rhs -> case Map.lookup l v of
+ Just True -> checkgo v rhs
+ Just False -> checkgo v lhs
+ Nothing -> checkgo (Map.insert l False v) lhs <|> go (Map.insert l True v) rhs
+ Split lhs rhs -> (checkgo v lhs <|> go v rhs)
+{-# INLINE reduceL #-}
+
+data ReState l = ReState ![Bool] !(Valuation l)
+
+newtype ReReduce l i = ReReduce {runReReduce :: IORef (ReState l) -> IO i}
+ deriving (Functor, Applicative, Monad) via (ReaderT (IORef (ReState l)) IO)
+
+instance (Ord l) => MonadReduce l (ReReduce l) where
+ split ml r1 r2 = ReReduce \ref -> do
+ test <- case ml of
+ Nothing -> do
+ atomicModifyIORef'
+ ref
+ ( \case
+ ReState (a : as) v -> (ReState as v, a)
+ ReState [] v -> (ReState [] v, False)
+ )
+ Just l -> do
+ atomicModifyIORef'
+ ref
+ ( \case
+ ReState as v@(Map.lookup l -> Just x) -> (ReState as v, not x)
+ ReState (a : as) v -> (ReState as (Map.insert l (not a) v), a)
+ ReState [] v -> (ReState [] (Map.insert l True v), False)
+ )
+ if test
+ then runReReduce r1 ref
+ else runReReduce r2 ref
+
+reduceFast
+ :: forall m l i
+ . (MonadIO m, Ord l)
+ => (Valuation l -> i -> MaybeT m ())
+ -> Valuation l
+ -> ReReduce l i
+ -> MaybeT m i
+reduceFast p v (ReReduce ext) = MaybeT $ go []
+ where
+ go pth = do
+ ref <- liftIO $ newIORef (ReState pth v)
+ i <- liftIO $ ext ref
+ ReState r v' <- liftIO $ readIORef ref
+ case r of
+ [] -> do
+ t <- isJust <$> runMaybeT (p v' i)
+ if t
+ then go (pth <> [True])
+ else go (pth <> [False])
+ _
+ | null pth ->
+ pure Nothing
+ | otherwise ->
+ pure (Just i)
+{-# INLINE reduceFast #-}
+
+-- Combinators
+
+type MRTree l = MaybeT (RTree l)
+
+instance (MonadReduce l m) => MonadReduce l (MaybeT m) where
+ split m (MaybeT lhs) (MaybeT rhs) = MaybeT (split m lhs rhs)
+
+-- | Given a list of item try to remove each of them the list.
+collect :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> m [b]
+collect fn = fmap catMaybes . traverse (runMaybeT . fn)
+{-# INLINE collect #-}
+
+collectNonEmpty' :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> MaybeT m [b]
+collectNonEmpty' fn as =
+ NE.toList <$> collectNonEmpty fn as
+{-# INLINE collectNonEmpty' #-}
+
+collectNonEmpty :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> MaybeT m (NE.NonEmpty b)
+collectNonEmpty fn as = do
+ as' <- lift . fmap catMaybes . traverse (runMaybeT . fn) $ as
+ MaybeT . pure $ NE.nonEmpty as'
+{-# INLINE collectNonEmpty #-}
+
+-- newtype LTree l i = LTree {runLTree :: Valuation l -> Maybe (RTree l i)}
+-- deriving (Functor)
+--
+-- instance Applicative (LTree l) where
+-- pure i = LTree{runLTree = \_ -> Just $ Done i}
+-- (<*>) = ap
+--
+-- instance Monad (LTree l) where
+-- LTree ma >>= f = LTree \l ->
+-- case ma l of
+-- Done i -> f i
+-- Split l lhs rhs ->
+
+-- extract' :: RTree l i -> i
+-- extract' = \case
+-- RTree' (Split _ _ v) -> extract' v
+-- Done v -> v
+--
+-- instance Functor (RTree l) where
+-- fmap f (Done i) = Done (f i)
+-- fmap f (RTree' r) = RTree' (fmap (fmap f) r)
+--
+--
+-- instance MonadFree (RTreeF l) (RTree' l) where
+-- wrap = RTree'
+-- {-# INLINE wrap #-}
+
+-- | Reduce an input using a monad.
-- newtype I l i = I ([(l, Bool)] -> RTreeI l i)
--
diff --git a/test/data/simple1.c b/test/data/simple1.c
index 3edd15b..206e198 100644
--- a/test/data/simple1.c
+++ b/test/data/simple1.c
@@ -2,5 +2,6 @@ extern int printf (const char *, ...);
int main (void)
{
- return 0;
+ printf("hello");
+ return 0;
}
--
GitLab