module Test.StrictCheck.Consume
  ( Input
  , Inputs
  , Consume(..)
  , constructor
  , normalize
  , consumeTrivial
  , consumePrimitive
  ) where

import Test.QuickCheck
import Generics.SOP
import Generics.SOP.NS

import Test.StrictCheck.Internal.Inputs

import Data.Monoid    as Monoid
import Data.Semigroup as Semigroup
import Control.Applicative
import Control.Monad.State
import Control.Monad.Cont
import Control.Monad.Except
import Control.Monad.Identity
import Control.Monad.RWS
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.ST
import GHC.Conc
import Data.Functor.Product as Functor
import Data.Functor.Sum     as Functor
import Data.Functor.Compose as Functor
import Data.Complex

import Data.Foldable as Fold
import Data.List.NonEmpty (NonEmpty(..))
import Data.Tree     as Tree
import Data.Set      as Set
import Data.Map      as Map
import Data.Sequence as Seq
import Data.IntMap   as IntMap
import Data.IntSet   as IntSet

-------------------------------------------------------
-- The user interface for creating Consume instances --
-------------------------------------------------------

-- | Generate a tree of all possible ways to destruct the input value.
class Consume a where
  consume :: a -> Input
  default consume :: GConsume a => a -> Input
  consume = gConsume

-- | Reassemble pieces of input into a larger Input.
constructor :: Int -> [Input] -> Input
constructor n !is =
  Input (Variant (variant n)) is

-- | Use the CoArbitrary instance for a type to consume it. This should only be
-- used for "flat" types, i.e. those which contain no interesting substructure.
consumePrimitive :: CoArbitrary a => a -> Input
consumePrimitive !a =
  Input (Variant (coarbitrary a)) []

-- | If a type has no observable properties or substructure which can be used
-- to drive the randomization of output, consumption should merely evaluate a
-- value to weak-head normal form.
consumeTrivial :: a -> Input
consumeTrivial !_ =
  Input mempty []

-- | Fully normalize something which can be consumed
normalize :: Consume a => a -> ()
normalize (consume -> input) = go input
  where
    go (Input _ is) = Fold.foldr seq () (fmap go is)

--------------------------------------------
-- Deriving Consume instances generically --
--------------------------------------------

type GConsume a = (Generic a, All2 Consume (Code a))

gConsume :: GConsume a => a -> Input
gConsume !(from -> sop) =
  constructor (index_SOP sop)
  . hcollapse
  . hcliftA (Proxy :: Proxy Consume) (K . consume . unI)
  $ sop

---------------
-- Instances --
---------------

instance Consume (IO a)    where consume = consumeTrivial
instance Consume (STM a)   where consume = consumeTrivial
instance Consume (ST s a)  where consume = consumeTrivial
instance Consume (a -> b)  where consume = consumeTrivial
instance Consume (Proxy p) where consume = consumeTrivial

instance Consume Char     where consume = consumePrimitive
instance Consume Word     where consume = consumePrimitive
instance Consume Int      where consume = consumePrimitive
instance Consume Double   where consume = consumePrimitive
instance Consume Float    where consume = consumePrimitive
instance Consume Rational where consume = consumePrimitive
instance Consume Integer  where consume = consumePrimitive
instance (CoArbitrary a, RealFloat a) => Consume (Complex a) where
  consume = consumePrimitive

deriving newtype instance Consume a => Consume (Identity a)
deriving newtype instance Consume (RWST r w s m a)
deriving newtype instance Consume (ReaderT r m a)
deriving newtype instance Consume (StateT s m a)
deriving newtype instance Consume (m (a, w)) => Consume (WriterT w m a)
deriving newtype instance Consume (ContT r m a)
deriving newtype instance Consume (m (Either e a)) => Consume (ExceptT e m a)
deriving newtype instance Consume a => Consume (ZipList a)
deriving newtype instance Consume a => Consume (Monoid.First a)
deriving newtype instance Consume a => Consume (Monoid.Last a)
deriving newtype instance Consume a => Consume (Semigroup.First a)
deriving newtype instance Consume a => Consume (Semigroup.Last a)
deriving newtype instance Consume a => Consume (Min a)
deriving newtype instance Consume a => Consume (Max a)
deriving newtype instance Consume a => Consume (Monoid.Sum a)
deriving newtype instance Consume a => Consume (Monoid.Product a)
deriving newtype instance Consume (f (g a)) => Consume (Functor.Compose f g a)
deriving newtype instance Consume a => Consume (Dual a)
deriving newtype instance Consume a => Consume (Const a b)

instance Consume ()
instance Consume Bool
instance Consume Ordering
instance Consume a => Consume (Maybe a)
instance (Consume a, Consume b) => Consume (Either a b)
instance Consume a => Consume [a]

deriving newtype instance Consume a => Consume (I a)
deriving newtype instance Consume a => Consume (K a b)
-- TODO: instances for the rest of the SOP newtypes

instance (Consume (f a), Consume (g a)) => Consume (Functor.Sum f g a) where
  consume (InL a) = constructor 0 [consume a]
  consume (InR b) = constructor 1 [consume b]

instance (Consume (f a), Consume (g a)) => Consume (Functor.Product f g a) where
  consume (Pair a b) = constructor 0 [consume a, consume b]

instance (Consume a, Consume b) => Consume (Semigroup.Arg a b) where
  consume (Arg a b) = constructor 0 [consume a, consume b]

instance Consume a => Consume (NonEmpty a) where
  consume (a :| as) = constructor 0 [consume a, consume as]

instance Consume a => Consume (Tree a) where
  consume (Node a as) = constructor 0 [consume a, consume as]

instance Consume v => Consume (Map k v) where
  consume = constructor 0 . fmap (consume . snd) . Map.toList

consumeContainer :: (Consume a, Foldable t) => t a -> Input
consumeContainer = constructor 0 . fmap consume . Fold.toList

instance Consume v => Consume (Seq v)    where consume = consumeContainer
instance Consume v => Consume (Set v)    where consume = consumeContainer
instance Consume v => Consume (IntMap v) where consume = consumeContainer
instance Consume v => Consume IntSet where
  consume = consumeContainer . IntSet.toList

-- TODO: instances for the rest of Containers

instance (Consume a, Consume b) => Consume (a, b)
instance (Consume a, Consume b, Consume c) => Consume (a, b, c)
instance (Consume a, Consume b, Consume c, Consume d) => Consume (a, b, c, d)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e
         ) => Consume
  (a, b, c, d, e)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         ) => Consume
  (a, b, c, d, e, f)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g
         ) => Consume
  (a, b, c, d, e, f, g)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h
         ) => Consume
  (a, b, c, d, e, f, g, h)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i
         ) => Consume
  (a, b, c, d, e, f, g, h, i)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n, Consume o
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n, Consume o, Consume p
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n, Consume o, Consume p, Consume q
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r
         , Consume s
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r
         , Consume s, Consume t
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r
         , Consume s, Consume t, Consume u
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r
         , Consume s, Consume t, Consume u, Consume v
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r
         , Consume s, Consume t, Consume u, Consume v, Consume w
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r
         , Consume s, Consume t, Consume u, Consume v, Consume w, Consume x
          ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r
         , Consume s, Consume t, Consume u, Consume v, Consume w, Consume x
         , Consume y
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y)
instance ( Consume a, Consume b, Consume c, Consume d, Consume e, Consume f
         , Consume g, Consume h, Consume i, Consume j, Consume k, Consume l
         , Consume m, Consume n, Consume o, Consume p, Consume q, Consume r
         , Consume s, Consume t, Consume u, Consume v, Consume w, Consume x
         , Consume y, Consume z
         ) => Consume
  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z)


