260fd43945645a9d9a225ee944cf3a5ea9fe4289
[packages/hoopl.git] / src / Compiler / Hoopl / Fuel.hs
1 {-# LANGUAGE TypeFamilies #-}
2
3 -----------------------------------------------------------------------------
4 -- The fuel monad
5 -----------------------------------------------------------------------------
6
7 module Compiler.Hoopl.Fuel
8 ( Fuel, infiniteFuel, fuelRemaining
9 , withFuel
10 , FuelMonad(..)
11 , FuelMonadT(..)
12 , CheckingFuelMonad
13 , InfiniteFuelMonad
14 , SimpleFuelMonad
15 )
16 where
17
18 import Compiler.Hoopl.Checkpoint
19 import Compiler.Hoopl.Unique
20
21 class Monad m => FuelMonad m where
22 getFuel :: m Fuel
23 setFuel :: Fuel -> m ()
24
25 -- | Find out how much fuel remains after a computation.
26 -- Can be subtracted from initial fuel to get total consumption.
27 fuelRemaining :: FuelMonad m => m Fuel
28 fuelRemaining = getFuel
29
30 class FuelMonadT fm where
31 runWithFuel :: (Monad m, FuelMonad (fm m)) => Fuel -> fm m a -> m a
32
33
34 type Fuel = Int
35
36 withFuel :: FuelMonad m => Maybe a -> m (Maybe a)
37 withFuel Nothing = return Nothing
38 withFuel (Just a) = do f <- getFuel
39 if f == 0
40 then return Nothing
41 else setFuel (f-1) >> return (Just a)
42
43
44 ----------------------------------------------------------------
45
46 newtype CheckingFuelMonad m a = FM { unFM :: Fuel -> m (a, Fuel) }
47
48 instance Monad m => Monad (CheckingFuelMonad m) where
49 return a = FM (\f -> return (a, f))
50 fm >>= k = FM (\f -> do { (a, f') <- unFM fm f; unFM (k a) f' })
51
52 instance CheckpointMonad m => CheckpointMonad (CheckingFuelMonad m) where
53 type Checkpoint (CheckingFuelMonad m) = (Fuel, Checkpoint m)
54 checkpoint = FM $ \fuel -> do { s <- checkpoint
55 ; return ((fuel, s), fuel) }
56 restart (fuel, s) = FM $ \_ -> do { restart s; return ((), fuel) }
57
58 instance UniqueMonad m => UniqueMonad (CheckingFuelMonad m) where
59 freshUnique = FM (\f -> do { l <- freshUnique; return (l, f) })
60
61 instance Monad m => FuelMonad (CheckingFuelMonad m) where
62 getFuel = FM (\f -> return (f, f))
63 setFuel f = FM (\_ -> return ((),f))
64
65 instance FuelMonadT CheckingFuelMonad where
66 runWithFuel fuel m = do { (a, _) <- unFM m fuel; return a }
67
68 ----------------------------------------------------------------
69
70 newtype InfiniteFuelMonad m a = IFM { unIFM :: m a }
71 instance Monad m => Monad (InfiniteFuelMonad m) where
72 return a = IFM $ return a
73 m >>= k = IFM $ do { a <- unIFM m; unIFM (k a) }
74
75 instance UniqueMonad m => UniqueMonad (InfiniteFuelMonad m) where
76 freshUnique = IFM $ freshUnique
77
78 instance Monad m => FuelMonad (InfiniteFuelMonad m) where
79 getFuel = return infiniteFuel
80 setFuel _ = return ()
81
82 instance CheckpointMonad m => CheckpointMonad (InfiniteFuelMonad m) where
83 type Checkpoint (InfiniteFuelMonad m) = Checkpoint m
84 checkpoint = IFM checkpoint
85 restart s = IFM $ restart s
86
87
88
89 instance FuelMonadT InfiniteFuelMonad where
90 runWithFuel _ = unIFM
91
92 infiniteFuel :: Fuel -- effectively infinite, any, but subtractable
93 infiniteFuel = maxBound
94
95 type SimpleFuelMonad = CheckingFuelMonad SimpleUniqueMonad
96
97 {-
98 runWithFuelAndUniques :: Fuel -> [Unique] -> FuelMonad a -> a
99 runWithFuelAndUniques fuel uniques m = a
100 where (a, _, _) = unFM m fuel uniques
101
102 freshUnique :: FuelMonad Unique
103 freshUnique = FM (\f (l:ls) -> (l, f, ls))
104 -}
105