{-# LANGUAGE DerivingStrategies, TypeFamilies #-}

module Control.Monad.Credit.Base
  ( Cell(..), Credit(..), Ticks(..)
  , MonadCount(..), MonadLazy(..), MonadCredit(..), HasStep(..), Lazy(..), MonadInherit(..)
  , MTree(..), Memory(..), MemoryCell(..), MonadMemory(..), linearize, mkMCell, mkMList
  , MemoryStructure(..), PrettyCell(..)
  ) where

import Prettyprinter
import Control.Monad
import Control.Monad.State
import Data.Char
import Data.Maybe
import Data.Map (Map)
import Data.Kind (Type)
import qualified Data.Map as Map

newtype Credit = Credit Int
  deriving (Credit -> Credit -> Bool
(Credit -> Credit -> Bool)
-> (Credit -> Credit -> Bool) -> Eq Credit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Credit -> Credit -> Bool
== :: Credit -> Credit -> Bool
$c/= :: Credit -> Credit -> Bool
/= :: Credit -> Credit -> Bool
Eq, Eq Credit
Eq Credit =>
(Credit -> Credit -> Ordering)
-> (Credit -> Credit -> Bool)
-> (Credit -> Credit -> Bool)
-> (Credit -> Credit -> Bool)
-> (Credit -> Credit -> Bool)
-> (Credit -> Credit -> Credit)
-> (Credit -> Credit -> Credit)
-> Ord Credit
Credit -> Credit -> Bool
Credit -> Credit -> Ordering
Credit -> Credit -> Credit
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Credit -> Credit -> Ordering
compare :: Credit -> Credit -> Ordering
$c< :: Credit -> Credit -> Bool
< :: Credit -> Credit -> Bool
$c<= :: Credit -> Credit -> Bool
<= :: Credit -> Credit -> Bool
$c> :: Credit -> Credit -> Bool
> :: Credit -> Credit -> Bool
$c>= :: Credit -> Credit -> Bool
>= :: Credit -> Credit -> Bool
$cmax :: Credit -> Credit -> Credit
max :: Credit -> Credit -> Credit
$cmin :: Credit -> Credit -> Credit
min :: Credit -> Credit -> Credit
Ord, Int -> Credit -> ShowS
[Credit] -> ShowS
Credit -> String
(Int -> Credit -> ShowS)
-> (Credit -> String) -> ([Credit] -> ShowS) -> Show Credit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Credit -> ShowS
showsPrec :: Int -> Credit -> ShowS
$cshow :: Credit -> String
show :: Credit -> String
$cshowList :: [Credit] -> ShowS
showList :: [Credit] -> ShowS
Show)
  deriving newtype (Integer -> Credit
Credit -> Credit
Credit -> Credit -> Credit
(Credit -> Credit -> Credit)
-> (Credit -> Credit -> Credit)
-> (Credit -> Credit -> Credit)
-> (Credit -> Credit)
-> (Credit -> Credit)
-> (Credit -> Credit)
-> (Integer -> Credit)
-> Num Credit
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Credit -> Credit -> Credit
+ :: Credit -> Credit -> Credit
$c- :: Credit -> Credit -> Credit
- :: Credit -> Credit -> Credit
$c* :: Credit -> Credit -> Credit
* :: Credit -> Credit -> Credit
$cnegate :: Credit -> Credit
negate :: Credit -> Credit
$cabs :: Credit -> Credit
abs :: Credit -> Credit
$csignum :: Credit -> Credit
signum :: Credit -> Credit
$cfromInteger :: Integer -> Credit
fromInteger :: Integer -> Credit
Num, Int -> Credit
Credit -> Int
Credit -> [Credit]
Credit -> Credit
Credit -> Credit -> [Credit]
Credit -> Credit -> Credit -> [Credit]
(Credit -> Credit)
-> (Credit -> Credit)
-> (Int -> Credit)
-> (Credit -> Int)
-> (Credit -> [Credit])
-> (Credit -> Credit -> [Credit])
-> (Credit -> Credit -> [Credit])
-> (Credit -> Credit -> Credit -> [Credit])
-> Enum Credit
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Credit -> Credit
succ :: Credit -> Credit
$cpred :: Credit -> Credit
pred :: Credit -> Credit
$ctoEnum :: Int -> Credit
toEnum :: Int -> Credit
$cfromEnum :: Credit -> Int
fromEnum :: Credit -> Int
$cenumFrom :: Credit -> [Credit]
enumFrom :: Credit -> [Credit]
$cenumFromThen :: Credit -> Credit -> [Credit]
enumFromThen :: Credit -> Credit -> [Credit]
$cenumFromTo :: Credit -> Credit -> [Credit]
enumFromTo :: Credit -> Credit -> [Credit]
$cenumFromThenTo :: Credit -> Credit -> Credit -> [Credit]
enumFromThenTo :: Credit -> Credit -> Credit -> [Credit]
Enum, Num Credit
Ord Credit
(Num Credit, Ord Credit) => (Credit -> Rational) -> Real Credit
Credit -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: Credit -> Rational
toRational :: Credit -> Rational
Real, Enum Credit
Real Credit
(Real Credit, Enum Credit) =>
(Credit -> Credit -> Credit)
-> (Credit -> Credit -> Credit)
-> (Credit -> Credit -> Credit)
-> (Credit -> Credit -> Credit)
-> (Credit -> Credit -> (Credit, Credit))
-> (Credit -> Credit -> (Credit, Credit))
-> (Credit -> Integer)
-> Integral Credit
Credit -> Integer
Credit -> Credit -> (Credit, Credit)
Credit -> Credit -> Credit
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
$cquot :: Credit -> Credit -> Credit
quot :: Credit -> Credit -> Credit
$crem :: Credit -> Credit -> Credit
rem :: Credit -> Credit -> Credit
$cdiv :: Credit -> Credit -> Credit
div :: Credit -> Credit -> Credit
$cmod :: Credit -> Credit -> Credit
mod :: Credit -> Credit -> Credit
$cquotRem :: Credit -> Credit -> (Credit, Credit)
quotRem :: Credit -> Credit -> (Credit, Credit)
$cdivMod :: Credit -> Credit -> (Credit, Credit)
divMod :: Credit -> Credit -> (Credit, Credit)
$ctoInteger :: Credit -> Integer
toInteger :: Credit -> Integer
Integral, (forall ann. Credit -> Doc ann)
-> (forall ann. [Credit] -> Doc ann) -> Pretty Credit
forall ann. [Credit] -> Doc ann
forall ann. Credit -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
$cpretty :: forall ann. Credit -> Doc ann
pretty :: forall ann. Credit -> Doc ann
$cprettyList :: forall ann. [Credit] -> Doc ann
prettyList :: forall ann. [Credit] -> Doc ann
Pretty)

newtype Cell = Cell Int
  deriving (Cell -> Cell -> Bool
(Cell -> Cell -> Bool) -> (Cell -> Cell -> Bool) -> Eq Cell
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Cell -> Cell -> Bool
== :: Cell -> Cell -> Bool
$c/= :: Cell -> Cell -> Bool
/= :: Cell -> Cell -> Bool
Eq, Eq Cell
Eq Cell =>
(Cell -> Cell -> Ordering)
-> (Cell -> Cell -> Bool)
-> (Cell -> Cell -> Bool)
-> (Cell -> Cell -> Bool)
-> (Cell -> Cell -> Bool)
-> (Cell -> Cell -> Cell)
-> (Cell -> Cell -> Cell)
-> Ord Cell
Cell -> Cell -> Bool
Cell -> Cell -> Ordering
Cell -> Cell -> Cell
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Cell -> Cell -> Ordering
compare :: Cell -> Cell -> Ordering
$c< :: Cell -> Cell -> Bool
< :: Cell -> Cell -> Bool
$c<= :: Cell -> Cell -> Bool
<= :: Cell -> Cell -> Bool
$c> :: Cell -> Cell -> Bool
> :: Cell -> Cell -> Bool
$c>= :: Cell -> Cell -> Bool
>= :: Cell -> Cell -> Bool
$cmax :: Cell -> Cell -> Cell
max :: Cell -> Cell -> Cell
$cmin :: Cell -> Cell -> Cell
min :: Cell -> Cell -> Cell
Ord, Int -> Cell -> ShowS
[Cell] -> ShowS
Cell -> String
(Int -> Cell -> ShowS)
-> (Cell -> String) -> ([Cell] -> ShowS) -> Show Cell
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cell -> ShowS
showsPrec :: Int -> Cell -> ShowS
$cshow :: Cell -> String
show :: Cell -> String
$cshowList :: [Cell] -> ShowS
showList :: [Cell] -> ShowS
Show)

instance Pretty Cell where
  pretty :: forall ann. Cell -> Doc ann
pretty (Cell Int
0) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"main thread"
  pretty (Cell Int
i) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"thunk" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
i

newtype Ticks = Ticks Int
  deriving (Ticks -> Ticks -> Bool
(Ticks -> Ticks -> Bool) -> (Ticks -> Ticks -> Bool) -> Eq Ticks
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Ticks -> Ticks -> Bool
== :: Ticks -> Ticks -> Bool
$c/= :: Ticks -> Ticks -> Bool
/= :: Ticks -> Ticks -> Bool
Eq, Eq Ticks
Eq Ticks =>
(Ticks -> Ticks -> Ordering)
-> (Ticks -> Ticks -> Bool)
-> (Ticks -> Ticks -> Bool)
-> (Ticks -> Ticks -> Bool)
-> (Ticks -> Ticks -> Bool)
-> (Ticks -> Ticks -> Ticks)
-> (Ticks -> Ticks -> Ticks)
-> Ord Ticks
Ticks -> Ticks -> Bool
Ticks -> Ticks -> Ordering
Ticks -> Ticks -> Ticks
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Ticks -> Ticks -> Ordering
compare :: Ticks -> Ticks -> Ordering
$c< :: Ticks -> Ticks -> Bool
< :: Ticks -> Ticks -> Bool
$c<= :: Ticks -> Ticks -> Bool
<= :: Ticks -> Ticks -> Bool
$c> :: Ticks -> Ticks -> Bool
> :: Ticks -> Ticks -> Bool
$c>= :: Ticks -> Ticks -> Bool
>= :: Ticks -> Ticks -> Bool
$cmax :: Ticks -> Ticks -> Ticks
max :: Ticks -> Ticks -> Ticks
$cmin :: Ticks -> Ticks -> Ticks
min :: Ticks -> Ticks -> Ticks
Ord, Int -> Ticks -> ShowS
[Ticks] -> ShowS
Ticks -> String
(Int -> Ticks -> ShowS)
-> (Ticks -> String) -> ([Ticks] -> ShowS) -> Show Ticks
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Ticks -> ShowS
showsPrec :: Int -> Ticks -> ShowS
$cshow :: Ticks -> String
show :: Ticks -> String
$cshowList :: [Ticks] -> ShowS
showList :: [Ticks] -> ShowS
Show)
  deriving newtype (Integer -> Ticks
Ticks -> Ticks
Ticks -> Ticks -> Ticks
(Ticks -> Ticks -> Ticks)
-> (Ticks -> Ticks -> Ticks)
-> (Ticks -> Ticks -> Ticks)
-> (Ticks -> Ticks)
-> (Ticks -> Ticks)
-> (Ticks -> Ticks)
-> (Integer -> Ticks)
-> Num Ticks
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Ticks -> Ticks -> Ticks
+ :: Ticks -> Ticks -> Ticks
$c- :: Ticks -> Ticks -> Ticks
- :: Ticks -> Ticks -> Ticks
$c* :: Ticks -> Ticks -> Ticks
* :: Ticks -> Ticks -> Ticks
$cnegate :: Ticks -> Ticks
negate :: Ticks -> Ticks
$cabs :: Ticks -> Ticks
abs :: Ticks -> Ticks
$csignum :: Ticks -> Ticks
signum :: Ticks -> Ticks
$cfromInteger :: Integer -> Ticks
fromInteger :: Integer -> Ticks
Num, Int -> Ticks
Ticks -> Int
Ticks -> [Ticks]
Ticks -> Ticks
Ticks -> Ticks -> [Ticks]
Ticks -> Ticks -> Ticks -> [Ticks]
(Ticks -> Ticks)
-> (Ticks -> Ticks)
-> (Int -> Ticks)
-> (Ticks -> Int)
-> (Ticks -> [Ticks])
-> (Ticks -> Ticks -> [Ticks])
-> (Ticks -> Ticks -> [Ticks])
-> (Ticks -> Ticks -> Ticks -> [Ticks])
-> Enum Ticks
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Ticks -> Ticks
succ :: Ticks -> Ticks
$cpred :: Ticks -> Ticks
pred :: Ticks -> Ticks
$ctoEnum :: Int -> Ticks
toEnum :: Int -> Ticks
$cfromEnum :: Ticks -> Int
fromEnum :: Ticks -> Int
$cenumFrom :: Ticks -> [Ticks]
enumFrom :: Ticks -> [Ticks]
$cenumFromThen :: Ticks -> Ticks -> [Ticks]
enumFromThen :: Ticks -> Ticks -> [Ticks]
$cenumFromTo :: Ticks -> Ticks -> [Ticks]
enumFromTo :: Ticks -> Ticks -> [Ticks]
$cenumFromThenTo :: Ticks -> Ticks -> Ticks -> [Ticks]
enumFromThenTo :: Ticks -> Ticks -> Ticks -> [Ticks]
Enum, Num Ticks
Ord Ticks
(Num Ticks, Ord Ticks) => (Ticks -> Rational) -> Real Ticks
Ticks -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: Ticks -> Rational
toRational :: Ticks -> Rational
Real, Enum Ticks
Real Ticks
(Real Ticks, Enum Ticks) =>
(Ticks -> Ticks -> Ticks)
-> (Ticks -> Ticks -> Ticks)
-> (Ticks -> Ticks -> Ticks)
-> (Ticks -> Ticks -> Ticks)
-> (Ticks -> Ticks -> (Ticks, Ticks))
-> (Ticks -> Ticks -> (Ticks, Ticks))
-> (Ticks -> Integer)
-> Integral Ticks
Ticks -> Integer
Ticks -> Ticks -> (Ticks, Ticks)
Ticks -> Ticks -> Ticks
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
$cquot :: Ticks -> Ticks -> Ticks
quot :: Ticks -> Ticks -> Ticks
$crem :: Ticks -> Ticks -> Ticks
rem :: Ticks -> Ticks -> Ticks
$cdiv :: Ticks -> Ticks -> Ticks
div :: Ticks -> Ticks -> Ticks
$cmod :: Ticks -> Ticks -> Ticks
mod :: Ticks -> Ticks -> Ticks
$cquotRem :: Ticks -> Ticks -> (Ticks, Ticks)
quotRem :: Ticks -> Ticks -> (Ticks, Ticks)
$cdivMod :: Ticks -> Ticks -> (Ticks, Ticks)
divMod :: Ticks -> Ticks -> (Ticks, Ticks)
$ctoInteger :: Ticks -> Integer
toInteger :: Ticks -> Integer
Integral, (forall ann. Ticks -> Doc ann)
-> (forall ann. [Ticks] -> Doc ann) -> Pretty Ticks
forall ann. [Ticks] -> Doc ann
forall ann. Ticks -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
$cpretty :: forall ann. Ticks -> Doc ann
pretty :: forall ann. Ticks -> Doc ann
$cprettyList :: forall ann. [Ticks] -> Doc ann
prettyList :: forall ann. [Ticks] -> Doc ann
Pretty)

class Monad m => MonadCount m where
  tick :: m ()
  -- ^ tick consumes one credit of the current cell

class Monad m => MonadLazy m where
  data Thunk m :: (Type -> Type) -> Type -> Type
  delay :: t a -> m (Thunk m t a)
  -- ^ delay creates a new cell with the given thunk
  force :: HasStep t m => Thunk m t a -> m a
  -- ^ force retrieves and evaluates the thunk of a cell
  lazymatch :: Thunk m t a -> (a -> m b) -> (t a -> m b) -> m b
  -- ^ lazymatch can inspect the unevaluated thunk and allows us to
  -- perform an action like forcing or assigning credits.

-- | Thunks can take a step to yield a computation that evaluates to their result.
class HasStep t m where
  step :: t a -> m a

-- | A basic thunk that contains the computation to be evaluated.
-- This type can be used to express any thunk but its disadvantage is that
-- it will be printed merely as "<lazy>".
newtype Lazy m a = Lazy (m a)

instance HasStep (Lazy m) m where
  step :: forall (a :: k). Lazy m a -> m a
step (Lazy m a
f) = m a
f

-- | A computation in the credit monad has a given amounts of credits,
-- which it can spend on computation or transfer to other cells.
class (MonadCount m, MonadLazy m, MonadFail m) => MonadCredit m where
  creditWith :: Thunk m t a -> Credit -> m ()
  -- ^ creditWith transfers a given amount of credits to a cell
  hasAtLeast :: Thunk m t a -> Credit -> m ()
  -- ^ assert that a cell has at least a given amount of credits

class MonadCredit m => MonadInherit m where
  creditAllTo :: Thunk m t a -> m ()
  -- ^ creditAllTo transfers all credits to a cell and assigns it as heir

data MTree = MCell String [MTree] | MList [MTree] (Maybe MTree) | Indirection Cell

-- | A view of memory that can be pretty-printed.
data Memory = Memory
  { Memory -> MTree
memoryTree :: MTree
  , Memory -> Map Cell (MTree, Credit)
memoryStore :: Map Cell (MTree, Credit)
  }

-- | Make memory cell with a given tag and a list of children.
mkMCell :: String -> [Memory] -> Memory
mkMCell :: String -> [Memory] -> Memory
mkMCell String
d [Memory]
ms = MTree -> Map Cell (MTree, Credit) -> Memory
Memory (String -> [MTree] -> MTree
MCell String
d ((Memory -> MTree) -> [Memory] -> [MTree]
forall a b. (a -> b) -> [a] -> [b]
map Memory -> MTree
memoryTree [Memory]
ms)) ([Map Cell (MTree, Credit)] -> Map Cell (MTree, Credit)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ((Memory -> Map Cell (MTree, Credit))
-> [Memory] -> [Map Cell (MTree, Credit)]
forall a b. (a -> b) -> [a] -> [b]
map Memory -> Map Cell (MTree, Credit)
memoryStore [Memory]
ms))

-- | A special case for nicer printing of list-like datatypes.
-- ''mkMList [m1,...,mn] Nothing'' renders as ''[m1, .., mn]'', while
-- ''mkMList [m1,...,mn] (Just m)'' renders as ''[m1, .., mn] ++ m''.
mkMList :: [Memory] -> Maybe Memory -> Memory
mkMList :: [Memory] -> Maybe Memory -> Memory
mkMList [Memory]
ms Maybe Memory
mm =
  let ms' :: [Memory]
ms' = case Maybe Memory
mm of Maybe Memory
Nothing -> [Memory]
ms; Just Memory
m -> [Memory]
ms [Memory] -> [Memory] -> [Memory]
forall a. [a] -> [a] -> [a]
++ [Memory
m] in
  MTree -> Map Cell (MTree, Credit) -> Memory
Memory ([MTree] -> Maybe MTree -> MTree
MList ((Memory -> MTree) -> [Memory] -> [MTree]
forall a b. (a -> b) -> [a] -> [b]
map Memory -> MTree
memoryTree [Memory]
ms) ((Memory -> MTree) -> Maybe Memory -> Maybe MTree
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Memory -> MTree
memoryTree Maybe Memory
mm)) ([Map Cell (MTree, Credit)] -> Map Cell (MTree, Credit)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ((Memory -> Map Cell (MTree, Credit))
-> [Memory] -> [Map Cell (MTree, Credit)]
forall a b. (a -> b) -> [a] -> [b]
map Memory -> Map Cell (MTree, Credit)
memoryStore [Memory]
ms'))

-- | A class for pretty-printing memory cells.
class Monad m => MemoryCell m a where
  prettyCell :: a -> m Memory

instance Monad m => MemoryCell m Int where
  prettyCell :: Int -> m Memory
prettyCell Int
i = Memory -> m Memory
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Memory -> m Memory) -> Memory -> m Memory
forall a b. (a -> b) -> a -> b
$ String -> [Memory] -> Memory
mkMCell (Int -> String
forall a. Show a => a -> String
show Int
i) []

instance MemoryCell m a => MemoryCell m [a] where
  prettyCell :: [a] -> m Memory
prettyCell [a]
xs = ([Memory] -> Maybe Memory -> Memory)
-> Maybe Memory -> [Memory] -> Memory
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Memory] -> Maybe Memory -> Memory
mkMList Maybe Memory
forall a. Maybe a
Nothing ([Memory] -> Memory) -> m [Memory] -> m Memory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m Memory) -> [a] -> m [Memory]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell [a]
xs

