content: {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  module Futhark.IR.Syntax.CoreTests (tests) where
  
  import Control.Applicative
  import Data.Loc (Loc (..), Pos (..))
  import Futhark.IR.Pretty (prettyString)
  import Futhark.IR.Syntax.Core
  import Language.Futhark.CoreTests ()
  import Language.Futhark.PrimitiveTests ()
  import Test.QuickCheck
  import Test.Tasty
  import Test.Tasty.HUnit
  import Prelude
  
  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
  
  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 "
              ++ prettyString shape1
              ++ " "
              ++ prettyString shape2
              ++ " == "
              ++ show expected
          )
          $ shape1 `subShapeOf` shape2 @?= expected
  
  provenanceTests :: [TestTree]
  provenanceTests =
    [ testGroup
        "<>"
        [ testCase "simple" $
            (Provenance [] line1 <> Provenance [] line0) @?= Provenance [] lines01,
          testCase "mempty left" $
            (Provenance [] mempty <> Provenance [] line0) @?= Provenance [] line0,
          testCase "mempty right" $
            (Provenance [] line1 <> Provenance [] mempty) @?= Provenance [] line1
        ],
      testGroup
        "stackProvenance"
        [ testCase "encloses" $
            (Provenance [] line0 `stackProvenance` Provenance [] line0_sub)
              @?= Provenance [] line0_sub
        ]
    ]
    where
      line0 = Loc (Pos "" 0 1 0) (Pos "" 0 10 10)
      line0_sub = Loc (Pos "" 0 2 1) (Pos "" 0 9 9)
      line1 = Loc (Pos "" 1 1 0) (Pos "" 1 10 20)
      lines01 = Loc (Pos "" 0 1 0) (Pos "" 1 10 20)
  
  tests :: TestTree
  tests =
    testGroup
      "Internal CoreTests"
      [ testGroup "subShape" subShapeTests,
        testGroup "Provenance" provenanceTests
      ]
  