hjugement-protocol/src/Voting/Protocol/Utils.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Voting.Protocol.Utils where
   3
   4 import Control.Applicative (Applicative(..))
   5 import Control.Arrow (first)
   6 import Data.Bool
   7 import Data.Either (Either(..), either)
   8 import Data.Eq (Eq(..))
   9 import Data.Foldable (sequenceA_)
  10 import Data.Function (($), (.))
  11 import Data.Functor ((<$))
  12 import Data.Maybe (Maybe(..), maybe, listToMaybe)
  13 import Data.String (String)
  14 import Data.Traversable (Traversable(..))
  15 import Data.Tuple (uncurry)
  16 import Numeric.Natural (Natural)
  17 import Prelude (Integer, fromIntegral)
  18 import qualified Data.Aeson.Internal as JSON
  19 import qualified Data.List as List
  20 import qualified System.Random as Random
  21 import qualified Text.ParserCombinators.ReadP as Read
  22
  23 -- | Like ('.') but with two arguments.
  24 o2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d
  25 o2 f g = \x y -> f (g x y)
  26 infixr 9 `o2`
  27 {-# INLINE o2 #-}
  28
  29 -- | NOTE: check the lengths before applying @f@.
  30 isoZipWith :: (a->b->c) -> [a]->[b]->Maybe [c]
  31 isoZipWith f as bs
  32  | List.length as /= List.length bs = Nothing
  33  | otherwise = Just (List.zipWith f as bs)
  34
  35 -- | NOTE: check the lengths before applying @f@.
  36 isoZipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->Maybe [d]
  37 isoZipWith3 f as bs cs
  38  | al /= List.length bs = Nothing
  39  | al /= List.length cs = Nothing
  40  | otherwise = Just (List.zipWith3 f as bs cs)
  41  where al = List.length as
  42
  43 isoZipWithM ::
  44  Applicative f =>
  45  f () -> (a->b->f c) -> [a]->[b]->f [c]
  46 isoZipWithM err f as bs =
  47         maybe ([] <$ err) sequenceA $
  48                 isoZipWith f as bs
  49
  50 isoZipWithM_ ::
  51  Applicative f =>
  52  f () -> (a->b->f c) -> [a]->[b]->f ()
  53 isoZipWithM_ err f as bs =
  54         maybe err sequenceA_ $
  55                 isoZipWith f as bs
  56
  57 isoZipWith3M ::
  58  Applicative f =>
  59  f () -> (a->b->c->f d) -> [a]->[b]->[c]->f [d]
  60 isoZipWith3M err f as bs cs =
  61         maybe ([] <$ err) sequenceA $
  62                 isoZipWith3 f as bs cs
  63
  64 isoZipWith3M_ ::
  65  Applicative f =>
  66  f () -> (a->b->c->f d) -> [a]->[b]->[c]->f ()
  67 isoZipWith3M_ err f as bs cs =
  68         maybe err sequenceA_ $
  69                 isoZipWith3 f as bs cs
  70
  71 -- * JSON utils
  72
  73 -- | Copied from 'Data.Aeson''s 'eitherFormatError'
  74 -- which is not exported.
  75 jsonEitherFormatError :: Either (JSON.JSONPath, String) a -> Either String a
  76 jsonEitherFormatError = either (Left . uncurry JSON.formatError) Right
  77 {-# INLINE jsonEitherFormatError #-}
  78
  79 instance Random.Random Natural where
  80         randomR (mini,maxi) =
  81                 first (fromIntegral::Integer -> Natural) .
  82                 Random.randomR (fromIntegral mini, fromIntegral maxi)
  83         random = first (fromIntegral::Integer -> Natural) . Random.random
  84
  85 -- * Parsing utils
  86
  87 parseReadP :: Read.ReadP a -> String -> Maybe a
  88 parseReadP p s =
  89         let p' = Read.readP_to_S p in
  90         listToMaybe $ do
  91                 (x, "") <- p' s
  92                 pure x