1{-| Position information for syntax. Crucial for giving good error messages. 2-} 3 4module Agda.Syntax.Position 5 ( -- * Positions 6 Position 7 , PositionWithoutFile 8 , Position'(..) 9 , SrcFile 10 , positionInvariant 11 , startPos 12 , movePos 13 , movePosByString 14 , backupPos 15 , startPos' 16 17 -- * Intervals 18 , Interval 19 , IntervalWithoutFile 20 , Interval'(..) 21 , intervalInvariant 22 , posToInterval 23 , getIntervalFile 24 , iLength 25 , fuseIntervals 26 , setIntervalFile 27 28 -- * Ranges 29 , Range 30 , Range'(..) 31 , rangeInvariant 32 , consecutiveAndSeparated 33 , intervalsToRange 34 , intervalToRange 35 , rangeIntervals 36 , rangeFile 37 , rightMargin 38 , noRange 39 , posToRange, posToRange' 40 , rStart, rStart' 41 , rEnd, rEnd' 42 , rangeToInterval 43 , rangeToIntervalWithFile 44 , continuous 45 , continuousPerLine 46 , PrintRange(..) 47 , HasRange(..) 48 , SetRange(..) 49 , KillRange(..) 50 , KillRangeT 51 , killRangeMap 52 , killRange1, killRange2, killRange3, killRange4, killRange5, killRange6, killRange7 53 , killRange8, killRange9, killRange10, killRange11, killRange12, killRange13, killRange14 54 , killRange15, killRange16, killRange17, killRange18, killRange19 55 , withRangeOf 56 , fuseRange 57 , fuseRanges 58 , beginningOf 59 , beginningOfFile 60 , interleaveRanges 61 ) where 62 63import Prelude hiding ( null ) 64 65import Control.DeepSeq 66import Control.Monad.Writer (runWriter, tell) 67 68import qualified Data.Foldable as Fold 69import Data.Function 70import Data.Int 71import Data.List hiding (null) 72import Data.Map (Map) 73import qualified Data.Map as Map 74import Data.Set (Set) 75import qualified Data.Set as Set 76import Data.Data (Data) 77import Data.Sequence (Seq) 78import qualified Data.Sequence as Seq 79import Data.Semigroup (Semigroup(..)) 80import Data.Void 81 82import GHC.Generics (Generic) 83 84import Agda.Utils.FileName 85import Agda.Utils.List 86import Agda.Utils.List1 (List1) 87import Agda.Utils.List2 (List2) 88import qualified Agda.Utils.Maybe.Strict as Strict 89import Agda.Utils.Null 90import Agda.Utils.Permutation 91import Agda.Utils.Pretty 92 93import Agda.Utils.Impossible 94 95{-------------------------------------------------------------------------- 96 Types and classes 97 --------------------------------------------------------------------------} 98 99-- | Represents a point in the input. 100-- 101-- If two positions have the same 'srcFile' and 'posPos' components, 102-- then the final two components should be the same as well, but since 103-- this can be hard to enforce the program should not rely too much on 104-- the last two components; they are mainly there to improve error 105-- messages for the user. 106-- 107-- Note the invariant which positions have to satisfy: 'positionInvariant'. 108data Position' a = Pn 109 { srcFile :: !a 110 -- ^ File. 111 , posPos :: !Int32 112 -- ^ Position, counting from 1. 113 , posLine :: !Int32 114 -- ^ Line number, counting from 1. 115 , posCol :: !Int32 116 -- ^ Column number, counting from 1. 117 } 118 deriving (Show, Data, Functor, Foldable, Traversable, Generic) 119 120positionInvariant :: Position' a -> Bool 121positionInvariant p = 122 posPos p > 0 && posLine p > 0 && posCol p > 0 123 124importantPart :: Position' a -> (a, Int32) 125importantPart p = (srcFile p, posPos p) 126 127instance Eq a => Eq (Position' a) where 128 (==) = (==) `on` importantPart 129 130instance Ord a => Ord (Position' a) where 131 compare = compare `on` importantPart 132 133type SrcFile = Strict.Maybe AbsolutePath 134 135type Position = Position' SrcFile 136type PositionWithoutFile = Position' () 137 138instance NFData Position where 139 rnf = (`seq` ()) 140 141instance NFData PositionWithoutFile where 142 rnf = (`seq` ()) 143 144-- | An interval. The @iEnd@ position is not included in the interval. 145-- 146-- Note the invariant which intervals have to satisfy: 'intervalInvariant'. 147data Interval' a = Interval { iStart, iEnd :: !(Position' a) } 148 deriving (Show, Data, Eq, Ord, Functor, Foldable, Traversable, Generic) 149 150type Interval = Interval' SrcFile 151type IntervalWithoutFile = Interval' () 152 153instance NFData Interval where 154 rnf = (`seq` ()) 155 156instance NFData IntervalWithoutFile where 157 rnf = (`seq` ()) 158 159intervalInvariant :: Ord a => Interval' a -> Bool 160intervalInvariant i = 161 all positionInvariant [iStart i, iEnd i] 162 && 163 iStart i <= iEnd i 164 && 165 srcFile (iStart i) == srcFile (iEnd i) 166 167-- | Sets the 'srcFile' components of the interval. 168 169setIntervalFile :: a -> Interval' b -> Interval' a 170setIntervalFile f (Interval p1 p2) = 171 Interval (p1 { srcFile = f }) (p2 { srcFile = f }) 172 173-- | Gets the 'srcFile' component of the interval. Because of the invariant, 174-- they are both the same. 175getIntervalFile :: Interval' a -> a 176getIntervalFile = srcFile . iStart 177 178-- | Converts a file name and two positions to an interval. 179posToInterval :: 180 a -> PositionWithoutFile -> PositionWithoutFile -> Interval' a 181posToInterval f p1 p2 = setIntervalFile f $ 182 if p1 < p2 183 then Interval p1 p2 184 else Interval p2 p1 185 186-- | The length of an interval. 187iLength :: Interval' a -> Int32 188iLength i = posPos (iEnd i) - posPos (iStart i) 189 190-- | A range is a file name, plus a sequence of intervals, assumed to 191-- point to the given file. The intervals should be consecutive and 192-- separated. 193-- 194-- Note the invariant which ranges have to satisfy: 'rangeInvariant'. 195data Range' a 196 = NoRange 197 | Range !a (Seq IntervalWithoutFile) 198 deriving 199 (Show, Data, Eq, Ord, Functor, Foldable, Traversable, Generic) 200 201type Range = Range' SrcFile 202 203instance NFData a => NFData (Range' a) 204 205instance Null (Range' a) where 206 null NoRange = True 207 null Range{} = False 208 209 empty = NoRange 210 211instance Semigroup a => Semigroup (Range' a) where 212 NoRange <> r = r 213 r <> NoRange = r 214 Range f is <> Range f' is' = Range (f <> f') (is <> is') 215 216instance Semigroup a => Monoid (Range' a) where 217 mempty = empty 218 mappend = (<>) 219 220-- | To get @'Semigroup' 'Range'@, we need a semigroup instance for 'AbsolutePath'. 221instance Semigroup AbsolutePath where 222 f <> f' = if f == f' then f else __IMPOSSIBLE__ 223 224-- | The intervals that make up the range. The intervals are 225-- consecutive and separated ('consecutiveAndSeparated'). 226rangeIntervals :: Range' a -> [IntervalWithoutFile] 227rangeIntervals NoRange = [] 228rangeIntervals (Range _ is) = Fold.toList is 229 230-- | Turns a file name plus a list of intervals into a range. 231-- 232-- Precondition: 'consecutiveAndSeparated'. 233intervalsToRange :: a -> [IntervalWithoutFile] -> Range' a 234intervalsToRange _ [] = NoRange 235intervalsToRange f is = Range f (Seq.fromList is) 236 237-- | Are the intervals consecutive and separated, do they all point to 238-- the same file, and do they satisfy the interval invariant? 239consecutiveAndSeparated :: Ord a => [Interval' a] -> Bool 240consecutiveAndSeparated is = 241 all intervalInvariant is 242 && 243 allEqual (map (srcFile . iStart) is) 244 && 245 (null is 246 || 247 and (zipWith (<) (map iEnd (init is)) 248 (map iStart (tail is)))) 249 250-- | Range invariant. 251rangeInvariant :: Ord a => Range' a -> Bool 252rangeInvariant r = 253 consecutiveAndSeparated (rangeIntervals r) 254 && 255 case r of 256 Range _ is -> not (null is) 257 NoRange -> True 258 259-- | The file the range is pointing to. 260rangeFile :: Range -> SrcFile 261rangeFile NoRange = Strict.Nothing 262rangeFile (Range f _) = f 263 264-- | Conflate a range to its right margin. 265rightMargin :: Range -> Range 266rightMargin r@NoRange = r 267rightMargin r@(Range f is) = case Seq.viewr is of 268 Seq.EmptyR -> __IMPOSSIBLE__ 269 _ Seq.:> i -> intervalToRange f (i { iStart = iEnd i }) 270 271-- | Wrapper to indicate that range should be printed. 272newtype PrintRange a = PrintRange a 273 deriving (Eq, Ord, HasRange, SetRange, KillRange) 274 275-- | Things that have a range are instances of this class. 276class HasRange a where 277 getRange :: a -> Range 278 279 default getRange :: (Foldable t, HasRange b, t b ~ a) => a -> Range 280 getRange = Fold.foldr fuseRange noRange 281 282instance HasRange Interval where 283 getRange i = 284 intervalToRange (srcFile (iStart i)) 285 (setIntervalFile () i) 286 287instance HasRange Range where 288 getRange = id 289 290instance HasRange () where 291 getRange _ = noRange 292 293instance HasRange Bool where 294 getRange _ = noRange 295 296-- | Precondition: The ranges of the list elements must point to the 297-- same file (or be empty). 298instance HasRange a => HasRange [a] 299 300-- | Precondition: The ranges of the list elements must point to the 301-- same file (or be empty). 302instance HasRange a => HasRange (List1 a) 303instance HasRange a => HasRange (List2 a) 304instance HasRange a => HasRange (Maybe a) 305 306-- | Precondition: The ranges of the tuple elements must point to the 307-- same file (or be empty). 308instance (HasRange a, HasRange b) => HasRange (a,b) where 309 getRange = uncurry fuseRange 310 311-- | Precondition: The ranges of the tuple elements must point to the 312-- same file (or be empty). 313instance (HasRange a, HasRange b, HasRange c) => HasRange (a,b,c) where 314 getRange (x,y,z) = getRange (x,(y,z)) 315 316-- | Precondition: The ranges of the tuple elements must point to the 317-- same file (or be empty). 318instance (HasRange a, HasRange b, HasRange c, HasRange d) => HasRange (a,b,c,d) where 319 getRange (x,y,z,w) = getRange (x,(y,(z,w))) 320 321-- | Precondition: The ranges of the tuple elements must point to the 322-- same file (or be empty). 323instance (HasRange a, HasRange b, HasRange c, HasRange d, HasRange e) => HasRange (a,b,c,d,e) where 324 getRange (x,y,z,w,v) = getRange (x,(y,(z,(w,v)))) 325 326-- | Precondition: The ranges of the tuple elements must point to the 327-- same file (or be empty). 328instance (HasRange a, HasRange b, HasRange c, HasRange d, HasRange e, HasRange f) => HasRange (a,b,c,d,e,f) where 329 getRange (x,y,z,w,v,u) = getRange (x,(y,(z,(w,(v,u))))) 330 331-- | Precondition: The ranges of the tuple elements must point to the 332-- same file (or be empty). 333instance (HasRange a, HasRange b, HasRange c, HasRange d, HasRange e, HasRange f, HasRange g) => HasRange (a,b,c,d,e,f,g) where 334 getRange (x,y,z,w,v,u,t) = getRange (x,(y,(z,(w,(v,(u,t)))))) 335 336instance (HasRange a, HasRange b) => HasRange (Either a b) where 337 getRange = either getRange getRange 338 339-- | If it is also possible to set the range, this is the class. 340-- 341-- Instances should satisfy @'getRange' ('setRange' r x) == r@. 342class HasRange a => SetRange a where 343 setRange :: Range -> a -> a 344 345 default setRange :: (Functor f, SetRange b, f b ~ a) => Range -> a -> a 346 setRange = fmap . setRange 347 348instance SetRange Range where 349 setRange = const 350 351instance SetRange a => SetRange [a] 352instance SetRange a => SetRange (Maybe a) 353 354-- | Killing the range of an object sets all range information to 'noRange'. 355class KillRange a where 356 killRange :: KillRangeT a 357 358 default killRange :: (Functor f, KillRange b, f b ~ a) => KillRangeT a 359 killRange = fmap killRange 360 361type KillRangeT a = a -> a 362 363-- | Remove ranges in keys and values of a map. 364killRangeMap :: (KillRange k, KillRange v) => KillRangeT (Map k v) 365killRangeMap = Map.mapKeysMonotonic killRange . Map.map killRange 366 367killRange1 :: KillRange a => (a -> b) -> a -> b 368 369killRange2 :: (KillRange a, KillRange b) => (a -> b -> c) -> a -> b -> c 370 371killRange3 :: (KillRange a, KillRange b, KillRange c) => 372 (a -> b -> c -> d) -> a -> b -> c -> d 373 374killRange4 :: (KillRange a, KillRange b, KillRange c, KillRange d) => 375 (a -> b -> c -> d -> e) -> a -> b -> c -> d -> e 376 377killRange5 :: ( KillRange a, KillRange b, KillRange c, KillRange d 378 , KillRange e ) => 379 (a -> b -> c -> d -> e -> f) -> a -> b -> c -> d -> e -> f 380 381killRange6 :: ( KillRange a, KillRange b, KillRange c, KillRange d 382 , KillRange e, KillRange f ) => 383 (a -> b -> c -> d -> e -> f -> g) -> a -> b -> c -> d -> e -> f -> g 384 385killRange7 :: ( KillRange a, KillRange b, KillRange c, KillRange d 386 , KillRange e, KillRange f, KillRange g ) => 387 (a -> b -> c -> d -> e -> f -> g -> h) -> a -> b -> c -> d -> e -> f -> g -> h 388 389killRange8 :: ( KillRange a, KillRange b, KillRange c, KillRange d 390 , KillRange e, KillRange f, KillRange g, KillRange h ) => 391 (a -> b -> c -> d -> e -> f -> g -> h -> i) -> 392 a -> b -> c -> d -> e -> f -> g -> h -> i 393 394killRange9 :: ( KillRange a, KillRange b, KillRange c, KillRange d 395 , KillRange e, KillRange f, KillRange g, KillRange h 396 , KillRange i ) => 397 (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> 398 a -> b -> c -> d -> e -> f -> g -> h -> i -> j 399 400killRange10 :: ( KillRange a, KillRange b, KillRange c, KillRange d 401 , KillRange e, KillRange f, KillRange g, KillRange h 402 , KillRange i, KillRange j ) => 403 (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> 404 a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k 405 406killRange11 :: ( KillRange a, KillRange b, KillRange c, KillRange d 407 , KillRange e, KillRange f, KillRange g, KillRange h 408 , KillRange i, KillRange j, KillRange k ) => 409 (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l) -> 410 a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l 411 412killRange12 :: ( KillRange a, KillRange b, KillRange c, KillRange d 413 , KillRange e, KillRange f, KillRange g, KillRange h 414 , KillRange i, KillRange j, KillRange k, KillRange l ) => 415 (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m) -> 416 a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m 417 418killRange13 :: ( KillRange a, KillRange b, KillRange c, KillRange d 419 , KillRange e, KillRange f, KillRange g, KillRange h 420 , KillRange i, KillRange j, KillRange k, KillRange l 421 , KillRange m ) => 422 (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n) -> 423 a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n 424 425killRange14 :: ( KillRange a, KillRange b, KillRange c, KillRange d 426 , KillRange e, KillRange f, KillRange g, KillRange h 427 , KillRange i, KillRange j, KillRange k, KillRange l 428 , KillRange m, KillRange n ) => 429 (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o) -> 430 a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o 431 432killRange15 :: ( KillRange a, KillRange b, KillRange c, KillRange d 433 , KillRange e, KillRange f, KillRange g, KillRange h 434 , KillRange i, KillRange j, KillRange k, KillRange l 435 , KillRange m, KillRange n, KillRange o ) => 436 (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p) -> 437 a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p 438 439killRange16 :: ( KillRange a, KillRange b, KillRange c, KillRange d 440 , KillRange e, KillRange f, KillRange g, KillRange h 441 , KillRange i, KillRange j, KillRange k, KillRange l 442 , KillRange m, KillRange n, KillRange o, KillRange p ) => 443 (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q) -> 444 a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q 445 446killRange17 :: ( KillRange a, KillRange b, KillRange c, KillRange d 447 , KillRange e, KillRange f, KillRange g, KillRange h 448 , KillRange i, KillRange j, KillRange k, KillRange l 449 , KillRange m, KillRange n, KillRange o, KillRange p 450 , KillRange q ) => 451 (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r) -> 452 a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r 453 454killRange18 :: ( KillRange a, KillRange b, KillRange c, KillRange d 455 , KillRange e, KillRange f, KillRange g, KillRange h 456 , KillRange i, KillRange j, KillRange k, KillRange l 457 , KillRange m, KillRange n, KillRange o, KillRange p 458 , KillRange q, KillRange r ) => 459 (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r -> s) -> 460 a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r -> s 461 462killRange19 :: ( KillRange a, KillRange b, KillRange c, KillRange d 463 , KillRange e, KillRange f, KillRange g, KillRange h 464 , KillRange i, KillRange j, KillRange k, KillRange l 465 , KillRange m, KillRange n, KillRange o, KillRange p 466 , KillRange q, KillRange r, KillRange s ) => 467 (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r -> s -> t) -> 468 a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r -> s -> t 469 470killRange1 f a = f (killRange a) 471killRange2 f a = killRange1 (f $ killRange a) 472killRange3 f a = killRange2 (f $ killRange a) 473killRange4 f a = killRange3 (f $ killRange a) 474killRange5 f a = killRange4 (f $ killRange a) 475killRange6 f a = killRange5 (f $ killRange a) 476killRange7 f a = killRange6 (f $ killRange a) 477killRange8 f a = killRange7 (f $ killRange a) 478killRange9 f a = killRange8 (f $ killRange a) 479killRange10 f a = killRange9 (f $ killRange a) 480killRange11 f a = killRange10 (f $ killRange a) 481killRange12 f a = killRange11 (f $ killRange a) 482killRange13 f a = killRange12 (f $ killRange a) 483killRange14 f a = killRange13 (f $ killRange a) 484killRange15 f a = killRange14 (f $ killRange a) 485killRange16 f a = killRange15 (f $ killRange a) 486killRange17 f a = killRange16 (f $ killRange a) 487killRange18 f a = killRange17 (f $ killRange a) 488killRange19 f a = killRange18 (f $ killRange a) 489 490instance KillRange Range where 491 killRange _ = noRange 492 493instance KillRange Void where 494 killRange = id 495 496instance KillRange () where 497 killRange = id 498 499instance KillRange Bool where 500 killRange = id 501 502instance KillRange Int where 503 killRange = id 504 505instance KillRange Integer where 506 killRange = id 507 508instance KillRange Permutation where 509 killRange = id 510 511-- | Overlaps with @KillRange [a]@. 512instance {-# OVERLAPPING #-} KillRange String where 513 killRange = id 514 515instance {-# OVERLAPPABLE #-} KillRange a => KillRange [a] 516instance {-# OVERLAPPABLE #-} KillRange a => KillRange (Map k a) 517 518instance KillRange a => KillRange (Drop a) 519instance KillRange a => KillRange (List1 a) 520instance KillRange a => KillRange (List2 a) 521instance KillRange a => KillRange (Maybe a) 522instance KillRange a => KillRange (Strict.Maybe a) 523 524instance {-# OVERLAPPABLE #-} (Ord a, KillRange a) => KillRange (Set a) where 525 killRange = Set.map killRange 526 527instance (KillRange a, KillRange b) => KillRange (a, b) where 528 killRange (x, y) = (killRange x, killRange y) 529 530instance (KillRange a, KillRange b, KillRange c) => 531 KillRange (a, b, c) where 532 killRange (x, y, z) = killRange3 (,,) x y z 533 534instance (KillRange a, KillRange b, KillRange c, KillRange d) => 535 KillRange (a, b, c, d) where 536 killRange (x, y, z, u) = killRange4 (,,,) x y z u 537 538instance (KillRange a, KillRange b) => KillRange (Either a b) where 539 killRange (Left x) = Left $ killRange x 540 killRange (Right x) = Right $ killRange x 541 542------------------------------------------------------------------------ 543-- Printing 544------------------------------------------------------------------------ 545 546instance Pretty a => Pretty (Position' (Strict.Maybe a)) where 547 pretty (Pn Strict.Nothing _ l c) = pretty l <> "," <> pretty c 548 pretty (Pn (Strict.Just f) _ l c) = 549 pretty f <> ":" <> pretty l <> "," <> pretty c 550 551instance Pretty PositionWithoutFile where 552 pretty p = pretty (p { srcFile = Strict.Nothing } :: Position) 553 554instance Pretty IntervalWithoutFile where 555 pretty (Interval s e) = start <> "-" <> end 556 where 557 sl = posLine s 558 el = posLine e 559 sc = posCol s 560 ec = posCol e 561 562 start :: Doc 563 start = pretty sl <> comma <> pretty sc 564 565 end :: Doc 566 | sl == el = pretty ec 567 | otherwise = pretty el <> comma <> pretty ec 568 569instance Pretty a => Pretty (Interval' (Strict.Maybe a)) where 570 pretty i@(Interval s _) = file <> pretty (setIntervalFile () i) 571 where 572 file :: Doc 573 file = case srcFile s of 574 Strict.Nothing -> empty 575 Strict.Just f -> pretty f <> colon 576 577instance Pretty a => Pretty (Range' (Strict.Maybe a)) where 578 pretty r = maybe empty pretty (rangeToIntervalWithFile r) 579 580instance (Pretty a, HasRange a) => Pretty (PrintRange a) where 581 pretty (PrintRange a) = pretty a <+> parens ("at" <+> pretty (getRange a)) 582 583{-------------------------------------------------------------------------- 584 Functions on positions and ranges 585 --------------------------------------------------------------------------} 586 587-- | The first position in a file: position 1, line 1, column 1. 588startPos' :: a -> Position' a 589startPos' f = Pn 590 { srcFile = f 591 , posPos = 1 592 , posLine = 1 593 , posCol = 1 594 } 595 596-- | The first position in a file: position 1, line 1, column 1. 597startPos :: Maybe AbsolutePath -> Position 598startPos = startPos' . Strict.toStrict 599 600-- | Ranges between two unknown positions 601noRange :: Range' a 602noRange = NoRange 603 604-- | Advance the position by one character. 605-- A newline character (@'\n'@) moves the position to the first 606-- character in the next line. Any other character moves the 607-- position to the next column. 608movePos :: Position' a -> Char -> Position' a 609movePos (Pn f p l c) '\n' = Pn f (p + 1) (l + 1) 1 610movePos (Pn f p l c) _ = Pn f (p + 1) l (c + 1) 611 612-- | Advance the position by a string. 613-- 614-- > movePosByString = foldl' movePos 615movePosByString :: Position' a -> String -> Position' a 616movePosByString = foldl' movePos 617 618-- | Backup the position by one character. 619-- 620-- Precondition: The character must not be @'\n'@. 621backupPos :: Position' a -> Position' a 622backupPos (Pn f p l c) = Pn f (p - 1) l (c - 1) 623 624-- | Converts a file name and two positions to a range. 625posToRange' :: 626 a -> PositionWithoutFile -> PositionWithoutFile -> Range' a 627posToRange' f p1 p2 = intervalToRange f (posToInterval () p1 p2) 628 629-- | Converts two positions to a range. 630-- 631-- Precondition: The positions have to point to the same file. 632posToRange :: Position' a -> Position' a -> Range' a 633posToRange p1 p2 = 634 posToRange' (srcFile p1) (p1 { srcFile = () }) (p2 { srcFile = () }) 635 636-- | Converts a file name and an interval to a range. 637intervalToRange :: a -> IntervalWithoutFile -> Range' a 638intervalToRange f i = Range f (Seq.singleton i) 639 640-- | Converts a range to an interval, if possible. 641rangeToIntervalWithFile :: Range' a -> Maybe (Interval' a) 642rangeToIntervalWithFile NoRange = Nothing 643rangeToIntervalWithFile (Range f is) = case (Seq.viewl is, Seq.viewr is) of 644 (head Seq.:< _, _ Seq.:> last) -> Just $ setIntervalFile f $ 645 Interval { iStart = iStart head 646 , iEnd = iEnd last 647 } 648 _ -> __IMPOSSIBLE__ 649 650-- | Converts a range to an interval, if possible. Note that the 651-- information about the source file is lost. 652rangeToInterval :: Range' a -> Maybe IntervalWithoutFile 653rangeToInterval NoRange = Nothing 654rangeToInterval (Range _ is) = case (Seq.viewl is, Seq.viewr is) of 655 (head Seq.:< _, _ Seq.:> last) -> Just $ 656 Interval { iStart = iStart head 657 , iEnd = iEnd last 658 } 659 _ -> __IMPOSSIBLE__ 660 661-- | Returns the shortest continuous range containing the given one. 662continuous :: Range' a -> Range' a 663continuous NoRange = NoRange 664continuous r@(Range f _) = case rangeToInterval r of 665 Nothing -> __IMPOSSIBLE__ 666 Just i -> intervalToRange f i 667 668-- | Removes gaps between intervals on the same line. 669continuousPerLine :: Ord a => Range' a -> Range' a 670continuousPerLine r@NoRange = r 671continuousPerLine r@(Range f _) = 672 Range f (Seq.unfoldr step (rangeIntervals r)) 673 where 674 step [] = Nothing 675 step [i] = Just (i, []) 676 step (i : is@(j : js)) 677 | sameLine = step (fuseIntervals i j : js) 678 | otherwise = Just (i, is) 679 where 680 sameLine = posLine (iEnd i) == posLine (iStart j) 681 682-- | The initial position in the range, if any. 683rStart' :: Range' a -> Maybe PositionWithoutFile 684rStart' r = iStart <$> rangeToInterval r 685 686-- | The initial position in the range, if any. 687rStart :: Range' a -> Maybe (Position' a) 688rStart NoRange = Nothing 689rStart r@(Range f _) = (\p -> p { srcFile = f }) <$> rStart' r 690 691-- | The position after the final position in the range, if any. 692rEnd' :: Range' a -> Maybe PositionWithoutFile 693rEnd' r = iEnd <$> rangeToInterval r 694 695-- | The position after the final position in the range, if any. 696rEnd :: Range' a -> Maybe (Position' a) 697rEnd NoRange = Nothing 698rEnd r@(Range f _) = (\p -> p { srcFile = f }) <$> rEnd' r 699 700-- | Finds the least interval which covers the arguments. 701-- 702-- Precondition: The intervals must point to the same file. 703fuseIntervals :: Ord a => Interval' a -> Interval' a -> Interval' a 704fuseIntervals x y = Interval { iStart = s, iEnd = e } 705 where 706 s = headWithDefault __IMPOSSIBLE__ $ sort [iStart x, iStart y] 707 e = lastWithDefault __IMPOSSIBLE__ $ sort [iEnd x, iEnd y] 708 709-- | @fuseRanges r r'@ unions the ranges @r@ and @r'@. 710-- 711-- Meaning it finds the least range @r0@ that covers @r@ and @r'@. 712-- 713-- Precondition: The ranges must point to the same file (or be empty). 714fuseRanges :: (Ord a) => Range' a -> Range' a -> Range' a 715fuseRanges NoRange is2 = is2 716fuseRanges is1 NoRange = is1 717fuseRanges (Range f is1) (Range _ is2) = Range f (fuse is1 is2) 718 where 719 fuse is1 is2 = case (Seq.viewl is1, Seq.viewr is1, 720 Seq.viewl is2, Seq.viewr is2) of 721 (Seq.EmptyL, _, _, _) -> is2 722 (_, _, Seq.EmptyL, _) -> is1 723 (s1 Seq.:< r1, l1 Seq.:> e1, s2 Seq.:< r2, l2 Seq.:> e2) 724 -- Special cases. 725 | iEnd e1 < iStart s2 -> is1 Seq.>< is2 726 | iEnd e2 < iStart s1 -> is2 Seq.>< is1 727 | iEnd e1 == iStart s2 -> mergeTouching l1 e1 s2 r2 728 | iEnd e2 == iStart s1 -> mergeTouching l2 e2 s1 r1 729 -- General cases. 730 | iEnd s1 < iStart s2 -> outputLeftPrefix s1 r1 s2 is2 731 | iEnd s2 < iStart s1 -> outputLeftPrefix s2 r2 s1 is1 732 | iEnd s1 < iEnd s2 -> fuseSome s1 r1 s2 r2 733 | otherwise -> fuseSome s2 r2 s1 r1 734 _ -> __IMPOSSIBLE__ 735 736 mergeTouching l e s r = l Seq.>< i Seq.<| r 737 where 738 i = Interval { iStart = iStart e, iEnd = iEnd s } 739 740 -- The following two functions could use binary search instead of 741 -- linear. 742 743 outputLeftPrefix s1 r1 s2 is2 = s1 Seq.<| r1' Seq.>< fuse r1'' is2 744 where 745 (r1', r1'') = Seq.spanl (\s -> iEnd s < iStart s2) r1 746 747 fuseSome s1 r1 s2 r2 = fuse r1' (fuseIntervals s1 s2 Seq.<| r2) 748 where 749 r1' = Seq.dropWhileL (\s -> iEnd s <= iEnd s2) r1 750 751-- | Precondition: The ranges must point to the same file (or be 752-- empty). 753fuseRange :: (HasRange u, HasRange t) => u -> t -> Range 754fuseRange x y = fuseRanges (getRange x) (getRange y) 755 756-- | @beginningOf r@ is an empty range (a single, empty interval) 757-- positioned at the beginning of @r@. If @r@ does not have a 758-- beginning, then 'noRange' is returned. 759beginningOf :: Range -> Range 760beginningOf NoRange = NoRange 761beginningOf r@(Range f _) = case rStart' r of 762 Nothing -> __IMPOSSIBLE__ 763 Just pos -> posToRange' f pos pos 764 765-- | @beginningOfFile r@ is an empty range (a single, empty interval) 766-- at the beginning of @r@'s starting position's file. If there is no 767-- such position, then an empty range is returned. 768beginningOfFile :: Range -> Range 769beginningOfFile NoRange = NoRange 770beginningOfFile (Range f _) = posToRange' f p p 771 where p = startPos' () 772 773-- | @x \`withRangeOf\` y@ sets the range of @x@ to the range of @y@. 774withRangeOf :: (SetRange t, HasRange u) => t -> u -> t 775x `withRangeOf` y = setRange (getRange y) x 776 777-- | Interleaves two streams of ranged elements 778-- 779-- It will report the conflicts as a list of conflicting pairs. 780-- In case of conflict, the element with the earliest start position 781-- is placed first. In case of a tie, the element with the earliest 782-- ending position is placed first. If both tie, the element from the 783-- first list is placed first. 784interleaveRanges :: (HasRange a) => [a] -> [a] -> ([a], [(a,a)]) 785interleaveRanges as bs = runWriter$ go as bs 786 where 787 go [] as = return as 788 go as [] = return as 789 go as@(a:as') bs@(b:bs') = 790 let ra = getRange a 791 rb = getRange b 792 793 ra0 = rStart ra 794 rb0 = rStart rb 795 796 ra1 = rEnd ra 797 rb1 = rEnd rb 798 in 799 if ra1 <= rb0 then 800 (a:) <$> go as' bs 801 else if rb1 <= ra0 then 802 (b:) <$> go as bs' 803 else do 804 tell [(a,b)] 805 if ra0 < rb0 || (ra0 == rb0 && ra1 <= rb1) then 806 (a:) <$> go as' bs 807 else 808 (b:) <$> go as bs' 809