content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE StaticPointers #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE UndecidableInstances #-}
  
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  module Main where
  
  import Control.Distributed.Closure
  import Control.Distributed.Closure.TH
  import Data.Binary
  import Data.Bool (bool)
  import Data.Typeable
  import GHC.StaticPtr
  import Test.Hspec
  import Test.Hspec.QuickCheck
  import qualified Test.QuickCheck as QC
  
  data T a = T a
  data T1 a b = T1 a b
  data T2 = T2
  
  type family F a
  
  -- Test that the result of this splice compiles.
  withStatic [d|
    instance Show a => Show (T a) where show = undefined
    instance (Eq a, Show a) => Eq (T a) where (==) = undefined
    instance Show (F a) => Show (T1 a b) where show = undefined
    instance Show T2 where show = undefined
    |]
  
  -- * Basic generators (parameterized by size)
  
  -- | Generates a basic closure using @cpure@
  genPure :: forall a. (Static (Serializable a), QC.Arbitrary a) => Int -> QC.Gen (Closure a)
  genPure i =
      cpure (closureDict :: Closure (Dict (Serializable a))) <$>
        QC.resize (max 0 (i-1)) QC.arbitrary
  
  -- | Generates a basic closure using @closure@
  genStatic :: QC.Arbitrary (StaticPtr a) => Int -> QC.Gen (Closure a)
  -- static pointers are considered to contribute 0 to the size, hence ignore the
  -- size parameter.
  genStatic _i = closure <$> QC.arbitrary
  
  -- | Reifies basic datatypes (they must be @Serializable@ types). Only two types
  -- here because we already have to enumerate a lot of cases manually (see below).
  data Type a where
    TInt :: Type Int
    TBool :: Type Bool
  
  instance Static (Binary Int) where closureDict = static Dict
  instance Static (Typeable Int) where closureDict = static Dict
  
  instance Static (Binary Bool) where closureDict = static Dict
  instance Static (Typeable Bool) where closureDict = static Dict
  
  -- | Existentially quantified version of 'Type'. So that they can be generated.
  data AType where AType :: Typeable a => Type a -> AType
  
  instance QC.Arbitrary (AType) where
    arbitrary =
        QC.elements [ AType TInt, AType TBool ]
  
  -- | Composed types. Very few choices because of the combinatorics.
  data Sig a where
    Zero :: Type a -> Sig a
    One :: Type a -> Type b -> Sig (a->b)
    Two :: Type a -> Type b -> Type c -> Sig (a->b->c)
  
  -- | Extend a type with an extra parameter. May fail since functions in 'Sig'
  -- have a maximum of two arguments.
  push :: Type a -> Sig b -> Maybe (Sig (a -> b))
  push a (Zero b) = Just $ One a b
  push a (One b c) = Just $ Two a b c
  push _ (Two _ _ _) = Nothing
  
  -- | Non-recursive generator of atomic values for each type.
  genSimple :: Sig a -> Int -> QC.Gen (Closure a)
  genSimple (Zero TInt) = genPure
  genSimple (Zero TBool) = genPure
  genSimple (One TInt TInt) = genStatic
  genSimple (One TBool TInt) = genStatic
  genSimple (One TInt TBool) = genStatic `gap` genPure @Int
  genSimple (One TBool TBool) = genStatic
  genSimple (Two TInt TInt TInt) = genStatic
  genSimple (Two TBool TInt TInt) = gflip genStatic
  genSimple (Two TInt TBool TInt) = genStatic
  genSimple (Two TBool TBool TInt) = genStatic
  genSimple (Two TInt TInt TBool) = genStatic
  genSimple (Two TBool TInt TBool) = genStatic
  genSimple (Two TInt TBool TBool) = gflip genStatic
  genSimple (Two TBool TBool TBool) = genStatic
  
  gflip
    :: (Typeable a, Typeable b, Typeable c)
    => (Int -> QC.Gen (Closure (a->b->c))) -> Int -> QC.Gen (Closure (b->a->c))
  gflip g i = (cap (static flip)) <$> g i
  
  gap
    :: Typeable a
    => (Int -> QC.Gen (Closure (a->b)))
    -> (Int -> QC.Gen (Closure a))
    -> Int -> QC.Gen (Closure b)
  gap gf gx i = do
    f <- gf i
    x <- gx i
    return $ f `cap` x
  
  -- | Generate closures of a given type by randomly choosing to make the closure
  -- a 'cap'. Stays within the boundaries of 'Sig' so that the type of the
  -- function is also 'QC.Arbitrary'.
  genClosure :: Sig a -> Int -> QC.Gen (Closure a)
  genClosure sig size | size < 10 =
      genSimple sig size
  genClosure sig size = do
      stop <- QC.frequency [(2, return True), (1, return False)]
      if stop then
        genSimple sig size
      else do
        let upper = div size 3
            lower = max 0 (size - 1 - upper)
        AType pivot <- QC.arbitrary
        case push pivot sig of
          Nothing -> genSimple sig size
          Just sig' -> do
            -- if the @size@ is big enough, then 1/3 of the time, if we can extend
            -- the signature, build a closure with @cap@
            function <- genClosure sig' upper
            argument <- genClosure (Zero pivot) lower
            return $ function `cap` argument
  
  -- * Generating static pointers
  --
  -- Must be from explicit lists since static pointers are, well, static. The
  -- combinatorics is unpleasant.
  
  instance QC.Arbitrary (StaticPtr (Int -> Int)) where
    arbitrary =
        QC.elements
          [ static id
          , static pred
          , static succ
          , static (3*)
          ]
  
  instance QC.Arbitrary (StaticPtr (Bool -> Int)) where
    arbitrary =
        QC.elements
         [ static (bool 0 1)
         , static (bool 57 42)]
  
  instance QC.Arbitrary (StaticPtr (Bool -> Bool)) where
    arbitrary =
      QC.elements
        [ static id
        , static not ]
  
  instance QC.Arbitrary (StaticPtr (Int -> Int -> Int)) where
    arbitrary =
        QC.elements
          [ static const
          , static (+)
          , static (*)
          , static (-)
          , static (\x y -> 2*x + y)
          ]
  
  instance QC.Arbitrary (StaticPtr (Int -> Bool -> Int)) where
    arbitrary =
      QC.elements
        [ static const
        , static (\n b -> if b then n else -n)
        , static (bool 0)
        ]
  
  instance QC.Arbitrary (StaticPtr (Bool -> Bool -> Int)) where
    arbitrary =
      QC.elements
        [ static (\x y -> bool 0 1 (x&&y))
        , static (\x y -> bool 57 42 (x||y))
        ]
  
  instance QC.Arbitrary (StaticPtr (Int -> Int -> Bool)) where
    arbitrary =
      QC.elements
        [ static (==)
        , static (>=)
        , static (<=)
        , static (<)
        , static (>)
        ]
  
  instance QC.Arbitrary (StaticPtr (Bool -> Int -> Bool)) where
    arbitrary =
      QC.elements
        [ static const
        , static (\b n -> b && (n >= 0))
        , static (\b n -> b || (n < 0))
        , static (\b n -> if b then n >=0 else n < 0)
        ]
  
  instance QC.Arbitrary (StaticPtr (Bool -> Bool -> Bool)) where
    arbitrary =
      QC.elements
        [ static (&&)
        , static (||)]
  
  -- * Instances
  
  instance QC.Arbitrary (Closure Int) where
    arbitrary = QC.sized $ genClosure (Zero TInt)
  
  instance QC.Arbitrary (Closure (Int -> Int)) where
    arbitrary = QC.sized $ genClosure (One TInt TInt)
  
  instance Show (Closure a) where
    show _ = "<closure>"
  
  instance Show (StaticPtr a) where
    show _ = "<static>"
  
  -- | Extensional equality on closures (/i.e./ closures are equal if they
  -- represent equal values)
  instance Eq a => Eq (Closure a) where
    cl1 == cl2 =
      unclosure cl1 == unclosure cl2
  
  -- * Tests
  
  main :: IO ()
  main = hspec $ do
      describe "unclosure" $ do
        prop "is inverse to cpure" $ \x y z ->
          (unclosure . cpure $cdict) x == (x :: Int) &&
          (unclosure . cpure $cdict) y == (y :: Bool) &&
          (unclosure . cpure $cdict) z == (z :: Maybe Int)
        prop "is inverse to cduplicate" $ \x ->
          (unclosure . cduplicate) x == (x :: Closure Int)
        prop "is inverse to closure of id" $ \(x :: Int) ->
          (unclosure . closure) (static id) x == x
        prop "is inverse to closure" $ \(f :: StaticPtr (Int -> Int))
                                        (x :: Int) ->
          (unclosure . closure) f x == deRefStaticPtr f x
      describe "laws" $ do
        prop "identity" $ \(v :: Closure Int) ->
          unclosure (static id `cap` v) == id (unclosure v)
        prop "composition" $ \(u :: Closure (Int -> Int))
                              (v :: Closure (Int -> Int))
                              (w :: Closure Int) ->
          closure (static (.)) `cap` u `cap` v `cap` w ==
          u `cap` (v `cap` w)
        prop "homomorphism" $ \(f :: Closure (Int -> Int)) x ->
          unclosure (f `cap` x) == (unclosure f) (unclosure x)
  
      describe "serialization" $ do
        prop "decode is left inverse to encode" $ \v ->
            (decode . encode) v == (v :: Closure Int)
  