instance (MemoryCell m a, MemoryCell m b) => MemoryCell m (a, b) where
  prettyCell :: (a, b) -> m Memory
prettyCell (a
a, b
b) = String -> [Memory] -> Memory
mkMCell String
"" ([Memory] -> Memory) -> m [Memory] -> m Memory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m Memory] -> m [Memory]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell a
a, b -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell b
b]

instance (MemoryCell m a, MemoryCell m b, MemoryCell m c) => MemoryCell m (a, b, c) where
  prettyCell :: (a, b, c) -> m Memory
prettyCell (a
a, b
b, c
c) = String -> [Memory] -> Memory
mkMCell String
"" ([Memory] -> Memory) -> m [Memory] -> m Memory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m Memory] -> m [Memory]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [a -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell a
a, b -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell b
b, c -> m Memory
forall (m :: * -> *) a. MemoryCell m a => a -> m Memory
prettyCell c
c]

instance Monad m => MemoryCell m (Lazy m a) where
  prettyCell :: Lazy m a -> m Memory
prettyCell (Lazy m a
_) = Memory -> m Memory
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Memory -> m Memory) -> Memory -> m Memory
forall a b. (a -> b) -> a -> b
$ String -> [Memory] -> Memory
mkMCell String
"<lazy>" []

