diff --git a/bin/rtree-c/Main.hs b/bin/rtree-c/Main.hs index 771098808af4a83efe6a42b9048af0fda3b02f3b..e6f95de2755333be22227e852b843990fe40c818 100644 --- a/bin/rtree-c/Main.hs +++ b/bin/rtree-c/Main.hs @@ -114,7 +114,7 @@ run = do unless t do liftIO exitFailure - l <- runMaybeT (reduceFast (check file) (Map.singleton (C.internalIdent "main") True) (reduceC c)) + l <- runMaybeT (reduceIO (check file) (Map.singleton (C.internalIdent "main") True) (reduceC c)) case l of Just l' -> do diff --git a/src/Control/RTree.hs b/src/Control/RTree.hs index de354a9ad3b33702c6b6990a86c9e9b5e8f6dbc3..4d3f76be1e8bd50124e5d511b6f54ed133d5b6ba 100644 --- a/src/Control/RTree.hs +++ b/src/Control/RTree.hs @@ -82,10 +82,8 @@ reduce p = checkgo where go = \case (Done i) -> pure i - (Split lhs rhs) -> - (checkgo lhs Control.Applicative.<|> go rhs) - (SplitOn _ lhs rhs) -> - (checkgo lhs Control.Applicative.<|> go rhs) + (Split lhs rhs) -> (checkgo lhs <|> go rhs) + (SplitOn _ lhs rhs) -> (checkgo lhs <|> go rhs) checkgo rt = p (extract rt) *> go rt {-# SPECIALIZE reduce :: (i -> MaybeT IO ()) -> RTree l i -> MaybeT IO i #-} @@ -120,11 +118,14 @@ reduceL p = checkgo data ReState l = ReState ![Bool] !(Valuation l) -newtype ReReduce l i = ReReduce {runReReduce :: IORef (ReState l) -> IO i} +{- | A faster version of the RTree which simply reruns the reducer program instead +of building a tree. +-} +newtype IORTree l i = IORTree {runIORTree :: 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 +instance (Ord l) => MonadReduce l (IORTree l) where + split ml r1 r2 = IORTree \ref -> do test <- case ml of Nothing -> do atomicModifyIORef' @@ -142,17 +143,17 @@ instance (Ord l) => MonadReduce l (ReReduce l) where ReState [] v -> (ReState [] (Map.insert l True v), False) ) if test - then runReReduce r1 ref - else runReReduce r2 ref + then runIORTree r1 ref + else runIORTree r2 ref -reduceFast +reduceIO :: forall m l i . (MonadIO m, Ord l) => (Valuation l -> i -> MaybeT m ()) -> Valuation l - -> ReReduce l i + -> IORTree l i -> MaybeT m i -reduceFast p v (ReReduce ext) = MaybeT $ go [] +reduceIO p v (IORTree ext) = MaybeT $ go [] where go pth = do ref <- liftIO $ newIORef (ReState pth v) @@ -169,7 +170,7 @@ reduceFast p v (ReReduce ext) = MaybeT $ go [] pure Nothing | otherwise -> pure (Just i) -{-# INLINE reduceFast #-} +{-# INLINE reduceIO #-} -- Combinators @@ -194,85 +195,6 @@ collectNonEmpty fn as = do 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) --- --- data RTreeI l i --- = RTreeI (RTreeF l (I l i)) --- | DoneI !i - --- -- This is not a great defintions, as the i does not depend on --- -- the current i, but instead on the final I. --- data RTreeIO j i = RTreeIO ((j -> IO Bool) -> IO i) j --- --- extractIO :: RTreeIO j i -> j --- extractIO (RTreeIO _ i) = i - --- instance Functor (RTreeIO j) where --- fmap f (RTreeIO mf i) = RTreeIO (\h -> f <$> mf (h . f)) (f i) --- --- instance Applicative (RTreeIO j) where --- pure i = RTreeIO (\_ -> pure i) i --- (<*>) = ap --- --- -- RTreeIO f fi <*> RTreeIO a ai = RTreeIO (f <*> a) (fi ai) --- --- instance Monad (RTreeIO j) where --- RTreeIO (ma :: ((a -> IO Bool) -> IO a)) a >>= (f :: (a -> RTreeIO b)) = --- RTreeIO undefined (extractIO $ f a) --- --- instance MonadFree (RTreeF Void) (RTreeIO j) where --- wrap (Split Nothing (RTreeIO lhs le) (RTreeIO rhs re)) = --- RTreeIO --- ( \p -> --- p le >>= \case --- True -> lhs p --- False -> rhs p --- ) --- re --- wrap (Split (Just x) _ _) = absurd x - --- reduceIO --- :: forall i --- . (i -> IO Bool) --- -> RTreeIO j i --- -> IO (Maybe i) --- reduceIO p (RTreeIO rt i) = runMaybeT do --- let (mi, i') = foldR go $ fmap (\i -> (pure i, i)) t --- p i' *> mi --- where --- go :: RTreeF l (IO i, i) -> (IO i, i) --- go (Split _ (lhs, le) (rhs, re)) = --- ((p le *> lhs) <|> rhs, re) - -- | Split the world on a fact. False it does not happen, and True it does happen. given :: RTree Void Bool given = pure False <| pure True