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

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

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

#include "HsBaseConfig.h"

module Generics.Deriving.Enum (

  -- * Generic enum class
    GEnum(..)

  -- * Default definitions for GEnum
  , genumDefault, toEnumDefault, fromEnumDefault

  -- * Internal enum class
  , Enum'(..)

  -- * Generic Ix class
  , GIx(..)

  -- * Default definitions for GIx
  , rangeDefault, indexDefault, inRangeDefault

  ) where

import           Control.Applicative (Const, ZipList)

import           Data.Int
import           Data.Monoid (All, Any, Dual, Product, Sum)
import qualified Data.Monoid as Monoid (First, Last)
import Data.Word

import           Foreign.C.Types
import           Foreign.Ptr

import           Generics.Deriving.Base
import           Generics.Deriving.Eq

import           System.Exit (ExitCode)
import           System.Posix.Types

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

#if MIN_VERSION_base(4,7,0)
import           Data.Coerce (coerce)
import           Data.Proxy (Proxy)
#else
import           Unsafe.Coerce (unsafeCoerce)
#endif

#if MIN_VERSION_base(4,8,0)
import           Data.Functor.Identity (Identity)
import           Data.Monoid (Alt)
import           Numeric.Natural (Natural)
#endif

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

-----------------------------------------------------------------------------
-- Utility functions for Enum'
-----------------------------------------------------------------------------

infixr 5 |||

-- | Interleave elements from two lists. Similar to (++), but swap left and
-- right arguments on every recursive application.
--
-- From Mark Jones' talk at AFP2008
(|||) :: [a] -> [a] -> [a]
[]     ||| ys = ys
(x:xs) ||| ys = x : ys ||| xs

-- | Diagonalization of nested lists. Ensure that some elements from every
-- sublist will be included. Handles infinite sublists.
--
-- From Mark Jones' talk at AFP2008
diag :: [[a]] -> [a]
diag = concat . foldr skew [] . map (map (\x -> [x]))

skew :: [[a]] -> [[a]] -> [[a]]
skew []     ys = ys
skew (x:xs) ys = x : combine (++) xs ys

combine :: (a -> a -> a) -> [a] -> [a] -> [a]
combine _ xs     []     = xs
combine _ []     ys     = ys
combine f (x:xs) (y:ys) = f x y : combine f xs ys

findIndex :: (a -> Bool) -> [a] -> Maybe Int
findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y]
                 in if (null l)
                    then Nothing
                    else Just (head l)

--------------------------------------------------------------------------------
-- Generic enum
--------------------------------------------------------------------------------

class Enum' f where
  enum' :: [f a]

instance Enum' U1 where
  enum' = [U1]

instance (GEnum c) => Enum' (K1 i c) where
  enum' = map K1 genum

instance (Enum' f) => Enum' (M1 i c f) where
  enum' = map M1 enum'

instance (Enum' f, Enum' g) => Enum' (f :+: g) where
  enum' = map L1 enum' ||| map R1 enum'

instance (Enum' f, Enum' g) => Enum' (f :*: g) where
  enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ]