class Monad m => MonadMemory m where
  prettyThunk :: (MemoryCell m a, MemoryCell m (t a)) => Thunk m t a -> m Memory

instance (MonadMemory m, MemoryCell m a, MemoryCell m (t a)) => MemoryCell m (Thunk m t a) where
  prettyCell :: Thunk m t a -> m Memory
prettyCell Thunk m t a
t = Thunk m t a -> m Memory
forall a (t :: * -> *).
(MemoryCell m a, MemoryCell m (t a)) =>
Thunk m t a -> m Memory
forall (m :: * -> *) a (t :: * -> *).
(MonadMemory m, MemoryCell m a, MemoryCell m (t a)) =>
Thunk m t a -> m Memory
prettyThunk Thunk m t a
t

newtype PrettyCell a = PrettyCell a
  deriving (PrettyCell a -> PrettyCell a -> Bool
(PrettyCell a -> PrettyCell a -> Bool)
-> (PrettyCell a -> PrettyCell a -> Bool) -> Eq (PrettyCell a)
forall a. Eq a => PrettyCell a -> PrettyCell a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => PrettyCell a -> PrettyCell a -> Bool
== :: PrettyCell a -> PrettyCell a -> Bool
$c/= :: forall a. Eq a => PrettyCell a -> PrettyCell a -> Bool
/= :: PrettyCell a -> PrettyCell a -> Bool
Eq, Eq (PrettyCell a)
Eq (PrettyCell a) =>
(PrettyCell a -> PrettyCell a -> Ordering)
-> (PrettyCell a -> PrettyCell a -> Bool)
-> (PrettyCell a -> PrettyCell a -> Bool)
-> (PrettyCell a -> PrettyCell a -> Bool)
-> (PrettyCell a -> PrettyCell a -> Bool)
-> (PrettyCell a -> PrettyCell a -> PrettyCell a)
-> (PrettyCell a -> PrettyCell a -> PrettyCell a)
-> Ord (PrettyCell a)
PrettyCell a -> PrettyCell a -> Bool
PrettyCell a -> PrettyCell a -> Ordering
PrettyCell a -> PrettyCell a -> PrettyCell a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (PrettyCell a)
forall a. Ord a => PrettyCell a -> PrettyCell a -> Bool
forall a. Ord a => PrettyCell a -> PrettyCell a -> Ordering
forall a. Ord a => PrettyCell a -> PrettyCell a -> PrettyCell a
$ccompare :: forall a. Ord a => PrettyCell a -> PrettyCell a -> Ordering
compare :: PrettyCell a -> PrettyCell a -> Ordering
$c< :: forall a. Ord a => PrettyCell a -> PrettyCell a -> Bool
< :: PrettyCell a -> PrettyCell a -> Bool
$c<= :: forall a. Ord a => PrettyCell a -> PrettyCell a -> Bool
<= :: PrettyCell a -> PrettyCell a -> Bool
$c> :: forall a. Ord a => PrettyCell a -> PrettyCell a -> Bool
> :: PrettyCell a -> PrettyCell a -> Bool
$c>= :: forall a. Ord a => PrettyCell a -> PrettyCell a -> Bool
>= :: PrettyCell a -> PrettyCell a -> Bool
$cmax :: forall a. Ord a => PrettyCell a -> PrettyCell a -> PrettyCell a
max :: PrettyCell a -> PrettyCell a -> PrettyCell a
$cmin :: forall a. Ord a => PrettyCell a -> PrettyCell a -> PrettyCell a
min :: PrettyCell a -> PrettyCell a -> PrettyCell a
Ord, Int -> PrettyCell a -> ShowS
[PrettyCell a] -> ShowS
PrettyCell a -> String
(Int -> PrettyCell a -> ShowS)
-> (PrettyCell a -> String)
-> ([PrettyCell a] -> ShowS)
-> Show (PrettyCell a)
forall a. Show a => Int -> PrettyCell a -> ShowS
forall a. Show a => [PrettyCell a] -> ShowS
forall a. Show a => PrettyCell a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> PrettyCell a -> ShowS
showsPrec :: Int -> PrettyCell a -> ShowS
$cshow :: forall a. Show a => PrettyCell a -> String
show :: PrettyCell a -> String
$cshowList :: forall a. Show a => [PrettyCell a] -> ShowS
showList :: [PrettyCell a] -> ShowS
Show)

