Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Convert to use hedgehog and hspec #25

Closed
wants to merge 3 commits into from
Closed

Convert to use hedgehog and hspec #25

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
4587787
Convert to use hedgehog and hspec
newhoggy Jan 23, 2020
136da05
Remove Semigroup import
newhoggy Jan 23, 2020
b26e731
Enable CI on PR
newhoggy Jan 23, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
8 changes: 4 additions & 4 deletions .github/workflows/haskell.yml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
name: Haskell CI

on: [push]
on: [push, pull_request]


jobs:
Expand Down Expand Up @@ -51,10 +51,10 @@ jobs:
run: cabal v2-configure

- name: Install dependencies
run: cabal v2-build --enable-tests --enable-benchmarks --write-ghc-environment-files=always --only-dependencies
run: cabal v2-build --enable-tests --enable-benchmarks --write-ghc-environment-files=always --test-show-details=direct --only-dependencies

- name: Build
run: cabal v2-build --enable-tests --enable-benchmarks --write-ghc-environment-files=always
run: cabal v2-build --enable-tests --enable-benchmarks --write-ghc-environment-files=always --test-show-details=direct

- name: Run tests
run: cabal v2-test --enable-tests --enable-benchmarks --write-ghc-environment-files=always
run: cabal v2-test --enable-tests --enable-benchmarks --write-ghc-environment-files=always --test-show-details=direct
69 changes: 69 additions & 0 deletions .vscode/tasks.json
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,69 @@
{
"version": "2.0.0",
"tasks": [
{
"label": "Build",
"type": "shell",
"command": "bash",
"args": ["-lc", "cabal v2-build --enable-tests && echo 'Done'"],
"group": {
"kind": "build",
"isDefault": true
},
"problemMatcher": {
"owner": "haskell",
"fileLocation": "relative",
"pattern": [
{
"regexp": "^(.+?):(\\d+):(\\d+):\\s+(error|warning|info):.*$",
"file": 1, "line": 2, "column": 3, "severity": 4
},
{
"regexp": "\\s*(.*)$",
"message": 1
}
]
},
"presentation": {
"echo": false,
"reveal": "always",
"focus": false,
"panel": "shared",
"showReuseMessage": false,
"clear": true
}
},
{
"label": "Test",
"type": "shell",
"command": "bash",
"args": ["-lc", "cabal v2-test --enable-tests --write-ghc-environment-files=ghc8.4.4+ --test-show-details=direct && echo 'Done'"],
"group": {
"kind": "test",
"isDefault": true
},
"problemMatcher": {
"owner": "haskell",
"fileLocation": "relative",
"pattern": [
{
"regexp": "^(.+?):(\\d+):(\\d+):.*$",
"file": 1, "line": 2, "column": 3, "severity": 4
},
{
"regexp": "\\s*(\\d\\)\\s)?(.*)$",
"message": 2
}
]
},
"presentation": {
"echo": false,
"reveal": "always",
"focus": false,
"panel": "shared",
"showReuseMessage": false,
"clear": true
}
}
]
}
1 change: 0 additions & 1 deletion Data/RTree/Base.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -76,7 +76,6 @@ import qualified Data.List as L (length, map)
import Data.Maybe (catMaybes, isJust)
import qualified Data.Maybe as Maybe (mapMaybe)
import Data.Typeable (Typeable)
import Data.Semigroup
import GHC.Generics (Generic)
import Prelude hiding (length, lookup, map, null)

Expand Down
23 changes: 11 additions & 12 deletions Data/RTree/Strict.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{- |
Expand Down Expand Up @@ -59,21 +59,20 @@ module Data.RTree.Strict
, toList
) where

import Prelude hiding (lookup, length, null, map)
import Prelude hiding (length, lookup, map, null)

import Data.Binary
import Data.Function (on)
import qualified Data.List as L (length)
import qualified Data.Maybe as Maybe (mapMaybe)
import Data.Semigroup
import Data.Typeable (Typeable)
import Data.Function (on)
import qualified Data.List as L (length)
import qualified Data.Maybe as Maybe (mapMaybe)
import Data.Typeable (Typeable)

