├── .envrc ├── .gitignore ├── cabal.project ├── default.nix ├── flake.lock ├── flake.nix ├── loc ├── changelog.md ├── example.png ├── example.svg ├── license.txt ├── loc.cabal ├── readme.md ├── src │ └── Data │ │ ├── Loc.hs │ │ └── Loc │ │ ├── Area.hs │ │ ├── Exception.hs │ │ ├── Internal │ │ ├── Map.hs │ │ └── Prelude.hs │ │ ├── List │ │ ├── OneToTwo.hs │ │ └── ZeroToTwo.hs │ │ ├── Loc.hs │ │ ├── Pos.hs │ │ ├── Span.hs │ │ ├── SpanOrLoc.hs │ │ └── Types.hs └── test │ ├── Gen.hs │ └── Main.hs ├── nix ├── default.nix └── haskell │ └── integer-types.nix └── readme.md /.envrc: -------------------------------------------------------------------------------- 1 | use flake 2 | 3 | watch_file **/*.cabal cabal.project.freeze **/*.nix flake.lock 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | result 2 | result-* 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: loc 2 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | let 2 | 3 | sources = import ./nix/sources.nix; 4 | nixos-22-05 = import sources."nixos-22.05" {}; 5 | nixos-22-11 = import sources."nixos-22.11" {}; 6 | inherit (nixos-22-11) haskell lib symlinkJoin; 7 | inherit (lib) fold composeExtensions concatMap attrValues; 8 | 9 | combineOverrides = old: 10 | fold composeExtensions (old.overrides or (_: _: { })); 11 | 12 | sourceOverrides = haskell.lib.packageSourceOverrides { 13 | loc = ./loc; 14 | }; 15 | 16 | depOverrides = new: old: { 17 | # package-name = new.callPackage ./nix/package-name-0.0.0.0.nix {}; 18 | }; 19 | 20 | ghc."8.10" = nixos-22-05.haskell.packages.ghc8107.override (old: { 21 | overrides = combineOverrides old [ sourceOverrides depOverrides ]; 22 | }); 23 | 24 | ghc."9.0" = nixos-22-11.haskell.packages.ghc90.override (old: { 25 | overrides = combineOverrides old [ sourceOverrides depOverrides ]; 26 | }); 27 | 28 | ghc."9.2" = nixos-22-11.haskell.packages.ghc92.override (old: { 29 | overrides = combineOverrides old [ sourceOverrides depOverrides ]; 30 | }); 31 | 32 | ghc."9.4" = nixos-22-11.haskell.packages.ghc94.override (old: { 33 | overrides = combineOverrides old [ sourceOverrides depOverrides ]; 34 | }); 35 | 36 | in 37 | 38 | symlinkJoin { 39 | name = "loc"; 40 | paths = concatMap (x: [x.loc]) (attrValues ghc); 41 | } // { 42 | inherit ghc; 43 | pkgs = nixos-22-11; 44 | } 45 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1685518550, 9 | "narHash": "sha256-o2d0KcvaXzTrPRIo0kOLV0/QXHhDQ5DTi+OxcjO8xqY=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "a1720a10a6cfe8234c0e93907ffe81be440f4cef", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1686237827, 24 | "narHash": "sha256-fAZB+Zkcmc+qlauiFnIH9+2qgwM0NO/ru5pWEw3tDow=", 25 | "owner": "NixOS", 26 | "repo": "nixpkgs", 27 | "rev": "81ed90058a851eb73be835c770e062c6938c8a9e", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "NixOS", 32 | "ref": "nixos-23.05", 33 | "repo": "nixpkgs", 34 | "type": "github" 35 | } 36 | }, 37 | "root": { 38 | "inputs": { 39 | "flake-utils": "flake-utils", 40 | "nixpkgs": "nixpkgs" 41 | } 42 | }, 43 | "systems": { 44 | "locked": { 45 | "lastModified": 1681028828, 46 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 47 | "owner": "nix-systems", 48 | "repo": "default", 49 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 50 | "type": "github" 51 | }, 52 | "original": { 53 | "owner": "nix-systems", 54 | "repo": "default", 55 | "type": "github" 56 | } 57 | } 58 | }, 59 | "root": "root", 60 | "version": 7 61 | } 62 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "github:NixOS/nixpkgs/nixos-23.05"; 4 | flake-utils.url = "github:numtide/flake-utils"; 5 | }; 6 | 7 | outputs = inputs: 8 | inputs.flake-utils.lib.eachDefaultSystem (system: 9 | let 10 | pkgs = import inputs.nixpkgs { inherit system; }; 11 | in 12 | import ./nix { inherit pkgs; } 13 | ); 14 | } 15 | -------------------------------------------------------------------------------- /loc/changelog.md: -------------------------------------------------------------------------------- 1 | ### 0.2.0.0 (2023-06-26) 2 | 3 | Remove `Pos` type; using `Positive` from the `integer-types` package instead 4 | 5 | Remove `ToNat` class 6 | 7 | Removed all `Data` instances. (Because I don't care; if you need this, ask 8 | for it to be restored.) 9 | 10 | `Line` and `Column` now have `Integral` instances 11 | 12 | ### 0.1.4.1 (2023-01-10) 13 | 14 | Support GHC 9.4 15 | 16 | ### 0.1.4.0 (2022-06-27) 17 | 18 | Drop support for GHC 8.4, 8.6, and 8.8 19 | 20 | Renamed test suite to `test-loc-properties` 21 | 22 | Added module `Data.Loc.SpanOrLoc` 23 | 24 | Added to module `Data.Loc` the type `SpanOrLoc` and the functions 25 | `spanOrLocFromTo`, `spanOrLocStart`, and `spanOrLocEnd` 26 | 27 | ### 0.1.3.16 (2022-01-24) 28 | 29 | Fix test suite failure on case-insensitive file systems 30 | 31 | ### 0.1.3.14 (2022-01-13) 32 | 33 | Drop support for GHC 8.0 and 8.2 34 | 35 | ### 0.1.3.12 (2022-01-13) 36 | 37 | Support GHC 9.0 and 9.2 38 | 39 | Tighten dependency version bounds 40 | 41 | ### 0.1.3.10 (2020-11-04) 42 | 43 | Added `Data` instances for `Area`, `Loc`, `Pos`, `Line`, `Column`, and `Span` 44 | 45 | ### 0.1.3.8 - 2020 May 20 46 | 47 | Support GHC 8.10 48 | 49 | ### 0.1.3.6 - 2020 Mar 15 50 | 51 | Support GHC 8.8 52 | 53 | ### Older 54 | 55 | The change log was not maintained before this point. 56 | 57 | - 0.1.3.4 (2018-11-22) 58 | - 0.1.3.3 (2018-08-23) 59 | - 0.1.3.2 (2017-12-03) 60 | - 0.1.3.1 (2017-08-20) 61 | - 0.1.3.0 (2017-07-22) 62 | - 0.1.2.3 (2017-05-28) 63 | - 0.1.2.2 (2017-05-28) 64 | - 0.1.2.1 (2017-05-16) 65 | - 0.1.2.0 (2017-05-07) 66 | - 0.1.1.0 (2017-05-07) 67 | - 0.1.0.2 (2017-05-07) 68 | - 0.1.0.1 (2017-05-07) 69 | - 0.1.0.0 (2017-05-07) 70 | -------------------------------------------------------------------------------- /loc/example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/typeclasses/loc/2e32d89a71448c38e47114874a254782a5fcbafa/loc/example.png -------------------------------------------------------------------------------- /loc/example.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 22 | 24 | 48 | 50 | 51 | 53 | image/svg+xml 54 | 56 | 57 | 58 | 59 | 60 | 65 | 72 | Lorem ipsum dolor sit amet, consecteturadipiscing elit, sed do eiusmod temporincididunt ut labore et dolore magna aliqua. 93 | 98 | Loc 1:5 109 | Span 1:13-1:18 120 | 126 | 143 | 148 | Loc 1:1 159 | 165 | 182 | 187 | 204 | 209 | Loc 1:40 220 | 226 | 243 | 250 | 255 | 260 | 265 | 270 | 277 | 282 | 289 | 294 | 301 | 306 | 311 | Area [2:18-2:24, 2:33-3:5, 3:15-3:21] 322 | 327 | 344 | 349 | 366 | 371 | 388 | 393 | 410 | 411 | 412 | -------------------------------------------------------------------------------- /loc/license.txt: -------------------------------------------------------------------------------- 1 | Copyright 2017 Mission Valley Software LLC 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /loc/loc.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | 3 | name: loc 4 | version: 0.2.0.0 5 | synopsis: Line and column positions and ranges in text files 6 | category: Data Structures, Text 7 | 8 | description: 9 | The package name /loc/ stands for “location” and is 10 | also an allusion to the acronym for “lines of code”. 11 | 12 | The @Loc@ type represents a caret position in a text file, 13 | the @Span@ type is a nonempty range between two @Loc@s, 14 | and the @Area@ type is a set of non-touching @Span@s. 15 | 16 | homepage: https://github.com/typeclasses/loc 17 | bug-reports: https://github.com/typeclasses/loc/issues 18 | 19 | author: Chris Martin 20 | maintainer: Chris Martin, Julie Moronuki 21 | 22 | copyright: 2017 Mission Valley Software LLC 23 | license: Apache-2.0 24 | license-file: license.txt 25 | 26 | extra-source-files: *.md 27 | extra-doc-files: *.png, *.svg 28 | 29 | source-repository head 30 | type: git 31 | location: git://github.com/typeclasses/loc.git 32 | 33 | common base 34 | default-language: GHC2021 35 | default-extensions: 36 | BlockArguments 37 | DerivingStrategies 38 | LambdaCase 39 | NoImplicitPrelude 40 | ghc-options: -Wall 41 | build-depends: 42 | , base ^>= 4.16 || ^>= 4.17 || ^>= 4.18 43 | , containers ^>= 0.6.4 44 | , integer-types ^>= 0.1.2 45 | 46 | library 47 | import: base 48 | hs-source-dirs: src 49 | exposed-modules: 50 | Data.Loc 51 | Data.Loc.Area 52 | Data.Loc.Exception 53 | Data.Loc.Internal.Map 54 | Data.Loc.Internal.Prelude 55 | Data.Loc.List.OneToTwo 56 | Data.Loc.List.ZeroToTwo 57 | Data.Loc.Loc 58 | Data.Loc.Pos 59 | Data.Loc.Span 60 | Data.Loc.SpanOrLoc 61 | Data.Loc.Types 62 | 63 | test-suite test-loc-properties 64 | import: base 65 | type: exitcode-stdio-1.0 66 | hs-source-dirs: test 67 | ghc-options: -threaded 68 | default-extensions: TemplateHaskell 69 | main-is: Main.hs 70 | other-modules: Gen 71 | build-depends: 72 | , hspec ^>= 2.8.5 || ^>= 2.9 || ^>= 2.10 || ^>= 2.11 73 | , hspec-hedgehog ^>= 0.0.1 74 | , hedgehog ^>= 1.0.5 || ^>= 1.1 || ^>= 1.2 75 | , loc 76 | -------------------------------------------------------------------------------- /loc/readme.md: -------------------------------------------------------------------------------- 1 | The package name *loc* stands for “location” and is 2 | also an allusion to the acronym for “lines of code”. 3 | 4 | Overview of the concepts: 5 | 6 | ![Example text illustrating Loc, Span, and Area](https://raw.githubusercontent.com/chris-martin/haskell-libraries/4be81df645d4a2e5073f45563930e202e41209c7/loc/example.png) 7 | 8 | * `Loc` - a cursor position, starting at the origin `1:1` 9 | * `Span` - a nonempty contiguous region between two locs 10 | * `Area` - a set of zero or more spans with gaps between them 11 | 12 | See also: 13 | 14 | * [loc-test](https://hackage.haskell.org/package/loc-test) - 15 | Test-related utilities for this package. 16 | 17 | ## `Pos` 18 | 19 | Since all of the numbers we're dealing with in this domain are positive, we 20 | define a "positive integer" type. This is a newtype for `Natural` that doesn't 21 | allow zero. 22 | 23 | ```haskell 24 | newtype Pos = Pos Natural 25 | deriving (Eq, Ord) 26 | 27 | instance Num Pos where 28 | fromInteger = Pos . checkForUnderflow . fromInteger 29 | Pos x + Pos y = Pos (x + y) 30 | Pos x - Pos y = Pos (checkForUnderflow (x - y)) 31 | Pos x * Pos y = Pos (x * y) 32 | abs = id 33 | signum _ = Pos 1 34 | negate _ = throw Underflow 35 | 36 | checkForUnderflow :: Natural -> Natural 37 | checkForUnderflow n = 38 | if n == 0 then throw Underflow else n 39 | ``` 40 | 41 | `Pos` does not have an `Integral` instance, because that would require 42 | implementing `quotRem :: Pos -> Pos -> (Pos, Pos)`, which doesn't make much 43 | sense. Therefore we can't use `toInteger` on `Pos`. Instead we use our own 44 | `ToNat` class to convert positive numbers to natural numbers. 45 | 46 | ```haskell 47 | class ToNat a where 48 | toNat :: a -> Natural 49 | 50 | instance ToNat Pos where 51 | toNat (Pos n) = n 52 | ``` 53 | 54 | ## `Line`, `Column` 55 | 56 | We then add some newtypes to be more specific about whether we're talking about 57 | line or column numbers. 58 | 59 | ```haskell 60 | newtype Line = Line Pos 61 | deriving (Eq, Ord, Num, Real, Enum, ToNat) 62 | 63 | newtype Column = Column Pos 64 | deriving (Eq, Ord, Num, Real, Enum, ToNat) 65 | ``` 66 | 67 | ## `Loc` 68 | 69 | A `Loc` is a `Line` and a `Column`. 70 | 71 | ```haskell 72 | data Loc = Loc 73 | { line :: Line 74 | , column :: Column 75 | } 76 | deriving (Eq, Ord) 77 | ``` 78 | 79 | Note that this library has chosen to be remain entirely agnostic of the text 80 | that the positions are referring to. Therefore there is no "plus one" operation 81 | on `Loc`, because the next `Loc` after *4:17* could be either *4:18* or *5:1* - 82 | we can't tell without knowing the line lengths. 83 | 84 | ## `Span` 85 | 86 | A `Span` is a start `Loc` and an end `Loc`. 87 | 88 | ```haskell 89 | data Span = Span 90 | { start :: Loc 91 | , end :: Loc 92 | } deriving (Eq, Ord) 93 | ``` 94 | 95 | A `Span` is not allowed to be empty; in other words, `start` and `end` must be 96 | different. 97 | 98 | There are two functions for constructing a `Span`. They both reorder their 99 | arguments as appropriate to make sure the start comes before the end (so that 100 | spans are never backwards). They take different approaches to ensuring that 101 | spans are never empty: the first can throw an exception, whereas the second is 102 | typed as `Maybe`. 103 | 104 | ```haskell 105 | fromTo :: Loc -> Loc -> Span 106 | fromTo a b = 107 | maybe (throw EmptySpan) id (fromToMay a b) 108 | 109 | fromToMay :: Loc -> Loc -> Maybe Span 110 | fromToMay a b = 111 | case compare a b of 112 | LT -> Just (Span a b) 113 | GT -> Just (Span b a) 114 | EQ -> Nothing 115 | ``` 116 | 117 | The choice to use an exclusive upper bound *\[start, end)* rather than two 118 | inclusive bounds *\[start, end\]* is forced by the decision to be text-agnostic. 119 | With inclusive ranges, you couldn't tell whether span *4:16-4:17* abuts span 120 | *5:1-5:2* without knowing whether the character at position *4:17* is a newline. 121 | 122 | ## `Area` 123 | 124 | Conceptually, an area is a set of spans. To support efficient union and 125 | difference operations, `Area` is defined like this: 126 | 127 | ```haskell 128 | data Terminus = Start | End 129 | deriving (Eq, Ord) 130 | 131 | newtype Area = Area (Map Loc Terminus) 132 | deriving (Eq, Ord) 133 | ``` 134 | 135 | You can think of this as a sorted list of the spans' start and end positions, 136 | along with a tag indicating whether each is a start or an end. 137 | 138 | ## `Show` 139 | 140 | We define custom `Show` and `Read` instances to be able to write terse tests like: 141 | 142 | ```haskell 143 | >>> addSpan (read "1:1-6:1") (read "[1:1-3:1,6:1-6:2,7:4-7:5]") 144 | [1:1-6:2,7:4-7:5] 145 | ``` 146 | 147 | These are the `showsPrec` implementations for `Loc` and `Span`: 148 | 149 | ```haskell 150 | locShowsPrec :: Int -> Loc -> ShowS 151 | locShowsPrec _ (Loc l c) = 152 | shows l . 153 | showString ":" . 154 | shows c 155 | 156 | spanShowsPrec :: Int -> Span -> ShowS 157 | spanShowsPrec _ (Span a b) = 158 | locShowsPrec 10 a . 159 | showString "-" . 160 | locShowsPrec 10 b 161 | ``` 162 | 163 | ## `Read` 164 | 165 | The parser for `Pos` is based on the parser for `Natural`, applying `mfilter (/= 166 | 0)` to make the parser fail if the input represents a zero. 167 | 168 | ```haskell 169 | posReadPrec :: ReadPrec Pos 170 | posReadPrec = 171 | Pos <$> mfilter (/= 0) readPrec 172 | ``` 173 | 174 | As a reminder, the type of `mfilter` is: 175 | 176 | ```haskell 177 | mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a 178 | ``` 179 | 180 | The `Loc` parser uses a very typical `Applicative` pattern: 181 | 182 | ```haskell 183 | -- | Parses a single specific character. 184 | readPrecChar :: Char -> ReadPrec () 185 | readPrecChar = void . readP_to_Prec . const . ReadP.char 186 | 187 | locReadPrec :: ReadPrec Loc 188 | locReadPrec = 189 | Loc <$> 190 | readPrec <* 191 | readPrecChar ':' <*> 192 | readPrec 193 | ``` 194 | 195 | We used `mfilter` above to introduce failure into the `Pos` parser; for `Span` 196 | we use `empty`. 197 | 198 | ```haskell 199 | empty :: Alternative f => f a 200 | ``` 201 | 202 | First we use `fromToMay` to produce a `Maybe Span`, and then in the case where 203 | the result is `Nothing` we use `empty` to make the parser fail. 204 | 205 | ```haskell 206 | spanReadPrec :: ReadPrec Span 207 | spanReadPrec = 208 | locReadPrec >>= \a -> 209 | readPrecChar '-' *> 210 | locReadPrec >>= \b -> 211 | maybe empty pure (fromToMay a b) 212 | ``` 213 | 214 | ## Comparison to similar packages 215 | 216 | ### `srcloc` 217 | 218 | [srcloc](https://hackage.haskell.org/package/srcloc) has a similar general 219 | purpose: defining types related to positions in text files. 220 | 221 | Some differences: 222 | 223 | * `srcloc`'s `Pos` type (comparable to our `Loc` type) has a `FilePath` 224 | parameter, whereas this library doesn't consider file paths at all. 225 | * `srcloc` has nothing comparable to the `Area` type. 226 | 227 | There are some undocumented aspects of `srcloc` we find confusing: 228 | 229 | * What does "character offset" mean? 230 | * Does `srcloc`'s `Loc` type use inclusive or exclusive bounds? 231 | -------------------------------------------------------------------------------- /loc/src/Data/Loc.hs: -------------------------------------------------------------------------------- 1 | module Data.Loc 2 | ( -- * Concepts 3 | -- $concepts 4 | 5 | -- * Imports 6 | -- $imports 7 | 8 | -- * Core types 9 | Line, 10 | Column, 11 | Loc, 12 | Span, 13 | SpanOrLoc, 14 | Area, 15 | 16 | -- * Constructing 17 | 18 | -- ** Loc 19 | loc, 20 | origin, 21 | 22 | -- ** Span 23 | spanFromTo, 24 | spanFromToMay, 25 | 26 | -- ** SpanOrLoc 27 | spanOrLocFromTo, 28 | 29 | -- ** Area 30 | areaFromTo, 31 | spanArea, 32 | 33 | -- * Deconstructing 34 | 35 | -- ** Loc 36 | locLine, 37 | locColumn, 38 | 39 | -- ** Span 40 | spanStart, 41 | spanEnd, 42 | 43 | -- ** SpanOrLoc 44 | spanOrLocStart, 45 | spanOrLocEnd, 46 | 47 | -- ** Area 48 | areaStart, 49 | areaEnd, 50 | areaSpansAsc, 51 | 52 | -- * Combining 53 | 54 | -- ** Span 55 | spanUnion, 56 | spanDifference, 57 | 58 | -- ** Area 59 | areaUnion, 60 | areaDifference, 61 | 62 | -- * Miscellaneous 63 | Positive, 64 | OneToTwo, 65 | ZeroToTwo, 66 | LocException (..), 67 | ) 68 | where 69 | 70 | import Data.Loc.Area (Area) 71 | import Data.Loc.Area qualified as Area 72 | import Data.Loc.Exception (LocException (..)) 73 | import Data.Loc.Internal.Prelude 74 | import Data.Loc.List.OneToTwo (OneToTwo) 75 | import Data.Loc.List.ZeroToTwo (ZeroToTwo) 76 | import Data.Loc.Loc (Loc) 77 | import Data.Loc.Loc qualified as Loc 78 | import Data.Loc.Pos (Column, Line) 79 | import Data.Loc.Span (Span) 80 | import Data.Loc.Span qualified as Span 81 | import Data.Loc.SpanOrLoc (SpanOrLoc) 82 | import Data.Loc.SpanOrLoc qualified as SpanOrLoc 83 | import Integer.Positive (Positive) 84 | 85 | -- | The smallest location: @'loc' 1 1@ 86 | -- 87 | -- /This is an alias for 'Loc.origin'./ 88 | origin :: Loc 89 | origin = Loc.origin 90 | 91 | -- | Create a 'Loc' from a line number and column number 92 | -- 93 | -- /This is an alias for 'Loc.loc'./ 94 | loc :: Line -> Column -> Loc 95 | loc = Loc.loc 96 | 97 | -- | /This is an alias for 'Loc.line'./ 98 | locLine :: Loc -> Line 99 | locLine = Loc.line 100 | 101 | -- | /This is an alias for 'Loc.column'./ 102 | locColumn :: Loc -> Column 103 | locColumn = Loc.column 104 | 105 | -- | Attempt to construct a 'Span' from two 'Loc's 106 | -- 107 | -- The lesser loc will be the start, and the greater loc will be the end. 108 | -- The two locs must not be equal, or else this throws 'EmptySpan'. 109 | -- 110 | -- /The safe version of this function is 'spanFromToMay'./ 111 | -- 112 | -- /This is an alias for 'Span.fromTo'./ 113 | spanFromTo :: Loc -> Loc -> Span 114 | spanFromTo = Span.fromTo 115 | 116 | -- | Attempt to construct a 'Span' from two 'Loc's 117 | -- 118 | -- The lesser loc will be the start, and the greater loc will be the end. 119 | -- If the two locs are equal, the result is 'Nothing', because a span cannot be empty. 120 | -- 121 | -- /This is the safe version of 'spanFromTo', which throws an exception instead./ 122 | -- 123 | -- /This is an alias for 'Span.fromToMay'./ 124 | spanFromToMay :: Loc -> Loc -> Maybe Span 125 | spanFromToMay = Span.fromToMay 126 | 127 | -- | Construct a 'SpanOrLoc' from two 'Loc's 128 | -- 129 | -- If the two locs are not equal, the lesser loc will be the start, 130 | -- and the greater loc will be the end. 131 | -- 132 | -- /This is an alias for 'SpanOrLoc.fromTo'./ 133 | spanOrLocFromTo :: Loc -> Loc -> SpanOrLoc 134 | spanOrLocFromTo = SpanOrLoc.fromTo 135 | 136 | -- | /This is an alias for 'SpanOrLoc.start'./ 137 | spanOrLocStart :: SpanOrLoc -> Loc 138 | spanOrLocStart = SpanOrLoc.start 139 | 140 | -- | /This is an alias for 'SpanOrLoc.end'./ 141 | spanOrLocEnd :: SpanOrLoc -> Loc 142 | spanOrLocEnd = SpanOrLoc.end 143 | 144 | -- | Construct a contiguous 'Area' consisting of a single 'Span' specified by two 'Loc's 145 | -- 146 | -- The lesser loc will be the start, and the greater loc will be the end. 147 | -- If the two locs are equal, the area will be empty. 148 | -- 149 | -- /This is an alias for 'Area.fromTo'./ 150 | areaFromTo :: Loc -> Loc -> Area 151 | areaFromTo = Area.fromTo 152 | 153 | -- | The union of two 'Area's 154 | -- 155 | -- Spans that overlap or abut will be merged in the result. 156 | -- 157 | -- /This is an alias for 'Area.+'./ 158 | areaUnion :: Area -> Area -> Area 159 | areaUnion = (Area.+) 160 | 161 | -- | The difference between two 'Area's 162 | -- 163 | -- @a `'areaDifference'` b@ contains what is covered by @a@ and not covered by @b@. 164 | -- 165 | -- /This is an alias for 'Area.-'./ 166 | areaDifference :: Area -> Area -> Area 167 | areaDifference = (Area.-) 168 | 169 | -- | A list of the 'Span's that constitute an 'Area', sorted in ascending order 170 | -- 171 | -- /This is an alias for 'Area.spansAsc'./ 172 | areaSpansAsc :: Area -> [Span] 173 | areaSpansAsc = Area.spansAsc 174 | 175 | -- | Construct an 'Area' consisting of a single 'Span' 176 | -- 177 | -- /This is an alias for 'Area.spanArea'./ 178 | spanArea :: Span -> Area 179 | spanArea = Area.spanArea 180 | 181 | -- | Combine two 'Span's, merging them if they abut or overlap 182 | -- 183 | -- /This is an alias for 'Span.+'./ 184 | spanUnion :: Span -> Span -> OneToTwo Span 185 | spanUnion = (Span.+) 186 | 187 | -- | The difference between two 'Spans's 188 | -- 189 | -- @a '-' b@ contains what is covered by @a@ and not covered by @b@. 190 | -- 191 | -- /This is an alias for 'Span.-'./ 192 | spanDifference :: Span -> Span -> ZeroToTwo Span 193 | spanDifference = (Span.-) 194 | 195 | -- | 196 | -- /This is an alias for 'Span.start'./ 197 | spanStart :: Span -> Loc 198 | spanStart = Span.start 199 | 200 | -- | 201 | -- /This is an alias for 'Span.end'./ 202 | spanEnd :: Span -> Loc 203 | spanEnd = Span.end 204 | 205 | -- | 206 | -- /This is an alias for 'Area.start'./ 207 | areaStart :: Area -> Maybe Loc 208 | areaStart = Area.start 209 | 210 | -- | 211 | -- /This is an alias for 'Area.end'./ 212 | areaEnd :: Area -> Maybe Loc 213 | areaEnd = Area.end 214 | 215 | -- $concepts 216 | -- 217 | -- 'Line' and 'Column' are positive integers representing line and column numbers. 218 | -- 219 | -- The product of 'Line' and 'Column' is a 'Loc', which represents a position 220 | -- between characters in multiline text. The smallest loc is 'origin': line 1, 221 | -- column 1. 222 | -- 223 | -- Here's a small piece of text for illustration: 224 | -- 225 | -- > 1 2 226 | -- > 12345678901234567890123456789 227 | -- > ┌───────────────────────────────┐ 228 | -- > 1 │ I have my reasons, you │ 229 | -- > 2 │ have yours. What's obvious │ 230 | -- > 3 │ to me isn't to everyone else, │ 231 | -- > 4 │ and vice versa. │ 232 | -- > └───────────────────────────────┘ 233 | -- 234 | -- In this example, the word “obvious” starts at line 2, column 20, and it ends at 235 | -- line 2, column 27. The 'Show' instance uses a shorthand notation denoting 236 | -- these locs as @2:20@ and @2:27@. 237 | -- 238 | -- A 'Span' is a nonempty contiguous region of text between two locs; think of it 239 | -- like a highlighted area in a simple text editor. In the above example, a span 240 | -- that covers the word “obvious” starts at @2:20@ and ends at @2:27@. The 'Show' 241 | -- instance describes this tersely as @2:20-2:27@. 242 | -- 243 | -- Multiple non-overlapping regions form an 'Area'. You may also think of an 244 | -- area like a span that can be empty or have “gaps”. In the example above, the 245 | -- first three words “I have my”, and not the spaces between them, are covered by 246 | -- the area @[1:1-1:2,1:3-1:7,1:8-1:10]@. 247 | 248 | -- $imports 249 | -- 250 | -- Recommended import: 251 | -- 252 | -- > import Data.Loc.Types 253 | -- > import qualified Data.Loc as Loc 254 | -------------------------------------------------------------------------------- /loc/src/Data/Loc/Area.hs: -------------------------------------------------------------------------------- 1 | module Data.Loc.Area 2 | ( Area, 3 | 4 | -- * Constructing 5 | fromTo, 6 | spanArea, 7 | 8 | -- * Combining 9 | (+), 10 | (-), 11 | addSpan, 12 | 13 | -- * Querying 14 | firstSpan, 15 | lastSpan, 16 | start, 17 | end, 18 | areaSpan, 19 | spansAsc, 20 | spanCount, 21 | 22 | -- * Show and Read 23 | areaShowsPrec, 24 | areaReadPrec, 25 | ) 26 | where 27 | 28 | import Data.Foldable qualified as Foldable 29 | import Data.Loc.Internal.Map qualified as Map 30 | import Data.Loc.Internal.Prelude 31 | import Data.Loc.Loc (Loc) 32 | import Data.Loc.Span (Span) 33 | import Data.Loc.Span qualified as Span 34 | import Data.Set qualified as Set 35 | 36 | data Terminus = Start | End 37 | deriving (Eq, Ord) 38 | 39 | -- | A set of non-overlapping, non-abutting 'Span's 40 | -- 41 | -- You may also think of an 'Area' like a span that can be empty or have “gaps.” 42 | -- 43 | -- Construct and combine areas using 'mempty', 'spanArea', 'fromTo', '+', and '-'. 44 | newtype Area = Area (Map Loc Terminus) 45 | deriving (Eq, Ord) 46 | 47 | -- | 'showsPrec' = 'areaShowsPrec' 48 | instance Show Area where 49 | showsPrec = areaShowsPrec 50 | 51 | -- | 'readPrec' = 'areaReadPrec' 52 | instance Read Area where 53 | readPrec = areaReadPrec 54 | 55 | instance Monoid Area where 56 | mempty = Area Map.empty 57 | 58 | -- | '<>' = '+' 59 | instance Semigroup Area where 60 | (<>) = (+) 61 | 62 | areaShowsPrec :: Int -> Area -> ShowS 63 | areaShowsPrec _ a = 64 | showList (spansAsc a) 65 | 66 | -- | 67 | -- 68 | -- >>> readPrec_to_S areaReadPrec minPrec "[]" 69 | -- [([],"")] 70 | -- 71 | -- >>> readPrec_to_S areaReadPrec minPrec "[3:2-5:5,8:3-11:4]" 72 | -- [([3:2-5:5,8:3-11:4],"")] 73 | -- 74 | -- >>> readPrec_to_S areaReadPrec minPrec "[3:2-5:5,11:4-8:3]" 75 | -- [([3:2-5:5,8:3-11:4],"")] 76 | -- 77 | -- >>> readPrec_to_S areaReadPrec minPrec "[3:2-5:5,8:3-8:3]" 78 | -- [] 79 | areaReadPrec :: ReadPrec Area 80 | areaReadPrec = 81 | foldMap spanArea <$> readListPrec 82 | 83 | -- | Construct a contiguous 'Area' consisting of a single 'Span' specified 84 | -- by two 'Loc's 85 | -- 86 | -- The lesser loc will be the start, and the greater loc will be the end. 87 | -- If the two locs are equal, the area will be empty. 88 | fromTo :: 89 | -- | Start 90 | Loc -> 91 | -- | End 92 | Loc -> 93 | Area 94 | fromTo a b 95 | | a == b = mempty 96 | | otherwise = spanArea (Span.fromTo a b) 97 | 98 | -- | Construct an 'Area' consisting of a single 'Span' 99 | -- 100 | -- >>> spanArea (read "4:5-6:3") 101 | -- [4:5-6:3] 102 | spanArea :: Span -> Area 103 | spanArea s = Area (Map.fromList locs) 104 | where 105 | locs = 106 | [ (Span.start s, Start), 107 | (Span.end s, End) 108 | ] 109 | 110 | -- | A 'Span' from 'start' to 'end', or 'Nothing' if the 'Area' is empty 111 | -- 112 | -- >>> areaSpan mempty 113 | -- Nothing 114 | -- 115 | -- >>> areaSpan (read "[3:4-7:2]") 116 | -- Just 3:4-7:2 117 | -- 118 | -- >>> areaSpan (read "[3:4-7:2,15:6-17:9]") 119 | -- Just 3:4-17:9 120 | areaSpan :: Area -> Maybe Span 121 | areaSpan x = 122 | start x >>= \a -> 123 | end x <&> \b -> 124 | Span.fromTo a b 125 | 126 | -- | A list of the 'Span's that constitute an 'Area', sorted in ascending order 127 | -- 128 | -- >>> spansAsc mempty 129 | -- [] 130 | -- 131 | -- >>> spansAsc (read "[3:4-7:2,15:6-17:9]") 132 | -- [3:4-7:2,15:6-17:9] 133 | spansAsc :: Area -> [Span] 134 | spansAsc (Area m) = 135 | mapAccumL f Nothing (Map.keys m) & snd & catMaybes 136 | where 137 | f Nothing l = (Just l, Nothing) 138 | f (Just l) l' = (Nothing, Just $ Span.fromTo l l') 139 | 140 | -- | 141 | -- 142 | -- >>> spanCount mempty 143 | -- 0 144 | -- 145 | -- >>> spanCount (read "[3:4-7:2]") 146 | -- 1 147 | -- 148 | -- >>> spanCount (read "[3:4-7:2,15:6-17:9]") 149 | -- 2 150 | spanCount :: Area -> Natural 151 | spanCount (Area locs) = 152 | fromIntegral (Foldable.length locs `div` 2) 153 | 154 | -- | The first contiguous 'Span' in the 'Area', or 'Nothing' if the area is empty 155 | -- 156 | -- >>> firstSpan mempty 157 | -- Nothing 158 | -- 159 | -- >>> firstSpan (read "[3:4-7:2]") 160 | -- Just 3:4-7:2 161 | -- 162 | -- >>> firstSpan (read "[3:4-7:2,15:6-17:9]") 163 | -- Just 3:4-7:2 164 | firstSpan :: Area -> Maybe Span 165 | firstSpan (Area m) = 166 | case Set.toAscList (Map.keysSet m) of 167 | a : b : _ -> Just (Span.fromTo a b) 168 | _ -> Nothing 169 | 170 | -- | The last contiguous 'Span' in the 'Area', or 'Nothing' if the area is empty 171 | -- 172 | -- >>> lastSpan mempty 173 | -- Nothing 174 | -- 175 | -- >>> lastSpan (read "[3:4-7:2]") 176 | -- Just 3:4-7:2 177 | -- 178 | -- >>> lastSpan (read "[3:4-7:2,15:6-17:9]") 179 | -- Just 15:6-17:9 180 | lastSpan :: Area -> Maybe Span 181 | lastSpan (Area m) = 182 | case Set.toDescList (Map.keysSet m) of 183 | b : a : _ -> Just (Span.fromTo a b) 184 | _ -> Nothing 185 | 186 | -- | The 'Loc' at which the 'Area' starts, or 'Nothing' if the 'Area' is empty 187 | -- 188 | -- >>> start mempty 189 | -- Nothing 190 | -- 191 | -- >>> start (read "[3:4-7:2]") 192 | -- Just 3:4 193 | -- 194 | -- >>> start (read "[3:4-7:2,15:6-17:9]") 195 | -- Just 3:4 196 | start :: Area -> Maybe Loc 197 | start (Area m) = 198 | case Map.minViewWithKey m of 199 | Just ((l, _), _) -> Just l 200 | Nothing -> Nothing 201 | 202 | -- | The 'Loc' at which the 'Area' ends, or 'Nothing' if the 'Area' is empty 203 | -- 204 | -- >>> end mempty 205 | -- Nothing 206 | -- 207 | -- >>> end (read "[3:4-7:2]") 208 | -- Just 7:2 209 | -- 210 | -- >>> end (read "[3:4-7:2,15:6-17:9]") 211 | -- Just 17:9 212 | end :: Area -> Maybe Loc 213 | end (Area locs) = 214 | case Map.maxViewWithKey locs of 215 | Just ((l, _), _) -> Just l 216 | Nothing -> Nothing 217 | 218 | -- | The union of two 'Area's 219 | -- 220 | -- Spans that overlap or abut will be merged in the result. 221 | -- 222 | -- >>> read "[1:1-1:2]" + mempty 223 | -- [1:1-1:2] 224 | -- 225 | -- >>> read "[1:1-1:2]" + read "[1:2-1:3]" 226 | -- [1:1-1:3] 227 | -- 228 | -- >>> read "[1:1-1:2]" + read "[1:1-3:1]" 229 | -- [1:1-3:1] 230 | -- 231 | -- >>> read "[1:1-1:2]" + read "[1:1-11:1]" 232 | -- [1:1-11:1] 233 | -- 234 | -- >>> read "[1:1-3:1,6:1-6:2]" + read "[1:1-6:1]" 235 | -- [1:1-6:2] 236 | -- 237 | -- >>> read "[1:1-3:1]" + read "[5:1-6:2]" 238 | -- [1:1-3:1,5:1-6:2] 239 | (+) :: Area -> Area -> Area 240 | a + b 241 | | spanCount a >= spanCount b = foldr addSpan a (spansAsc b) 242 | | otherwise = b + a 243 | 244 | -- | @'addSpan' s a@ is the union of @'Area' a@ and @'Span' s@ 245 | -- 246 | -- >>> addSpan (read "1:1-6:1") (read "[1:1-3:1,6:1-6:2]") 247 | -- [1:1-6:2] 248 | addSpan :: Span -> Area -> Area 249 | addSpan b (Area as) = 250 | let -- Spans lower than b that do not abut or overlap b. 251 | -- These spans will remain completely intact in the result. 252 | unmodifiedSpansBelow :: Map Loc Terminus 253 | 254 | -- Spans greater than b that do not abut or overlap b. 255 | -- These spans will remain completely intact in the result. 256 | unmodifiedSpansAbove :: Map Loc Terminus 257 | 258 | -- The start location of a span that starts below b but doesn't end below b, 259 | -- if such a span exists. This span will be merged into the 'middle'. 260 | startBelow :: Maybe Loc 261 | 262 | -- The end location of a span that ends above b but doesn't start above b, 263 | -- if such a span exists. This span will be merged into the 'middle'. 264 | endAbove :: Maybe Loc 265 | 266 | -- b, plus any spans it abuts or overlaps. 267 | middle :: Map Loc Terminus 268 | 269 | (unmodifiedSpansBelow, startBelow) = 270 | let below = Map.below (Span.start b) as 271 | in case Map.maxViewWithKey below of 272 | Just ((l, Start), xs) -> (xs, Just l) 273 | _ -> (below, Nothing) 274 | 275 | (unmodifiedSpansAbove, endAbove) = 276 | let above = Map.above (Span.end b) as 277 | in case Map.minViewWithKey above of 278 | Just ((l, End), xs) -> (xs, Just l) 279 | _ -> (above, Nothing) 280 | 281 | middle = 282 | Map.fromList 283 | [ (minimum $ Foldable.toList startBelow <> [Span.start b], Start), 284 | (maximum $ Foldable.toList endAbove <> [Span.end b], End) 285 | ] 286 | in Area $ unmodifiedSpansBelow <> middle <> unmodifiedSpansAbove 287 | 288 | -- | The difference between two 'Area's 289 | -- 290 | -- @a '-' b@ contains what is covered by @a@ and not covered by @b@. 291 | (-) :: Area -> Area -> Area 292 | a - b = foldr subtractSpan a (spansAsc b) 293 | 294 | -- | @'subtractSpan' s a@ is the subset of 'Area' @a@ that is not 295 | -- covered by 'Span' @s@ 296 | subtractSpan :: Span -> Area -> Area 297 | subtractSpan b (Area as) = 298 | let resultBelow :: Map Loc Terminus = 299 | let below = Map.belowInclusive (Span.start b) as 300 | in case Map.maxViewWithKey below of 301 | Just ((l, Start), xs) -> 302 | if l == Span.start b 303 | then xs 304 | else below & Map.insert (Span.start b) End 305 | _ -> below 306 | 307 | resultAbove :: Map Loc Terminus = 308 | let above = Map.aboveInclusive (Span.end b) as 309 | in case Map.minViewWithKey above of 310 | Just ((l, End), xs) -> 311 | if l == Span.end b 312 | then xs 313 | else above & Map.insert (Span.end b) Start 314 | _ -> above 315 | in Area $ resultBelow <> resultAbove 316 | -------------------------------------------------------------------------------- /loc/src/Data/Loc/Exception.hs: -------------------------------------------------------------------------------- 1 | module Data.Loc.Exception 2 | ( LocException (..), 3 | ) 4 | where 5 | 6 | import Data.Loc.Internal.Prelude 7 | 8 | data LocException 9 | = EmptySpan 10 | deriving (Eq, Ord) 11 | 12 | instance Exception LocException 13 | 14 | instance Show LocException where 15 | showsPrec _ EmptySpan = showString "empty Span" 16 | -------------------------------------------------------------------------------- /loc/src/Data/Loc/Internal/Map.hs: -------------------------------------------------------------------------------- 1 | module Data.Loc.Internal.Map 2 | ( module Data.Map, 3 | below, 4 | above, 5 | belowInclusive, 6 | aboveInclusive, 7 | ) 8 | where 9 | 10 | import Data.Loc.Internal.Prelude 11 | import Data.Map 12 | 13 | -- | @'below' k m@ is the subset of 'Map' @m@ whose keys are less than @k@ 14 | below :: Ord k => k -> Map k a -> Map k a 15 | below k m = 16 | let (x, _) = split k m 17 | in x 18 | 19 | -- | @'below' k m@ is the subset of 'Map' @m@ whose keys are greater than @k@ 20 | above :: Ord k => k -> Map k a -> Map k a 21 | above k m = 22 | let (_, x) = split k m 23 | in x 24 | 25 | -- | @'belowInclusive' k m@ is the subset of 'Map' @m@ whose keys are less 26 | -- than or equal to @k@ 27 | belowInclusive :: Ord k => k -> Map k a -> Map k a 28 | belowInclusive k m = 29 | let (x, at, _) = splitLookup k m 30 | in case at of 31 | Nothing -> x 32 | Just v -> insert k v x 33 | 34 | -- | @'aboveInclusive' k m@ is the subset of 'Map' @m@ whose keys are 35 | -- greater than or equal to @k@ 36 | aboveInclusive :: Ord k => k -> Map k a -> Map k a 37 | aboveInclusive k m = 38 | let (_, at, x) = splitLookup k m 39 | in case at of 40 | Nothing -> x 41 | Just v -> insert k v x 42 | -------------------------------------------------------------------------------- /loc/src/Data/Loc/Internal/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Data.Loc.Internal.Prelude 2 | ( module X, 3 | (<&>), 4 | readPrecChar, 5 | ) 6 | where 7 | 8 | import Control.Applicative as X (empty, pure, (*>), (<*), (<*>)) 9 | import Control.Arrow as X ((<<<), (>>>)) 10 | import Control.Exception as X (ArithException (..), Exception, throw) 11 | import Control.Monad as X (Monad (..), guard, mfilter, when) 12 | import Data.Bifunctor as X (Bifunctor (..)) 13 | import Data.Bool as X (Bool (..), not, otherwise, (&&), (||)) 14 | import Data.Char (Char) 15 | import Data.Eq as X (Eq (..)) 16 | import Data.Foldable as X (Foldable (..), foldMap, traverse_) 17 | import Data.Function as X (const, flip, id, on, ($), (&), (.)) 18 | import Data.Functor as X (Functor (..), void, ($>), (<$), (<$>)) 19 | import Data.List.NonEmpty as X (NonEmpty (..)) 20 | import Data.Map as X (Map) 21 | import Data.Maybe as X (Maybe (..), catMaybes, fromMaybe, maybe) 22 | import Data.Monoid as X (Monoid (..)) 23 | import Data.Ord as X (Ord (..), Ordering (..), max, min) 24 | import Data.Semigroup as X (Semigroup (..)) 25 | import Data.Set as X (Set) 26 | import Data.Traversable as X (mapAccumL, sequenceA, traverse) 27 | import Data.Tuple as X (fst, snd) 28 | import Numeric.Natural as X (Natural) 29 | import System.Exit as X (exitFailure) 30 | import System.IO as X (IO) 31 | import Text.ParserCombinators.ReadP qualified as ReadP 32 | import Text.ParserCombinators.ReadPrec as X 33 | ( minPrec, 34 | readP_to_Prec, 35 | readPrec_to_S, 36 | ) 37 | import Text.Read as X (Read (..), ReadPrec, read) 38 | import Text.Show as X (Show (..), ShowS, showString, shows) 39 | import Prelude as X 40 | ( Double, 41 | Enum (..), 42 | Int, 43 | Integral, 44 | Real (..), 45 | String, 46 | div, 47 | fromIntegral, 48 | print, 49 | quotRem, 50 | round, 51 | sqrt, 52 | toInteger, 53 | undefined, 54 | (/), 55 | ) 56 | 57 | -- | '<&>' = flip 'fmap' 58 | (<&>) :: Functor f => f a -> (a -> b) -> f b 59 | (<&>) = flip fmap 60 | 61 | -- | A precedence parser that reads a single specific character 62 | readPrecChar :: Char -> ReadPrec () 63 | readPrecChar = void . readP_to_Prec . const . ReadP.char 64 | -------------------------------------------------------------------------------- /loc/src/Data/Loc/List/OneToTwo.hs: -------------------------------------------------------------------------------- 1 | module Data.Loc.List.OneToTwo 2 | ( -- * Imports 3 | -- $imports 4 | 5 | -- * Type 6 | OneToTwo (..), 7 | 8 | -- * Tuple conversion 9 | toTuple, 10 | toTuple', 11 | ) 12 | where 13 | 14 | import Data.Loc.Internal.Prelude 15 | 16 | -- | List of length 1 or 2 17 | data OneToTwo a 18 | = -- | List of length 1 19 | One a 20 | | -- | List of length 2 21 | Two a a 22 | deriving (Eq, Ord, Show, Read, Foldable, Functor) 23 | 24 | -- | 25 | -- 26 | -- >>> toTuple (One 1) 27 | -- (1,Nothing) 28 | -- 29 | -- >>> toTuple (Two 1 2) 30 | -- (1,Just 2) 31 | toTuple :: OneToTwo a -> (a, Maybe a) 32 | toTuple = 33 | \case 34 | One a -> (a, Nothing) 35 | Two a b -> (a, Just b) 36 | 37 | -- | 38 | -- 39 | -- >>> toTuple' (One 1) 40 | -- (Nothing,1) 41 | -- 42 | -- >>> toTuple' (Two 1 2) 43 | -- (Just 1,2) 44 | toTuple' :: OneToTwo a -> (Maybe a, a) 45 | toTuple' = 46 | \case 47 | One a -> (Nothing, a) 48 | Two a b -> (Just a, b) 49 | 50 | -- $imports 51 | -- 52 | -- Recommended import: 53 | -- 54 | -- > import Data.Loc.List.OneToTwo (OneToTwo) 55 | -- > import qualified Data.Loc.List.OneToTwo as OneToTwo 56 | -------------------------------------------------------------------------------- /loc/src/Data/Loc/List/ZeroToTwo.hs: -------------------------------------------------------------------------------- 1 | module Data.Loc.List.ZeroToTwo 2 | ( -- Imports 3 | -- $imports 4 | 5 | -- * Type 6 | ZeroToTwo (..), 7 | ) 8 | where 9 | 10 | import Data.Loc.Internal.Prelude 11 | 12 | -- | List of length 0, 1, or 2 13 | data ZeroToTwo a 14 | = -- | List of length 0 15 | Zero 16 | | -- | List of length 1 17 | One a 18 | | -- | List of length 2 19 | Two a a 20 | deriving (Eq, Ord, Show, Read, Foldable, Functor) 21 | 22 | -- $imports 23 | -- 24 | -- Recommended import: 25 | -- 26 | -- > import Data.Loc.List.ZeroToTwo (ZeroToTwo) 27 | -- > import qualified Data.Loc.List.ZeroToTwo as ZeroToTwo 28 | -------------------------------------------------------------------------------- /loc/src/Data/Loc/Loc.hs: -------------------------------------------------------------------------------- 1 | module Data.Loc.Loc 2 | ( Loc, 3 | 4 | -- * Constructing 5 | loc, 6 | origin, 7 | 8 | -- * Querying 9 | line, 10 | column, 11 | 12 | -- * Show and Read 13 | locShowsPrec, 14 | locReadPrec, 15 | ) 16 | where 17 | 18 | import Data.Loc.Internal.Prelude 19 | import Data.Loc.Pos (Column, Line) 20 | import Integer.Positive (Positive) 21 | 22 | -- | Stands for /location/, consists of a 'Line' and a 'Column' 23 | -- 24 | -- You can think of a 'Loc' like a caret position in a text editor. 25 | -- Following the normal convention for text editors and such, line 26 | -- and column numbers start with 1. 27 | data Loc = Loc 28 | { line :: Line, 29 | column :: Column 30 | } 31 | deriving (Eq, Ord) 32 | 33 | -- | 'showsPrec' = 'locShowsPrec' 34 | instance Show Loc where 35 | showsPrec = locShowsPrec 36 | 37 | -- | 'readPrec' = 'locReadPrec' 38 | instance Read Loc where 39 | readPrec = locReadPrec 40 | 41 | -- | 42 | -- 43 | -- >>> locShowsPrec minPrec (loc 3 14) "" 44 | -- "3:14" 45 | locShowsPrec :: Int -> Loc -> ShowS 46 | locShowsPrec _ (Loc l c) = 47 | shows l 48 | . showString ":" 49 | . shows c 50 | 51 | -- | 52 | -- 53 | -- >>> readPrec_to_S locReadPrec minPrec "3:14" 54 | -- [(3:14,"")] 55 | locReadPrec :: ReadPrec Loc 56 | locReadPrec = 57 | Loc 58 | <$> (fromIntegral <$> readPrec @Positive) 59 | <* readPrecChar ':' 60 | <*> (fromIntegral <$> readPrec @Positive) 61 | 62 | -- | Create a 'Loc' from a line number and column number. 63 | loc :: Line -> Column -> Loc 64 | loc = Loc 65 | 66 | -- | The smallest location: @'loc' 1 1@ 67 | -- 68 | -- >>> origin 69 | -- 1:1 70 | origin :: Loc 71 | origin = loc 1 1 72 | -------------------------------------------------------------------------------- /loc/src/Data/Loc/Pos.hs: -------------------------------------------------------------------------------- 1 | module Data.Loc.Pos 2 | ( Line, 3 | Column, 4 | ) 5 | where 6 | 7 | import Data.Loc.Internal.Prelude 8 | import Integer (Positive) 9 | import Prelude (Num (..)) 10 | 11 | -------------------------------------------------------------------------------- 12 | -- Line 13 | -------------------------------------------------------------------------------- 14 | 15 | newtype Line = Line Positive 16 | deriving newtype (Eq, Ord, Num, Integral, Real, Enum, Show) 17 | 18 | -------------------------------------------------------------------------------- 19 | -- Column 20 | -------------------------------------------------------------------------------- 21 | 22 | newtype Column = Column Positive 23 | deriving newtype (Eq, Ord, Num, Integral, Real, Enum, Show) 24 | -------------------------------------------------------------------------------- /loc/src/Data/Loc/Span.hs: -------------------------------------------------------------------------------- 1 | module Data.Loc.Span 2 | ( Span, 3 | 4 | -- * Constructing 5 | fromTo, 6 | fromToMay, 7 | 8 | -- * Querying 9 | start, 10 | end, 11 | 12 | -- * Calculations 13 | lines, 14 | overlapping, 15 | linesOverlapping, 16 | touching, 17 | join, 18 | joinAsc, 19 | (+), 20 | (-), 21 | 22 | -- * Show and Read 23 | spanShowsPrec, 24 | spanReadPrec, 25 | ) 26 | where 27 | 28 | import Data.Foldable qualified as Foldable 29 | import Data.List.NonEmpty qualified as NonEmpty 30 | import Data.Loc.Exception (LocException (..)) 31 | import Data.Loc.Internal.Prelude 32 | import Data.Loc.List.OneToTwo (OneToTwo) 33 | import Data.Loc.List.OneToTwo qualified as OneToTwo 34 | import Data.Loc.List.ZeroToTwo (ZeroToTwo) 35 | import Data.Loc.List.ZeroToTwo qualified as ZeroToTwo 36 | import Data.Loc.Loc (Loc, locReadPrec, locShowsPrec) 37 | import Data.Loc.Loc qualified as Loc 38 | import Data.Loc.Pos (Line) 39 | 40 | -- | A 'Span' consists of a start location ('start') and an end location ('end') 41 | -- 42 | -- The end location must be greater than the start location; in other words, empty 43 | -- or backwards spans are not permitted. 44 | -- 45 | -- Construct and combine spans using 'fromTo', 'fromToMay', '+', and '-'. 46 | data Span = Span 47 | { start :: Loc, 48 | end :: Loc 49 | } 50 | deriving (Eq, Ord) 51 | 52 | -- | 'showsPrec' = 'spanShowsPrec' 53 | instance Show Span where 54 | showsPrec = spanShowsPrec 55 | 56 | -- | 'readPrec' = 'spanReadPrec' 57 | instance Read Span where 58 | readPrec = spanReadPrec 59 | 60 | -- | 61 | -- 62 | -- >>> spanShowsPrec minPrec (fromTo (read "3:14") (read "6:5")) "" 63 | -- "3:14-6:5" 64 | spanShowsPrec :: Int -> Span -> ShowS 65 | spanShowsPrec _ (Span a b) = 66 | locShowsPrec 10 a 67 | . showString "-" 68 | . locShowsPrec 10 b 69 | 70 | -- | 71 | -- 72 | -- >>> readPrec_to_S spanReadPrec minPrec "3:14-6:5" 73 | -- [(3:14-6:5,"")] 74 | -- 75 | -- >>> readPrec_to_S spanReadPrec minPrec "6:5-3:14" 76 | -- [(3:14-6:5,"")] 77 | -- 78 | -- >>> readPrec_to_S spanReadPrec minPrec "6:5-6:5" 79 | -- [] 80 | spanReadPrec :: ReadPrec Span 81 | spanReadPrec = 82 | locReadPrec >>= \a -> 83 | readPrecChar '-' 84 | *> locReadPrec 85 | >>= \b -> 86 | maybe empty pure (fromToMay a b) 87 | 88 | -- | Attempt to construct a 'Span' from two 'Loc's 89 | -- 90 | -- The lesser loc will be the start, and the greater loc will be the end. 91 | -- The two locs must not be equal, or else this throws 'EmptySpan'. 92 | -- 93 | -- /The safe version of this function is 'fromToMay'./ 94 | fromTo :: Loc -> Loc -> Span 95 | fromTo a b = 96 | fromMaybe (throw EmptySpan) (fromToMay a b) 97 | 98 | -- | Attempt to construct a 'Span' from two 'Loc's 99 | -- 100 | -- The lesser loc will be the start, and the greater loc will be the end. 101 | -- If the two locs are equal, the result is 'Nothing', because a span cannot 102 | -- be empty. 103 | -- 104 | -- /This is the safe version of 'fromTo', which throws an exception instead./ 105 | fromToMay :: Loc -> Loc -> Maybe Span 106 | fromToMay a b = 107 | case compare a b of 108 | LT -> Just (Span a b) 109 | GT -> Just (Span b a) 110 | EQ -> Nothing 111 | 112 | -- | All of the lines that a span touches 113 | -- 114 | -- >>> NonEmpty.toList (lines (read "2:6-2:10")) 115 | -- [2] 116 | -- 117 | -- >>> NonEmpty.toList (lines (read "2:6-8:4")) 118 | -- [2,3,4,5,6,7,8] 119 | lines :: Span -> NonEmpty Line 120 | lines s = 121 | NonEmpty.fromList [Loc.line (start s) .. Loc.line (end s)] 122 | 123 | -- | Spans that are directly abutting do not count as overlapping 124 | -- 125 | -- >>> overlapping (read "1:5-1:8") (read "1:8-1:12") 126 | -- False 127 | -- 128 | -- But these spans overlap by a single character: 129 | -- 130 | -- >>> overlapping (read "1:5-1:9") (read "1:8-1:12") 131 | -- True 132 | -- 133 | -- Spans are overlapping if one is contained entirely within another. 134 | -- 135 | -- >>> overlapping (read "1:5-1:15") (read "1:6-1:10") 136 | -- True 137 | -- 138 | -- Spans are overlapping if they are identical. 139 | -- 140 | -- >>> overlapping (read "1:5-1:15") (read "1:5-1:15") 141 | -- True 142 | overlapping :: Span -> Span -> Bool 143 | overlapping a b = 144 | not (end a <= start b || end b <= start a) 145 | 146 | -- | Determines whether the two spans touch any of the same lines 147 | -- 148 | -- >>> linesOverlapping (read "1:1-1:2") (read "1:1-1:2") 149 | -- True 150 | -- 151 | -- >>> linesOverlapping (read "1:1-1:2") (read "1:1-2:1") 152 | -- True 153 | -- 154 | -- >>> linesOverlapping (read "1:1-1:2") (read "2:1-2:2") 155 | -- False 156 | linesOverlapping :: Span -> Span -> Bool 157 | linesOverlapping a b = 158 | not $ 159 | (Loc.line . end) a < (Loc.line . start) b 160 | || (Loc.line . end) b < (Loc.line . start) a 161 | 162 | -- | Two spans are considered to "touch" if they are overlapping 163 | -- or abutting; in other words, if there is no space between them 164 | -- 165 | -- >>> touching (read "1:1-1:2") (read "1:2-1:3") 166 | -- True 167 | -- 168 | -- >>> touching (read "1:1-1:2") (read "1:1-1:3") 169 | -- True 170 | -- 171 | -- >>> touching (read "1:1-1:2") (read "1:3-1:4") 172 | -- False 173 | touching :: Span -> Span -> Bool 174 | touching a b = 175 | not (end a < start b || end b < start a) 176 | 177 | -- | 178 | -- 179 | -- >>> join (read "1:1-1:2") (read "1:2-1:3") 180 | -- 1:1-1:3 181 | -- 182 | -- >>> join (read "1:1-1:2") (read "1:1-1:3") 183 | -- 1:1-1:3 184 | join :: Span -> Span -> Span 185 | join a b = 186 | Span 187 | (min (start a) (start b)) 188 | (max (end a) (end b)) 189 | 190 | -- | Combine two 'Span's, merging them if they abut or overlap 191 | -- 192 | -- >>> read "1:1-1:2" + read "1:2-1:3" 193 | -- One 1:1-1:3 194 | -- 195 | -- >>> read "1:1-1:2" + read "1:1-3:1" 196 | -- One 1:1-3:1 197 | -- 198 | -- >>> read "1:1-1:2" + read "1:1-11:1" 199 | -- One 1:1-11:1 200 | -- 201 | -- If the spans are not overlapping or abutting, they are returned unmodified 202 | -- in the same order in which they were given as parameters. 203 | -- 204 | -- >>> read "1:1-1:2" + read "2:1-2:5" 205 | -- Two 1:1-1:2 2:1-2:5 206 | -- 207 | -- >>> read "2:1-2:5" + read "1:1-1:2" 208 | -- Two 2:1-2:5 1:1-1:2 209 | (+) :: Span -> Span -> OneToTwo Span 210 | a + b 211 | | touching a b = OneToTwo.One (join a b) 212 | | otherwise = OneToTwo.Two a b 213 | 214 | -- | The difference between two 'Spans's 215 | -- 216 | -- @a '-' b@ contains what is covered by @a@ and not covered by @b@. 217 | -- 218 | -- >>> read "2:5-4:1" - read "2:9-3:5" 219 | -- Two 2:5-2:9 3:5-4:1 220 | -- 221 | -- >>> read "2:5-4:1" - read "2:5-3:5" 222 | -- One 3:5-4:1 223 | -- 224 | -- >>> read "2:5-4:1" - read "2:2-3:5" 225 | -- One 3:5-4:1 226 | -- 227 | -- Subtracting a thing from itself yields nothing. 228 | -- 229 | -- >>> let x = read "2:5-4:1" in x - x 230 | -- Zero 231 | -- 232 | -- >>> read "2:5-4:1" - read "2:2-4:4" 233 | -- Zero 234 | -- 235 | -- >>> read "1:1-8:1" - read "1:2-8:1" 236 | -- One 1:1-1:2 237 | (-) :: Span -> Span -> ZeroToTwo Span 238 | a - b 239 | -- [ a ] [ b ] 240 | | not (overlapping a b) = 241 | ZeroToTwo.One a 242 | -- [ a ] 243 | -- [ b ] 244 | | start b > start a && end b < end a = 245 | ZeroToTwo.Two 246 | (Span (start a) (start b)) 247 | (Span (end b) (end a)) 248 | -- [ a ] 249 | -- [ b ] 250 | | start b <= start a && end b < end a = 251 | ZeroToTwo.One (Span (end b) (end a)) 252 | -- [ a ] 253 | -- [ b ] 254 | | start b > start a && end b >= end a = 255 | ZeroToTwo.One (Span (start a) (start b)) 256 | | otherwise = 257 | ZeroToTwo.Zero 258 | 259 | -- | Given an ascending list of 'Span's, combine those which abut or overlap 260 | joinAsc :: 261 | -- | A list of 'Spans' sorted in ascending order. 262 | -- 263 | -- /This precondition is not checked./ 264 | [Span] -> 265 | [Span] 266 | joinAsc = 267 | \case 268 | x : y : zs -> 269 | let (r, s) = OneToTwo.toTuple' (x + y) 270 | in Foldable.toList r <> joinAsc (s : zs) 271 | xs -> xs 272 | -------------------------------------------------------------------------------- /loc/src/Data/Loc/SpanOrLoc.hs: -------------------------------------------------------------------------------- 1 | module Data.Loc.SpanOrLoc 2 | ( SpanOrLoc, 3 | 4 | -- * Constructing 5 | span, 6 | loc, 7 | fromTo, 8 | 9 | -- * Deconstructing 10 | spanOrLoc, 11 | 12 | -- * Querying 13 | start, 14 | end, 15 | ) 16 | where 17 | 18 | import Data.Loc.Internal.Prelude 19 | import Data.Loc.Loc (Loc) 20 | import Data.Loc.Loc qualified as Loc 21 | import Data.Loc.Span (Span) 22 | import Data.Loc.Span qualified as Span 23 | 24 | -- | A 'SpanOrLoc' consists of a start location and an end location 25 | -- 26 | -- The end location must be greater than or equal to the start location; 27 | -- in other words, backwards spans are not permitted. 28 | -- 29 | -- If the start and end location are the same, then the value is a 'Loc'. 30 | -- If they differ, then the value is a 'Span'. 31 | data SpanOrLoc = Span Span | Loc Loc 32 | deriving (Eq, Ord) 33 | 34 | instance Show SpanOrLoc where 35 | showsPrec i = \case 36 | Span x -> Span.spanShowsPrec i x 37 | Loc x -> Loc.locShowsPrec i x 38 | 39 | span :: Span -> SpanOrLoc 40 | span = Span 41 | 42 | loc :: Loc -> SpanOrLoc 43 | loc = Loc 44 | 45 | spanOrLoc :: (Span -> a) -> (Loc -> a) -> SpanOrLoc -> a 46 | spanOrLoc f _ (Span x) = f x 47 | spanOrLoc _ f (Loc x) = f x 48 | 49 | -- | Construct a 'SpanOrLoc' from two 'Loc's 50 | -- 51 | -- If the two locs are not equal, the lesser loc will be the start, 52 | -- and the greater loc will be the end. 53 | fromTo :: Loc -> Loc -> SpanOrLoc 54 | fromTo a b = 55 | maybe (Loc a) Span (Span.fromToMay a b) 56 | 57 | start :: SpanOrLoc -> Loc 58 | start = spanOrLoc Span.start id 59 | 60 | end :: SpanOrLoc -> Loc 61 | end = spanOrLoc Span.end id 62 | -------------------------------------------------------------------------------- /loc/src/Data/Loc/Types.hs: -------------------------------------------------------------------------------- 1 | -- | For convenience, this module exports only the important types from 'Data.Loc' 2 | module Data.Loc.Types 3 | ( Line, 4 | Column, 5 | Loc, 6 | Span, 7 | SpanOrLoc, 8 | Area, 9 | ) 10 | where 11 | 12 | import Data.Loc 13 | -------------------------------------------------------------------------------- /loc/test/Gen.hs: -------------------------------------------------------------------------------- 1 | module Gen where 2 | 3 | import Data.List qualified as List 4 | import Data.Loc qualified as Loc 5 | import Data.Loc.Internal.Prelude 6 | import Data.Loc.Types 7 | import Data.Set qualified as Set 8 | import Hedgehog (Gen) 9 | import Hedgehog.Gen qualified as Gen 10 | import Hedgehog.Range qualified as Range 11 | import Prelude (Num (..)) 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Parameter defaults 15 | -------------------------------------------------------------------------------- 16 | 17 | -- | The default maximum line: 99. 18 | defMaxLine :: Line 19 | defMaxLine = 99 20 | 21 | -- | The default maximum column number: 99. 22 | defMaxColumn :: Column 23 | defMaxColumn = 99 24 | 25 | -------------------------------------------------------------------------------- 26 | -- Bounds 27 | -------------------------------------------------------------------------------- 28 | 29 | -- | Inclusive lower and upper bounds on a range. 30 | type Bounds a = (a, a) 31 | 32 | -- | The size of a range specified by 'Bounds' 33 | -- 34 | -- Assumes the upper bound is at least the lower bound. 35 | boundsSize :: Num n => (n, n) -> n 36 | boundsSize (a, b) = 1 + b - a 37 | 38 | -------------------------------------------------------------------------------- 39 | -- Pos 40 | -------------------------------------------------------------------------------- 41 | 42 | -- | @'line' a b@ generates a line number on the linear range /a/ to /b/ 43 | line :: 44 | -- | Minimum and maximum line number 45 | Bounds Line -> 46 | Gen Line 47 | line (a, b) = Gen.integral (Range.linear a b) 48 | 49 | -- | Generates a line number within the default bounds @(1, 'defMaxLine')@ 50 | line' :: Gen Line 51 | line' = line (1, defMaxLine) 52 | 53 | -- | @'column' a b@ generates a column number on the linear range /a/ to /b/ 54 | column :: 55 | -- | Minimum and maximum column number 56 | Bounds Column -> 57 | Gen Column 58 | column (a, b) = Gen.integral (Range.linear a b) 59 | 60 | -- | Generates a column number within the default bounds @(1, 'defMaxColumn')@ 61 | column' :: Gen Column 62 | column' = column (1, defMaxColumn) 63 | 64 | -------------------------------------------------------------------------------- 65 | -- Loc 66 | -------------------------------------------------------------------------------- 67 | 68 | -- | @'loc' lineBounds columnBounds@ generates a 'Loc' with the line number 69 | -- bounded by @lineBounds@ and column number bounded by @columnBounds@ 70 | loc :: 71 | -- | Minimum and maximum line number 72 | Bounds Line -> 73 | -- | Minimum and maximum column number 74 | Bounds Column -> 75 | Gen Loc 76 | loc lineBounds columnBounds = 77 | Loc.loc <$> line lineBounds <*> column columnBounds 78 | 79 | -- | Generates a 'Loc' within the default line and column bounds 80 | loc' :: Gen Loc 81 | loc' = loc (1, defMaxLine) (1, defMaxColumn) 82 | 83 | -------------------------------------------------------------------------------- 84 | -- Span 85 | -------------------------------------------------------------------------------- 86 | 87 | -- | @'span' lineBounds columnBounds@ generates a 'Span' with start and end 88 | -- positions whose line numbers are bounded by @lineBounds@ and whose column 89 | -- numbers are bounded by @columnBounds@ 90 | span :: 91 | -- | Minimum and maximum line number 92 | Bounds Line -> 93 | -- | Minimum and maximum column number 94 | Bounds Column -> 95 | Gen Span 96 | span lineBounds columnBounds@(minColumn, maxColumn) = 97 | let lines :: Gen (Line, Line) 98 | lines = 99 | line lineBounds >>= \a -> 100 | line lineBounds <&> \b -> 101 | (min a b, max a b) 102 | 103 | columnsDifferentLine :: Gen (Column, Column) 104 | columnsDifferentLine = 105 | column columnBounds >>= \a -> 106 | column columnBounds <&> \b -> 107 | (a, b) 108 | 109 | columnsSameLine :: Gen (Column, Column) 110 | columnsSameLine = 111 | column (minColumn + 1, maxColumn) >>= \a -> 112 | column columnBounds <&> \b -> 113 | case compare a b of 114 | EQ -> (a - 1, b) 115 | LT -> (a, b) 116 | GT -> (b, a) 117 | in lines >>= \(startLine, endLine) -> 118 | ( if startLine /= endLine 119 | then columnsDifferentLine 120 | else columnsSameLine 121 | ) 122 | <&> \(startColumn, endColumn) -> 123 | let start = Loc.loc startLine startColumn 124 | end = Loc.loc endLine endColumn 125 | in Loc.spanFromTo start end 126 | 127 | -- | Generates a 'Span' with start and end positions within the default line and 128 | -- column bounds 129 | span' :: Gen Span 130 | span' = span (1, defMaxLine) (1, defMaxColumn) 131 | 132 | -------------------------------------------------------------------------------- 133 | -- Area 134 | -------------------------------------------------------------------------------- 135 | 136 | -- | @'area' lineBounds columnBounds@ generates an 'Area' consisting of 'Span's 137 | -- with start and end positions whose line numbers are bounded by @lineBounds@ 138 | -- and whose column numbers are bounded by @columnBounds@ 139 | area :: 140 | -- | Minimum and maximum line number 141 | Bounds Line -> 142 | -- | Minimum and maximum column number 143 | Bounds Column -> 144 | Gen Area 145 | area lineBounds columnBounds = 146 | fold . snd . mapAccumL f Nothing . Set.toAscList . Set.fromList <$> locs 147 | where 148 | gridSize :: Int = 149 | max 150 | (fromIntegral (boundsSize lineBounds)) 151 | (fromIntegral (boundsSize columnBounds)) 152 | 153 | locs :: Gen [Loc] = 154 | loc lineBounds columnBounds 155 | & List.repeat 156 | & List.take (gridSize `div` 5) 157 | & sequenceA 158 | 159 | f :: Maybe Loc -> Loc -> (Maybe Loc, Area) 160 | f prevLocMay newLoc = 161 | case prevLocMay of 162 | Just prevLoc -> (Nothing, Loc.areaFromTo prevLoc newLoc) 163 | Nothing -> (Just newLoc, mempty) 164 | 165 | -- | Generates an 'Area' consisting of 'Span's with start and end positions within 166 | -- the default line and column bounds 167 | area' :: Gen Area 168 | area' = area (1, defMaxLine) (1, defMaxColumn) 169 | -------------------------------------------------------------------------------- /loc/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Data.List qualified as List 4 | import Data.List.NonEmpty qualified as NonEmpty 5 | import Data.Loc 6 | import Data.Loc.Area qualified as Area 7 | import Data.Loc.Internal.Prelude 8 | import Data.Loc.List.OneToTwo qualified as OneToTwo 9 | import Data.Loc.List.ZeroToTwo qualified as ZeroToTwo 10 | import Data.Loc.Loc qualified as Loc 11 | import Data.Loc.Span qualified as Span 12 | import Gen qualified 13 | import Hedgehog 14 | import Hedgehog.Gen qualified as Gen 15 | import Hedgehog.Range qualified as Range 16 | import Test.Hspec 17 | import Test.Hspec.Hedgehog 18 | 19 | main :: IO () 20 | main = hspec do 21 | locSpec 22 | spanSpec 23 | areaSpec 24 | 25 | locSpec :: SpecWith () 26 | locSpec = describe "Loc" do 27 | specify "read and show" $ hedgehog do 28 | x <- forAll Gen.loc' 29 | read (show x) === x 30 | 31 | specify "read and show examples" $ hedgehog do 32 | show Loc.origin === "1:1" 33 | Loc.locShowsPrec minPrec (loc 3 14) "" === "3:14" 34 | readPrec_to_S Loc.locReadPrec minPrec "3:14" === [(read "3:14", "")] 35 | 36 | spanSpec :: SpecWith () 37 | spanSpec = describe "Span" do 38 | specify "joinAsc" $ hedgehog do 39 | spans <- forAll (Gen.list (Range.linear 1 10) Gen.span') 40 | areaSpansAsc (foldMap spanArea spans) === Span.joinAsc (List.sort spans) 41 | 42 | specify "read and show" $ hedgehog do 43 | x <- forAll Gen.span' 44 | read (show x) === x 45 | 46 | describe "read and show examples" do 47 | specify "show 3:14-6:5" $ Span.spanShowsPrec minPrec (Span.fromTo (read "3:14") (read "6:5")) "" == "3:14-6:5" 48 | specify "read 3:14-6:5" $ show (readPrec_to_S Span.spanReadPrec minPrec "3:14-6:5") == "[(3:14-6:5,\"\")]" 49 | specify "read 6:5-3:14" $ show (readPrec_to_S Span.spanReadPrec minPrec "6:5-3:14") == "[(3:14-6:5,\"\")]" 50 | specify "read 6:5-6:5" $ readPrec_to_S Span.spanReadPrec minPrec "6:5-6:5" == [] 51 | 52 | describe "lines" do 53 | specify "one" $ NonEmpty.toList (Span.lines (read "2:6-2:10")) == [2] 54 | specify "many" $ NonEmpty.toList (Span.lines (read "2:6-8:4")) == [2, 3, 4, 5, 6, 7, 8] 55 | 56 | describe "overlapping" do 57 | specify "if only touching, no" $ not $ Span.overlapping (read "1:5-1:8") (read "1:8-1:12") 58 | specify "on a single line" $ Span.overlapping (read "1:5-1:9") (read "1:8-1:12") 59 | specify "one contained within another" $ Span.overlapping (read "1:5-1:15") (read "1:6-1:10") 60 | specify "same span" $ hedgehog do 61 | x <- forAll Gen.span' 62 | assert (Span.overlapping x x) 63 | 64 | describe "linesOverlapping" do 65 | specify "same span" $ hedgehog do 66 | x <- forAll Gen.span' 67 | assert (Span.linesOverlapping x x) 68 | specify "multi line" $ Span.linesOverlapping (read "1:1-1:2") (read "1:1-2:1") 69 | specify "no" $ not $ Span.linesOverlapping (read "1:1-1:2") (read "2:1-2:2") 70 | 71 | describe "touching" do 72 | specify "same span" $ hedgehog do 73 | x <- forAll Gen.span' 74 | assert (Span.touching x x) 75 | specify "barely" $ Span.touching (read "1:1-1:2") (read "1:2-1:3") 76 | specify "overlapping" $ Span.touching (read "1:1-1:2") (read "1:1-1:3") 77 | specify "no" $ not $ Span.touching (read "1:1-1:2") (read "1:3-1:4") 78 | 79 | describe "join" do 80 | specify "touching" $ Span.join (read "1:1-1:2") (read "1:2-1:3") == read "1:1-1:3" 81 | specify "overlapping" $ Span.join (read "1:1-1:2") (read "1:1-1:3") == read "1:1-1:3" 82 | 83 | describe "addition" do 84 | specify "example 1" $ read "1:1-1:2" Span.+ read "1:2-1:3" == OneToTwo.One (read "1:1-1:3") 85 | specify "example 2" $ read "1:1-1:2" Span.+ read "1:1-3:1" == OneToTwo.One (read "1:1-3:1") 86 | specify "example 3" $ read "1:1-1:2" Span.+ read "1:1-11:1" == OneToTwo.One (read "1:1-11:1") 87 | specify "example 4" $ read "1:1-1:2" Span.+ read "2:1-2:5" == OneToTwo.Two (read "1:1-1:2") (read "2:1-2:5") 88 | specify "example 5" $ read "2:1-2:5" Span.+ read "1:1-1:2" == OneToTwo.Two (read "2:1-2:5") (read "1:1-1:2") 89 | 90 | describe "subtraction" do 91 | specify "x - x" $ hedgehog do 92 | x <- forAll Gen.span' 93 | x Span.- x === ZeroToTwo.Zero 94 | specify "example 1" $ read "2:5-4:1" Span.- read "2:9-3:5" == ZeroToTwo.Two (read "2:5-2:9") (read "3:5-4:1") 95 | specify "example 2" $ read "2:5-4:1" Span.- read "2:5-3:5" == ZeroToTwo.One (read "3:5-4:1") 96 | specify "example 3" $ read "2:5-4:1" Span.- read "2:2-3:5" == ZeroToTwo.One (read "3:5-4:1") 97 | specify "example 4" $ read "2:5-4:1" Span.- read "2:2-4:4" == ZeroToTwo.Zero 98 | specify "example 5" $ read "1:1-8:1" Span.- read "1:2-8:1" == ZeroToTwo.One (read "1:1-1:2") 99 | 100 | areaSpec :: SpecWith () 101 | areaSpec = describe "Area" do 102 | specify "add mempty = id for a single span" $ hedgehog do 103 | a <- forAll Gen.span' 104 | spanArea a Area.+ mempty === spanArea a 105 | 106 | specify "subtract mempty = id for a single span" $ hedgehog do 107 | a <- forAll Gen.span' 108 | spanArea a Area.- mempty === spanArea a 109 | 110 | specify "addition is commutative" $ hedgehog do 111 | a <- forAll Gen.area' 112 | b <- forAll Gen.area' 113 | a Area.+ b === b Area.+ a 114 | 115 | specify "add mempty = id" $ hedgehog do 116 | a <- forAll Gen.area' 117 | a Area.+ mempty === a 118 | 119 | specify "subtract mempty = id" $ hedgehog do 120 | a <- forAll Gen.area' 121 | a Area.- mempty === a 122 | 123 | specify "addition and subtraction" $ hedgehog do 124 | a <- forAll Gen.area' 125 | b <- forAll Gen.area' 126 | c <- forAll Gen.area' 127 | a Area.- b Area.- c === a Area.- (b Area.+ c) 128 | 129 | specify "addSpan" $ hedgehog do 130 | a <- forAll Gen.area' 131 | s <- forAll Gen.span' 132 | Area.addSpan s a === areaUnion (spanArea s) a 133 | 134 | specify "fromTo mempty 1" $ hedgehog do 135 | x <- forAll Gen.loc' 136 | y <- forAll Gen.loc' 137 | (Area.fromTo x y == mempty) === (x == y) 138 | 139 | specify "fromTo mempty 2" $ hedgehog do 140 | x <- forAll Gen.loc' 141 | Area.fromTo x x === mempty 142 | 143 | specify "read and show" $ hedgehog do 144 | x <- forAll Gen.area' 145 | read (show x) === x 146 | 147 | specify "read and show example 1" $ hedgehog do 148 | let x = show (readPrec_to_S Area.areaReadPrec minPrec "[]") 149 | x === "[([],\"\")]" 150 | 151 | specify "read and show example 2" $ hedgehog do 152 | x <- forAll (Gen.element ["[3:2-5:5,8:3-11:4]", "[3:2-5:5,11:4-8:3]"]) 153 | let y = show (readPrec_to_S Area.areaReadPrec minPrec x) 154 | y === "[([3:2-5:5,8:3-11:4],\"\")]" 155 | 156 | specify "read and show example 3" $ hedgehog do 157 | let x = show (readPrec_to_S Area.areaReadPrec minPrec "[3:2-5:5,8:3-8:3]") 158 | x === "[]" 159 | 160 | specify "constructed from a single span" $ hedgehog do 161 | let x = read "4:5-6:3" 162 | spanArea x === read "[4:5-6:3]" 163 | 164 | specify "converted to a span, maybe" $ hedgehog do 165 | Area.areaSpan mempty === Nothing 166 | Area.areaSpan (read "[3:4-7:2]") === Just (read "3:4-7:2") 167 | Area.areaSpan (read "[3:4-7:2,15:6-17:9]") === Just (read "3:4-17:9") 168 | 169 | specify "converted to a list of spans" $ hedgehog do 170 | Area.spansAsc mempty === [] 171 | Area.spansAsc (read "[3:4-7:2,15:6-17:9]") === [read "3:4-7:2", read "15:6-17:9"] 172 | 173 | specify "spanCount" $ hedgehog do 174 | Area.spanCount mempty === 0 175 | Area.spanCount (read "[3:4-7:2]") === 1 176 | Area.spanCount (read "[3:4-7:2,15:6-17:9]") === 2 177 | 178 | specify "firstSpan" $ hedgehog do 179 | Area.firstSpan mempty === Nothing 180 | Area.firstSpan (read "[3:4-7:2]") === Just (read "3:4-7:2") 181 | Area.firstSpan (read "[3:4-7:2,15:6-17:9]") === Just (read "3:4-7:2") 182 | 183 | specify "lastSpan" $ hedgehog do 184 | Area.lastSpan mempty === Nothing 185 | Area.lastSpan (read "[3:4-7:2]") === Just (read "3:4-7:2") 186 | Area.lastSpan (read "[3:4-7:2,15:6-17:9]") === Just (read "15:6-17:9") 187 | 188 | specify "start" $ hedgehog do 189 | Area.start mempty === Nothing 190 | Area.start (read "[3:4-7:2]") === Just (read "3:4") 191 | Area.start (read "[3:4-7:2,15:6-17:9]") === Just (read "3:4") 192 | 193 | specify "end" $ hedgehog do 194 | Area.end mempty === Nothing 195 | Area.end (read "[3:4-7:2]") === Just (read "7:2") 196 | Area.end (read "[3:4-7:2,15:6-17:9]") === Just (read "17:9") 197 | 198 | specify "addition examples" $ hedgehog do 199 | read "[1:1-1:2]" Area.+ mempty === read "[1:1-1:2]" 200 | read "[1:1-1:2]" Area.+ read "[1:2-1:3]" === read "[1:1-1:3]" 201 | read "[1:1-1:2]" Area.+ read "[1:1-3:1]" === read "[1:1-3:1]" 202 | read "[1:1-1:2]" Area.+ read "[1:1-11:1]" === read "[1:1-11:1]" 203 | read "[1:1-3:1,6:1-6:2]" Area.+ read "[1:1-6:1]" === read "[1:1-6:2]" 204 | read "[1:1-3:1]" Area.+ read "[5:1-6:2]" === read "[1:1-3:1,5:1-6:2]" 205 | 206 | specify "addSpan examples" $ hedgehog do 207 | Area.addSpan (read "1:1-6:1") (read "[1:1-3:1,6:1-6:2]") === read "[1:1-6:2]" 208 | -------------------------------------------------------------------------------- /nix/default.nix: -------------------------------------------------------------------------------- 1 | { pkgs }: 2 | 3 | let 4 | inherit (pkgs.lib) fold composeExtensions concatMap attrValues; 5 | 6 | hls = pkgs.haskell-language-server.override { 7 | supportedGhcVersions = [ "96" ]; 8 | }; 9 | 10 | combineOverrides = old: 11 | fold composeExtensions (old.overrides or (_: _: { })); 12 | 13 | testConfigurations = 14 | let 15 | makeTestConfiguration = { ghcVersion, overrides ? new: old: { } }: 16 | let 17 | inherit (pkgs.haskell.lib) dontCheck packageSourceOverrides; 18 | in 19 | (pkgs.haskell.packages.${ghcVersion}.override (old: { 20 | overrides = 21 | combineOverrides old [ 22 | (packageSourceOverrides { loc = ../loc; }) 23 | overrides 24 | ]; 25 | })).loc; 26 | in 27 | rec { 28 | ghc-9-2 = makeTestConfiguration { 29 | ghcVersion = "ghc92"; 30 | overrides = new: old: { 31 | integer-types = new.callPackage ./haskell/integer-types.nix { }; 32 | }; 33 | }; 34 | ghc-9-4 = makeTestConfiguration { 35 | ghcVersion = "ghc94"; 36 | overrides = new: old: { 37 | integer-types = new.callPackage ./haskell/integer-types.nix { }; 38 | }; 39 | }; 40 | ghc-9-6 = makeTestConfiguration { 41 | ghcVersion = "ghc96"; 42 | overrides = new: old: { 43 | integer-types = new.callPackage ./haskell/integer-types.nix { }; 44 | }; 45 | }; 46 | all = pkgs.symlinkJoin { 47 | name = "loc-tests"; 48 | paths = [ ghc-9-2 ghc-9-4 ghc-9-6 ]; 49 | }; 50 | }; 51 | 52 | in 53 | { 54 | 55 | packages = { inherit testConfigurations; }; 56 | 57 | devShells.default = pkgs.mkShell { 58 | inputsFrom = [ testConfigurations.ghc-9-6.env ]; 59 | buildInputs = [ hls pkgs.cabal-install ]; 60 | }; 61 | 62 | } 63 | -------------------------------------------------------------------------------- /nix/haskell/integer-types.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, deepseq, exceptions, hashable, hedgehog 2 | , hspec, hspec-hedgehog, lib, quaalude 3 | }: 4 | mkDerivation { 5 | pname = "integer-types"; 6 | version = "0.1.2.0"; 7 | sha256 = "37ea06340c904aaf297b0d2224bf6b9d45bdf9742fa7e6c51835f809195251aa"; 8 | libraryHaskellDepends = [ base deepseq hashable quaalude ]; 9 | testHaskellDepends = [ 10 | base deepseq exceptions hashable hedgehog hspec hspec-hedgehog 11 | quaalude 12 | ]; 13 | homepage = "https://github.com/typeclasses/integer-types"; 14 | description = "Integer, Natural, and Positive"; 15 | license = lib.licenses.asl20; 16 | } 17 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | To build and test with all supported compiler versions: 2 | 3 | nix build .#testConfigurations.all --no-link 4 | --------------------------------------------------------------------------------