Cases.hs

{-|
Module      : Test.Multivariant.Types.Cases
Description : Interpreter for corner cases
Copyright   : (c) Anton Marchenko, Mansur Ziatdinov, 2016-2017
License     : BSD-3
Maintainer  : gltronred@gmail.com
Stability   : provisional
Portability : POSIX

This module provides interpreter for corner cases.
-}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
module Test.Multivariant.Types.Cases where

import           Test.Multivariant.Classes

import           Control.Arrow
import qualified Control.Invertible.BiArrow as BA
import           Data.Invertible.Bijection
import qualified Data.Invertible.Function as Inv
import           Data.List
import           Data.Tuple

data Case a b = Case { caseTransform :: a<->b
                     , caseCorner :: [(a, b)]
                     }

-- | Type of interpreter
newtype Cases a b = Cases { unCases :: [Case a b] }

-- | Get a list of corner cases for each variant
getCases :: (Eq a, Eq b)
         => Cases a b           -- ^ Interpreter
         -> [[(a,b)]]           -- ^ List (for each variant) of lists of pairs of input and output.
getCases = nub . map caseCorner . unCases

after :: Case a b -> Case b c -> Case a c
after (Case f abs) (Case g bcs) = Case (g Inv.. f) $ map (id *** biTo g) abs ++ map (biFrom f *** id) bcs

prod :: Case a1 b1 -> Case a2 b2 -> Case (a1,a2) (b1,b2)
prod (Case f cs1) (Case g cs2) = Case (f *** g) [ ((a1,a2),(b1,b2)) | (a1,b1) <- cs1, (a2,b2) <- cs2 ]

instance Program Cases where
  step f = Cases [Case f []]
  a ~> b = Cases [ after ca cb | ca <- unCases a, cb <- unCases b ]
  a <***> b = Cases [ prod ca cb | ca <- unCases a, cb <- unCases b ]
  a <+++> b = Cases $ unCases a ++ unCases b

appendCases :: [a] -> [b] -> Case a b -> Case a b
appendCases as bs (Case f abs) = Case f $ map (id &&& biTo f) as ++ map (biFrom f &&& id) bs ++ abs

instance WithCornerCases Cases where
  withCornerCases f (as,bs) = Cases $ map (appendCases as bs) $ unCases f

instance WithInvert Cases where
  invert (Cases cs) = Cases $ map (\(Case f c) -> Case (BA.invert f) (map swap c)) cs

instance WithDescription Cases where
  withDescription f _ = f