compiler: de-lhs utils/

Signed-off-by: Austin Seipp <austin@well-typed.com>

1 files changed, 106 insertions, 0 deletions

diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs
new file mode 100644
index 0000000000..fc8e3199ae
--- /dev/null
+++ b/compiler/utils/Maybes.hs
@@ -0,0 +1,106 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+{-# LANGUAGE CPP #-}
+module Maybes (
+        module Data.Maybe,
+
+        MaybeErr(..), -- Instance of Monad
+        failME, isSuccess,
+
+        orElse,
+        firstJust, firstJusts,
+        whenIsJust,
+        expectJust,
+
+        MaybeT(..)
+    ) where
+#if __GLASGOW_HASKELL__ < 709
+import Control.Applicative
+#endif
+import Control.Monad
+import Data.Maybe
+
+infixr 4 `orElse`
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[Maybe type]{The @Maybe@ type}
+*                                                                      *
+************************************************************************
+-}
+
+firstJust :: Maybe a -> Maybe a -> Maybe a
+firstJust a b = firstJusts [a, b]
+
+-- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or
+-- @Nothing@ otherwise.
+firstJusts :: [Maybe a] -> Maybe a
+firstJusts = msum
+
+expectJust :: String -> Maybe a -> a
+{-# INLINE expectJust #-}
+expectJust _   (Just x) = x
+expectJust err Nothing  = error ("expectJust " ++ err)
+
+whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenIsJust (Just x) f = f x
+whenIsJust Nothing  _ = return ()
+
+-- | Flipped version of @fromMaybe@, useful for chaining.
+orElse :: Maybe a -> a -> a
+orElse = flip fromMaybe
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[MaybeT type]{The @MaybeT@ monad transformer}
+*                                                                      *
+************************************************************************
+-}
+
+newtype MaybeT m a = MaybeT {runMaybeT :: m (Maybe a)}
+
+instance Functor m => Functor (MaybeT m) where
+  fmap f x = MaybeT $ fmap (fmap f) $ runMaybeT x
+
+instance (Monad m, Functor m) => Applicative (MaybeT m) where
+  pure  = return
+  (<*>) = ap
+
+instance Monad m => Monad (MaybeT m) where
+  return = MaybeT . return . Just
+  x >>= f = MaybeT $ runMaybeT x >>= maybe (return Nothing) (runMaybeT . f)
+  fail _ = MaybeT $ return Nothing
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[MaybeErr type]{The @MaybeErr@ type}
+*                                                                      *
+************************************************************************
+-}
+
+data MaybeErr err val = Succeeded val | Failed err
+
+instance Functor (MaybeErr err) where
+  fmap = liftM
+
+instance Applicative (MaybeErr err) where
+  pure  = return
+  (<*>) = ap
+
+instance Monad (MaybeErr err) where
+  return v = Succeeded v
+  Succeeded v >>= k = k v
+  Failed e    >>= _ = Failed e
+
+isSuccess :: MaybeErr err val -> Bool
+isSuccess (Succeeded {}) = True
+isSuccess (Failed {})    = False
+
+failME :: err -> MaybeErr err val
+failME e = Failed e