vectorise/Vectorise/Monad/Base.hs

    -- |The Vectorisation monad.

    module Vectorise.Monad.Base (
      -- * The Vectorisation Monad
      VResult(..),
      VM(..),

      -- * Lifting
      liftDs,

      -- * Error Handling
      cantVectorise,
      maybeCantVectorise,
      maybeCantVectoriseM,

      -- * Debugging
      emitVt, traceVt, dumpOptVt, dumpVt,

      -- * Control
      noV, traceNoV,
      ensureV, traceEnsureV,
      onlyIfV,
      tryV, tryErrV,
      maybeV,  traceMaybeV,
      orElseV, orElseErrV,
      fixV,
    ) where

    import Vectorise.Builtins
    import Vectorise.Env

    import DsMonad
    import TcRnMonad
    import ErrUtils
    import Outputable
    import DynFlags

    import Control.Monad

    -- The Vectorisation Monad ----------------------------------------------------

    -- |Vectorisation can either succeed with new envionment and a value, or return with failure
    -- (including a description of the reason for failure).
    --
    data VResult a
      = Yes GlobalEnv LocalEnv a
      | No  SDoc

    newtype VM a
      = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }

    instance Monad VM where
      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 reason         -> return $ No reason

    instance Applicative VM where
      pure x = VM $ \_ genv lenv -> return (Yes genv lenv x)
      (<*>) = ap

    instance Functor VM where
      fmap = liftM

    instance MonadIO VM where
      liftIO = liftDs . liftIO

    instance HasDynFlags VM where
        getDynFlags = liftDs getDynFlags

    -- Lifting --------------------------------------------------------------------

    -- |Lift a desugaring computation into the vectorisation monad.
    --
    liftDs :: DsM a -> VM a
    liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }

    -- Error Handling -------------------------------------------------------------

    -- |Throw a `pgmError` saying we can't vectorise something.
    --
    cantVectorise :: DynFlags -> String -> SDoc -> a
    cantVectorise dflags s d = pgmError
                      . showSDoc dflags
                      $ vcat [text "*** Vectorisation error ***",
                              nest 4 $ sep [text s, nest 4 d]]

    -- |Like `fromJust`, but `pgmError` on Nothing.
    --
    maybeCantVectorise :: DynFlags -> String -> SDoc -> Maybe a -> a
    maybeCantVectorise dflags s d Nothing  = cantVectorise dflags s d
    maybeCantVectorise _ _ _ (Just x) = x

    -- |Like `maybeCantVectorise` but in a `Monad`.
    --
    maybeCantVectoriseM :: (Monad m, HasDynFlags m)
                        => String -> SDoc -> m (Maybe a) -> m a
    maybeCantVectoriseM s d p
      = do
          r <- p
          case r of
            Just x  -> return x
            Nothing ->
                do dflags <- getDynFlags
                   cantVectorise dflags s d

    -- Debugging ------------------------------------------------------------------

    -- |Output a trace message if -ddump-vt-trace is active.
    --
    emitVt :: String -> SDoc -> VM ()
    emitVt herald doc
      = liftDs $ do
          dflags <- getDynFlags
          liftIO . printOutputForUser dflags alwaysQualify $
            hang (text herald) 2 doc

    -- |Output a trace message if -ddump-vt-trace is active.
    --
    traceVt :: String -> SDoc -> VM ()
    traceVt herald doc
      = liftDs $ traceOptIf Opt_D_dump_vt_trace $ hang (text herald) 2 doc

    -- |Dump the given program conditionally.
    --
    dumpOptVt :: DumpFlag -> String -> SDoc -> VM ()
    dumpOptVt flag header doc
      = do { b <- liftDs $ doptM flag
           ; if b
             then dumpVt header doc
             else return ()
           }

    -- |Dump the given program unconditionally.
    --
    dumpVt :: String -> SDoc -> VM ()
    dumpVt header doc
      = do { unqual <- liftDs mkPrintUnqualifiedDs
           ; dflags <- liftDs getDynFlags
           ; liftIO $ printOutputForUser dflags unqual (mkDumpDoc header doc)
           }

    -- Control --------------------------------------------------------------------

    -- |Return some result saying we've failed.
    --
    noV :: SDoc -> VM a
    noV reason = VM $ \_ _ _ -> return $ No reason

    -- |Like `traceNoV` but also emit some trace message to stderr.
    --
    traceNoV :: String -> SDoc -> VM a
    traceNoV s d = pprTrace s d $ noV d

    -- |If `True` then carry on, otherwise fail.
    --
    ensureV :: SDoc -> Bool -> VM ()
    ensureV reason  False = noV reason
    ensureV _reason True  = return ()

    -- |Like `ensureV` but if we fail then emit some trace message to stderr.
    --
    traceEnsureV :: String -> SDoc -> Bool -> VM ()
    traceEnsureV s d False = traceNoV s d
    traceEnsureV _ _ True  = return ()

    -- |If `True` then return the first argument, otherwise fail.
    --
    onlyIfV :: SDoc -> Bool -> VM a -> VM a
    onlyIfV reason b p = ensureV reason b >> p

    -- |Try some vectorisation computaton.
    --
    -- If it succeeds then return `Just` the result; otherwise, return `Nothing` after emitting a
    -- failure message.
    --
    tryErrV :: VM a -> VM (Maybe a)
    tryErrV (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 reason         -> do { unqual <- mkPrintUnqualifiedDs
                                  ; dflags <- getDynFlags
                                  ; liftIO $
                                      printInfoForUser dflags unqual $
                                        text "Warning: vectorisation failure:" <+> reason
                                  ; return (Yes genv  lenv  Nothing)
                                  }

    -- |Try some vectorisation computaton.
    --
    -- If it succeeds then return `Just` the result; otherwise, return `Nothing` without emitting a
    -- failure message.
    --
    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 _reason        -> return (Yes genv  lenv  Nothing)

    -- |If `Just` then return the value, otherwise fail.
    --
    maybeV :: SDoc -> VM (Maybe a) -> VM a
    maybeV reason p = maybe (noV reason) return =<< p

    -- |Like `maybeV` but emit a message to stderr if we fail.
    --
    traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a
    traceMaybeV s d p = maybe (traceNoV s d) return =<< p

    -- |Try the first computation,
    --
    --   * if it succeeds then take the returned value,
    --   * if it fails then run the second computation instead while emitting a failure message.
    --
    orElseErrV :: VM a -> VM a -> VM a
    orElseErrV p q = maybe q return =<< tryErrV p

    -- |Try the first computation,
    --
    --   * if it succeeds then take the returned value,
    --   * if it fails then run the second computation instead without emitting a failure message.
    --
    orElseV :: VM a -> VM a -> VM a
    orElseV p q = maybe q return =<< tryV p

    -- |Fixpoint in the vectorisation monad.
    --
    fixV :: (a -> VM a) -> VM a
    fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
      where
        -- NOTE: It is essential that we are lazy in r above so do not replace
        --       calls to this function by an explicit case.
        unYes (Yes _ _ x) = x
        unYes (No reason) = pprPanic "Vectorise.Monad.Base.fixV: no result" reason