packages feed

multivariant (empty) → 0.1.0.1

raw patch · 18 files changed

+1019/−0 lines, 18 filesdep +HUnitdep +MonadRandomdep +QuickChecksetup-changedbinary-added

Dependencies added: HUnit, MonadRandom, QuickCheck, base, containers, free, invertible, multivariant, profunctors, semigroupoids, tasty, tasty-hunit, tasty-quickcheck, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Anton Marchenko, Mansur Ziatdinov (c) 2016-2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Mansur Ziatdinov nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,49 @@+# Multivariant assignments generation language++This library allows you to write short description of multivariant assignments in embedded DSL and interpret them as solution, text of assignment and tests.++This library is available at [hackage](http://hackage.haskell.org/package/multivariant).++## Installation++- install [stack](https://docs.haskellstack.org/en/stable/README/)+- run `stack exec multivariant`++or you can use `cabal install multivariant`.++## Language description++There are several typeclasses for tagless-final encoding of language:+- Program+- WithDescription+- WithCornerCases+- WithInvert++Each typeclass defines some operations that every interpreter has to implement.++There are currently three ``interpreters'' (types that implement corresponding typeclasses):+- Cases+- Description+- Solution++### Program++### WithDescription++### WithInvert++TBA++## Examples++```haskell+task = Inv.map ((+1) :<->: (-1)) `withDescription` "Add one to each list element" `withCornerCases` ([0],[0])+    ~>   (   (sum :<->: (\s -> [s,0])) `withDescription` "Compute sum of elements" `withCornerCases` ([[]],[0])+	   <+++> (product :<->: (\p -> [1,p])) `withDescription` "Compute product of elements" `withCornerCases` ([[]],[1])+	     )+```++TBA++More examples are available in the [examples](examples/) directory.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,36 @@+{-|+Module      : Lib+Description : Example usage of library+Copyright   : (c) Anton Marchenko, Mansur Ziatdinov, 2016-2017+License     : BSD-3+Maintainer  : gltronred@gmail.com+Stability   : experimental+Portability : POSIX++This module provides 'appMain' function that prints variants for 'Task.task'++See "Task" module for more description+-}++{-# LANGUAGE OverloadedStrings #-}++module Main where++import Test.Multivariant.Types++import Task (task, inputVariants, printTask)++import Data.List (zip4)++-- | Prints all variants from 'Task.task'+appMain :: IO ()+appMain = do+  let descriptions = getDescription task+      solutions = getSolutions task+      cases = getCases task+  mapM_ (\(i,d,s,c) -> printTask i d inputVariants s c) $+    zip4 [1..] descriptions solutions cases++main = appMain++
+ app/Task.hs view
@@ -0,0 +1,121 @@+{-|+Module      : Task+Description : Example usage of library+Copyright   : (c) Anton Marchenko, Mansur Ziatdinov, 2016-2017+License     : BSD-3+Maintainer  : gltronred@gmail.com+Stability   : experimental+Portability : POSIX++This module provides example of 'task'.++This task is the following one.++<<doc/diagram.png Task example>>++Part 'alpha' adds 5 to each list element.++Part 'beta' has two variants: it either sums all list elements or computes product.++Part 'gamma' takes a list and a number and multiplies every list element to this number.++Part 'delta' is either sum or product of given list.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++module Task+  ( task+  , Input+  , Output+  , inputVariants+  , printTask+  ) where++import           Task.Pretty+import           Task.Types++import           Data.Invertible.Bijection+import           Prelude (Integer, (+), (-), (*), ($))+import qualified Prelude as P+import           Data.Invertible.List++---------------------------------------------------------------------+-- EXAMPLE OF TAGLESS FINAL APPROACH+---------------------------------------------------------------------++import           Test.Multivariant.Classes++type P prog a b = (WithDescription prog, WithCornerCases prog) => prog a b++-- TASK DESCRIPTION BEGINS HERE++-- | Part alpha. Adds 5 to each list element+--+-- >  step (Inv.map $ (\x -> x+5) :<->: (\x -> x-5))+--+-- We use 'Data.Invertible.List.map' and 'Data.Invertible.Bijection.(:<->:)'+alpha :: P prog [Integer] [Integer]+alpha = step (map $ (\x -> x+5) :<->: (\x -> x-5))+        `withCornerCases` ([[],[-1,5],[5,4]],+                           [])+        `withDescription` "Add 5 to each element of the list"++-- | Part beta. Either sum or product of given list+--+-- >  step (sum :<->: (\x -> [x,0]))+--+-- 'Prelude.sum' is not invertible, so we use a (right) inverse.+beta :: P prog [Integer] Integer+beta = oneof [beta1, beta2]+  where beta1 = step (P.sum :<->: (\x -> [x,0]))+                `withCornerCases` ([[],[3,2]],+                                   [0])+                `withDescription` "Compute sum of elements of list"+        beta2 = step (P.product :<->: (\p -> [p,1]))+                `withDescription` "Compute product of elements of list"+                `withCornerCases` ([[],[0]],+                                   [])++-- | Part gamma.+--+-- >  step ((\(xs,y) -> map (*y) xs) :<->: (\ys -> (ys,1)))+--+-- We use a (right) inverse @(\ys -> (ys,1))@.+gamma :: P prog ([Integer],Integer) [Integer]+gamma = step ((\(xs,y) -> P.map (*y) xs) :<->: (\ys -> (ys,1)))+        `withCornerCases` ([ ([],1), ([1,2],0), ([],0), ([1,2],2)],+                           [ ])+        `withDescription` "Multiply each element of result of first operation to result of second operation"++-- | Part delta.+--+-- Either sum or product of list+delta :: P prog [Integer] Integer+delta = delta1 <+++> delta2+  where delta1 = step (P.product :<->: (\p -> [p,1]))+                 `withDescription` "Compute product of elements of list"+                 `withCornerCases` ([[],[0]],+                                    [])+        delta2 = step (P.sum :<->: (\s -> [s,0]))+                 `withDescription` "Compute sum of elements of list"+                 `withCornerCases` ([[]],+                                    [0])++-- | Combined task+task :: P prog Input Output+task = (alpha <***> beta) ~> gamma ~> delta++-- TASK DESCRIPTION ENDS HERE++-- | Inputs to be fed to example solution (see 'Task.Pretty.printTask')+inputVariants :: [Input]+inputVariants = +  [ ([1,2,3], [1,2])+  , ([1,-1], [1,2])+  , ([], [1,2,1,4])+  , ([0,1,2], [1,-1])+  ]+
+ app/Task/Pretty.hs view
@@ -0,0 +1,82 @@+{-|+Module      : Task.Pretty+Description : Pretty printing task elements+Copyright   : (c) Anton Marchenko, Mansur Ziatdinov, 2016-2017+License     : BSD-3+Maintainer  : gltronred@gmail.com+Stability   : experimental+Portability : POSIX++This module provides functions to pretty print variants, e.g. text description, solution,+input/output, test cases.++See "Task" module for more description+-}++{-# LANGUAGE OverloadedStrings #-}+module Task.Pretty where++import           Task.Types++import           Control.Monad+import           Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import           Data.Text.Lazy.Builder+import           Data.Text.Lazy.Builder.Int+import qualified Data.Text.Lazy.IO as TIO++-- | Outputs a line of given chars+hline :: Char -> IO ()+hline = TIO.putStrLn . T.replicate 80 . T.singleton++-- | Outputs a number+int :: Integral a => a -> Text+int = toLazyText . decimal++-- | Prints a list of numbers+printList :: Integral a => [a] -> IO ()+printList = TIO.putStr . T.intercalate ", " . map (toLazyText . decimal)++-- | Prints an input+printInput :: Input -> IO ()+printInput (xs,ys) = do+  TIO.putStr "["+  printList xs+  TIO.putStr "], ["+  printList ys+  -- TIO.putStr $ sh ys+  TIO.putStr "]"++-- | Outputs anything (not optimal performance, uses conversion to String)+sh :: Show a => a -> Text+sh = toLazyText . fromString . show++-- | Pretty prints a variant+printTask :: Int                -- ^ Variant number+          -> Text               -- ^ Text+          -> [Input]            -- ^ Example inputs+          -> (Input -> Output)  -- ^ Solution (it is launched on example inputs and corresponding input-output pairs are printed)+          -> [(Input, Output)]  -- ^ Test cases+          -> IO ()+printTask i varDesc varInputs varSol varTests = do+  hline '='+  TIO.putStr "Variant "+  TIO.putStrLn (int i)+  hline '-'+  TIO.putStrLn varDesc+  hline '-'+  forM_ varInputs $ \input -> do+    TIO.putStr "* "+    printInput input+    TIO.putStr "\t  ==>  \t"+    TIO.putStrLn (sh $ varSol input)+  hline '-'+  forM_ varTests $ \(input, output) -> do+    TIO.putStr "* "+    printInput input+    TIO.putStr "\t  ///  \t"+    TIO.putStr (sh output)+    TIO.putStr "\t  ==>  \t"+    TIO.putStrLn (sh $ varSol input)+  hline '='+
+ app/Task/Types.hs view
@@ -0,0 +1,19 @@+{-|+Module      : Task.Types+Description : Example usage of library+Copyright   : (c) Anton Marchenko, Mansur Ziatdinov, 2016-2017+License     : BSD-3+Maintainer  : gltronred@gmail.com+Stability   : experimental+Portability : POSIX++This module provides 'Input' and 'Output' types for "Task" and "Task.Pretty"++See "Task" module for more description+-}++module Task.Types where++type Input = ([Integer], [Integer])+type Output = Integer+
+ doc/diagram.png view

binary file changed (absent → 6472 bytes)

+ multivariant.cabal view
@@ -0,0 +1,104 @@+name: multivariant+version: 0.1.0.1+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: Copyright (c) 2016-2017 Anton Marchenko, Mansur Ziatdinov+maintainer: gltronred@gmail.com+homepage: https://bitbucket.org/gltronred/multivariant#readme+synopsis: Multivariant assignments generation language+description:+    Please see README.md+category: Test+author: Anton Marchenko, Mansur Ziatdinov+extra-source-files:+    doc/diagram.png+    README.md++library+    exposed-modules:+        Control.Invertible.BiArrow.Free+        Data.Invertible.Profunctor+        Data.Invertible.Strong+        Test.Multivariant.Classes+        Test.Multivariant.Types+        Test.Multivariant.Types.Cases+        Test.Multivariant.Types.Description+        Test.Multivariant.Types.Solution+    build-depends:+        base >=4.7 && <5,+        containers >=0.5.7.1 && <0.6,+        free >=4.12.4 && <4.13,+        invertible >=0.1.2 && <0.2,+        MonadRandom >=0.4.2.3 && <0.5,+        profunctors ==5.2.*,+        semigroupoids ==5.1.*,+        text >=1.2.2.1 && <1.3,+        transformers >=0.5.2.0 && <0.6,+        tasty >=0.11.0.4 && <0.12,+        tasty-quickcheck >=0.8.4 && <0.9,+        tasty-hunit >=0.9.2 && <0.10,+        QuickCheck >=2.8.2 && <2.9,+        HUnit >=1.3.1.2 && <1.4+    default-language: Haskell2010+    hs-source-dirs: src+    ghc-options: -W++executable example+    main-is: Main.hs+    build-depends:+        base >=4.7 && <5,+        containers >=0.5.7.1 && <0.6,+        free >=4.12.4 && <4.13,+        invertible >=0.1.2 && <0.2,+        MonadRandom >=0.4.2.3 && <0.5,+        profunctors ==5.2.*,+        semigroupoids ==5.1.*,+        text >=1.2.2.1 && <1.3,+        transformers >=0.5.2.0 && <0.6,+        tasty >=0.11.0.4 && <0.12,+        tasty-quickcheck >=0.8.4 && <0.9,+        tasty-hunit >=0.9.2 && <0.10,+        QuickCheck >=2.8.2 && <2.9,+        HUnit >=1.3.1.2 && <1.4,+        multivariant >=0.1.0.1 && <0.2+    default-language: Haskell2010+    hs-source-dirs: app+    other-modules:+        Task+        Task.Pretty+        Task.Types+    ghc-options: -W++test-suite test+    type: exitcode-stdio-1.0+    main-is: Test.hs+    build-depends:+        base >=4.7 && <5,+        containers >=0.5.7.1 && <0.6,+        free >=4.12.4 && <4.13,+        invertible >=0.1.2 && <0.2,+        MonadRandom >=0.4.2.3 && <0.5,+        profunctors ==5.2.*,+        semigroupoids ==5.1.*,+        text >=1.2.2.1 && <1.3,+        transformers >=0.5.2.0 && <0.6,+        tasty >=0.11.0.4 && <0.12,+        tasty-quickcheck >=0.8.4 && <0.9,+        tasty-hunit >=0.9.2 && <0.10,+        QuickCheck >=2.8.2 && <2.9,+        HUnit >=1.3.1.2 && <1.4,+        multivariant >=0.1.0.1 && <0.2+    default-language: Haskell2010+    hs-source-dirs: src test+    other-modules:+        Control.Invertible.BiArrow.Free+        Data.Invertible.Profunctor+        Data.Invertible.Strong+        Test.Multivariant.Classes+        Test.Multivariant.Types+        Test.Multivariant.Types.Cases+        Test.Multivariant.Types.Description+        Test.Multivariant.Types.Solution+    ghc-options: -W
+ src/Control/Invertible/BiArrow/Free.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++module Control.Invertible.BiArrow.Free where++import Prelude hiding ((.), id, fst, snd, curry)+-- import qualified Prelude as P+import Control.Invertible.BiArrow+import Control.Category+import Data.Groupoid+import Data.Invertible.Bijection+import Data.Invertible.Profunctor+import Data.Invertible.Strong+import Data.Semigroupoid++infixr :-++data FreeA p a b = PureP (a <-> b)+                 | forall x. p a x :- FreeA p x b++nil :: IsoProfunctor p => FreeA p a a+nil = PureP id++instance IsoProfunctor b => IsoProfunctor (FreeA b) where+  lmap f (PureP g) = PureP (g . f)+  lmap f (g :- h)  = (lmap f g) :- h+  rmap f (PureP g) = PureP (f . g)+  rmap f (g :- h)  = g :- (rmap f h)++instance IsoStrong p => IsoStrong (FreeA p) where+  first' (PureP f) = PureP (first' f)+  first' (g :- h)  = (first' g) :- (first' h)++instance IsoProfunctor p => Semigroupoid (FreeA p) where+  o g (PureP f) = lmap f g+  o k (g :- h)  = g :- (k `o` h)++instance IsoProfunctor p => Category (FreeA p) where+  id = PureP id+  (.) = o++revinv :: (IsoProfunctor p, Groupoid p)+       => (forall x y. p x y -> p y x)+       -> FreeA p a b+       -> FreeA p b a+revinv _ (PureP f) = PureP $ inv f+revinv i (g :- h)  = go i h (i g :- nil)++go :: IsoProfunctor p => (forall x y. p x y -> p y x) -> FreeA p x d -> FreeA p x c -> FreeA p d c+go _ (PureP f) acc = lmap (inv f) acc+go i (g :- h)  acc = go i h (i g :- acc)++instance (IsoProfunctor p, Groupoid p) => Groupoid (FreeA p) where+  inv = revinv inv++instance (IsoProfunctor p, Groupoid p) => BiArrow (FreeA p) where+  (<->) f g = PureP $ f :<->: g++-- instance (IsoProfunctor p, IsoStrong p, Groupoid p) => BiArrow' (FreeA p) where+
+ src/Data/Invertible/Profunctor.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}++module Data.Invertible.Profunctor where++import Prelude hiding ((.), id, fst, snd, curry)+import qualified Prelude as P+import Data.Invertible.Bijection+import Data.Invertible.Function++-- | Class 'IsoProfunctor' represents a profunctor from @Iso@ -> @Hask@ (?)+--+-- @'dimap' 'id' 'id' ≡ 'id'@+--+-- @+--  'lmap' 'id' ≡ 'id'+--  'rmap' 'id' ≡ 'id'+-- @+--+-- @'dimap' f g ≡ 'lmap' f '.' 'rmap' g@+--+--+-- @+-- 'dimap' (f '.' g) (h '.' i) ≡ 'dimap' g h '.' 'dimap' f i+-- 'lmap' (f '.' g) ≡ 'lmap' g '.' 'lmap' f+-- 'rmap' (f '.' g) ≡ 'rmap' f '.' 'rmap' g+-- @+class IsoProfunctor p where+  dimap :: (a <-> b) -> (c <-> d) -> p b c -> p a d+  dimap f g = (P..) (lmap f) (rmap g)+  {-# INLINE dimap #-}+  +  lmap :: (a <-> b) -> p b c -> p a c+  lmap f = dimap f id+  {-# INLINE lmap #-}+  +  rmap :: (b <-> c) -> p a b -> p a c+  rmap = dimap id+  {-# INLINE rmap #-}++instance IsoProfunctor (Bijection (->)) where+  dimap f g h = g . h . f+++
+ src/Data/Invertible/Strong.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}++module Data.Invertible.Strong where++import Prelude hiding ((.), id, fst, snd, curry)+import qualified Prelude as P+import Data.Invertible.Bijection+-- import Data.Invertible.Function+import Data.Invertible.Profunctor+import Data.Invertible.Tuple++-- | Generalizing 'Star' of a strong 'Functor'+--+-- /Note:/ Every 'Functor' in Haskell is strong with respect to @(,)@.+--+-- This describes profunctor strength with respect to the product structure+-- of Hask.+--+-- <http://www-kb.is.s.u-tokyo.ac.jp/~asada/papers/arrStrMnd.pdf>+class IsoProfunctor p => IsoStrong p where+  first' :: p a b -> p (a, c) (b, c)+  first' = dimap swap swap P.. second'++  second' :: p a b -> p (c, a) (c, b)+  second' = dimap swap swap P.. first'++instance IsoStrong (Bijection (->)) where+  first' (ab :<->: ba) = (\ ~(a, c) -> (ab a, c)) :<->: (\ ~(b, c) -> (ba b, c))+  {-# INLINE first' #-}+  second' (ab :<->: ba) = (\ ~(c, a) -> (c, ab a)) :<->: (\ ~(c, b) -> (c, ba b))+  {-# INLINE second' #-}+
+ src/Test/Multivariant/Classes.hs view
@@ -0,0 +1,118 @@+{-|+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 _ _ _ _+
+ src/Test/Multivariant/Types.hs view
@@ -0,0 +1,28 @@+{-|+Module      : Test.Multivariant.Types+Description : Intepreters for language+Copyright   : (c) Anton Marchenko, Mansur Ziatdinov, 2016-2017+License     : BSD-3+Maintainer  : gltronred@gmail.com+Stability   : provisional+Portability : POSIX++This module exports all interpreters.+-}++module Test.Multivariant.Types+  ( -- * Interpreter for corner cases+    Cases+  , getCases+    -- * Interpreter for description+  , Description+  , getDescription+    -- * Interpreter for solution+  , Solution+  , getSolutions+  ) where++import Test.Multivariant.Types.Cases+import Test.Multivariant.Types.Description+import Test.Multivariant.Types.Solution+
+ src/Test/Multivariant/Types/Cases.hs view
@@ -0,0 +1,62 @@+{-|+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+
+ src/Test/Multivariant/Types/Description.hs view
@@ -0,0 +1,39 @@+{-|+Module      : Test.Multivariant.Types.Description+Description : Interpreter for description+Copyright   : (c) Anton Marchenko, Mansur Ziatdinov, 2016-2017+License     : BSD-3+Maintainer  : gltronred@gmail.com+Stability   : provisional+Portability : POSIX++This module provides interpreter for description.+-}++module Test.Multivariant.Types.Description where++import Test.Multivariant.Classes++import Data.Monoid ((<>))+import Data.Text.Lazy (Text)+import Data.Text.Lazy.Builder++-- | Type for interpreter+newtype Description a b = Description { variants :: [Builder] }++-- | Get a list of texts of variants+getDescription :: Description a b -> [Text]+getDescription = map toLazyText . variants++instance Program Description where+  step _f = Description [flush]+  a ~> b = Description [da <> db | da <- variants a, db <- variants b ]+  a <***> b = Description [da <> db | da <- variants a, db <- variants b ]+  a <+++> b = Description (variants a ++ variants b)++instance WithCornerCases Description where+  withCornerCases p _ = p++instance WithDescription Description where+  withDescription (Description b) t = Description $ map ((fromLazyText t <>) . (singleton '\n' <>)) b+
+ src/Test/Multivariant/Types/Solution.hs view
@@ -0,0 +1,44 @@+{-|+Module      : Test.Multivariant.Types.Solution+Description : Interpreter for solution+Copyright   : (c) Anton Marchenko, Mansur Ziatdinov, 2016-2017+License     : BSD-3+Maintainer  : gltronred@gmail.com+Stability   : provisional+Portability : POSIX++This module provides interpreter for solution.+-}++{-# LANGUAGE TypeOperators #-}++module Test.Multivariant.Types.Solution 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++-- | Type for interpreter+newtype Solution a b = Solution { solutions :: [a <-> b] }++-- | Extract a list of solutions (functions that map input to output)+getSolutions = map biTo . solutions++instance Program Solution where+  step f = Solution [f]+  a ~> b = Solution [sb Inv.. sa | sa <- solutions a, sb <- solutions b]+  a <***> b = Solution [sa *** sb | sa <- solutions a, sb <- solutions b]+  a <+++> b = Solution $ solutions a ++ solutions b++instance WithInvert Solution where+  invert (Solution fs) = Solution $ map BA.invert fs++instance WithCornerCases Solution where+  withCornerCases p _ = p++instance WithDescription Solution where+  withDescription p _ = p+
+ test/Test.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE RankNTypes #-}++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit++import Test.Multivariant.Classes+import Test.Multivariant.Types.Cases+import Test.Multivariant.Types.Solution+--import qualified Task++import Data.Invertible.Bijection+import qualified Data.Invertible.Prelude as Inv+import qualified Data.Set as S++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests"+  [ solutionTest+  , casesTest+  , taskTest+  ]++alpha' :: Program p => p [[Integer]] [Integer]+alpha' = step (Inv.map $ sum :<->: (\x -> [x-1, 1]))++alpha :: (Program p, WithCornerCases p) => p [[Integer]] [Integer]+alpha = alpha'+        `withCornerCases` ([ [[1,2,3], [4,5,6]]+                           , []+                           ],+                           [ []+                           , [5]+                           ]+                          )++beta' :: Program p => p [Integer] Integer+beta' = step (sum :<->: (\x -> [x,0]))++beta :: (Program p, WithCornerCases p) => p [Integer] Integer+beta = beta'+       `withCornerCases` ([ [0,1,2]+                          , []+                          ],+                          [ 0+                          , 1+                          ]+                         )++gamma' :: (Program p, WithCornerCases p) => p [Integer] Integer+gamma' = step (product :<->: (\x -> [1,x]))++delta' :: (Program p, WithCornerCases p) => p ([Integer], Integer) [Integer]+delta' = step ((\(xs,y) -> map (*y) xs) :<->: (\xs -> (xs,1)))++id' :: (Program p, WithCornerCases p) => p a a+id' = step (id :<->: id)++solutionCasesCompatible :: Eq b+                        => (forall p. (Program p, WithCornerCases p) => p a b)+                        -> Bool+solutionCasesCompatible task = let+  sol = head $ getSolutions task+  cases = head $ getCases task+  in all (\(i,o) -> sol i == o) cases++casesTest :: TestTree+casesTest = testGroup "Cases interpreter"+  [ testCase "Alpha" $+    S.fromList (getCases alpha) @?= S.fromList [[ ([[1,2,3], [4,5,6]], [6,15])+                                                , ([], [])+                                                , ([], [])+                                                , ([[4,1]], [5])+                                                ]]+  , testCase "Beta" $+    S.fromList (getCases beta) @?= S.fromList [[ ([0,1,2], 3)+                                               , ([], 0)+                                               , ([0,0], 0)+                                               , ([1,0], 1)+                                               ]]+  , testCase "Alpha ~> Beta" $+    S.fromList (getCases $ alpha ~> beta) @?=+    S.fromList [[ ([[1,2,3], [4,5,6]], 21)+                , ([], 0)+                , ([], 0)+                , ([[4,1]], 5)+                , ([[-1,1],[0,1],[1,1]], 3)+                , ([], 0)+                , ([[-1,1],[-1,1]],0)+                , ([[0,1],[-1,1]],1)+                ]]+  , testGroup "Output in getCases is equal to getSolution on corresponding input"+    [ QC.testProperty "alpha ~> beta" $+      \(cs1,cs2) -> let task :: (Program p, WithCornerCases p) => p [[Integer]] Integer+                        task = alpha' `withCornerCases` cs1 ~> beta' `withCornerCases` cs2+                    in solutionCasesCompatible task+    , QC.testProperty "alpha ~> gamma" $+      \(cs1,cs2) -> let task :: (Program p, WithCornerCases p) => p [[Integer]] Integer+                        task = alpha' `withCornerCases` cs1 ~> gamma' `withCornerCases` cs2+                    in solutionCasesCompatible task+    , QC.testProperty "(alpha *** id) ~> delta" $+      \(cs1,cs2) -> let task :: (Program p, WithCornerCases p) => p ([[Integer]],Integer) [Integer]+                        task = (alpha' `withCornerCases` cs1 <***> id') ~> delta' `withCornerCases` cs2+                    in solutionCasesCompatible task+    , QC.testProperty "(alpha *** beta) ~> delta" $+      \(cs1,cs2) -> let task :: (Program p, WithCornerCases p) => p ([[Integer]],[Integer]) [Integer]+                        task = (alpha' <***> beta') `withCornerCases` cs1 ~> delta' `withCornerCases` cs2+                    in solutionCasesCompatible task+    ]+  ]++solutionTest :: TestTree+solutionTest = testGroup "Solution interpreter"+  [ testCase "Alpha" $+    map (head $ getSolutions alpha) [ [[1,2,3],[4,5,6]]+                                    , []+                                    , [[1,2],[3]]+                                    ] @?=+    [ [6,15]+    , []+    , [3,3]+    ]+  , testCase "Beta" $+    map (head $ getSolutions beta) [ [6,15]+                                   , []+                                   , [1,2,3]+                                   ] @?=+    [ 21, 0, 6 ]+  , testCase "Alpha ~> Beta" $+    map (head $ getSolutions $ alpha ~> beta) [ [[1,2,3],[4,5,6]]+                                              , []+                                              , [[1,2],[3]]+                                              ] @?=+    [ 21, 0, 6 ]+  ]++taskTest :: TestTree+taskTest = testGroup "Task"+  [ QC.testProperty "alpha" $+    \(i,o) -> let alpha' :: Program p => p [Integer] [Integer]+                  alpha' = step (Inv.map $ (\x -> x+5) :<->: (\x -> x-5))+                  sol = head $ solutions alpha'+              in biFrom sol (biTo sol i) == i && biTo sol (biFrom sol o) == o+  ]+