futhark-0.15.8: unittests/Futhark/IR/Syntax/CoreTests.hs

{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Futhark.IR.Syntax.CoreTests
       ( tests )
       where

import Control.Applicative

import Test.Tasty
import Test.Tasty.HUnit
import Test.QuickCheck

import Prelude

import Language.Futhark.CoreTests ()
import Futhark.IR.PrimitiveTests()
import Futhark.IR.Syntax.Core
import Futhark.IR.Pretty ()

tests :: TestTree
tests = testGroup "Internal CoreTests" subShapeTests

subShapeTests :: [TestTree]
subShapeTests =
  [ shape [free 1, free 2] `isSubShapeOf` shape [free 1, free 2]
  , shape [free 1, free 3] `isNotSubShapeOf` shape [free 1, free 2]
  , shape [free 1] `isNotSubShapeOf` shape [free 1, free 2]
  , shape [free 1, free 2] `isSubShapeOf` shape [free 1, Ext 3]
  , shape [Ext 1, Ext 2] `isNotSubShapeOf` shape [Ext 1, Ext 1]
  , shape [Ext 1, Ext 1] `isSubShapeOf` shape [Ext 1, Ext 2]
  ]
  where shape :: [ExtSize] -> ExtShape
        shape = Shape

        free :: Int -> ExtSize
        free = Free . Constant . IntValue . Int32Value . fromIntegral

        isSubShapeOf shape1 shape2 =
          subShapeTest shape1 shape2 True
        isNotSubShapeOf shape1 shape2 =
          subShapeTest shape1 shape2 False

        subShapeTest :: ExtShape -> ExtShape -> Bool -> TestTree
        subShapeTest shape1 shape2 expected =
          testCase ("subshapeOf " ++ pretty shape1 ++ " " ++
                    pretty shape2 ++ " == " ++
                    show expected) $
          shape1 `subShapeOf` shape2 @?= expected

instance Arbitrary NoUniqueness where
  arbitrary = pure NoUniqueness

instance (Arbitrary shape, Arbitrary u) => Arbitrary (TypeBase shape u) where
  arbitrary =
    oneof [ Prim <$> arbitrary
          , Array <$> arbitrary <*> arbitrary <*> arbitrary
          ]

instance Arbitrary Ident where
  arbitrary = Ident <$> arbitrary <*> arbitrary

instance Arbitrary Rank where
  arbitrary = Rank <$> elements [1..9]

instance Arbitrary Shape where
  arbitrary = Shape . map intconst <$> listOf1 (elements [1..9])
    where intconst = Constant . IntValue . Int32Value