{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Witch.Instances where

import qualified Control.Exception as Exception
import qualified Data.Bits as Bits
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as LazyByteString
import qualified Data.ByteString.Short as ShortByteString
import qualified Data.Complex as Complex
import qualified Data.Fixed as Fixed
import qualified Data.Foldable as Foldable
import qualified Data.Int as Int
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Ratio as Ratio
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Encoding as LazyText
import qualified Data.Time as Time
import qualified Data.Time.Clock.POSIX as Time
import qualified Data.Time.Clock.System as Time
import qualified Data.Time.Clock.TAI as Time
import qualified Data.Word as Word
import qualified GHC.Float as Float
import qualified Numeric
import qualified Numeric.Natural as Natural
import qualified Witch.From as From
import qualified Witch.TryFrom as TryFrom
import qualified Witch.TryFromException as TryFromException
import qualified Witch.Utility as Utility

-- | Uses 'id'.
instance From.From a a where
  from = id

-- Int8

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Int.Int16 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Int.Int32 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Int.Int64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Int where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Integer where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int8 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int8 Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int8 Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int8 Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int8 Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral' when the input is not negative.
instance TryFrom.TryFrom Int.Int8 Natural.Natural where
  tryFrom = Utility.eitherTryFrom fromNonNegativeIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Float where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int8 Double where
  from = fromIntegral

-- Int16

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int16 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Int.Int16 Int.Int32 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int16 Int.Int64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int16 Int where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int16 Integer where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int16 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int16 Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int16 Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int16 Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int16 Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral' when the input is not negative.
instance TryFrom.TryFrom Int.Int16 Natural.Natural where
  tryFrom = Utility.eitherTryFrom fromNonNegativeIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int16 Float where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int.Int16 Double where
  from = fromIntegral

-- Int32

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Int.Int32 Int.Int64 where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Int.Int32 Integer where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int32 Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral' when the input is not negative.
instance TryFrom.TryFrom Int.Int32 Natural.Natural where
  tryFrom = Utility.eitherTryFrom fromNonNegativeIntegral

-- | Uses 'fromIntegral' when the input is between -16,777,215 and 16,777,215
-- inclusive.
instance TryFrom.TryFrom Int.Int32 Float where
  tryFrom = Utility.eitherTryFrom $ \s -> if s < -maxFloat
    then Left Exception.Underflow
    else if s > maxFloat
      then Left Exception.Overflow
      else Right $ fromIntegral s

-- | Uses 'fromIntegral'.
instance From.From Int.Int32 Double where
  from = fromIntegral

-- Int64

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Int.Int64 Integer where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int.Int64 Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral' when the input is not negative.
instance TryFrom.TryFrom Int.Int64 Natural.Natural where
  -- This should use @eitherTryFrom fromNonNegativeIntegral@, but that causes
  -- a bug in GHC 9.0.1.
  -- https://mail.haskell.org/pipermail/haskell-cafe/2021-March/133540.html
  tryFrom =
    Utility.eitherTryFrom $ \s -> TryFrom.tryFrom (From.from s :: Integer)

-- | Uses 'fromIntegral' when the input is between -16,777,215 and 16,777,215
-- inclusive.
instance TryFrom.TryFrom Int.Int64 Float where
  tryFrom = Utility.eitherTryFrom $ \s -> if s < -maxFloat
    then Left Exception.Underflow
    else if s > maxFloat
      then Left Exception.Overflow
      else Right $ fromIntegral s

-- | Uses 'fromIntegral' when the input is between -9,007,199,254,740,991 and
-- 9,007,199,254,740,991 inclusive.
instance TryFrom.TryFrom Int.Int64 Double where
  tryFrom = Utility.eitherTryFrom $ \s -> if s < -maxDouble
    then Left Exception.Underflow
    else if s > maxDouble
      then Left Exception.Overflow
      else Right $ fromIntegral s

-- Int

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Int Int.Int64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Int Integer where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Int Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral' when the input is not negative.
instance TryFrom.TryFrom Int Natural.Natural where
  tryFrom = Utility.eitherTryFrom fromNonNegativeIntegral

-- | Uses 'fromIntegral' when the input is between -16,777,215 and 16,777,215
-- inclusive.
instance TryFrom.TryFrom Int Float where
  tryFrom = Utility.eitherTryFrom $ \s -> if s < -maxFloat
    then Left Exception.Underflow
    else if s > maxFloat
      then Left Exception.Overflow
      else Right $ fromIntegral s

-- | Uses 'fromIntegral' when the input is between -9,007,199,254,740,991 and
-- 9,007,199,254,740,991 inclusive.
instance TryFrom.TryFrom Int Double where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if toInteger (maxBound :: Int) <= maxDouble
      then Right $ fromIntegral s
      else if s < -maxDouble
        then Left Exception.Underflow
        else if s > maxDouble
          then Left Exception.Overflow
          else Right $ fromIntegral s

-- Integer

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Int.Int64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Integer Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromInteger' when the input is not negative.
instance TryFrom.TryFrom Integer Natural.Natural where
  -- This should use @eitherTryFrom fromNonNegativeIntegral@, but that causes
  -- a bug in GHC 9.0.1. By inlining @fromNonNegativeIntegral@ and replacing
  -- @fromIntegral@ with @fromInteger@, we can work around the bug.
  -- https://mail.haskell.org/pipermail/haskell-cafe/2021-March/133540.html
  tryFrom = Utility.eitherTryFrom
    $ \s -> if s < 0 then Left Exception.Underflow else Right $ fromInteger s

-- | Uses 'fromIntegral' when the input is between -16,777,215 and 16,777,215
-- inclusive.
instance TryFrom.TryFrom Integer Float where
  tryFrom = Utility.eitherTryFrom $ \s -> if s < -maxFloat
    then Left Exception.Underflow
    else if s > maxFloat
      then Left Exception.Overflow
      else Right $ fromIntegral s

-- | Uses 'fromIntegral' when the input is between -9,007,199,254,740,991 and
-- 9,007,199,254,740,991 inclusive.
instance TryFrom.TryFrom Integer Double where
  tryFrom = Utility.eitherTryFrom $ \s -> if s < -maxDouble
    then Left Exception.Underflow
    else if s > maxDouble
      then Left Exception.Overflow
      else Right $ fromIntegral s

-- Word8

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Word.Word16 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Word.Word32 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Word.Word64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Word where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Natural.Natural where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word8 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Int.Int16 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Int.Int32 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Int.Int64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Int where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Integer where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Float where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word8 Double where
  from = fromIntegral

-- Word16

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word16 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Word.Word32 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Word.Word64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Word where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Natural.Natural where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word16 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word16 Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Int.Int32 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Int.Int64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Int where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Integer where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Float where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word.Word16 Double where
  from = fromIntegral

-- Word32

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word32 Word.Word64 where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word32 Natural.Natural where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word32 Int.Int64 where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word32 Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word32 Integer where
  from = fromIntegral

-- | Uses 'fromIntegral' when the input is less than or equal to 16,777,215.
instance TryFrom.TryFrom Word.Word32 Float where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if s <= maxFloat then Right $ fromIntegral s else Left Exception.Overflow

-- | Uses 'fromIntegral'.
instance From.From Word.Word32 Double where
  from = fromIntegral

-- Word64

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word64 Natural.Natural where
  -- This should use @fromIntegral@, but that causes a bug in GHC 9.0.1.
  -- https://mail.haskell.org/pipermail/haskell-cafe/2021-March/133540.html
  from s = Utility.unsafeFrom (From.from s :: Integer)

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Int.Int64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word.Word64 Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word.Word64 Integer where
  from = fromIntegral

-- | Uses 'fromIntegral' when the input is less than or equal to 16,777,215.
instance TryFrom.TryFrom Word.Word64 Float where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if s <= maxFloat then Right $ fromIntegral s else Left Exception.Overflow

-- | Uses 'fromIntegral' when the input is less than or equal to
-- 9,007,199,254,740,991.
instance TryFrom.TryFrom Word.Word64 Double where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if s <= maxDouble then Right $ fromIntegral s else Left Exception.Overflow

-- Word

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word Word.Word64 where
  from = fromIntegral

-- | Uses 'fromIntegral'.
instance From.From Word Natural.Natural where
  from = fromIntegral

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Int.Int64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Word Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Word Integer where
  from = fromIntegral

-- | Uses 'fromIntegral' when the input is less than or equal to 16,777,215.
instance TryFrom.TryFrom Word Float where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if s <= maxFloat then Right $ fromIntegral s else Left Exception.Overflow

-- | Uses 'fromIntegral' when the input is less than or equal to
-- 9,007,199,254,740,991.
instance TryFrom.TryFrom Word Double where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if (toInteger (maxBound :: Word) <= maxDouble) || (s <= maxDouble)
      then Right $ fromIntegral s
      else Left Exception.Overflow

-- Natural

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Word.Word8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Word.Word16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Word.Word32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Word.Word64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Word where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Int.Int8 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Int.Int16 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Int.Int32 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Int.Int64 where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'Bits.toIntegralSized'.
instance TryFrom.TryFrom Natural.Natural Int where
  tryFrom = Utility.maybeTryFrom Bits.toIntegralSized

-- | Uses 'fromIntegral'.
instance From.From Natural.Natural Integer where
  from = fromIntegral

-- | Uses 'fromIntegral' when the input is less than or equal to 16,777,215.
instance TryFrom.TryFrom Natural.Natural Float where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if s <= maxFloat then Right $ fromIntegral s else Left Exception.Overflow

-- | Uses 'fromIntegral' when the input is less than or equal to
-- 9,007,199,254,740,991.
instance TryFrom.TryFrom Natural.Natural Double where
  tryFrom = Utility.eitherTryFrom $ \s ->
    if s <= maxDouble then Right $ fromIntegral s else Left Exception.Overflow

-- Float

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Int.Int8 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Int.Int16 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Int.Int32 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Int.Int64 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Int where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Rational' when the input is between -16,777,215 and
-- 16,777,215 inclusive.
instance TryFrom.TryFrom Float Integer where
  tryFrom = Utility.eitherTryFrom $ \s -> case Utility.tryVia @Rational s of
    Left e -> Left $ Exception.toException e
    Right t
      | t < -maxFloat -> Left $ Exception.toException Exception.Underflow
      | t > maxFloat -> Left $ Exception.toException Exception.Overflow
      | otherwise -> Right t

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Word.Word8 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Word.Word16 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Word.Word32 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Word.Word64 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Word where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Float Natural.Natural where
  tryFrom = Utility.tryVia @Integer

-- | Uses 'Numeric.floatToDigits' when the input is not NaN or infinity.
instance TryFrom.TryFrom Float Rational where
  tryFrom = Utility.eitherTryFrom realFloatToRational

-- | Uses 'Float.float2Double'.
instance From.From Float Double where
  from = Float.float2Double

-- Double

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Int.Int8 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Int.Int16 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Int.Int32 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Int.Int64 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Int where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Rational' when the input is between -9,007,199,254,740,991
-- and 9,007,199,254,740,991 inclusive.
instance TryFrom.TryFrom Double Integer where
  tryFrom = Utility.eitherTryFrom $ \s -> case Utility.tryVia @Rational s of
    Left e -> Left $ Exception.toException e
    Right t
      | t < -maxDouble -> Left $ Exception.toException Exception.Underflow
      | t > maxDouble -> Left $ Exception.toException Exception.Overflow
      | otherwise -> Right t

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Word.Word8 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Word.Word16 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Word.Word32 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Word.Word64 where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Word where
  tryFrom = Utility.tryVia @Integer

-- | Converts via 'Integer'.
instance TryFrom.TryFrom Double Natural.Natural where
  tryFrom = Utility.tryVia @Integer

-- | Uses 'Numeric.floatToDigits' when the input is not NaN or infinity.
instance TryFrom.TryFrom Double Rational where
  tryFrom = Utility.eitherTryFrom realFloatToRational

-- | Uses 'Float.double2Float'. This necessarily loses some precision.
instance From.From Double Float where
  from = Float.double2Float

-- Ratio

-- | Uses '(Ratio.%)' with a denominator of 1.
instance Integral a => From.From a (Ratio.Ratio a) where
  from = (Ratio.% 1)

-- | Uses 'Ratio.numerator' when the denominator is 1.
instance (Eq a, Num a) => TryFrom.TryFrom (Ratio.Ratio a) a where
  tryFrom = Utility.eitherTryFrom $ \s -> if Ratio.denominator s == 1
    then Right $ Ratio.numerator s
    else Left Exception.LossOfPrecision

-- | Uses 'fromRational'. This necessarily loses some precision.
instance From.From Rational Float where
  from = fromRational

-- | Uses 'fromRational'. This necessarily loses some precision.
instance From.From Rational Double where
  from = fromRational

-- | Uses `fromRational` as long as there isn't a loss of precision.
instance Fixed.HasResolution a => TryFrom.TryFrom Rational (Fixed.Fixed a) where
  tryFrom = Utility.eitherTryFrom $ \s ->
    let
      t :: Fixed.Fixed a
      t = fromRational s
    in if toRational t == s then Right t else Left Exception.LossOfPrecision

-- Fixed

-- | Uses 'Fixed.MkFixed'. This means @from \@Integer \@Centi 2@ is @0.02@
-- rather than @2.00@.
instance From.From Integer (Fixed.Fixed a) where
  from = Fixed.MkFixed

-- | Uses 'Fixed.MkFixed'. This means @from \@Centi \@Integer 3.00@ is @300@
-- rather than @3@.
instance From.From (Fixed.Fixed a) Integer where
  from (Fixed.MkFixed t) = t

-- | Uses 'toRational'.
instance Fixed.HasResolution a => From.From (Fixed.Fixed a) Rational where
  from = toRational

-- Complex

-- | Uses '(Complex.:+)' with an imaginary part of 0.
instance Num a => From.From a (Complex.Complex a) where
  from = (Complex.:+ 0)

-- | Uses 'Complex.realPart' when the imaginary part is 0.
instance (Eq a, Num a) => TryFrom.TryFrom (Complex.Complex a) a where
  tryFrom = Utility.eitherTryFrom $ \s -> if Complex.imagPart s == 0
    then Right $ Complex.realPart s
    else Left Exception.LossOfPrecision

-- NonEmpty

-- | Uses 'NonEmpty.nonEmpty'.
instance TryFrom.TryFrom [a] (NonEmpty.NonEmpty a) where
  tryFrom = Utility.maybeTryFrom NonEmpty.nonEmpty

-- | Uses 'NonEmpty.toList'.
instance From.From (NonEmpty.NonEmpty a) [a] where
  from = NonEmpty.toList

-- Set

-- | Uses 'Set.fromList'.
instance Ord a => From.From [a] (Set.Set a) where
  from = Set.fromList

-- | Uses 'Set.toAscList'.
instance From.From (Set.Set a) [a] where
  from = Set.toAscList

-- IntSet

-- | Uses 'IntSet.fromList'.
instance From.From [Int] IntSet.IntSet where
  from = IntSet.fromList

-- | Uses 'IntSet.toAscList'.
instance From.From IntSet.IntSet [Int] where
  from = IntSet.toAscList

-- Map

-- | Uses 'Map.fromList'. If there are duplicate keys, later values will
-- overwrite earlier ones.
instance Ord k => From.From [(k, v)] (Map.Map k v) where
  from = Map.fromList

-- | Uses 'Map.toAscList'.
instance From.From (Map.Map k v) [(k, v)] where
  from = Map.toAscList

-- IntMap

-- | Uses 'IntMap.fromList'. If there are duplicate keys, later values will
-- overwrite earlier ones.
instance From.From [(Int, v)] (IntMap.IntMap v) where
  from = IntMap.fromList

-- | Uses 'IntMap.toAscList'.
instance From.From (IntMap.IntMap v) [(Int, v)] where
  from = IntMap.toAscList

-- Seq

-- | Uses 'Seq.fromList'.
instance From.From [a] (Seq.Seq a) where
  from = Seq.fromList

-- | Uses 'Foldable.toList'.
instance From.From (Seq.Seq a) [a] where
  from = Foldable.toList

-- ByteString

-- | Uses 'ByteString.pack'.
instance From.From [Word.Word8] ByteString.ByteString where
  from = ByteString.pack

-- | Uses 'ByteString.unpack'.
instance From.From ByteString.ByteString [Word.Word8] where
  from = ByteString.unpack

-- | Uses 'LazyByteString.fromStrict'.
instance From.From ByteString.ByteString LazyByteString.ByteString where
  from = LazyByteString.fromStrict

-- | Uses 'ShortByteString.toShort'.
instance From.From ByteString.ByteString ShortByteString.ShortByteString where
  from = ShortByteString.toShort

-- | Uses 'Text.decodeUtf8''.
instance TryFrom.TryFrom ByteString.ByteString Text.Text where
  tryFrom = Utility.eitherTryFrom Text.decodeUtf8'

-- | Converts via 'Text.Text'.
instance TryFrom.TryFrom ByteString.ByteString LazyText.Text where
  tryFrom =
    Utility.eitherTryFrom
      $ fmap (Utility.into @LazyText.Text)
      . Utility.tryInto @Text.Text

-- | Converts via 'Text.Text'.
instance TryFrom.TryFrom ByteString.ByteString String where
  tryFrom =
    Utility.eitherTryFrom
      $ fmap (Utility.into @String)
      . Utility.tryInto @Text.Text

-- LazyByteString

-- | Uses 'LazyByteString.pack'.
instance From.From [Word.Word8] LazyByteString.ByteString where
  from = LazyByteString.pack

-- | Uses 'LazyByteString.unpack'.
instance From.From LazyByteString.ByteString [Word.Word8] where
  from = LazyByteString.unpack

-- | Uses 'LazyByteString.toStrict'.
instance From.From LazyByteString.ByteString ByteString.ByteString where
  from = LazyByteString.toStrict

-- | Uses 'LazyText.decodeUtf8''.
instance TryFrom.TryFrom LazyByteString.ByteString LazyText.Text where
  tryFrom = Utility.eitherTryFrom LazyText.decodeUtf8'

-- | Converts via 'LazyText.Text'.
instance TryFrom.TryFrom LazyByteString.ByteString Text.Text where
  tryFrom =
    Utility.eitherTryFrom
      $ fmap (Utility.into @Text.Text)
      . Utility.tryInto @LazyText.Text

-- | Converts via 'LazyText.Text'.
instance TryFrom.TryFrom LazyByteString.ByteString String where
  tryFrom =
    Utility.eitherTryFrom
      $ fmap (Utility.into @String)
      . Utility.tryInto @LazyText.Text

-- ShortByteString

-- | Uses 'ShortByteString.pack'.
instance From.From [Word.Word8] ShortByteString.ShortByteString where
  from = ShortByteString.pack

-- | Uses 'ShortByteString.unpack'.
instance From.From ShortByteString.ShortByteString [Word.Word8] where
  from = ShortByteString.unpack

-- | Uses 'ShortByteString.fromShort'.
instance From.From ShortByteString.ShortByteString ByteString.ByteString where
  from = ShortByteString.fromShort

-- Text

-- | Uses 'LazyText.fromStrict'.
instance From.From Text.Text LazyText.Text where
  from = LazyText.fromStrict

-- | Uses 'Text.encodeUtf8'.
instance From.From Text.Text ByteString.ByteString where
  from = Text.encodeUtf8

-- | Converts via 'ByteString.ByteString'.
instance From.From Text.Text LazyByteString.ByteString where
  from = Utility.via @ByteString.ByteString

-- LazyText

-- | Uses 'LazyText.toStrict'.
instance From.From LazyText.Text Text.Text where
  from = LazyText.toStrict

-- | Uses 'LazyText.encodeUtf8'.
instance From.From LazyText.Text LazyByteString.ByteString where
  from = LazyText.encodeUtf8

-- | Converts via 'LazyByteString.ByteString'.
instance From.From LazyText.Text ByteString.ByteString where
  from = Utility.via @LazyByteString.ByteString

-- String

-- | Uses 'Text.pack'. Some 'Char' values cannot be represented in 'Text.Text'
-- and will be replaced with @'\\xFFFD'@.
instance From.From String Text.Text where
  from = Text.pack

-- | Uses 'Text.unpack'.
instance From.From Text.Text String where
  from = Text.unpack

-- | Uses 'LazyText.pack'. Some 'Char' values cannot be represented in
-- 'LazyText.Text' and will be replaced with @'\\xFFFD'@.
instance From.From String LazyText.Text where
  from = LazyText.pack

-- | Uses 'LazyText.unpack'.
instance From.From LazyText.Text String where
  from = LazyText.unpack

-- | Converts via 'Text.Text'.
instance From.From String ByteString.ByteString where
  from = Utility.via @Text.Text

-- | Converts via 'LazyText.Text'.
instance From.From String LazyByteString.ByteString where
  from = Utility.via @LazyText.Text

-- TryFromException

-- | Uses @coerce@.
instance From.From
  (TryFromException.TryFromException source oldTarget)
  (TryFromException.TryFromException source newTarget)

-- Day

-- | Uses 'Time.ModifiedJulianDay'.
instance From.From Integer Time.Day where
  from = Time.ModifiedJulianDay

-- | Uses 'Time.toModifiedJulianDay'.
instance From.From Time.Day Integer where
  from = Time.toModifiedJulianDay

-- DayOfWeek

-- | Uses 'Time.dayOfWeek'.
instance From.From Time.Day Time.DayOfWeek where
  from = Time.dayOfWeek

-- UniversalTime

-- | Uses 'Time.ModJulianDate'.
instance From.From Rational Time.UniversalTime where
  from = Time.ModJulianDate

-- | Uses 'Time.getModJulianDate'.
instance From.From Time.UniversalTime Rational where
  from = Time.getModJulianDate

-- DiffTime

-- | Uses 'realToFrac'.
instance From.From Fixed.Pico Time.DiffTime where
  from = realToFrac

-- | Uses 'realToFrac'.
instance From.From Time.DiffTime Fixed.Pico where
  from = realToFrac

-- NominalDiffTime

-- | Uses 'Time.secondsToNominalDiffTime'.
instance From.From Fixed.Pico Time.NominalDiffTime where
  from = Time.secondsToNominalDiffTime

-- | Uses 'Time.nominalDiffTimeToSeconds'.
instance From.From Time.NominalDiffTime Fixed.Pico where
  from = Time.nominalDiffTimeToSeconds

-- POSIXTime

-- | Uses 'Time.systemToPOSIXTime'.
instance From.From Time.SystemTime Time.POSIXTime where
  from = Time.systemToPOSIXTime

-- | Uses 'Time.utcTimeToPOSIXSeconds'.
instance From.From Time.UTCTime Time.POSIXTime where
  from = Time.utcTimeToPOSIXSeconds

-- | Uses 'Time.posixSecondsToUTCTime'.
instance From.From Time.POSIXTime Time.UTCTime where
  from = Time.posixSecondsToUTCTime

-- SystemTime

-- | Uses 'Time.utcToSystemTime'.
instance From.From Time.UTCTime Time.SystemTime where
  from = Time.utcToSystemTime

-- | Uses 'Time.systemToTAITime'.
instance From.From Time.SystemTime Time.AbsoluteTime where
  from = Time.systemToTAITime

-- | Uses 'Time.systemToUTCTime'.
instance From.From Time.SystemTime Time.UTCTime where
  from = Time.systemToUTCTime

-- TimeOfDay

-- | Uses 'Time.timeToTimeOfDay'.
instance From.From Time.DiffTime Time.TimeOfDay where
  from = Time.timeToTimeOfDay

-- | Uses 'Time.dayFractionToTimeOfDay'.
instance From.From Rational Time.TimeOfDay where
  from = Time.dayFractionToTimeOfDay

-- | Uses 'Time.timeOfDayToTime'.
instance From.From Time.TimeOfDay Time.DiffTime where
  from = Time.timeOfDayToTime

-- | Uses 'Time.timeOfDayToDayFraction'.
instance From.From Time.TimeOfDay Rational where
  from = Time.timeOfDayToDayFraction

-- CalendarDiffTime

-- | Uses 'Time.calendarTimeDays'.
instance From.From Time.CalendarDiffDays Time.CalendarDiffTime where
  from = Time.calendarTimeDays

-- | Uses 'Time.calendarTimeTime'.
instance From.From Time.NominalDiffTime Time.CalendarDiffTime where
  from = Time.calendarTimeTime

-- ZonedTime

-- | Uses 'Time.zonedTimeToUTC'.
instance From.From Time.ZonedTime Time.UTCTime where
  from = Time.zonedTimeToUTC

--

realFloatToRational
  :: RealFloat s => s -> Either Exception.ArithException Rational
realFloatToRational s
  | isNaN s = Left Exception.LossOfPrecision
  | isInfinite s = if s > 0
    then Left Exception.Overflow
    else Left Exception.Underflow
  | otherwise = Right $ overPositive
    (uncurry makeRational . uncurry fromDigits . Numeric.floatToDigits 10)
    s

overPositive :: (Eq a, Num a, Num b) => (a -> b) -> a -> b
overPositive f x = if signum x == -1 then -(f (-x)) else f x

fromDigits :: [Int] -> Int -> (Integer, Integer)
fromDigits ds e =
  List.foldl' (\(a, n) d -> (a * 10 + toInteger d, n - 1)) (0, toInteger e) ds

makeRational :: Integer -> Integer -> Rational
makeRational d e = toRational d * 10 ^^ e

fromNonNegativeIntegral
  :: (Integral s, Num t) => s -> Either Exception.ArithException t
fromNonNegativeIntegral x =
  if x < 0 then Left Exception.Underflow else Right $ fromIntegral x

-- | The maximum integral value that can be unambiguously represented as a
-- 'Float'. Equal to 16,777,215.
maxFloat :: Num a => a
maxFloat = 16777215

-- | The maximum integral value that can be unambiguously represented as a
-- 'Double'. Equal to 9,007,199,254,740,991.
maxDouble :: Num a => a
maxDouble = 9007199254740991


{-# LANGUAGE Haskell98 #-}
{-# LINE 1 "src/Data/Complex/Compat.hs" #-}

{-# LANGUAGE CPP, NoImplicitPrelude #-}
module Data.Complex.Compat (
  module Base
) where

import Data.Complex as Base


{-# LANGUAGE TemplateHaskell, RecordWildCards #-}
module TestGamer where

import           Data.ByteString.Builder        ( toLazyByteString )
import qualified Data.ByteString.Lazy          as B
import           Data.List                      ( foldl1'
                                                , stripPrefix
                                                )
import qualified Data.Map.Strict               as Map
import           Data.Maybe                     ( fromMaybe )
import           Data.Ord                       ( Down(Down) )
import qualified Data.Set                      as S
import qualified Data.Vector                   as V
import           GHC.Float                      ( float2Int
                                                , int2Float
                                                )
import           GHC.IO.Handle                  ( hDuplicate
                                                , hDuplicateTo
                                                )
import           Graphics.EasyPlot              ( Graph2D(Function2D)
                                                , Option(Title)
                                                , Option2D(Range, Step)
                                                , Plot(plot)
                                                , TerminalType(PNG)
                                                )
import           Internal.Evolution
import           Internal.Gamer
import           Statistics.Sample              ( correlation )
import           System.IO                      ( IOMode(WriteMode)
                                                , hClose
                                                , openFile
                                                , stdout
                                                )
import           Test.QuickCheck                ( Gen
                                                , Property
                                                , arbitrary
                                                , counterexample
                                                , cover
                                                , generate
                                                , quickCheckAll
                                                , vectorOf
                                                , verboseCheck
                                                , withMaxSuccess
                                                )
import           Text.Regex.TDFA                ( (=~) )
import           Util

matchup :: [Agent a] -> [[Agent a]]
--matchup = matchWithBest 2 10 (Down . agentFitness) . S.fromDistinctAscList
matchup = matchups 2 . S.fromDistinctAscList

prop_encodedLen :: GamerParams -> Gen Bool
prop_encodedLen params@GamerParams {..} = do
    tree <- genStateTransitionTree params
    let encoded = encodeTransitions params tree
        bsLen   = fromIntegral . B.length . toLazyByteString
    return $ 0 == bsLen encoded `rem` bcdLen gamerStates

prop_encodeUniformLen :: GamerParams -> Gen Bool
prop_encodeUniformLen params = do
    let encodedLen = B.length . encodeGenome params <$> genGenome params
    cs <- vectorOf 20 encodedLen
    return $ all (head cs ==) cs

prop_treeUniform :: GamerParams -> Gen Bool
prop_treeUniform params@GamerParams {..} = do
    let uniform (NextState _ ) = True
        uniform (Reactions xs) = length xs == gamerActions && all uniform xs
    tree <- genStateTransitionTree params
    return $ uniform tree

prop_evolveFitness :: GamerParams -> EvolutionParams -> Gen Property
prop_evolveFitness gParams eParams@EvolutionParams {..} = do
    let game   = playGame dilemma 100
        avgFit = combineWith
            (/)
            [ sum . map agentFitness . getFitness game . matchup
            , realToFrac . length
            ]
    pop  <- genPlayers gParams { gamerActions = 2 } evolvePopSize
    pop' <- evolve eParams game matchup pop
    let dFit = avgFit pop' - avgFit pop
    return
        . counterexample ("dFit = " ++ show dFit)
        . cover 90 (dFit > 0) "increased fitness"
        $ True -- we only care about the statistics

-- | Redirects @stdout@ to a file temporarily to capture output of an IO action,
-- then returns the file's contents.
outputToFile
    :: String -- ^ The name of the file to redirect output to.
    -> IO () -- ^ The IO action to execute, which should output to @stdout@.
    -> IO String
outputToFile filename action = do
    stdout' <- hDuplicate stdout
    file    <- openFile filename WriteMode
    hDuplicateTo file stdout
    action
    hClose file
    hDuplicateTo stdout' stdout
    readFile filename

-- | Parses parameter names and values from 'Test.QuickCheck.verboseCheck' output.
--
-- Returns a Map from each parameter's name to a Vector of its values,
-- collected from all tests in order of execution.
parseQuickCheck
    :: Read a
    => String -- ^ The output of 'Test.QuickCheck.verboseCheck'.
    -> Map.Map String (V.Vector a)
parseQuickCheck text = Map.fromListWith
    (V.++)
    [ (parseKey match, parseVal match) | match <- matches ]
  where
    regex   = "([a-zA-Z]+) = ([-0-9.]+)"
    matches = text =~ regex :: [[String]]
    stripGet s = fromMaybe s (stripPrefix "get" s)
    parseKey match = stripGet $ match !! 1
    parseVal match = V.singleton . read $ match !! 2

analyzeEvolveFitness :: IO Bool
analyzeEvolveFitness = do
    let filename = "prop_evolveFitness.log"

    text <-
        outputToFile filename
        . verboseCheck
        . withMaxSuccess 300
        $ prop_evolveFitness

    let allData = parseQuickCheck text
        pairFit = Map.map $ V.zip (allData Map.! "dFit")
        rs      = Map.map correlation $ pairFit allData

    mapM_
        putStrLn
        ("correlations:" : [ k ++ " = " ++ show v | (k, v) <- Map.assocs rs ])
    return True

graphEvolveFitness :: IO Bool
graphEvolveFitness = do
    runs <- generate $ vectorOf
        10
        (arbitrary >>= \x -> arbitrary >>= \y -> genCollectEvolve x y)
    let avgRun = mergeRuns $ map (map avgFit) runs
    plot (PNG "plot.png") $ Function2D
        [Title "Average Fitness"]
        [Range 0 (int2Float $ length avgRun - 1), Step 1]
        ((avgRun !!) . float2Int)
  where
    avgFit :: [Agent a] -> Float
    avgFit = combineWith (/) [sum . map agentFitness, realToFrac . length]
    mergeRuns :: [[Float]] -> [Float]
    mergeRuns = foldl1' (zipWith (\x y -> (x + y) / 2))
    game      = playGame dilemma 5
    genCollectEvolve
        :: GamerParams -> EvolutionParams -> Gen [[Agent [PlayerState]]]
    genCollectEvolve gParams eParams@EvolutionParams {..} = do
        pop <- genPlayers gParams { gamerActions = 2 } evolvePopSize
        collectEvolve eParams game matchup pop

return []
runTests :: IO Bool
runTests = $quickCheckAll


-- |
-- Copyright: 2013 (C) Amgen, Inc
--

{-# Language ConstraintKinds #-}
{-# Language DefaultSignatures #-}
{-# Language DataKinds #-}
{-# Language FlexibleContexts #-}
{-# Language FlexibleInstances #-}
{-# Language FunctionalDependencies #-}
{-# Language GADTs #-}
{-# Language LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# Language TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# Language ViewPatterns #-}

-- required to not warn about IsVector usage.
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Language.R.Literal
  ( -- * Literals conversion
    Literal(..)
  , toPairList
  , fromPairList
    -- * Derived helpers
  , fromSomeSEXP
  , mkSEXP
  , dynSEXP
  , mkSEXPVector
  , mkSEXPVectorIO
  , mkProtectedSEXPVector
  , mkProtectedSEXPVectorIO
    -- * Internal
  , funToSEXP
  ) where

import           Control.Memory.Region
import           Control.Monad.R.Class
import qualified Data.Vector.SEXP as SVector
import qualified Data.Vector.SEXP.Mutable as SMVector
import qualified Foreign.R as R
import qualified Foreign.R.Internal as R (somesexp)
import           Foreign.R.Type ( IsVector, SSEXPTYPE )
import           Foreign.R ( SEXP, SomeSEXP(..) )
import           Internal.Error
import           {-# SOURCE #-} Language.R.Internal (r1)
import           Language.R.Globals (nilValue)
import           Language.R.HExp
import           Language.R.Instance
import           Language.R.Internal.FunWrappers
import           Language.R.Internal.FunWrappers.TH

import Data.Singletons ( Sing, SingI, fromSing, sing )

import Control.DeepSeq ( NFData )
import Control.Monad ( void, zipWithM_ )
import Data.Int (Int32)
import qualified Data.ByteString.Unsafe as B
import Data.Complex (Complex)
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import Foreign          ( FunPtr, castPtr )
import Foreign.C.String ( withCString )
import Foreign.Storable ( Storable, pokeElemOff )
import qualified GHC.Foreign as GHC
import GHC.IO.Encoding.UTF8
import System.IO.Unsafe ( unsafePerformIO )

-- | Values that can be converted to 'SEXP'.
class SingI ty => Literal a ty | a -> ty where
    -- | Internal function for converting a literal to a 'SEXP' value. You
    -- probably want to be using 'mkSEXP' instead.
    mkSEXPIO :: a -> IO (SEXP V ty)
    fromSEXP :: SEXP s ty -> a

    default mkSEXPIO :: (IsVector ty, Literal [a] ty) => a -> IO (SEXP V ty)
    mkSEXPIO x = mkSEXPIO [x]

    default fromSEXP :: (IsVector ty, Literal [a] ty) => SEXP s ty -> a
    fromSEXP (fromSEXP -> [x]) = x
    fromSEXP _ = failure "fromSEXP" "Not a singleton vector."

-- |  Create a SEXP value and protect it in current region
mkSEXP :: (Literal a b, MonadR m) => a -> m (SEXP (Region m) b)
mkSEXP x = acquire =<< io (mkSEXPIO x)

-- | Like 'fromSEXP', but with no static type satefy. Performs a dynamic
-- (i.e. at runtime) check instead.
fromSomeSEXP :: forall s a form. (Literal a form) => R.SomeSEXP s -> a
fromSomeSEXP = fromSEXP . R.cast (sing :: Sing form)

-- | Like 'fromSomeSEXP', but behaves like the @as.*@ family of functions
-- in R, by performing a best effort conversion to the target form (e.g. rounds
-- reals to integers, etc) for atomic types.
dynSEXP :: forall a s ty. (Literal a ty) => SomeSEXP s -> a
dynSEXP (SomeSEXP sx) =
    fromSomeSEXP $ unsafePerformIO $ case fromSing (sing :: SSEXPTYPE ty) of
      R.Char -> r1 "as.character" sx
      R.Int -> r1 "as.integer" sx
      R.Real -> r1 "as.double" sx
      R.Complex -> r1 "as.complex" sx
      R.Logical -> r1 "as.logical" sx
      R.Raw -> r1 "as.raw" sx
      _ -> return $ SomeSEXP $ R.release sx

{-# NOINLINE mkSEXPVector #-}
mkSEXPVector :: (Storable (SVector.ElemRep s a), IsVector a)
             => SSEXPTYPE a
             -> [IO (SVector.ElemRep s a)]
             -> SEXP s a
mkSEXPVector ty allocators = unsafePerformIO $ mkSEXPVectorIO ty allocators

mkSEXPVectorIO :: (Storable (SVector.ElemRep s a), IsVector a)
               => SSEXPTYPE a
               -> [IO (SVector.ElemRep s a)]
               -> IO (SEXP s a)
mkSEXPVectorIO ty allocators =
    R.withProtected (R.allocVector ty $ length allocators) $ \vec -> do
      let ptr = castPtr $ R.unsafeSEXPToVectorPtr vec
      zipWithM_ (\i -> (>>= pokeElemOff ptr i)) [0..] allocators
      return vec

{-# NOINLINE mkProtectedSEXPVector #-}
mkProtectedSEXPVector :: IsVector b
                      => SSEXPTYPE b
                      -> [SEXP s a]
                      -> SEXP s b
mkProtectedSEXPVector ty xs = unsafePerformIO $ mkProtectedSEXPVectorIO ty xs

mkProtectedSEXPVectorIO :: IsVector b
                        => SSEXPTYPE b
                        -> [SEXP s a]
                        -> IO (SEXP s b)
mkProtectedSEXPVectorIO ty xs = do
    mapM_ (void . R.protect) xs
    z <- R.withProtected (R.allocVector ty $ length xs) $ \vec -> do
           let ptr = castPtr $ R.unsafeSEXPToVectorPtr vec
           zipWithM_ (pokeElemOff ptr) [0..] xs
           return vec
    R.unprotect (length xs)
    return z

instance Literal [R.Logical] 'R.Logical where
    mkSEXPIO = mkSEXPVectorIO sing . map return
    fromSEXP (hexp -> Logical v) = SVector.toList v
    fromSEXP _ =
        failure "fromSEXP" "Logical expected where some other expression appeared."

instance Literal [Int32] 'R.Int where
    mkSEXPIO = mkSEXPVectorIO sing . map return
    fromSEXP (hexp -> Int v) = SVector.toList v
    fromSEXP _ =
        failure "fromSEXP" "Int expected where some other expression appeared."

instance Literal [Double] 'R.Real where
    mkSEXPIO = mkSEXPVectorIO sing . map return
    fromSEXP (hexp -> Real v) = SVector.toList v
    fromSEXP _ =
        failure "fromSEXP" "Numeric expected where some other expression appeared."

instance Literal [Complex Double] 'R.Complex where
    mkSEXPIO = mkSEXPVectorIO sing . map return
    fromSEXP (hexp -> Complex v) = SVector.toList v
    fromSEXP _ =
        failure "fromSEXP" "Complex expected where some other expression appeared."

instance Literal [String] 'R.String where
    mkSEXPIO =
        mkSEXPVectorIO sing .
        map (\str -> GHC.withCString utf8 str (R.mkCharCE R.CE_UTF8))
    fromSEXP (hexp -> String v) =
        map (\(hexp -> Char xs) -> SVector.toString xs) (SVector.toList v)
    fromSEXP _ =
        failure "fromSEXP" "String expected where some other expression appeared."

instance Literal Text 'R.String where
    mkSEXPIO s =
        mkSEXPVectorIO sing
          [ B.unsafeUseAsCStringLen (T.encodeUtf8 s) $
              uncurry (R.mkCharLenCE R.CE_UTF8) ]
    fromSEXP (hexp -> String v) =
      case SVector.toList v of
        [hexp -> Char x] -> SVector.unsafeWithByteString x $ \p -> do
           pure $ T.decodeUtf8 p
        _ -> failure "fromSEXP" "Not a singleton vector"
    fromSEXP _ =
      failure "fromSEXP" "String expected where some other expression appeared."

-- | Create a pairlist from an association list. Result is either a pairlist or
-- @nilValue@ if the input is the null list. These are two distinct forms. Hence
-- why the type of this function is not more precise.
toPairList :: MonadR m => [(String, SomeSEXP (Region m))] -> m (SomeSEXP (Region m))
toPairList [] = return $ SomeSEXP (R.release nilValue)
toPairList ((k, SomeSEXP v):kvs) = do
    -- No need to protect the tag because it's in the symbol table, so won't be
    -- garbage collected.
    tag <- io $ withCString k R.install
    toPairList kvs >>= \case
      SomeSEXP cdr@(hexp -> Nil) ->
        fmap SomeSEXP $ unhexp $ List v cdr (R.unsafeRelease tag)
      SomeSEXP cdr@(hexp -> List _ _ _) ->
        fmap SomeSEXP $ unhexp $ List v cdr (R.unsafeRelease tag)
      _ -> impossible "toPairList"

-- | Create an association list from a pairlist. R Pairlists are nil-terminated
-- chains of nested cons cells, as in LISP.
fromPairList :: SomeSEXP s -> [(String, SomeSEXP s)]
fromPairList (SomeSEXP (hexp -> Nil)) = []
fromPairList (SomeSEXP (hexp -> List car cdr (hexp -> Symbol (hexp -> Char name) _ _))) =
    (SVector.toString name, SomeSEXP car) : fromPairList (SomeSEXP cdr)
fromPairList (SomeSEXP (hexp -> List _ _ _)) =
    failure "fromPairList" "Association listed expected but tag not set."
fromPairList _ =
    failure "fromPairList" "Pairlist expected where some other expression appeared."

-- Use the default definitions included in the class declaration.
instance Literal R.Logical 'R.Logical
instance Literal Int32 'R.Int
instance Literal Double 'R.Real
instance Literal (Complex Double) 'R.Complex

instance Literal String 'R.String where
    mkSEXPIO x = mkSEXPIO [x]
    fromSEXP x@(hexp -> String {})
      | [h] <- fromSEXP x = h
      | otherwise = failure "fromSEXP" "Not a singleton vector."
    fromSEXP _ =
        failure "fromSEXP" "String expected where some other expression appeared."

instance SVector.SVECTOR ty a => Literal (SVector.Vector ty a) ty where
    mkSEXPIO = return . SVector.toSEXP
    fromSEXP = SVector.fromSEXP . R.cast (sing :: SSEXPTYPE ty)
             . SomeSEXP

instance SVector.VECTOR V ty a => Literal (SMVector.MVector V ty a) ty where
    mkSEXPIO = unsafeRunRegion . SMVector.toSEXP
    fromSEXP = SMVector.fromSEXP . R.cast (sing :: SSEXPTYPE ty)
             . SomeSEXP . R.release

instance SingI a => Literal (SEXP s a) a where
    mkSEXPIO = fmap R.unsafeRelease . return
    fromSEXP = R.cast (sing :: SSEXPTYPE a) . SomeSEXP . R.unsafeRelease

instance Literal (SomeSEXP s) 'R.Any where
    -- The ANYSXP type in R plays the same role as SomeSEXP in H. It is a dummy
    -- type tag, that is never seen in any object. It serves only as a stand-in
    -- when the real type is not known.
    mkSEXPIO (SomeSEXP s) = return . R.unsafeRelease $ R.unsafeCoerce s
    fromSEXP = SomeSEXP . R.unsafeRelease

instance (NFData a, Literal a b) => Literal (R s a) 'R.ExtPtr where
    mkSEXPIO = funToSEXP wrap0
    fromSEXP = unimplemented "Literal (R s a) fromSEXP"

instance (NFData b, Literal a a0, Literal b b0) => Literal (a -> R s b) 'R.ExtPtr where
    mkSEXPIO = funToSEXP wrap1
    fromSEXP = unimplemented "Literal (a -> R s b) fromSEXP"

instance (NFData c, Literal a a0, Literal b b0, Literal c c0)
         => Literal (a -> b -> R s c) 'R.ExtPtr where
    mkSEXPIO   = funToSEXP wrap2
    fromSEXP = unimplemented "Literal (a -> b -> IO c) fromSEXP"

-- | A class for functions that can be converted to functions on SEXPs.
class HFunWrap a b | a -> b where
    hFunWrap :: a -> b

instance (NFData a, Literal a la) => HFunWrap (R s a) (IO R.SEXP0) where
    hFunWrap a = fmap R.unsexp $ (mkSEXPIO $!) =<< unsafeRunRegion a

instance (Literal a la, HFunWrap b wb)
         => HFunWrap (a -> b) (R.SEXP0 -> wb) where
    hFunWrap f a = hFunWrap $ f $! fromSEXP (R.cast sing (R.somesexp a) :: SEXP s la)

foreign import ccall "missing_r.h funPtrToSEXP" funPtrToSEXP
    :: FunPtr a -> IO (SEXP s 'R.ExtPtr)

funToSEXP :: HFunWrap a b => (b -> IO (FunPtr b)) -> a -> IO (SEXP s 'R.ExtPtr)
funToSEXP w x = funPtrToSEXP =<< w (hFunWrap x)

$(thWrapperLiterals 3 12)


{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE TypeOperators             #-}

module Main where

import           Control.Arrow                          ((&&&))
import           Control.Exception                      (bracket)
import           Control.Lens                           (to, toListOf, view,
                                                         (%~), (&), (.~), (^.),
                                                         (^..), _2)
import           Control.Monad                          (when)
import           Control.Monad.Par.Class                (NFData)
import           Criterion
import           Criterion.Types                        (Regression (..),
                                                         Report (..),
                                                         SampleAnalysis (..))
import qualified Data.Binary                            as Bin
import qualified Data.ByteString.Lazy                   as B
import qualified Data.Csv                               as Csv
import           Data.Default                           (def)
import           Data.Function                          (on)
import           Data.List                              (nub, sort, sortBy)
import           Data.List.Split                        (splitOn)
import           Data.Maybe                             (fromMaybe)
import           Data.Monoid                            ((<>))
import qualified Data.Text                              as T
import qualified Data.Vector                            as V
import           GHC.Generics                           (Generic)
import           Graphics.Rendering.Chart.Backend.Cairo (FileFormat (..),
                                                         fo_format,
                                                         renderableToFile)
import qualified Options.Generic                        as Opts
import           Statistics.Resampling.Bootstrap        (Estimate (..))
import           System.Directory                       (doesFileExist)
import           System.IO                              (BufferMode (..),
                                                         hGetBuffering,
                                                         hSetBuffering, stdin)

import           Bench
import qualified Classes.Cross                          as Classes
import qualified Classes.Exception                      as Classes
import qualified Classes.Reader                         as Classes
import qualified Classes.RSABS                          as Classes
import qualified Classes.State                          as Classes
import qualified Classes.Writer                         as Classes
import qualified Freer.Cross                            as Freer
import qualified Freer.Exception                        as Freer
import qualified Freer.Reader                           as Freer
import qualified Freer.RSABS                            as Freer
import qualified Freer.State                            as Freer
import qualified Freer.Writer                           as Freer
import           Latex
import qualified Mtl.Cross                              as Mtl
import qualified Mtl.Exception                          as Mtl
import qualified Mtl.Reader                             as Mtl
import qualified Mtl.RSABS                              as Mtl
import qualified Mtl.State                              as Mtl
import qualified Mtl.Writer                             as Mtl
import           Plot

steps :: Num a => a -> a -> Int -> [a]
steps _ _ 0 = []
steps low stepSize n = low : steps (low + stepSize) stepSize (n - 1)

genBenches :: (Integral a, NFData b) => [a] -> [(T.Text, a -> b)] -> [Bench Benchmarkable]
genBenches xValues = map mkBench
  where
    mkBench (name, benchmark) =
        Bench name (map (fromIntegral &&& nf benchmark) xValues)

benchmarks :: [BenchGroup Benchmarkable]
benchmarks = [
      BenchGroup {
            _bgId = "cd"
          , _bgDescription = "State"
          , _bgBenches = genBenches (steps (10^6) (10^6) 10)
                [
                  ("monad-classes", Classes.countdown)
                , ("freer", Freer.countdown)
                , ("mtl", Mtl.countdown)
                ]
          , _bgXAxisName = "# of iterations"
      }

    , BenchGroup {
        _bgId = "ras"
      , _bgDescription = "ReaderStackAboveState"
      , _bgBenches = (\n ks ->
          [
            Bench "freer" (map (\k -> (k, whnf (Freer.readersAboveState k) n)) ks)
          , Bench "monad-classes" (map (\k -> (k, whnf (Classes.readersAboveState k) n)) ks)
          , Bench "mtl" (map (\k -> (k, whnf (Mtl.readersAboveState k) n)) ks)
          ]) (10^6) [0..10]
      , _bgXAxisName = "# of Reader layers above State"
      }

    , BenchGroup {
          _bgId = "rbs"
        , _bgDescription = "ReaderStackBelowState"
        , _bgBenches = (\n ks ->
            [
              Bench "freer" (map (\k -> (k, whnf (Freer.readersBelowState k) n)) ks)
            , Bench "monad-classes" (map (\k -> (k, whnf (Classes.readersBelowState k) n)) ks)
            , Bench "mtl" (map (\k -> (k, whnf (Mtl.readersBelowState k) n)) ks)
            ]) (10^6) [0..10]
        , _bgXAxisName = "# of Reader layers below State"
        }

    , BenchGroup {
          _bgId = "exc"
        , _bgDescription = "Exception"
        , _bgBenches = genBenches (steps (10^8) (10^8) 10)
              [
                ("monad-classes", Classes.exception)
              , ("freer", Freer.exception)
              , ("mtl", Mtl.exception)
              ]
        , _bgXAxisName = "# of iterations"
        }

    , BenchGroup {
          _bgId = "cdr"
        , _bgDescription = "Reader"
        , _bgBenches = genBenches (steps (10^6) (10^6) 10)
              [
                ("monad-classes", Classes.countdownReader)
              , ("freer", Freer.countdownReader)
              , ("mtl", Mtl.countdownReader)
              ]
        , _bgXAxisName = "# of iterations"
        }

    , BenchGroup {
          _bgId = "rt"
        , _bgDescription = "Writer"
        , _bgBenches = genBenches (steps (10^5) (10^5) 10)
              [
                ("monad-classes", Classes.repeatedTell)
              , ("freer", Freer.repeatedTell)
              , ("mtl", Mtl.repeatedTell)
              ]
        , _bgXAxisName = "# of iterations"
        }
    ] ++ map parseDeclaration crossBenchDeclarations

data BenchDecl = forall a b. (Integral a, NFData b) => BenchDecl {
      bdName        :: T.Text
    , bdDescription :: T.Text
    , bdMagnitude   :: a
    , bdBenches     :: [(T.Text, a -> b)]
    }

parseDeclaration :: BenchDecl -> BenchGroup Benchmarkable
parseDeclaration (BenchDecl name desc magnitude fwsAndFuns) = BenchGroup {
      _bgId = name
    , _bgDescription = desc
    , _bgBenches = genBenches (steps magnitude magnitude 10) fwsAndFuns
    , _bgXAxisName = "# of iterations"
    }

crossBenchDeclarations :: [BenchDecl]
crossBenchDeclarations = [
      BenchDecl "ss" "StateAboveState" (10^6) [
          ("freer", Freer.stateState)
        , ("monad-classes", Classes.stateState)
        , ("mtl", Mtl.stateState)
        ]
    , BenchDecl "sr" "StateAboveReader" (10^7) [
          ("freer", Freer.stateReader)
        , ("monad-classes", Classes.stateReader)
        , ("mtl", Mtl.stateReader)
        ]
    , BenchDecl "sw" "StateAboveWriter" (10^6) [
          ("freer", Freer.stateWriter)
        , ("monad-classes", Classes.stateWriter)
        , ("mtl", Mtl.stateWriter)
        ]
    , BenchDecl "se" "StateAboveException" (10^7) [
          ("freer", Freer.stateException)
        , ("monad-classes", Classes.stateException)
        , ("mtl", Mtl.stateException)
        ]
    , BenchDecl "rs" "ReaderAboveState" (10^7) [
          ("freer", Freer.readerState)
        , ("monad-classes", Classes.readerState)
        , ("mtl", Mtl.readerState)
        ]
    , BenchDecl "rr" "ReaderAboveReader" (10^3) [
          ("freer", Freer.readerReader)
        , ("monad-classes", Classes.readerReader)
        , ("mtl", Mtl.readerReader)
        ]
    , BenchDecl "rw" "ReaderAboveWriter" (10^3) [
          ("freer", Freer.readerWriter)
        , ("monad-classes", Classes.readerWriter)
        , ("mtl", Mtl.readerWriter)
        ]
    , BenchDecl "re" "ReaderAboveException" (10^6) [
          ("freer", Freer.readerException)
        , ("monad-classes", Classes.readerException)
        , ("mtl", Mtl.readerException)
        ]
    , BenchDecl "ws" "WriterAboveState" (10^6) [
          ("freer", Freer.writerState)
        , ("monad-classes", Classes.writerState)
        , ("mtl", Mtl.writerState)
        ]
    , BenchDecl "wr" "WriterAboveReader" (10^3) [
          ("freer", Freer.writerReader)
        , ("monad-classes", Classes.writerReader)
        , ("mtl", Mtl.writerReader)
        ]
    , BenchDecl "ww" "WriterAboveWriter" (10^3) [
          ("freer", Freer.writerWriter)
        , ("monad-classes", Classes.writerWriter)
        , ("mtl", Mtl.writerWriter)
        ]
    , BenchDecl "we" "WriterAboveException" (10^6) [
          ("freer", Freer.writerException)
        , ("monad-classes", Classes.writerException)
        , ("mtl", Mtl.writerException)
        ]
    , BenchDecl "es" "ExceptionAboveState" (10^7) [
          ("freer", Freer.exceptionState)
        , ("monad-classes", Classes.exceptionState)
        , ("mtl", Mtl.exceptionState)
        ]
    , BenchDecl "er" "ExceptionAboveReader" (10^6) [
          ("freer", Freer.exceptionReader)
        , ("monad-classes", Classes.exceptionReader)
        , ("mtl", Mtl.exceptionReader)
        ]
    , BenchDecl "ew" "ExceptionAboveWriter" (10^6) [
          ("freer", Freer.exceptionWriter)
        , ("monad-classes", Classes.exceptionWriter)
        , ("mtl", Mtl.exceptionWriter)
        ]
    , BenchDecl "ee" "ExceptionAboveException" (10^8) [
          ("freer", Freer.exceptionException)
        , ("monad-classes", Classes.exceptionException)
        , ("mtl", Mtl.exceptionException)
        ]
    ]

data Options =
      List
    | Run {
          bench    :: [T.Text]
        , savePath :: Maybe FilePath
        , fw       :: [T.Text]
        }
    | Plot FilePath
    | Latex [FilePath]
    | RSquared FilePath
    | Csv FilePath
    | Split FilePath
    | Regressions FilePath
    deriving (Generic, Show)

instance Opts.ParseRecord Options

ppBenchGroup :: BenchGroup a -> String
ppBenchGroup group = T.unpack $ group ^. bgId <> ": " <> group ^. bgDescription

aboutToBenchDescription :: [BenchGroup a] -> T.Text
aboutToBenchDescription bgs =
       "I'm about to benchmark:\n"
    <> T.replicate headerIndentLength " "
    <> header <> "\n"
    <> T.intercalate "\n" (map rowText rows)
  where
    headerIndentLength :: Int
    headerIndentLength = maximum (map T.length allFrameworks) + 1

    bgsSortedById = sortBy (compare `on` view bgId) bgs

    header :: T.Text
    header = T.concat (map insertSpaceAfter headerItems)
      where
        insertSpaceAfter item =
            item <> T.replicate (headerItemSpacing - T.length item) " "

    headerItems :: [T.Text] -- Benchmark group ids
    headerItems = map (view bgId) bgsSortedById

    headerItemSpacing = headerItemMaxLen + 3

    headerItemMaxLen = maximum (map T.length headerItems)

    rowText :: (T.Text, [Bool]) -> T.Text
    rowText (title, benchPresentList) =
           title <> T.replicate indent " "
        <> T.intercalate (T.replicate (headerItemSpacing - 1) " ") (map displayBool benchPresentList)
      where
        indent = headerIndentLength - T.length title

    rows :: [(T.Text, [Bool])]
    rows = map (id &&& benchesPresent) allFrameworks

    benchesPresent :: T.Text -> [Bool]
    benchesPresent fwName = map (elem fwName . fwsInBench) bgsSortedById
      where
        fwsInBench = toListOf (bgBenches . traverse . benchDescription)

    allFrameworks :: [T.Text]
    allFrameworks =
        sort (nub (bgs ^.. traverse . bgBenches . traverse . benchDescription))

    displayBool :: Bool -> T.Text
    displayBool False = " "
    displayBool True = "✓"

confirmSave :: FilePath -> IO Bool
confirmSave name = bracket
    clearAndStoreBuffering
    (hSetBuffering stdin) $
    \_ -> do
        putStrLn $ "Do you want to overwrite " <> name <> "? [press y to confirm]"
        response <- getChar
        return (response == 'y')
  where
    clearAndStoreBuffering = do
        buf <- hGetBuffering stdin
        hSetBuffering stdin NoBuffering
        return buf

main :: IO ()
main = do
    opts <- Opts.getRecord "Benchmarking" :: IO Options
    case opts of
        List -> do
            putStrLn "Available benchmarks:"
            mapM_ (putStrLn . ppBenchGroup) benchmarks

        Run benches mSavePath fws -> do
            let idsFiltered = if null benches
                    then benchmarks
                    else filter ((`elem` benches) . view bgId) benchmarks

            let toBenchmark = if null fws
                    then idsFiltered
                    else idsFiltered & traverse . bgBenches %~ filter ((`elem` fws) . view benchDescription)

            putStrLn (T.unpack $ aboutToBenchDescription toBenchmark)
            putStrLn ""

            let filename = fromMaybe "results.bin" mSavePath
            destFileExists <- doesFileExist filename
            saveConfirmed <- if destFileExists
                then confirmSave filename
                else return True

            results <- mapM runBenchGroup toBenchmark

            when saveConfirmed (B.writeFile filename (Bin.encode results))

        Plot path -> do
            results <- loadAndSortByDescription path
            mapM_ (\group -> do
                let filename = T.unpack (group ^. bgId) <> ".pdf"
                putStrLn $ "plot: " <> T.unpack (group ^. bgDescription) <> ": " <> filename
                renderableToFile
                    (def & fo_format .~ PDF)
                    filename
                    (plotBenchGroup group)
                ) results

        Latex paths -> do
            results <- concat <$> mapM loadAndSortByDescription paths
            mapM_ (putStrLn . T.unpack . exportTable) results

        RSquared path -> do
            results <- loadAndSortByDescription path
            let qualities = concatMap qualityReport results
            putStrLn $ "Worst R^2 value: " <> show (minimum (concatMap qRSquared qualities))
            case filter (not . all (>= 0.99) . qRSquared) qualities of
                [] -> putStrLn "All R^2 are over 0.99"
                qs -> do
                    putStrLn "NOT all R^2 are over 0.99:"
                    mapM_ (\q -> print $ qGroupDescription q <> "/" <> qBenchDescription q) qs

        Csv path -> do
            results <- loadAndSortByDescription path
            mapM_ (\group -> do
                let filename = T.unpack (group ^. bgId) <> ".csv"
                putStrLn $ "export csv: " <> T.unpack (group ^. bgDescription) <> ": " <> filename
                B.writeFile filename (toCsv (fmap getOLS group))
                ) results

        Regressions path -> do
            csv <- B.readFile path
            let Right regressions = fmap V.toList (Csv.decode Csv.HasHeader csv)
            let output = exportRegressions benchmarks regressions
            putStrLn (T.unpack output)

        Split path -> do
            results <- loadAndSortByDescription path
            let nameParts = splitOn ['.'] path
            mapM_ (\group -> do
                let newPath = concat (init nameParts)
                           ++ "."
                           ++ T.unpack (group ^. bgId)
                           ++ "."
                           ++ last nameParts
                B.writeFile newPath (Bin.encode [group])
                ) results

qualityReport :: BenchGroup Report -> [Quality]
qualityReport group = map buildQuality (group ^. bgBenches)
  where
    buildQuality :: Bench Report -> Quality
    buildQuality bench = Quality {
          qBenchDescription = bench ^. benchDescription
        , qGroupDescription = group ^. bgDescription
        , qRSquared = bench ^.. benchData . traverse . _2 . to reportAnalysis .
                                to anRegress . to head . to regRSquare .
                                to estPoint
        }

data Quality = Quality {
      qBenchDescription :: T.Text
    , qGroupDescription :: T.Text
    , qRSquared         :: [Double]
    } deriving Show

loadAndSortByDescription :: FilePath -> IO [BenchGroup Report]
loadAndSortByDescription path = do
    file <- B.readFile path
    let results = Bin.decode file :: [BenchGroup Report]
    return (results & traverse . bgBenches %~ sortBy (compare `on` view benchDescription))


{-# LANGUAGE TemplateHaskell #-}

-- | This module exports TH utilities intended to be useful to users.
--
-- 'makeStore' can be used to generate a 'Store' instance for types,
-- when all the type variables also require 'Store' instances. If some
-- do not, then instead use "TH.Derive" like this:
--
-- @
-- \{\-\# LANGUAGE TemplateHaskell \#\-\}
-- \{\-\# LANGUAGE ScopedTypeVariables \#\-\}
--
-- import TH.Derive
-- import Data.Store
--
-- data Foo a = Foo a | Bar Int
--
-- \$($(derive [d|
--     instance Store a => Deriving (Store (Foo a))
--     |]))
-- @
--
-- Note that when used with datatypes that require type variables, the
-- ScopedTypeVariables extension is required.
--
-- One advantage of using this Template Haskell definition of Store
-- instances is that in some cases they can be faster than the instances
-- defined via Generics. Specifically, sum types which can yield
-- 'ConstSize' from 'size' will be faster when used in array-like types.
-- The instances generated via generics always use 'VarSize' for sum
-- types.
module Data.Store.TH
    ( makeStore
    -- * Testing Store instances
    , smallcheckManyStore
    , checkRoundtrip
    , assertRoundtrip
    ) where

import qualified Control.Monad.Fail as Fail
import Data.Complex ()
import Data.Store.Impl
import Data.Typeable (Typeable, typeOf)
import Debug.Trace (trace)
import Language.Haskell.TH
import Prelude
import Test.Hspec
import Test.Hspec.SmallCheck (property)
import Test.SmallCheck
import Data.Store.TH.Internal (makeStore)

------------------------------------------------------------------------
-- Testing

-- | Test a 'Store' instance using 'smallcheck' and 'hspec'.
smallcheckManyStore :: Bool -> Int -> [TypeQ] -> ExpQ
smallcheckManyStore verbose depth = smallcheckMany . map testRoundtrip
  where
    testRoundtrip tyq = do
        ty <- tyq
        expr <- [e| property $ changeDepth (\_ -> depth) $ \x -> checkRoundtrip verbose (x :: $(return ty)) |]
        return ("Roundtrips (" ++ pprint ty ++ ")", expr)

assertRoundtrip :: (Eq a, Show a, Store a, Fail.MonadFail m, Typeable a) => Bool -> a -> m ()
assertRoundtrip verbose x
    | checkRoundtrip verbose x = return ()
    | otherwise = fail $ "Failed to roundtrip "  ++ show (typeOf x)

-- | Check if a given value succeeds in decoding its encoded
-- representation.
checkRoundtrip :: (Eq a, Show a, Store a) => Bool -> a -> Bool
checkRoundtrip verbose x = decoded == Right x
  where
    encoded = verboseTrace verbose "encoded" (encode x)
    decoded = verboseTrace verbose "decoded" (decode encoded)

smallcheckMany :: [Q (String, Exp)] -> ExpQ
smallcheckMany = doE . map (\f -> f >>= \(name, expr) -> noBindS [e| it name $ $(return expr) |])

verboseTrace :: Show a => Bool -> String -> a -> a
verboseTrace True msg x = trace (show (msg, x)) x
verboseTrace False _ x = x


-- |
-- This module reexports most of the definitions from the \"base\" package,
-- which are meant to be imported unqualified.
--
-- This is adapted from the base-prelude package by Nikita Volkov.
module Prelude.Base
  ( module E
  ) where

-- Reexports
-------------------------

import Control.Applicative as E
import Control.Arrow as E
import Control.Concurrent as E
import Control.Exception as E
import Control.Monad as E
import Control.Monad.Fix as E hiding (fix)
import Control.Monad.ST as E
import Data.Bits as E
import Data.Bool as E
import Data.Char as E
import Data.Complex as E
import Data.Data as E
import Data.Dynamic as E
import Data.Either as E
import Data.Fixed as E
import Data.Foldable as E
import Data.Functor as E
import Data.Function as E
import Data.Int as E
import Data.IORef as E
import Data.Ix as E
import Data.List as E
import Data.Maybe as E
import Data.Monoid as E
import Data.Ord as E
import Data.Ratio as E
import Data.STRef as E
import Data.String as E
import Data.Traversable as E
import Data.Tuple as E
import Data.Unique as E
import Data.Version as E
import Data.Word as E
import Debug.Trace as E
import Foreign.Storable as E (Storable)
import GHC.Conc as E hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)
import GHC.Generics as E (Generic)
import GHC.IO.Exception as E (IOError,ioError,userError)
import Prelude as E
import System.Environment as E
import System.Exit as E
import System.IO as E (Handle, hClose)
import System.IO.Error as E
import System.Mem as E
import System.Mem.StableName as E
import System.Timeout as E
import Text.ParserCombinators.ReadP as E (ReadP, readP_to_S, readS_to_P)
import Text.ParserCombinators.ReadPrec as E (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)
import Text.Read as E (Read(..), readMaybe, readEither)
import Unsafe.Coerce as E


module Hasql.TH.Prelude
  ( module Exports,
    showAsText,
    suffixRec,
  )
where

import Control.Applicative as Exports
import Control.Arrow as Exports hiding (first, second)
import Control.Category as Exports
import Control.Concurrent as Exports
import Control.Exception as Exports
import Control.Foldl as Exports (Fold (..))
import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_)
import Control.Monad.Fail as Exports
import Control.Monad.Fix as Exports hiding (fix)
import Control.Monad.IO.Class as Exports
import Control.Monad.ST as Exports
import Data.Bifunctor as Exports
import Data.Bits as Exports
import Data.Bool as Exports
import Data.ByteString as Exports (ByteString)
import Data.Char as Exports
import Data.Coerce as Exports
import Data.Complex as Exports
import Data.Data as Exports
import Data.Dynamic as Exports
import Data.Either as Exports
import Data.Fixed as Exports
import Data.Foldable as Exports
import Data.Function as Exports hiding (id, (.))
import Data.Functor as Exports
import Data.Functor.Contravariant as Exports
import Data.Functor.Contravariant.Divisible as Exports
import Data.Functor.Identity as Exports
import Data.IORef as Exports
import Data.Int as Exports
import Data.IntMap.Strict as Exports (IntMap)
import Data.IntSet as Exports (IntSet)
import Data.Ix as Exports
import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)
import Data.List.NonEmpty as Exports (NonEmpty (..))
import Data.Map.Strict as Exports (Map)
import Data.Maybe as Exports
import Data.Monoid as Exports hiding (First (..), Last (..), (<>))
import Data.Ord as Exports
import Data.Proxy as Exports
import Data.Ratio as Exports
import Data.STRef as Exports
import Data.Semigroup as Exports
import Data.Sequence as Exports (Seq)
import Data.Set as Exports (Set)
import Data.String as Exports
import Data.Text as Exports (Text)
import Data.Traversable as Exports
import Data.Tuple as Exports
import Data.UUID as Exports (UUID)
import Data.Unique as Exports
import Data.Version as Exports
import Data.Void as Exports
import Data.Word as Exports
import Debug.Trace as Exports
import Foreign.ForeignPtr as Exports
import Foreign.Ptr as Exports
import Foreign.StablePtr as Exports
import Foreign.Storable as Exports hiding (alignment, sizeOf)
import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)
import GHC.Exts as Exports (IsList (Item, fromList), groupWith, inline, lazy, sortWith)
import GHC.Generics as Exports (Generic, Generic1)
import GHC.IO.Exception as Exports
import Numeric as Exports
import System.Environment as Exports
import System.Exit as Exports
import System.IO as Exports
import System.IO.Error as Exports
import System.IO.Unsafe as Exports
import System.Mem as Exports
import System.Mem.StableName as Exports
import System.Timeout as Exports
import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)
import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)
import Text.Printf as Exports (hPrintf, printf)
import Text.Read as Exports (Read (..), readEither, readMaybe)
import Unsafe.Coerce as Exports
import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))

showAsText :: Show a => a -> Text
showAsText = show >>> fromString

-- |
-- Compose a monad, which attempts to extend a value, based on the following input.
-- It does that recursively until the suffix alternative fails.
suffixRec :: (Monad m, Alternative m) => m a -> (a -> m a) -> m a
suffixRec base suffix = do
  _base <- base
  suffixRec (suffix _base) suffix <|> pure _base


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE DefaultSignatures #-}
#endif

#if __GLASGOW_HASKELL__ >= 705
{-# LANGUAGE PolyKinds #-}
#endif

#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE EmptyCase #-}
#endif

#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif

module Generics.Deriving.Traversable (
  -- * Generic Traversable class
    GTraversable(..)

  -- * Default method
  , gtraversedefault

  -- * Internal Traversable class
  , GTraversable'(..)

  ) where

import           Control.Applicative (Const, WrappedMonad(..), ZipList)
#if !(MIN_VERSION_base(4,8,0))
import           Control.Applicative (Applicative(..), (<$>))
#endif

import qualified Data.Monoid as Monoid (First, Last, Product, Sum)
import           Data.Monoid (Dual)

import           Generics.Deriving.Base
import           Generics.Deriving.Foldable
import           Generics.Deriving.Functor

#if MIN_VERSION_base(4,4,0)
import           Data.Complex (Complex)
#endif

#if MIN_VERSION_base(4,6,0)
import           Data.Ord (Down)
#else
import           GHC.Exts (Down)
#endif

#if MIN_VERSION_base(4,7,0)
import           Data.Proxy (Proxy)
#endif

#if MIN_VERSION_base(4,8,0)
import           Data.Functor.Identity (Identity)
#endif

#if MIN_VERSION_base(4,9,0)
import qualified Data.Functor.Product as Functor (Product)
import qualified Data.Functor.Sum as Functor (Sum)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.Semigroup as Semigroup (First, Last)
import           Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid)
#endif

--------------------------------------------------------------------------------
-- Generic traverse
--------------------------------------------------------------------------------

class GTraversable' t where
  gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b)

instance GTraversable' V1 where
  gtraverse' _ x = pure $ case x of
#if __GLASGOW_HASKELL__ >= 708
                            {}
#else
                            !_ -> error "Void gtraverse"
#endif

instance GTraversable' U1 where
  gtraverse' _ U1 = pure U1

instance GTraversable' Par1 where
  gtraverse' f (Par1 a) = Par1 <$> f a

instance GTraversable' (K1 i c) where
  gtraverse' _ (K1 a) = pure (K1 a)

instance (GTraversable f) => GTraversable' (Rec1 f) where
  gtraverse' f (Rec1 a) = Rec1 <$> gtraverse f a

instance (GTraversable' f) => GTraversable' (M1 i c f) where
  gtraverse' f (M1 a) = M1 <$> gtraverse' f a

instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where
  gtraverse' f (L1 a) = L1 <$> gtraverse' f a
  gtraverse' f (R1 a) = R1 <$> gtraverse' f a

instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where
  gtraverse' f (a :*: b) = (:*:) <$> gtraverse' f a <*> gtraverse' f b

instance (GTraversable f, GTraversable' g) => GTraversable' (f :.: g) where
  gtraverse' f (Comp1 x) = Comp1 <$> gtraverse (gtraverse' f) x

-- instance GTraversable' UAddr where
--   gtraverse' _ (UAddr a) = pure (UAddr a)

-- instance GTraversable' UChar where
--   gtraverse' _ (UChar c) = pure (UChar c)

-- instance GTraversable' UDouble where
--   gtraverse' _ (UDouble d) = pure (UDouble d)

-- instance GTraversable' UFloat where
--   gtraverse' _ (UFloat f) = pure (UFloat f)

-- instance GTraversable' UInt where
--   gtraverse' _ (UInt i) = pure (UInt i)

-- instance GTraversable' UWord where
--   gtraverse' _ (UWord w) = pure (UWord w)

class (GFunctor t, GFoldable t) => GTraversable t where
  gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b)
#if __GLASGOW_HASKELL__ >= 701
  default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)
                    => (a -> f b) -> t a -> f (t b)
  gtraverse = gtraversedefault
#endif

  gsequenceA :: Applicative f => t (f a) -> f (t a)
  gsequenceA = gtraverse id

  gmapM :: Monad m => (a -> m b) -> t a -> m (t b)
  gmapM f = unwrapMonad . gtraverse (WrapMonad . f)

  gsequence :: Monad m => t (m a) -> m (t a)
  gsequence = gmapM id

gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)
                 => (a -> f b) -> t a -> f (t b)
gtraversedefault f x = to1 <$> gtraverse' f (from1 x)

-- Base types instances
instance GTraversable ((,) a) where
  gtraverse = gtraversedefault

instance GTraversable [] where
  gtraverse = gtraversedefault

#if MIN_VERSION_base(4,9,0)
instance GTraversable (Arg a) where
  gtraverse = gtraversedefault
#endif

#if MIN_VERSION_base(4,4,0)
instance GTraversable Complex where
  gtraverse = gtraversedefault
#endif

instance GTraversable (Const m) where
  gtraverse = gtraversedefault

instance GTraversable Down where
  gtraverse = gtraversedefault

instance GTraversable Dual where
  gtraverse = gtraversedefault

instance GTraversable (Either a) where
  gtraverse = gtraversedefault

instance GTraversable Monoid.First where
  gtraverse = gtraversedefault

#if MIN_VERSION_base(4,9,0)
instance GTraversable (Semigroup.First) where
  gtraverse = gtraversedefault
#endif

#if MIN_VERSION_base(4,8,0)
instance GTraversable Identity where
  gtraverse = gtraversedefault
#endif

instance GTraversable Monoid.Last where
  gtraverse = gtraversedefault

#if MIN_VERSION_base(4,9,0)
instance GTraversable Semigroup.Last where
  gtraverse = gtraversedefault

instance GTraversable Max where
  gtraverse = gtraversedefault
#endif

instance GTraversable Maybe where
  gtraverse = gtraversedefault

#if MIN_VERSION_base(4,9,0)
instance GTraversable Min where
  gtraverse = gtraversedefault

instance GTraversable NonEmpty where
  gtraverse = gtraversedefault

instance GTraversable Option where
  gtraverse = gtraversedefault
#endif

instance GTraversable Monoid.Product where
  gtraverse = gtraversedefault

#if MIN_VERSION_base(4,9,0)
instance (GTraversable f, GTraversable g) => GTraversable (Functor.Product f g) where
  gtraverse = gtraversedefault
#endif

#if MIN_VERSION_base(4,7,0)
instance GTraversable Proxy where
  gtraverse = gtraversedefault
#endif

instance GTraversable Monoid.Sum where
  gtraverse = gtraversedefault

#if MIN_VERSION_base(4,9,0)
instance (GTraversable f, GTraversable g) => GTraversable (Functor.Sum f g) where
  gtraverse = gtraversedefault

instance GTraversable WrappedMonoid where
  gtraverse = gtraversedefault
#endif

instance GTraversable ZipList where
  gtraverse = gtraversedefault


{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Plot.Render
-- Copyright   :  (c) A. V. H. McPhail 2010
-- License     :  BSD3
--
-- Maintainer  :  haskell.vivian.mcphail <at> gmail <dot> com
-- Stability   :  provisional
-- Portability :  portable
--
-- Rendering 'Figure's
--
-----------------------------------------------------------------------------

module Graphics.Rendering.Plot.Render (
                                       -- * Rendering
                                       render
                                       -- ** Access to 'FigureState'
                                       , newFigureState
                                       , updateFigureState
                                       , renderFigureState
                                       -- ** Outputting to file
                                       , OutputType(..)
                                       , writeFigure
                                       , writeFigureState
                                       -- * Notes
                                       -- $notes
                                       ) where

-----------------------------------------------------------------------------
{- TODO

    store 'next colour' list in state
-}
-----------------------------------------------------------------------------

--import Data.Either

--import Data.Packed.Vector
--import Numeric.LinearAlgebra.Linear

--import Data.Word

--import Data.Maybe

--import Data.Colour.SRGB
--import Data.Colour.Names

--import qualified Data.Array.IArray as A

import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Pango as P

--import Control.Monad.Reader
--import Control.Monad.State
--import Control.Monad.Trans

import Graphics.Rendering.Plot.Types
import Graphics.Rendering.Plot.Defaults

--import Graphics.Rendering.Plot.Figure.Text

import Graphics.Rendering.Plot.Render.Types
import Graphics.Rendering.Plot.Render.Text
import Graphics.Rendering.Plot.Render.Plot

--import qualified Text.Printf as Printf

--import Prelude hiding(min,max)
--import qualified Prelude(max)

-----------------------------------------------------------------------------

-- | render a 'Figure'
render :: Figure ()    -- ^ the figure to be rendered
       -> (Int,Int)    -- ^ (width,height)
       -> C.Render ()  -- ^ a Cairo operation
render g = (\(w,h) -> do
  pc <- pango $ P.cairoCreateContext Nothing
  to <- pango $ getDefaultTextOptions pc
  let options' = Options defaultLineOptions
                         defaultPointOptions defaultBarOptions to
  let (FigureState options _ figure) =
        execFigure g (FigureState options' defaultSupply emptyFigure)
  evalRender (renderFigure figure) (RenderEnv pc options)
             (BoundingBox 0 0 (fromIntegral w) (fromIntegral h)))

-----------------------------------------------------------------------------

-- | create 'FigureState' from a series of 'Figure' actions
newFigureState :: Figure () -> IO FigureState
newFigureState f = do
  pc <- P.cairoCreateContext Nothing
  to <- getDefaultTextOptions pc
  let options' = Options defaultLineOptions
                         defaultPointOptions defaultBarOptions to
  return $ execFigure f (FigureState options' defaultSupply emptyFigure)

-- | modify a 'FigureState' with some new actions
updateFigureState :: FigureState -> Figure () -> FigureState
updateFigureState s f = execFigure f s

-- | render a 'FigureState'
renderFigureState :: FigureState  -- ^ the figure state
                -> (Int,Int)    -- ^ (width,height)
                -> C.Render ()  -- ^ a Cairo operation
renderFigureState (FigureState options _ figure) = (\(w,h) -> do
  pc <- pango $ P.cairoCreateContext Nothing
  evalRender (renderFigure figure) (RenderEnv pc options)
             (BoundingBox 0 0 (fromIntegral w) (fromIntegral h)))

-----------------------------------------------------------------------------

-- | output the 'Figure'
writeFigure :: OutputType    -- ^ output file type
            -> FilePath      -- ^ file path
            -> (Int,Int)     -- ^ (width,height)
            -> Figure ()     -- ^ the 'Figure' rendering operation
            -> IO ()
writeFigure PNG fn wh f = withImageSurface wh (writeSurfaceToPNG fn (render f wh))
writeFigure PS  fn wh f = writeSurface C.withPSSurface fn wh f
writeFigure PDF fn wh f = writeSurface C.withPDFSurface fn wh f
writeFigure SVG fn wh f = writeSurface C.withSVGSurface fn wh f

withImageSurface :: (Int,Int) -> (C.Surface -> IO ()) -> IO ()
withImageSurface (w,h) = C.withImageSurface C.FormatARGB32 w h

writeSurfaceToPNG :: FilePath -> C.Render () -> C.Surface -> IO ()
writeSurfaceToPNG fn r s = do
  C.renderWith s r
  C.surfaceWriteToPNG s fn

writeSurface :: (FilePath -> Double -> Double -> (C.Surface -> IO ()) -> IO ())
            -> FilePath -> (Int,Int) -> Figure () -> IO ()
writeSurface rw fn (w,h) f = rw fn (fromIntegral w) (fromIntegral h)
                               (flip C.renderWith (render f (w,h)))

-----------------------------------------------------------------------------

-- | output the 'FigureState'
writeFigureState :: OutputType    -- ^ output file type
            -> FilePath      -- ^ file path
            -> (Int,Int)     -- ^ (width,height)
            -> FigureState   -- ^ a FigureState
            -> IO ()
writeFigureState PNG fn wh f = withImageSurface wh
  (writeSurfaceToPNG fn (renderFigureState f wh))
writeFigureState PS  fn wh f = writeSurfaceFS C.withPSSurface fn wh f
writeFigureState PDF fn wh f = writeSurfaceFS C.withPDFSurface fn wh f
writeFigureState SVG fn wh f = writeSurfaceFS C.withSVGSurface fn wh f

writeSurfaceFS :: (FilePath -> Double -> Double -> (C.Surface -> IO ()) -> IO ())
            -> FilePath -> (Int,Int) -> FigureState -> IO ()
writeSurfaceFS rw fn (w,h) f = rw fn (fromIntegral w) (fromIntegral h)
                                (flip C.renderWith (renderFigureState f (w,h)))

-----------------------------------------------------------------------------

renderFigure :: FigureData -> Render ()
renderFigure (Figure b p t s d) = do
  cairo $ do
    C.save
    setColour b
    C.paint
    C.restore

  applyPads p

  tx <- bbCentreWidth
  ty <- bbTopHeight
  (_,th) <- renderText t Centre TTop tx ty
  bbLowerTop (th+textPad)

  sx <- bbCentreWidth
  sy <- bbTopHeight
  (_,sh) <- renderText s Centre TTop sx sy
  bbLowerTop (sh+textPad)

  renderPlots d

-----------------------------------------------------------------------------