From d0ff68c499bb2bfce069c062edbd8965e8d4a583 Mon Sep 17 00:00:00 2001 From: Christian Gram Kalhauge <chrg@dtu.dk> Date: Mon, 19 Feb 2024 13:32:03 +0100 Subject: [PATCH] Add labels --- rtree/.hspec | 1 - rtree/rtree.cabal | 1 - rtree/src/Control/Monad/IRTree.hs | 84 +++++++++++-------- rtree/src/Control/Monad/RTree.hs | 83 +++++++++--------- rtree/src/Control/Monad/Reduce.hs | 61 +++++++++----- rtree/src/Data/RPath.hs | 5 ++ rtree/test/expected/double-let-expr | 45 +++++----- rtree/test/expected/double-let-expr-red | 11 ++- rtree/test/expected/double-let-expr-red-exp | 17 ++-- .../test/expected/double-overloading-let-expr | 48 ++++++----- .../expected/double-overloading-let-expr-red | 9 +- .../double-overloading-let-expr-red-exp | 15 ++-- rtree/test/expected/small-let-expr | 23 ++--- rtree/test/expected/small-let-expr-red | 9 +- rtree/test/expected/small-let-expr-red-exp | 12 ++- rtree/test/expected/small-opr-expr | 8 +- rtree/test/expected/small-opr-expr-red | 7 +- rtree/test/expected/small-opr-expr-red-exp | 7 +- rtree/test/src/Control/Monad/IRTreeSpec.hs | 67 ++++++++------- rtree/test/src/Control/Monad/RTreeSpec.hs | 30 ++++--- rtree/test/src/Data/Expr.hs | 34 +++++--- rtree/test/src/Test/Hspec/GitGolden.hs | 2 +- 22 files changed, 340 insertions(+), 239 deletions(-) diff --git a/rtree/.hspec b/rtree/.hspec index 3117928..c2400d4 100644 --- a/rtree/.hspec +++ b/rtree/.hspec @@ -1,4 +1,3 @@ --failure-report .hspec-failures --rerun --rerun-all-on-success ---fail-fast diff --git a/rtree/rtree.cabal b/rtree/rtree.cabal index 7070af5..f1bc1b9 100644 --- a/rtree/rtree.cabal +++ b/rtree/rtree.cabal @@ -13,7 +13,6 @@ library Control.Monad.IRTree Control.Monad.Reduce Control.Monad.RTree - Control.RTree Data.RPath Data.Valuation other-modules: diff --git a/rtree/src/Control/Monad/IRTree.hs b/rtree/src/Control/Monad/IRTree.hs index 7694e77..983cc81 100644 --- a/rtree/src/Control/Monad/IRTree.hs +++ b/rtree/src/Control/Monad/IRTree.hs @@ -1,5 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -7,11 +9,13 @@ module Control.Monad.IRTree ( -- * IRTree IRTree, extract, + -- probe, reduce, reduceExp, -- * IRTreeT IRTreeT, + -- probeT, extractT, reduceT, reduceExpT, @@ -21,52 +25,63 @@ module Control.Monad.IRTree ( module Data.RPath, ) where +import Control.Monad.RWS.Strict import Control.Monad.Reader import Control.Monad.Reduce -import Control.Monad.State import Data.Bits import Data.Foldable +import Data.Functor import Data.Functor.Identity import Data.RPath import qualified Data.Sequence as Seq -type IRTree = IRTreeT Identity +type IRTree l = IRTreeT l Identity -newtype IRTreeT m i = IRTreeT (RPath -> Int -> m (i, Int)) +newtype IRTreeT l m i = IRTreeT (RWST RPath (Endo [l]) Int m i) deriving (Functor, Applicative, Monad) - via (ReaderT RPath (StateT Int m)) + via (RWST RPath (Endo [l]) Int m) -instance (Monad m) => MonadReduce (IRTreeT m) where - check = IRTreeT \rp i -> do - pure (indexChoice rp i, i + 1) +instance (Monad m) => MonadReduce l (IRTreeT l m) where + check l = IRTreeT . RWST $ \rp i -> do + pure (indexChoice rp i, i + 1, Endo (l :)) -extract :: IRTree i -> i +extract :: IRTree l i -> i extract t = runIdentity $ extractT t {-# INLINE extract #-} -extractT :: (Functor m) => IRTreeT m i -> m i -extractT (IRTreeT m) = fmap fst (m "" 0) +extractT :: (Functor m) => IRTreeT l m i -> m i +extractT (IRTreeT m) = fmap (\(i, _, _) -> i) (runRWST m "" 0) {-# INLINE extractT #-} +-- probe :: IRTree l i -> RPath -> (i, [(Bool, l)]) +-- probe t pth = runIdentity $ probeT t pth +-- {-# INLINE probe #-} + +probeT :: (Functor m) => IRTreeT l m i -> RPath -> m (i, [(Bool, l)]) +probeT (IRTreeT m) pth = + runRWST m pth 0 <&> \(i, _, l) -> + (i, zip (toChoiceList pth) (appEndo l [])) +{-# INLINE probeT #-} + reduce :: (Monad m) - => (i -> m Bool) - -> IRTree i + => ([(Bool, l)] -> i -> m Bool) + -> IRTree l i -> m (Maybe i) reduce = reduceT (pure . runIdentity) {-# INLINE reduce #-} -- | Interpreted reduction with an m base monad reduceT - :: (Monad m) + :: (Monad m, Functor t) => (forall a. t a -> m a) - -> (i -> m Bool) - -> IRTreeT t i + -> ([(Bool, l)] -> i -> m Bool) + -> IRTreeT l t i -> m (Maybe i) -reduceT lift_ p (IRTreeT m) = do - (i, _) <- lift_ (m "" 0) - t <- p i +reduceT lift_ p rt = do + (i, l) <- lift_ (probeT rt "") + t <- p l i if t then Just <$> go Seq.empty else pure Nothing @@ -74,32 +89,33 @@ reduceT lift_ p (IRTreeT m) = do go pth = do -- Try to run the true branch. let pth' = fromChoiceList (toList (pth Seq.|> True)) - (i, x) <- lift_ (m pth' 0) - t <- p i - if x >= numberOfChoices pth' - then go (pth Seq.|> t) + (i, l) <- lift_ $ probeT rt pth' + if length l >= numberOfChoices pth' + then do + t <- p l i + go (pth Seq.|> t) else pure i {-# INLINE reduceT #-} reduceExp :: (Monad m) - => (i -> m Bool) - -> IRTree i + => ([(Bool, l)] -> i -> m Bool) + -> IRTree l i -> m (Maybe i) reduceExp = reduceExpT (pure . runIdentity) {-# INLINE reduceExp #-} -- | Interpreted reduction with an m base monad, and running in expoential mode. reduceExpT - :: (Monad m) + :: (Monad m, Functor t) => (forall a. t a -> m a) -- ^ a lift of monad m into t (normally @id@ or @lift@) - -> (i -> m Bool) - -> IRTreeT t i + -> ([(Bool, l)] -> i -> m Bool) + -> IRTreeT l t i -> m (Maybe i) -reduceExpT lift_ p (IRTreeT m) = do - (i, _) <- lift_ (m "" 0) - t <- p i +reduceExpT lift_ p rt = do + (i, l) <- lift_ (probeT rt "") + t <- p l i if t then Just <$> go 0 Seq.empty else pure Nothing @@ -108,10 +124,10 @@ reduceExpT lift_ p (IRTreeT m) = do let depth = shiftL 1 n let sq' = sq <> Seq.replicate depth True let pth' = fromChoiceList (toList sq') - (i, x) <- lift_ (m pth' 0) - t <- p i - if x >= numberOfChoices pth' - depth + 1 - then + (i, l) <- lift_ (probeT rt pth') + if length l >= numberOfChoices pth' - depth + 1 + then do + t <- p l i if t then go (n + 1) sq' else case n of diff --git a/rtree/src/Control/Monad/RTree.hs b/rtree/src/Control/Monad/RTree.hs index 18cc816..728b8db 100644 --- a/rtree/src/Control/Monad/RTree.hs +++ b/rtree/src/Control/Monad/RTree.hs @@ -45,53 +45,61 @@ import Data.RPath import qualified Data.Sequence as Seq -- | The simple RTree -data RTree i +data RTree l i = Done !i - | Split ~(RTree i) !(RTree i) + | Split !l ~(RTree l i) !(RTree l i) deriving (Functor, Foldable) -instance Applicative RTree where +instance Applicative (RTree l) where pure = Done (<*>) = ap -instance Monad RTree where +instance Monad (RTree l) where ma >>= f = case ma of Done i -> f i - Split lhs rhs -> Split (lhs >>= f) (rhs >>= f) + Split ctx lhs rhs -> Split ctx (lhs >>= f) (rhs >>= f) -instance MonadReduce RTree where +instance MonadReduce l (RTree l) where split = Split -instance FoldableWithIndex RPath RTree where +instance FoldableWithIndex RPath (RTree l) where ifoldMap f = Seq.empty & fix \rec rs -> \case Done i -> f (fromChoiceList (toList rs)) i - Split lhs rhs -> rec (rs Seq.|> True) lhs <> rec (rs Seq.|> False) rhs + Split _ lhs rhs -> rec (rs Seq.|> True) lhs <> rec (rs Seq.|> False) rhs -- | Extract the top value from the RTree. -extract :: RTree i -> i +extract :: RTree l i -> i extract = \case - Split _ rhs -> extract rhs + Split _ _ rhs -> extract rhs Done i -> i {-# INLINE extract #-} -- | A list of inputs, A simple wrapper around @toList@ -inputs :: RTree i -> [i] +inputs :: RTree l i -> [i] inputs = toList -- | A list of indexed inputs, A simple wrapper around @itoList@ -iinputs :: RTree i -> [(RPath, i)] +iinputs :: RTree l i -> [(RPath, i)] iinputs = itoList -- | For debugging purposes -drawRTree :: (i -> String) -> RTree i -> String -drawRTree pp = concat . go +drawRTree :: (l -> ShowS) -> (i -> ShowS) -> RTree l i -> String +drawRTree ppl ppi = concat . go id where - go = \case - Done i -> map (\a -> " " <> a <> "\n") (lines $ pp i) - Split lhs rhs -> - let (rh : rhs') = go rhs - (lh : lhs') = go lhs + go x = \case + Done i -> + map + (\a -> " " <> a <> "\n") + ( lines + . ppi i + . showString "\n" + . x + $ "" + ) + Split ctx2 lhs rhs -> + let (rh : rhs') = go x rhs + (lh : lhs') = go (ppl ctx2) lhs in fold [ ["┳━" <> rh] , map ("┃ " <>) rhs' @@ -103,7 +111,7 @@ drawRTree pp = concat . go reduce :: (Monad m) => (i -> m Bool) - -> RTree i + -> RTree l i -> m (Maybe i) reduce p = runMaybeT . checkgo where @@ -112,55 +120,54 @@ reduce p = runMaybeT . checkgo guard t *> go r go = \case Done i -> pure i - Split lhs rhs -> checkgo lhs <|> go rhs + Split _ lhs rhs -> checkgo lhs <|> go rhs {-# INLINE reduce #-} -- | An RTreeT Node -data RTreeN m i +data RTreeN l m i = DoneN !i - | SplitN !(RTreeT m i) !(RTreeT m i) + | SplitN !l !(RTreeT l m i) !(RTreeT l m i) deriving (Functor, Foldable) -newtype RTreeT m i = RTreeT {unRTreeT :: m (RTreeN m i)} +newtype RTreeT l m i = RTreeT {unRTreeT :: m (RTreeN l m i)} deriving (Functor, Foldable) -instance (Monad m) => Applicative (RTreeT m) where +instance (Monad m) => Applicative (RTreeT l m) where pure = RTreeT . pure . DoneN (<*>) = ap -instance (Monad m) => Monad (RTreeT m) where +instance (Monad m) => Monad (RTreeT l m) where RTreeT ma >>= f = RTreeT $ do ma >>= \case DoneN i -> unRTreeT (f i) - SplitN lhs rhs -> pure $ SplitN (lhs >>= f) (rhs >>= f) + SplitN ctx lhs rhs -> pure $ SplitN ctx (lhs >>= f) (rhs >>= f) -instance (Monad m) => MonadReduce (RTreeT m) where - split lhs rhs = RTreeT (pure $ SplitN lhs rhs) +instance (Monad m) => MonadReduce l (RTreeT l m) where + split l lhs rhs = RTreeT (pure $ SplitN l lhs rhs) -- | Extract a value from an @RTreeT@ -extractT :: (Monad m) => RTreeT m b -> m b +extractT :: (Monad m) => RTreeT l m b -> m b extractT (RTreeT m) = m >>= extractN {-# INLINE extractT #-} -extractN :: (Monad m) => RTreeN m b -> m b +extractN :: (Monad m) => RTreeN l m b -> m b extractN = \case DoneN i -> pure i - SplitN _ rhs -> extractT rhs + SplitN _ _ rhs -> extractT rhs {-# INLINE extractN #-} -flattenT :: RTreeT Identity i -> RTree i +flattenT :: RTreeT l Identity i -> RTree l i flattenT (RTreeT (Identity t)) = case t of DoneN i -> Done i - SplitN lhs rhs -> Split (flattenT lhs) (flattenT rhs) + SplitN ctx lhs rhs -> Split ctx (flattenT lhs) (flattenT rhs) -- | Reduction in @RTreeT@ reduceT - :: forall i m n - . (Monad m, MonadPlus n) + :: (Monad m, MonadPlus n) => (forall a. m a -> n a) -- ^ A function to lift m into n -> (i -> n Bool) - -> RTreeT m i + -> RTreeT l m i -> n i reduceT lift_ p = checkgo where @@ -171,5 +178,5 @@ reduceT lift_ p = checkgo go r' go = \case DoneN i -> pure i - SplitN lhs rhs -> checkgo lhs <|> (lift_ (unRTreeT rhs) >>= go) + SplitN _ lhs rhs -> checkgo lhs <|> (lift_ (unRTreeT rhs) >>= go) {-# INLINE reduceT #-} diff --git a/rtree/src/Control/Monad/Reduce.hs b/rtree/src/Control/Monad/Reduce.hs index ae55bb9..dfda96c 100644 --- a/rtree/src/Control/Monad/Reduce.hs +++ b/rtree/src/Control/Monad/Reduce.hs @@ -3,10 +3,13 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} {- | @@ -40,6 +43,8 @@ import Control.Monad.State import Control.Monad.Trans.Maybe import qualified Data.List.NonEmpty as NE import Data.Maybe +import GHC.Exception (CallStack, prettyCallStack) +import GHC.Stack (callStack, withFrozenCallStack) -- {- | A reducer should extract itself -- @ @@ -50,58 +55,70 @@ import Data.Maybe -- lawReduceId red i = extract (red i) == i -- | The Monad Reduce class. -class (Monad m) => MonadReduce m where +class (Monad m) => MonadReduce l m | m -> l where {-# MINIMAL (split | check) #-} - split :: m i -> m i -> m i - split r1 r2 = - check >>= \case + split :: l -> m i -> m i -> m i + split l r1 r2 = + check l >>= \case True -> r1 False -> r2 {-# INLINE split #-} -- | Check if the predicate is true. - check :: m Bool - check = split (pure True) (pure False) + check :: l -> m Bool + check l = split l (pure True) (pure False) {-# INLINE check #-} -- | Infix split. -(<|) :: (MonadReduce m) => m i -> m i -> m i -(<|) = split +(<|) :: (MonadReduce l m, IsCallStack l) => m i -> m i -> m i +(<|) = split (fromCallStack callStack) {-# INLINE (<|) #-} infixr 3 <| -- | Infix split, to the right. -(|>) :: (MonadReduce m) => m i -> m i -> m i -r1 |> r2 = r2 <| r1 +(|>) :: (MonadReduce l m, IsCallStack l) => m i -> m i -> m i +r1 |> r2 = withFrozenCallStack (r2 <| r1) {-# INLINE (|>) #-} infixl 3 |> -type MonadReducePlus m = (MonadReduce m, MonadPlus m) +class IsCallStack l where + fromCallStack :: CallStack -> l -instance (MonadReduce m) => MonadReduce (MaybeT m) where - split (MaybeT lhs) (MaybeT rhs) = MaybeT (split lhs rhs) +instance IsCallStack () where + fromCallStack = const () + +instance IsCallStack CallStack where + fromCallStack = id + +instance IsCallStack String where + fromCallStack = prettyCallStack + +type MonadReducePlus l m = (MonadReduce l m, MonadPlus m) + +instance (MonadReduce l m) => MonadReduce l (MaybeT m) where + split l (MaybeT lhs) (MaybeT rhs) = MaybeT (split l lhs rhs) -- | Continues if the fact is true. -given :: (MonadReducePlus m) => m () -given = split mzero (pure ()) +given :: (MonadReducePlus l m) => l -> m () +given l = split l mzero (pure ()) {-# INLINE given #-} -- | Given a list of item try to remove each of them from the list. -collect :: (MonadReduce m) => (a -> MaybeT m b) -> [a] -> m [b] +collect :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> m [b] collect fn = fmap catMaybes . traverse (runMaybeT . fn) {-# INLINE collect #-} -- | Given a list of item try to remove each of them, but keep atleast one. -collectNonEmpty' :: (MonadReducePlus m) => (a -> m b) -> [a] -> m [b] +collectNonEmpty' :: (MonadReducePlus l m) => (a -> m b) -> [a] -> m [b] collectNonEmpty' fn as = NE.toList <$> collectNonEmpty fn as {-# INLINE collectNonEmpty' #-} -- | Given a list of item try to remove each of them, but keep atleast one. -collectNonEmpty :: (MonadReducePlus m) => (a -> m b) -> [a] -> m (NE.NonEmpty b) +collectNonEmpty :: (MonadReducePlus l m) => (a -> m b) -> [a] -> m (NE.NonEmpty b) collectNonEmpty fn as = do as' <- fmap catMaybes . traverse (optional . fn) $ as maybe mzero pure $ NE.nonEmpty as' @@ -124,10 +141,10 @@ onBoth mlhs mrhs fn = Nothing -> pure lhs Just rhs -> fn lhs rhs -instance (MonadReduce m) => MonadReduce (StateT s m) where - check = StateT (\s -> split (pure (True, s)) (pure (False, s))) +instance (MonadReduce l m) => MonadReduce l (StateT s m) where + check l = StateT (\s -> (,s) <$> check l) {-# INLINE check #-} -instance (MonadReduce m) => MonadReduce (ReaderT r m) where - check = ReaderT (\_ -> split (pure True) (pure False)) +instance (MonadReduce l m) => MonadReduce l (ReaderT r m) where + check l = ReaderT (\_ -> check l) {-# INLINE check #-} diff --git a/rtree/src/Data/RPath.hs b/rtree/src/Data/RPath.hs index df436f5..1018591 100644 --- a/rtree/src/Data/RPath.hs +++ b/rtree/src/Data/RPath.hs @@ -26,6 +26,9 @@ Is isomorphic to a list of choices. newtype RPath = RPath {rPathAsVector :: VU.Vector Bool} deriving (Eq, Ord) +{- | Convert an RPath into a predicate, which will find the element which +the rpath points to. +-} toPredicate :: RPath -> IO (i -> IO Bool) toPredicate rp = do idx <- newIORef (-1) @@ -33,6 +36,7 @@ toPredicate rp = do idx' <- atomicModifyIORef idx (\n -> (n + 1, n)) pure $ indexChoice rp idx' +-- | Like @toPredicate@, but with debugging information toPredicateDebug :: (Show i) => RPath -> IO (i -> IO Bool) toPredicateDebug rp = do idx <- newIORef (-1) @@ -51,6 +55,7 @@ indexChoice (RPath v) idx | idx < 0 = True | otherwise = fromMaybe False (v VU.!? idx) +-- | Get the number of choices in the RPath. numberOfChoices :: RPath -> Int numberOfChoices (RPath v) = VU.length v diff --git a/rtree/test/expected/double-let-expr b/rtree/test/expected/double-let-expr index 5ac1a22..3487c1c 100644 --- a/rtree/test/expected/double-let-expr +++ b/rtree/test/expected/double-let-expr @@ -1,20 +1,25 @@ -┳━┳━┳━┳━┳━┳━ x := 1; y := 2; x + y -┃ ┃ ┃ ┃ ┃ ┗━ x := 1; y := 2; x -┃ ┃ ┃ ┃ ┗━┳━ x := 1; y := 2; y -┃ ┃ ┃ ┃ ┗━ ⊥ -┃ ┃ ┃ ┗━┳━┳━ x := 1; x + 2 -┃ ┃ ┃ ┃ ┗━ x := 1; x -┃ ┃ ┃ ┗━┳━ x := 1; 2 -┃ ┃ ┃ ┗━ ⊥ -┃ ┃ ┗━ ⊥ -┃ ┗━┳━┳━┳━┳━ y := 2; 1 + y -┃ ┃ ┃ ┃ ┗━ y := 2; 1 -┃ ┃ ┃ ┗━┳━ y := 2; y -┃ ┃ ┃ ┗━ ⊥ -┃ ┃ ┗━┳━┳━┳━ 1 + 2 -┃ ┃ ┃ ┃ ┗━ 3 -┃ ┃ ┃ ┗━ 1 -┃ ┃ ┗━┳━ 2 -┃ ┃ ┗━ ⊥ -┃ ┗━ ⊥ -┗━ ⊥ +┳━┳━┳━┳━ x := 1; y := 2; x + y +┃ ┃ ┃ ┗━ x := 1; y := 2; y +┃ ┃ ┃ choose right +┃ ┃ ┗━ x := 1; y := 2; x +┃ ┃ choose left +┃ ┗━┳━┳━ x := 1; x + 2 +┃ ┃ ┃ inline "y" +┃ ┃ ┗━ x := 1; 2 +┃ ┃ choose right +┃ ┗━ x := 1; x +┃ choose left +┗━┳━┳━┳━ y := 2; 1 + y + ┃ ┃ ┃ inline "x" + ┃ ┃ ┗━ y := 2; y + ┃ ┃ choose right + ┃ ┗━ y := 2; 1 + ┃ choose left + ┗━┳━┳━┳━ 1 + 2 + ┃ ┃ ┃ inline "y" + ┃ ┃ ┗━ 3 + ┃ ┃ compute 1 + 2 + ┃ ┗━ 2 + ┃ choose right + ┗━ 1 + choose left diff --git a/rtree/test/expected/double-let-expr-red b/rtree/test/expected/double-let-expr-red index 96086ed..3932757 100644 --- a/rtree/test/expected/double-let-expr-red +++ b/rtree/test/expected/double-let-expr-red @@ -1,9 +1,12 @@ 1: x := 1; y := 2; x + y -0: - +initial 1: y := 2; 1 + y -0: - +inline "x" 1: 1 + 2 -0: 2 +inline "y" 0: 1 +choose left +0: 2 +choose right 0: 3 -1: 1 + 2 +compute 1 + 2 diff --git a/rtree/test/expected/double-let-expr-red-exp b/rtree/test/expected/double-let-expr-red-exp index 2cba901..305795e 100644 --- a/rtree/test/expected/double-let-expr-red-exp +++ b/rtree/test/expected/double-let-expr-red-exp @@ -1,11 +1,16 @@ 1: x := 1; y := 2; x + y -0: - +initial 1: y := 2; 1 + y -0: - -0: - +inline "x" +0: 1 +choose left 1: 1 + 2 -0: - -0: 2 +inline "y" +0: 1 +choose left 0: 1 +choose left +0: 2 +choose right 0: 3 -1: 1 + 2 +compute 1 + 2 diff --git a/rtree/test/expected/double-overloading-let-expr b/rtree/test/expected/double-overloading-let-expr index 99dab4e..70461bf 100644 --- a/rtree/test/expected/double-overloading-let-expr +++ b/rtree/test/expected/double-overloading-let-expr @@ -1,21 +1,27 @@ -┳━┳━┳━┳━┳━┳━ x := 1; x := 2; x + x -┃ ┃ ┃ ┃ ┃ ┗━ x := 1; x := 2; x -┃ ┃ ┃ ┃ ┗━┳━ x := 1; x := 2; x -┃ ┃ ┃ ┃ ┗━ ⊥ -┃ ┃ ┃ ┗━┳━┳━┳━ x := 1; 2 + 2 -┃ ┃ ┃ ┃ ┃ ┗━ x := 1; 4 -┃ ┃ ┃ ┃ ┗━ x := 1; 2 -┃ ┃ ┃ ┗━┳━ x := 1; 2 -┃ ┃ ┃ ┗━ ⊥ -┃ ┃ ┗━ ⊥ -┃ ┗━┳━┳━┳━┳━ x := 2; x + x -┃ ┃ ┃ ┃ ┗━ x := 2; x -┃ ┃ ┃ ┗━┳━ x := 2; x -┃ ┃ ┃ ┗━ ⊥ -┃ ┃ ┗━┳━┳━┳━ 2 + 2 -┃ ┃ ┃ ┃ ┗━ 4 -┃ ┃ ┃ ┗━ 2 -┃ ┃ ┗━┳━ 2 -┃ ┃ ┗━ ⊥ -┃ ┗━ ⊥ -┗━ ⊥ +┳━┳━┳━┳━ x := 1; x := 2; x + x +┃ ┃ ┃ ┗━ x := 1; x := 2; x +┃ ┃ ┃ choose right +┃ ┃ ┗━ x := 1; x := 2; x +┃ ┃ choose left +┃ ┗━┳━┳━┳━ x := 1; 2 + 2 +┃ ┃ ┃ ┃ inline "x" +┃ ┃ ┃ ┗━ x := 1; 4 +┃ ┃ ┃ compute 2 + 2 +┃ ┃ ┗━ x := 1; 2 +┃ ┃ choose right +┃ ┗━ x := 1; 2 +┃ choose left +┗━┳━┳━┳━ x := 2; x + x + ┃ ┃ ┃ inline "x" + ┃ ┃ ┗━ x := 2; x + ┃ ┃ choose right + ┃ ┗━ x := 2; x + ┃ choose left + ┗━┳━┳━┳━ 2 + 2 + ┃ ┃ ┃ inline "x" + ┃ ┃ ┗━ 4 + ┃ ┃ compute 2 + 2 + ┃ ┗━ 2 + ┃ choose right + ┗━ 2 + choose left diff --git a/rtree/test/expected/double-overloading-let-expr-red b/rtree/test/expected/double-overloading-let-expr-red index 6810214..0d14ced 100644 --- a/rtree/test/expected/double-overloading-let-expr-red +++ b/rtree/test/expected/double-overloading-let-expr-red @@ -1,9 +1,12 @@ 1: x := 1; x := 2; x + x -0: - +initial 1: x := 2; x + x -0: - +inline "x" 1: 2 + 2 +inline "x" 0: 2 +choose left 0: 2 +choose right 0: 4 -1: 2 + 2 +compute 2 + 2 diff --git a/rtree/test/expected/double-overloading-let-expr-red-exp b/rtree/test/expected/double-overloading-let-expr-red-exp index 096282a..eced1fe 100644 --- a/rtree/test/expected/double-overloading-let-expr-red-exp +++ b/rtree/test/expected/double-overloading-let-expr-red-exp @@ -1,11 +1,16 @@ 1: x := 1; x := 2; x + x -0: - +initial 1: x := 2; x + x -0: - -0: - +inline "x" +0: 2 +choose left 1: 2 + 2 -0: - +inline "x" +0: 2 +choose left 0: 2 +choose left 0: 2 +choose right 0: 4 -1: 2 + 2 +compute 2 + 2 diff --git a/rtree/test/expected/small-let-expr b/rtree/test/expected/small-let-expr index e7c2cde..3ba5e2a 100644 --- a/rtree/test/expected/small-let-expr +++ b/rtree/test/expected/small-let-expr @@ -1,10 +1,13 @@ -┳━┳━┳━┳━ x := 1; 2 + x -┃ ┃ ┃ ┗━ x := 1; 2 -┃ ┃ ┗━┳━ x := 1; x -┃ ┃ ┗━ ⊥ -┃ ┗━┳━┳━┳━ 2 + 1 -┃ ┃ ┃ ┗━ 3 -┃ ┃ ┗━ 2 -┃ ┗━┳━ 1 -┃ ┗━ ⊥ -┗━ ⊥ +┳━┳━┳━ x := 1; 2 + x +┃ ┃ ┗━ x := 1; x +┃ ┃ choose right +┃ ┗━ x := 1; 2 +┃ choose left +┗━┳━┳━┳━ 2 + 1 + ┃ ┃ ┃ inline "x" + ┃ ┃ ┗━ 3 + ┃ ┃ compute 2 + 1 + ┃ ┗━ 1 + ┃ choose right + ┗━ 2 + choose left diff --git a/rtree/test/expected/small-let-expr-red b/rtree/test/expected/small-let-expr-red index b487917..bc1d4e7 100644 --- a/rtree/test/expected/small-let-expr-red +++ b/rtree/test/expected/small-let-expr-red @@ -1,7 +1,10 @@ 1: x := 1; 2 + x -0: - +initial 1: 2 + 1 -0: 1 +inline "x" 0: 2 +choose left +0: 1 +choose right 0: 3 -1: 2 + 1 +compute 2 + 1 diff --git a/rtree/test/expected/small-let-expr-red-exp b/rtree/test/expected/small-let-expr-red-exp index 16c26bf..c3576c5 100644 --- a/rtree/test/expected/small-let-expr-red-exp +++ b/rtree/test/expected/small-let-expr-red-exp @@ -1,8 +1,12 @@ 1: x := 1; 2 + x -0: - +initial 1: 2 + 1 -0: - -0: 1 +inline "x" +0: 2 +choose left 0: 2 +choose left +0: 1 +choose right 0: 3 -1: 2 + 1 +compute 2 + 1 diff --git a/rtree/test/expected/small-opr-expr b/rtree/test/expected/small-opr-expr index b6a7514..a402f9d 100644 --- a/rtree/test/expected/small-opr-expr +++ b/rtree/test/expected/small-opr-expr @@ -1,5 +1,7 @@ ┳━┳━┳━ 1 + 2 ┃ ┃ ┗━ 3 -┃ ┗━ 1 -┗━┳━ 2 - ┗━ ⊥ +┃ ┃ compute 1 + 2 +┃ ┗━ 2 +┃ choose right +┗━ 1 + choose left diff --git a/rtree/test/expected/small-opr-expr-red b/rtree/test/expected/small-opr-expr-red index 85cbaac..f9d3eb6 100644 --- a/rtree/test/expected/small-opr-expr-red +++ b/rtree/test/expected/small-opr-expr-red @@ -1,5 +1,8 @@ 1: 1 + 2 -0: 2 +initial 0: 1 +choose left +0: 2 +choose right 0: 3 -1: 1 + 2 +compute 1 + 2 diff --git a/rtree/test/expected/small-opr-expr-red-exp b/rtree/test/expected/small-opr-expr-red-exp index 85cbaac..f9d3eb6 100644 --- a/rtree/test/expected/small-opr-expr-red-exp +++ b/rtree/test/expected/small-opr-expr-red-exp @@ -1,5 +1,8 @@ 1: 1 + 2 -0: 2 +initial 0: 1 +choose left +0: 2 +choose right 0: 3 -1: 1 + 2 +compute 1 + 2 diff --git a/rtree/test/src/Control/Monad/IRTreeSpec.hs b/rtree/test/src/Control/Monad/IRTreeSpec.hs index e3a10de..1674217 100644 --- a/rtree/test/src/Control/Monad/IRTreeSpec.hs +++ b/rtree/test/src/Control/Monad/IRTreeSpec.hs @@ -5,11 +5,11 @@ module Control.Monad.IRTreeSpec where import Control.Monad.IRTree import qualified Control.Monad.IRTree as IRTree import qualified Control.Monad.RTree as RTree -import Control.Monad.State -import Control.Monad.Trans.Maybe +import Control.Monad.Writer.Strict import Data.Bool import Data.Expr as Expr -import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Test.Hspec import Test.Hspec.GitGolden @@ -29,46 +29,51 @@ spec = describe "examples" do Let "x" (Cnt 1) (Let "x" (Cnt 2) (Opr (Var "x") (Var "x"))) where handle str e = describe (str <> " (" <> prettyExprS 0 e ")") do - let me = evalStateT (runMaybeT $ Expr.rExpr e) Map.empty + let me = runReaderT (Expr.rExpr e) Map.empty it "should extract" do - IRTree.extract me `shouldBe` Just e + IRTree.extract me `shouldBe` e - let re = evalStateT (runMaybeT $ Expr.rExpr e) Map.empty + let re = runReaderT (Expr.rExpr e) Map.empty - let predicate = maybe False (contains isOpr) + let + predicate :: Expr -> IO Bool + predicate = pure . contains isOpr - rex <- RTree.reduce (pure . predicate) re + rex <- runIO $ RTree.reduce predicate re it "should find an opr" do - ref <- newIORef "" - - let test i = do - let x = predicate i - modifyIORef' ref (\t -> t <> bool "0" "1" x <> ": " <> maybe "-" (flip (prettyExprS 0) "") i <> "\n") - pure x - - mex <- IRTree.reduce test me + (mex, result) <- runWriterT (IRTree.reduce (debugPredicate showString (prettyExprS 0) predicate) me) rex `shouldBe` mex - - result <- readIORef ref - pure $ golden ("test/expected/" <> str <> "-red") result + pure $ golden ("test/expected/" <> str <> "-red") (appEndo result "") it "should find an opr exponentially" do - ref <- newIORef "" - - let test i = do - let x = predicate i - modifyIORef' ref (\t -> t <> bool "0" "1" x <> ": " <> maybe "-" (flip (prettyExprS 0) "") i <> "\n") - pure x - - mex <- IRTree.reduceExp test me + (mex, result) <- runWriterT (IRTree.reduceExp (debugPredicate showString (prettyExprS 0) predicate) me) rex `shouldBe` mex - - result <- readIORef ref - pure $ golden ("test/expected/" <> str <> "-red-exp") result + pure $ golden ("test/expected/" <> str <> "-red-exp") (appEndo result "") it "should reduce like iinputs" do forM_ (RTree.iinputs re) \(ii, e') -> do p <- toPredicate ii - IRTree.reduce p me `shouldReturn` Just e' + IRTree.reduce (const p) me `shouldReturn` Just e' + +debugPredicate + :: (Monad m) + => (l -> ShowS) + -> (i -> ShowS) + -> (i -> m Bool) + -> [(Bool, l)] + -> i + -> WriterT (Endo String) m Bool +debugPredicate ppl ppi predicate lst i = do + x <- lift (predicate i) + tell . Endo $ + showString (bool "0" "1" x) + . showString ": " + . ppi i + . showString "\n" + . case nonEmpty lst of + Nothing -> showString "initial\n" + Just lst' -> ppl (snd $ NE.last lst') . showString "\n" + + pure x diff --git a/rtree/test/src/Control/Monad/RTreeSpec.hs b/rtree/test/src/Control/Monad/RTreeSpec.hs index 37c4541..9696c18 100644 --- a/rtree/test/src/Control/Monad/RTreeSpec.hs +++ b/rtree/test/src/Control/Monad/RTreeSpec.hs @@ -1,6 +1,5 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -8,8 +7,7 @@ module Control.Monad.RTreeSpec where import Control.Monad.Identity (Identity (runIdentity)) import Control.Monad.RTree -import Control.Monad.State -import Control.Monad.Trans.Maybe +import Control.Monad.Reader import Data.Expr as Expr import Data.Foldable import Data.Functor @@ -21,11 +19,11 @@ import Test.Hspec.GitGolden shouldBeString :: String -> String -> Pretty.Expectation shouldBeString = Pretty.shouldBe -rBool :: (MonadReduce m) => m Bool -rBool = split (pure False) (pure True) +rBool :: (MonadReduce () m) => m Bool +rBool = split () (pure False) (pure True) -rList :: (MonadReduce m) => [a] -> m [a] -rList = collect (given $>) +rList :: (MonadReduce () m) => [Int] -> m [Int] +rList = collect (given () $>) spec :: Spec spec = do @@ -40,11 +38,11 @@ rtreeTSpec = describe "RTreeT" do equiv (rList [1, 2, 3 :: Int]) extract (runIdentity . extractT) it "should input like RTree" do - equiv (rList [1, 2, 3 :: Int]) inputs (toList :: RTreeT Identity [Int] -> [[Int]]) + equiv (rList [1, 2, 3 :: Int]) inputs (toList :: RTreeT () Identity [Int] -> [[Int]]) equiv - :: (Show b, MonadReduce x, MonadReduce y, Eq b) - => (forall m. (MonadReduce m) => m a) + :: (Show b, MonadReduce l x, MonadReduce l y, Eq b) + => (forall m. (MonadReduce l m) => m a) -> (x a -> b) -> (y a -> b) -> IO () @@ -85,7 +83,7 @@ rtreeSpec = describe "RTree" do it "should pretty print it's tree" do golden "test/expected/rlist-drawrtree" - (drawRTree show (rList [1, 2, 3 :: Int])) + (drawRTree (\() -> id) shows (rList [1, 2, 3 :: Int])) examplesSpec :: Spec examplesSpec = describe "example" do @@ -102,17 +100,17 @@ examplesSpec = describe "example" do Let "x" (Cnt 1) (Let "x" (Cnt 2) (Opr (Var "x") (Var "x"))) where handle str e = describe (str <> " (" <> prettyExprS 0 e ")") do - let me = runMaybeT $ Expr.rExpr e + let me = Expr.rExpr e it "should extract" do - extract (runStateT me Map.empty) - `shouldBe` (Just e, Map.empty) + extract (runReaderT me Map.empty) + `shouldBe` e - let re = evalStateT me Map.empty + let re = runReaderT me Map.empty it "should draw the same" do golden ("test/expected/" <> str) - (drawRTree (maybe "⊥" (flip (prettyExprS 0) "")) re) + (drawRTree showString (prettyExprS 0) re) it "should reduce like iinputs" do forM_ (iinputs re) \(ii, e') -> do diff --git a/rtree/test/src/Data/Expr.hs b/rtree/test/src/Data/Expr.hs index ece9855..fc51cf8 100644 --- a/rtree/test/src/Data/Expr.hs +++ b/rtree/test/src/Data/Expr.hs @@ -7,10 +7,10 @@ module Data.Expr where import Control.Applicative +import Control.Monad.Reader import Control.Monad.Reduce import Control.Monad.State import Data.Data -import Data.Functor import qualified Data.Map.Strict as Map import Test.Hspec @@ -39,26 +39,36 @@ contains fn e = Nothing -> False rExpr - :: (MonadReducePlus m, MonadState (Map.Map String (Either String Expr)) m) + :: (MonadReduce String m, MonadReader (Map.Map String (Either String Expr)) m) => Expr -> m Expr rExpr e = case e of Cnt i -> do - given $> Cnt i + pure $ Cnt i Var k -> do - v <- liftMaybe =<< gets (Map.lookup k) + v <- asks (Map.lookup k) case v of - Left k' -> given $> Var k' - Right x -> rExpr x - Opr e1 e2 -> onBoth (rExpr e1) (rExpr e2) $ \e1' e2' -> - case (e1', e2') of - (Cnt a, Cnt b) -> pure (Cnt (a + b)) <| pure (Opr e1' e2') - _ow -> pure $ Opr e1' e2' + Just (Left k') -> pure $ Var k' + Just (Right x) -> rExpr x + Nothing -> pure (Cnt 0) + Opr e1 e2 -> do + split "choose left" (rExpr e1) . split "choose right" (rExpr e2) $ do + e1' <- rExpr e1 + e2' <- rExpr e2 + case (e1', e2') of + (Cnt n1, Cnt n2) -> do + let opr = Opr e1' e2' + split + ("compute " <> prettyExprS 0 opr "") + (pure (Cnt (n1 + n2))) + (pure (Opr e1' e2')) + _ow -> pure $ Opr e1' e2' Let k e1 e2 -> do e1' <- rExpr e1 split - (modifyIn (Map.insert k (Right e1')) $ rExpr e2) - (Let k e1' <$> modifyIn (Map.insert k (Left k)) (rExpr e2)) + ("inline " <> show k) + (local (Map.insert k (Right e1')) $ rExpr e2) + (Let k e1' <$> local (Map.insert k (Left k)) (rExpr e2)) modifyIn :: (Alternative m, MonadState s m) => (s -> s) -> m b -> m b modifyIn fn mx = do diff --git a/rtree/test/src/Test/Hspec/GitGolden.hs b/rtree/test/src/Test/Hspec/GitGolden.hs index 2bd9e18..c1b2946 100644 --- a/rtree/test/src/Test/Hspec/GitGolden.hs +++ b/rtree/test/src/Test/Hspec/GitGolden.hs @@ -59,7 +59,7 @@ instance Example GitGolden where ( Failure location ( Reason - (unlines . drop 4 . lines $ df) + (unlines . drop 3 . lines $ df) ) ) -- GitLab