cli/Hcompta/Expr/Maybe.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE NoImplicitPrelude #-}
   3 {-# OPTIONS_GHC -fno-warn-tabs #-}
   4
   5 module Hcompta.Expr.Maybe where
   6
   7 import Data.Maybe (Maybe(..))
   8 import Control.Monad (Monad(..))
   9 import Data.Function (($))
  10
  11 import Hcompta.Expr.Dup
  12
  13 -- * Class 'Expr_Maybe'
  14
  15 class Expr_Maybe repr where
  16         default may
  17          :: Monad repr
  18          => repr (Maybe a)
  19          -> repr b
  20          -> repr ((->) (repr a) (repr b))
  21          -> repr b
  22         default nothing
  23          :: Monad repr
  24          => repr (Maybe a)
  25         default just
  26          :: Monad repr
  27          => repr a
  28          -> repr (Maybe a)
  29
  30         may
  31          :: repr (Maybe a)
  32          -> repr b
  33          -> repr ((->) (repr a) (repr b))
  34          -> repr b
  35         may r_m r_n r_j = do
  36                 m <- r_m
  37                 case m of
  38                  Nothing -> r_n
  39                  Just x -> do
  40                         j <- r_j
  41                         j (return x)
  42         nothing :: repr (Maybe a)
  43         nothing = return Nothing
  44         just :: repr a -> repr (Maybe a)
  45         just r_a = do
  46                 a <- r_a
  47                 return $ Just a
  48
  49 instance -- Expr_Maybe Dup
  50  ( Expr_Maybe r1
  51  , Expr_Maybe r2
  52  , Monad r1
  53  , Monad r2
  54  ) => Expr_Maybe (Dup r1 r2) where
  55         may (m1 `Dup` m2) (n1 `Dup` n2) (r1_j `Dup` r2_j) =
  56                 may m1 n1 (return $ \r1_a -> do
  57                         j <- r1_j
  58                         a <- r1_a
  59                         dup1 $ j $ r1_a `Dup` return a)
  60                 `Dup`
  61                 may m2 n2 (return $ \r2_a -> do
  62                         j <- r2_j
  63                         a <- r2_a
  64                         dup2 $ j $ return a `Dup` r2_a)
  65         nothing = nothing `Dup` nothing
  66         just (a1 `Dup` a2) = just (a1 `Dup` a2)