src-test/Parsers/Types.hs

   1 {-|
   2 Module      : Parsers.Types
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Here is a longer description of this module, containing some
  11 commentary with @some markup@.
  12 -}
  13
  14 {-# OPTIONS_GHC -fno-warn-orphans #-}
  15
  16 {-# LANGUAGE StandaloneDeriving   #-}
  17
  18 module Parsers.Types where
  19
  20 import Gargantext.Prelude
  21
  22 import Test.QuickCheck
  23 import Test.QuickCheck.Instances ()
  24
  25 import Text.Parsec.Pos
  26 import Text.Parsec.Error (ParseError, Message(..), newErrorMessage)
  27 import Data.Time.LocalTime (ZonedTime (..), TimeZone (..), TimeOfDay(..), LocalTime(..))
  28 import Data.Eq (Eq(..))
  29 import Data.Either (Either(..))
  30
  31 deriving instance Eq ZonedTime
  32
  33 looseTimeOfDayPrecision :: TimeOfDay -> TimeOfDay
  34 looseTimeOfDayPrecision (TimeOfDay h m _) = TimeOfDay h m 0
  35
  36 looseLocalTimePrecision :: LocalTime -> LocalTime
  37 looseLocalTimePrecision (LocalTime ld ltd) = LocalTime ld $ looseTimeOfDayPrecision ltd
  38
  39 looseTimeZonePrecision :: TimeZone -> TimeZone
  40 looseTimeZonePrecision (TimeZone zm _ _) = TimeZone zm False "CET"
  41
  42 looseZonedTimePrecision :: ZonedTime -> ZonedTime
  43 looseZonedTimePrecision (ZonedTime lt tz) = ZonedTime (looseLocalTimePrecision lt) $ looseTimeZonePrecision tz
  44
  45 loosePrecisionEitherPEZT :: Either ParseError ZonedTime -> Either ParseError ZonedTime
  46 loosePrecisionEitherPEZT (Right zt) = Right $ looseZonedTimePrecision zt
  47 loosePrecisionEitherPEZT pe = pe
  48
  49 instance Arbitrary Message where
  50   arbitrary = do
  51     msgContent <- arbitrary
  52     oneof $ return <$> [SysUnExpect msgContent
  53                        , UnExpect msgContent
  54                        , Expect msgContent
  55                        , Message msgContent
  56                        ]
  57
  58 instance Arbitrary SourcePos where
  59   arbitrary = do
  60     sn <- arbitrary
  61     l <- arbitrary
  62     c <- arbitrary
  63     return $ newPos sn l c
  64
  65 instance Arbitrary ParseError where
  66   arbitrary = do
  67     sp <- arbitrary
  68     msg <- arbitrary
  69     return $ newErrorMessage msg sp