diff --git a/sized.cabal b/sized.cabal --- a/sized.cabal +++ b/sized.cabal @@ -1,66 +1,66 @@ -cabal-version: >=2.0 +cabal-version: 2.0 name: sized -version: 1.0.0.0 +version: 1.0.0.1 license: BSD3 license-file: LICENSE maintainer: konn.jinro_at_gmail.com author: Hiromi ISHII -tested-with: - ghc ==8.6.5, ghc ==8.8.4, ghc ==8.10.3 - +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.3 synopsis: Sized sequence data-types description: - A wrapper to make length-parametrized data-type from functorial data-types. + A wrapper to make length-parametrized data-type from functorial data-types. category: Data build-type: Simple source-repository head - type: git - location: git://github.com/konn/sized.git + type: git + location: git://github.com/konn/sized.git library - exposed-modules: - Data.Sized - Data.Sized.Builtin - Data.Sized.Flipped + exposed-modules: + Data.Sized + Data.Sized.Builtin + Data.Sized.Flipped - hs-source-dirs: src - other-modules: Data.Sized.Internal - default-language: Haskell2010 - ghc-options: -O2 -Wall -Wno-redundant-constraints - build-depends: - base ==4.*, - constraints, - these, - type-natural >=0.8.1.0, - ghc-typelits-presburger >=0.4, - ghc-typelits-knownnat, - mono-traversable >=0.10, - subcategories, - deepseq >=1.4, - hashable >=1.2, - vector >=0.12, - containers >=0.5, - equational-reasoning >=0.5, - lens >=0.14 + hs-source-dirs: src + other-modules: Data.Sized.Internal + default-language: Haskell2010 + ghc-options: -O2 -Wall -Wno-redundant-constraints + build-depends: + base >=4 && <5 + , constraints + , containers >=0.5 + , deepseq >=1.4 + , equational-reasoning >=0.5 + , ghc-typelits-knownnat + , ghc-typelits-presburger >=0.5 + , hashable >=1.2 + , lens >=0.14 + , mono-traversable >=0.10 + , subcategories + , these + , type-natural >=1.0 + , vector >=0.12 test-suite optimisaion-test - type: exitcode-stdio-1.0 - main-is: opt-test.hs - hs-source-dirs: test - other-modules: Shared - default-language: Haskell2010 - ghc-options: -O2 -Wall -Wno-redundant-constraints -fno-hpc - build-depends: - base -any, - containers -any, - hspec -any, - inspection-testing ^>=0.4, - mono-traversable -any, - sized -any, - template-haskell -any, - type-natural, - th-lift -any, - subcategories -any, - vector -any + type: exitcode-stdio-1.0 + main-is: opt-test.hs + hs-source-dirs: test + other-modules: Shared + default-language: Haskell2010 + ghc-options: -O2 -Wall -Wno-redundant-constraints -fno-hpc + build-depends: + base + , containers + , inspection-testing >=0.4 && <0.6 + , mono-traversable + , sized + , subcategories + , tasty + , tasty-expected-failure + , tasty-inspection-testing + , template-haskell + , th-lift + , type-natural + , vector diff --git a/test/Shared.hs b/test/Shared.hs --- a/test/Shared.hs +++ b/test/Shared.hs @@ -1,21 +1,28 @@ -{-# LANGUAGE DataKinds, TemplateHaskell #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -O2 -fno-hpc #-} -{-# OPTIONS_GHC -dsuppress-idinfo -dsuppress-coercions - -dsuppress-type-applications - -dsuppress-module-prefixes -dsuppress-type-signatures - -dsuppress-uniques #-} + module Shared where -import Language.Haskell.TH -import Test.Hspec -import Test.Inspection +import Language.Haskell.TH (ExpQ) +import Test.Tasty.Inspection -checkInspection - :: Result -> Expectation -checkInspection Success{} = pure () -checkInspection (Failure msg) = - fail msg +inspecting :: String -> Obligation -> ExpQ +inspecting title obl = inspectTest $ obl {testName = Just title} -inspecting :: String -> Obligation -> Q Exp -inspecting desc reg = - [|it desc $ checkInspection $(inspectTest reg)|] +data GHCVer = GHC8_8 | GHC8_10 | GHC9_0 | GHC9_2 + deriving (Show, Eq, Ord) + +ghcVer :: GHCVer + +#if __GLASGOW_HASKELL__ == 902 +ghcVer = GHC9_2 +#elif __GLASGOW_HASKELL__ == 900 +ghcVer = GHC9_0 +#elif __GLASGOW_HASKELL__ == 810 +ghcVer = GHC8_10 +#elif __GLASGOW_HASKELL__ == 808 +ghcVer = GHC8_8 +#else +ghcVer = error "Coudld not determine GHC Version: __GLASGOW_HASKELL__" +#endif diff --git a/test/opt-test.hs b/test/opt-test.hs --- a/test/opt-test.hs +++ b/test/opt-test.hs @@ -10,9 +10,10 @@ module Main where import Control.Subcategory +import Data.Function ((&)) import qualified Data.Sequence as Seq -import Data.Sized.Builtin (Sized, zipWithSame) -import qualified Data.Sized.Builtin as SV +import Data.Sized (Sized, zipWithSame) +import qualified Data.Sized as SV import Data.Type.Natural import qualified Data.Vector as V import qualified Data.Vector.Generic as G @@ -22,8 +23,9 @@ import qualified Data.Vector.Unboxed as U import Numeric.Natural (Natural) import Shared -import Test.Hspec -import Test.Inspection +import Test.Tasty +import Test.Tasty.ExpectedFailure (expectFailBecause) +import Test.Tasty.Inspection type LSized = Sized [] @@ -35,6 +37,8 @@ type SeqSized = Sized Seq.Seq +{-# ANN module "HLINT: ignore Use camelCase" #-} + zipWith_subcat_List :: (Int -> Int -> Int) -> [Int] -> [Int] -> [Int] zipWith_subcat_List = czipWith @@ -106,68 +110,69 @@ const_two_dom = const 2 main :: IO () -main = hspec $ do - describe "czipWith" $ do - $( inspecting "doesn't contain type classes" $ - hasNoTypeClasses 'zipWith_subcat_List - ) - describe "zipWith" $ do - $( inspecting "doesn't contain type classes" $ - hasNoTypeClasses 'zipWith_List - ) - describe "zipWithSame" $ do - describe "list" $ do - it "doesn't contain type classes" $ - checkInspection - $( inspectTest $ - hasNoTypeClasses 'zipWithSame_List - ) - it "is almost the same as the original zipWith (list)" $ - checkInspection - $( inspectTest $ - 'zipWithSame_List ==- 'zipWith_List_Prel - ) - describe "Boxed Vector" $ do - it "doesn't contain type classes, except for G.Vector" $ - checkInspection - $( inspectTest $ - 'zipWithSame_Boxed - `hasNoTypeClassesExcept` [''G.Vector] - ) - it "is almost the same as the original zipWith (Boxed)" $ - checkInspection - $( inspectTest $ - 'zipWithSame_Boxed ==- 'zipWith_Boxed - ) - describe "Unboxed Vector" $ do - it "doesn't contain type classes except for Unbox" $ - checkInspection - $( inspectTest $ - 'zipWithSame_Unboxed - `hasNoTypeClassesExcept` [''Unbox] - ) - it "doesn't contain type classes if fully instnatiated" $ - checkInspection - $( inspectTest $ - hasNoTypeClasses 'zipWithSame_Unboxed_monomorphic - ) - it "is almost the same as the original zipWith, if fully instantiated" $ - checkInspection - $( inspectTest $ - 'zipWithSame_Unboxed_monomorphic - ==- 'zipWith_Unboxed_monomorphic - ) - describe "length" $ do - it "is a constant function when length is concrete (with Dom dictionary)" $ - checkInspection - $( inspectTest $ - 'length_two ==- 'const_two_dom - ) - it "doesn't contain Integer when the length is concrete" $ - checkInspection - $( inspectTest $ hasNoType 'length_two ''Integer - ) - it "doesn't contain Natural when the length is concrete" $ - checkInspection - $( inspectTest $ hasNoType 'length_two ''Natural - ) +main = + defaultMain $ + testGroup + "Optimisation test" + [ testGroup + "czipWith" + [ $( inspecting "doesn't contain type classes" $ + hasNoTypeClasses 'zipWith_subcat_List + ) + ] + , testGroup + "zipWith" + [ $( inspecting "doesn't contain type classes" $ + hasNoTypeClasses 'zipWith_List + ) + ] + , testGroup + "zipWithSame" + [ testGroup + "list" + [ $( inspecting "doesn't contain type classes" $ + hasNoTypeClasses 'zipWithSame_List + ) + , $( inspecting "is almost the same as the original zipWith (list)" $ + 'zipWithSame_List ==- 'zipWith_List_Prel + ) + ] + , testGroup + "Boxed Vector" + [ $( inspecting "doesn't contain type classes, except for G.Vector" $ + 'zipWithSame_Boxed + `hasNoTypeClassesExcept` [''G.Vector] + ) + , $( inspecting "is almost the same as the original zipWith (Boxed)" $ + 'zipWithSame_Boxed ==- 'zipWith_Boxed + ) + ] + , testGroup + "Unboxed Vector" + [ $( inspecting "doesn't contain type classes except for Unbox" $ + 'zipWithSame_Unboxed + `hasNoTypeClassesExcept` [''Unbox] + ) + & if ghcVer >= GHC9_0 + then expectFailBecause "This suffers from Simplified Subsumption" + else id + , $( inspecting "doesn't contain type classes if fully instnatiated" $ + hasNoTypeClasses 'zipWithSame_Unboxed_monomorphic + ) + , $( inspecting "is almost the same as the original zipWith, if fully instantiated" $ + 'zipWithSame_Unboxed_monomorphic + ==- 'zipWith_Unboxed_monomorphic + ) + ] + ] + , testGroup + "length" + [ $( inspecting "is a constant function when length is concrete (with Dom dictionary)" $ + 'length_two ==- 'const_two_dom + ) + , $( inspecting "doesn't contain Integer when the length is concrete" $ hasNoType 'length_two ''Integer + ) + , $( inspecting "doesn't contain Natural when the length is concrete" $ hasNoType 'length_two ''Natural + ) + ] + ]