instance (Monad m, Pretty a) => MemoryCell m (PrettyCell a) where
  prettyCell :: PrettyCell a -> m Memory
prettyCell (PrettyCell a
a) = Memory -> m Memory
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Memory -> m Memory) -> Memory -> m Memory
forall a b. (a -> b) -> a -> b
$ String -> [Memory] -> Memory
mkMCell (Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ a -> Doc Any
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
a) []

class MemoryStructure t where
  prettyStructure :: MonadMemory m => t m -> m Memory

showCredit :: Credit -> String
showCredit :: Credit -> String
showCredit (Credit Int
c) = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Char -> Int) -> Char -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Int
n -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
48 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8320) (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
c

annCredit :: Credit -> MTree -> MTree
annCredit :: Credit -> MTree -> MTree
annCredit Credit
c (MCell String
d [MTree]
ms) = String -> [MTree] -> MTree
MCell (String
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ Credit -> String
showCredit Credit
c) [MTree]
ms
annCredit Credit
c MTree
m = MTree
m

-- | Inline memory cells that are only used once and remove them from the store 
linearize :: Memory -> Memory
linearize :: Memory -> Memory
linearize Memory
mem = Memory -> Map Cell Int -> Memory
linearize' Memory
mem (Map Cell Int -> Memory) -> Map Cell Int -> Memory
forall a b. (a -> b) -> a -> b
$ Memory -> Map Cell Int
countUsages Memory
mem
  where
    countUsage :: MTree -> Map Cell Int
    countUsage :: MTree -> Map Cell Int
countUsage (MCell String
_ [MTree]
ms) = (Int -> Int -> Int) -> [Map Cell Int] -> Map Cell Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ((MTree -> Map Cell Int) -> [MTree] -> [Map Cell Int]
forall a b. (a -> b) -> [a] -> [b]
map MTree -> Map Cell Int
countUsage [MTree]
ms)
    countUsage (MList [MTree]
ms Maybe MTree
mm) =
      (Int -> Int -> Int) -> [Map Cell Int] -> Map Cell Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (MTree -> Map Cell Int
countUsage (MTree -> Map Cell Int) -> [MTree] -> [Map Cell Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MTree]
ms [MTree] -> [MTree] -> [MTree]
forall a. [a] -> [a] -> [a]
++ Maybe MTree -> [MTree]
forall a. Maybe a -> [a]
maybeToList Maybe MTree
mm)
    countUsage (Indirection Cell
c) = Cell -> Int -> Map Cell Int
forall k a. k -> a -> Map k a
Map.singleton Cell
c Int
1

    countUsages :: Memory -> Map Cell Int
    countUsages :: Memory -> Map Cell Int
countUsages (Memory MTree
mtree Map Cell (MTree, Credit)
mstore) = (Int -> Int -> Int) -> [Map Cell Int] -> Map Cell Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (MTree -> Map Cell Int
countUsage MTree
mtree Map Cell Int -> [Map Cell Int] -> [Map Cell Int]
forall a. a -> [a] -> [a]
: ((MTree, Credit) -> Map Cell Int)
-> [(MTree, Credit)] -> [Map Cell Int]
forall a b. (a -> b) -> [a] -> [b]
map (MTree -> Map Cell Int
countUsage (MTree -> Map Cell Int)
-> ((MTree, Credit) -> MTree) -> (MTree, Credit) -> Map Cell Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MTree, Credit) -> MTree
forall a b. (a, b) -> a
fst) (Map Cell (MTree, Credit) -> [(MTree, Credit)]
forall k a. Map k a -> [a]
Map.elems Map Cell (MTree, Credit)
mstore))

    lin :: Map Cell Int -> Map Cell (MTree, Credit) -> Cell -> State (Map Cell (MTree, Credit)) ()
    lin :: Map Cell Int