import Control.DeepSeq (NFData)
import GHC.Generics (Generic)
import GHC.Generics (Generic)
--import Data.RTree.Base hiding (RTree, singleton, fromList, insertWith, unionDistinctWith, unionWith, insert, mapMaybe, union, fromList', unionDistinct, unionDistinctSplit)
import qualified Data.RTree.Base as Lazy
import Data.RTree.MBB hiding (mbb)
import qualified Data.RTree.MBB as MBB
import Data.RTree.MBB hiding (mbb)
import qualified Data.RTree.MBB as MBB
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

is there a tool you're using to format the code?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm set up to use stylish-haskell with Visual Studio Code.

Currently using these rules:

$ cat .stylish-haskell.yaml
# stylish-haskell configuration file
# ==================================

# The stylish-haskell tool is mainly configured by specifying steps. These steps
# are a list, so they have an order, and one specific step may appear more than
# once (if needed). Each file is processed by these steps in the given order.
steps:
  # Convert some ASCII sequences to their Unicode equivalents. This is disabled
  # by default.
  # - unicode_syntax:
  #     # In order to make this work, we also need to insert the UnicodeSyntax
  #     # language pragma. If this flag is set to true, we insert it when it's
  #     # not already present. You may want to disable it if you configure
  #     # language extensions using some other method than pragmas. Default:
  #     # true.
  #     add_language_pragma: true

  # Align the right hand side of some elements.  This is quite conservative
  # and only applies to statements where each element occupies a single
  # line.
  - simple_align:
      cases: true
      top_level_patterns: true
      records: true

  # Import cleanup
  - imports:
      # There are different ways we can align names and lists.
      #
      # - global: Align the import names and import list throughout the entire
      #   file.
      #
      # - file: Like global, but don't add padding when there are no qualified
      #   imports in the file.
      #
      # - group: Only align the imports per group (a group is formed by adjacent
      #   import lines).
      #
      # - none: Do not perform any alignment.
      #
      # Default: global.
      align: group

      # Folowing options affect only import list alignment.
      #
      # List align has following options:
      #
      # - after_alias: Import list is aligned with end of import including
      #   'as' and 'hiding' keywords.
      #
      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
      #   >                                          init, last, length)
      #
      # - with_alias: Import list is aligned with start of alias or hiding.
      #
      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
      #   >                                 init, last, length)
      #
      # - new_line: Import list starts always on new line.
      #
      #   > import qualified Data.List      as List
      #   >     (concat, foldl, foldr, head, init, last, length)
      #
      # Default: after_alias
      list_align: after_alias

      # Long list align style takes effect when import is too long. This is
      # determined by 'columns' setting.
      #
      # - inline: This option will put as much specs on same line as possible.
      #
      # - new_line: Import list will start on new line.
      #
      # - new_line_multiline: Import list will start on new line when it's
      #   short enough to fit to single line. Otherwise it'll be multiline.
      #
      # - multiline: One line per import list entry.
      #   Type with contructor list acts like single import.
      #
      #   > import qualified Data.Map as M
      #   >     ( empty
      #   >     , singleton
      #   >     , ...
      #   >     , delete
      #   >     )
      #
      # Default: inline
      long_list_align: inline

      # Align empty list (importing instances)
      #
      # Empty list align has following options
      #
      # - inherit: inherit list_align setting
      #
      # - right_after: () is right after the module name:
      #
      #   > import Vector.Instances ()
      #
      # Default: inherit
      empty_list_align: inherit

      # List padding determines indentation of import list on lines after import.
      # This option affects 'long_list_align'.
      #
      # - <integer>: constant value
      #
      # - module_name: align under start of module name.
      #   Useful for 'file' and 'group' align settings.
      list_padding: 4

      # Separate lists option affects formating of import list for type
      # or class. The only difference is single space between type and list
      # of constructors, selectors and class functions.
      #
      # - true: There is single space between Foldable type and list of it's
      #   functions.
      #
      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))
      #
      # - false: There is no space between Foldable type and list of it's
      #   functions.
      #
      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))
      #
      # Default: true
      separate_lists: true

  # Language pragmas
  - language_pragmas:
      # We can generate different styles of language pragma lists.
      #
      # - vertical: Vertical-spaced language pragmas, one per line.
      #
      # - compact: A more compact style.
      #
      # - compact_line: Similar to compact, but wrap each line with
      #   `{-#LANGUAGE #-}'.
      #
      # Default: vertical.
      style: vertical

      # Align affects alignment of closing pragma brackets.
      #
      # - true: Brackets are aligned in same collumn.
      #
      # - false: Brackets are not aligned together. There is only one space
      #   between actual import and closing bracket.
      #
      # Default: true
      align: true

      # stylish-haskell can detect redundancy of some language pragmas. If this
      # is set to true, it will remove those redundant pragmas. Default: true.
      remove_redundant: true

  # Replace tabs by spaces. This is disabled by default.
  # - tabs:
  #     # Number of spaces to use for each tab. Default: 8, as specified by the
  #     # Haskell report.
  #     spaces: 8

  # Remove trailing whitespace
  - trailing_whitespace: {}

# A common setting is the number of columns (parts of) code will be wrapped
# to. Different steps take this into account. Default: 80.
columns: 800

# By default, line endings are converted according to the OS. You can override
# preferred format here.
#
# - native: Native newline format. CRLF on Windows, LF on other OSes.
#
# - lf: Convert to LF ("\n").
#
# - crlf: Convert to CRLF ("\r\n").
#
# Default: native.
newline: native

# Sometimes, language extensions are specified in a cabal file or from the
# command line instead of using language pragmas in the file. stylish-haskell
# needs to be aware of these, so it can parse the file correctly.
#
# No language extensions are enabled by default.
# language_extensions:
  # - TemplateHaskell
  # - QuasiQuotes