genumDefault :: (Generic a, Enum' (Rep a)) => [a]
genumDefault = map to enum'

toEnumDefault :: (Generic a, Enum' (Rep a)) => Int -> a
toEnumDefault i = let l = enum'
                  in if (length l > i)
                      then to (l !! i)
                       else error "toEnum: invalid index"

fromEnumDefault :: (GEq a, Generic a, Enum' (Rep a))
                => a -> Int
fromEnumDefault x = case findIndex (geq x) (map to enum') of
      Nothing -> error "fromEnum: no corresponding index"
      Just i  -> i

class GEnum a where
  genum :: [a]

#if __GLASGOW_HASKELL__ >= 701
  default genum :: (Generic a, Enum' (Rep a)) => [a]
  genum = genumDefault
#endif

genumNumUnbounded :: Num a => [a]
genumNumUnbounded = pos 0 ||| neg 0 where
  pos n = n     : pos (n + 1)
  neg n = (n-1) : neg (n - 1)

genumNumSigned :: (Bounded a, Enum a, Num a) => [a]
genumNumSigned = [0 .. maxBound] ||| [-1, -2 .. minBound]

genumNumUnsigned :: (Enum a, Num a) => [a]
genumNumUnsigned = [0 ..]

#if !(MIN_VERSION_base(4,7,0))
coerce :: a -> b
coerce = unsafeCoerce
#endif

-- Base types instances
instance GEnum () where
  genum = genumDefault

instance (GEnum a, GEnum b) => GEnum (a, b) where
  genum = genumDefault

instance (GEnum a, GEnum b, GEnum c) => GEnum (a, b, c) where
  genum = genumDefault

instance (GEnum a, GEnum b, GEnum c, GEnum d) => GEnum (a, b, c, d) where
  genum = genumDefault

instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e) => GEnum (a, b, c, d, e) where
  genum = genumDefault

instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f)
    => GEnum (a, b, c, d, e, f) where
  genum = genumDefault

instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f, GEnum g)
    => GEnum (a, b, c, d, e, f, g) where
  genum = genumDefault

instance GEnum a => GEnum [a] where
  genum = genumDefault

instance (GEnum (f p), GEnum (g p)) => GEnum ((f :+: g) p) where
  genum = genumDefault

instance (GEnum (f p), GEnum (g p)) => GEnum ((f :*: g) p) where
  genum = genumDefault

instance GEnum (f (g p)) => GEnum ((f :.: g) p) where
  genum = genumDefault

instance GEnum All where
  genum = genumDefault

#if MIN_VERSION_base(4,8,0)
instance GEnum (f a) => GEnum (Alt f a) where
  genum = genumDefault
#endif

instance GEnum Any where
  genum = genumDefault

#if MIN_VERSION_base(4,9,0)
instance (GEnum a, GEnum b) => GEnum (Arg a b) where
  genum = genumDefault
#endif

#if !(MIN_VERSION_base(4,9,0))
instance GEnum Arity where
  genum = genumDefault
#endif

instance GEnum Associativity where
  genum = genumDefault

instance GEnum Bool where
  genum = genumDefault

#if defined(HTYPE_CC_T)
instance GEnum CCc where
  genum = coerce (genum :: [HTYPE_CC_T])
#endif

instance GEnum CChar where
  genum = coerce (genum :: [HTYPE_CHAR])

instance GEnum CClock where
  genum = coerce (genum :: [HTYPE_CLOCK_T])

#if defined(HTYPE_DEV_T)
instance GEnum CDev where
  genum = coerce (genum :: [HTYPE_DEV_T])
#endif

instance GEnum CDouble where
  genum = coerce (genum :: [HTYPE_DOUBLE])

instance GEnum CFloat where
  genum = coerce (genum :: [HTYPE_FLOAT])

#if defined(HTYPE_GID_T)
instance GEnum CGid where
  genum = coerce (genum :: [HTYPE_GID_T])
#endif

#if defined(HTYPE_INO_T)
instance GEnum CIno where
  genum = coerce (genum :: [HTYPE_INO_T])
#endif

instance GEnum CInt where
  genum = coerce (genum :: [HTYPE_INT])

instance GEnum CIntMax where
  genum = coerce (genum :: [HTYPE_INTMAX_T])

instance GEnum CIntPtr where
  genum = coerce (genum :: [HTYPE_INTPTR_T])

instance GEnum CLLong where
  genum = coerce (genum :: [HTYPE_LONG_LONG])

instance GEnum CLong where
  genum = coerce (genum :: [HTYPE_LONG])

#if defined(HTYPE_MODE_T)
instance GEnum CMode where
  genum = coerce (genum :: [HTYPE_MODE_T])
#endif

#if defined(HTYPE_NLINK_T)
instance GEnum CNlink where
  genum = coerce (genum :: [HTYPE_NLINK_T])
#endif

#if defined(HTYPE_OFF_T)
instance GEnum COff where
  genum = coerce (genum :: [HTYPE_OFF_T])
#endif

#if MIN_VERSION_base(4,4,0)
instance GEnum a => GEnum (Complex a) where
  genum = genumDefault
#endif

instance GEnum a => GEnum (Const a b) where
  genum = genumDefault

#if defined(HTYPE_PID_T)
instance GEnum CPid where
  genum = coerce (genum :: [HTYPE_PID_T])
#endif

instance GEnum CPtrdiff where
  genum = coerce (genum :: [HTYPE_PTRDIFF_T])

#if defined(HTYPE_RLIM_T)
instance GEnum CRLim where
  genum = coerce (genum :: [HTYPE_RLIM_T])
#endif

instance GEnum CSChar where
  genum = coerce (genum :: [HTYPE_SIGNED_CHAR])

#if defined(HTYPE_SPEED_T)
instance GEnum CSpeed where
  genum = coerce (genum :: [HTYPE_SPEED_T])
#endif

#if MIN_VERSION_base(4,4,0)
instance GEnum CSUSeconds where
  genum = coerce (genum :: [HTYPE_SUSECONDS_T])
#endif

instance GEnum CShort where
  genum = coerce (genum :: [HTYPE_SHORT])

instance GEnum CSigAtomic where
  genum = coerce (genum :: [HTYPE_SIG_ATOMIC_T])

instance GEnum CSize where
  genum = coerce (genum :: [HTYPE_SIZE_T])

#if defined(HTYPE_SSIZE_T)
instance GEnum CSsize where
  genum = coerce (genum :: [HTYPE_SSIZE_T])
#endif

#if defined(HTYPE_TCFLAG_T)
instance GEnum CTcflag where
  genum = coerce (genum :: [HTYPE_TCFLAG_T])
#endif

instance GEnum CTime where
  genum = coerce (genum :: [HTYPE_TIME_T])

instance GEnum CUChar where
  genum = coerce (genum :: [HTYPE_UNSIGNED_CHAR])

#if defined(HTYPE_UID_T)
instance GEnum CUid where
  genum = coerce (genum :: [HTYPE_UID_T])
#endif

instance GEnum CUInt where
  genum = coerce (genum :: [HTYPE_UNSIGNED_INT])

instance GEnum CUIntMax where
  genum = coerce (genum :: [HTYPE_UINTMAX_T])

instance GEnum CUIntPtr where
  genum = coerce (genum :: [HTYPE_UINTPTR_T])

instance GEnum CULLong where
  genum = coerce (genum :: [HTYPE_UNSIGNED_LONG_LONG])

instance GEnum CULong where
  genum = coerce (genum :: [HTYPE_UNSIGNED_LONG])

#if MIN_VERSION_base(4,4,0)
instance GEnum CUSeconds where
  genum = coerce (genum :: [HTYPE_USECONDS_T])
#endif

instance GEnum CUShort where
  genum = coerce (genum :: [HTYPE_UNSIGNED_SHORT])

instance GEnum CWchar where
  genum = coerce (genum :: [HTYPE_WCHAR_T])

instance GEnum Double where
  genum = genumNumUnbounded

instance GEnum a => GEnum (Dual a) where
  genum = genumDefault

instance (GEnum a, GEnum b) => GEnum (Either a b) where
  genum = genumDefault

instance GEnum ExitCode where
  genum = genumDefault

instance GEnum Fd where
  genum = coerce (genum :: [CInt])

instance GEnum a => GEnum (Monoid.First a) where
  genum = genumDefault

#if MIN_VERSION_base(4,9,0)
instance GEnum a => GEnum (Semigroup.First a) where
  genum = genumDefault
#endif

instance GEnum Fixity where
  genum = genumDefault

instance GEnum Float where
  genum = genumNumUnbounded

#if MIN_VERSION_base(4,8,0)
instance GEnum a => GEnum (Identity a) where
  genum = genumDefault
#endif

instance GEnum Int where
  genum = genumNumSigned

instance GEnum Int8 where
  genum = genumNumSigned

instance GEnum Int16 where
  genum = genumNumSigned

instance GEnum Int32 where
  genum = genumNumSigned

instance GEnum Int64 where
  genum = genumNumSigned

instance GEnum Integer where
  genum = genumNumUnbounded

instance GEnum IntPtr where
  genum = genumNumSigned

instance GEnum c => GEnum (K1 i c p) where
  genum = genumDefault

instance GEnum a => GEnum (Monoid.Last a) where
  genum = genumDefault

#if MIN_VERSION_base(4,9,0)
instance GEnum a => GEnum (Semigroup.Last a) where
  genum = genumDefault
#endif

instance GEnum (f p) => GEnum (M1 i c f p) where
  genum = genumDefault

#if MIN_VERSION_base(4,9,0)
instance GEnum a => GEnum (Max a) where
  genum = genumDefault
#endif

instance GEnum a => GEnum (Maybe a) where
  genum = genumDefault

#if MIN_VERSION_base(4,9,0)
instance GEnum a => GEnum (Min a) where
  genum = genumDefault
#endif

#if MIN_VERSION_base(4,8,0)
instance GEnum Natural where
  genum = genumNumUnsigned
#endif

#if MIN_VERSION_base(4,9,0)
instance GEnum a => GEnum (NonEmpty a) where
  genum = genumDefault
#endif

instance GEnum Ordering where
  genum = genumDefault

instance GEnum p => GEnum (Par1 p) where
  genum = genumDefault

instance GEnum a => GEnum (Product a) where
  genum = genumDefault

#if MIN_VERSION_base(4,7,0)
instance GEnum
# if MIN_VERSION_base(4,9,0)
               (Proxy s)
# else
               (Proxy (s :: *))
# endif
               where
  genum = genumDefault
#endif

instance GEnum (f p) => GEnum (Rec1 f p) where
  genum = genumDefault

instance GEnum a => GEnum (Sum a) where
  genum = genumDefault

instance GEnum (U1 p) where
  genum = genumDefault

instance GEnum Word where
  genum = genumNumUnsigned

instance GEnum Word8 where
  genum = genumNumUnsigned

instance GEnum Word16 where
  genum = genumNumUnsigned

instance GEnum Word32 where
  genum = genumNumUnsigned

instance GEnum Word64 where
  genum = genumNumUnsigned

instance GEnum WordPtr where
  genum = genumNumUnsigned

#if MIN_VERSION_base(4,9,0)
instance GEnum m => GEnum (WrappedMonoid m) where
  genum = genumDefault
#endif

instance GEnum a => GEnum (ZipList a) where
  genum = genumDefault

#if MIN_VERSION_base(4,10,0)
instance GEnum CBool where
  genum = coerce (genum :: [HTYPE_BOOL])

# if defined(HTYPE_BLKSIZE_T)
instance GEnum CBlkSize where
  genum = coerce (genum :: [HTYPE_BLKSIZE_T])
# endif

# if defined(HTYPE_BLKCNT_T)
instance GEnum CBlkCnt where
  genum = coerce (genum :: [HTYPE_BLKCNT_T])
# endif

# if defined(HTYPE_CLOCKID_T)
instance GEnum CClockId where
  genum = coerce (genum :: [HTYPE_CLOCKID_T])
# endif

# if defined(HTYPE_FSBLKCNT_T)
instance GEnum CFsBlkCnt where
  genum = coerce (genum :: [HTYPE_FSBLKCNT_T])
# endif

# if defined(HTYPE_FSFILCNT_T)
instance GEnum CFsFilCnt where
  genum = coerce (genum :: [HTYPE_FSFILCNT_T])
# endif

# if defined(HTYPE_ID_T)
instance GEnum CId where
  genum = coerce (genum :: [HTYPE_ID_T])
# endif

# if defined(HTYPE_KEY_T)
instance GEnum CKey where
  genum = coerce (genum :: [HTYPE_KEY_T])
# endif
#endif

--------------------------------------------------------------------------------
-- Generic Ix
--------------------------------------------------------------------------------

-- Minimal complete instance: 'range', 'index' and 'inRange'.
class (Ord a) => GIx a where
    -- | The list of values in the subrange defined by a bounding pair.
    range               :: (a,a) -> [a]
    -- | The position of a subscript in the subrange.
    index               :: (a,a) -> a -> Int
    -- | Returns 'True' the given subscript lies in the range defined
    -- the bounding pair.
    inRange             :: (a,a) -> a -> Bool
#if __GLASGOW_HASKELL__ >= 701
    default range :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a]
    range = rangeDefault

    default index :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int
    index = indexDefault

    default inRange :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool
    inRange = inRangeDefault
#endif

rangeDefault :: (GEq a, Generic a, Enum' (Rep a))
             => (a,a) -> [a]
rangeDefault = t (map to enum') where
  t l (x,y) =
    case (findIndex (geq x) l, findIndex (geq y) l) of
      (Nothing, _)     -> error "rangeDefault: no corresponding index"
      (_, Nothing)     -> error "rangeDefault: no corresponding index"
      (Just i, Just j) -> take (j-i) (drop i l)

indexDefault :: (GEq a, Generic a, Enum' (Rep a))
             => (a,a) -> a -> Int
indexDefault = t (map to enum') where
  t l (x,y) z =
    case (findIndex (geq x) l, findIndex (geq y) l) of
      (Nothing, _)     -> error "indexDefault: no corresponding index"
      (_, Nothing)     -> error "indexDefault: no corresponding index"
      (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of
                            Nothing -> error "indexDefault: index out of range"
                            Just k  -> k

inRangeDefault :: (GEq a, Generic a, Enum' (Rep a))
               => (a,a) -> a -> Bool
inRangeDefault = t (map to enum') where
  t l (x,y) z =
    case (findIndex (geq x) l, findIndex (geq y) l) of
      (Nothing, _)     -> error "indexDefault: no corresponding index"
      (_, Nothing)     -> error "indexDefault: no corresponding index"
      (Just i, Just j) -> maybe False (const True)
                            (findIndex (geq z) (take (j-i) (drop i l)))

rangeEnum :: Enum a => (a, a) -> [a]
rangeEnum (m,n) = [m..n]

indexIntegral :: Integral a => (a, a) -> a -> Int
indexIntegral (m,_n) i = fromIntegral (i - m)

inRangeOrd :: Ord a => (a, a) -> a -> Bool
inRangeOrd (m,n) i =  m <= i && i <= n

-- Base types instances
instance GIx () where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (a, b) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c)
    => GIx (a, b, c) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,
          GEq d, GEnum d, GIx d)
    => GIx (a, b, c, d) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,
          GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e)
    => GIx (a, b, c, d, e) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,
          GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f)
    => GIx (a, b, c, d, e, f) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,
          GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f,
          GEq g, GEnum g, GIx g)
    => GIx (a, b, c, d, e, f, g) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a) => GIx [a] where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance GIx All where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,8,0)
instance (GEq (f a), GEnum (f a), GIx (f a)) => GIx (Alt f a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance GIx Any where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,9,0)
instance (GEq a, GEnum a, GIx a, GEnum b) => GIx (Arg a b) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

#if !(MIN_VERSION_base(4,9,0))
instance GIx Arity where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance GIx Associativity where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance GIx Bool where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance GIx CChar where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

#if defined(HTYPE_GID_T)
instance GIx CGid where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

#if defined(HTYPE_INO_T)
instance GIx CIno where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

instance GIx CInt where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CIntMax where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CIntPtr where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CLLong where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CLong where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

#if defined(HTYPE_MODE_T)
instance GIx CMode where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

#if defined(HTYPE_NLINK_T)
instance GIx CNlink where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

#if defined(HTYPE_OFF_T)
instance GIx COff where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

#if defined(HTYPE_PID_T)
instance GIx CPid where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

instance GIx CPtrdiff where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

#if defined(HTYPE_RLIM_T)
instance GIx CRLim where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

instance GIx CSChar where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CShort where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CSigAtomic where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CSize where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

#if defined(HTYPE_SSIZE_T)
instance GIx CSsize where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

#if defined(HTYPE_TCFLAG_T)
instance GIx CTcflag where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

instance GIx CUChar where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

#if defined(HTYPE_UID_T)
instance GIx CUid where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

instance GIx CUInt where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CUIntMax where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CUIntPtr where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CULLong where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CULong where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CUShort where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx CWchar where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance (GEq a, GEnum a, GIx a) => GIx (Dual a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (Either a b) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance GIx ExitCode where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance GIx Fd where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance (GEq a, GEnum a, GIx a) => GIx (Monoid.First a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,9,0)
instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.First a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance GIx Fixity where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,8,0)
instance (GEq a, GEnum a, GIx a) => GIx (Identity a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance GIx Int where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Int8 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Int16 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Int32 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Int64 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Integer where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx IntPtr where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance (GEq a, GEnum a, GIx a) => GIx (Monoid.Last a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,9,0)
instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.Last a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

#if MIN_VERSION_base(4,9,0)
instance (GEq a, GEnum a, GIx a) => GIx (Max a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,9,0)
instance (GEq a, GEnum a, GIx a) => GIx (Min a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

#if MIN_VERSION_base(4,8,0)
instance GIx Natural where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
#endif

#if MIN_VERSION_base(4,9,0)
instance (GEq a, GEnum a, GIx a) => GIx (NonEmpty a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance GIx Ordering where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance (GEq a, GEnum a, GIx a) => GIx (Product a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

#if MIN_VERSION_base(4,7,0)
instance GIx
# if MIN_VERSION_base(4,9,0)
             (Proxy s)
# else
             (Proxy (s :: *))
# endif
             where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

instance (GEq a, GEnum a, GIx a) => GIx (Sum a) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault

instance GIx Word where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Word8 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Word16 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Word32 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx Word64 where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

instance GIx WordPtr where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

#if MIN_VERSION_base(4,9,0)
instance (GEq m, GEnum m, GIx m) => GIx (WrappedMonoid m) where
  range   = rangeDefault
  index   = indexDefault
  inRange = inRangeDefault
#endif

#if MIN_VERSION_base(4,10,0)
instance GIx CBool where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd

# if defined(HTYPE_BLKSIZE_T)
instance GIx CBlkSize where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif

# if defined(HTYPE_BLKCNT_T)
instance GIx CBlkCnt where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif

# if defined(HTYPE_CLOCKID_T)
instance GIx CClockId where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif

# if defined(HTYPE_FSBLKCNT_T)
instance GIx CFsBlkCnt where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif

# if defined(HTYPE_FSFILCNT_T)
instance GIx CFsFilCnt where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif

# if defined(HTYPE_ID_T)
instance GIx CId where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif

# if defined(HTYPE_KEY_T)
instance GIx CKey where
  range   = rangeEnum
  index   = indexIntegral
  inRange = inRangeOrd
# endif
#endif


{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
-- | Tests for forms.
module FormTest where

#include "ghc_modules.h"

-- base
import           Control.Applicative          (Alternative (..))
import           Data.Char                    (toUpper)
import           Data.Complex
import           Data.Data
import qualified Data.Fixed                   as Fixed
import           Data.Functor.Compose
import           Data.Functor.Const
import           Data.Functor.Identity
import qualified Data.Functor.Product         as Product
import qualified Data.Functor.Sum             as Sum
import           Data.Int
import           Data.List                    (isPrefixOf, isSubsequenceOf)
import           Data.List.NonEmpty           (NonEmpty (..))
import           Data.Monoid
import           Data.Ratio
import qualified Data.Semigroup               as Semigroup
import           Data.Version
import           Data.Word
import           GHC.Generics                 (Generic (..))
import           Numeric.Natural
import           Text.Show.Functions          ()

#if !MIN_VERSION_ghc(8,4,0)
import           Data.Monoid                  ((<>))
#endif

-- binary
import           Data.Binary                  (decode, encode)

-- deepseq
import           Control.DeepSeq

-- ghc
import           GHC_Data_FastString          (fsLit, unpackFS)
import           GHC_Data_StringBuffer        (stringToStringBuffer)
import           GHC_Driver_Session           (HasDynFlags (..))
import           GHC_Types_SrcLoc             (GenLocated (..), SrcSpan (..),
                                               noSrcSpan)
import           GHC_Driver_Ppr               (showPpr)

#if MIN_VERSION_ghc(9,0,0)
import           GHC_Types_SrcLoc             (UnhelpfulSpanReason (..))
#endif

-- transformers
import           Control.Monad.Trans.State

-- hspec
import           Test.Hspec

-- QuickCheck
import           Test.QuickCheck

-- finkel-kernel
import           Language.Finkel.Fnk
import           Language.Finkel.Form
import           Language.Finkel.Homoiconic
import qualified Language.Finkel.Homoiconic   as Homoiconic
import           Language.Finkel.Lexer
import           Language.Finkel.Reader
import           Language.Finkel.SpecialForms

-- Internal
import           Orphan                       ()

formTests :: Spec
formTests = do
  mapM_ readShow
    [ "foo", "#'a", "12345", "6.789", "0.001"
    , "(foo bar buzz)"
    , "(#'a #'\\SP #'\\ \"bcd\")"
    , "[#'\\BEL #'\\BS #'\\FF #'\\LF #'\\CR #'\\HT #'\\VT]"
    , "[()]"
    , "(1 -2 345 6.789 0.001)" ]

  readUnicodeStringProp
  readShowFormProp

  dataInstanceTests
  qFunctionTests

  fracTest 1.23
  fracTest (-1.23)
  fracTest 0
  fracTest 1e-9

  showTest
  pprTest
  functorTest "(a \"foo\" \\x [True False])"
  applicativeTest
  monadTest
  foldableTest
  traversableTest
  binaryTest

  eqTest "(a \"bcd\" \\e [f g] (h i))"
  eqPropTest

  locationTest Nothing "foo"
  locationTest (Just "locationTest") "foo"
  asLocOfTest

  lengthTest 3 "(a b c)"
  lengthTest 5 "(a (b (c)) d e)"
  lengthTest 1 "()"
  lengthTest 8 "[a (b (c d e) [f g]) h]"
  lengthTest 1 "foo"

  homoiconicTests
  rnfTest
  listTest
  numTest
  fractionalTest
  monoidTest
  alternativeTest

  fromCodeTest
  fromCodeErrorTest

  dataToCodeTest
  genericHomoiconicTest

  unquoteSpliceTest

readShow :: String -> Spec
readShow str =
  describe ("read and show `" ++ str ++ "'") $
    it "should match the input" $
      show (parseE str) `shouldBe` str

readUnicodeStringProp :: Spec
readUnicodeStringProp =
  describe "read and show unicode string" $
    it "should return itself" $
      property (\uni ->
                  let str = getUnicodeString uni
                  in  parseE (show str) == toCode (aString NoSourceText str))

readShowFormProp :: Spec
readShowFormProp =
  describe "read and show form property" $
    it "should match the input" $
      property (\form ->
                  form == form && parseE (show form) `eqForm` form)

dataInstanceTests :: Spec
dataInstanceTests = do
  let gfoldl_self atom =
        gfoldl (\mb_f x -> case mb_f of
                   Just f -> pure (f x)
                   _ -> error "should not happen")
               return atom
      t_gfoldl_self x = gfoldl_self x `shouldBe` Just x
      t_show_constr x y = show (toConstr x) `shouldBe` y
  describe "Data instance for Atom" $ do
    let aunit = AUnit
        asym = ASymbol (fsLit "foo")
        achar = AChar NoSourceText 'a'
        astr = AString NoSourceText (fsLit "string")
        aint = AInteger (mkIntegralLit (42 :: Int))
        afrac = aFractional (1.23 :: Double)
    it "should return Just self with simple gfoldl" $ do
      t_gfoldl_self aunit
      t_gfoldl_self asym
      t_gfoldl_self achar
      t_gfoldl_self astr
      t_gfoldl_self aint
      t_gfoldl_self afrac
    it "should show itself with toConstr" $ do
      t_show_constr aunit "AUnit"
      t_show_constr asym "ASymbol"
      t_show_constr achar "AChar"
      t_show_constr astr "AString"
      t_show_constr aint "AInteger"
      t_show_constr afrac "AFractional"
    it "should return AUnit with simple gunfold" $ do
      gunfold (const Nothing) Just (toConstr AUnit) `shouldBe` Just AUnit
    it "should return AUnit constr" $ do
      let dtype = dataTypeOf AUnit
          cnstr = toConstr AUnit
      readConstr dtype "AUnit" `shouldBe` Just cnstr
  describe "Data instance for Form" $ do
    let fatom = Atom AUnit
        qc c = qChar c "" 0 0 0 0
        flist = List [qc 'a', qc 'b']
        fhslist = HsList [qc 'a', qc 'b']
        ftend :: Form Atom
        ftend = TEnd
    it "should return Just self with simple gfoldl" $ do
      t_gfoldl_self fatom
      t_gfoldl_self flist
      t_gfoldl_self fhslist
      t_gfoldl_self ftend
    it "should show itself with toConstr" $ do
      t_show_constr fatom "Atom"
      t_show_constr flist "List"
      t_show_constr fhslist "HsList"
      t_show_constr ftend "TEnd"
    it "should return TEnd with simple gunfold" $
      gunfold (const Nothing) Just (toConstr ftend) `shouldBe` Just ftend
    it "should return Atom constr" $ do
      let dtype = dataTypeOf fatom
          cnstr = toConstr fatom
      readConstr dtype "Atom" `shouldBe` Just cnstr
    it "should return same result from dataCast1 and gcast1" $ do
      (dataCast1 [TEnd] :: Maybe [Form Atom]) `shouldBe` Just [TEnd]
  describe "Data instance for LForm" $ do
    let qc = qChar 'x' "" 0 0 0 0
        d1, d2, d3 :: Data a => a
        d1 = fromConstr (toConstr noSrcSpan)
        d2 = fromConstrB (fromConstr (toConstr AUnit))
                         (toConstr (Atom AUnit))
        d3 = evalState m 0
          where
            m = fromConstrM act (toConstr (L noSrcSpan (Atom AUnit)))
            act :: Data d => State Int d
            act = do
              i <- get
              modify succ
              case i of
                0 -> return d1
                1 -> return d2
                _ -> error ("index " ++ show i ++ " for LForm")
        d4 = fromConstrB d3 (toConstr qu)
        gc1 :: Data a => Maybe [LForm a]
        gc1 =
          let a :: Data a => a
              a = fromConstr (toConstr AUnit)
          in  dataCast1 [LForm (L noSrcSpan (Atom a))]
        qu = qUnit "" 0 0 0 0
    it "should return Just self with simple gfoldl" $ do
      t_gfoldl_self qc
    it "should show itself with toConstr" $ do
      t_show_constr qc "LForm"
    it "should return LForm constr" $ do
      let dtype = dataTypeOf qc
          cnstr = toConstr qc
      readConstr dtype "LForm" `shouldBe` Just cnstr
    it "should construct qUnit from constructors" $ do
      d4 `shouldBe` qu
    it "should return qUnit from dataCast1" $
      gc1 `shouldBe` Just [qu]

qFunctionTests :: Spec
qFunctionTests = do
  describe "qSymbol function" $
    it "should equal to quoted symbol" $
      qSymbol "foo" "" 0 0 0 0 `shouldBe` toCode (ASymbol (fsLit "foo"))
  describe "qChar function" $
    it "should equal to quoted char" $
      qChar 'x' "" 0 0 0 0 `shouldBe` toCode 'x'
  describe "qString function" $
    it "should equal to quoted string" $
      qString "foo" "" 0 0 0 0 `shouldBe` toCode "foo"
  describe "qInteger function" $
    it "should equal to quoted integer" $
      qInteger 42 "" 0 0 0 0 `shouldBe` toCode (42 :: Integer)
  describe "qFractional function" $
    it "should equal to quoted fractional" $
      qFractional (1.23 :: Double) "" 0 0 0 0
        `shouldBe` toCode (1.23 :: Double)
  describe "qUnit function" $
    it "should equal to quoted unit" $
      qUnit "" 0 0 0 0 `shouldBe` toCode ()

  let qc x = qChar x "" 0 0 0 0
  describe "qList function" $
    it "should equal to quoted codes" $
      let xs = [qc 'a', qc 'b']
      in qList xs "" 0 0 0 0 `shouldBe` toCode (List xs)
  describe "qHsList function" $
    it "should equal to quoted haskell list" $
      let xs = [qc 'a', qc 'b']
      in  qHsList xs "" 0 0 0 0 `shouldBe` toCode (HsList xs)

fracTest :: Double -> Spec
fracTest x =
  describe ("read and show a fractional number `" ++ show x ++ "'") $
    it "should match the input" $
       show (aFractional x) `shouldBe` show x

showTest :: Spec
showTest =
  describe "showing TEnd" $
    it "should be \"TEnd\"" $
      show (TEnd :: Form Atom) `shouldBe` "TEnd"

functorTest :: String -> Spec
functorTest str = do
  describe ("Functor instance of Code `" ++ str ++ "'") $
    it "should obey the Functor law" $
       let c = parseE str
       in  fmap id c `shouldBe` c
  describe "fmap to TEnd" $
    it "should be TEnd" $ do
      let te :: Form Atom
          te = TEnd
          f :: Atom -> Atom
          f _ = AUnit
      fmap f te `shouldBe` te

applicativeTest :: Spec
applicativeTest = do
  let atom_a = AChar NoSourceText 'a'
      char_a = toCode atom_a
      al2 = qList [char_a, char_a] "" 0 0 0 0
      ahl2 = qHsList [char_a, char_a] "" 0 0 0 0
      unit = toCode ()
      f1 a b = (a,b)
      a_pair = lf (Atom (atom_a, atom_a))
      a_pair_ls = mk_a_pairs List 2 -- lf (List [a_pair, a_pair])
      a_pair_hls = mk_a_pairs HsList 2 -- lf (HsList [a_pair, a_pair])
      mk_a_pairs f n = lf (f (replicate n a_pair))
      lf = LForm . genSrc
      tend :: Form Atom
      tend = TEnd

  describe "pure" $
    it "should result in atom" $
      toCode (pure AUnit :: Form Atom) `shouldBe` unit

  describe "<*>" $ do
    it "should apply f1 to atom and atom" $
      f1 <$> char_a <*> char_a `shouldBe` a_pair
    it "should apply f1 to atom and list" $
      f1 <$> char_a <*> al2 `shouldBe` a_pair_ls
    it "should apply f1 to atom and hslist" $
      f1 <$> char_a <*> ahl2 `shouldBe` a_pair_hls
    it "should aply f1 to list and atom" $
      f1 <$> al2 <*> char_a `shouldBe` a_pair_ls
    it "should apply f1 to list and list" $
      f1 <$> al2 <*> al2 `shouldBe` mk_a_pairs List 4
    it "should apply f1 to list and hslist" $
      f1 <$> al2 <*> ahl2 `shouldBe` mk_a_pairs List 4
    it "should aply f1 to list and atom" $
      f1 <$> ahl2 <*> char_a `shouldBe` a_pair_hls
    it "should apply f1 to list and list" $
      f1 <$> ahl2 <*> al2 `shouldBe` mk_a_pairs HsList 4
    it "should apply f1 to list and list" $
      f1 <$> ahl2 <*> ahl2 `shouldBe` mk_a_pairs HsList 4
    it "should result in TEnd" $ do
      f1 <$> char_a <*> lf tend `shouldBe` lf TEnd
      f1 <$> lf tend <*> char_a `shouldBe` lf TEnd

monadTest :: Spec
monadTest = do
  let f1 x = case x of
               AChar st c -> AChar st (toUpper c)
               _          -> x
      qh x = qHsList x "" 0 0 0 0
      ql x = qList x "" 0 0 0 0
  describe "bind" $ do
    it "should apply f1 to atom" $
      do {x <- toCode 'x'; return (f1 x)} `shouldBe` toCode 'X'
    it "should apply f1 to list" $
      do {x <- ql [toCode 'x', toCode 'x']; return (f1 x)} `shouldBe`
         ql [toCode 'X', toCode 'X']
    it "should apply f1 to hslist" $
      do {x <- qh [toCode 'x',toCode 'x']; return (f1 x)} `shouldBe`
         qh [toCode 'X', toCode 'X']
    it "should apply f1 to TEnd" $
      do {x <- toCode (TEnd :: Form Atom); return (f1 x)} `shouldBe`
         toCode (TEnd :: Form Atom)

foldableTest :: Spec
foldableTest = do
  let fsum = foldr (\x acc -> case x of
                                AInteger il -> acc + il_value il
                                _           -> acc)
                   0
  describe "taking sum of 1 to 10 with foldr" $ do
    let str1 = "(1 2 3 4 5 6 7 8 9 10)"
    it ("should be 55 for " ++ str1) $
      fsum (parseE str1) `shouldBe` 55
    it "should be 0 for TEnd" $ do
#if MIN_VERSION_ghc(9,0,0)
      let sp = UnhelpfulSpan (UnhelpfulOther (fsLit "<foldableTest>"))
#else
      let sp = UnhelpfulSpan (fsLit "<foldableTest>")
#endif
      fsum (LForm (L sp TEnd)) `shouldBe` 0
  describe "length of nil" $
    it "should be 0" $
      length nil `shouldBe` 0

traversableTest :: Spec
traversableTest = do
  let f atom = case atom of
                 ASymbol sym | '$' : _ <- unpackFS sym
                             -> return (aSymbol "_")
                 _ -> return atom
  describe "replacing symbol with mapM" $ do
    let str1 = "(a $b c [$d e] [f g $h] ($i $j))"
        str2 = "(a  _ c [ _ e] [f g  _] ( _  _))"
    it "should replace $.* with _" $ do
      let form1 = parseE str1
          form2 = parseE str2
      mapM f form1 `shouldBe` Just form2
  describe "traversing TEnd" $
    it "should be Just TEnd" $
      mapM f TEnd `shouldBe` Just TEnd

binaryTest :: Spec
binaryTest = do
  describe "Instances of Get and Put from binary" $ do
    it "should return the original value" $ do
      let to_from_bin :: Code -> Bool
          to_from_bin x = decode (encode x) == x
      property to_from_bin

eqTest :: String -> Spec
eqTest str =
  describe "parsing same string twice" $
   it "should result in equal codes" $
     let c1 = parseE str
         c2 = parseE str
     in  c1 `shouldBe` c2

eqPropTest :: Spec
eqPropTest = do
  describe "Eq instance for LForm" $
    it "should ignore location information" $ do
      let g :: Code -> Bool
          g x@(LForm (L _ body)) = x == LForm (L sp body)
#if MIN_VERSION_ghc(9,0,0)
          sp = UnhelpfulSpan (UnhelpfulOther (fsLit "<eqPropTest>"))
#else
          sp = UnhelpfulSpan (fsLit "<eqPropTest>")
#endif
      property g
  describe "comparing TEnd with TEnd" $
    it "should be True" $
      (TEnd :: Form Atom) `shouldBe` (TEnd :: Form Atom)

locationTest :: Maybe FilePath -> String -> Spec
locationTest mb_path str =
  describe ("location of `" ++ str ++ "'") $
    it (case mb_path of
          Just path -> "should contain `" ++ path ++ "'"
          Nothing   -> "should be unhelpful") $ do
       let c = parseE' mb_path str
           l = showLoc c
       case mb_path of
         Just path -> (path `isPrefixOf` l) `shouldBe` True
         Nothing   -> ("anon" `isSubsequenceOf` l) `shouldBe` True

asLocOfTest :: Spec
asLocOfTest =
  describe ("apply asLocOf to code") $ do
    it "should return the value of first arg" $
      property (\ a b -> asLocOf a b == a)
    it "should use the location of second arg" $
      property (\ a b -> case (asLocOf a b, b) of
                   (LForm (L l1 _), LForm (L l2 _)) -> l1 == l2)

lengthTest :: Int -> String -> Spec
lengthTest n str =
  describe ("length of " ++ str) $
   it ("should be " ++ show n) $
     length (parseE str) `shouldBe` n

homoiconicTests :: Spec
homoiconicTests = do
  let t x = describe ("to/from code " ++ show x) $
              it "shoult match the input" $
                 case fromCode (toCode x) of
                   Just y  -> y `shouldBe` x
                   Nothing -> error ("got Nothing with " ++ show x)
  t (aIntegral (42 :: Int))
  t ()
  t 'x'
  t "string"
  t (42 :: Int)
  t (42 :: Int8)
  t (42 :: Int16)
  t (42 :: Int32)
  t (42 :: Int64)
  t (42 :: Integer)
  t (42 :: Word)
  t (42 :: Word8)
  t (42 :: Word16)
  t (42 :: Word32)
  t (42 :: Word64)
  t (0.123456789 :: Double)
  t (1.234 :: Float)
  t ([1,2,3] :: [Int])
  t (Fixed.MkFixed 2 :: Fixed.Pico)
  t (Identity 'a')
  t (1 :+ 2 :: Complex Int)
  t (Compose (Just (Just 'a')))
  t (Const True :: Const Bool Char)
  t (Product.Pair (Just 'a') (Just 'b'))
  t [Sum.InL (Just 'a'), Sum.InR (Right 'b'), Sum.InR (Left "foo")]
  t ('a' :| ['b', 'c', 'd'])
  t (All False)
  t (Alt (Just True))
  t (Any False)
  t (Dual 'x')
  t (First (Just 'a'))
  t (Last (Just 'a'))
  t (Product (42 :: Int))
  t (Sum (42 :: Int))
  t (Proxy :: Proxy ())
  t (Version [1,2,3] ["foo", "bar"])
  t (1 % 3 :: Rational)
  t (Semigroup.Arg 'x' False)
  t (Semigroup.First 'a')
  t (Semigroup.Last 'z')
  t (Semigroup.Max (42 :: Int))
  t (Semigroup.Min (42 :: Int))
#if !MIN_VERSION_ghc(9,0,0)
  t (Semigroup.Option (Just "foo"))
#endif
  t (Semigroup.WrapMonoid True)
  t (42 :: Natural)
  t (Atom (aIntegral (42 :: Int)))
  t (LForm (genSrc (Atom (aIntegral (42 :: Int)))))
  t [True, False]
  t [EQ, LT, GT]
  t (Just (42 :: Int))
  t [Right True, Left "foo"]
  t (Just 'x', [Right False, Left "foo"])
  t (Just 'x', [Right False, Left "foo"], EQ)
  t (Just 'x', [Right False, Left "foo"], EQ, 42::Int)
  t (Just 'x', [Right False, Left "foo"], EQ, 42::Int ,False)
  t (Just 'x', [Right False, Left "foo"], EQ, 42::Int
    ,False, Just [Right (Just EQ), Left (3.1 :: Double)])

rnfTest :: Spec
rnfTest = do
  describe "rnf of arbitrary form" $
    it "should return ()" $
       property (rnf :: Code -> ())
  describe "rnf of TEnd" $
    it "should return ()" $
      rnf (TEnd :: Form Atom) `shouldBe` ()

listTest :: Spec
listTest =
  describe "list from arbitrary form applied to arbitrary function" $
    it "should be a list" $ do
      let f :: (Code -> Code) -> Code -> Bool
          f g form = isListL (toListL (g form))
      property f

cInt :: Int -> Code
cInt = toCode

cDouble :: Double -> Code
cDouble = toCode

numTest :: Spec
numTest =
  describe "Num instance for Code" $ do
    it "should evaluate +" $ do
      cInt 2 + cInt 40 `shouldBe` 42
      cInt 2 + cDouble 40 `shouldBe` 42.0
      cDouble 2 + cInt 40 `shouldBe` 42.0
      cDouble 2.0 + cDouble 40.0 `shouldBe` 42.0
    it "should evaluate * for AInteger" $ do
      cInt 6 * cInt 7  `shouldBe` 42
      cDouble 6 * cDouble 7 `shouldBe` 42.0
    it "should evalue - for AInteger" $ do
      cInt 50 - cInt 8 `shouldBe` 42
      cDouble 50 - cDouble 8 `shouldBe` 42.0
    it "should evaluate abs" $ do
      abs (cInt (-42)) `shouldBe` 42
      abs (cDouble (-42)) `shouldBe` 42.0
    it "should evaluate signum" $ do
      signum (cInt (-42)) `shouldBe` -1
      signum (cDouble (-42)) `shouldBe` -1.0
    it "should evaluate fromInteger" $
      fromInteger 42 `shouldBe` cInt 42
    it "should result to nil with invalid values" $ do
      3 + toCode 'a' `shouldBe` nil
      signum (toCode 'a') `shouldBe` nil

fractionalTest :: Spec
fractionalTest =
  describe "Fractional instance for Code" $ do
    it "should evaluate /" $ do
      cInt 84 / cInt 2 `shouldBe` 42.0
      cDouble 84.0 / cDouble 2.0 `shouldBe` 42.0
    it "should evaluate recip" $ do
      recip (cInt 4) `shouldBe` 0.25
      recip (cDouble 4.0) `shouldBe` 0.25

monoidTest :: Spec
monoidTest = do
  let a = toCode 'a'
      b = toCode 'b'
      lst = toCode (List [a,b])
      hslst = toCode (HsList [a,b])
  describe "Atom <> XXX" $ do
    it "should result in '(a b)" $
      a <> b `shouldBe` lst
    it "should result in '(a a b)" $
      a <> lst `shouldBe` toCode (List [a,a,b])
    it "should result in '(a a b)" $
      a <> hslst `shouldBe` toCode (List [a,a,b])
  describe "List <> XXX" $ do
    it "should result in '(a b a)" $
      lst <> a `shouldBe` toCode (List [a,b,a])
    it "should result in '(a b a b)" $
      lst <> lst `shouldBe` toCode (List [a,b,a,b])
    it "should result in '(a b a b)" $
      lst <> hslst `shouldBe` toCode (List [a,b,a,b])
  describe "HsList <> XXX" $ do
    it "should result in '(a b a)" $
      hslst <> a `shouldBe` toCode (List [a,b,a])
    it "should result in '(a b a b)" $
      hslst <> lst `shouldBe` toCode (List [a,b,a,b])
    it "should result in '(a b a b)" $
      hslst <> hslst `shouldBe` toCode (List [a,b,a,b])
  describe "TEnd" $ do
    it "should result in non-TEnd" $ do
      let at = Atom True
      at <> TEnd `shouldBe` at
      TEnd <> at `shouldBe` at
  describe "mempty" $ do
    it "should be empty list" $
      mempty `shouldBe` (List [] :: Form Atom)
    it "should be nil" $
      mempty `shouldBe` nil

alternativeTest :: Spec
alternativeTest =
  describe "Alternative" $ do
    describe "empty" $ do
      it "should be nil for Code" $
        empty `shouldBe` nil
      it "should be empty form for Form" $
        empty `shouldBe` (mempty :: Form Atom)
    describe "<|>" $ do
      let a = toCode 'a'
          b = toCode 'b'
          c = toCode 'c'
      it "should append elements for Code" $
        let ab = toCode (List [a,b])
            cb = toCode (List [c,b])
        in  ab <|> cb `shouldBe` toCode (List [a,b,c,b])
      it "should append elements for Form Atom" $
        let ab = List [a,b]
            cb = List [c,b]
        in  ab <|> cb `shouldBe` List [a,b,c,b]

data Foo = Foo deriving (Eq, Show)

instance Homoiconic Foo where
  toCode foo = toCode (aSymbol (show foo))
  parseCode _ = Homoiconic.Failure "Foo"

fromCodeTest :: Spec
fromCodeTest = do
  describe "default toCode implementation" $
    it "should return Nothing" $
      (fromCode nil :: Maybe Foo) `shouldBe` Nothing

  describe "getting Nothing from fromCode" $ do
    let ng title x = it title $ x `shouldBe` Nothing
        q x = qSymbol x "" 0 0 0 0
        foo = q "foo"
        foo1 = qList [q "Foo", q "a"] "" 0 0 0 0
        foo2 = qList [q "Foo", q "a", q "b"] "" 0 0 0 0

    it "should result to Nothing with explicit Nothing" $ do
      fromCode (q "Nothing") `shouldBe` (Just Nothing :: Maybe (Maybe ()))
      toCode (Nothing :: Maybe ()) `shouldBe` q "Nothing"

    ng "()" (fromCode foo :: Maybe ())
    ng "Int" (fromCode foo :: Maybe Int)
    ng "Char" (fromCode nil :: Maybe Char)
    ng "[Int]" (fromCode nil :: Maybe [Int])
    ng "[Char]" (fromCode foo :: Maybe [Char])
    ng "Bool" (fromCode foo :: Maybe Bool)
    ng "Ordering" (fromCode foo :: Maybe Ordering)
    ng "Maybe ()" (fromCode foo1 :: Maybe (Maybe ()))
    ng "Either String ()" (fromCode foo1 :: Maybe (Either String ()))
    ng "(,)" (fromCode foo :: Maybe ((), ()))
    ng "(,,)" (fromCode foo :: Maybe ((), (), ()))
    ng "(,,,)" (fromCode foo :: Maybe ((), (), (), ()))
    ng "(,,,,)" (fromCode foo :: Maybe ((), (), (), (), ()))
    ng "(,,,,,)" (fromCode foo :: Maybe ((), (), (), (), (), ()))
    ng "Data.Functor.Sum.Sum Maybe (Either String) ()"
       (fromCode foo1 :: Maybe (Sum.Sum Maybe (Either String) ()))
    ng "Data.Functor.Product.Product Maybe (Either String) ()"
       (fromCode foo2 :: Maybe (Product.Product Maybe (Either String) ()))
    ng "Sum ()" (fromCode foo1 :: Maybe (Sum ()))
    ng "Proxy ()" (fromCode foo :: Maybe (Proxy ()))
    ng "Atom" (fromCode foo1 :: Maybe Atom)

fromCodeErrorTest :: Spec
fromCodeErrorTest = do
  let err :: Homoiconic a => a -> String -> Spec
      err a ty = it ("should show error message containing " ++ ty) $ do
        case parseCode x `asTypeOf` Homoiconic.Success a of
          Homoiconic.Failure e -> e `shouldSatisfy` isSubsequenceOf ty
          _           -> expectationFailure "parser unexpectedly succeeded"
      x = toCode (List [ toCode (aSymbol "foo")
                       , toCode (aSymbol "x") ])
  describe "Failing to parse Code" $ do
    err (1 :: Integer) "integral"
    err (1 :: Double) "fractional"
    err () "()"
    err 'a' "Char"
    err "string" "String"
    err False "Bool"
    err EQ "Ordering"
    err (Just False) "Maybe"
    err (Right True `asTypeOf` Left "foo") "Either"
    err ((),()) ","
    err ((),(),()) "(,,)"
    err ((),(),(),()) "(,,,)"
    err ((),(),(),(),()) "(,,,,)"
    err ((),(),(),(),(),()) "(,,,,,)"
    err (Sum.InL (Just True) `asTypeOf` Sum.InR (Just False)) "Sum"
    err (All True) "All"
    err (Proxy :: Proxy Int) "Proxy"
    err (aSymbol "foo") "Atom"

data D1 = D1a | D1b | D1c
  deriving (Eq, Show, Data, Typeable, Generic)

instance Homoiconic D1
instance Arbitrary D1 where
  arbitrary = oneof (map pure [D1a, D1b, D1c])

data D2 a = D2a a | D2b a a
  deriving (Eq, Show, Data, Typeable, Generic)

instance Homoiconic a => Homoiconic (D2 a)
instance Arbitrary a => Arbitrary (D2 a) where
  arbitrary = oneof [D2a <$> arbitrary, D2b <$> arbitrary <*> arbitrary]

data D3 a b = D3a Int a b
  deriving (Eq, Show, Data, Typeable, Generic)

instance (Homoiconic a, Homoiconic b) => Homoiconic (D3 a b)
instance (Arbitrary a, Arbitrary b) => Arbitrary (D3 a b) where
  arbitrary = D3a <$> arbitrary <*> arbitrary <*> arbitrary

data D4 a = D4a (a, a, a, a)
  deriving (Eq, Show, Data, Typeable, Generic)

instance Homoiconic a => Homoiconic (D4 a)
instance Arbitrary a => Arbitrary (D4 a) where
  arbitrary =
    D4a <$> ((,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary)

dataToCodeTest :: Spec
dataToCodeTest = do
  let s = toCode . aSymbol
  describe "D1 to Code" $
    it "should match D1 values" $ do
      let e1a = s "D1a"
          e1b = s "D1b"
          e1c = s "D1c"
      dataToCode D1a `shouldBe` e1a
      dataToCode D1b `shouldBe` e1b
      dataToCode D1c `shouldBe` e1c
  describe "D2 to Code" $
    it "should match `D2 Char' values"$ do
      let e2a = toCode (List [s "D2a", toCode 'x'])
          e2b = toCode (List [s "D2b", toCode 'y', toCode 'z'])
      dataToCode (D2a 'x') `shouldBe` e2a
      dataToCode (D2b 'y' 'z') `shouldBe` e2b
  describe "D2 with D1 to Code" $
    it "should match `D2 D1' values" $ do
      let e2b = toCode (List [s "D2b", s "D1a", s "D1b"])
      dataToCode (D2b D1a D1b) `shouldBe` e2b
  describe "D2 with Double to Code" $
    it "should match `D2 Double' values" $ do
      let e2c = toCode (List [s "D2a", toCode (1.23 :: Double)])
      dataToCode (D2a (1.23 :: Double)) `shouldBe` e2c
  describe "D3 to Code" $
    it "should match `D3' value" $ do
      let e3 = toCode (List [ s "D3a"
                            , toCode (42 :: Int)
                            , toCode False
                            , toCode 'a' ])
      dataToCode (D3a 42 False 'a') `shouldBe` e3
  describe "D4 to Code" $
    it "should match `D4' value" $ do
       let e4 = toCode (List [ s "D4a"
                             , toCode (List [ s ","
                                            , toCode 'w'
                                            , toCode 'x'
                                            , toCode 'y'
                                            , toCode 'z'])])
       dataToCode (D4a ('w', 'x', 'y', 'z')) `shouldBe` e4

genericHomoiconicTest :: Spec
genericHomoiconicTest = do
  describe "Result data type for parsing" $ do
    let s1, s2, f1 :: Homoiconic.Result Bool
        s1 = Homoiconic.Success True
        s2 = Homoiconic.Success False
        f1 = Homoiconic.Failure "foo"
    it "should equal to itself" $ do
      s1 `shouldBe` s1
      s1 `shouldNotBe` s2
      f1 `shouldNotBe` s2
    it "should show its conteints" $ do
      show s1 `shouldBe` "Success True"
      show f1 `shouldBe` "Failure \"foo\""
    let isFailure (Homoiconic.Failure _) = True
        isFailure _                      = False
    it "should fail on binding Failure" $
      ((Homoiconic.Failure "X_X" >>= pure) :: Homoiconic.Result Bool)
        `shouldSatisfy` isFailure

  describe "parseCode failure" $ do
    let d2a_sym = toCode $ aSymbol "D2a"
        d3a_sym = toCode $ aSymbol "D3a"
        unit_sym = toCode ()
        fail_with substring r = case r of
          Homoiconic.Failure msg -> substring `isSubsequenceOf` msg
          _                      -> False

    it "should fail on non list Code" $ do
      let r = parseCode @(D2 ()) d2a_sym
      r `shouldSatisfy` fail_with "Not a list"
    it "should fail on unexpected field constructor" $ do
      let r = parseCode @(D3 (D2 Bool) Bool) x
          x = toCode (List [d3a_sym, unit_sym])
      r `shouldSatisfy` fail_with "()"
    it "should fail on unexpected leftover values" $ do
      let r = parseCode @(D2 ()) x
          x = toCode (List [d2a_sym, unit_sym, unit_sym])
      r `shouldSatisfy` fail_with "leftover"
    it "should fail on invalid constructor (no arg)" $ do
      let r = parseCode @FormTest.D1 (toCode (aSymbol "foo"))
      r `shouldSatisfy` fail_with "foo"
    it "should fail on invalid constructor (with args)" $ do
      let r = parseCode @(D2 Bool) (toCode (List [toCode (aSymbol "foo")]))
      r `shouldSatisfy` fail_with "foo"

  describe "genericFromCode" $ do
    it "should result in Code value" $ do
      let d2 :: D2 Int
          d2 = D2a 42
      genericFromCode (toCode d2) `shouldBe` Just d2
    it "should fail with invalid value" $ do
      genericFromCode (toCode ()) `shouldBe` (Nothing :: Maybe (D2 Int))

  describe "To/from code via Generic" $ do
    it "should return itself" $
      let g_to_from :: D4 (D3 (D2 Int) D1) -> Bool
          g_to_from x = Just x == fromCode (toCode x)
      in  property g_to_from
    it "should return itself with nested Maybe data type" $
      let g_to_from :: D3 (Maybe (Maybe (Maybe Int))) (Maybe (Maybe Bool))
                    -> Bool
          g_to_from x = Just x == fromCode (toCode x)
      in  property g_to_from

  let s = toCode . aSymbol
      noParse :: (Eq a, Show a, Homoiconic a) => Maybe a -> IO ()
      noParse = (`shouldBe` Nothing)

  describe "Malformed codes via Generic" $ do
    it "result to Nothing with invalid constructor" $
      noParse (fromCode (s "Foo") :: Maybe D1)
    it "result to Nothing with arity mismatch" $
      noParse
        (fromCode (toCode (List [s "D2a", toCode False, toCode False]))
          :: Maybe (D2 Bool))
    it "result to Nothing with invalid field value" $
      noParse
        (fromCode (toCode (List [s "D2a", s "FOO"])) :: Maybe (D2 Bool))
    it "result to Nothing with non list" $
      noParse (fromCode (toCode "FOO") :: Maybe (D2 Bool))
    it "result to Nothing with invalid form" $
      noParse
        (fromCode (toCode (List [s "D2a", toCode (List [s "Just", s "___"])]))
           :: Maybe (D2 (Maybe Bool)))

unquoteSpliceTest :: Spec
unquoteSpliceTest =
  describe "unquote splicing List" $
    it "should return list contents" $
      property
        (\form ->
           (isListL form || isHsListL form ||
            isStringL form || isUnitL form)
           ==> (0 <= length (unquoteSplice form)))

eqForm :: Code -> Code -> Bool
eqForm a b =
  case (unCode a, unCode b) of
    -- Ignoring rounding error for fractional literals.
    (Atom (AFractional x), Atom (AFractional y))
      -> abs (fl_value x - fl_value y) <= toRational epsilon

    -- Recursively compare with `eqForm' for 'List' and 'HsList'.
    (List [], List []) -> True
    (List (x:xs), List (y:ys)) ->
      let ql z = qList z "" 0 0 0 0
      in  eqForm x y && eqForm (ql xs) (ql ys)

    (HsList [], HsList []) -> True
    (HsList (x:xs), HsList (y:ys)) ->
      let qh z = qHsList z "" 0 0 0 0
      in  eqForm x y && eqForm (qh xs) (qh ys)

    -- Treating empty 'List' and Atom symbol 'nil' as same value.
    (Atom (ASymbol sym), List []) | sym == fsLit "nil" -> True
    (List [], Atom (ASymbol sym)) | sym == fsLit "nil" -> True

    -- Using '==' for other Atom values.
    (Atom x, Atom y) -> x == y

    _ -> False
  where
    epsilon :: Double
    epsilon = 1e-7

pprTest :: Spec
pprTest =
  describe "ppr" $
    it "should return expected String" $ do
      let str0 = "(1 2.34 () #'a \"foo\" [foo bar buzz])"
      str1 <- runPpr str0
      str1 `shouldBe` str0

runPpr :: String -> IO String
runPpr str =
  runFnk (do dflags <- getDynFlags
             return (showPpr dflags (parseE str)))
         defaultFnkEnv

parseE :: String -> Code
parseE = parseE' Nothing

parseE' :: Maybe FilePath -> String -> Code
parseE' mb_path str =
  let inp = stringToStringBuffer str
  in  case runSP sexpr mb_path inp of
        Right (expr, _) -> expr
        Left err        -> error (show err)

isListL :: Code -> Bool
isListL (LForm (L _ (List _))) = True
isListL _                      = False

isHsListL :: Code -> Bool
isHsListL (LForm (L _ (HsList _))) = True
isHsListL _                        = False

isStringL :: Code -> Bool
isStringL (LForm (L _ (Atom (AString _ _)))) = True
isStringL _                                  = False

isUnitL :: Code -> Bool
isUnitL (LForm (L _ (Atom AUnit))) = True
isUnitL _                          = False


-- |
-- Module      : BattleHack.Events
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental
-- Portability : POSIX

-- Created September 12 2015

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC pragmas
--------------------------------------------------------------------------------------------------------------------------------------------
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module BattleHack.Events where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Text.Printf
import Data.IORef
import Data.Complex
import Data.List
import Data.Maybe
import Data.Functor

-- import qualified Data.Aeson as JSON

import qualified Data.Text as T
import qualified Data.Map  as M
import qualified Data.Set  as S

import Control.Lens
import Control.Monad (liftM, forM, void, when, unless, liftM)
import Control.Applicative
import Control.Concurrent

import Graphics.UI.Gtk
import qualified Graphics.Rendering.Cairo as Cairo

import Sound.OpenAL

import BattleHack.Types
import BattleHack.Lenses
import BattleHack.Utilities.General
import BattleHack.Utilities.Vector
import BattleHack.Utilities.Math
import qualified BattleHack.Piano  as Piano
import qualified BattleHack.Audio  as Audio
import qualified BattleHack.Render as Render

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------
-- |
onanimate :: DrawingArea -> IORef AppState -> IO Bool
onanimate canvas stateref = do
  widgetQueueDraw canvas
  modifyIORef stateref (animation.frame %~ (+1)) -- Increment frame count
  return True

-- |
ondraw :: IORef AppState -> Cairo.Render ()
ondraw stateref = do
  appstate <- Cairo.liftIO $ readIORef stateref
  -- Render.overlay    $ appstate         --
  Render.claviature $ appstate-->piano --
  Render.debugHUD   $ appstate         --
  -- Render.radial     $ appstate         --
  -- Render.sinewave   $ appstate         -- Just for shits and giggles

-- |
ondelete :: IORef AppState -> EventM EAny Bool
ondelete stateref = Cairo.liftIO $ do
  putStrLn "Good bye"
  mainQuit
  return False

-- |
-- TODO: Capture mouse drag
onmousemotion :: IORef AppState -> EventM EMotion Bool
onmousemotion stateref = do
  mouse' <- liftM tovector eventCoordinates
  Cairo.liftIO $ do
    appstate <- readIORef stateref
    modifyIORef stateref (piano.active     .~ Piano.findKeyAt mouse' (appstate-->piano))
    modifyIORef stateref (inputstate.mouse .~ mouse')
  return False

-- |
-- Do yourself a favour and pretend you never saw this mess
onmousedown :: IORef AppState -> EventM EButton Bool
onmousedown stateref = do
  Cairo.liftIO $ do
    appstate <- readIORef stateref
    perhaps pass (appstate-->piano.active) $ \i -> do
      -- loopingMode (_source appstate) $= [OneShot, Looping] !! 1 -- Easy toggling
      -- void . forkIO $ Audio.note (_source appstate) (Piano.pitchFromKeyIndex ikey) 1.0 -- TODO: Do not hard code duration
      -- void $ Audio.playnote (appstate-->claviature) i
      modifyIORef stateref (piano.keys.ix i .~ True)
  return False

-- |
onmouseup :: IORef AppState -> EventM EButton Bool
onmouseup stateref = do
  -- TODO: Implement note press and release properly
  -- source <- Cairo.liftIO $ liftM _source $ readIORef stateref
  Cairo.liftIO $ do
    appstate <- readIORef stateref
    perhaps pass (appstate-->piano.active) $ \i -> do
      modifyIORef stateref (piano.keys.ix i .~ False)
      -- return expressionvoid $ Audio.stopnote (appstate-->claviature) i
  return False

-- |
onwheelscrool :: IORef AppState -> EventM EScroll Bool
onwheelscrool stateref = do
  direction <- eventScrollDirection
  Cairo.liftIO $ do
    modifyIORef stateref (piano.origin %~ panX direction)
  return False
  where
    panX ScrollUp   = (+ ((-5.0):+0.0))
    panX ScrollDown = (+ (( 5.0):+0.0))

-- |
-- TODO: Helpers for updating state, checking repeats
onkeydown :: IORef AppState -> EventM EKey Bool
onkeydown stateref = do
  key <- T.unpack <$> eventKeyName -- TODO: Use key val?

  Cairo.liftIO $ do
    -- Do yourself a favour and pretend you never saw this mess
    bindings <- liftM (-->bindings) . readIORef $ stateref
    appstate <- readIORef stateref

    -- Unless the key is already being pressed
    unless (S.member key $ appstate-->inputstate.keyboard) $ do
      modifyIORef stateref (inputstate.keyboard %~ S.insert key) -- Mark key as pressed
      fromMaybe pass (M.lookup key bindings)                     -- Invoke the command bound to this key (if any)

      perhaps pass (noteIndexFromKey key) $ \i -> do
        appstate <- readIORef stateref
        modifyIORef stateref (piano.keys.ix i .~ True)
        -- void $ Audio.playnote (appstate-->claviature) i

  return False

-- |
-- TODO: Implement note press and release properly
onkeyup :: IORef AppState -> EventM EKey Bool
onkeyup stateref = do
  key <- T.unpack <$> eventKeyName -- TODO: Use key val?
  Cairo.liftIO $ do
    appstate <- readIORef stateref
    modifyIORef stateref (inputstate.keyboard %~ S.delete key) -- Mark key as pressed
    perhaps pass (noteIndexFromKey key) $ \i -> do
      -- Audio.stopnote (appstate-->claviature) i
      modifyIORef stateref (piano.keys.ix i .~ False)

  return False

-- Utilities -------------------------------------------------------------------------------------------------------------------------------
-- |
-- TODO: Don't use 'head' (decapitations are dangerous)
-- TODO: Move out key bindings (eg. to JSON file)
-- TODO: Range should be a setting
noteIndexFromKey :: String -> Maybe Int
noteIndexFromKey key = M.lookup (head key) mapping -- TODO: Factor out
  where
    mapping = M.fromList $ zip "asdfghjklöä" Piano.allnaturals ++ zip "wetyupå"  Piano.allaccidentals


{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DefaultSignatures   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}
-- | Module containing 'Homoiconic' and 'FromCode' type classes and its instance
-- declarations.
module Language.Finkel.Homoiconic
  ( -- * Homoiconic class
    Homoiconic(..)
  , fromCode
  , Result(..)

    -- * Generic functions
  , genericToCode
  , genericFromCode
  , genericParseCode

    -- * Generic classes
  , GToCode(..)
  , GParseCode(..)

    -- * Data.Data function
  , dataToCode
  ) where

#include "ghc_modules.h"

-- base
import           Control.Applicative             (Alternative (..))
import           Data.Complex                    (Complex (..))
import           Data.Data
import           Data.Fixed                      (Fixed (..))
import           Data.Functor.Compose            (Compose (..))
import           Data.Functor.Const              (Const (..))
import           Data.Functor.Identity           (Identity (..))
import           Data.Int                        (Int16, Int32, Int64, Int8)
import           Data.List.NonEmpty              (NonEmpty (..))
import           Data.Monoid                     (All (..), Alt (..), Any (..),
                                                  Dual (..), First (..),
                                                  Last (..), Product (..),
                                                  Sum (..))
import           Data.Ratio                      (Ratio, denominator, numerator,
                                                  (%))
import           Data.Version                    (Version (..))
import           Data.Word                       (Word16, Word32, Word64, Word8)
import           GHC.Generics                    (C, Constructor (..), D,
                                                  Generic (..), K1 (..),
                                                  M1 (..), S, U1 (..), V1,
                                                  (:*:) (..), (:+:) (..))
import           Numeric.Natural                 (Natural)

import qualified Data.Functor.Product            as Product
import qualified Data.Functor.Sum                as Sum
import qualified Data.Semigroup                  as Semigroup

#if !MIN_VERSION_ghc(8,8,0)
import           Control.Monad.Fail              (MonadFail (..))
import           Prelude                         hiding (fail)
#endif

-- ghc
import           GHC_Data_FastString             (FastString, unpackFS)
import           GHC_Types_SrcLoc                (GenLocated (..), SrcSpan,
                                                  getLoc)

-- Internal
import           Language.Finkel.Form

-- -------------------------------------------------------------------
--
-- Homoiconic type class
--
-- -------------------------------------------------------------------

-- | Class for handling Haskell value as 'Code'.
--
-- Instance of 'Homoiconic' should satisfy the law:
--
-- @
-- 'parseCode' ('toCode' x) ≡ 'Success' x
-- @
--
-- The function 'listToCode' and 'parseHsListCode' are used when handling
-- Haskell list values specially (e.g., 'Char'). These functions have default
-- implementations, which simply applies 'toCode' to elements of the argument
-- list, and which parses elements of 'HsList', respectively.
--
-- One can implement 'Homoiconic' instance with 'GHC.Generics.Generic', e.g.:
--
-- @
-- {-# LANGUAGE DeriveGeneric #-}
--
-- data MyData
--   = MyInt Int
--   | MyChar Char
--   deriving (Generic)
--
-- instance Homoiconic MyData
-- @
--
-- Sample snippet using above @MyData@:
--
-- >>> toCode (MyInt 42)
-- (MyInt 42)
-- >>> fromCode (toCode (MyChar 'a')) :: Maybe MyData
-- Just (MyChar 'a')
---
class Homoiconic a where
  -- | Convert Haskell value to 'Code'.
  toCode :: a -> Code
  {-# INLINE toCode #-}

  default toCode :: (Generic a, GToCode (Rep a)) => a -> Code
  toCode = genericToCode

  -- | Convert list of Haskell values to 'Code'.
  listToCode :: [a] -> Code
  listToCode xs =
     let xs' = map toCode xs
         l = getLoc (mkLocatedForm xs')
     in  LForm (L l (HsList xs'))
  {-# INLINE listToCode #-}

  -- | Convert 'Code' to Haskell value, or 'Failure' if the code could
  -- not be converted.
  parseCode :: Code -> Result a
  {-# INLINE parseCode #-}

  default parseCode :: (Generic a, GParseCode (Rep a)) => Code -> Result a
  parseCode = genericParseCode

  -- | Convert 'Code' to list of Haskell values, or 'Failure' if the code
  -- could not be converted.
  parseHsListCode :: Code -> Result [a]
  parseHsListCode xs =
    case unCode xs of
      HsList as -> mapM parseCode as
      _         -> fail "got non HsList value"
  {-# INLINE parseHsListCode #-}

-- | Like 'parseCode', but the result wrapped with 'Maybe' instead of 'Result'.
fromCode :: Homoiconic a => Code -> Maybe a
fromCode code = case parseCode code of
  Success a -> Just a
  _         -> Nothing

-- -------------------------------------------------------------------
--
-- Instances of Homoiconic
--
-- -------------------------------------------------------------------

--
-- Prelude
--

instance Homoiconic () where
  toCode _ = LForm (genSrc (Atom AUnit))
  parseCode a =
    case unCode a of
      Atom AUnit -> pure ()
      _          -> failedToParse "()"

instance Homoiconic Char where
  toCode = LForm . genSrc . Atom . AChar NoSourceText
  listToCode = LForm . genSrc . Atom . aString NoSourceText
  parseCode a =
    case unCode a of
      Atom (AChar _ x) -> pure x
      _                -> failedToParse "Char"
  parseHsListCode a = case unCode a of
                      Atom (AString _ s) -> pure (unpackFS s)
                      _                  -> failedToParse "String"

instance Homoiconic Int where
  toCode = integralToCode
  parseCode = integralFromCode

instance Homoiconic Word where
  toCode = integralToCode
  parseCode = integralFromCode

instance Homoiconic Integer where
  toCode = integralToCode
  parseCode = integralFromCode

instance Homoiconic Float where
  toCode = realFracToCode
  parseCode = fractionalFromCode

instance Homoiconic Double where
  toCode = realFracToCode
  parseCode = fractionalFromCode

instance Homoiconic a => Homoiconic [a] where
  toCode = listToCode
  parseCode = parseHsListCode

instance Homoiconic Bool where
  toCode = showAsSymbolCode
  parseCode a =
    case unCode a of
      Atom (ASymbol sym) | sym == "True"  -> pure True
                         | sym == "False" -> pure False
      _                                   -> failedToParse "Bool"

instance Homoiconic Ordering where
  toCode = showAsSymbolCode
  parseCode a =
    case unCode a of
      Atom (ASymbol sym) | sym == "EQ" -> pure EQ
                         | sym == "LT" -> pure LT
                         | sym == "GT" -> pure GT
      _                                -> failedToParse "Ordering"

instance Homoiconic a => Homoiconic (Maybe a) where
  toCode a =
    case a of
      Nothing -> toCode (aSymbol "Nothing")
      Just x  -> toCode1 "Just" x
  parseCode a =
    case unCode a of
      Atom (ASymbol "Nothing")                      -> pure Nothing
      List [LForm (L _ (Atom (ASymbol "Just"))), x] -> pure <$> parseCode x
      _                                             -> failedToParse "Maybe"

instance (Homoiconic a, Homoiconic b) => Homoiconic (Either a b) where
  toCode a =
    case a of
      Right x -> toCode1 "Right" x
      Left x  -> toCode1 "Left" x
  parseCode a =
    case unCode a of
      List [LForm (L _ (Atom (ASymbol x))), y]
        | x == "Right" -> fmap Right (parseCode y)
        | x == "Left"  -> fmap Left (parseCode y)
      _                -> failedToParse "Either"

instance (Homoiconic a, Homoiconic b) => Homoiconic (a, b) where
  toCode (a1, a2) = toCode2 "," a1 a2
  parseCode = parseCode2 "," (,)

instance (Homoiconic a, Homoiconic b, Homoiconic c)
         => Homoiconic (a, b, c) where
  toCode (a1, a2, a3) =
    toCode (List [symbolCode ",", toCode a1, toCode a2, toCode a3])
  parseCode a =
    case unCode a of
      List [LForm (L _ (Atom (ASymbol ","))), a1, a2, a3]
        -> (,,) <$> parseCode a1 <*> parseCode a2 <*> parseCode a3
      _ -> failedToParse "(,,)"

instance (Homoiconic a, Homoiconic b, Homoiconic c, Homoiconic d)
         => Homoiconic (a, b, c, d) where
  toCode (a1, a2, a3, a4) =
    toCode (List [ symbolCode ",", toCode a1, toCode a2, toCode a3
                 , toCode a4])
  parseCode a =
    case unCode a of
      List [LForm (L _ (Atom (ASymbol ","))), a1, a2, a3, a4]
        -> (,,,) <$>
           parseCode a1 <*> parseCode a2 <*> parseCode a3 <*> parseCode a4
      _ -> failedToParse "(,,,)"

instance (Homoiconic a, Homoiconic b, Homoiconic c, Homoiconic d, Homoiconic e)
         => Homoiconic (a, b, c, d, e) where
  toCode (a1, a2, a3, a4, a5) =
    toCode (List [ symbolCode ",", toCode a1, toCode a2, toCode a3
                 , toCode a4, toCode a5])
  parseCode a =
    case unCode a of
      List [LForm (L _ (Atom (ASymbol ","))), a1, a2, a3, a4, a5]
        -> (,,,,) <$>
           parseCode a1 <*> parseCode a2 <*> parseCode a3 <*>
           parseCode a4 <*> parseCode a5
      _ -> failedToParse "(,,,,)"

instance (Homoiconic a, Homoiconic b, Homoiconic c, Homoiconic d, Homoiconic e, Homoiconic f)
         => Homoiconic (a, b, c, d, e, f) where
  toCode (a1, a2, a3, a4, a5, a6) =
    toCode (List [ symbolCode ",", toCode a1, toCode a2, toCode a3
                 , toCode a4, toCode a5, toCode a6])
  parseCode a =
    case unCode a of
      List [LForm (L _ (Atom (ASymbol ","))), a1, a2, a3, a4, a5, a6]
        -> (,,,,,) <$>
           parseCode a1 <*> parseCode a2 <*> parseCode a3 <*>
           parseCode a4 <*> parseCode a5 <*> parseCode a6
      _ -> failedToParse "(,,,,,)"

--
-- Data.Complex
--

instance Homoiconic a => Homoiconic (Complex a) where
  toCode (a :+ b) = toCode2 ":+" a b
  parseCode = parseCode2 ":+" (:+)

--
-- Data.Fixed
--

instance Homoiconic (Fixed a) where
  toCode (MkFixed a) = toCode1 "MkFixed" a
  parseCode = parseCode1 "MkFixed" MkFixed

--
-- Data.Functor.Compose

instance Homoiconic (f (g a)) => Homoiconic (Compose f g a) where
  toCode (Compose a) = toCode1 "Compose" a
  parseCode = parseCode1 "Compose" Compose

--
-- Data.Functor.Const
--

instance Homoiconic a => Homoiconic (Const a b) where
  toCode (Const a) = toCode1 "Const" a
  parseCode = parseCode1 "Const" Const

--
-- Data.Functor.Identity
--

instance Homoiconic a=> Homoiconic (Identity a) where
  toCode (Identity a) = toCode1 "Identity" a
  parseCode = parseCode1 "Identity" Identity

--
-- Data.Functor.Product
--

instance (Homoiconic (f a), Homoiconic (g a))
         => Homoiconic (Product.Product f g a) where
  toCode (Product.Pair a b) = toCode2 "Pair" a b
  parseCode = parseCode2 "Pair" Product.Pair

--
-- Data.Functor.Sum
--

instance (Homoiconic (f a), Homoiconic (g a)) => Homoiconic (Sum.Sum f g a) where
  toCode a =
    case a of
      Sum.InL x -> toCode1 "InL" x
      Sum.InR x -> toCode1 "InR" x
  parseCode a =
    case unCode a of
      List [LForm (L _ (Atom (ASymbol tag))), b]
        | tag == "InL" -> Sum.InL <$> parseCode b
        | tag == "InR" -> Sum.InR <$> parseCode b
      _ -> failedToParse "Sum"

--
-- Data.Int
--

instance Homoiconic Int8 where
  toCode = integralToCode
  parseCode = integralFromCode

instance Homoiconic Int16 where
  toCode = integralToCode
  parseCode = integralFromCode

instance Homoiconic Int32 where
  toCode = integralToCode
  parseCode = integralFromCode

instance Homoiconic Int64 where
  toCode = integralToCode
  parseCode = integralFromCode

--
-- Data.List.NonEmpty
--

instance Homoiconic a => Homoiconic (NonEmpty a) where
  toCode (a :| as) = toCode2 ":|" a as
  parseCode = parseCode2 ":|" (:|)

--
-- Data.Monoid
--

instance Homoiconic All where
  toCode (All a) = toCode1 "All" a
  parseCode = parseCode1 "All" All

instance Homoiconic (f a) => Homoiconic (Alt f a) where
  toCode (Alt a) = toCode1 "Alt" a
  parseCode = parseCode1 "Alt" Alt

instance Homoiconic Any where
  toCode (Any a) = toCode1 "Any" a
  parseCode = parseCode1 "Any" Any

instance Homoiconic a => Homoiconic (Dual a) where
  toCode (Dual a) = toCode1 "Dual" a
  parseCode = parseCode1 "Dual" Dual

instance Homoiconic a => Homoiconic (First a) where
  toCode (First a) = toCode1 "First" a
  parseCode = parseCode1 "First" First

instance Homoiconic a => Homoiconic (Last a) where
  toCode (Last a) = toCode1 "Last" a
  parseCode = parseCode1 "Last" Last

instance Homoiconic a => Homoiconic (Product a) where
  toCode (Product a) = toCode1 "Product" a
  parseCode = parseCode1 "Product" Product

instance Homoiconic a => Homoiconic (Sum a) where
  toCode (Sum a) = toCode1 "Sum" a
  parseCode = parseCode1 "Sum" Sum

--
-- Data.Proxy
--

instance Homoiconic a => Homoiconic (Proxy a) where
  toCode _ = symbolCode "Proxy"
  parseCode a = case unCode a of
                 Atom (ASymbol "Proxy") -> pure Proxy
                 _                      -> failedToParse "Proxy"

--
-- Data.Version
--

instance Homoiconic Version where
  toCode (Version b t) = toCode2 "Version" b t
  parseCode = parseCode2 "Version" Version

--
-- Data.Ratio
--

instance (Integral a, Homoiconic a) => Homoiconic (Ratio a) where
  toCode a =
    let n = toCode (numerator a)
        d = toCode (denominator a)
    in toCode (List [symbolCode ":%", n, d])
  parseCode = parseCode2 ":%" (%)

--
-- Data.Semigroup
--

instance (Homoiconic a, Homoiconic b) => Homoiconic (Semigroup.Arg a b) where
  toCode (Semigroup.Arg a b) = toCode2 "Arg" a b
  parseCode = parseCode2 "Arg" Semigroup.Arg

instance Homoiconic a => Homoiconic (Semigroup.First a) where
  toCode (Semigroup.First a) = toCode1 "First" a
  parseCode = parseCode1 "First" Semigroup.First

instance Homoiconic a => Homoiconic (Semigroup.Last a) where
  toCode (Semigroup.Last a) = toCode1 "Last" a
  parseCode = parseCode1 "Last" Semigroup.Last

instance Homoiconic a => Homoiconic (Semigroup.Max a) where
  toCode (Semigroup.Max a) = toCode1 "Max" a
  parseCode = parseCode1 "Max" Semigroup.Max

instance Homoiconic a => Homoiconic (Semigroup.Min a) where
  toCode (Semigroup.Min a) = toCode1 "Min" a
  parseCode = parseCode1 "Min" Semigroup.Min

#if !MIN_VERSION_ghc(9,0,0)
instance Homoiconic a => Homoiconic (Semigroup.Option a) where
  toCode (Semigroup.Option a) = toCode1 "Option" a
  parseCode = parseCode1 "Option" Semigroup.Option
#endif

instance Homoiconic a => Homoiconic (Semigroup.WrappedMonoid a) where
  toCode (Semigroup.WrapMonoid a) = toCode1 "WrapMonoid" a
  parseCode = parseCode1 "WrapMonoid" Semigroup.WrapMonoid

--
-- Data.Word
--

instance Homoiconic Word8 where
  toCode = integralToCode
  parseCode = integralFromCode

instance Homoiconic Word16 where
  toCode = integralToCode
  parseCode = integralFromCode

instance Homoiconic Word32 where
  toCode = integralToCode
  parseCode = integralFromCode

instance Homoiconic Word64 where
  toCode = integralToCode
  parseCode = integralFromCode

--
-- Numeric.Natural
--

instance Homoiconic Natural where
  toCode = integralToCode
  parseCode = integralFromCode

--
-- Language.Finkel.Form
--

instance Homoiconic Atom where
  toCode = LForm . genSrc . Atom
  parseCode a =
    case unCode a of
      Atom x -> pure x
      _      -> failedToParse "Atom"

instance Homoiconic (Form Atom) where
  toCode = LForm . genSrc
  parseCode = pure . unCode

instance Homoiconic (LForm Atom) where
  toCode = id
  parseCode = pure

-- -------------------------------------------------------------------
--
-- Generic toCode
--
-- -------------------------------------------------------------------

-- | Generic variant of 'toCode'.
genericToCode :: (Generic a, GToCode (Rep a)) => a -> Code
genericToCode = unCodeArgs . gToCode . from
{-# INLINABLE genericToCode #-}

-- | To distinguish arguments of constructor from non-argument.
data CodeArgs
  = NonArg Code
  | Args [Code]

unCodeArgs :: CodeArgs -> Code
unCodeArgs ca = case ca of
  NonArg c -> c
  Args cs  -> toCode (List cs)
{-# INLINABLE unCodeArgs #-}

instance Semigroup.Semigroup CodeArgs where
  Args xs <> Args ys   = Args (xs Semigroup.<> ys)
  Args xs <> NonArg y  = Args (xs Semigroup.<> [y])
  NonArg x <> Args ys  = Args (x : ys)
  NonArg x <> NonArg y = Args [x, y]
  {-# INLINE (<>) #-}

-- | For making 'Code' with 'Generic' instances.
class GToCode f where
  gToCode :: f a -> CodeArgs

instance GToCode V1 where
  gToCode _ = NonArg undefined
  {-# INLINE gToCode #-}

instance GToCode U1 where
  gToCode U1 = NonArg nil
  {-# INLINE gToCode #-}

instance (GToCode f, GToCode g) => GToCode (f :+: g) where
  gToCode lr = case lr of
    L1 x -> gToCode x
    R1 x -> gToCode x
  {-# INLINE gToCode #-}

instance (GToCode f, GToCode g) => GToCode (f :*: g) where
  gToCode (f :*: g) = gToCode f Semigroup.<> gToCode g
  {-# INLINE gToCode #-}

instance Homoiconic c => GToCode (K1 i c) where
  gToCode (K1 x) = NonArg (toCode x)
  {-# INLINE gToCode #-}

instance GToCode f => GToCode (M1 D c f) where
  gToCode (M1 x) = gToCode x
  {-# INLINE gToCode #-}

instance (Constructor c, GToCode f) => GToCode (M1 C c f) where
  gToCode m1@(M1 x) =
    let constr = toCode (aSymbol (conName m1))
    in  case gToCode x of
      NonArg c -> if null c
        then NonArg constr
        else NonArg (toCode (List [constr, c]))
      Args cs -> NonArg (toCode (List (constr : cs)))
  {-# INLINE gToCode #-}

instance GToCode f => GToCode (M1 S c f) where
  gToCode (M1 x) = gToCode x
  {-# INLINE gToCode #-}

-- -------------------------------------------------------------------
--
-- Generic FromCode
--
-- -------------------------------------------------------------------

-- | Generic variant of 'fromCode'.
genericFromCode :: (Generic a, GParseCode (Rep a)) => Code -> Maybe a
genericFromCode x = case genericParseCode x of
  Success a -> Just a
  _         -> Nothing
{-# INLINABLE genericFromCode #-}

-- | Generic function to get result value from 'Code'.
genericParseCode :: (Generic a, GParseCode (Rep a)) => Code -> Result a
genericParseCode =
  let f a xs = if null xs
                 then pure (to a)
                 else fail "Unexpected leftover"
  in  runCodeP gParseCode fail f
{-# INLINABLE genericParseCode #-}

-- | For getting value from 'Code' with 'Generic' instances.
class GParseCode f where
  gParseCode :: CodeP (f a)

instance GParseCode V1 where
  gParseCode = pure undefined
  {-# INLINE gParseCode #-}

instance GParseCode U1 where
  gParseCode = pure U1
  {-# INLINE gParseCode #-}

instance (GParseCode f, GParseCode g) => GParseCode (f :+: g) where
  gParseCode = fmap L1 gParseCode <|> fmap R1 gParseCode
  {-# INLINE gParseCode #-}

instance (GParseCode f, GParseCode g) => GParseCode (f :*: g) where
  gParseCode = (:*:) <$> gParseCode <*> gParseCode
  {-# INLINE gParseCode #-}

instance Homoiconic c => GParseCode (K1 i c) where
  gParseCode =
    unconsP (\l c cs ->
              case parseCode c of
                Success a -> contP (K1 a) (LForm (L l (List cs)))
                _         -> failP ("Unexpected: " ++ show c))
  {-# INLINE gParseCode #-}

instance GParseCode f => GParseCode (M1 D c f) where
  gParseCode = fmap M1 gParseCode
  {-# INLINE gParseCode #-}

instance {-# OVERLAPPABLE #-} Constructor c => GParseCode (M1 C c U1) where
  gParseCode =
    let c1 :: M1 C c U1 a
        c1 = undefined
    in  eqP (toCode (aSymbol (conName c1))) *> fmap M1 gParseCode
  {-# INLINE gParseCode #-}

instance {-# OVERLAPPABLE #-} (Constructor c, GParseCode f)
  => GParseCode (M1 C c f) where
  gParseCode =
    let c1 :: M1 C c f a
        c1 = undefined
    in  eqCarP (toCode (aSymbol (conName c1))) *> fmap M1 gParseCode
  {-# INLINE gParseCode #-}

instance GParseCode f => GParseCode (M1 S c f) where
  gParseCode = fmap M1 gParseCode
  {-# INLINE gParseCode #-}

-- -------------------------------------------------------------------
--
-- Code parser for GParseCode
--
-- -------------------------------------------------------------------

-- | Dedicated data type to hold parsed result of 'Code'.
--
-- Using dedicated data type when parsing 'Code' data type for 'parseCode'. This
-- data type is intentionally not defined as an instance of 'Homoiconic', so
-- that the user defined data types can tell the parse error from explicit
-- failure constructor of the target type, e,g, 'Nothing' for 'Maybe', 'Left'
-- for 'Either', ... etc.
data Result a
  = Success a
  | Failure String
  deriving (Eq, Show)

instance Functor Result where
  fmap f r = case r of
    Success a -> Success (f a)
    Failure e -> Failure e
  {-# INLINE fmap #-}

instance Applicative Result where
  pure a = Success a
  {-# INLINE pure #-}
  f <*> m = f >>= flip fmap m
  {-# INLINE (<*>) #-}

instance Monad Result where
  m >>= k = case m of
    Success a -> k a
    Failure e -> Failure e
  {-# INLINE (>>=) #-}

instance MonadFail Result where
  fail = Failure
  {-# INLINE fail #-}

failedToParse :: String -> Result a
failedToParse ty = Failure ("Failed to parse " ++ ty)
{-# INLINABLE failedToParse #-}

-- | Simple parser for 'Code'.
newtype CodeP a =
  CodeP {runCodeP :: forall r. (String -> r) -- On failure
                  -> (a -> Code -> r)        -- On success
                  -> Code                    -- Input
                  -> r}

instance Functor CodeP where
  fmap f p = CodeP (\err go -> runCodeP p err (go . f))
  {-# INLINE fmap #-}

instance Applicative CodeP where
  pure a = CodeP (\_ go -> go a)
  {-# INLINE pure #-}

  f <*> p = f >>= flip fmap p
  {-# INLINE (<*>) #-}

instance Monad CodeP where
  m >>= k = CodeP (\err go -> runCodeP m err (\a -> runCodeP (k a) err go))
  {-# INLINE (>>=) #-}

instance Alternative CodeP where
  empty = failP "Alternative.empty"
  {-# INLINE empty #-}

  p1 <|> p2 =
    CodeP (\err go cs ->
            runCodeP p1 (\_ -> runCodeP p2 err go cs) go cs)
  {-# INLINE (<|>) #-}

failP :: String -> CodeP a
failP msg = CodeP (\err _ _ -> err msg)
{-# INLINABLE failP #-}

contP :: a -> Code -> CodeP a
contP a cs = CodeP (\_ go _ -> go a cs)
{-# INLINEABLE contP #-}

unconsP :: (SrcSpan -> Code -> [Code] -> CodeP a) -> CodeP a
unconsP f =
  CodeP (\err go cs ->
    case cs of
      LForm (L l (List (x : xs))) -> runCodeP (f l x xs) err go cs
      _                           -> err "Not a list")
{-# INLINEABLE unconsP #-}

eqP :: Code -> CodeP ()
eqP x =
  CodeP (\err go cs ->
    if cs == x
      then go () nil
      else err ("eqP: unexpected " ++ show cs))
{-# INLINABLE eqP #-}

eqCarP :: Code -> CodeP ()
eqCarP x =
  unconsP (\l c cs ->
             if x == c
               then contP () (LForm (L l (List cs)))
               else failP ("eqCarP: unexpected " ++ show c))
{-# INLINABLE eqCarP #-}

-- -------------------------------------------------------------------
--
-- Data to Code
--
-- -------------------------------------------------------------------

dataToCode :: Data d => d -> Code
dataToCode x =
  let constr = toConstr x
      isTupleStr cs = case cs of
                        '(':cs1 -> go cs1
                        _       -> False
                        where go xs = case xs of
                                        ',':xs' -> go xs'
                                        [')']   -> True
                                        _       -> False
      cstr = case showConstr constr of
               str | isTupleStr str -> ","
                   | otherwise  -> str
      hd = toCode (aSymbol cstr)
  in  case constrRep constr of
         IntConstr n   -> toCode (aIntegral n)
         FloatConstr f -> toCode (aFractional (fromRational f :: Double))
         CharConstr c  -> toCode c
         _             ->
           case gmapQ dataToCode x of
             [] -> hd
             _  -> toCode (List (hd:gmapQ dataToCode x))

-- -------------------------------------------------------------------
--
-- Auxiliary
--
-- -------------------------------------------------------------------

realFracToCode :: (Real a, Show a) => a -> Code
realFracToCode = LForm . genSrc . Atom . aFractional
{-# INLINABLE realFracToCode #-}

fractionalFromCode :: Fractional a => Code -> Result a
fractionalFromCode a =
  case unCode a of
    Atom (AFractional x) -> pure (fromRational (fl_value x))
    _                    -> failedToParse "fractional"
{-# INLINABLE fractionalFromCode #-}

symbolCode :: String -> Code
symbolCode = LForm . genSrc . Atom . aSymbol
{-# INLINABLE symbolCode #-}

showAsSymbolCode :: Show a => a -> Code
showAsSymbolCode = symbolCode . show
{-# INLINABLE showAsSymbolCode #-}

integralToCode :: Integral a => a -> Code
integralToCode = LForm . genSrc . Atom . aIntegral
{-# INLINABLE integralToCode #-}

integralFromCode :: Integral a => Code -> Result a
integralFromCode a =
  case unCode a of
    Atom (AInteger n) -> pure (fromIntegral (il_value n))
    _                 -> failedToParse "integral"

toCode1 :: Homoiconic a => FastString -> a -> Code
toCode1 tag arg1 =
  toCode (List [LForm (genSrc (Atom (ASymbol tag))), toCode arg1])
{-# INLINABLE toCode1 #-}

toCode2 :: (Homoiconic a, Homoiconic b) => FastString -> a -> b -> Code
toCode2 tag arg1 arg2 =
  toCode (List [ LForm (genSrc (Atom (ASymbol tag)))
               , toCode arg1, toCode arg2 ])
{-# INLINABLE toCode2 #-}

parseCode1 :: (Homoiconic a) => FastString -> (a -> h) -> Code -> Result h
parseCode1 tag f a =
  case unCode a of
    List [LForm (L _ (Atom (ASymbol tag'))), x]
      | tag == tag' -> f <$> parseCode x
    _               -> failedToParse (unpackFS tag)
{-# INLINABLE parseCode1 #-}

parseCode2 :: (Homoiconic a, Homoiconic b)
          => FastString -> (a -> b -> h) -> Code -> Result h
parseCode2 tag f a =
  case unCode a of
    List [LForm (L _ (Atom (ASymbol tag'))), x, y]
      | tag == tag' -> f <$> parseCode x <*> parseCode y
    _               -> failedToParse (unpackFS tag)
{-# INLINABLE parseCode2 #-}


module Sondages where

import qualified Data.Text as T
import Data.Time (UTCTime)
import qualified Data.Map as M
import Data.Time.Segment
import Statistics.LinearRegression (linearRegression)
import qualified Data.Vector.Unboxed as U

data Candidat = Macron | LePen | Clinton | Trump
    deriving (Show, Read, Eq, Ord, Enum, Bounded)

data VoteIntention = VoteIntention { unCandidat :: Candidat
                                   , unIntention :: Double
             } deriving (Show, Read, Eq)

data Sondage = Sondage { unSondeur   :: T.Text
                       , unDateBegin :: UTCTime
                       , unDateEnd   :: Maybe UTCTime
                       , echantillon :: Maybe Int
                       , margeErreur :: Maybe Double
                       , abstention  :: Maybe Double
                       , indecis     :: Maybe Double
                       , intentions  :: [(Candidat, Double)]
                       } deriving (Show, Read, Eq)

sondages :: [Sondage]
sondages = [ Sondage "Harris"     (jour 2017 04 23) Nothing                  (Just 2684)   Nothing   Nothing     Nothing            [(Macron, 0.64)]
           , Sondage "Ipsos"      (jour 2017 04 23) Nothing                  (Just 1379)   Nothing   Nothing     Nothing            [(Macron, 0.62)]
           , Sondage "OpinionWay" (jour 2017 04 23) (Just $ jour 2017 04 24) (Just 1461)   Nothing   Nothing     Nothing     [(Macron, 0.61)]
           , Sondage "Ifop"       (jour 2017 04 23) (Just $ jour 2017 04 24) (Just 846)    Nothing  (Just 0.26) (Just 0.12)  [(Macron, 0.60)]
           , Sondage "Harris"     (jour 2017 04 25) (Just $ jour 2017 04 27) (Just 1016)   Nothing   Nothing     Nothing     [(Macron, 0.61)]
           , Sondage "OpinionWay" (jour 2017 04 25) (Just $ jour 2017 04 27) (Just 1500)   Nothing  (Just 0.25)  Nothing     [(Macron, 0.60)]
           , Sondage "Odoxa"      (jour 2017 04 26) (Just $ jour 2017 04 27) (Just 1003)   Nothing  (Just 0.20)   Nothing     [(Macron, 0.59)]
           , Sondage "BVA"        (jour 2017 04 26) (Just $ jour 2017 04 28) (Just 1506)   Nothing  (Just 0.245) (Just 0.15) [(Macron, 0.59)]
           , Sondage "Ipsos"      (jour 2017 04 28) (Just $ jour 2017 04 29) (Just 1504)   Nothing  (Just 0.25)   Nothing     [(Macron, 0.60)]
           , Sondage "Kantar"     (jour 2017 04 28) (Just $ jour 2017 04 30) (Just 1539)   Nothing   Nothing      Nothing     [(Macron, 0.59)]
           , Sondage "Elabe"      (jour 2017 04 28) (Just $ jour 2017 05 02) (Just 3956)   Nothing   Nothing     (Just 0.11)  [(Macron, 0.59)]
           , Sondage "Ifop"       (jour 2017 04 28) (Just $ jour 2017 05 02) (Just 1388)   Nothing  (Just 0.27)   Nothing     [(Macron, 0.595)]
           , Sondage "Cevifop"    (jour 2017 04 30) (Just $ jour 2017 05 01) (Just 13742)  Nothing  (Just 0.24)  (Just 0.15)  [(Macron, 0.59)]
           , Sondage "BVA"        (jour 2017 05 01) (Just $ jour 2017 05 02) (Just 1435)   Nothing  (Just 0.22)   Nothing     [(Macron, 0.60)]
           , Sondage "OpinionWay" (jour 2017 05 02) (Just $ jour 2017 05 04) (Just 1500)   Nothing  (Just 0.25)  (Just 0.15)  [(Macron, 0.62)]
           , Sondage "Elabe"      (jour 2017 05 04)  Nothing                 (Just 1009)   Nothing   Nothing      Nothing     [(Macron, 0.62)]
           , Sondage "Ipsos"      (jour 2017 05 04)  Nothing                 (Just 2632)   Nothing  (Just 0.24)   Nothing     [(Macron, 0.615)]
           , Sondage "Odoxa"      (jour 2017 05 04)  Nothing                 (Just 998)    Nothing  (Just 0.25)  (Just 0.21)  [(Macron, 0.62)]
           , Sondage "Harris"     (jour 2017 05 02) (Just $ jour 2017 05 05) (Just 4991)   Nothing  (Just 0.25)   Nothing     [(Macron, 0.62)]
           , Sondage "Ifop"       (jour 2017 05 02) (Just $ jour 2017 05 05) (Just 1861)   Nothing  (Just 0.245)  Nothing     [(Macron, 0.63)]
           , Sondage "Ipsos"      (jour 2017 05 05)  Nothing                 (Just 5331)   Nothing  (Just 0.24)  Nothing      [(Macron, 0.63)]
           ]

polls :: [Sondage]
polls = [ Sondage "YouGov" (jour 2016 10 22) (Just $ jour 2016 10 26) (Just 1376) (Just 0.031) Nothing Nothing [(Clinton, 0.49), (Trump, 0.46)]
        , Sondage "ABC"    (jour 2016 10 23) (Just $ jour 2016 10 26) (Just 1150) (Just 0.03)  Nothing Nothing [(Clinton, 0.50), (Trump, 0.45)]
        , Sondage "USC"    (jour 2016 10 21) (Just $ jour 2016 10 27) (Just 3248) (Just 0.045) Nothing Nothing [(Clinton, 0.44), (Trump, 0.46)]
        , Sondage "Ipsos"  (jour 2016 10 21) (Just $ jour 2016 10 27) (Just 1627) (Just 0.03)  Nothing Nothing [(Clinton, 0.42), (Trump, 0.36)]
        , Sondage "IBD"    (jour 2016 10 22) (Just $ jour 2016 10 27) (Just 973)  (Just 0.033) Nothing Nothing [(Clinton, 0.45), (Trump, 0.42)]
        , Sondage "ABC"    (jour 2016 10 24) (Just $ jour 2016 10 27) (Just 1148) (Just 0.03)  Nothing Nothing [(Clinton, 0.49), (Trump, 0.46)]
        , Sondage "IBD"    (jour 2016 10 23) (Just $ jour 2016 10 28) (Just 1013) (Just 0.033) Nothing Nothing [(Clinton, 0.46), (Trump, 0.41)]
        , Sondage "ABC"    (jour 2016 10 25) (Just $ jour 2016 10 28) (Just 1160) (Just 0.03)  Nothing Nothing [(Clinton, 0.46), (Trump, 0.45)]
        ]

pollsResult :: [Sondage]
pollsResult = [Sondage "REAL" (jour 2016 11 08) Nothing Nothing Nothing Nothing Nothing [(Clinton, 0.481), (Trump, 0.46)]]

normalizePolls :: [Sondage] -> [Sondage]
normalizePolls xs = Prelude.map normalizePolls' xs
    where
        normalizePolls' (Sondage a b c d e f g is) = Sondage a b c d e f g is'
            where
                is' = Prelude.map (\(m, n) -> (m, n/total)) is
                total = sum $ Prelude.map snd is

sondage2date :: [Sondage] -> [(UTCTime, [(Candidat, Double)])]
sondage2date xs = concat ( map (dureeSondage) xs )
    where
        dureeSondage (Sondage _ begin end _ _ _ _ is) = case end of
                    Nothing   -> zip (timesBetween begin begin D) (repeat is)
                    Just end' -> zip (timesBetween begin end'  D) (repeat is)

toMap :: forall k a. Ord k => [(k, [a])] -> M.Map k [a]
toMap = Prelude.foldr (\s -> M.insertWith (++) (fst s) (snd s)) M.empty

toMap' :: forall k a. Ord k => [(k, a)] -> M.Map k [a]
toMap' = Prelude.foldr (\s -> M.insertWith (++) (fst s) ([snd s])) M.empty

mapSondages :: [Sondage] -> M.Map UTCTime (M.Map Candidat Double)
mapSondages sondage = M.map (M.map mean) $ M.map toMap' $ toMap (sondage2date sondage)
    where
        mean :: [Double] -> Double
        mean xs = (sum xs) / (fromIntegral $ length xs)

predict :: (Double -> Double) -> Int -> [(UTCTime, Double)]
predict f days = predict' sondages f days

predict' :: [Sondage] -> (Double -> Double) -> Int -> [(UTCTime, Double)]
predict' sondes f days = zip dates $ Prelude.map (\x -> f $ a' + b' * x) [1.. (fromIntegral n)]
    where
        sondes' = M.toAscList (mapSondages sondes)
        firstDate = fst $ head sondes'
        n = length sondes' + days
        dates = timesAfter n D firstDate
        (a', b') = linearRegression (U.fromList a) (U.fromList b)
        (a, b) = unzip $ zip ([1..] :: [Double]) $  Prelude.map snd $ concat $ Prelude.map M.toList $ Prelude.map snd sondes'