Classes.hs

{-|
Module      : Test.Multivariant.Classes
Description : Final tagless encoding of multivariant assignments language
Copyright   : (c) Anton Marchenko, Mansur Ziatdinov, 2016-2017
License     : BSD-3
Maintainer  : gltronred@gmail.com
Stability   : provisional
Portability : POSIX

This module provides typeclasses for final tagless encoding of multivariant assignment language.
-}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}

module Test.Multivariant.Classes
  ( -- * Program
    Program (..)
  , oneof
    -- * Corner cases
  , WithCornerCases (..)
    -- * Description
  , WithDescription (..)
    -- * Inverse
  , WithInvert (..)
    -- * Properties
  , WithConditions (..)
    -- * ProgramArrow
  , ProgramArrow (..)
  ) where

import Prelude (Bool, ($), error)
import Control.Arrow
import Control.Category (Category)
import qualified Control.Category as C
import Data.Invertible.Bijection
import Data.Invertible.Function
import qualified Data.List as L
import Data.Semigroupoid
import Data.Text.Lazy (Text)

-- | Program provides the most common operations
class Program prog where
  -- | One step of transformation
  step :: (a <-> b)             -- ^ Bijection @f :<->: g@ to be applied. If @f@ is not invertible, @g@ has to be right inverse: @f . g === id@
       -> prog a b              -- ^ Resulting program
  -- | Launches first program and feeds its output as input to the second one (sequential connection on the scheme)
  (~>) :: prog a b              -- ^ First program
       -> prog b c              -- ^ Second program
       -> prog a c              -- ^ Resulting program
  -- | Launches programs in parallel and combines their inputs and outputs (parallel connection on the scheme)
  (<***>) :: prog a1 b1         -- ^ First program
          -> prog a2 b2         -- ^ Second program
          -> prog (a1,a2) (b1,b2) -- ^ Resulting program
  -- | Creates two variants of transformation (variants are stacked above each other on the scheme)
  (<+++>) :: prog a b           -- ^ First variant
          -> prog a b           -- ^ Second variant
          -> prog a b           -- ^ Result

-- | Simple wrapper around '(<+++>)'
oneof :: Program prog => [prog a b] -> prog a b
oneof = L.foldl1' (<+++>)

-- | Program that can be inverted
class Program prog => WithInvert prog where
  -- | Inversion
  invert :: prog a b -> prog b a

-- | Program that has corner cases
class Program prog => WithCornerCases prog where
  -- | Supply corner cases for some step
  withCornerCases :: prog a b   -- ^ Program
                  -> ([a], [b]) -- ^ Corner cases to check for inputs (some test will feed such input) and outputs (some test will have this result)
                  -> prog a b   -- ^ Program with corner cases

-- | Program that has properties (*not implemented yet*)
class Program prog => WithConditions prog where
  -- | Supply precondition and postcondition
  withConditions :: prog a b               -- ^ Program
                 -> (a -> Bool, b -> Bool) -- ^ Pre- and postcondition
                 -> prog a b               -- ^ Program with properties to be tested

-- | Program that has description
class Program prog => WithDescription prog where
  -- | Supply description for some step
  withDescription :: prog a b   -- ^ Program
                  -> Text       -- ^ Its description in natural language
                  -> prog a b   -- ^ Program with description



-- | Embed program into arrow
newtype ProgramArrow p a b = ProgramArrow { getProgram :: p a b }

instance Program prog => Semigroupoid (ProgramArrow prog) where
  o b a = ProgramArrow $ getProgram a ~> getProgram b

instance Program prog => Category (ProgramArrow prog) where
  id = ProgramArrow $ step id
  (.) = o

instance Program prog => Arrow (ProgramArrow prog) where
  arr f = ProgramArrow $ step (f :<->: error "Use biarr instead of arr")
  a *** b = ProgramArrow $ getProgram a <***> getProgram b



-- instance IsoProfunctor Step where
--   dimap f g (Step h as bs t) = Step (dimap f g h) (biFrom f <$> as) (biTo g <$> bs) t
--   -- dimap f g (a :>>> b) = (dimap f g a) :>>> (dimap f g b)
--   -- dimap f g (a :<***> b) = (dimap f g a) :<***> (dimap f g b)
--   -- dimap f g (a :<+++> b) = (dimap f g a) :<+++> (dimap f g b)

-- instance IsoStrong Step where
--   -- first' (Step h as bs t) = Step _ _ _ _