1. Haskell / Говнокод #19672

    −57

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    32. 32
    33. 33
    34. 34
    35. 35
    36. 36
    37. 37
    38. 38
    39. 39
    40. 40
    41. 41
    42. 42
    43. 43
    44. 44
    45. 45
    46. 46
    47. 47
    48. 48
    49. 49
    50. 50
    51. 51
    52. 52
    53. 53
    54. 54
    55. 55
    56. 56
    57. 57
    58. 58
    59. 59
    60. 60
    61. 61
    62. 62
    63. 63
    64. 64
    65. 65
    66. 66
    67. 67
    68. 68
    69. 69
    70. 70
    71. 71
    72. 72
    73. 73
    74. 74
    75. 75
    76. 76
    77. 77
    78. 78
    79. 79
    80. 80
    81. 81
    82. 82
    83. 83
    84. 84
    85. 85
    86. 86
    87. 87
    88. 88
    89. 89
    90. 90
    91. 91
    92. 92
    93. 93
    94. 94
    95. 95
    96. 96
    97. 97
    98. 98
    module Control.Monad.Warning (
   errorToWarning
 , errorsToWarnings
 , justW
 , rightW
 , WarningT(..)
 , MonadWarning(..)
 , module Control.Monad.Except
 , module Control.Monad.Writer
 )
 where

import Control.Applicative
import Control.Monad.Except
import Control.Monad.Writer
import Control.Monad.Reader
import Data.Monoid

newtype WarningT w e m a = WarningT { runWarningT ∷ w → m (w, Either e a) }

class (Monad m) ⇒ MonadWarning w e m | m → w e where
  warning ∷ w → m ()
  throwW  ∷ e → m a
  catchW  ∷ m a → (e → m a) → m a

instance (Functor m) ⇒ Functor (WarningT w e m) where
  fmap f a = WarningT $ \w → let f' (w', a') = (w', (fmap f) a')
                             in fmap f' $ runWarningT a w

instance (Applicative m) ⇒ Applicative (WarningT w e m) where
  pure a = WarningT $ \w → pure (w, Right a)
  f <*> a = WarningT $ \w → runWarningT f w 
       (w', f') = 
       (w'', a') = runWarningT a w'
     in case (f', a') of
       (Right f'', Right a'') → undefined --runWarningT (f'' a'') w''
       (Left l, _) → pure (w', Left l)
       (_, Left l) → pure (w'', Left l)

instance (Monad m, Monoid w) ⇒ Monad (WarningT w e m) where
  return a = WarningT $ \w → return (w, Right a)
  
  a >>= b = WarningT $ \w → do
    (w', e) ← runWarningT a w
    case e of
     Right r → runWarningT (b r) w'
     Left l → return (w', Left l)

  fail = WarningT . fail

instance (Monad m, Monoid w) ⇒ MonadWarning w e (WarningT w e m) where
  warning w' = WarningT $ \w → return (w `mappend` w', Right ())

  throwW e = WarningT $ \w → return (w, Left e)
  
  catchW a f = WarningT $ \w → do
    (w', e) ← runWarningT a w
    case e of
     Right e' → return (w', Right e')
     Left e' → runWarningT (f e') w'

instance (MonadWarning w e m) ⇒ MonadError e m where
  throwError = throwW
  catchError = catchW

instance (Monoid w, MonadWarning w e m) ⇒ MonadWriter w m where
  tell = warning

instance MonadTrans (WarningT w e) where
  lift a = WarningT $ \w → do
    a' ← a
    return $ (w, Right a')

instance (Monoid w, MonadIO m) ⇒ MonadIO (WarningT w e m) where
  liftIO = lift . liftIO

instance (MonadReader r m, Monoid w) ⇒ MonadReader r (WarningT w e m) where
  ask = lift ask
  -- TODO: Check and test it.
  local f a = WarningT $ \w → local f $ runWarningT a w
  
errorToWarning ∷ (Monoid w, MonadWarning w e m) ⇒ (e → w) → (e → m a) → m a → m a
errorToWarning f g a = catchW a (\e → warning (f e) >> g e)

errorsToWarnings ∷ (Monoid w, MonadWarning w e m) ⇒ (e → w) → [m a] → m [a]
errorsToWarnings f = foldl go (return [])
  where go r a = errorToWarning f (const r) $ do
          a' ← a
          r' ← r
          return $ a' : r'--
          
justW ∷ (MonadWarning w e m) ⇒ e → Maybe a → m a
justW _ (Just x) = return x
justW e Nothing  = throwW e

rightW ∷ (MonadWarning w e m) ⇒ (e' → e) → Either e' a → m a
rightW _ (Right x) = return x
rightW f (Left e) = throwW (f e)

    выкладываю перед выпиливанием этого говна

    Запостил: CHayT, 22 Марта 2016

    Комментарии (329) RSS

    Добавить комментарий