-> Map Cell (MTree, Credit)
-> Cell
-> State (Map Cell (MTree, Credit)) ()
lin Map Cell Int
usages Map Cell (MTree, Credit)
mstore Cell
c = do
      Map Cell (MTree, Credit)
mstore' <- StateT
  (Map Cell (MTree, Credit)) Identity (Map Cell (MTree, Credit))
forall s (m :: * -> *). MonadState s m => m s
get
      Bool
-> State (Map Cell (MTree, Credit)) ()
-> State (Map Cell (MTree, Credit)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Cell -> Map Cell (MTree, Credit) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember Cell
c Map Cell (MTree, Credit)
mstore') (State (Map Cell (MTree, Credit)) ()
 -> State (Map Cell (MTree, Credit)) ())
-> State (Map Cell (MTree, Credit)) ()
-> State (Map Cell (MTree, Credit)) ()
forall a b. (a -> b) -> a -> b
$
        case Cell -> Map Cell (MTree, Credit) -> Maybe (MTree, Credit)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Cell
c Map Cell (MTree, Credit)
mstore of
          Just (MTree
mtree, Credit
credit) -> do
            MTree
mtree' <- Map Cell Int
-> Map Cell (MTree, Credit)
-> MTree
-> State (Map Cell (MTree, Credit)) MTree
linearizeTree Map Cell Int
usages Map Cell (MTree, Credit)
mstore MTree
mtree
            case Cell -> Map Cell Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Cell