{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Tests for the flat module
module Main where

import           Control.Monad
import           Data.Bits
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Short as SBS
import           Data.Char
import           Data.Either
import           Flat
import           Flat.Bits
import           Flat.Decoder
import qualified Flat.Encoder as E
import qualified Flat.Encoder.Prim as E
import qualified Flat.Encoder.Strict as E
import           Data.Int
import           Data.Proxy
import qualified Data.Sequence as Seq
import           Data.String (fromString)
import qualified Data.Text as T
import           Data.Word
import           Numeric.Natural
import           System.Exit
import           Test.Data
import           Test.Data.Arbitrary ()
import           Test.Data.Flat
import           Test.Data.Values hiding (lbs, ns)
import           Test.E
import           Test.E.Arbitrary ()
import           Test.E.Flat
import           Test.Tasty
import           Test.Tasty.HUnit
import           Test.Tasty.QuickCheck as QC hiding (getSize)
import           Flat.Endian
import           Data.FloatCast
import           Data.Text.Arbitrary
-- import Test.QuickCheck.Arbitrary
import qualified Data.Complex as B
import qualified Data.Ratio as B
import qualified Data.Map as C
import qualified Data.Map.Strict as CS
import qualified Data.Map.Lazy as CL
import qualified Data.IntMap.Strict as CS
import qualified Data.IntMap.Lazy as CL
-- import           Data.List
-- import           Data.Ord
#if MIN_VERSION_base(4,9,0)
import qualified Data.List.NonEmpty as BI
#endif

instance Arbitrary UTF8Text where
  arbitrary = UTF8Text <$> arbitrary

  shrink t = UTF8Text <$> shrink (unUTF8 t)

#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)
instance Arbitrary UTF16Text where
  arbitrary = UTF16Text <$> arbitrary

  shrink t = UTF16Text <$> shrink (unUTF16 t)
#endif

-- instance Flat [Int16]
-- instance Flat [Word8]
-- instance Flat [Bool]
main = do
  -- #ifdef ghcjs_HOST_OS
  --   print "GHCJS"
  -- #endif
  -- printInfo
  -- print $ flat asciiStrT
  mainTest

  -- print $ flatRaw 18446744073709551615::Word64
  -- print $ B.unpack . flat $ (True,0::Word64,18446744073709551615::Word64)
  -- print (2^56::Word64,fromIntegral (1::Word8) `shiftL` 56 :: Word64,(18446744073709551615::Word64) `shiftR` 1)
  -- mainShow
  -- eWord64E id 0b
mainShow = do
  mapM_ (\_ -> generate (arbitrary :: Gen Int) >>= print) [1 .. 10]
  exitFailure

mainTest = defaultMain tests

tests :: TestTree
tests = testGroup "Tests" [testPrimitives, testEncDec, testFlat]

testPrimitives =
  testGroup "conversion/memory primitives" [testEndian, testFloatingConvert]

  --,testShifts -- ghcjs fails this
testEncDec = testGroup
  "encode/decode primitives"
  [ testEncodingPrim
  , testDecodingPrim
#ifdef TEST_DECBITS
  , testDecBits
#endif
  ]

testFlat = testGroup
  "flat/unflat"
  [testSize, testLargeEnum, testContainers, flatUnflatRT, flatTests]

-- Flat.Endian tests (to run, need to modify imports and cabal file)
testEndian = testGroup
  "Endian"
  [ convBE toBE16 (2 ^ 10 + 3) (2 ^ 9 + 2 ^ 8 + 4)
  , convBE toBE32 (2 ^ 18 + 3) 50332672
  , convBE toBE64 (2 ^ 34 + 3) 216172782180892672
  , convBE toBE16 0x1234 0x3412
  , convBE toBE32 0x11223344 0x44332211
  , convBE toBE64 0x0123456789ABCDEF 0xEFCDAB8967452301]

testFloatingConvert = testGroup
  "Floating conversions"
  [ conv floatToWord (-0.15625) 3189768192
  , conv wordToFloat 3189768192 (-0.15625)
  , conv doubleToWord (-0.15625) 13818169556679524352
  , conv wordToDouble 13818169556679524352 (-0.15625)
  , rt "floatToWord" (prop_float_conv :: RT Float)
  , rt "doubleToWord" (prop_double_conv :: RT Double)]

convBE f v littleEndianE =
  let e = if isBigEndian
          then v
          else littleEndianE
  in testCase (unwords ["conv BigEndian", sshow v, "to", sshow e]) $ f v @?= e

conv f v e = testCase
  (unwords ["conv", sshow v, showB . flat $ v, "to", sshow e])
  $ f v @?= e

-- ghcjs bug on shiftR 0, see: https://github.com/ghcjs/ghcjs/issues/706
testShifts = testGroup "Shifts" $ map tst [0 .. 33]
  where
    tst n = testCase ("shiftR " ++ show n)
      $ let val = 4294967295 :: Word32
            s = val `shift` (-n)
            r = val `shiftR` n
        in r @?= s

-- shR = shiftR
-- shR = unsafeShiftR
shR val 0 = val
shR val n = shift val (-n)

testEncodingPrim = testGroup
  "Encoding Primitives"
  [ encRawWith 1 E.eTrueF [0b10000001]
  , encRawWith 3 (E.eTrueF >=> E.eFalseF >=> E.eTrueF) [0b10100001]
    -- Depends on endianess
    --,encRawWith 32 (E.eWord32E id $ 2^18 + 3) [3,0,4,0,1]
    -- ,encRawWith 64 (E.eWord64E id $ 0x1122334455667788) [0x88,0x77,0x66,0x55,0x44,0x33,0x22,0x11,1]
    --,encRawWith 65 (E.eTrueF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,128,129]
    --,encRawWith 65 (E.eFalseF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,0,129]
    -- Big Endian
  , encRawWith 32 (E.eWord32BEF $ 2 ^ 18 + 3) [0, 4, 0, 3, 1]
  , encRawWith 64 (E.eWord64BEF $ 2 ^ 34 + 3) [0, 0, 0, 4, 0, 0, 0, 3, 1]
  , encRawWith
      65
      (E.eTrueF >=> E.eWord64BEF (2 ^ 34 + 3))
      [128, 0, 0, 2, 0, 0, 0, 1, 129]
  , encRawWith
      65
      (E.eFalseF >=> E.eWord64BEF (2 ^ 34 + 3))
      [0, 0, 0, 2, 0, 0, 0, 1, 129]]
  where
    encRawWith sz enc exp = testCase
      (unwords ["encode raw with size", show sz])
      $ flatRawWith sz enc @?= exp

testDecodingPrim = testGroup
  "Decoding Primitives"
  [ dec
      ((,,,) <$> dropBits 13 <*> dBool <*> dBool <*> dBool)
      [0b10111110, 0b10011010]
      ((), False, True, False)
  , dec
      ((,,,) <$> dropBits 1 <*> dBE16 <*> dBool <*> dropBits 6)
      [0b11000000, 0b00000001, 0b01000000]
      ((), 2 ^ 15 + 2, True, ())
  , dec
      ((,,,) <$> dropBits 1 <*> dBE32 <*> dBool <*> dropBits 6)
      [0b11000000, 0b00000000, 0b00000000, 0b00000001, 0b01000000]
      ((), 2 ^ 31 + 2, True, ())
  , dec
      dBE64
      [ 0b10000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000010]
      (2 ^ 63 + 2)
  , dec
      ((,,,) <$> dropBits 1 <*> dBE64 <*> dBool <*> dropBits 6)
      [ 0b11000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000001
      , 0b01000000]
      ((), 2 ^ 63 + 2, True, ())]
  where
    dec decOp v e = testCase (unwords ["decode", sshow v])
      $ unflatRawWith decOp (B.pack v) @?= Right e

testDecBits = testGroup "Decode Bits"
  $ concat
    [ decBitsN dBEBits8
    , decBitsN dBEBits16
    , decBitsN dBEBits32
    , decBitsN dBEBits64]
-- Test dBEBits8/16/32/64, extraction of up to 8/16/32/bits from various positions
  where
    decBitsN :: forall a.
             (Num a, FiniteBits a, Show a, Flat a)
             => (Int -> Get a)
             -> [TestTree]
    decBitsN dec = let s = finiteBitSize (undefined :: a)
                   in [decBits_ dec val numBitsToTake pre
                      | numBitsToTake <- [0 .. s]
                      , val <- [ 0 :: a
                               , 1 + 2 ^ (s - 2) + 2 ^ (s - 5)
                               , fromIntegral $ (2 ^ s :: Integer) - 1]
                      , pre <- [0, 1, 7]]

    decBits_ :: forall a.
             (FiniteBits a, Show a, Flat a)
             => (Int -> Get a)
             -> a
             -> Int
             -> Int
             -> TestTree
    decBits_ deco val numBitsToTake pre =
      -- a sequence composed by pre zero bits followed by the val and zero bits till the next byte boundary
      let vs = B.pack . asBytes . fromBools
            $ replicate pre False ++ toBools (asBits val)
          len = B.length vs
          sz = finiteBitSize (undefined :: a)
          dec :: Get a
          dec = do
            dropBits pre
            r <- deco numBitsToTake
            dropBits (len * 8 - numBitsToTake - pre)
            return r
          -- we expect the first numBitsToTake bits of the value
          expectedD @ (Right expected) :: Decoded a = Right
            $ val `shR` (sz - numBitsToTake) -- ghcjs: shiftR fails, see: https://github.com/ghcjs/ghcjs/issues/706
          actualD @ (Right actual) :: Decoded a = unflatRawWith dec vs
      in testCase
           (unwords
              [ "take"
              , show numBitsToTake
              , "bits from"
              , show val
              , "of size"
              , show sz
              , "with prefix"
              , show pre
              , "sequence"
              , showB vs
              , show expected
              , show actual
              , show $ val == actual
              , show $ expected == actual
              , show $ expected /= actual
              , show $ show expected == show actual
              , show $ flat expected == flat actual])
         $ actualD @?= expectedD

testSize = testGroup "Size"
  $ concat
    [ sz () 0
    , sz True 1
    , sz One 2
    , sz Two 2
    , sz Three 2
    , sz Four 3
    , sz Five 3
    , sz 'a' 8
    , sz 'à' 16
    , sz '经' 24
    , sz (0 :: Word8) 8
    , sz (1 :: Word8) 8
    , concatMap (uncurry sz) ns
    , concatMap (uncurry sz) nsI
    , concatMap (uncurry sz) nsII
    , sz (1.1 :: Float) 32
    , sz (1.1 :: Double) 64
    , sz "" 1
    , sz "abc" (4 + 3 * 8)
    , sz ((), (), Unit) 0
    , sz (True, False, One, Five) 7
    , sz map1 7
    , sz bs (4 + 3 * 8)
    , sz stBS bsSize
    , sz lzBS bsSize
#ifndef ghcjs_HOST_OS
    , sz shBS bsSize
#endif
    , sz tx utf8Size
    , sz (UTF8Text tx) utf8Size
#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)
    , sz (UTF16Text tx) utf16Size
#endif
    ]
  where
    tx = T.pack "txt"

    utf8Size = 8 + 8 + 3 * 32 + 8

    utf16Size = 8 + 8 + 3 * 16 + 8

    bsSize = 8 + 8 + 3 * 8 + 8

sz v e = [testCase (unwords ["size of", sshow v]) $ getSize v @?= e]

-- E258_256 = 11111110 _257 = 111111110 _258 = 111111111
testLargeEnum = testGroup "test enum with more than 256 constructors"
  $ concat
    [
#ifdef ENUM_LARGE
      sz E258_256 8
    , sz E258_257 9
    , sz E258_258 9
      -- As encodes are inlined, this is going to take for ever if this is compiled with -O1 or -O2
      -- , encRaw (E258_256) [0b11111110]
      -- , encRaw (E258_257) [0b11111111,0b00000000]
      -- , encRaw (E258_258) [0b11111111,0b10000000]
      -- , encRaw (E258_256,E258_257,E258_258) [0b11111110,0b11111111,0b01111111,0b11000000]
    , map trip [E258_1, E258_256, E258_257, E258_258]
    , map trip [E256_1, E256_134, E256_256]
#endif
    ]

testContainers =
  testGroup "containers" [trip longSeq, trip dataMap, trip listMap]

    -- , trip intMap
flatUnflatRT = testGroup
  "unflat (flat v) == v"
  [ rt "()" (prop_Flat_roundtrip :: RT ())
  , rt "Bool" (prop_Flat_roundtrip :: RT Bool)
  , rt "Char" (prop_Flat_roundtrip :: RT Char)
  , rt "Complex" (prop_Flat_roundtrip :: RT (B.Complex Float))
  , rt "Either N Bool" (prop_Flat_roundtrip :: RT (Either N Bool))
  , rt "Either Int Char" (prop_Flat_roundtrip :: RT (Either Int Char))
  , rt "Int8" (prop_Flat_Large_roundtrip :: RTL Int8)
  , rt "Int16" (prop_Flat_Large_roundtrip :: RTL Int16)
  , rt "Int32" (prop_Flat_Large_roundtrip :: RTL Int32)
  , rt "Int64" (prop_Flat_Large_roundtrip :: RTL Int64)
  , rt "Int" (prop_Flat_Large_roundtrip :: RTL Int)
  , rt "[Int16]" (prop_Flat_roundtrip :: RT [Int16])
  , rt "String" (prop_Flat_roundtrip :: RT String)
#if MIN_VERSION_base(4,9,0)
  , rt "NonEmpty" (prop_Flat_roundtrip :: RT (BI.NonEmpty Bool))
#endif
  , rt "Maybe N" (prop_Flat_roundtrip :: RT (Maybe N))
  , rt "Ratio" (prop_Flat_roundtrip :: RT (B.Ratio Int32))
  , rt "Word8" (prop_Flat_Large_roundtrip :: RTL Word8)
  , rt "Word16" (prop_Flat_Large_roundtrip :: RTL Word16)
  , rt "Word32" (prop_Flat_Large_roundtrip :: RTL Word32)
  , rt "Word64" (prop_Flat_Large_roundtrip :: RTL Word64)
  , rt "Word" (prop_Flat_Large_roundtrip :: RTL Word)
  , rt "Natural" (prop_Flat_roundtrip :: RT Natural)
  , rt "Integer" (prop_Flat_roundtrip :: RT Integer)
  , rt "Float" (prop_Flat_roundtrip :: RT Float)
  , rt "Double" (prop_Flat_roundtrip :: RT Double)
  , rt "Text" (prop_Flat_roundtrip :: RT T.Text)
  , rt "UTF8 Text" (prop_Flat_roundtrip :: RT UTF8Text)
#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)
  , rt "UTF16 Text" (prop_Flat_roundtrip :: RT UTF16Text)
#endif
  , rt "ByteString" (prop_Flat_roundtrip :: RT B.ByteString)
  , rt "Lazy ByteString" (prop_Flat_roundtrip :: RT L.ByteString)
#ifndef ghcjs_HOST_OS
  , rt "Short ByteString" (prop_Flat_roundtrip :: RT SBS.ShortByteString)
#endif
  , rt "Map.Strict" (prop_Flat_roundtrip :: RT (CS.Map Int Bool))
  , rt "Map.Lazy" (prop_Flat_roundtrip :: RT (CL.Map Int Bool))
  , rt "IntMap.Strict" (prop_Flat_roundtrip :: RT (CS.IntMap Bool))
  , rt "IntMap.Lazy" (prop_Flat_roundtrip :: RT (CL.IntMap Bool))
  , rt "Unit" (prop_Flat_roundtrip :: RT Unit)
  , rt "Un" (prop_Flat_roundtrip :: RT Un)
  , rt "N" (prop_Flat_roundtrip :: RT N)
  , rt "E2" (prop_Flat_roundtrip :: RT E2)
  , rt "E3" (prop_Flat_roundtrip :: RT E3)
  , rt "E4" (prop_Flat_roundtrip :: RT E4)
  , rt "E8" (prop_Flat_roundtrip :: RT E8)
  , rt "E16" (prop_Flat_roundtrip :: RT E16)
  , rt "E17" (prop_Flat_roundtrip :: RT E17)
  , rt "E32" (prop_Flat_roundtrip :: RT E32)
  , rt "A" (prop_Flat_roundtrip :: RT A)
  , rt "B" (prop_Flat_roundtrip :: RT B)
    -- ,rt "Tree Bool" (prop_Flat_roundtrip:: RT (Tree Bool))
    -- ,rt "Tree N" (prop_Flat_roundtrip:: RT (Tree N))
  , rt "List N" (prop_Flat_roundtrip :: RT (List N))]

rt n = QC.testProperty (unwords ["round trip", n])

flatTests = testGroup "flat/unflat Unit tests"
  $ concat
    [ -- Expected errors
      errDec (Proxy :: Proxy Bool) [] -- no data
    , errDec (Proxy :: Proxy Bool) [128] -- no filler
    , errDec (Proxy :: Proxy Bool) [128 + 1, 1, 2, 4, 8] -- additional bytes
    , errDec (Proxy :: Proxy Text) (B.unpack (flat ((fromString "\x80") :: B.ByteString))) -- invalid UTF-8
    , encRaw () []
    , encRaw ((), (), Unit) []
    , encRaw (Unit, 'a', Unit, 'a', Unit, 'a', Unit) [97, 97, 97]
    , a () [1]
    , a True [128 + 1]
    , a (True, True) [128 + 64 + 1]
    , a (True, False, True) [128 + 32 + 1]
    , a (True, False, True, True) [128 + 32 + 16 + 1]
    , a (True, False, True, True, True) [128 + 32 + 16 + 8 + 1]
    , a (True, False, True, True, True, True) [128 + 32 + 16 + 8 + 4 + 1]
    , a
        (True, False, True, True, True, True, True)
        [128 + 32 + 16 + 8 + 4 + 2 + 1]
    , a
        (True, False, True, True, (True, True, True, True))
        [128 + 32 + 16 + 8 + 4 + 2 + 1, 1]
    , encRaw (True, False, True, True) [128 + 32 + 16]
    , encRaw
        ( (True, True, False, True, False)
        , (False, False, True, False, True, True))
        [128 + 64 + 16 + 1, 64 + 32]
    , encRaw ('\0', '\1', '\127') [0, 1, 127]
    , encRaw (33 :: Word32, 44 :: Word32) [33, 44]
       --,s (Elem True) [64]
       --,s (NECons True (NECons False (Elem True))) [128+64+32+4]
    , encRaw (0 :: Word8) [0]
    , encRaw (1 :: Word8) [1]
    , encRaw (255 :: Word8) [255]
    , encRaw (0 :: Word16) [0]
    , encRaw (1 :: Word16) [1]
    , encRaw (255 :: Word16) [255, 1]
    , encRaw (256 :: Word16) [128, 2]
    , encRaw (65535 :: Word16) [255, 255, 3]
    , encRaw (127 :: Word32) [127]
    , encRaw (128 :: Word32) [128, 1]
    , encRaw (129 :: Word32) [129, 1]
    , encRaw (255 :: Word32) [255, 1]
    , encRaw (16383 :: Word32) [255, 127]
    , encRaw (16384 :: Word32) [128, 128, 1]
    , encRaw (16385 :: Word32) [129, 128, 1]
    , encRaw (32767 :: Word32) [255, 255, 1]
    , encRaw (32768 :: Word32) [128, 128, 2]
    , encRaw (32769 :: Word32) [129, 128, 2]
    , encRaw (65535 :: Word32) [255, 255, 3]
    , encRaw (2097151 :: Word32) [255, 255, 127]
    , encRaw (2097152 :: Word32) [128, 128, 128, 1]
    , encRaw (2097153 :: Word32) [129, 128, 128, 1]
    , encRaw (4294967295 :: Word32) [255, 255, 255, 255, 15]
    , encRaw (255 :: Word64) [255, 1]
    , encRaw (65535 :: Word64) [255, 255, 3]
    , encRaw (4294967295 :: Word64) [255, 255, 255, 255, 15]
    , encRaw
        (18446744073709551615 :: Word64)
        [255, 255, 255, 255, 255, 255, 255, 255, 255, 1]
    , encRaw
        (False, 18446744073709551615 :: Word64)
        [127, 255, 255, 255, 255, 255, 255, 255, 255, 128, 128]
    , encRaw (255 :: Word) [255, 1]
    , encRaw (65535 :: Word) [255, 255, 3]
    , encRaw (4294967295 :: Word) [255, 255, 255, 255, 15]
    , tstI [0 :: Int8, 2, -2]
    , encRaw (127 :: Int8) [254]
    , encRaw (-128 :: Int8) [255]
    , tstI [0 :: Int16, 2, -2, 127, -128]
    , tstI [0 :: Int32, 2, -2, 127, -128]
    , tstI [0 :: Int64, 2, -2, 127, -128]
    , encRaw (-1024 :: Int64) [255, 15]
    , encRaw (maxBound :: Word8) [255]
    , encRaw (True, maxBound :: Word8) [255, 128]
    , encRaw (maxBound :: Word16) [255, 255, 3]
    , encRaw (True, maxBound :: Word16) [255, 255, 129, 128]
    , encRaw (maxBound :: Word32) [255, 255, 255, 255, 15]
    , encRaw (True, maxBound :: Word32) [255, 255, 255, 255, 135, 128]
    , encRaw
        (maxBound :: Word64)
        [255, 255, 255, 255, 255, 255, 255, 255, 255, 1]
    , encRaw
        (True, maxBound :: Word64)
        [255, 255, 255, 255, 255, 255, 255, 255, 255, 128, 128]
    , encRaw
        (minBound :: Int64)
        [255, 255, 255, 255, 255, 255, 255, 255, 255, 1]
    , encRaw
        (maxBound :: Int64)
        [254, 255, 255, 255, 255, 255, 255, 255, 255, 1]
    , tstI [0 :: Int, 2, -2, 127, -128]
    , tstI [0 :: Integer, 2, -2, 127, -128, -256, -512]
    , encRaw (-1024 :: Integer) [255, 15]
    , encRaw (0 :: Float) [0, 0, 0, 0]
    , encRaw (-2 :: Float) [0b11000000, 0, 0, 0]
    , encRaw (0.085 :: Float) [0b00111101, 0b10101110, 0b00010100, 0b01111011]
    , encRaw (0 :: Double) [0, 0, 0, 0, 0, 0, 0, 0]
    , encRaw (-2 :: Double) [0b11000000, 0, 0, 0, 0, 0, 0, 0]
    , encRaw (23 :: Double) [0b01000000, 0b00110111, 0, 0, 0, 0, 0, 0]
    , encRaw (-0.15625 :: Float) [0b10111110, 0b00100000, 0, 0]
    , encRaw (-0.15625 :: Double) [0b10111111, 0b11000100, 0, 0, 0, 0, 0, 0]
    , encRaw
        (-123.2325E-23 :: Double)
        [ 0b10111011
        , 0b10010111
        , 0b01000111
        , 0b00101000
        , 0b01110101
        , 0b01111011
        , 0b01000111
        , 0b10111010]
    , encRaw (Left True :: Either Bool (Double, Double)) [0b01000000]
    , encRaw (-2.1234E15 :: Double) [195, 30, 44, 226, 90, 221, 64, 0]
    , encRaw (1.1234E-22 :: Double) [59, 96, 249, 241, 120, 219, 249, 174]
    , encRaw
        ((False, -2.1234E15) :: (Bool, Double))
        [97, 143, 22, 113, 45, 110, 160, 0, 0]
    , encRaw
        ((True, -2.1234E15) :: (Bool, Double))
        [225, 143, 22, 113, 45, 110, 160, 0, 0]
    , encRaw ((-2.1234E15, 1.1234E-22) :: (Double, Double))
        $ [0b11000011, 30, 44, 226, 90, 221, 64, 0]
        ++ [59, 96, 249, 241, 120, 219, 249, 174]
    , encRaw
        ((True, -2.1234E15, 1.1234E-22) :: (Bool, Double, Double))
        [ 0b11100001
        , 143
        , 22
        , 113
        , 45
        , 110
        , 160
        , 0
        , 29
        , 176
        , 124
        , 248
        , 188
        , 109
        , 252
        , 215
        , 0]
    , encRaw
        (Right (-2.1234E15, 1.1234E-22) :: Either Bool (Double, Double))
        [ 0b11100001
        , 143
        , 22
        , 113
        , 45
        , 110
        , 160
        , 0
        , 29
        , 176
        , 124
        , 248
        , 188
        , 109
        , 252
        , 215
        , 0]
    , encRaw (Left True :: Either Bool Direction) [0b01000000]
    , encRaw (Right West :: Either Bool Direction) [0b11110000]
    , map trip [minBound, maxBound :: Word8]
    , map trip [minBound, maxBound :: Word16]
    , map trip [minBound, maxBound :: Word32]
    , map trip [minBound, maxBound :: Word64]
    , map trip [minBound :: Int8, maxBound :: Int8]
    , map trip [minBound :: Int16, maxBound :: Int16]
    , map trip [minBound :: Int32, maxBound :: Int32]
    , map trip [minBound :: Int64, maxBound :: Int64]
    , map tripShow [0 :: Float, -0 :: Float, 0 / 0 :: Float, 1 / 0 :: Float]
    , map
        tripShow
        [0 :: Double, -0 :: Double, 0 / 0 :: Double, 1 / 0 :: Double]
    , encRaw '\0' [0]
    , encRaw '\1' [1]
    , encRaw '\127' [127]
    , encRaw 'a' [97]
    , encRaw 'à' [224, 1]
    , encRaw '经' [207, 253, 1]
    , [trip [chr 0x10FFFF]]
    , encRaw Unit []
    , encRaw (Un False) [0]
    , encRaw (One, Two, Three) [16 + 8]
    , encRaw (Five, Five, Five) [255, 128]
       --,s (NECons True (Elem True)) [128+64+16]
    , encRaw "" [0]
#ifdef LIST_BIT
    , encRaw "abc" [176, 216, 172, 96]
    , encRaw [False, True, False, True] [128 + 32 + 16 + 8 + 2 + 1, 0]
#elif defined(LIST_BYTE)
    , s "abc" s3
    , s (cs 600) s600
#endif
       -- Aligned structures
       --,s (T.pack "") [1,0]
       --,s (Just $ T.pack "abc") [128+1,3,97,98,99,0]
       --,s (T.pack "abc") (al s3)
       --,s (T.pack $ cs 600) (al s600)
    , encRaw map1 [0b10111000]
    , encRaw (B.pack $ csb 3) (bsl c3)
    , encRaw (B.pack $ csb 600) (bsl s600)
    , encRaw (L.pack $ csb 3) (bsl c3)
      -- Long LazyStrings can have internal sections shorter than 255
      --,s (L.pack $ csb 600) (bsl s600)
    , [trip [1 .. 100 :: Int16]]
      -- See https://github.com/typelead/eta/issues/901
#ifndef ETA_VERSION
    , [trip longAsciiStrT]
    , [trip longBoolListT]
#endif
    , [trip asciiTextT]
    , [trip english]
    , [trip "维护和平正"]
    , [trip (T.pack "abc")]
    , [trip unicodeText]
    , [trip unicodeTextUTF8T]
    , [trip longBS, trip longLBS]
#ifndef ghcjs_HOST_OS
    , [trip longSBS]
#endif
#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)
    , [trip unicodeTextUTF16T]
#endif
    ]
--al = (1:) -- prealign
  where
    bsl = id -- noalign

    tstI = map ti

    ti v
      | v >= 0 = testCase (unwords ["Int", show v])
        $ teq v (2 * fromIntegral v :: Word64)
      | otherwise = testCase (unwords ["Int", show v])
        $ teq v (2 * fromIntegral (-v) - 1 :: Word64)

    teq a b = ser a @?= ser b

            --,testCase (unwords ["unflat raw",sshow v]) $ desRaw e @?= Right v]
    -- Aligned values unflat to the original value, modulo the added filler.
    a v e = [ testCase (unwords ["flat", sshow v]) $ ser v @?= e
            , testCase (unwords ["unflat", sshow v])
                $ let Right v' = des e
                  in v @?= v']

      -- a v e = [testCase (unwords ["flat postAligned",show v]) $ ser (postAligned v) @?= e
      --         ,testCase (unwords ["unflat postAligned",show v]) $ let Right (PostAligned v' _) = des e in v @?= v']
encRaw :: forall a. (Show a, Flat a) => a -> [Word8] -> [TestTree]
encRaw v e =
  [ testCase (unwords ["flat raw", sshow v, show . B.unpack . flat $ v])
      $ serRaw v @?= e]

trip :: forall a. (Show a, Flat a, Eq a) => a -> TestTree
trip v = testCase (unwords ["roundtrip", sshow v])
  $
  -- direct comparison
  (unflat (flat v :: B.ByteString) :: Decoded a) @?= (Right v :: Decoded a)

tripShow :: forall a. (Show a, Flat a, Eq a) => a -> TestTree
tripShow v = testCase (unwords ["roundtrip", sshow v])
  $
  -- we use show to get Right NaN == Right NaN
  show (unflat (flat v :: B.ByteString) :: Decoded a)
  @?= show (Right v :: Decoded a)

-- Test Data
lzBS = L.pack bs

stBS = B.pack bs

bs = [32, 32, 32 :: Word8]

s3 = [3, 97, 98, 99, 0]

c3a = [3, 99, 99, 99, 0] -- Array Word8

c3 = pre c3a

s600 = pre s600a

pre = (1:)

s600a = concat [[255], csb 255, [255], csb 255, [90], csb 90, [0]]

s600B =
  concat [[55], csb 55, [255], csb 255, [90], csb 90, [200], csb 200, [0]]

longSeq :: Seq.Seq Word8
longSeq = Seq.fromList lbs

longBS = B.pack lbs

longLBS = L.concat $ concat $ replicate 10 [L.pack lbs]

lbs = concat $ replicate 100 [234, 123, 255, 0]

cs n = replicate n 'c' -- take n $ cycle ['a'..'z']

csb = map (fromIntegral . ord) . cs

map1 = C.fromList [(False, True), (True, False)]

ns :: [(Word64, Int)]
ns = [((-) (2 ^ (i * 7)) 1, fromIntegral (8 * i)) | i <- [1 .. 10]]

nsI :: [(Int64, Int)]
nsI = nsI_

nsII :: [(Integer, Int)]
nsII = nsI_

nsI_ = [((-) (2 ^ (((-) i 1) * 7)) 1, fromIntegral (8 * i)) | i <- [1 .. 10]]

#ifndef ghcjs_HOST_OS
shBS = SBS.toShort stBS

longSBS = SBS.toShort longBS
#endif

sshow = take 80 . show

showB = show . B.unpack

errDec :: forall a. (Flat a, Eq a, Show a) => Proxy a -> [Word8] -> [TestTree]

--errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in ev @?= Left ""]
errDec _ bs = [ testCase "bad decode"
                  $ let ev = (des bs :: Decoded a)
                    in isRight ev @?= False]

ser :: Flat a => a -> [Word8]
ser = B.unpack . flat

des :: Flat a => [Word8] -> Decoded a
des = unflat

flatRawWith sz enc = B.unpack
  $ E.strictEncoder (sz + 8) (E.Encoding $ enc >=> E.eFillerF)

serRaw :: Flat a => a -> [Word8]

-- serRaw = B.unpack . flatRaw
-- serRaw = L.unpack . flatRaw
serRaw = asBytes . bits

--desRaw :: Flat a => [Word8] -> Decoded a
--desRaw = unflatRaw . L.pack
type RT a = a -> Bool

type RTL a = Large a -> Bool

prop_Flat_roundtrip :: (Flat a, Eq a) => a -> Bool
prop_Flat_roundtrip = roundTripExt

prop_Flat_Large_roundtrip :: (Eq b, Flat b) => Large b -> Bool
prop_Flat_Large_roundtrip (Large x) = roundTripExt x

roundTrip x = unflat (flat x :: B.ByteString) == Right x

-- Test roundtrip for both the value and the value embedded between bools
roundTripExt x = roundTrip x && roundTrip (True, x, False)

prop_double_conv d = wordToDouble (doubleToWord d) == d

prop_float_conv d = wordToFloat (floatToWord d) == d
{-
prop_common_unsigned :: (Num l,Num h,Flat l,Flat h) => l -> h -> Bool
prop_common_unsigned n _ = let n2 :: h = fromIntegral n
                           in flat n == flat n2
-}
-- e :: Stream Bool
-- e = unflatIncremental . flat $ stream1
-- el :: List Bool
-- el = unflatIncremental . flat $ infList
-- deflat = unflat
-- b1 :: BLOB UTF8
-- b1 = BLOB UTF8 (preAligned (List255 [97,98,99]))
-- -- b1 = BLOB (preAligned (UTF8 (List255 [97,98,99])))


{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | copied from <http://hackage.haskell.org/package/data-default-instances-containers>
--
-- I think the orphan 'Generic' instances are okay, because you can't write manual 'Generic' (or 'Rep'?) instances in modern GHC anyway.
-- however, not sure if this is the best way to do this.
--
-- in the automatic instances, there's a runtime cost from converting between @'Rep' a@ and @a@. for now, I just want to see how it works.
--
module Commands.Generic.Instances where
import Commands.Generic

import Generics.Deriving

import Data.Int
import Data.Word
import Data.Monoid
import Data.Ratio
import Data.Complex

import qualified Data.Set as S
import qualified Data.Map as M
import Data.IntMap (IntMap)
import Data.IntSet (IntSet)
import Data.Sequence (Seq)
import Data.Tree (Tree(..))

deriving instance (Generic a)   => Generic (Tree a)
deriving instance (RealFloat a) => Generic (Complex a)

-- constructors are private
-- deriving instance (Generic k, Generic v)   => Generic (Map k v)
-- deriving instance (Generic v)              => Generic (Set v)

-- automatic instances
instance                                        Default Bool
instance                                        Default Ordering -- should be LT?
instance (Default a)                         => Default [a]
instance (Default a)                         => Default (Maybe a)
instance (Generic a, Default a)              => Default (Tree a)
instance (Generic a, Default a, RealFloat a) => Default (Complex a)

-- manual instances
instance (Default a)              => Default (e -> a)  where def = const def
instance (Default a)              => Default (IO a)    where def = return def

instance Default (S.Set v)   where def = S.empty
instance Default (M.Map k v) where def = M.empty
instance Default (IntMap v)  where def = mempty
instance Default IntSet      where def = mempty
instance Default (Seq a)     where def = mempty

instance Default Int                       where def = 0
instance Default Int8                      where def = 0
instance Default Int16                     where def = 0
instance Default Int32                     where def = 0
instance Default Int64                     where def = 0
instance Default Word                      where def = 0
instance Default Word8                     where def = 0
instance Default Word16                    where def = 0
instance Default Word32                    where def = 0
instance Default Word64                    where def = 0
instance Default Integer                   where def = 0
instance Default Float                     where def = 0
instance Default Double                    where def = 0
instance (Integral a) => Default (Ratio a) where def = 0

instance                                                                                Default ()                    where def = ()
instance (Default a, Default b)                                                        => Default (a, b)                where def = (def, def)
instance (Default a, Default b, Default c)                                             => Default (a, b, c)             where def = (def, def, def)
instance (Default a, Default b, Default c, Default d)                                  => Default (a, b, c, d)          where def = (def, def, def, def)
instance (Default a, Default b, Default c, Default d, Default e)                       => Default (a, b, c, d, e)       where def = (def, def, def, def, def)
instance (Default a, Default b, Default c, Default d, Default e, Default f)            => Default (a, b, c, d, e, f)    where def = (def, def, def, def, def, def)
instance (Default a, Default b, Default c, Default d, Default e, Default f, Default g) => Default (a, b, c, d, e, f, g) where def = (def, def, def, def, def, def, def)


{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Parse (readExpr, readExprList) where
import LispVals

import Control.Monad (liftM, join)
import Text.ParserCombinators.Parsec (
    unexpected,
    char
    , try
    , (<|>)
    , many
    , many1
    , string
    , sepEndBy
    , endBy
    , Parser
    , oneOf
    , noneOf
    , skipMany1
    , space
    , anyChar
    , letter
    , digit
    , octDigit
    , hexDigit
    , parse)
import Numeric (readOct, readHex, readFloat)
import Data.Char (digitToInt)
import Data.Ratio ((%))
import Data.Complex (Complex((:+)))
import Control.Monad.Error (MonadError, throwError)
import qualified Data.Vector as V (fromList)

-- $setup
-- >>> import Text.ParserCombinators.Parsec (parse)

symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~"

spaces :: Parser ()
spaces = skipMany1 space

-- |
-- >>> parse parseString "lisp" "\"he\\nllo\""
-- Right "he\nllo"
parseString :: Parser LispVal
parseString = do
    char '\"'
    x <- many (many1 (noneOf "\\\"") <|> do
        char '\\'
        s <- oneOf "nrt\"\\"
        case s of
            '\"' -> return "\""
            '\\' -> return "\\"
            't' -> return "\t"
            'n' -> return "\n"
            'r' -> return "\r"
            c -> unexpected [c])
    char '\"'
    return $ String $ join x

-- |
-- >>> parse parseAtom "lisp" "hello"
-- Right hello
parseAtom :: Parser LispVal
parseAtom = do
    first <- letter <|> symbol
    rest <- many (letter <|> digit <|> symbol)
    return $ Atom $ first : rest

-- |
-- >>> parse parseBool "lisp" "#t"
-- Right #t
--
-- >>> parse parseBool "lisp" "#f"
-- Right #f
parseBool :: Parser LispVal
parseBool = try $ do
    char '#'
    x <- oneOf "tf"
    case x of
        't' -> return $ Bool True
        'f' -> return $ Bool False
        c -> unexpected [c]

-- |
-- >>> parse parseSignedNumber "lisp" "+#x123"
-- Right 291
--
-- >>> parse parseSignedNumber "lisp" "+#o123"
-- Right 83
--
-- >>> parse parseSignedNumber "lisp" "+#d123"
-- Right 123
--
-- >>> parse parseSignedNumber "lisp" "-#b101"
-- Right -5
--
-- >>> parse parseSignedNumber "lisp" "-123"
-- Right -123
--
-- >>> parse parseSignedNumber "lisp" "-3+2i"
-- Right -3.0+2.0i
--
-- >>> parse parseSignedNumber "lisp" "-3/2"
-- Right -3/2
parseSignedNumber :: Parser LispVal
parseSignedNumber = try $ do
    signChar <- oneOf "+-"
    let sign = case signChar of
                '-' -> -1 :: Integer
                _ -> 1
    ureal <- parseComplex <|> parseRatio <|> parseFloat <|> parsePrefixNumber <|> parseDecimal
    case ureal of
                Ratio r -> return $ Ratio (r * fromIntegral sign)
                Complex (r :+ i) -> return $ Complex $ (fromIntegral sign * r) :+ i
                Float f -> return $ Float $ fromIntegral sign * f
                Number n -> return $ Number $ sign * n
                _ -> unexpected (show ureal)

-- |
-- >>> parse parseUnsignedNumber "lisp" "#x123"
-- Right 291
--
-- >>> parse parseUnsignedNumber "lisp" "#o123"
-- Right 83
--
-- >>> parse parseUnsignedNumber "lisp" "#d123"
-- Right 123
--
-- >>> parse parseUnsignedNumber "lisp" "#b101"
-- Right 5
--
-- >>> parse parseUnsignedNumber "lisp" "123"
-- Right 123
parseUnsignedNumber :: Parser LispVal
parseUnsignedNumber = parsePrefixNumber <|> parseDecimal

parsePrefixNumber :: Parser LispVal
parsePrefixNumber = parseOctal
    <|> parseHexadecimal
    <|> parseBinary
    <|> (do
        try $ string "#d"
        parseDecimal)

parseOctal :: Parser LispVal
parseOctal = do
    try $ string "#o"
    os <- many1 octDigit
    return $ (Number . fst . head . readOct) os

parseHexadecimal :: Parser LispVal
parseHexadecimal = do
    try $ string "#x"
    os <- many1 hexDigit
    return $ (Number . fst . head . readHex) os

parseBinary :: Parser LispVal
parseBinary = do
    try $ string "#b"
    bs <- many1 (oneOf "01")
    return $ (Number . readBinary) bs

readBinary :: Num a => String -> a
readBinary = foldl (\x y -> x * 2 + (fromIntegral . digitToInt) y) 0

parseDecimal :: Parser LispVal
parseDecimal = do
    ds <- many1 digit
    return $ (Number . read) ds

-- |
-- >>> parse parseChar "list" "#\\c"
-- Right #\c
--
-- >>> parse parseChar "lisp" "#\\space"
-- Right #\space
parseChar :: Parser LispVal
parseChar = do
    try $ string "#\\"
    cs <- parseCharLiteral <|> anyChar
    return $ Char cs

parseCharLiteral :: Parser Char
parseCharLiteral = try $ do
    cs <- string "space" <|> string "newline"
    case cs of
        "space" -> return ' '
        "newline" -> return '\n'
        s -> unexpected s

parseFloat :: Parser LispVal
parseFloat = try $ do
    integer <- many1 digit
    char '.'
    fractional <- many1 digit
    return $ (Float . fst . head . readFloat) (integer ++ "." ++ fractional)

parseRatio :: Parser LispVal
parseRatio = try $ do
    numerator <- many1 digit
    char '/'
    denominator <- many1 digit
    return $ Ratio $ read numerator % read denominator

-- |
-- >>> parse parseComplex "lisp" "3.2+2i"
-- Right 3.2+2.0i
--
-- >>> parse parseComplex "lisp" "+2i"
-- Right 0.0+2.0i
--
-- >>> parse parseComplex "lisp" "-2i"
-- Right 0.0-2.0i
parseComplex :: Parser LispVal
parseComplex = parseImaginary <|> try (do
    real <- many1 digit
    realFrac <- (char '.' >> many1 digit) <|> return "0"
    sign <- oneOf "+-"
    complex <- many digit
    let okComplex = case complex of
                        [] -> "1"
                        _ -> complex
    complexFrac <- (char '.' >> many1 digit) <|> return "0"
    char 'i'
    return $ Complex  ((fst . head . readFloat) (real ++ "." ++ realFrac) :+
                        (fst . head . readFloat) (okComplex ++ "." ++ complexFrac) * case sign of
                            '-' -> -1
                            _ -> 1))

parseImaginary :: Parser LispVal
parseImaginary = try $ do
    sign <- (oneOf "+-" >>= \s -> return [s]) <|> return ""
    complex <- many1 digit
    complexFrac <- (char '.' >> many1 digit) <|> return "0"
    char 'i'
    let okComplex = case complex of
                        [] -> "1"
                        _ -> complex
    return $ Complex (0.0 :+ (fst . head . readFloat) (okComplex ++ "." ++ complexFrac) * case sign of
                            ('-':_) -> -1
                            _ -> 1)

-- |
-- >>> parse parseList "lisp" "1 2 3"
-- Right (1 2 3)
parseList :: Parser LispVal
parseList = liftM List $ sepEndBy parseExpr spaces

-- |
-- >>> parse parseDottedList "lisp" "1 . 2"
-- Right (1 . 2)
parseDottedList :: Parser LispVal
parseDottedList = do
    h <- endBy parseExpr spaces
    t <- char '.' >> spaces >> parseExpr
    return $ DottedList h t

parseQuoted :: Parser LispVal
parseQuoted = do
    char '\''
    x <- parseExpr
    return $ List [Atom "quote", x]

parseUnquoted :: Parser LispVal
parseUnquoted = do
    char ','
    x <- parseExpr
    return $ List [Atom "unquote", x]

parseQuasiQuoted :: Parser LispVal
parseQuasiQuoted = do
    char '`'
    x <- parseExpr
    return $ List [Atom "quasiquote", x]

-- |
-- >>> parse parseVector "lisp" "#(1 2 3)"
-- Right #(1 2 3)
parseVector :: Parser LispVal
parseVector = try $ do
    string "#("
    many space
    x <- sepEndBy parseExpr spaces
    string ")"
    return $ Vector $ V.fromList x

parseBracketedParser :: Parser LispVal -> Parser LispVal
parseBracketedParser p = try $ do
    char '('
    many space
    x <- p
    char ')'
    return x

-- |
-- >>> parse parseExpr "lisp" "hello"
-- Right hello
--
-- >>> parse parseExpr "lisp" "#(1 2 3)"
-- Right #(1 2 3)
--
-- >>> parse parseExpr "lisp" "3+2i"
-- Right 3.0+2.0i
--
-- >>> parse parseExpr "lisp" "3.2+2i"
-- Right 3.2+2.0i
--
-- >>> parse parseExpr "lisp" "3/2"
-- Right 3/2
--
-- >>> parse parseExpr "lisp" "3.2"
-- Right 3.2
--
-- >>> parse parseExpr "lisp" "-3.2"
-- Right -3.2
--
-- >>> parse parseExpr "lisp" "+#x123"
-- Right 291
--
-- >>> parse parseExpr "lisp" "#x123"
-- Right 291
--
-- >>> parse parseExpr "lisp" "+#o123"
-- Right 83
--
-- >>> parse parseExpr "lisp" "+#d123"
-- Right 123
--
-- >>> parse parseExpr "lisp" "123"
-- Right 123
--
-- >>> parse parseExpr "lisp" "-#b101"
-- Right -5
--
-- >>> parse parseExpr "lisp" "#t"
-- Right #t
--
-- >>> parse parseExpr "lisp" "#f"
-- Right #f
--
-- >>> parse parseExpr "list" "#\\c"
-- Right #\c
--
-- >>> parse parseExpr "lisp" "#\\space"
-- Right #\space
--
-- >>> parse parseExpr "lisp" "atom"
-- Right atom
--
-- >>> parse parseExpr "lisp" "'(a list)"
-- Right (quote (a list))
--
-- >>> parse parseExpr "lisp" "`(a list)"
-- Right (quasiquote (a list))
--
-- >>> parse parseExpr "lisp" "`(a ,( + 1 2))"
-- Right (quasiquote (a (unquote (+ 1 2))))
--
-- >>> parse parseExpr "lisp" "#(1 2 3 )"
-- Right #(1 2 3)
--
-- >>> parse parseExpr "lisp" "(1 2 3)"
-- Right (1 2 3)
--
-- >>> parse parseExpr "lisp" "( 1 2 . 3)"
-- Right (1 2 . 3)
--
-- >>> parse parseExpr "lisp" "\"he\\nllo\""
-- Right "he\nllo"
parseExpr :: Parser LispVal
parseExpr = parseString
    <|> parseComplex
    <|> parseRatio
    <|> parseFloat
    <|> parseSignedNumber
    <|> parseUnsignedNumber
    <|> parseBool
    <|> parseChar
    <|> parseAtom
    <|> parseQuoted
    <|> parseQuasiQuoted
    <|> parseUnquoted
    <|> parseVector
    <|> parseBracketedParser parseList
    <|> parseBracketedParser parseDottedList

readExpr :: (MonadError LispError m) => String -> m LispVal
readExpr = readOrThrow parseExpr

readExprList :: (MonadError LispError m) => String -> m [LispVal]
readExprList = readOrThrow (endBy parseExpr spaces)

readOrThrow :: (MonadError LispError m) => Parser a -> String -> m a
readOrThrow parser input = case parse parser "lisp" input of
    Left err -> throwError $ Parser err
    Right val -> return val


{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}

module Services (postCompute, postLogin, ApiApp) where

import           Config
import           Control.Monad.IO.Class    (liftIO)
import           Control.Monad.Logger      (runNoLoggingT)
import           Control.Monad.Trans
import           Data.Aeson                hiding (json)
import           Data.Complex
import           Data.IORef
import           Data.Monoid
import           Data.Text                 (pack)
import qualified Data.Text                 as T
import           Data.Time.Clock           (getCurrentTime)
import           Database.Persist.Sqlite   (SqlBackend, createSqlitePool,
                                            runMigration, runSqlPool)
import           Db                        (createToken, findToken, migrateAll,
                                            removeOldTokens, runSQL)
import           Eval                      (eval)
import           GHC.Generics              (Generic)
import           Network.HTTP.Types.Status
import           Text.Read                 (readMaybe)
import           Text.StringRandom         (stringRandomIO)
import           Web.Spock
import           Web.Spock.Config
import Data

type MySession = ()
type MyAppState = Config

type ApiAction ctx a = SpockActionCtx  ctx SqlBackend MySession MyAppState a
type ApiApp ctx = SpockCtxM ctx SqlBackend MySession MyAppState ()

postLogin :: ActionCtxT () (WebStateM SqlBackend MySession MyAppState) b
postLogin = do
  usr <- jsonBody' :: ApiAction () User
  case usr of
    User "admin" "admin" -> do
      currentTime <- liftIO getCurrentTime
      token <- liftIO $ stringRandomIO "[a-zA-Z0-9]{50}"
      runSQL $ createToken token currentTime
      json $ object ["token" .= String token]
    _ -> do setStatus status401
            json $ object ["fault" .= String "invalid login and password"]

postCompute :: ActionCtxT () (WebStateM SqlBackend MySession MyAppState) b
postCompute = do
  (ComputeData token expression) <- jsonBody' :: ApiAction () ComputeData
  currentTime <- liftIO getCurrentTime
  runSQL $ removeOldTokens currentTime -- cleanup old tokens
  tokenLine <- runSQL $ findToken (pack token)
  case tokenLine of
    Just _  -> do
      v <- liftIO $ eval expression
      case v of
        Left _ -> do setStatus status418
                     json $ object ["fault" .= String ( pack $ "can't parse expression [" ++ expression ++ "]")]
        Right a -> case a of
          "True" -> json $ object ["result" .= Bool True]
          "False" -> json $ object ["result" .= Bool False]
          _ -> case readMaybe a of
            Nothing -> do setStatus status418
                          json $ object ["fault" .= String ( pack $ "can't parse expression [" ++ expression ++ "]")]
            Just nv -> json $ object ["result" .= Number nv]
    Nothing -> do setStatus status401
                  json $ object ["fault" .= String "invalid token"]


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeOperators #-}

module Language.Grappa.Interp.TypedExpr where

import Data.Proxy
import Data.Functor.Const
import GHC.Generics

import qualified Numeric.SpecFunctions as Gamma
import qualified Language.Haskell.TH as TH

import Language.Grappa.Interp
import Language.Grappa.GrappaInternals
import Language.Haskell.TH.GrappaUtil
import Language.Grappa.Interp.FunRepr

----------------------------------------------------------------------
-- * Typed TH Expressions
----------------------------------------------------------------------

-- | Typed Template Haskell literals
data TypedLit a where
  TypedIntLit :: Num a => Integer -> TypedLit a
  TypedRatLit :: Fractional a => Rational -> TypedLit a

data TypedExpr a where
  TypedVar :: THName a -> TypedExpr a
  -- ^ A Haskell definition or variable lifted into the expression language
  TypedLit :: TypedLit a -> TypedExpr a
  -- ^ Literal expressions
  TypedApp :: TypedExpr (a -> b) -> TypedExpr a -> TypedExpr b
  -- ^ Function application
  TypedLam :: (THName a -> TypedExpr b) -> TypedExpr (a -> b)
  -- ^ Function abstraction
  TypedIfThenElse :: TypedExpr Bool -> TypedExpr a -> TypedExpr a -> TypedExpr a
  -- ^ If-then-else expression
  TypedFix :: (THName a -> TypedExpr a) -> TypedExpr a
  -- ^ Fixed-point expression

  TypedTuple :: TupleF ts TypedExpr (GTuple ts) -> TypedExpr (GTuple ts)
  -- ^ Tuple expression
  TypedMatchTuple :: IsTypeList ts => TypedExpr (GTuple ts) ->
                     (TupleF ts THName (GTuple ts) -> TypedExpr a) ->
                     TypedExpr a
  -- ^ Tuple pattern-matching expression

  TypedCtor :: THADT adt => adt TypedExpr (ADT adt) -> TypedExpr (ADT adt)
  -- ^ Constructor application expression
  TypedMatchCtor :: THADT adt => TypedExpr (ADT adt) ->
                    (adt Proxy (ADT adt)) ->
                    (adt THName (ADT adt) -> TypedExpr a) ->
                    TypedExpr a -> TypedExpr a
  -- ^ ADT match expression against a specific constructor, given as an element
  -- of its ADT, that will either call the continuation if the expression
  -- matches the constructor or will call the alternative expression otherwise
  -- which acts like the body of a wildcard pattern

-- FIXME: give TypedMatchCtor a list of possible cases, so that a wildcard that
-- is itself a match over the same expression can be folded in

----------------------------------------------------------------------
-- * Compiling Typed Expressions to TH
----------------------------------------------------------------------

class GTHCompilable f where
  gthCompile :: f a -> TH.Q TH.Exp

instance GTHCompilable U1 where
  gthCompile U1 = [| U1 |]

instance (GTHCompilable a, GTHCompilable b) => GTHCompilable (a :*: b) where
  gthCompile (a :*: b) = [| $(gthCompile a) :*: $(gthCompile b) |]

instance (GTHCompilable a, GTHCompilable b) => GTHCompilable (a :+: b) where
  gthCompile (L1 a) = [| L1 $(gthCompile a) |]
  gthCompile (R1 b) = [| R1 $(gthCompile b) |]

instance GTHCompilable a => GTHCompilable (M1 i c a) where
  gthCompile (M1 a) = [| M1 $(gthCompile a) |]

instance THCompilable a => GTHCompilable (K1 i a) where
  gthCompile (K1 a) = [| M1 $(thCompile a) |]

-- | A general typeclass for compiling things via TH
class THCompilable a where
  thCompile :: a -> TH.Q TH.Exp

  default thCompile :: (Generic a, GTHCompilable (Rep a)) => a -> TH.Q TH.Exp
  thCompile a = [| to $(gthCompile (from a)) |]

instance THCompilable a => THCompilable [a] where
  thCompile l = TH.ListE <$> mapM thCompile l

instance THCompilable (TypedExpr a) where
  thCompile (TypedVar nm) = TH.varE $ getTHName nm
  thCompile (TypedLit (TypedIntLit i)) = TH.litE (TH.IntegerL i)
  thCompile (TypedLit (TypedRatLit r)) = TH.litE (TH.RationalL r)
  thCompile (TypedApp f arg) = TH.appE (thCompile f) (thCompile arg)
  thCompile (TypedLam f) =
    do x <- TH.newName "x"
       TH.lamE [TH.varP x] (thCompile (f $ THName x))
  thCompile (TypedIfThenElse c t f) =
    TH.condE (thCompile c) (thCompile t) (thCompile f)
  thCompile (TypedFix f) =
    do x <- TH.newName "fix_var"
       TH.letE [TH.valD (TH.varP x) (TH.normalB $ thCompile $ f $ THName x) []]
         (TH.varE x)
  thCompile (TypedTuple tup) =
    adtToTHExp <$> traverseADT (fmap Const . thCompile) tup
  thCompile (TypedMatchTuple e k) =
    do ctx <- traverseADT (const $ newTHName "tup_arg") typeListProxy
       TH.caseE (thCompile e)
         [TH.match (return $ adtToTHPattern ctx)
          (TH.normalB $ thCompile $ k ctx) []]
  thCompile (TypedCtor adt) =
    adtToTHExp <$> traverseADT (fmap Const . thCompile) adt
  thCompile (TypedMatchCtor e ctor k_succ k_fail) =
    do ns_adt <- traverseADT (const (newTHName "case_arg")) ctor
       TH.caseE (thCompile e)
         [TH.match (return $ adtToTHPattern ns_adt)
          (TH.normalB $ thCompile $ k_succ $ ns_adt) []
         ,
          TH.match TH.wildP (TH.normalB $ thCompile k_fail) []]

instance THCompilable (GExpr TypedExprRepr a) where
  thCompile = thCompile . unGExpr

----------------------------------------------------------------------
-- * Compiling Functions Over Typed Expressions to TH
----------------------------------------------------------------------

-- | A context is a tuple of names, one for each type in @ctx@
type TypedCtx ctx = TupleF ctx THName (GTuple ctx)

-- | Build a tuple of fresh TH names with the given string prefix
buildTypedCtx :: IsTypeList ctx => String -> TH.Q (TypedCtx ctx)
buildTypedCtx str = traverseADT (const $ newTHName str) typeListProxy

-- | Get a list of the TH names in a 'TypedCtx'
ctxNames :: TypedCtx ctx -> [TH.Name]
ctxNames = ctorArgsADT getTHName

-- | An expression in a context is a function from contexts to expressions
type TypedCtxExpr ctx a = TypedCtx ctx -> TypedExpr a

instance IsTypeList ctx => THCompilable (TypedCtxExpr ctx a) where
  thCompile expr_f =
    do ctx <- buildTypedCtx "fun_arg"
       body_th <- thCompile $ expr_f ctx
       return $ foldr (\n -> TH.LamE [TH.VarP n]) body_th (ctxNames ctx)

-- | The representation that uses an expression-in-context
type TypedCtxExprRepr ctx = FunRepr (TypedCtx ctx) TypedExprRepr

instance IsTypeList ctx => THCompilable (GExpr (TypedCtxExprRepr ctx) a) where
  thCompile = thCompile . unGExpr

----------------------------------------------------------------------
-- * The Typed Expression Representation
----------------------------------------------------------------------

data TypedExprRepr :: *

instance ValidExprRepr TypedExprRepr where
  type GExprRepr TypedExprRepr a = TypedExpr a
  interp__'bottom = error "TypedExprRepr: unexpected bottom!"
  interp__'injTuple tup = GExpr $ TypedTuple $ mapADT unGExpr tup
  interp__'projTuple (GExpr e) k =
    GExpr $ TypedMatchTuple e (unGExpr . k . mapADT (GExpr . TypedVar))
  interp__'app (GExpr f) (GExpr x) =
    GExpr (TypedApp f x)
  interp__'lam f = GExpr $ TypedLam (unGExpr . f . GExpr . TypedVar)
  interp__'fix f = GExpr $ TypedFix (unGExpr . f . GExpr . TypedVar)

instance THADT adt => Interp__ADT__Expr TypedExprRepr adt where
  interp__'injADT adt = GExpr $ TypedCtor $ mapADT unGExpr adt
  interp__'projADT (GExpr _e) _k =
    error "FIXME HERE: no support for projADT in TypedExprRepr!"
  interp__'projMatchADT (GExpr e) ctor _ k_succ k_fail =
    GExpr $ TypedMatchCtor e ctor
    (unGExpr . k_succ . mapADT (GExpr . TypedVar)) $
    unGExpr k_fail

-- | Helper for lifting definitions to 'TypedExpr'
typedVar :: TH.Name -> GExpr TypedExprRepr a
typedVar = GExpr . TypedVar . THName

----------------------------------------------------------------------
-- * Interpreting the Operations in 'TypedExprRepr'
----------------------------------------------------------------------

--
-- Boolean and comparison operations
--

instance Interp__'ifThenElse TypedExprRepr where
  interp__'ifThenElse (GExpr c) (GExpr t) (GExpr f) =
    GExpr $ TypedIfThenElse c t f

instance Interp__not TypedExprRepr where
  interp__not = typedVar 'not

instance Interp__'amp'amp TypedExprRepr where
  interp__'amp'amp = typedVar '(&&)

instance Interp__'bar'bar TypedExprRepr where
  interp__'bar'bar = typedVar '(||)

instance Ord a => Interp__'eq'eq TypedExprRepr a where
  interp__'eq'eq = typedVar '(==)

instance Ord a => Interp__'lt TypedExprRepr a where
  interp__'lt = typedVar '(<)

instance Ord a => Interp__'gt TypedExprRepr a where
  interp__'gt = typedVar '(>)

instance Ord a => Interp__'lt'eq TypedExprRepr a where
  interp__'lt'eq = typedVar '(<=)

instance Ord a => Interp__'gt'eq TypedExprRepr a where
  interp__'gt'eq = typedVar '(>=)

instance Ord a => Interp__min TypedExprRepr a where
  interp__min = typedVar 'min

instance Ord a => Interp__max TypedExprRepr a where
  interp__max = typedVar 'max

instance Num a => Interp__'plus TypedExprRepr a where
  interp__'plus = typedVar '(+)

instance Num a => Interp__'minus TypedExprRepr a where
  interp__'minus = typedVar '(-)

instance Num a => Interp__'times TypedExprRepr a where
  interp__'times = typedVar '(*)

instance Num a => Interp__negate TypedExprRepr a where
  interp__negate = typedVar 'negate

instance Num a => Interp__abs TypedExprRepr a where
  interp__abs = typedVar 'abs

instance Num a => Interp__signum TypedExprRepr a where
  interp__signum = typedVar 'signum

instance Num a => Interp__fromInteger TypedExprRepr a where
  interp__fromInteger = typedVar 'fromInteger

instance Num a => Interp__'integer TypedExprRepr a where
  interp__'integer i = GExpr $ TypedLit $ TypedIntLit i

instance Fractional a => Interp__'rational TypedExprRepr a where
  interp__'rational r = GExpr $ TypedLit $ TypedRatLit r

instance Fractional a => Interp__'div TypedExprRepr a where
  interp__'div = typedVar '(/)

instance Fractional a => Interp__recip TypedExprRepr a where
  interp__recip = typedVar 'recip

instance Fractional a => Interp__fromRational TypedExprRepr a where
  interp__fromRational = typedVar 'fromRational

instance Floating a => Interp__pi TypedExprRepr a where
  interp__pi = typedVar 'pi

instance Floating a => Interp__exp TypedExprRepr a where
  interp__exp = typedVar 'exp

instance Floating a => Interp__log TypedExprRepr a where
  interp__log = typedVar 'log

instance Floating a => Interp__sqrt TypedExprRepr a where
  interp__sqrt = typedVar 'sqrt

instance Floating a => Interp__'times'times TypedExprRepr a where
  interp__'times'times = typedVar '(**)

instance Floating a => Interp__logBase TypedExprRepr a where
  interp__logBase = typedVar 'logBase

instance Floating a => Interp__sin TypedExprRepr a where
  interp__sin = typedVar 'sin

instance Floating a => Interp__cos TypedExprRepr a where
  interp__cos = typedVar 'cos

instance Floating a => Interp__tan TypedExprRepr a where
  interp__tan = typedVar 'tan

instance Floating a => Interp__asin TypedExprRepr a where
  interp__asin = typedVar 'asin

instance Floating a => Interp__acos TypedExprRepr a where
  interp__acos = typedVar 'acos

instance Floating a => Interp__atan TypedExprRepr a where
  interp__atan = typedVar 'atan

instance Floating a => Interp__sinh TypedExprRepr a where
  interp__sinh = typedVar 'sinh

instance Floating a => Interp__cosh TypedExprRepr a where
  interp__cosh = typedVar 'cosh

instance Floating a => Interp__tanh TypedExprRepr a where
  interp__tanh = typedVar 'tanh

instance Floating a => Interp__asinh TypedExprRepr a where
  interp__asinh = typedVar 'asinh

instance Floating a => Interp__acosh TypedExprRepr a where
  interp__acosh = typedVar 'acosh

instance Floating a => Interp__atanh TypedExprRepr a where
  interp__atanh = typedVar 'atanh

--
-- Probability operations
--

instance Interp__realToProb TypedExprRepr where
  interp__realToProb = typedVar 'realToProb

instance Interp__logRealToProb TypedExprRepr where
  interp__logRealToProb = typedVar 'logRealToProb

instance Interp__probToReal TypedExprRepr where
  interp__probToReal = typedVar 'probToReal

instance Interp__probToLogReal TypedExprRepr where
  interp__probToLogReal = typedVar 'probToLogReal

instance Interp__gammaProb TypedExprRepr where
  interp__gammaProb = typedVar 'gammaProb

instance Interp__digamma TypedExprRepr where
  interp__digamma = typedVar 'Gamma.digamma

--
-- Misc operations
--

instance Interp__gerror TypedExprRepr a where
  interp__gerror = typedVar 'gerror


{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}

-- | Functions to represent a 'Vector' on disk in efficient, if
-- unportable, ways.
--
-- This module uses memory-mapping, a feature of all modern
-- operating-systems, to mirror the disk contents in memory. There are
-- quite a few advantages to memory-mapping files instead of reading
-- the files traditionally:
--
--  * Speed: memory-mapping is often much faster than traditional
--    reading.
--
--  * Memory efficiency: Memory-mapped files are loaded into RAM
--    on-demand, and easily swapped out. The upside is that the
--    program can work with data-sets larger than the available RAM,
--    as long as they are accessed carefully.
--
-- The caveat to using memory-mapping is that it makes the files
-- specific to the current architecture because of the endianness of
-- the data. For more information, see the description in
-- "System.IO.MMap"
--
-- If you wish to write the contents in a portable fashion, either use
-- the ASCII load and save functions in "Numeric.Container", or use
-- the binary serialization in "Data.Binary".

module Data.Packed.Vector.MMap (
  -- * Memory-mapping 'Vector' from disk
  unsafeMMapVector,
  unsafeLazyMMapVectors,

  -- * Writing 'Vector' to disk

  -- | These functions write the 'Vector' in a way suitable for
  -- reading back with 'unsafeMMapVector'.
  hPutVector,
  writeVector
) where

import Control.Monad (when)

import System.IO
import System.IO.MMap
import System.IO.Unsafe

import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable

import qualified Numeric.LinearAlgebra.Devel as I
import qualified Numeric.LinearAlgebra.HMatrix as I
-- import qualified Data.Packed.Vector as I
import Data.Int

---------------------------
-- Memory-Mapping 'Vector' from disk

-- | Map a file into memory (read-only) as a 'Vector'.
--
-- It is considered unsafe because changes to the underlying file may
-- (or may not) be reflected in the 'Vector', which breaks referential
-- transparency.
unsafeMMapVector :: forall a. Storable a => FilePath -- ^ Path of the file to map
                                         -> Maybe (Int64, Int) -- ^ 'Nothing' to map entire file into memory, otherwise 'Just (fileOffset, elementCount)'
                                         -> IO (I.Vector a)
unsafeMMapVector path range =
  do (foreignPtr, offset, size) <- mmapFileForeignPtr path ReadOnly $
        case range of
          Nothing -> Nothing
          Just (start, length) -> Just (start, length * sizeOf (undefined :: a))
     return $ I.unsafeFromForeignPtr foreignPtr offset (size `div` sizeOf (undefined :: a))

-- | Map a file into memory as a lazy-list of equal-sized 'Vector',
-- even if they can't all fit in the address space at the same time.
--
-- > (numVectors,vectors) <- unsafeLazyMMapVectors filename Nothing vectorSize
--
-- Commonly, a data file will contain multiple vectors of equal length
-- (matrix). This function is convenient for those uses, but it plays
-- a more important role: supporting data-sets that cannot fit in the
-- address space of the current machine.
--
-- On 32-bit machines the address space is only 4GB, and it is
-- actually pretty easy to find data-sets that are too large to be
-- represented, even in virtual memory.
--
-- This function loads the data in chunks, and as long as you drop
-- your reference to the vectors as you consume the data, the old
-- chunks will be unmapped before mapping the next chunk.
--
-- The number of vectors in the list is returned because it's often
-- needed, yet calculating it using 'length' would demand the whole
-- list.
unsafeLazyMMapVectors :: forall a. (Storable a, I.Container I.Vector a) => FilePath -- ^ Path of the file to map
                      -> Maybe (Int64, Int64)
                      -- ^ 'Nothing' to map entire file into memory,
                      -- otherwise @'Just' (fileOffset, totalElementCount)@
                      -> Int -- ^ The number of elements in each 'Vector'
                      -> IO (Int64,[I.Vector a]) -- ^ Return @(numberOfVectors,vectors)@
unsafeLazyMMapVectors path range vsize = do
  when (vecSize > maxChunkSize) vecTooBigError
  filesize <- withFile path ReadMode hFileSize
  let filesize' :: Int64
      filesize' = fI filesize
  imgs <- unsafeInterleaveIO $ unsafeLazyMMapVectors' filesize' path range vsize
  return (nimages range filesize', imgs)
      where
        nimages :: Maybe (Int64, Int64) -> Int64 -> Int64
        nimages Nothing fsz = fsz `div` imageSize
        nimages (Just (_,sz)) _ = sz `div` imageSize
        imageSize = fI vsize * eltSize
        eltSize = fI (sizeOf (undefined :: a))
        vecSize = fI vsize * eltSize
        vecTooBigError = fail "The requested vector size can't be mapped into memory"

unsafeLazyMMapVectors' :: forall a. (Storable a, I.Container I.Vector a) => Int64
                       -> FilePath
                       -> Maybe (Int64, Int64)
                       -> Int
                       -> IO [I.Vector a]
unsafeLazyMMapVectors' fileSize
                       fileName
                       fileRange
                       numEltsPerVec
                           | mapSize < maxChunkSize = mmapAll
                           | otherwise = mmapChunks 0
    where
      mapSize, eltSize, vecSize, chunkSize, baseOffset :: Int64
      eltSize = fI $ sizeOf (undefined :: a)
      (baseOffset,mapSize) = case fileRange of
                               Just (off,nelts) -> (off,nelts*eltSize)
                               _ -> (0,fileSize)
      vecSize = fI numEltsPerVec * eltSize
      chunkSize = (maxChunkSize `div` vecSize) * vecSize

      fileRange' = do
        (offset, nelts) <- fileRange
        return (offset, fI nelts)

      splitVecs :: I.Vector a -> [I.Vector a]
      splitVecs bigVec = let nvecs = I.size bigVec `div` numEltsPerVec
                         in I.takesV (replicate nvecs numEltsPerVec) bigVec

      mmapAll :: IO [I.Vector a]
      mmapAll = do
        allVecs <- unsafeMMapVector fileName fileRange'
        return $ splitVecs allVecs

      mmapChunks :: Int64 -> IO [I.Vector a]
      mmapChunks offs | remaining <= 0 = return []
                      | otherwise = do
        chunk <- unsafeMMapVector fileName mmapRange
        rest <- unsafeInterleaveIO $ mmapChunks (offs+chunkSize')
        return $ splitVecs chunk ++ rest
          where
            mmapRange = Just (baseOffset+offs,fI (chunkSize' `div` eltSize))
            remaining = mapSize-offs
            chunkSize' = min chunkSize remaining

-- Maximum size for chunks
maxChunkSize :: Int64
maxChunkSize = fI (maxBound `div` 256 :: Int)

-- Handy alias for 'fromIntegral'
fI :: (Integral a, Num b) => a -> b
fI = fromIntegral

---------------------------
-- Writing 'Vector' to disk

-- | Write out a vector verbatim into an open file handle.
hPutVector :: forall a. Storable a => Handle -> I.Vector a -> IO ()
hPutVector h v = withForeignPtr fp $ \p -> hPutBuf h (p `plusPtr` offset) sz
      where
        (fp, offset, n) = I.unsafeToForeignPtr v
        eltsize = sizeOf (undefined :: a)
        sz = n * eltsize

-- | Write the vector verbatim to a file.
writeVector :: forall a. Storable a => FilePath -> I.Vector a -> IO ()
writeVector fp v = withFile fp WriteMode $ \h -> hPutVector h v


{-# LANGUAGE ViewPatterns ,DeriveGeneric,DeriveAnyClass ,BangPatterns #-}
module Report where
import           Criterion.IO
import           Criterion.Types
import           Data.Bifunctor
import           Data.List
import qualified Data.Map                        as M
import           Data.Ord
import           Statistics.Resampling.Bootstrap
import           System.Directory
import           Text.Printf
import System.FilePath
import Control.DeepSeq
import GHC.Generics
import Control.Monad

type Measures = M.Map String Measure

data Measure = Measure {mTest::String,mValue::Double} deriving (Show,Read,Eq,Generic,NFData)

mKindPkg :: Measure -> (String, String)
mKindPkg m = let (k,_:p) = break (== '-') $ mTest m in (k,p)

mKind :: Measure -> String
mKind = fst . mKindPkg

mKindPkgVal :: Measure -> (String, (String, Double))
mKindPkgVal m = let (k,p) = mKindPkg m in (k,(p,mValue m))

byTestKind :: M.Map k Measure -> [(String, (String, Double))]
byTestKind = map mKindPkgVal . M.elems

toMeasures :: [Report] -> Measures
toMeasures = M.fromList . map (\r-> let m = toMeasure r in (mTest m,m))

toMeasure :: Report -> Measure
toMeasure r = Measure (reportName r) ((1000 *) . estPoint . anMean . reportAnalysis $ r)

deleteMeasures :: FilePath -> IO ()
deleteMeasures = removeFile . measuresFile

updateMeasures :: FilePath -> IO ()
updateMeasures = void . updateMeasures_

updateMeasures_ :: FilePath -> IO (Measures, Measures, Measures)
updateMeasures_ dir = do
  m' <- readCriterionMeasures dir
  addMeasures_ dir m'

addMeasures_
  :: FilePath
     -> Measures
     -> IO (Measures, Measures, Measures)
addMeasures_ dir m' = do
  !m <- readMeasures dir
  let m'' = M.union m' m
  writeMeasures dir m''
  return (m,m',m'')

addMeasures
  :: FilePath
     -> String
     -> [(String, Double)]
     -> IO () -- Measures, Measures, Measures)
addMeasures dir name ms = void $ addMeasures_ dir (M.fromList $ map (\(pkg,val) -> let n = concat [name,"-",pkg] in (n,Measure n val)) ms)

readMeasures :: FilePath -> IO Measures
readMeasures dir =  do
  let f = measuresFile dir
  fe <- doesFileExist f
  if not fe
    then return M.empty
    else (force . read) <$> readFile f

writeMeasures :: FilePath -> Measures -> IO ()
writeMeasures dir = writeFile (measuresFile dir) . show

readCriterionMeasures :: FilePath -> IO Measures
readCriterionMeasures dir = toMeasures <$> readReports (reportsFile dir)

measuresFile :: FilePath -> FilePath
measuresFile dir = dir </> "measures"

reportsFile :: FilePath -> FilePath
reportsFile dir = dir </> "report.json"

printMeasures :: FilePath -> IO ()
printMeasures dir = readMeasures dir >>= printMeasuresAll_ (const True)

printMeasuresCurrent :: (Measures,Measures,Measures) -> IO ()
printMeasuresCurrent (_,m',m'') =
  let currentKinds = allKinds m'
  in printMeasuresAll_ (\ts -> fst ts `elem` currentKinds) m''

printMeasuresAll_
  :: ((String, [(String, Double)]) -> Bool)
     -> Measures -> IO ()
printMeasuresAll_ f m'' = mapM_ (uncurry report) . filter f . allTests . byTestKind $ m''

allKinds :: Measures -> [String]
allKinds = nub . map mKind . M.elems

allTests
  :: [(String, (String, Double))] -> [(String, [(String, Double)])]
allTests = sort . map (\g -> (fst . head $ g,map snd g)) . groupBy (\a b -> fst a == fst b)

printMeasuresDiff :: (Measures,Measures,Measures) -> IO ()
printMeasuresDiff (m,m',_) =
--  mapM_ (\(n,d) -> putStrLn (unwords [n,show d,"%"])) . M.toList $ M.intersectionWithKey (\k a b ->(k,round ((mValue b/mValue a-1)*100))) m m'
  mapM_ (\(n,d) -> putStrLn (unwords [n,show d,"%"])) . M.toList $ M.intersectionWith (\a b -> round ((mValue b/mValue a-1)*100)::Int) m m'

readReports :: FilePath -> IO [Report]
readReports jsonReportFile = do
  fe <- doesFileExist jsonReportFile
  if not fe
    then return [] -- M.empty
    else do
      er <- readJSONReports jsonReportFile
      return $
        case er of
          Right (_, _, reports) -> reports
          _ -> [] -- M.empty

report :: String -> [(String,Double)] -> IO ()
report _ [] = return ()
report name rs = do
  -- print rs
  let (_,rss) = report_ rs
  let width = maximum . map (length . fst) $ rs
  -- putStrLn $ unwords [name,"ordered by",prop,"("++fst best++":",printInt (snd best),unit++")"]
  putStrLn $ unwords [name,"(best first)"] -- package: "++fst best++" with ",printInt (snd best)++")"]
  -- putStrLn name -- ,"(Best package: "++fst best++" with ",printInt (snd best)++")"]
  mapM_ (\(n,v) -> putStrLn $ unwords [printString width n,printDouble v]) rss
  putStrLn ""

report_ :: (Fractional c, Ord c) => [(a, c)] -> ((a, c), [(a, c)])
report_ rs =
  let
    rss = sortBy (comparing snd) rs
    best = snd . head $ rss
  in (head rss, map (second (/ best)) rss)

printDouble :: Double -> String
printDouble = printf "%5.1f"

printInt :: Double -> String
printInt = printf "%.0f"

printString :: Int -> String -> String
printString width = printf ("%-"++show width++"s")


import Prelude
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Array
import Data.Bits
import Data.Bool
import Data.Char
import Data.Complex
import Data.Dynamic
import Data.Either
import Data.Eq
import Data.Fixed
import Data.Function
import Data.Graph
import Data.Int
import Data.Ix
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.Ratio
import Data.Tree
import Data.Tuple
import Data.Typeable
import Data.Word
import Text.Printf

' '?y=y
x?' '=x
_?_='~'
(x:c)??(y:d)=x?y:c??d
x??y=x++y
""#[]=[(0,"")]
x#y=[(c+1,a:d)|a:b<-[x],a/='~',(c,d)<-b#y]++[c|a:b<-[y],c<-x??a#b]
g a=snd$minimum$(#)""=<<permutations a

test input ans=
  let output = g input
  in do
    print ("output: " ++ output)
    print ("answer: " ++ ans)

main=do
  test ["hac m", "k e"] "hackme"
  test ["b", "a"] "ab"
  test [] ""
  test ["rst r", "rsy rsytsr", "a"] "rst rrsyarsytsr"


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonoLocalBinds    #-}
{-# LANGUAGE TypeOperators     #-}
module Utils.Array where

import           Control.Monad        (when)
import           Data.Array.Repa      as R
import           Data.Binary
import           Data.ByteString.Lazy as BL
import           Data.Complex
import           Data.Int
import           Data.List            as L
import           Data.Vector.Unboxed  as VU
import           System.IO            (IOMode (..), withBinaryFile)
import           Text.Printf
import           Types

{-# INLINE rotate3D #-}
rotate3D :: (R.Source s e) => R.Array s DIM3 e -> R.Array D DIM3 e
rotate3D arr =
  let (Z :. k :. i :. j) = extent arr
   in R.backpermute
        (Z :. i :. j :. k)
        (\(Z :. a :. b :. c) -> (Z :. c :. a :. b))
        arr

{-# INLINE rotate3DR #-}
rotate3DR :: (R.Source s e) => R.Array s DIM3 e -> R.Array D DIM3 e
rotate3DR arr =
  let (Z :. i :. j :. k) = extent arr
   in R.backpermute
        (Z :. k :. i :. j)
        (\(Z :. a :. b :. c) -> (Z :. b :. c :. a))
        arr

{-# INLINE rotate4D #-}
rotate4D :: (R.Source s e) => R.Array s DIM4 e -> R.Array D DIM4 e
rotate4D arr =
  let (Z :. k :. l :. i :. j) = extent arr
   in R.backpermute
        (Z :. l :. i :. j :. k)
        (\(Z :. a :. b :. c :. d) -> (Z :. d :. a :. b :. c))
        arr

{-# INLINE rotate4D' #-}
rotate4D' :: (R.Source s e) => R.Array s DIM4 e -> R.Array D DIM4 e
rotate4D' arr =
  let (Z :. k :. l :. i :. j) = extent arr
   in R.backpermute
        (Z :. j :. k :. l :. i)
        (\(Z :. a :. b :. c :. d) -> (Z :. b :. c :. d :. a))
        arr

{-# INLINE rotate4D2 #-}
rotate4D2 :: (R.Source s e) => R.Array s DIM4 e -> R.Array D DIM4 e
rotate4D2 arr =
  let (Z :. k :. l :. i :. j) = extent arr
  in R.backpermute
       (Z :. i :. j :. k :. l)
       (\(Z :. a :. b :. c :. d) -> (Z :. c :. d :. a :. b))
       arr

{-# INLINE rotateR2Z1T0Array #-}
rotateR2Z1T0Array :: (R.Source s e) => R.Array s DIM4 e -> R.Array D DIM4 e
rotateR2Z1T0Array arr =
  let (Z :. k :. l :. i :. j) = extent arr
   in R.backpermute
        (Z :. k :. i :. j :. l)
        (\(Z :. a :. b :. c :. d) -> (Z :. a :. d :. b :. c))
        arr

{-# INLINE rotateR2Z2T0S0Array #-}
rotateR2Z2T0S0Array :: (R.Source s e) => R.Array s DIM6 e -> R.Array D DIM6 e
rotateR2Z2T0S0Array arr =
  let (Z :. k :. l :. m :. n :. i :. j) = extent arr
  in R.backpermute
       (Z :. k :. l :. i :. j :. m :. n)
       (\(Z :. a :. b :. c :. d :. e :. f) -> (Z :. a :. b :. e :. f :. c :. d))
       arr

{-# INLINE rotateR2Z2T0S0ArrayDeconv #-}
rotateR2Z2T0S0ArrayDeconv :: (R.Source s e) => R.Array s DIM6 e -> R.Array D DIM6 e
rotateR2Z2T0S0ArrayDeconv arr =
  let (Z :. k :. l :. m :. n :. i :. j) = extent arr
  in R.backpermute
       (Z :. m :. n :. i :. j :. k :. l)
       (\(Z :. a :. b :. c :. d :. e :. f) -> (Z :. e :. f :. a :. b :. c :. d))
       arr

{-# INLINE writeRepaArray #-}
writeRepaArray ::
     (Shape sh, Binary e, R.Source s e) => FilePath -> R.Array s sh e -> IO ()
writeRepaArray filePath arr =
  withBinaryFile filePath WriteMode $ \h -> do
    let shapeBS = encode . listOfShape . extent $ arr
        elemBS = encode . R.toList $ arr
    BL.hPut h . encode . BL.length $ shapeBS -- ByteString lenght is 64 bits = 8 bytes
    BL.hPut h shapeBS
    BL.hPut h . encode . BL.length $ elemBS  -- ByteString lenght is 64 bits = 8 bytes
    BL.hPut h elemBS

{-# INLINE readRepaArray #-}
readRepaArray ::
     (R.Source U e, Binary e, Unbox e, Shape sh)
  => FilePath
  -> IO (R.Array U sh e)
readRepaArray filePath =
  withBinaryFile filePath ReadMode $ \h -> do
    shapeLen <- decode <$> BL.hGet h 8 :: IO Int64
    sh <- (shapeOfList . decode) <$> BL.hGet h (fromIntegral shapeLen)
    elemLen <- decode <$> BL.hGet h 8 :: IO Int64
    elem <- decode <$> BL.hGet h (fromIntegral elemLen)
    when
      (size sh /= L.length elem)
      (error
         (printf
            "readRepaArray: array shape size (%d) /= element size (%d)\n"
            (size sh)
            (L.length elem)))
    return $ fromListUnboxed sh elem

{-# INLINE pad #-}
pad ::
     (Source s e, Shape sh)
  => [Int]
  -> e
  -> R.Array s sh e
  -> R.Array D sh e
pad newDims padVal arr
  | L.length newDims /= L.length oldDimList =
    error $
    printf
      "pad: Dimensions are different. (%d vs. %d)"
      (L.length oldDimList)
      (L.length newDims)
  | L.all (== 0) diff = delay arr
  | otherwise =
    backpermuteDft
      (fromFunction (shapeOfList dimList) (const padVal))
      (\sh' ->
         let idx = L.zipWith (-) (listOfShape sh') diff
         in if L.or (L.zipWith (\i j -> i < 0 || (i >= j)) idx oldDimList)
              then Nothing
              else Just $ shapeOfList idx)
      arr
  where
    !oldDimList = listOfShape . extent $ arr
    !dimList = L.zipWith max newDims oldDimList
    !diff =
      L.zipWith
        (\a b ->
           if a - b <= 0
             then 0
             else if a - b == 1
                    then 1
                    else div (a - b) 2)
        newDims
        oldDimList


module MatrixMarket
( MatrixList
, mmReadFile
, mmWriteFile
) where

-- reads/writes MatrixMarket files to a generic matrix data type

import Data.Char (toLower)
import Data.Complex
import Data.List (intersperse, nub)
import qualified Data.Map as Map (fromList, lookup, Map)
import Data.Maybe (fromJust, isNothing)
import MatrixList (MatrixList)
import System.IO (hClose, hPutStrLn, openFile, IOMode(WriteMode))

data MMFormat = Array | Coordinate
data MMType = MMInt | MMReal | MMComplex

class MMReadable a where
      mmRead :: String -> a
      mmReads :: String -> [(a, String)]

instance MMReadable Int where
         mmRead = read
         mmReads = reads

instance MMReadable Float where
         mmRead = read
         mmReads = reads

instance MMReadable Double where
         mmRead = read
         mmReads = reads

instance (MMReadable a, RealFloat a) => MMReadable (Complex a) where
         mmRead strz = a :+ b where [a, b] = fmap mmRead (words strz)

         mmReads str | len == 2  = if null xread || null yread then []
                                   else [(x :+ y, "")]
                     | otherwise = []
                     where len = length (words str)
                           [xread, yread] = fmap mmReads (words str)
                           [x, y] = fmap (fst . head) [xread, yread]

instance MMReadable MMFormat where
         mmReads name =
                 case map toLower name of "array"      -> [(Array, "")]
                                          "coordinate" -> [(Coordinate, "")]
                                          _            -> []

         mmRead = fst . head . mmReads

instance MMReadable MMType where
         mmReads name =
                 case map toLower name of "integer" -> [(MMInt, "")]
                                          "real"    -> [(MMReal, "")]
                                          "complex" -> [(MMComplex, "")]
                                          _         -> []

         mmRead = fst . head . mmReads

class MMShowable a where
      mmShow :: a -> String

instance MMShowable Int where
         mmShow = show

instance MMShowable Float where
         mmShow = show

instance MMShowable Double where
         mmShow = show

instance (MMShowable a, RealFloat a) => MMShowable (Complex a) where
         mmShow z = concat . intersperse " " . fmap mmShow $ [realPart z, imagPart z]

instance MMShowable MMFormat where
         mmShow Array = "array"
         mmShow Coordinate = "coordinate"

instance MMShowable MMType where
         mmShow MMInt = "integer"
         mmShow MMReal = "real"
         mmShow MMComplex = "complex"

mmReadFile :: FilePath -> IO (MatrixList Double)
mmReadFile filePath = readFile filePath >>=
                      (return . mmToMatrixList filePath)

mmWriteFile :: MatrixList Double -> String -> FilePath -> IO ()
mmWriteFile matrixList format filePath = do
            let action = Map.lookup format mmWriteCmds
            let list = maybe (error $ "Unrecognized format " ++ format)
                             ($ matrixList) action
            handle <- openFile filePath WriteMode
            hPutStrLn handle $ "%%MatrixMarket matrix " ++ format ++ " real general"
            mapM_ (hPutStrLn handle) list
            hClose handle

mmToMatrixList :: FilePath -> String -> MatrixList Double
mmToMatrixList filePath contents
      | null (words contents) = error $ filePath ++ " is empty"
      | length first < 4      = error $ filePath ++ " header is invalid"
      | null rest             = error $ filePath ++ " has no contents"
      | otherwise             = maybe errormsg (($ filePath) . ($ rest)) action
      where fileLines = lines contents
            first = words . head $ fileLines
            rest = filter ((/='%') . head . head) . filter (not . null) .
                   fmap words $ tail fileLines
            action = Map.lookup (fmap toLower (first !! 2)) mmReadCmds
            errormsg = error $ filePath ++ " has unrecognized format " ++
                               (first !! 2)

mmReadCmds :: Map.Map String ([[String]] -> FilePath -> MatrixList Double)
mmReadCmds = Map.fromList [
               ("array", arrayToMatrixList)
             , ("coordinate", coordinateToMatrixList)
             ]

arrayToMatrixList :: [[String]] -> FilePath -> MatrixList Double
arrayToMatrixList lineList filePath
     | length firstLine /= 2             = error $ filePath ++ " matrix size invalid"
     | any ((/= 1) . length) valueLines  = error $ filePath ++ " has invalid value lines"
     | any null size                     = error $ filePath ++ " matrix size invalid"
     | length valueList /= nrows * ncols = error $ filePath ++ " has wrong matrix size"
     | any null valueReads               = error $ filePath ++ " has invalid values"
     | otherwise                         = (nrows, ncols, ijxs)
     where (firstLine, valueLines) = (head lineList, tail lineList)
           size = fmap reads firstLine :: [[(Int, String)]]
           [nrows, ncols] = fmap (fst . head) size
           valueList = concat valueLines
           valueReads = fmap reads valueList :: [[(Double, String)]]
           values = fmap (fst . head) valueReads
           indices = [(i, j) | j <- [1..ncols], i <- [1..nrows]]
           ijxs = fmap (\((i, j), x) -> (i, j, x)) . filter ((/= 0) . snd) .
                  zip indices $ values

coordinateToMatrixList :: [[String]] -> FilePath -> MatrixList Double
coordinateToMatrixList lineList filePath
     | any ((/= 3) . length) lineList   = error $ filePath ++ " has wrong-length line"
     | any null firstLineNums           = error $ filePath ++ " has invalid size line"
     | length entryLines /= nonzeros    = error $ filePath ++ " has wrong no. of nonzeros"
     | any (any null) indexReads        = error $ filePath ++ " has invalid indices"
     | indices /= nub indices           = error $ filePath ++ " has duplicate indices"
     | maxRow > nrows || maxCol > ncols = error $ filePath ++ " has indices outside range"
     | any null valueReads              = error $ filePath ++ " has invalid values"
     | otherwise                        = (nrows, ncols, if nonzeros == 0 then [] else ijxs)
     where (firstLine, entryLines) = (head lineList, tail lineList)
           firstLineNums = fmap reads firstLine :: [[(Int, String)]]
           firstLineVals = fmap (fst . head) firstLineNums
           [nrows, ncols] = take 2 firstLineVals
           nonzeros = firstLineVals !! 2
           splitEntries = fmap (splitAt 2) entryLines
           indexLines = fmap fst splitEntries
           indexReads = fmap (fmap reads) indexLines :: [[[(Int, String)]]]
           indices = fmap (fmap $ fst . head) indexReads
           [maxRow, maxCol] = if nonzeros == 0 then [1,1] else
                              fmap maximum [fmap (!! 0) indices, fmap (!! 1) indices]
           valueLines = concat . fmap snd $ splitEntries
           valueReads = fmap reads valueLines :: [[(Double, String)]]
           values = fmap (fst . head) valueReads
           ijxs = zipWith (\[i,j] x -> (i,j,x)) indices values

mmWriteCmds :: Map.Map String (MatrixList Double -> [String])
mmWriteCmds = Map.fromList [
                ("array", matrixListToArray)
              , ("coordinate", matrixListToCoordinate)
              ]

matrixListToArray :: MatrixList Double -> [String]
matrixListToArray (m, n, ijxs) = (joinStr [show m, show n]):showVals
                   where pairList = fmap (\(i, j, x) -> ((i,j), x)) ijxs
                         hashTable = Map.fromList pairList
                         indices = [(i, j) | j <- [1..n], i <- [1..m]]
                         showVals = fmap (show . value) indices
                         value pair | isNothing check = 0
                                    | otherwise       = fromJust check
                                    where check = Map.lookup pair hashTable

matrixListToCoordinate :: MatrixList Double -> [String]
matrixListToCoordinate (m, n, ijxs) =
          (joinStr [show m, show n, show $ length ijxs]):(fmap pairToStr ijxs)

joinStr :: [String] -> String
joinStr = concat . intersperse " "

pairToStr :: (Show a, Show b, Show c) => (a,b,c) -> String
pairToStr = joinStr . (\(i,j,x) -> [show i, show j, show x])