module Vectorise.Monad.Base (
VResult(..),
VM(..),
liftDs,
cantVectorise,
maybeCantVectorise,
maybeCantVectoriseM,
noV, traceNoV,
ensureV, traceEnsureV,
onlyIfV,
tryV,
maybeV, traceMaybeV,
orElseV,
fixV,
) where
import Vectorise.Builtins
import Vectorise.Env
import DsMonad
import Outputable
data VResult a
= Yes GlobalEnv LocalEnv a | No
newtype VM a
= VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
instance Monad VM where
return x = VM $ \_ genv lenv -> return (Yes genv lenv x)
VM p >>= f = VM $ \bi genv lenv -> do
r <- p bi genv lenv
case r of
Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
No -> return No
liftDs :: DsM a -> VM a
liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
cantVectorise :: String -> SDoc -> a
cantVectorise s d = pgmError
. showSDocDump
$ vcat [text "*** Vectorisation error ***",
nest 4 $ sep [text s, nest 4 d]]
maybeCantVectorise :: String -> SDoc -> Maybe a -> a
maybeCantVectorise s d Nothing = cantVectorise s d
maybeCantVectorise _ _ (Just x) = x
maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a
maybeCantVectoriseM s d p
= do
r <- p
case r of
Just x -> return x
Nothing -> cantVectorise s d
noV :: VM a
noV = VM $ \_ _ _ -> return No
traceNoV :: String -> SDoc -> VM a
traceNoV s d = pprTrace s d noV
ensureV :: Bool -> VM ()
ensureV False = noV
ensureV True = return ()
traceEnsureV :: String -> SDoc -> Bool -> VM ()
traceEnsureV s d False = traceNoV s d
traceEnsureV _ _ True = return ()
onlyIfV :: Bool -> VM a -> VM a
onlyIfV b p = ensureV b >> p
tryV :: VM a -> VM (Maybe a)
tryV (VM p) = VM $ \bi genv lenv ->
do
r <- p bi genv lenv
case r of
Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
No -> return (Yes genv lenv Nothing)
maybeV :: VM (Maybe a) -> VM a
maybeV p = maybe noV return =<< p
traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a
traceMaybeV s d p = maybe (traceNoV s d) return =<< p
orElseV :: VM a -> VM a -> VM a
orElseV p q = maybe q return =<< tryV p
fixV :: (a -> VM a) -> VM a
fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
where
unYes (Yes _ _ x) = x
unYes No = panic "Vectorise.Monad.Base.fixV: no result"