diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,229 +0,0 @@ -# loc - -Overview of the concepts: - -![Example text illustrating Loc, Span, and Area](https://raw.githubusercontent.com/chris-martin/haskell-libraries/4be81df645d4a2e5073f45563930e202e41209c7/loc/example.png) - -* `Loc` - a cursor position, starting at the origin `1:1` -* `Span` - a nonempty contiguous region between two locs -* `Area` - a set of zero or more spans with gaps between them - -See also: - -* [loc-test](https://hackage.haskell.org/package/loc-test) - - Test-related utilities for this package. - -## `Pos` - -Since all of the numbers we're dealing with in this domain are positive, we -define a "positive integer" type. This is a newtype for `Natural` that doesn't -allow zero. - -```haskell -newtype Pos = Pos Natural - deriving (Eq, Ord) - -instance Num Pos where - fromInteger = Pos . checkForUnderflow . fromInteger - Pos x + Pos y = Pos (x + y) - Pos x - Pos y = Pos (checkForUnderflow (x - y)) - Pos x * Pos y = Pos (x * y) - abs = id - signum _ = Pos 1 - negate _ = throw Underflow - -checkForUnderflow :: Natural -> Natural -checkForUnderflow n = - if n == 0 then throw Underflow else n -``` - -`Pos` does not have an `Integral` instance, because that would require -implementing `quotRem :: Pos -> Pos -> (Pos, Pos)`, which doesn't make much -sense. Therefore we can't use `toInteger` on `Pos`. Instead we use our own -`ToNat` class to convert positive numbers to natural numbers. - -```haskell -class ToNat a where - toNat :: a -> Natural - -instance ToNat Pos where - toNat (Pos n) = n -``` - -## `Line`, `Column` - -We then add some newtypes to be more specific about whether we're talking about -line or column numbers. - -```haskell -newtype Line = Line Pos - deriving (Eq, Ord, Num, Real, Enum, ToNat) - -newtype Column = Column Pos - deriving (Eq, Ord, Num, Real, Enum, ToNat) -``` - -## `Loc` - -A `Loc` is a `Line` and a `Column`. - -```haskell -data Loc = Loc - { line :: Line - , column :: Column - } - deriving (Eq, Ord) -``` - -Note that this library has chosen to be remain entirely agnostic of the text -that the positions are referring to. Therefore there is no "plus one" operation -on `Loc`, because the next `Loc` after *4:17* could be either *4:18* or *5:1* - -we can't tell without knowing the line lengths. - -## `Span` - -A `Span` is a start `Loc` and an end `Loc`. - -```haskell -data Span = Span - { start :: Loc - , end :: Loc - } deriving (Eq, Ord) -``` - -A `Span` is not allowed to be empty; in other words, `start` and `end` must be -different. - -There are two functions for constructing a `Span`. They both reorder their -arguments as appropriate to make sure the start comes before the end (so that -spans are never backwards). They take different approaches to ensuring that -spans are never empty: the first can throw an exception, whereas the second is -typed as `Maybe`. - -```haskell -fromTo :: Loc -> Loc -> Span -fromTo a b = - maybe (throw EmptySpan) id (fromToMay a b) - -fromToMay :: Loc -> Loc -> Maybe Span -fromToMay a b = - case compare a b of - LT -> Just (Span a b) - GT -> Just (Span b a) - EQ -> Nothing -``` - -The choice to use an exclusive upper bound *\[start, end)* rather than two -inclusive bounds *\[start, end\]* is forced by the decision to be text-agnostic. -With inclusive ranges, you couldn't tell whether span *4:16-4:17* abuts span -*5:1-5:2* without knowing whether the character at position *4:17* is a newline. - -## `Area` - -Conceptually, an area is a set of spans. To support efficient union and -difference operations, `Area` is defined like this: - -```haskell -data Terminus = Start | End - deriving (Eq, Ord) - -newtype Area = Area (Map Loc Terminus) - deriving (Eq, Ord) -``` - -You can think of this as a sorted list of the spans' start and end positions, -along with a tag indicating whether each is a start or an end. - -## `Show` - -We define custom `Show` and `Read` instances to be able to write terse tests like: - -```haskell ->>> addSpan (read "1:1-6:1") (read "[1:1-3:1,6:1-6:2,7:4-7:5]") -[1:1-6:2,7:4-7:5] -``` - -These are the `showsPrec` implementations for `Loc` and `Span`: - -```haskell -locShowsPrec :: Int -> Loc -> ShowS -locShowsPrec _ (Loc l c) = - shows l . - showString ":" . - shows c - -spanShowsPrec :: Int -> Span -> ShowS -spanShowsPrec _ (Span a b) = - locShowsPrec 10 a . - showString "-" . - locShowsPrec 10 b -``` - -## `Read` - -The parser for `Pos` is based on the parser for `Natural`, applying `mfilter (/= -0)` to make the parser fail if the input represents a zero. - -```haskell -posReadPrec :: ReadPrec Pos -posReadPrec = - Pos <$> mfilter (/= 0) readPrec -``` - -As a reminder, the type of `mfilter` is: - -```haskell -mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a -``` - -The `Loc` parser uses a very typical `Applicative` pattern: - -```haskell --- | Parses a single specific character. -readPrecChar :: Char -> ReadPrec () -readPrecChar = void . readP_to_Prec . const . ReadP.char - -locReadPrec :: ReadPrec Loc -locReadPrec = - Loc <$> - readPrec <* - readPrecChar ':' <*> - readPrec -``` - -We used `mfilter` above to introduce failure into the `Pos` parser; for `Span` -we use `empty`. - -```haskell -empty :: Alternative f => f a -``` - -First we use `fromToMay` to produce a `Maybe Span`, and then in the case where -the result is `Nothing` we use `empty` to make the parser fail. - -```haskell -spanReadPrec :: ReadPrec Span -spanReadPrec = - locReadPrec >>= \a -> - readPrecChar '-' *> - locReadPrec >>= \b -> - maybe empty pure (fromToMay a b) -``` - -## Comparison to similar packages - -### `srcloc` - -[srcloc](https://hackage.haskell.org/package/srcloc) has a similar general -purpose: defining types related to positions in text files. - -Some differences: - -* `srcloc`'s `Pos` type (comparable to our `Loc` type) has a `FilePath` - parameter, whereas this library doesn't consider file paths at all. -* `srcloc` has nothing comparable to the `Area` type. - -There are some undocumented aspects of `srcloc` we find confusing: - -* What does "character offset" mean? -* Does `srcloc`'s `Loc` type use inclusive or exclusive bounds? diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,58 @@ +### 0.1.4.1 (2023-01-10) + +Support GHC 9.4 + +### 0.1.4.0 (2022-06-27) + +Drop support for GHC 8.4, 8.6, and 8.8 + +Renamed test suite to `test-loc-properties` + +Added module `Data.Loc.SpanOrLoc` + +Added to module `Data.Loc` the type `SpanOrLoc` and the functions +`spanOrLocFromTo`, `spanOrLocStart`, and `spanOrLocEnd` + +### 0.1.3.16 (2022-01-24) + +Fix test suite failure on case-insensitive file systems + +### 0.1.3.14 (2022-01-13) + +Drop support for GHC 8.0 and 8.2 + +### 0.1.3.12 (2022-01-13) + +Support GHC 9.0 and 9.2 + +Tighten dependency version bounds + +### 0.1.3.10 (2020-11-04) + +Added `Data` instances for `Area`, `Loc`, `Pos`, `Line`, `Column`, and `Span` + +### 0.1.3.8 - 2020 May 20 + +Support GHC 8.10 + +### 0.1.3.6 - 2020 Mar 15 + +Support GHC 8.8 + +### Older + +The change log was not maintained before this point. + +- 0.1.3.4 (2018-11-22) +- 0.1.3.3 (2018-08-23) +- 0.1.3.2 (2017-12-03) +- 0.1.3.1 (2017-08-20) +- 0.1.3.0 (2017-07-22) +- 0.1.2.3 (2017-05-28) +- 0.1.2.2 (2017-05-28) +- 0.1.2.1 (2017-05-16) +- 0.1.2.0 (2017-05-07) +- 0.1.1.0 (2017-05-07) +- 0.1.0.2 (2017-05-07) +- 0.1.0.1 (2017-05-07) +- 0.1.0.0 (2017-05-07) diff --git a/license.txt b/license.txt --- a/license.txt +++ b/license.txt @@ -1,4 +1,4 @@ -Copyright 2017 Chris Martin +Copyright 2017 Mission Valley Software LLC Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/loc-test-src/Test/Loc/Hedgehog/Gen.hs b/loc-test-src/Test/Loc/Hedgehog/Gen.hs deleted file mode 100644 --- a/loc-test-src/Test/Loc/Hedgehog/Gen.hs +++ /dev/null @@ -1,265 +0,0 @@ -{- | - -Hedgehog generators for types defined in the /loc/ package. - --} -module Test.Loc.Hedgehog.Gen - ( - -- * Line - line, line', defMaxLine, - - -- * Column - column, column', defMaxColumn, - - -- * Loc - loc, loc', - - -- * Span - span, span', - - -- * Area - area, area', - - -- * Generator bounds - Bounds, boundsSize, - ) - where - -import Data.Loc (ToNat (..)) -import Data.Loc.Internal.Prelude -import Data.Loc.Types - -import qualified Data.Loc as Loc - -import Hedgehog (Gen) -import Prelude (Num (..)) - -import qualified Data.List as List -import qualified Data.Set as Set -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range - - --------------------------------------------------------------------------------- --- Parameter defaults --------------------------------------------------------------------------------- - --- | The default maximum line: 99. -defMaxLine :: Line -defMaxLine = 99 - --- | The default maximum column number: 99. -defMaxColumn :: Column -defMaxColumn = 99 - - --------------------------------------------------------------------------------- --- Bounds --------------------------------------------------------------------------------- - --- | Inclusive lower and upper bounds on a range. -type Bounds a = (a, a) - -{- | - -The size of a range specified by 'Bounds'. - -Assumes the upper bound is at least the lower bound. - --} -boundsSize :: Num n => (n, n) -> n -boundsSize (a, b) = - 1 + b - a - - --------------------------------------------------------------------------------- --- Pos --------------------------------------------------------------------------------- - -{- | - -@'pos' a b@ generates a number on the linear range /a/ to /b/. - --} -pos :: (ToNat n, Num n) - => Bounds n -- ^ Minimum and maximum value to generate - -> Gen n -pos (a, b) = - let - range = Range.linear (toNat a) (toNat b) - in - fromInteger . toInteger <$> Gen.integral range - -{- | - -@'line' a b@ generates a line number on the linear range /a/ to /b/. - --} -line - :: Bounds Line -- ^ Minimum and maximum line number - -> Gen Line -line = pos - -{- | - -Generates a line number within the default bounds @(1, 'defMaxLine')@. - --} -line' :: Gen Line -line' = - line (1, defMaxLine) - -{- | - -@'column' a b@ generates a column number on the linear range /a/ to /b/. - --} -column - :: Bounds Column -- ^ Minimum and maximum column number - -> Gen Column -column = pos - -{- | - -Generates a column number within the default bounds @(1, 'defMaxColumn')@. - --} -column' :: Gen Column -column' = - column (1, defMaxColumn) - - --------------------------------------------------------------------------------- --- Loc --------------------------------------------------------------------------------- - -{- | - -@'loc' lineBounds columnBounds@ generates a 'Loc' with the line number -bounded by @lineBounds@ and column number bounded by @columnBounds@. - --} -loc - :: Bounds Line -- ^ Minimum and maximum line number - -> Bounds Column -- ^ Minimum and maximum column number - -> Gen Loc -loc lineBounds columnBounds = - Loc.loc <$> line lineBounds - <*> column columnBounds - -{- | - -Generates a 'Loc' within the default line and column bounds. - --} -loc' :: Gen Loc -loc' = - loc (1, defMaxLine) (1, defMaxColumn) - - --------------------------------------------------------------------------------- --- Span --------------------------------------------------------------------------------- - -{- | - -@'span' lineBounds columnBounds@ generates a 'Span' with start and end -positions whose line numbers are bounded by @lineBounds@ and whose column -numbers are bounded by @columnBounds@. - --} -span - :: Bounds Line -- ^ Minimum and maximum line number - -> Bounds Column -- ^ Minimum and maximum column number - -> Gen Span -span lineBounds columnBounds@(minColumn, maxColumn) = - let - lines :: Gen (Line, Line) - lines = - line lineBounds >>= \a -> - line lineBounds <&> \b -> - (min a b, max a b) - - columnsDifferentLine :: Gen (Column, Column) - columnsDifferentLine = - column columnBounds >>= \a -> - column columnBounds <&> \b -> - (a, b) - - columnsSameLine :: Gen (Column, Column) - columnsSameLine = - column (minColumn + 1, maxColumn) >>= \a -> - column columnBounds <&> \b -> - case compare a b of - EQ -> (a - 1, b) - LT -> (a, b) - GT -> (b, a) - - in - lines >>= \(startLine, endLine) -> - (if startLine /= endLine - then columnsDifferentLine - else columnsSameLine - ) <&> \(startColumn, endColumn) -> - - let - start = Loc.loc startLine startColumn - end = Loc.loc endLine endColumn - - in - Loc.spanFromTo start end - -{- | - -Generates a 'Span' with start and end positions within the default line and -column bounds. - --} -span' :: Gen Span -span' = - span (1, defMaxLine) (1, defMaxColumn) - - --------------------------------------------------------------------------------- --- Area --------------------------------------------------------------------------------- - -{- | - -@'area' lineBounds columnBounds@ generates an 'Area' consisting of 'Span's -with start and end positions whose line numbers are bounded by @lineBounds@ -and whose column numbers are bounded by @columnBounds@. - --} -area - :: Bounds Line -- ^ Minimum and maximum line number - -> Bounds Column -- ^ Minimum and maximum column number - -> Gen Area -area lineBounds columnBounds = - fold . snd . mapAccumL f Nothing . Set.toAscList . Set.fromList <$> locs - - where - gridSize :: Int = fromIntegral $ toNat (boundsSize lineBounds) - `max` toNat (boundsSize columnBounds) - - locs :: Gen [Loc] = - loc lineBounds columnBounds - & List.repeat - & List.take (gridSize `div` 5) - & sequenceA - - f :: Maybe Loc -> Loc -> (Maybe Loc, Area) - f prevLocMay newLoc = - case prevLocMay of - Just prevLoc -> (Nothing, Loc.areaFromTo prevLoc newLoc) - Nothing -> (Just newLoc, mempty) - -{- | - -Generates an 'Area' consisting of 'Span's with start and end positions within -the default line and column bounds. - --} -area' :: Gen Area -area' = - area (1, defMaxLine) (1, defMaxColumn) diff --git a/loc.cabal b/loc.cabal --- a/loc.cabal +++ b/loc.cabal @@ -1,9 +1,9 @@ cabal-version: 3.0 name: loc -version: 0.1.4.0 - -synopsis: Types representing line and column positions and ranges in text files. +version: 0.1.4.1 +synopsis: Line and column positions and ranges in text files +category: Data Structures, Text description: The package name /loc/ stands for “location” and is @@ -13,9 +13,8 @@ the @Span@ type is a nonempty range between two @Loc@s, and the @Area@ type is a set of non-touching @Span@s. -category: Data Structures, Text - -homepage: https://github.com/typeclasses/loc +homepage: https://github.com/typeclasses/loc +bug-reports: https://github.com/typeclasses/loc/issues author: Chris Martin maintainer: Chris Martin, Julie Moronuki @@ -24,9 +23,12 @@ license: Apache-2.0 license-file: license.txt -build-type: Simple +extra-source-files: *.md +extra-doc-files: *.png, *.svg -extra-source-files: example.png example.svg README.md +source-repository head + type: git + location: git://github.com/typeclasses/loc.git common base default-language: Haskell2010 @@ -40,14 +42,9 @@ NoImplicitPrelude ScopedTypeVariables ghc-options: -Wall - build-depends: base >= 4.14 && < 4.17 - build-depends: containers >= 0.6.5.1 && < 0.7 - -common test - import: base - hs-source-dirs: test - ghc-options: -threaded - build-depends: loc + build-depends: + , base ^>= 4.14 || ^>= 4.15 || ^>= 4.16 || ^>= 4.17 + , containers ^>= 0.6.4 library import: base @@ -67,13 +64,15 @@ Data.Loc.Types test-suite test-loc-properties - import: test + import: base type: exitcode-stdio-1.0 + hs-source-dirs: test + ghc-options: -threaded default-extensions: TemplateHaskell main-is: Main.hs - hs-source-dirs: loc-test-src - other-modules: Test.Loc.Hedgehog.Gen + other-modules: Gen build-depends: - hspec - , hspec-hedgehog - , hedgehog ^>= 1.0.2 || ^>= 1.1 + , hspec ^>= 2.8.5 || ^>= 2.9 || ^>= 2.10 + , hspec-hedgehog ^>= 0.0.1 + , hedgehog ^>= 1.0.5 || ^>= 1.1 || ^>= 1.2 + , loc diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,230 @@ +The package name *loc* stands for “location” and is +also an allusion to the acronym for “lines of code”. + +Overview of the concepts: + +![Example text illustrating Loc, Span, and Area](https://raw.githubusercontent.com/chris-martin/haskell-libraries/4be81df645d4a2e5073f45563930e202e41209c7/loc/example.png) + +* `Loc` - a cursor position, starting at the origin `1:1` +* `Span` - a nonempty contiguous region between two locs +* `Area` - a set of zero or more spans with gaps between them + +See also: + +* [loc-test](https://hackage.haskell.org/package/loc-test) - + Test-related utilities for this package. + +## `Pos` + +Since all of the numbers we're dealing with in this domain are positive, we +define a "positive integer" type. This is a newtype for `Natural` that doesn't +allow zero. + +```haskell +newtype Pos = Pos Natural + deriving (Eq, Ord) + +instance Num Pos where + fromInteger = Pos . checkForUnderflow . fromInteger + Pos x + Pos y = Pos (x + y) + Pos x - Pos y = Pos (checkForUnderflow (x - y)) + Pos x * Pos y = Pos (x * y) + abs = id + signum _ = Pos 1 + negate _ = throw Underflow + +checkForUnderflow :: Natural -> Natural +checkForUnderflow n = + if n == 0 then throw Underflow else n +``` + +`Pos` does not have an `Integral` instance, because that would require +implementing `quotRem :: Pos -> Pos -> (Pos, Pos)`, which doesn't make much +sense. Therefore we can't use `toInteger` on `Pos`. Instead we use our own +`ToNat` class to convert positive numbers to natural numbers. + +```haskell +class ToNat a where + toNat :: a -> Natural + +instance ToNat Pos where + toNat (Pos n) = n +``` + +## `Line`, `Column` + +We then add some newtypes to be more specific about whether we're talking about +line or column numbers. + +```haskell +newtype Line = Line Pos + deriving (Eq, Ord, Num, Real, Enum, ToNat) + +newtype Column = Column Pos + deriving (Eq, Ord, Num, Real, Enum, ToNat) +``` + +## `Loc` + +A `Loc` is a `Line` and a `Column`. + +```haskell +data Loc = Loc + { line :: Line + , column :: Column + } + deriving (Eq, Ord) +``` + +Note that this library has chosen to be remain entirely agnostic of the text +that the positions are referring to. Therefore there is no "plus one" operation +on `Loc`, because the next `Loc` after *4:17* could be either *4:18* or *5:1* - +we can't tell without knowing the line lengths. + +## `Span` + +A `Span` is a start `Loc` and an end `Loc`. + +```haskell +data Span = Span + { start :: Loc + , end :: Loc + } deriving (Eq, Ord) +``` + +A `Span` is not allowed to be empty; in other words, `start` and `end` must be +different. + +There are two functions for constructing a `Span`. They both reorder their +arguments as appropriate to make sure the start comes before the end (so that +spans are never backwards). They take different approaches to ensuring that +spans are never empty: the first can throw an exception, whereas the second is +typed as `Maybe`. + +```haskell +fromTo :: Loc -> Loc -> Span +fromTo a b = + maybe (throw EmptySpan) id (fromToMay a b) + +fromToMay :: Loc -> Loc -> Maybe Span +fromToMay a b = + case compare a b of + LT -> Just (Span a b) + GT -> Just (Span b a) + EQ -> Nothing +``` + +The choice to use an exclusive upper bound *\[start, end)* rather than two +inclusive bounds *\[start, end\]* is forced by the decision to be text-agnostic. +With inclusive ranges, you couldn't tell whether span *4:16-4:17* abuts span +*5:1-5:2* without knowing whether the character at position *4:17* is a newline. + +## `Area` + +Conceptually, an area is a set of spans. To support efficient union and +difference operations, `Area` is defined like this: + +```haskell +data Terminus = Start | End + deriving (Eq, Ord) + +newtype Area = Area (Map Loc Terminus) + deriving (Eq, Ord) +``` + +You can think of this as a sorted list of the spans' start and end positions, +along with a tag indicating whether each is a start or an end. + +## `Show` + +We define custom `Show` and `Read` instances to be able to write terse tests like: + +```haskell +>>> addSpan (read "1:1-6:1") (read "[1:1-3:1,6:1-6:2,7:4-7:5]") +[1:1-6:2,7:4-7:5] +``` + +These are the `showsPrec` implementations for `Loc` and `Span`: + +```haskell +locShowsPrec :: Int -> Loc -> ShowS +locShowsPrec _ (Loc l c) = + shows l . + showString ":" . + shows c + +spanShowsPrec :: Int -> Span -> ShowS +spanShowsPrec _ (Span a b) = + locShowsPrec 10 a . + showString "-" . + locShowsPrec 10 b +``` + +## `Read` + +The parser for `Pos` is based on the parser for `Natural`, applying `mfilter (/= +0)` to make the parser fail if the input represents a zero. + +```haskell +posReadPrec :: ReadPrec Pos +posReadPrec = + Pos <$> mfilter (/= 0) readPrec +``` + +As a reminder, the type of `mfilter` is: + +```haskell +mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a +``` + +The `Loc` parser uses a very typical `Applicative` pattern: + +```haskell +-- | Parses a single specific character. +readPrecChar :: Char -> ReadPrec () +readPrecChar = void . readP_to_Prec . const . ReadP.char + +locReadPrec :: ReadPrec Loc +locReadPrec = + Loc <$> + readPrec <* + readPrecChar ':' <*> + readPrec +``` + +We used `mfilter` above to introduce failure into the `Pos` parser; for `Span` +we use `empty`. + +```haskell +empty :: Alternative f => f a +``` + +First we use `fromToMay` to produce a `Maybe Span`, and then in the case where +the result is `Nothing` we use `empty` to make the parser fail. + +```haskell +spanReadPrec :: ReadPrec Span +spanReadPrec = + locReadPrec >>= \a -> + readPrecChar '-' *> + locReadPrec >>= \b -> + maybe empty pure (fromToMay a b) +``` + +## Comparison to similar packages + +### `srcloc` + +[srcloc](https://hackage.haskell.org/package/srcloc) has a similar general +purpose: defining types related to positions in text files. + +Some differences: + +* `srcloc`'s `Pos` type (comparable to our `Loc` type) has a `FilePath` + parameter, whereas this library doesn't consider file paths at all. +* `srcloc` has nothing comparable to the `Area` type. + +There are some undocumented aspects of `srcloc` we find confusing: + +* What does "character offset" mean? +* Does `srcloc`'s `Loc` type use inclusive or exclusive bounds? diff --git a/test/Gen.hs b/test/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Gen.hs @@ -0,0 +1,231 @@ +module Gen where + +import Data.Loc (ToNat (..)) +import Data.Loc.Internal.Prelude +import Data.Loc.Types + +import qualified Data.Loc as Loc + +import Hedgehog (Gen) +import Prelude (Num (..)) + +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + + +-------------------------------------------------------------------------------- +-- Parameter defaults +-------------------------------------------------------------------------------- + +-- | The default maximum line: 99. +defMaxLine :: Line +defMaxLine = 99 + +-- | The default maximum column number: 99. +defMaxColumn :: Column +defMaxColumn = 99 + + +-------------------------------------------------------------------------------- +-- Bounds +-------------------------------------------------------------------------------- + +-- | Inclusive lower and upper bounds on a range. +type Bounds a = (a, a) + +{- | + +The size of a range specified by 'Bounds'. + +Assumes the upper bound is at least the lower bound. + +-} +boundsSize :: Num n => (n, n) -> n +boundsSize (a, b) = 1 + b - a + + +-------------------------------------------------------------------------------- +-- Pos +-------------------------------------------------------------------------------- + +{- | + +@'pos' a b@ generates a number on the linear range /a/ to /b/. + +-} +pos :: (ToNat n, Num n) => + Bounds n -- ^ Minimum and maximum value to generate + -> Gen n +pos (a, b) = fromInteger . toInteger <$> Gen.integral range + where + range = Range.linear (toNat a) (toNat b) + +{- | + +@'line' a b@ generates a line number on the linear range /a/ to /b/. + +-} +line :: + Bounds Line -- ^ Minimum and maximum line number + -> Gen Line +line = pos + +{- | + +Generates a line number within the default bounds @(1, 'defMaxLine')@. + +-} +line' :: Gen Line +line' = line (1, defMaxLine) + +{- | + +@'column' a b@ generates a column number on the linear range /a/ to /b/. + +-} +column :: + Bounds Column -- ^ Minimum and maximum column number + -> Gen Column +column = pos + +{- | + +Generates a column number within the default bounds @(1, 'defMaxColumn')@. + +-} +column' :: Gen Column +column' = column (1, defMaxColumn) + + +-------------------------------------------------------------------------------- +-- Loc +-------------------------------------------------------------------------------- + +{- | + +@'loc' lineBounds columnBounds@ generates a 'Loc' with the line number +bounded by @lineBounds@ and column number bounded by @columnBounds@. + +-} +loc :: + Bounds Line -- ^ Minimum and maximum line number + -> Bounds Column -- ^ Minimum and maximum column number + -> Gen Loc +loc lineBounds columnBounds = + Loc.loc <$> line lineBounds <*> column columnBounds + +{- | + +Generates a 'Loc' within the default line and column bounds. + +-} +loc' :: Gen Loc +loc' = loc (1, defMaxLine) (1, defMaxColumn) + + +-------------------------------------------------------------------------------- +-- Span +-------------------------------------------------------------------------------- + +{- | + +@'span' lineBounds columnBounds@ generates a 'Span' with start and end +positions whose line numbers are bounded by @lineBounds@ and whose column +numbers are bounded by @columnBounds@. + +-} +span :: + Bounds Line -- ^ Minimum and maximum line number + -> Bounds Column -- ^ Minimum and maximum column number + -> Gen Span +span lineBounds columnBounds@(minColumn, maxColumn) = + let + lines :: Gen (Line, Line) + lines = + line lineBounds >>= \a -> + line lineBounds <&> \b -> + (min a b, max a b) + + columnsDifferentLine :: Gen (Column, Column) + columnsDifferentLine = + column columnBounds >>= \a -> + column columnBounds <&> \b -> + (a, b) + + columnsSameLine :: Gen (Column, Column) + columnsSameLine = + column (minColumn + 1, maxColumn) >>= \a -> + column columnBounds <&> \b -> + case compare a b of + EQ -> (a - 1, b) + LT -> (a, b) + GT -> (b, a) + + in + lines >>= \(startLine, endLine) -> + (if startLine /= endLine + then columnsDifferentLine + else columnsSameLine + ) <&> \(startColumn, endColumn) -> + + let + start = Loc.loc startLine startColumn + end = Loc.loc endLine endColumn + + in + Loc.spanFromTo start end + +{- | + +Generates a 'Span' with start and end positions within the default line and +column bounds. + +-} +span' :: Gen Span +span' = span (1, defMaxLine) (1, defMaxColumn) + + +-------------------------------------------------------------------------------- +-- Area +-------------------------------------------------------------------------------- + +{- | + +@'area' lineBounds columnBounds@ generates an 'Area' consisting of 'Span's +with start and end positions whose line numbers are bounded by @lineBounds@ +and whose column numbers are bounded by @columnBounds@. + +-} +area :: + Bounds Line -- ^ Minimum and maximum line number + -> Bounds Column -- ^ Minimum and maximum column number + -> Gen Area +area lineBounds columnBounds = + fold . snd . mapAccumL f Nothing . Set.toAscList . Set.fromList <$> locs + + where + gridSize :: Int = fromIntegral $ toNat (boundsSize lineBounds) + `max` toNat (boundsSize columnBounds) + + locs :: Gen [Loc] = + loc lineBounds columnBounds + & List.repeat + & List.take (gridSize `div` 5) + & sequenceA + + f :: Maybe Loc -> Loc -> (Maybe Loc, Area) + f prevLocMay newLoc = + case prevLocMay of + Just prevLoc -> (Nothing, Loc.areaFromTo prevLoc newLoc) + Nothing -> (Just newLoc, mempty) + +{- | + +Generates an 'Area' consisting of 'Span's with start and end positions within +the default line and column bounds. + +-} +area' :: Gen Area +area' = area (1, defMaxLine) (1, defMaxColumn) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -17,7 +17,7 @@ import qualified Data.List as List import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import qualified Test.Loc.Hedgehog.Gen as Gen +import qualified Gen import Prelude (fromInteger, ($!), Num (..))