newtype RTree a = RTree {toLazy' :: Lazy.RTree a}
Expand Down Expand Up @@ -183,9 +182,9 @@ addLeaf f left right
newChildren = findNodeWithMinimalAreaIncrease f left (Lazy.getChildren right)
(eq, nonEq) = Lazy.partition (on (==) Lazy.getMBB left) $ Lazy.getChildren right
newNode = case eq of
[] -> left
[] -> left
[x] -> simpleMergeEqNode f left x
_ -> error "addLeaf: invalid RTree"
_ -> error "addLeaf: invalid RTree"

findNodeWithMinimalAreaIncrease :: (a -> a -> a) -> Lazy.RTree a -> [Lazy.RTree a] -> [Lazy.RTree a]
findNodeWithMinimalAreaIncrease f leaf children = splitMinimal xsAndIncrease
Expand Down
28 changes: 13 additions & 15 deletions data-r-tree.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -32,15 +32,14 @@ common binary { build-depends: binary
common containers { build-depends: containers >= 0.5 && < 0.7 }
common deepseq { build-depends: deepseq >= 1.4 && < 1.5 }
common ghc-heap-view { build-depends: ghc-heap-view >= 0.5 && < 0.7 }
common hedgehog { build-depends: hedgehog >= 1.0.2 && < 1.1 }
common hspec { build-depends: hspec >= 2.4 && < 2.8 }
common HUnit { build-depends: HUnit >= 1.6 && < 1.7 }
common QuickCheck { build-depends: QuickCheck >= 2.13 && < 2.14 }
common test-framework { build-depends: test-framework >= 0.8 && < 0.9 }
common test-framework-hunit { build-depends: test-framework-hunit >= 0.3 && < 0.4 }
common test-framework-quickcheck2 { build-depends: test-framework-quickcheck2 >= 0.3 && < 0.4 }
common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1 && < 0.2 }

common config
default-language: Haskell2010
ghc-options: -Wall -fwarn-tabs
ghc-options: -Wall -fwarn-tabs -Wno-orphans

common data-r-tree
build-depends: data-r-tree
Expand All @@ -60,28 +59,27 @@ test-suite properties
, binary
, containers
, data-r-tree
, ghc-heap-view
, hedgehog
, hspec
, HUnit
, QuickCheck
, test-framework
, test-framework-hunit
, test-framework-quickcheck2
, hw-hspec-hedgehog
type: exitcode-stdio-1.0
main-is: RTreeProperties.hs
other-extensions: NoMonomorphismRestriction
ghc-options: -Wall -fwarn-tabs -Wno-orphans
other-modules: Gen
hs-source-dirs: test

test-suite strict
import: base, config
, data-r-tree
, deepseq
, ghc-heap-view
, hedgehog
, hspec
, HUnit
, QuickCheck
, test-framework
, test-framework-hunit
, test-framework-quickcheck2
, hw-hspec-hedgehog
type: exitcode-stdio-1.0
main-is: RTreeStrict.hs
ghc-options: -Wall -fwarn-tabs -Wno-orphans
other-modules: Gen
hs-source-dirs: test
45 changes: 45 additions & 0 deletions test/Gen.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,45 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}

module Gen
( mbb
, rtreeInt
) where

import Control.Applicative ((<$>))
import Data.RTree.Base
import Data.RTree.MBB hiding (mbb)
import Hedgehog
import Prelude hiding (length, lookup, map, null)
import Text.Show.Functions ()

import qualified Hedgehog.Gen as G
import qualified Hedgehog.Range as R

mbb :: MonadGen m => m MBB
mbb = G.shrink more $ do
cx <- G.double (R.linearFrac (-100000.0) 100000.0)
cy <- G.double (R.linearFrac (-100000.0) 100000.0)
h <- G.double (R.linearFrac 0.0 100000.0)
w <- G.double (R.linearFrac 0.0 100000.0)
return $ MBB (cx - w) (cy - h) (cx + w) (cy + h)
where more :: MBB -> [MBB]
more mbb'@(MBB ulx uly brx bry)
| isPointMBB mbb' = []
| otherwise = [MBB (mid ulx brx) (mid uly bry) (mid ulx brx) (mid uly bry)]
mid x y = (y - x) / 2
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

One benefit of hedgehog is you get automatic shrinking for free. I supplied a custom shrinker here just in case you need that behaviour, but if you don't this can be dropped.


rtreeInt :: MonadGen m => m (RTree Int)
rtreeInt = G.shrink more $ do
ks <- G.list (R.linear 0 100) mbb
return $ fromList (ks `zip` [1..])
where more :: RTree Int -> [RTree Int]
more Empty = []
more Leaf{} = [Empty]
more t =
[Empty] ++
-- shrink to subterms
getChildren t ++
-- recursively shrink subterms
[createNodeWithChildren newChildred | newChildred <- more <$> getChildren t]
Loading