added and exported liftFuel method of FuelMonadT
[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 liftFuel :: (Monad m, FuelMonad (fm m)) => m a -> fm m a
33
34
35
36 type Fuel = Int
37
38 withFuel :: FuelMonad m => Maybe a -> m (Maybe a)
39 withFuel Nothing = return Nothing
40 withFuel (Just a) = do f <- getFuel
41 if f == 0
42 then return Nothing
43 else setFuel (f-1) >> return (Just a)
44
45
46 ----------------------------------------------------------------
47
48 newtype CheckingFuelMonad m a = FM { unFM :: Fuel -> m (a, Fuel) }
49
50 instance Monad m => Monad (CheckingFuelMonad m) where
51 return a = FM (\f -> return (a, f))
52 fm >>= k = FM (\f -> do { (a, f') <- unFM fm f; unFM (k a) f' })
53
54 instance CheckpointMonad m => CheckpointMonad (CheckingFuelMonad m) where
55 type Checkpoint (CheckingFuelMonad m) = (Fuel, Checkpoint m)
56 checkpoint = FM $ \fuel -> do { s <- checkpoint
57 ; return ((fuel, s), fuel) }
58 restart (fuel, s) = FM $ \_ -> do { restart s; return ((), fuel) }
59
60 instance UniqueMonad m => UniqueMonad (CheckingFuelMonad m) where
61 freshUnique = FM (\f -> do { l <- freshUnique; return (l, f) })
62
63 instance Monad m => FuelMonad (CheckingFuelMonad m) where
64 getFuel = FM (\f -> return (f, f))
65 setFuel f = FM (\_ -> return ((),f))
66
67 instance FuelMonadT CheckingFuelMonad where
68 runWithFuel fuel m = do { (a, _) <- unFM m fuel; return a }
69 liftFuel m = FM $ \f -> do { a <- m; return (a, f) }
70
71 ----------------------------------------------------------------
72
73 newtype InfiniteFuelMonad m a = IFM { unIFM :: m a }
74 instance Monad m => Monad (InfiniteFuelMonad m) where
75 return a = IFM $ return a
76 m >>= k = IFM $ do { a <- unIFM m; unIFM (k a) }
77
78 instance UniqueMonad m => UniqueMonad (InfiniteFuelMonad m) where
79 freshUnique = IFM $ freshUnique
80
81 instance Monad m => FuelMonad (InfiniteFuelMonad m) where
82 getFuel = return infiniteFuel
83 setFuel _ = return ()
84
85 instance CheckpointMonad m => CheckpointMonad (InfiniteFuelMonad m) where
86 type Checkpoint (InfiniteFuelMonad m) = Checkpoint m
87 checkpoint = IFM checkpoint
88 restart s = IFM $ restart s
89
90
91
92 instance FuelMonadT InfiniteFuelMonad where
93 runWithFuel _ = unIFM
94 liftFuel = IFM
95
96 infiniteFuel :: Fuel -- effectively infinite, any, but subtractable
97 infiniteFuel = maxBound
98
99 type SimpleFuelMonad = CheckingFuelMonad SimpleUniqueMonad
100
101 {-
102 runWithFuelAndUniques :: Fuel -> [Unique] -> FuelMonad a -> a
103 runWithFuelAndUniques fuel uniques m = a
104 where (a, _, _) = unFM m fuel uniques
105
106 freshUnique :: FuelMonad Unique
107 freshUnique = FM (\f (l:ls) -> (l, f, ls))
108 -}
109