never executed always true always false

    1 module Reporting.Result where
    2 
    3 import qualified Control.Monad as M
    4 import Control.Monad.Except (Except, runExcept)
    5 import Data.Coapplicative
    6 import qualified Reporting.Annotation as A
    7 import qualified Reporting.Region as R
    8 
    9 
   10 -- TASK
   11 
   12 data Result warning error result =
   13     Result
   14       [A.Located warning]
   15       (RawResult [A.Located error] result)
   16     deriving (Show)
   17 
   18 
   19 data RawResult e a
   20     = Ok a
   21     | Err e
   22     deriving (Show)
   23 
   24 
   25 -- HELPERS
   26 
   27 ok :: a -> Result w e a
   28 ok value =
   29   Result [] (Ok value)
   30 
   31 
   32 throw :: R.Region -> e -> Result w e a
   33 throw region err =
   34   Result [] (Err [A.A region err])
   35 
   36 
   37 throwMany :: [A.Located e] -> Result w e a
   38 throwMany errors =
   39   Result [] (Err errors)
   40 
   41 
   42 from :: (e -> e') -> Except [A.Located e] a -> Result w e' a
   43 from f except =
   44   case runExcept except of
   45     Right answer ->
   46         ok answer
   47 
   48     Left errors ->
   49         throwMany (map (fmap f) errors)
   50 
   51 
   52 mapError :: (e -> e') -> Result w e a -> Result w e' a
   53 mapError f (Result warnings rawResult) =
   54   Result warnings $
   55     case rawResult of
   56       Ok v ->
   57           Ok v
   58 
   59       Err msgs ->
   60           Err (map (fmap f) msgs)
   61 
   62 
   63 warn :: R.Region -> w -> Result w e ()
   64 warn region warning =
   65   Result [A.A region warning] (Ok ())
   66 
   67 
   68 addWarnings :: [A.Located w] -> Result w e a -> Result w e a
   69 addWarnings newWarnings (Result warnings rawResult) =
   70   Result (newWarnings ++ warnings) rawResult
   71 
   72 
   73 destruct :: (e -> b) -> (a -> b) -> RawResult e a -> b
   74 destruct errFunc okFunc rawResult =
   75   case rawResult of
   76     Ok answer ->
   77         okFunc answer
   78 
   79     Err errors ->
   80         errFunc errors
   81 
   82 
   83 toMaybe :: Result w x a -> Maybe a
   84 toMaybe (Result _ (Ok a)) = Just a
   85 toMaybe (Result _ (Err _)) = Nothing
   86 
   87 
   88 toEither :: Result w x a -> Either [x] a
   89 toEither (Result _ (Ok a)) = Right a
   90 toEither (Result _ (Err x)) = Left $ fmap extract x
   91 
   92 
   93 -- EXTRA FANCY HELPERS
   94 
   95 instance M.Functor (Result w e) where
   96   fmap func (Result warnings rawResult) =
   97       case rawResult of
   98         Ok a ->
   99             Result warnings (Ok (func a))
  100 
  101         Err msgs ->
  102             Result warnings (Err msgs)
  103 
  104 
  105 instance Applicative (Result w e) where
  106   pure value =
  107       ok value
  108 
  109   (<*>) (Result warnings resultFunc) (Result warnings' resultVal) =
  110       Result (warnings ++ warnings') $
  111           case (resultFunc, resultVal) of
  112             (Ok func, Ok val) ->
  113                 Ok (func val)
  114 
  115             (Err msgs, Err msgs') ->
  116                 Err (msgs ++ msgs')
  117 
  118             (Err msgs, _) ->
  119                 Err msgs
  120 
  121             (_, Err msgs) ->
  122                 Err msgs
  123 
  124 
  125 instance M.Monad (Result w e) where
  126   return value =
  127       ok value
  128 
  129   (>>=) (Result warnings rawResult) callback =
  130       case rawResult of
  131           Err msg ->
  132               Result warnings (Err msg)
  133 
  134           Ok value ->
  135               let (Result warnings' rawResult') = callback value
  136               in
  137                   Result (warnings ++ warnings') rawResult'