c Map Cell Int
usages of
              Just Int
1 -> (Map Cell (MTree, Credit) -> Map Cell (MTree, Credit))
-> State (Map Cell (MTree, Credit)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((Map Cell (MTree, Credit) -> Map Cell (MTree, Credit))
 -> State (Map Cell (MTree, Credit)) ())
-> (Map Cell (MTree, Credit) -> Map Cell (MTree, Credit))
-> State (Map Cell (MTree, Credit)) ()
forall a b. (a -> b) -> a -> b
$ Cell
-> (MTree, Credit)
-> Map Cell (MTree, Credit)
-> Map Cell (MTree, Credit)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Cell
c (Credit -> MTree -> MTree
annCredit Credit
credit MTree
mtree', Credit
credit)
              Maybe Int
_ -> (Map Cell (MTree, Credit) -> Map Cell (MTree, Credit))
-> State (Map Cell (MTree, Credit)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((Map Cell (MTree, Credit) -> Map Cell (MTree, Credit))
 -> State (Map Cell (MTree, Credit)) ())
-> (Map Cell (MTree, Credit) -> Map Cell (MTree, Credit))
-> State (Map Cell (MTree, Credit)) ()
forall a b. (a -> b) -> a -> b
$ Cell
-> (MTree, Credit)
-> Map Cell (MTree, Credit)
-> Map Cell (MTree, Credit)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Cell
c (MTree
mtree', Credit
credit)
          Maybe (MTree, Credit)
Nothing -> () -> State (Map Cell (MTree, Credit)) ()
forall a. a -> StateT (Map Cell (MTree, Credit)) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    linearizeTree :: Map Cell Int -> Map Cell (MTree, Credit) -> MTree -> State (Map Cell (MTree, Credit)) MTree
    linearizeTree :: Map Cell Int
-> Map Cell (MTree, Credit)
-> MTree
-> State (Map Cell (MTree, Credit)) MTree
linearizeTree Map Cell Int
usages Map Cell (MTree, Credit)
mstore (MCell String
d [MTree]
ms) = do
      [MTree]
ms' <- (MTree -> State (Map Cell (MTree, Credit)) MTree)
-> [MTree] -> StateT (Map Cell (MTree, Credit)) Identity [MTree]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Map Cell Int
-> Map Cell (MTree, Credit)
-> MTree
-> State (Map Cell (MTree, Credit)) MTree
linearizeTree Map Cell Int
usages Map Cell (MTree, Credit)
mstore) [MTree]
ms
      MTree -> State (Map Cell (MTree, Credit)) MTree
forall a. a -> StateT (Map Cell (MTree, Credit)) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MTree -> State (Map Cell (MTree, Credit)) MTree)
-> MTree -> State (Map Cell (MTree, Credit)) MTree
forall a b. (a -> b) -> a -> b
$ String -> [MTree] -> MTree
MCell String
d [MTree]
ms'
    linearizeTree Map Cell Int
