diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 + + diff --git a/app/Task.hs b/app/Task.hs new file mode 100644 --- /dev/null +++ b/app/Task.hs @@ -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. + +<> + +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]) + ] + diff --git a/app/Task/Pretty.hs b/app/Task/Pretty.hs new file mode 100644 --- /dev/null +++ b/app/Task/Pretty.hs @@ -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 '=' + diff --git a/app/Task/Types.hs b/app/Task/Types.hs new file mode 100644 --- /dev/null +++ b/app/Task/Types.hs @@ -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 + diff --git a/doc/diagram.png b/doc/diagram.png new file mode 100644 Binary files /dev/null and b/doc/diagram.png differ diff --git a/multivariant.cabal b/multivariant.cabal new file mode 100644 --- /dev/null +++ b/multivariant.cabal @@ -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 diff --git a/src/Control/Invertible/BiArrow/Free.hs b/src/Control/Invertible/BiArrow/Free.hs new file mode 100644 --- /dev/null +++ b/src/Control/Invertible/BiArrow/Free.hs @@ -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 + diff --git a/src/Data/Invertible/Profunctor.hs b/src/Data/Invertible/Profunctor.hs new file mode 100644 --- /dev/null +++ b/src/Data/Invertible/Profunctor.hs @@ -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 + + + diff --git a/src/Data/Invertible/Strong.hs b/src/Data/Invertible/Strong.hs new file mode 100644 --- /dev/null +++ b/src/Data/Invertible/Strong.hs @@ -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. +-- +-- +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' #-} + diff --git a/src/Test/Multivariant/Classes.hs b/src/Test/Multivariant/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Test/Multivariant/Classes.hs @@ -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 _ _ _ _ + diff --git a/src/Test/Multivariant/Types.hs b/src/Test/Multivariant/Types.hs new file mode 100644 --- /dev/null +++ b/src/Test/Multivariant/Types.hs @@ -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 + diff --git a/src/Test/Multivariant/Types/Cases.hs b/src/Test/Multivariant/Types/Cases.hs new file mode 100644 --- /dev/null +++ b/src/Test/Multivariant/Types/Cases.hs @@ -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 + diff --git a/src/Test/Multivariant/Types/Description.hs b/src/Test/Multivariant/Types/Description.hs new file mode 100644 --- /dev/null +++ b/src/Test/Multivariant/Types/Description.hs @@ -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 + diff --git a/src/Test/Multivariant/Types/Solution.hs b/src/Test/Multivariant/Types/Solution.hs new file mode 100644 --- /dev/null +++ b/src/Test/Multivariant/Types/Solution.hs @@ -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 + diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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 + ] +