2 -- | The Vectorisation monad.
3 module Vectorise.Monad.Base (
4 -- * The Vectorisation Monad
17 traceVt, dumpOptVt, dumpVt,
21 ensureV, traceEnsureV,
29 import Vectorise.Builtins
40 import System.IO (stderr)
43 -- The Vectorisation Monad ----------------------------------------------------
45 -- | Vectorisation can either succeed with new envionment and a value,
46 -- or return with failure.
48 = Yes GlobalEnv LocalEnv a | No
51 = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
53 instance Monad VM where
54 return x = VM $ \_ genv lenv -> return (Yes genv lenv x)
55 VM p >>= f = VM $ \bi genv lenv -> do
58 Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
61 instance Functor VM where
64 instance MonadIO VM where
65 liftIO = liftDs . liftIO
68 -- Lifting --------------------------------------------------------------------
69 -- | Lift a desugaring computation into the vectorisation monad.
70 liftDs :: DsM a -> VM a
71 liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
74 -- Error Handling -------------------------------------------------------------
75 -- | Throw a `pgmError` saying we can't vectorise something.
76 cantVectorise :: String -> SDoc -> a
77 cantVectorise s d = pgmError
79 $ vcat [text "*** Vectorisation error ***",
80 nest 4 $ sep [text s, nest 4 d]]
83 -- | Like `fromJust`, but `pgmError` on Nothing.
84 maybeCantVectorise :: String -> SDoc -> Maybe a -> a
85 maybeCantVectorise s d Nothing = cantVectorise s d
86 maybeCantVectorise _ _ (Just x) = x
89 -- | Like `maybeCantVectorise` but in a `Monad`.
90 maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a
91 maybeCantVectoriseM s d p
96 Nothing -> cantVectorise s d
99 -- Debugging ------------------------------------------------------------------
101 -- |Output a trace message if -ddump-vt-trace is active.
103 traceVt :: String -> SDoc -> VM ()
105 | 1 <= opt_TraceLevel = liftDs $
106 traceOptIf Opt_D_dump_vt_trace $
107 hang (text herald) 2 doc
108 | otherwise = return ()
110 -- |Dump the given program conditionally.
112 dumpOptVt :: DynFlag -> String -> SDoc -> VM ()
113 dumpOptVt flag header doc
114 = do { b <- liftDs $ doptM flag
116 then dumpVt header doc
120 -- |Dump the given program unconditionally.
122 dumpVt :: String -> SDoc -> VM ()
124 = do { unqual <- liftDs mkPrintUnqualifiedDs
125 ; liftIO $ printForUser stderr unqual (mkDumpDoc header doc)
128 -- Control --------------------------------------------------------------------
129 -- | Return some result saying we've failed.
131 noV = VM $ \_ _ _ -> return No
134 -- | Like `traceNoV` but also emit some trace message to stderr.
135 traceNoV :: String -> SDoc -> VM a
136 traceNoV s d = pprTrace s d noV
139 -- | If `True` then carry on, otherwise fail.
140 ensureV :: Bool -> VM ()
142 ensureV True = return ()
145 -- | Like `ensureV` but if we fail then emit some trace message to stderr.
146 traceEnsureV :: String -> SDoc -> Bool -> VM ()
147 traceEnsureV s d False = traceNoV s d
148 traceEnsureV _ _ True = return ()
151 -- | If `True` then return the first argument, otherwise fail.
152 onlyIfV :: Bool -> VM a -> VM a
153 onlyIfV b p = ensureV b >> p
156 -- | Try some vectorisation computaton.
157 -- If it succeeds then return `Just` the result,
158 -- otherwise return `Nothing`.
159 tryV :: VM a -> VM (Maybe a)
160 tryV (VM p) = VM $ \bi genv lenv ->
164 Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
165 No -> return (Yes genv lenv Nothing)
168 -- | If `Just` then return the value, otherwise fail.
169 maybeV :: VM (Maybe a) -> VM a
170 maybeV p = maybe noV return =<< p
173 -- | Like `maybeV` but emit a message to stderr if we fail.
174 traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a
175 traceMaybeV s d p = maybe (traceNoV s d) return =<< p
178 -- | Try the first computation,
179 -- if it succeeds then take the returned value,
180 -- if it fails then run the second computation instead.
181 orElseV :: VM a -> VM a -> VM a
182 orElseV p q = maybe q return =<< tryV p
185 -- | Fixpoint in the vectorisation monad.
186 fixV :: (a -> VM a) -> VM a
187 fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
189 -- NOTE: It is essential that we are lazy in r above so do not replace
190 -- calls to this function by an explicit case.
191 unYes (Yes _ _ x) = x
192 unYes No = panic "Vectorise.Monad.Base.fixV: no result"