usages Map Cell (MTree, Credit)
mstore (MList [MTree]
ms Maybe MTree
mm) = do
      [MTree]
ms' <- (MTree -> State (Map Cell (MTree, Credit)) MTree)
-> [MTree] -> StateT (Map Cell (MTree, Credit)) Identity [MTree]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Map Cell Int
-> Map Cell (MTree, Credit)
-> MTree
-> State (Map Cell (MTree, Credit)) MTree
linearizeTree Map Cell Int
usages Map Cell (MTree, Credit)
mstore) [MTree]
ms
      Maybe MTree
mm' <- (MTree -> State (Map Cell (MTree, Credit)) MTree)
-> Maybe MTree
-> StateT (Map Cell (MTree, Credit)) Identity (Maybe MTree)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (Map Cell Int
-> Map Cell (MTree, Credit)
-> MTree
-> State (Map Cell (MTree, Credit)) MTree
linearizeTree Map Cell Int
usages Map Cell (MTree, Credit)
mstore) Maybe MTree
mm
      MTree -> State (Map Cell (MTree, Credit)) MTree
forall a. a -> StateT (Map Cell (MTree, Credit)) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MTree -> State (Map Cell (MTree, Credit)) MTree)
-> MTree -> State (Map Cell (MTree, Credit)) MTree
forall a b. (a -> b) -> a -> b
$ [MTree] -> Maybe MTree -> MTree
MList [MTree]
ms' Maybe MTree
mm'
    linearizeTree Map Cell Int
usages Map Cell (MTree, Credit)
mstore (Indirection Cell
c) =
      case Cell -> Map Cell Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Cell
c Map Cell Int
usages of
        Just Int
1 -> do
          Map Cell Int
-> Map Cell (MTree, Credit)
-> Cell
-> State (Map Cell (MTree, Credit)) ()
lin Map Cell Int
usages Map Cell (MTree, Credit)
mstore Cell
c
          Map Cell (MTree, Credit)
mstore' <- StateT
  (Map Cell (MTree, Credit)) Identity (Map Cell (MTree, Credit))
forall s (m :: * -> *). MonadState s m => m s
get
          MTree -> State (Map Cell (MTree, Credit)) MTree
forall a. a -> StateT (Map Cell (MTree, Credit)) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MTree -> State (Map Cell (MTree, Credit)) MTree)
-> MTree -> State (Map Cell (MTree, Credit)) MTree
forall a b. (a -> b) -> a -> b
$ case Cell -> Map Cell (MTree, Credit) -> Maybe (MTree, Credit)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Cell
c Map Cell (MTree, Credit)
mstore' of
            Just (MTree
mtree, Credit
_) -> MTree
mtree
            Maybe (MTree, Credit)
Nothing -> Cell -> MTree
Indirection Cell
c
        Maybe Int
