packages feed

loc (empty) → 0.1.0.0

raw patch · 16 files changed

+1890/−0 lines, 16 filesdep +basedep +containersdep +doctest

Dependencies added: base, containers, doctest, hedgehog, loc, loc-test

Files

+ license.txt view
@@ -0,0 +1,13 @@+Copyright 2017 Chris Martin++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++    http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ loc.cabal view
@@ -0,0 +1,75 @@+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack++name:           loc+version:        0.1.0.0+synopsis:       Types representing line and column positions and ranges in text files.++description:    The package name /loc/ stands for "location" and is also an allusion to the acronym for "lines of code".+                The @Loc@ type represents a caret position in a text file, 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+homepage:       https://github.com/chris-martin/haskell-libraries+author:         Chris Martin <ch.martin@gmail.com>+maintainer:     Chris Martin <ch.martin@gmail.com>+license:        Apache-2.0+license-file:   license.txt+build-type:     Simple+cabal-version:  >= 1.10++library+  hs-source-dirs:+      src+  default-extensions: NoImplicitPrelude+  ghc-options: -Wall+  build-depends:+      base >= 4.9 && < 4.10+    , containers+  exposed-modules:+      Data.Loc+      Data.Loc.Area+      Data.Loc.Exception+      Data.Loc.Internal.Map+      Data.Loc.Internal.Prelude+      Data.Loc.List.OneToTwo+      Data.Loc.List.ZeroToTwo+      Data.Loc.Loc+      Data.Loc.Pos+      Data.Loc.Span+      Data.Loc.Types+  other-modules:+      Paths_loc+  default-language: Haskell2010++test-suite doctest+  type: exitcode-stdio-1.0+  main-is: doctest.hs+  hs-source-dirs:+      test+  default-extensions: NoImplicitPrelude+  ghc-options: -Wall -threaded+  build-depends:+      base >= 4.9 && < 4.10+    , containers+    , doctest+    , loc+  other-modules:+      Test.Loc.Hedgehog.Gen+  default-language: Haskell2010++test-suite hedgehog+  type: exitcode-stdio-1.0+  main-is: hedgehog.hs+  hs-source-dirs:+      test+  default-extensions: NoImplicitPrelude+  ghc-options: -Wall -threaded+  build-depends:+      base >= 4.9 && < 4.10+    , containers+    , hedgehog+    , loc+    , loc-test+  other-modules:+      Test.Loc.Hedgehog.Gen+  default-language: Haskell2010
+ src/Data/Loc.hs view
@@ -0,0 +1,197 @@+module Data.Loc+  (+  -- * Concepts+  -- $concepts++  -- * Imports+  -- $imports++  -- * Core types+    Line, Column, Loc, Span, Area++  -- * Constructing+  , loc, origin, spanFromTo, spanFromToMay, areaFromTo, spanArea++  -- * Deconstructing+  , areaSpansAsc+  , spanStart, spanEnd++  -- * Combining+  , areaUnion, areaDifference+  , spanUnion, spanDifference++  -- * Miscellaneous+  , Pos, OneToTwo, ZeroToTwo, ToNat (..), LocException (..)++  ) where++import Data.Loc.Internal.Prelude++import Data.Loc.Area (Area)+import Data.Loc.Exception (LocException (..))+import Data.Loc.List.OneToTwo (OneToTwo)+import Data.Loc.List.ZeroToTwo (ZeroToTwo)+import Data.Loc.Loc (Loc)+import Data.Loc.Pos (Column, Line, Pos, ToNat (..))+import Data.Loc.Span (Span)++import qualified Data.Loc.Loc as Loc+import qualified Data.Loc.Area as Area+import qualified Data.Loc.Span as Span++{- |+The smallest location: @'loc' 1 1@.++/This is an alias for 'Loc.origin'./+-}+origin :: Loc+origin = Loc.origin++{- |+Create a 'Loc' from a line number and column number.++/This is an alias for 'Loc.loc'./+-}+loc :: Line -> Column -> Loc+loc = Loc.loc++{- |+Attempt to construct a 'Span' from two 'Loc's. The lesser loc will be the+start, and the greater loc will be the end. The two locs must not be equal,+or else this throws 'EmptySpan'.++/The safe version of this function is 'spanFromToMay'./++/This is an alias for 'Span.fromTo'./+-}+spanFromTo :: Loc -> Loc -> Span+spanFromTo = Span.fromTo++{- |+Attempt to construct a 'Span' from two 'Loc's. The lesser loc will be the+start, and the greater loc will be the end. If the two locs are not equal,+the result is 'Nothing', because a span cannot be empty.++/This is the safe version of 'spanFromTo', which throws an exception instead./++/This is an alias for 'Span.fromToMay'./+-}+spanFromToMay :: Loc -> Loc -> Maybe Span+spanFromToMay = Span.fromToMay++{- |+Construct a contiguous 'Area' consisting of a single 'Span' specified by two+'Loc's. The lesser loc will be the start, and the greater loc will be the end.+If the two locs are equal, the area will be empty.++/This is an alias for 'Area.fromTo'./+-}+areaFromTo :: Loc -> Loc -> Area+areaFromTo = Area.fromTo++{- |+The union of two 'Area's. Spans that overlap or abut will be merged in the+result.++/This is an alias for 'Area.+'./+-}+areaUnion :: Area -> Area -> Area+areaUnion = (Area.+)++{- |+The difference between two 'Area's. @a `'areaDifference'` b@ contains what is+covered by @a@ and not covered by @b@.++/This is an alias for 'Area.-'./+-}+areaDifference :: Area -> Area -> Area+areaDifference = (Area.-)++{- |+A list of the 'Span's that constitute an 'Area', sorted in ascending order.++/This is an alias for 'Area.spansAsc'./+-}+areaSpansAsc :: Area -> [Span]+areaSpansAsc = Area.spansAsc++{- |+Construct an 'Area' consisting of a single 'Span'.++/This is an alias for 'Area.spanArea'./+-}+spanArea :: Span -> Area+spanArea = Area.spanArea++{- |+Combine two 'Span's, merging them if they abut or overlap.++/This is an alias for 'Span.+'./+-}+spanUnion :: Span -> Span -> OneToTwo Span+spanUnion = (Span.+)++{- |+The difference between two 'Spans's. @a '-' b@ contains what is covered by+@a@ and not covered by @b@.++/This is an alias for 'Span.-'./+-}+spanDifference :: Span -> Span -> ZeroToTwo Span+spanDifference = (Span.-)++{- |+/This is an alias for 'Span.start'./+-}+spanStart :: Span -> Loc+spanStart = Span.start++{- |+/This is an alias for 'Span.end'./+-}+spanEnd :: Span -> Loc+spanEnd = Span.end++{- $concepts++'Line' and 'Column' are positive integers representing line and column numbers.++The product of 'Line' and 'Column' is a 'Loc', which represents a position+between characters in multiline text. The smallest loc is 'origin': line 1,+column 1.++Here's a small piece of text for illustration:++>              1         2+>     12345678901234567890123456789+>   ┌───────────────────────────────┐+> 1 │ I have my reasons, you        │+> 2 │ have yours. What's obvious    │+> 3 │ to me isn't to everyone else, │+> 4 │ and vice versa.               │+>   └───────────────────────────────┘++In this example, the word "obvious" starts at line 2, column 20, and it ends at+line 2, column 27. The 'Show' instance uses a shorthand notation denoting+these locs as @2:20@ and @2:27@.++A 'Span' is a nonempty contiguous region of text between two locs; think of it+like a highlighted area in a simple text editor. In the above example, a span+that covers the word "obvious" starts at @2:20@ and ends at @2:27@. The 'Show'+instance describes this tersely as @2:20-2:27@.++Multiple non-overlapping regions form an 'Area'. You may also think of an+area like a span that can be empty or have "gaps". In the example above, the+first three words "I have my", and not the spaces between them, are covered by+the area @[1:1-1:2,1:3-1:7,1:8-1:10]@.++-}++{- $imports++Recommended import:++> import Data.Loc.Types+> import qualified Data.Loc as Loc++-}
+ src/Data/Loc/Area.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}++module Data.Loc.Area+  ( Area++  -- * Constructing+  , fromTo+  , spanArea++  -- * Combining+  , (+)+  , (-)+  , addSpan++  -- * Querying+  , firstSpan+  , lastSpan+  , start+  , end+  , areaSpan+  , spansAsc+  , spanCount++  -- * Show and Read+  , areaShowsPrec+  , areaReadPrec++  ) where++import Data.Loc.Internal.Prelude++import Data.Loc.Loc (Loc)+import Data.Loc.Span (Span)++import qualified Data.Loc.Internal.Map as Map+import qualified Data.Loc.Span as Span++import qualified Data.Foldable as Foldable+import qualified Data.Set as Set++data Terminus = Start | End+  deriving (Eq, Ord)++{- |++A set of non-overlapping, non-abutting 'Span's. You may also think of an 'Area'+like a span that can be empty or have "gaps".++Construct and combine areas using 'mempty', 'spanArea', 'fromTo', '+', and '-'.++-}+newtype Area = Area (Map Loc Terminus)+  deriving (Eq, Ord)++-- | 'showsPrec' = 'areaShowsPrec'+instance Show Area+  where++    showsPrec = areaShowsPrec++-- | 'readPrec' = 'areaReadPrec'+instance Read Area+  where++    readPrec = areaReadPrec++instance Monoid Area+  where++    mempty = Area Map.empty++    mappend = (+)++-- | '<>' = '+'+instance Semigroup Area++areaShowsPrec :: Int -> Area -> ShowS+areaShowsPrec _ a =+  showList (spansAsc a)++{- |++>>> readPrec_to_S areaReadPrec minPrec "[]"+[([],"")]++>>> readPrec_to_S areaReadPrec minPrec "[3:2-5:5,8:3-11:4]"+[([3:2-5:5,8:3-11:4],"")]++>>> readPrec_to_S areaReadPrec minPrec "[3:2-5:5,11:4-8:3]"+[([3:2-5:5,8:3-11:4],"")]++>>> readPrec_to_S areaReadPrec minPrec "[3:2-5:5,8:3-8:3]"+[]++-}+areaReadPrec :: ReadPrec Area+areaReadPrec =+  foldMap spanArea <$> readListPrec++{- |++Construct a contiguous 'Area' consisting of a single 'Span' specified by two+'Loc's. The lesser loc will be the start, and the greater loc will be the end.+If the two locs are equal, the area will be empty.++-}+fromTo+  :: Loc -- ^ Start+  -> Loc -- ^ End+  -> Area+fromTo a b+  | a == b    = mempty+  | otherwise = spanArea (Span.fromTo a b)++{- |++Construct an 'Area' consisting of a single 'Span'.++>>> spanArea (read "4:5-6:3")+[4:5-6:3]++-}+spanArea :: Span -> Area+spanArea s = Area (Map.fromList locs)+  where+    locs = [ (Span.start s, Start)+           , (Span.end   s, End  )+           ]++{- |++A 'Span' from 'start' to 'end', or 'Nothing' if the 'Area' is empty.++>>> areaSpan mempty+Nothing++>>> areaSpan (read "[3:4-7:2]")+Just 3:4-7:2++>>> areaSpan (read "[3:4-7:2,15:6-17:9]")+Just 3:4-17:9++-}+areaSpan :: Area -> Maybe Span+areaSpan x =+  start x >>= \a ->+  end x   <&> \b ->+  Span.fromTo a b++{- |++A list of the 'Span's that constitute an 'Area', sorted in ascending order.++>>> spansAsc mempty+[]++>>> spansAsc (read "[3:4-7:2,15:6-17:9]")+[3:4-7:2,15:6-17:9]++-}+spansAsc :: Area -> [Span]+spansAsc (Area m) =+    mapAccumL f Nothing (Map.keys m) & snd & catMaybes+  where+    f Nothing  l  = (Just l,  Nothing)+    f (Just l) l' = (Nothing, Just $ Span.fromTo l l')++{- |++>>> spanCount mempty+0++>>> spanCount (read "[3:4-7:2]")+1++>>> spanCount (read "[3:4-7:2,15:6-17:9]")+2++-}+spanCount :: Area -> Natural+spanCount (Area locs) =+  fromIntegral (Foldable.length locs `div` 2)++{- |++The first contiguous 'Span' in the 'Area', or 'Nothing' if the area is empty.++>>> firstSpan mempty+Nothing++>>> firstSpan (read "[3:4-7:2]")+Just 3:4-7:2++>>> firstSpan (read "[3:4-7:2,15:6-17:9]")+Just 3:4-7:2++-}+firstSpan :: Area -> Maybe Span+firstSpan (Area m) =+  case Set.toAscList (Map.keysSet m) of+    a:b:_ -> Just (Span.fromTo a b)+    _     -> Nothing++{- |++The last contiguous 'Span' in the 'Area', or 'Nothing' if the area is empty.++>>> lastSpan mempty+Nothing++>>> lastSpan (read "[3:4-7:2]")+Just 3:4-7:2++>>> lastSpan (read "[3:4-7:2,15:6-17:9]")+Just 15:6-17:9++-}+lastSpan :: Area -> Maybe Span+lastSpan (Area m) =+  case Set.toDescList (Map.keysSet m) of+    b:a:_ -> Just (Span.fromTo a b)+    _     -> Nothing++{- |++The 'Loc' at which the 'Area' starts, or 'Nothing' if the 'Area' is empty.++>>> start mempty+Nothing++>>> start (read "[3:4-7:2]")+Just 3:4++>>> start (read "[3:4-7:2,15:6-17:9]")+Just 3:4++-}+start :: Area -> Maybe Loc+start (Area m) =+  case Map.minViewWithKey m of+    Just ((l, _), _) -> Just l+    Nothing          -> Nothing++{- |++The 'Loc' at which the 'Area' ends, or 'Nothing' if the 'Area' is empty.++>>> end mempty+Nothing++>>> end (read "[3:4-7:2]")+Just 7:2++>>> end (read "[3:4-7:2,15:6-17:9]")+Just 17:9++-}+end :: Area -> Maybe Loc+end (Area locs) =+  case Map.maxViewWithKey locs of+    Just ((l, _), _) -> Just l+    Nothing          -> Nothing++{- |++The union of two 'Area's. Spans that overlap or abut will be merged in the+result.++>>> read "[1:1-1:2]" + mempty+[1:1-1:2]++>>> read "[1:1-1:2]" + read "[1:2-1:3]"+[1:1-1:3]++>>> read "[1:1-1:2]" + read "[1:1-3:1]"+[1:1-3:1]++>>> read "[1:1-1:2]" + read "[1:1-11:1]"+[1:1-11:1]++>>> read "[1:1-3:1,6:1-6:2]" + read "[1:1-6:1]"+[1:1-6:2]++>>> read "[1:1-3:1]" + read "[5:1-6:2]"+[1:1-3:1,5:1-6:2]++-}+(+) :: Area -> Area -> Area+a + b+  | spanCount a >= spanCount b = foldr addSpan a (spansAsc b)+  | otherwise                  = b + a++{- |++@'addSpan' s a@ is the union of @'Area' a@ and @'Span' s@.++>>> addSpan (read "1:1-6:1") (read "[1:1-3:1,6:1-6:2]")+[1:1-6:2]++-}+addSpan :: Span -> Area -> Area+addSpan b (Area as) =++  let+    -- Spans lower than b that do not abut or overlap b.+    -- These spans will remain completely intact in the result.+    unmodifiedSpansBelow :: Map Loc Terminus++    -- Spans greater than b that do not abut or overlap b.+    -- These spans will remain completely intact in the result.+    unmodifiedSpansAbove :: Map Loc Terminus++    -- The start location of a span that starts below b but doesn't end below b,+    -- if such a span exists. This span will be merged into the 'middle'.+    startBelow :: Maybe Loc++    -- The end location of a span that ends above b but doesn't start above b,+    -- if such a span exists. This span will be merged into the 'middle'.+    endAbove :: Maybe Loc++    -- b, plus any spans it abuts or overlaps.+    middle :: Map Loc Terminus++    (unmodifiedSpansBelow, startBelow) =+      let+        below = Map.below (Span.start b) as+      in+        case Map.maxViewWithKey below of+          Just ((l, Start), xs) -> (xs, Just l)+          _ -> (below, Nothing)+++    (unmodifiedSpansAbove, endAbove) =+      let+        above = Map.above (Span.end b) as+      in+        case Map.minViewWithKey above of+          Just ((l, End), xs) -> (xs, Just l)+          _ -> (above, Nothing)++    middle = Map.fromList+        [ (minimum $ Foldable.toList startBelow <> [Span.start b], Start)+        , (maximum $ Foldable.toList endAbove   <> [Span.end b],   End)+        ]++  in+    Area $ unmodifiedSpansBelow <> middle <> unmodifiedSpansAbove++{- |++The difference between two 'Area's. @a '-' b@ contains what is covered by @a@+and not covered by @b@.++-}+(-) :: Area -> Area -> Area+a - b = foldr subtractSpan a (spansAsc b)++{- |++@'subtractSpan' s a@ is the subset of 'Area' @a@ that is not covered by 'Span'+@s@.++-}+subtractSpan :: Span -> Area -> Area+subtractSpan b (Area as) =++  let+    resultBelow :: Map Loc Terminus =+      let+        below = Map.belowInclusive (Span.start b) as+      in+        case Map.maxViewWithKey below of+          Just ((l, Start), xs) ->+              if l == Span.start b+              then xs+              else below & Map.insert (Span.start b) End+          _ -> below++    resultAbove :: Map Loc Terminus =+      let+        above = Map.aboveInclusive (Span.end b) as+      in+        case Map.minViewWithKey above of+          Just ((l, End), xs) ->+              if l == Span.end b+              then xs+              else above & Map.insert (Span.end b) Start+          _ -> above++  in+    Area $ resultBelow <> resultAbove
+ src/Data/Loc/Exception.hs view
@@ -0,0 +1,14 @@+module Data.Loc.Exception+  ( LocException (..)+  ) where++import Data.Loc.Internal.Prelude++data LocException+  = EmptySpan+  deriving (Eq, Ord)++instance Exception LocException++instance Show LocException where+  showsPrec _ EmptySpan = showString "empty Span"
+ src/Data/Loc/Internal/Map.hs view
@@ -0,0 +1,62 @@+module Data.Loc.Internal.Map+  ( module Data.Map+  , below, above, belowInclusive, aboveInclusive+  ) where++import Data.Loc.Internal.Prelude++import Data.Map++{- |++@'below' k m@ is the subset of 'Map' @m@ whose keys are less than @k@.++-}+below :: Ord k => k -> Map k a -> Map k a+below k m =+  let+    (x, _) = split k m+  in+    x++{- |++@'below' k m@ is the subset of 'Map' @m@ whose keys are greater than @k@.++-}+above :: Ord k => k -> Map k a -> Map k a+above k m =+  let+    (_, x) = split k m+  in+    x++{- |++@'belowInclusive' k m@ is the subset of 'Map' @m@ whose keys are less than or+equal to @k@.++-}+belowInclusive :: Ord k => k -> Map k a -> Map k a+belowInclusive k m =+  let+    (x, at, _) = splitLookup k m+  in+    case at of+      Nothing -> x+      Just v -> insert k v x++{- |++@'aboveInclusive' k m@ is the subset of 'Map' @m@ whose keys are greater than+or equal to @k@.++-}+aboveInclusive :: Ord k => k -> Map k a -> Map k a+aboveInclusive k m =+  let+    (_, at, x) = splitLookup k m+  in+    case at of+      Nothing -> x+      Just v -> insert k v x
+ src/Data/Loc/Internal/Prelude.hs view
@@ -0,0 +1,46 @@+module Data.Loc.Internal.Prelude+  ( module X+  , (<&>)+  , readPrecChar+  ) where++import Control.Applicative as X (empty, pure, (*>), (<*), (<*>))+import Control.Arrow as X ((<<<), (>>>))+import Control.Exception as X (ArithException (..), Exception, throw)+import Control.Monad as X (Monad (..), guard, mfilter, when)+import Data.Bifunctor as X (Bifunctor (..))+import Data.Bool as X (Bool (..), not, otherwise, (&&), (||))+import Data.Char (Char)+import Data.Eq as X (Eq (..))+import Data.Foldable as X (Foldable (..), foldMap, traverse_)+import Data.Function as X (flip, id, on, ($), (&), (.), const)+import Data.Functor as X (Functor (..), ($>), (<$), (<$>), void)+import Data.List.NonEmpty as X (NonEmpty (..))+import Data.Map as X (Map)+import Data.Maybe as X (Maybe (..), catMaybes, maybe)+import Data.Monoid as X (Monoid (..))+import Data.Ord as X (Ord (..), Ordering (..), max, min)+import Data.Semigroup as X (Semigroup (..))+import Data.Set as X (Set)+import Data.Traversable as X (mapAccumL, sequenceA, traverse)+import Data.Tuple as X (fst, snd)+import Numeric.Natural as X (Natural)+import Prelude as X (Double, Enum (..), Int, Integral, Real (..), div,+                     fromIntegral, print, quotRem, round, sqrt, toInteger,+                     undefined, (/), String)+import System.Exit as X (exitFailure)+import System.IO as X (IO)+import Text.ParserCombinators.ReadPrec as X (readP_to_Prec, readPrec_to_S,+  minPrec)+import Text.Read as X (Read (..), read, ReadPrec)+import Text.Show as X (Show (..), showString, shows, ShowS)++import qualified Text.ParserCombinators.ReadP as ReadP++-- | '<&>' = flip 'fmap'+(<&>) :: Functor f => f a -> (a -> b) -> f b+(<&>) = flip fmap++-- | A precedence parser that reads a single specific character.+readPrecChar :: Char -> ReadPrec ()+readPrecChar = void . readP_to_Prec . const . ReadP.char
+ src/Data/Loc/List/OneToTwo.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveFoldable, DeriveFunctor, LambdaCase #-}++module Data.Loc.List.OneToTwo+  (+  -- * Imports+  -- $imports++  -- * Type+    OneToTwo (..)++  -- * Tuple conversion+  , toTuple+  , toTuple'+  ) where++import Data.Loc.Internal.Prelude++-- | List of length 1 or 2.+data OneToTwo a+  = One a   -- ^ List of length 1+  | Two a a -- ^ List of length 2+  deriving (Eq, Ord, Show, Read, Foldable, Functor)++{- |++>>> toTuple (One 1)+(1,Nothing)++>>> toTuple (Two 1 2)+(1,Just 2)++-}+toTuple :: OneToTwo a -> (a, Maybe a)+toTuple =+  \case+    One a -> (a, Nothing)+    Two a b -> (a, Just b)++{- |++>>> toTuple' (One 1)+(Nothing,1)++>>> toTuple' (Two 1 2)+(Just 1,2)++-}+toTuple' :: OneToTwo a -> (Maybe a, a)+toTuple' =+  \case+    One a -> (Nothing, a)+    Two a b -> (Just a, b)++{- $imports++Recommended import:++> import Data.Loc.List.OneToTwo (OneToTwo)+> import qualified Data.Loc.List.OneToTwo as OneToTwo++-}
+ src/Data/Loc/List/ZeroToTwo.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveFoldable, DeriveFunctor #-}++module Data.Loc.List.ZeroToTwo+  (+  -- Imports+  -- $imports++  -- * Type+    ZeroToTwo (..)+  ) where++import Data.Loc.Internal.Prelude++-- | List of length 0, 1, or 2.+data ZeroToTwo a+  = Zero    -- ^ List of length 0+  | One a   -- ^ List of length 1+  | Two a a -- ^ List of length 2+  deriving (Eq, Ord, Show, Read, Foldable, Functor)++{- $imports++Recommended import:++> import Data.Loc.List.ZeroToTwo (ZeroToTwo)+> import qualified Data.Loc.List.ZeroToTwo as ZeroToTwo++-}
+ src/Data/Loc/Loc.hs view
@@ -0,0 +1,85 @@+module Data.Loc.Loc+  ( Loc++  -- * Constructing+  , loc+  , origin++  -- * Querying+  , line+  , column++  -- * Show and Read+  , locShowsPrec+  , locReadPrec++  ) where++import Data.Loc.Pos (Column, Line)++import Data.Loc.Internal.Prelude++{- |++Stands for /location/. Consists of a 'Line' and a 'Column'. You can think of a+'Loc' like a caret position in a text editor. Following the normal convention+for text editors and such, line and column numbers start with 1.++-}+data Loc = Loc+  { line   :: Line+  , column :: Column+  }+  deriving (Eq, Ord)++-- | 'showsPrec' = 'locShowsPrec'+instance Show Loc+  where++    showsPrec = locShowsPrec++-- | 'readPrec' = 'locReadPrec'+instance Read Loc+  where++    readPrec = locReadPrec++{- |++>>> locShowsPrec minPrec (loc 3 14) ""+"3:14"++-}+locShowsPrec :: Int -> Loc -> ShowS+locShowsPrec _ (Loc l c) =+  shows l .+  (showString ":") .+  shows c++{- |++>>> readPrec_to_S locReadPrec minPrec "3:14"+[(3:14,"")]++-}+locReadPrec :: ReadPrec Loc+locReadPrec =+  Loc              <$>+  readPrec         <*+  readPrecChar ':' <*>+  readPrec++-- | Create a 'Loc' from a line number and column number.+loc :: Line -> Column -> Loc+loc = Loc++{- |++The smallest location: @'loc' 1 1@.++>>> origin+1:1++-}+origin :: Loc+origin = loc 1 1
+ src/Data/Loc/Pos.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.Loc.Pos+  ( Pos+  , Line+  , Column+  , ToNat (..)++  -- * Show and Read+  , posShowsPrec+  , posReadPrec++  ) where++import Data.Loc.Internal.Prelude++import Prelude (Num (..))++{- |++'Pos' stands for /positive integer/. You can also think of it as /position/,+because we use it to represent line and column numbers ('Line' and 'Column').++'Pos' has instances of several of the standard numeric typeclasses, although+many of the operations throw 'Underflow' when non-positive values result.+'Pos' does /not/ have an 'Integral' instance, because there is no sensible+way to implement 'quotRem'.++-}+newtype Pos = Pos Natural+  deriving (Eq, Ord)++instance ToNat Pos+  where++    toNat (Pos n) = n++instance Show Pos+  where++    showsPrec = posShowsPrec++instance Read Pos+  where++    readPrec = posReadPrec++{- |++>>> fromInteger 3 :: Pos+3++>>> fromInteger 0 :: Pos+*** Exception: arithmetic underflow++>>> 2 + 3 :: Pos+5++>>> 3 - 2 :: Pos+1++>>> 3 - 3 :: Pos+*** Exception: arithmetic underflow++>>> 2 * 3 :: Pos+6++>>> negate 3 :: Pos+*** Exception: arithmetic underflow++-}+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++instance Real Pos+  where++    toRational (Pos n) = toRational n++{- |++>>> toEnum 3 :: Pos+3++>>> toEnum 0 :: Pos+*** Exception: arithmetic underflow++>>> fromEnum (3 :: Pos)+3++-}+instance Enum Pos+  where++    toEnum = Pos . checkForUnderflow . toEnum++    fromEnum (Pos n) = fromEnum n++checkForUnderflow :: Natural -> Natural+checkForUnderflow n =+  if n == 0 then throw Underflow else n++{- |++>>> posShowsPrec minPrec 1 ""+"1"++>>> posShowsPrec minPrec 42 ""+"42"++-}+posShowsPrec :: Int -> Pos -> ShowS+posShowsPrec i (Pos n) =+  showsPrec i n++{- |++>>> readPrec_to_S posReadPrec minPrec "1"+[(1,"")]++>>> readPrec_to_S posReadPrec minPrec "42"+[(42,"")]++>>> readPrec_to_S posReadPrec minPrec "0"+[]++>>> readPrec_to_S posReadPrec minPrec "-1"+[]++-}+posReadPrec :: ReadPrec Pos+posReadPrec =+  Pos <$> mfilter (/= 0) readPrec+++--------------------------------------------------------------------------------+--  ToNat+--------------------------------------------------------------------------------++{- |++Types that can be converted to 'Natural'.++This class mostly exists so that 'toNat' can be used in situations that would+normally call for 'toInteger' (which we cannot use because 'Pos' does not have+an instance of 'Integral').++-}+class ToNat a+  where++    toNat :: a -> Natural+++--------------------------------------------------------------------------------+--  Line+--------------------------------------------------------------------------------++newtype Line = Line Pos+  deriving (Eq, Ord, Num, Real, Enum, ToNat)++instance Show Line+  where++    showsPrec i (Line pos) = showsPrec i pos++instance Read Line+  where++    readPrec = Line <$> readPrec+++--------------------------------------------------------------------------------+--  Column+--------------------------------------------------------------------------------++newtype Column = Column Pos+  deriving (Eq, Ord, Num, Real, Enum, ToNat)++instance Show Column+  where++    showsPrec i (Column pos) = showsPrec i pos++instance Read Column+  where++    readPrec = Column <$> readPrec
+ src/Data/Loc/Span.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE LambdaCase #-}++module Data.Loc.Span+  ( Span++  -- * Constructing+  , fromTo+  , fromToMay++  -- * Querying+  , start+  , end++  -- * Calculations+  , lines+  , overlapping+  , linesOverlapping+  , touching+  , join+  , joinAsc+  , (+)+  , (-)++  -- * Show and Read+  , spanShowsPrec+  , spanReadPrec++  ) where++import Data.Loc.Internal.Prelude+import Data.Loc.Loc (locReadPrec, locShowsPrec)++import Data.Loc.Exception (LocException (..))+import Data.Loc.List.OneToTwo (OneToTwo)+import Data.Loc.List.ZeroToTwo (ZeroToTwo)+import Data.Loc.Loc (Loc)+import Data.Loc.Pos (Line)++import qualified Data.Loc.List.OneToTwo as OneToTwo+import qualified Data.Loc.List.ZeroToTwo as ZeroToTwo+import qualified Data.Loc.Loc as Loc++import qualified Data.Foldable as Foldable+import qualified Data.List.NonEmpty as NonEmpty++{- |++A 'Span' consists of a start location ('start') and an end location ('end').+The end location must be greater than the start location; in other words, empty+or backwards spans are not permitted.++Construct and combine spans using 'fromTo', 'fromToMay', '+', and '-'.++-}+data Span = Span+  { start :: Loc+  , end   :: Loc+  } deriving (Eq, Ord)++-- | 'showsPrec' = 'spanShowsPrec'+instance Show Span+  where++    showsPrec = spanShowsPrec++-- | 'readPrec' = 'spanReadPrec'+instance Read Span+  where++    readPrec = spanReadPrec+++{- |++>>> spanShowsPrec minPrec (fromTo (read "3:14") (read "6:5")) ""+"3:14-6:5"++-}+spanShowsPrec :: Int -> Span -> ShowS+spanShowsPrec _ (Span a b) =+  locShowsPrec 10 a .+  (showString "-") .+  locShowsPrec 10 b++{- |++>>> readPrec_to_S spanReadPrec minPrec "3:14-6:5"+[(3:14-6:5,"")]++>>> readPrec_to_S spanReadPrec minPrec "6:5-3:14"+[(3:14-6:5,"")]++>>> readPrec_to_S spanReadPrec minPrec "6:5-6:5"+[]++-}+spanReadPrec :: ReadPrec Span+spanReadPrec =+  locReadPrec      >>= \a ->+  readPrecChar '-' *>+  locReadPrec      >>= \b ->+  maybe empty pure (fromToMay a b)++{- |++Attempt to construct a 'Span' from two 'Loc's. The lesser loc will be the+start, and the greater loc will be the end. The two locs must not be equal,+or else this throws 'EmptySpan'.++/The safe version of this function is 'fromToMay'./++-}+fromTo :: Loc -> Loc -> Span+fromTo a b =+  maybe (throw EmptySpan) id (fromToMay a b)++{- |++Attempt to construct a 'Span' from two 'Loc's. The lesser loc will be the+start, and the greater loc will be the end. If the two locs are not equal,+the result is 'Nothing', because a span cannot be empty.++/This is the safe version of 'fromTo', which throws an exception instead./+-}+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++{- |++All of the lines that a span touches.++>>> NonEmpty.toList (lines (read "2:6-2:10"))+[2]++>>> NonEmpty.toList (lines (read "2:6-8:4"))+[2,3,4,5,6,7,8]++-}+lines :: Span -> NonEmpty Line+lines s =+  NonEmpty.fromList [Loc.line (start s) .. Loc.line (end s)]++{- |++Spans that are directly abutting do not count as overlapping.++>>> overlapping (read "1:5-1:8") (read "1:8-1:12")+False++But these spans overlap by a single character:++>>> overlapping (read "1:5-1:9") (read "1:8-1:12")+True++Spans are overlapping if one is contained entirely within another.++>>> overlapping (read "1:5-1:15") (read "1:6-1:10")+True++Spans are overlapping if they are identical.++>>> overlapping (read "1:5-1:15") (read "1:5-1:15")+True++-}+overlapping :: Span -> Span -> Bool+overlapping a b =+  not (end a <= start b || end b <= start a)++{- |++Determines whether the two spans touch any of the same lines.++>>> linesOverlapping (read "1:1-1:2") (read "1:1-1:2")+True++>>> linesOverlapping (read "1:1-1:2") (read "1:1-2:1")+True++>>> linesOverlapping (read "1:1-1:2") (read "2:1-2:2")+False++-}+linesOverlapping :: Span -> Span -> Bool+linesOverlapping a b =+  not $+    (Loc.line . end) a < (Loc.line . start) b ||+    (Loc.line . end) b < (Loc.line . start) a++{- |++Two spans are considered to "touch" if they are overlapping or abutting;+in other words, if there is no space between them.++>>> touching (read "1:1-1:2") (read "1:2-1:3")+True++>>> touching (read "1:1-1:2") (read "1:1-1:3")+True++>>> touching (read "1:1-1:2") (read "1:3-1:4")+False++-}+touching :: Span -> Span -> Bool+touching a b =+  not (end a < start b || end b < start a)++{- |++>>> join (read "1:1-1:2") (read "1:2-1:3")+1:1-1:3++>>> join (read "1:1-1:2") (read "1:1-1:3")+1:1-1:3++-}+join :: Span -> Span -> Span+join a b =+  Span (min (start a) (start b))+       (max (end   a) (end   b))++{- |++Combine two 'Span's, merging them if they abut or overlap.++>>> read "1:1-1:2" + read "1:2-1:3"+One 1:1-1:3++>>> read "1:1-1:2" + read "1:1-3:1"+One 1:1-3:1++>>> read "1:1-1:2" + read "1:1-11:1"+One 1:1-11:1++If the spans are not overlapping or abutting, they are returned unmodified+in the same order in which they were given as parameters.++>>> read "1:1-1:2" + read "2:1-2:5"+Two 1:1-1:2 2:1-2:5++>>> read "2:1-2:5" + read "1:1-1:2"+Two 2:1-2:5 1:1-1:2++-}+(+) :: Span -> Span -> OneToTwo Span+a + b+  | touching a b = OneToTwo.One (join a b)+  | otherwise    = OneToTwo.Two a b++{- |++The difference between two 'Spans's. @a '-' b@ contains what is covered by+@a@ and not covered by @b@.++>>> read "2:5-4:1" - read "2:9-3:5"+Two 2:5-2:9 3:5-4:1++>>> read "2:5-4:1" - read "2:5-3:5"+One 3:5-4:1++>>> read "2:5-4:1" - read "2:2-3:5"+One 3:5-4:1++Subtracting a thing from itself yields nothing.++>>> let x = read "2:5-4:1" in x - x+Zero++>>> read "2:5-4:1" - read "2:2-4:4"+Zero++>>> read "1:1-8:1" - read "1:2-8:1"+One 1:1-1:2++-}+(-) :: Span -> Span -> ZeroToTwo Span+a - b++    -- [   a   ]   [   b   ]+  | not (overlapping a b) =+      ZeroToTwo.One a++    -- [   a   ]+    --   [ b ]+  | start b > start a && end b < end a =+      ZeroToTwo.Two (Span (start a) (start b))+                    (Span (end b) (end a))++    --    [   a   ]+    -- [   b    ]+  | start b <= start a && end b < end a =+      ZeroToTwo.One (Span (end b) (end a))++    -- [   a   ]+    --    [   b   ]+  | start b > start a && end b >= end a =+      ZeroToTwo.One (Span (start a) (start b))++  | otherwise =+      ZeroToTwo.Zero++-- | Given an ascending list of 'Span's, combine those which abut or overlap.+joinAsc+  :: [Span] -- ^ A list of 'Spans' sorted in ascending order.+            --+            -- /This precondition is not checked./+  -> [Span]+joinAsc =+  \case+    x:y:zs ->+      let (r, s) = OneToTwo.toTuple' (x + y)+      in  Foldable.toList r <> joinAsc (s:zs)+    xs -> xs
+ src/Data/Loc/Types.hs view
@@ -0,0 +1,10 @@+{- |++For convenience, this module exports only the important types from 'Data.Loc'.++-}+module Data.Loc.Types+  ( Pos, Line, Column, Loc, Span, Area+  ) where++import Data.Loc
+ test/Test/Loc/Hedgehog/Gen.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE ScopedTypeVariables #-}++{- |++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 :: (Monad m, ToNat n, Num n)+  => Bounds n -- ^ Minimum and maximum value to generate+  -> Gen m 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 :: Monad m+  => Bounds Line -- ^ Minimum and maximum line number+  -> Gen m Line+line = pos++{- |++Generates a line number within the default bounds @(1, 'defMaxLine')@.++-}+line' :: Monad m => Gen m Line+line' =+  line (1, defMaxLine)++{- |++@'column' a b@ generates a column number on the linear range /a/ to /b/.++-}+column :: Monad m+  => Bounds Column -- ^ Minimum and maximum column number+  -> Gen m Column+column = pos++{- |++Generates a column number within the default bounds @(1, 'defMaxColumn')@.++-}+column' :: Monad m => Gen m 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 :: Monad m+  => Bounds Line   -- ^ Minimum and maximum line number+  -> Bounds Column -- ^ Minimum and maximum column number+  -> Gen m Loc+loc lineBounds columnBounds =+  Loc.loc <$> line   lineBounds+          <*> column columnBounds++{- |++Generates a 'Loc' within the default line and column bounds.++-}+loc' :: Monad m => Gen m 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 :: forall m. Monad m+  => Bounds Line   -- ^ Minimum and maximum line number+  -> Bounds Column -- ^ Minimum and maximum column number+  -> Gen m Span+span lineBounds columnBounds@(minColumn, maxColumn) =+  let+    lines :: Gen m (Line, Line)+    lines =+      line lineBounds >>= \a ->+      line lineBounds <&> \b ->+      (min a b, max a b)++    columnsDifferentLine :: Gen m (Column, Column)+    columnsDifferentLine =+      column columnBounds >>= \a ->+      column columnBounds <&> \b ->+      (a, b)++    columnsSameLine :: Gen m (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' :: Monad m => Gen m 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 :: forall m. Monad m+  => Bounds Line   -- ^ Minimum and maximum line number+  -> Bounds Column -- ^ Minimum and maximum column number+  -> Gen m 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 m [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' :: Monad m => Gen m Area+area' =+  area (1, defMaxLine) (1, defMaxColumn)
+ test/doctest.hs view
@@ -0,0 +1,6 @@+import Prelude+import Test.DocTest++main :: IO ()+main =+  doctest ["-XNoImplicitPrelude", "src"]
+ test/hedgehog.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE TemplateHaskell #-}++import Data.Loc+import Data.Loc.Internal.Prelude++import qualified Data.Loc.Area as Area+import qualified Data.Loc.Span as Span++import Hedgehog++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++main :: IO ()+main =+  checkConcurrent $$(discover) >>= \ok ->+  when (not ok) exitFailure++prop_Span_add_mempty :: Property+prop_Span_add_mempty =+    property $+    forAll Gen.span' >>= \a ->+    spanArea a + mempty === spanArea a+  where+    (+) = (Area.+)++prop_Span_subtract_mempty :: Property+prop_Span_subtract_mempty =+    property $+    forAll Gen.span' >>= \a ->+    spanArea a - mempty === spanArea a+  where+    (-) = (Area.-)++prop_Area_addition_commutativity :: Property+prop_Area_addition_commutativity =+    property $+    forAll Gen.area' >>= \a ->+    forAll Gen.area' >>= \b ->+    a + b === b + a+  where+    (+) = (Area.+)++prop_Area_add_mempty :: Property+prop_Area_add_mempty =+    property $+    forAll Gen.area' >>= \a ->+    a + mempty === a+  where+    (+) = (Area.+)++prop_Area_subtract_mempty :: Property+prop_Area_subtract_mempty =+    property $+    forAll Gen.area' >>= \a ->+    a - mempty === a+  where+    (-) = (Area.-)++prop_Area_addition_and_subtraction :: Property+prop_Area_addition_and_subtraction =+    property $+    forAll Gen.area' >>= \a ->+    forAll Gen.area' >>= \b ->+    forAll Gen.area' >>= \c ->+    a - b - c === a - (b + c)+  where+    (+) = (Area.+)+    (-) = (Area.-)++prop_Span_joinAsc :: Property+prop_Span_joinAsc =+  property $+  forAll (Gen.list (Range.linear 1 10) Gen.span') >>= \spans ->+  areaSpansAsc (foldMap spanArea spans) === Span.joinAsc (List.sort spans)++prop_Area_addSpan :: Property+prop_Area_addSpan =+  property $+  forAll Gen.area' >>= \a ->+  forAll Gen.span' >>= \s ->+  Area.addSpan s a === areaUnion (spanArea s) a++prop_Area_fromTo_mempty1 :: Property+prop_Area_fromTo_mempty1 =+  property $+  forAll Gen.loc' >>= \x ->+  forAll Gen.loc' >>= \y ->+  (Area.fromTo x y == mempty) === (x == y)++prop_Area_fromTo_mempty2 :: Property+prop_Area_fromTo_mempty2 =+  property $+  forAll Gen.loc' >>= \x ->+  Area.fromTo x x === mempty++prop_Loc_read_show :: Property+prop_Loc_read_show =+  property $+  forAll Gen.loc' >>= \x ->+  read (show x) === x++prop_Span_read_show :: Property+prop_Span_read_show =+  property $+  forAll Gen.span' >>= \x ->+  read (show x) === x++prop_Area_read_show :: Property+prop_Area_read_show =+  property $+  forAll Gen.area' >>= \x ->+  read (show x) === x