_ -> MTree -> State (Map Cell (MTree, Credit)) MTree
forall a. a -> StateT (Map Cell (MTree, Credit)) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MTree -> State (Map Cell (MTree, Credit)) MTree)
-> MTree -> State (Map Cell (MTree, Credit)) MTree
forall a b. (a -> b) -> a -> b
$ Cell -> MTree
Indirection Cell
c

    linearizeAll :: Map Cell Int -> Map Cell (MTree, Credit) -> Map Cell (MTree, Credit)
    linearizeAll :: Map Cell Int
-> Map Cell (MTree, Credit) -> Map Cell (MTree, Credit)
linearizeAll Map Cell Int
usages Map Cell (MTree, Credit)
mstore = (Cell
 -> (MTree, Credit)
 -> Map Cell (MTree, Credit)
 -> Map Cell (MTree, Credit))
-> Map Cell (MTree, Credit)
-> Map Cell (MTree, Credit)
-> Map Cell (MTree, Credit)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\Cell
k (MTree, Credit)
_ -> State (Map Cell (MTree, Credit)) ()
-> Map Cell (MTree, Credit) -> Map Cell (MTree, Credit)
forall s a. State s a -> s -> s
execState (Map Cell Int
-> Map Cell (MTree, Credit)
-> Cell
-> State (Map Cell (MTree, Credit)) ()
lin Map Cell Int
usages Map Cell (MTree, Credit)
mstore Cell
k)) Map Cell (MTree, Credit)
forall k a. Map k a
Map.empty Map Cell (MTree, Credit)
mstore

    removeUniques :: Map Cell Int -> Map Cell (MTree, Credit) -> Map Cell (MTree, Credit)
    removeUniques :: Map Cell Int
-> Map Cell (MTree, Credit) -> Map Cell (MTree, Credit)
removeUniques Map Cell Int
usages Map Cell (MTree, Credit)
mstore = (Cell -> (MTree, Credit) -> Bool)
-> Map Cell (MTree, Credit) -> Map Cell (MTree, Credit)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Cell
c (MTree, Credit)
_ -> Int -> Cell -> Map Cell Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 Cell
c Map Cell Int
usages Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) Map Cell (MTree, Credit)
mstore

    linearize' :: Memory -> Map Cell Int -> Memory
    linearize' :: Memory -> Map Cell Int -> Memory
linearize' (Memory MTree
mtree Map Cell (MTree, Credit)
mstore) Map Cell Int
usages =
      let mstore' :: Map Cell (MTree, Credit)
mstore' = Map Cell Int
-> Map Cell (MTree, Credit) -> Map Cell (MTree, Credit)
linearizeAll Map Cell Int
usages Map Cell (MTree, Credit)
mstore
          mtree' :: MTree
mtree' = State (Map Cell (MTree, Credit)) MTree
-> Map Cell (MTree, Credit) -> MTree
forall s a. State s a -> s -> a
evalState (Map Cell Int
-> Map Cell (MTree, Credit)
-> MTree
-> State (Map Cell (MTree, Credit)) MTree
linearizeTree Map Cell Int
usages Map Cell (MTree, Credit)
mstore' MTree
mtree) Map Cell (MTree, Credit)
mstore'
      in MTree -> Map Cell (MTree, Credit) -> Memory
Memory MTree
mtree' (Map Cell Int
-> Map Cell (MTree, Credit) -> Map Cell (MTree, Credit)
removeUniques Map Cell Int
usages Map Cell (MTree, Credit)
mstore')

instance Pretty MTree where
  pretty :: forall ann. MTree -> Doc ann
pretty (MCell String
d []) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
d 
  pretty (MCell String
d [MTree]
ms) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
d Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
tupled ((MTree -> Doc ann) -> [MTree] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map MTree -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MTree -> Doc ann
pretty [MTree]
ms)
  pretty (MList [] Maybe MTree
Nothing) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"[]"
  pretty (MList [] (Just MTree
m)) = MTree -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MTree -> Doc ann
pretty MTree
m
  pretty (MList [MTree]
ms Maybe MTree
Nothing) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
list ((MTree -> Doc ann) -> [MTree] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map MTree -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MTree -> Doc ann
pretty [MTree]
ms)
  pretty (MList [MTree]
ms (Just MTree
m)) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
tupled [[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
list ((MTree -> Doc ann) -> [MTree] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map MTree -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MTree -> Doc ann
pretty [MTree]
ms) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"++" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MTree -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MTree -> Doc ann
pretty MTree
m]
  pretty (Indirection (Cell Int
c)) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"<" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
c Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
">"

instance Pretty Memory where
  pretty :: forall ann. Memory -> Doc ann
pretty (Memory MTree
mtree Map Cell (MTree, Credit)
mstore) =
    let prettyStore :: Doc ann
prettyStore = case Map Cell (MTree, Credit) -> [(Cell, (MTree, Credit))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Cell (MTree, Credit)
mstore of
          [] -> Doc ann
forall a. Monoid a => a
mempty
          [(Cell, (MTree, Credit))]
_ -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"where:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep (((Cell, (MTree, Credit)) -> Doc ann)
-> [(Cell, (MTree, Credit))] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (\((Cell Int
c), (MTree
m, Credit
cr)) -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"<" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
c Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"> =>" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Credit -> String
showCredit Credit
cr) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MTree -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MTree -> Doc ann
pretty MTree
m) (Map Cell (MTree, Credit) -> [(Cell, (MTree, Credit))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Cell (MTree, Credit)
mstore)))
    in MTree -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. MTree -> Doc ann
pretty MTree
mtree Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
prettyStore