1{- 2 Copyright 2014-2021 Mario Blazevic 3 4 License: BSD3 (see BSD3-LICENSE.txt file) 5-} 6 7-- | This module defines two monoid transformer data types, 'OffsetPositioned' and 'LinePositioned'. Both data types add 8-- a notion of the current position to their base monoid. In case of 'OffsetPositioned', the current position is a 9-- simple integer offset from the beginning of the monoid, and it can be applied to any 'StableFactorial'. The 10-- base monoid of 'LinePositioned' must be a 'TextualMonoid', but for the price it will keep track of the current line 11-- and column numbers as well. 12-- 13-- Line number is zero-based, column one-based: 14-- 15-- >> let p = pure "abcd\nefgh\nijkl\nmnop\n" :: LinePositioned String 16-- >> p 17-- >"abcd\nefgh\nijkl\nmnop\n" 18-- >> Data.Monoid.Factorial.drop 13 p 19-- >Line 2, column 4: "l\nmnop\n" 20 21{-# LANGUAGE Haskell2010 #-} 22 23module Data.Monoid.Instances.Positioned ( 24 OffsetPositioned, LinePositioned, extract, position, line, column 25 ) 26where 27 28import Control.Applicative -- (Applicative(..)) 29import qualified Data.List as List 30import Data.String (IsString(..)) 31 32import Data.Semigroup (Semigroup(..)) 33import Data.Monoid (Monoid(..), Endo(..)) 34import Data.Semigroup.Cancellative (LeftReductive(..), RightReductive(..)) 35import Data.Semigroup.Factorial (Factorial(..), StableFactorial) 36import Data.Monoid.GCD (LeftGCDMonoid(..), RightGCDMonoid(..)) 37import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) 38import Data.Monoid.Factorial (FactorialMonoid(..)) 39import Data.Monoid.Textual (TextualMonoid(..)) 40import qualified Data.Semigroup.Factorial as Factorial 41import qualified Data.Monoid.Factorial as Factorial 42import qualified Data.Monoid.Textual as Textual 43 44import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, lines, map, concatMap, 45 length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) 46 47class Positioned p where 48 extract :: p a -> a 49 position :: p a -> Int 50 51data OffsetPositioned m = OffsetPositioned{offset :: !Int, 52 -- ^ the current offset 53 extractOffset :: m} 54 55data LinePositioned m = LinePositioned{fullOffset :: !Int, 56 -- | the current line 57 line :: !Int, 58 lineStart :: !Int, 59 extractLines :: m} 60 61-- | the current column 62column :: LinePositioned m -> Int 63column lp = position lp - lineStart lp 64 65instance Functor OffsetPositioned where 66 fmap f (OffsetPositioned p c) = OffsetPositioned p (f c) 67 68instance Functor LinePositioned where 69 fmap f (LinePositioned p l lp c) = LinePositioned p l lp (f c) 70 71instance Applicative OffsetPositioned where 72 pure = OffsetPositioned 0 73 OffsetPositioned _ f <*> OffsetPositioned p c = OffsetPositioned p (f c) 74 75instance Applicative LinePositioned where 76 pure = LinePositioned 0 0 (-1) 77 LinePositioned _ _ _ f <*> LinePositioned p l lp c = LinePositioned p l lp (f c) 78 79instance Positioned OffsetPositioned where 80 extract = extractOffset 81 position = offset 82 83instance Positioned LinePositioned where 84 extract = extractLines 85 position = fullOffset 86 87instance Eq m => Eq (OffsetPositioned m) where 88 OffsetPositioned{extractOffset= a} == OffsetPositioned{extractOffset= b} = a == b 89 90instance Eq m => Eq (LinePositioned m) where 91 LinePositioned{extractLines= a} == LinePositioned{extractLines= b} = a == b 92 93instance Ord m => Ord (OffsetPositioned m) where 94 compare OffsetPositioned{extractOffset= a} OffsetPositioned{extractOffset= b} = compare a b 95 96instance Ord m => Ord (LinePositioned m) where 97 compare LinePositioned{extractLines= a} LinePositioned{extractLines= b} = compare a b 98 99instance Show m => Show (OffsetPositioned m) where 100 showsPrec prec (OffsetPositioned 0 c) = showsPrec prec c 101 showsPrec prec (OffsetPositioned pos c) = shows pos . (": " ++) . showsPrec prec c 102 103instance Show m => Show (LinePositioned m) where 104 showsPrec prec (LinePositioned 0 0 (-1) c) = showsPrec prec c 105 showsPrec prec (LinePositioned pos l lpos c) = 106 ("Line " ++) . shows l . (", column " ++) . shows (pos - lpos) . (": " ++) . showsPrec prec c 107 108instance StableFactorial m => Semigroup (OffsetPositioned m) where 109 OffsetPositioned p1 c1 <> OffsetPositioned p2 c2 = 110 OffsetPositioned (if p1 /= 0 || p2 == 0 then p1 else max 0 $ p2 - length c1) (c1 <> c2) 111 {-# INLINE (<>) #-} 112 113instance (FactorialMonoid m, StableFactorial m) => Monoid (OffsetPositioned m) where 114 mempty = pure mempty 115 mappend = (<>) 116 {-# INLINE mempty #-} 117 {-# INLINE mappend #-} 118 119instance (StableFactorial m, TextualMonoid m) => Semigroup (LinePositioned m) where 120 LinePositioned p1 l1 lp1 c1 <> LinePositioned p2 l2 lp2 c2 121 | p1 /= 0 || p2 == 0 = LinePositioned p1 l1 lp1 c 122 | otherwise = LinePositioned p2' l2' lp2' c 123 where c = mappend c1 c2 124 p2' = max 0 $ p2 - length c1 125 lp2' = p2' - (p2 - lp2 - cd + 1) 126 l2' = if l2 == 0 then 0 else max 0 (l2 - ld) 127 (ld, cd) = linesColumns' c1 128 {-# INLINE (<>) #-} 129 130instance (StableFactorial m, TextualMonoid m) => Monoid (LinePositioned m) where 131 mempty = pure mempty 132 mappend = (<>) 133 {-# INLINE mempty #-} 134 135instance (StableFactorial m, FactorialMonoid m) => MonoidNull (OffsetPositioned m) where 136 null = null . extractOffset 137 {-# INLINE null #-} 138 139instance (StableFactorial m, TextualMonoid m, MonoidNull m) => MonoidNull (LinePositioned m) where 140 null = null . extractLines 141 {-# INLINE null #-} 142 143instance (StableFactorial m, FactorialMonoid m) => PositiveMonoid (OffsetPositioned m) 144 145instance (StableFactorial m, TextualMonoid m) => PositiveMonoid (LinePositioned m) 146 147instance (StableFactorial m, LeftReductive m) => LeftReductive (OffsetPositioned m) where 148 isPrefixOf (OffsetPositioned _ c1) (OffsetPositioned _ c2) = isPrefixOf c1 c2 149 stripPrefix (OffsetPositioned _ c1) (OffsetPositioned p c2) = fmap (OffsetPositioned (p + length c1)) (stripPrefix c1 c2) 150 {-# INLINE isPrefixOf #-} 151 {-# INLINE stripPrefix #-} 152 153instance (StableFactorial m, TextualMonoid m) => LeftReductive (LinePositioned m) where 154 isPrefixOf a b = isPrefixOf (extractLines a) (extractLines b) 155 stripPrefix LinePositioned{extractLines= c1} (LinePositioned p l lpos c2) = 156 let (lines, columns) = linesColumns' c1 157 len = length c1 158 in fmap (LinePositioned (p + len) (l + lines) (lpos + len - columns)) (stripPrefix c1 c2) 159 {-# INLINE isPrefixOf #-} 160 {-# INLINE stripPrefix #-} 161 162instance (StableFactorial m, FactorialMonoid m, LeftGCDMonoid m) => LeftGCDMonoid (OffsetPositioned m) where 163 commonPrefix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = OffsetPositioned (min p1 p2) (commonPrefix c1 c2) 164 stripCommonPrefix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = 165 (OffsetPositioned (min p1 p2) prefix, OffsetPositioned (p1 + l) c1', OffsetPositioned (p2 + l) c2') 166 where (prefix, c1', c2') = stripCommonPrefix c1 c2 167 l = length prefix 168 {-# INLINE commonPrefix #-} 169 {-# INLINE stripCommonPrefix #-} 170 171instance (StableFactorial m, TextualMonoid m, LeftGCDMonoid m) => LeftGCDMonoid (LinePositioned m) where 172 commonPrefix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) = 173 if p1 <= p2 174 then LinePositioned p1 l1 lp1 (commonPrefix c1 c2) 175 else LinePositioned p2 l2 lp2 (commonPrefix c1 c2) 176 stripCommonPrefix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) = 177 let (prefix, c1', c2') = stripCommonPrefix c1 c2 178 (lines, columns) = linesColumns' prefix 179 len = length prefix 180 in (if p1 <= p2 then LinePositioned p1 l1 lp1 prefix else LinePositioned p2 l2 lp2 prefix, 181 LinePositioned (p1 + len) (l1 + lines) (lp1 + len - columns) c1', 182 LinePositioned (p2 + len) (l2 + lines) (lp2 + len - columns) c2') 183 {-# INLINE commonPrefix #-} 184 {-# INLINE stripCommonPrefix #-} 185 186instance (StableFactorial m, FactorialMonoid m, RightReductive m) => RightReductive (OffsetPositioned m) where 187 isSuffixOf (OffsetPositioned _ c1) (OffsetPositioned _ c2) = isSuffixOf c1 c2 188 stripSuffix (OffsetPositioned _ c1) (OffsetPositioned p c2) = fmap (OffsetPositioned p) (stripSuffix c1 c2) 189 {-# INLINE isSuffixOf #-} 190 {-# INLINE stripSuffix #-} 191 192instance (StableFactorial m, TextualMonoid m, RightReductive m) => RightReductive (LinePositioned m) where 193 isSuffixOf LinePositioned{extractLines=c1} LinePositioned{extractLines=c2} = isSuffixOf c1 c2 194 stripSuffix (LinePositioned p l lp c1) LinePositioned{extractLines=c2} = 195 fmap (LinePositioned p l lp) (stripSuffix c1 c2) 196 {-# INLINE isSuffixOf #-} 197 {-# INLINE stripSuffix #-} 198 199instance (StableFactorial m, FactorialMonoid m, RightGCDMonoid m) => RightGCDMonoid (OffsetPositioned m) where 200 commonSuffix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = 201 OffsetPositioned (min (p1 + length c1) (p2 + length c2) - length suffix) suffix 202 where suffix = commonSuffix c1 c2 203 stripCommonSuffix (OffsetPositioned p1 c1) (OffsetPositioned p2 c2) = 204 (OffsetPositioned p1 c1', OffsetPositioned p2 c2', 205 OffsetPositioned (min (p1 + length c1') (p2 + length c2')) suffix) 206 where (c1', c2', suffix) = stripCommonSuffix c1 c2 207 {-# INLINE commonSuffix #-} 208 {-# INLINE stripCommonSuffix #-} 209 210instance (StableFactorial m, TextualMonoid m, RightGCDMonoid m) => RightGCDMonoid (LinePositioned m) where 211 stripCommonSuffix (LinePositioned p1 l1 lp1 c1) (LinePositioned p2 l2 lp2 c2) = 212 (LinePositioned p1 l1 lp1 c1', LinePositioned p2 l2 lp2 c2', 213 if p1 < p2 214 then LinePositioned (p1 + len1) (l1 + lines1) (lp1 + len1 - columns1) suffix 215 else LinePositioned (p2 + len2) (l2 + lines2) (lp2 + len2 - columns2) suffix) 216 where (c1', c2', suffix) = stripCommonSuffix c1 c2 217 len1 = length c1' 218 len2 = length c2' 219 (lines1, columns1) = linesColumns' c1' 220 (lines2, columns2) = linesColumns' c2' 221 222instance StableFactorial m => Factorial (OffsetPositioned m) where 223 factors (OffsetPositioned p c) = snd $ List.mapAccumL next p (factors c) 224 where next p1 c1 = (succ p1, OffsetPositioned p1 c1) 225 primePrefix (OffsetPositioned p c) = OffsetPositioned p (primePrefix c) 226 foldl f a0 (OffsetPositioned p0 c0) = fst $ Factorial.foldl f' (a0, p0) c0 227 where f' (a, p) c = (f a (OffsetPositioned p c), succ p) 228 foldl' f a0 (OffsetPositioned p0 c0) = fst $ Factorial.foldl' f' (a0, p0) c0 229 where f' (a, p) c = let a' = f a (OffsetPositioned p c) in seq a' (a', succ p) 230 foldr f a0 (OffsetPositioned p0 c0) = Factorial.foldr f' (const a0) c0 p0 231 where f' c cont p = f (OffsetPositioned p c) (cont $! succ p) 232 foldMap f (OffsetPositioned p c) = appEndo (Factorial.foldMap f' c) (const mempty) p 233 where -- f' :: m -> Endo (Int -> m) 234 f' prime = Endo (\cont pos-> f (OffsetPositioned pos prime) `mappend` cont (succ pos)) 235 length (OffsetPositioned _ c) = length c 236 reverse (OffsetPositioned p c) = OffsetPositioned p (Factorial.reverse c) 237 {-# INLINE primePrefix #-} 238 {-# INLINE foldl #-} 239 {-# INLINE foldl' #-} 240 {-# INLINE foldr #-} 241 {-# INLINE foldMap #-} 242 243instance (StableFactorial m, FactorialMonoid m) => FactorialMonoid (OffsetPositioned m) where 244 splitPrimePrefix (OffsetPositioned p c) = fmap rewrap (splitPrimePrefix c) 245 where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (if null cs then 0 else succ p) cs) 246 splitPrimeSuffix (OffsetPositioned p c) = fmap rewrap (splitPrimeSuffix c) 247 where rewrap (cp, cs) = (OffsetPositioned p cp, OffsetPositioned (p + length cp) cs) 248 spanMaybe s0 f (OffsetPositioned p0 t) = rewrap $ Factorial.spanMaybe (s0, p0) f' t 249 where f' (s, p) prime = do s' <- f s (OffsetPositioned p prime) 250 let p' = succ p 251 Just $! seq p' (s', p') 252 rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) 253 spanMaybe' s0 f (OffsetPositioned p0 t) = rewrap $! Factorial.spanMaybe' (s0, p0) f' t 254 where f' (s, p) prime = do s' <- f s (OffsetPositioned p prime) 255 let p' = succ p 256 Just $! s' `seq` p' `seq` (s', p') 257 rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) 258 span f (OffsetPositioned p0 t) = rewrap $ Factorial.spanMaybe' p0 f' t 259 where f' p prime = if f (OffsetPositioned p prime) 260 then Just $! succ p 261 else Nothing 262 rewrap (prefix, suffix, p) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix) 263 splitAt n m@(OffsetPositioned p c) | n <= 0 = (mempty, m) 264 | n >= length c = (m, mempty) 265 | otherwise = (OffsetPositioned p prefix, OffsetPositioned (p + n) suffix) 266 where (prefix, suffix) = splitAt n c 267 drop n (OffsetPositioned p c) = OffsetPositioned (p + n) (Factorial.drop n c) 268 take n (OffsetPositioned p c) = OffsetPositioned p (Factorial.take n c) 269 {-# INLINE splitPrimePrefix #-} 270 {-# INLINE splitPrimeSuffix #-} 271 {-# INLINE span #-} 272 {-# INLINE splitAt #-} 273 {-# INLINE take #-} 274 {-# INLINE drop #-} 275 276instance (StableFactorial m, TextualMonoid m) => Factorial (LinePositioned m) where 277 factors (LinePositioned p0 l0 lp0 c) = snd $ List.mapAccumL next (p0, l0, lp0) (factors c) 278 where next (p, l, lp) c1 = let p' = succ p 279 in p' `seq` case characterPrefix c1 280 of Just '\n' -> ((p', succ l, p), LinePositioned p l lp c1) 281 Just '\f' -> ((p', succ l, p), LinePositioned p l lp c1) 282 Just '\r' -> ((p', l, p), LinePositioned p l lp c1) 283 Just '\t' -> ((p', l, lp + (p - lp) `mod` 8 - 8), LinePositioned p l lp c1) 284 _ -> ((p', l, lp), LinePositioned p l lp c1) 285 primePrefix (LinePositioned p l lp c) = LinePositioned p l lp (primePrefix c) 286 foldl f a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $! Factorial.foldl f' (a0, p0, l0, lp0) c0 287 where f' (a, p, l, lp) c = case characterPrefix c 288 of Just '\n' -> (f a (LinePositioned p l lp c), succ p, succ l, p) 289 Just '\f' -> (f a (LinePositioned p l lp c), succ p, succ l, p) 290 Just '\r' -> (f a (LinePositioned p l lp c), succ p, l, p) 291 Just '\t' -> (f a (LinePositioned p l lp c), succ p, l, lp + (p - lp) `mod` 8 - 8) 292 _ -> (f a (LinePositioned p l lp c), succ p, l, lp) 293 foldl' f a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $! Factorial.foldl' f' (a0, p0, l0, lp0) c0 294 where f' (a, p, l, lp) c = let a' = f a (LinePositioned p l lp c) 295 in seq a' (case characterPrefix c 296 of Just '\n' -> (a', succ p, succ l, p) 297 Just '\f' -> (a', succ p, succ l, p) 298 Just '\r' -> (a', succ p, l, p) 299 Just '\t' -> (a', succ p, l, lp + (p - lp) `mod` 8 - 8) 300 _ -> (a', succ p, l, lp)) 301 foldr f a0 (LinePositioned p0 l0 lp0 c0) = Factorial.foldr f' (const3 a0) c0 p0 l0 lp0 302 where f' c cont p l lp = case characterPrefix c 303 of Just '\n' -> f (LinePositioned p l lp c) $ ((cont $! succ p) $! succ l) p 304 Just '\f' -> f (LinePositioned p l lp c) $ ((cont $! succ p) $! succ l) p 305 Just '\r' -> f (LinePositioned p l lp c) $ (cont $! succ p) l p 306 Just '\t' -> f (LinePositioned p l lp c) $ (cont $! succ p) l $! lp + (p - lp) `mod` 8 - 8 307 _ -> f (LinePositioned p l lp c) $ (cont $! succ p) l lp 308 foldMap f (LinePositioned p0 l0 lp0 c) = appEndo (Factorial.foldMap f' c) (const mempty) p0 l0 lp0 309 where -- f' :: m -> Endo (Int -> Int -> Int -> m) 310 f' prime = Endo (\cont p l lp-> f (LinePositioned p l lp prime) 311 `mappend` 312 case characterPrefix prime 313 of Just '\n' -> cont (succ p) (succ l) p 314 Just '\f' -> cont (succ p) (succ l) p 315 Just '\r' -> cont (succ p) l p 316 Just '\t' -> cont (succ p) l (lp + (p - lp) `mod` 8 - 8) 317 _ -> cont (succ p) l lp) 318 length = length . extractLines 319 reverse (LinePositioned p l lp c) = LinePositioned p l lp (Factorial.reverse c) 320 {-# INLINE primePrefix #-} 321 {-# INLINE foldl #-} 322 {-# INLINE foldl' #-} 323 {-# INLINE foldr #-} 324 {-# INLINE foldMap #-} 325 {-# INLINE length #-} 326 {-# INLINE reverse #-} 327 328instance (StableFactorial m, TextualMonoid m) => FactorialMonoid (LinePositioned m) where 329 splitPrimePrefix (LinePositioned p l lp c) = fmap rewrap (splitPrimePrefix c) 330 where rewrap (cp, cs) = (LinePositioned p l lp cp, 331 if null cs then mempty 332 else case characterPrefix cp 333 of Just '\n' -> LinePositioned p' (succ l) p cs 334 Just '\f' -> LinePositioned p' (succ l) p cs 335 Just '\r' -> LinePositioned p' l p cs 336 Just '\t' -> LinePositioned p' l (lp + (p - lp) `mod` 8 - 8) cs 337 _ -> LinePositioned p' l lp cs) 338 p' = succ p 339 splitPrimeSuffix (LinePositioned p l lp c) = fmap rewrap (splitPrimeSuffix c) 340 where rewrap (cp, cs) = (LinePositioned p l lp cp, LinePositioned p' (l + lines) (p' - columns) cs) 341 where len = length cp 342 (lines, columns) = linesColumns cp 343 p' = p + len 344 spanMaybe s0 f (LinePositioned p0 l0 lp0 c) = rewrap $ Factorial.spanMaybe (s0, p0, l0, lp0) f' c 345 where f' (s, p, l, lp) prime = do s' <- f s (LinePositioned p l lp prime) 346 let p' = succ p 347 l' = succ l 348 Just $! p' `seq` case characterPrefix prime 349 of Just '\n' -> l' `seq` (s', p', l', p) 350 Just '\f' -> l' `seq` (s', p', l', p) 351 Just '\r' -> (s', p', l, p) 352 Just '\t' -> (s', p', l, lp + (p - lp) `mod` 8 - 8) 353 _ -> (s', p', l, lp) 354 rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s) 355 spanMaybe' s0 f (LinePositioned p0 l0 lp0 c) = rewrap $! Factorial.spanMaybe' (s0, p0, l0, lp0) f' c 356 where f' (s, p, l, lp) prime = do s' <- f s (LinePositioned p l lp prime) 357 let p' = succ p 358 l' = succ l 359 Just $! s' `seq` p' `seq` case characterPrefix prime 360 of Just '\n' -> l' `seq` (s', p', l', p) 361 Just '\f' -> l' `seq` (s', p', l', p) 362 Just '\r' -> (s', p', l, p) 363 Just '\t' -> (s', p', l, lp + (p - lp) `mod` 8 - 8) 364 _ -> (s', p', l, lp) 365 rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s) 366 367 span f (LinePositioned p0 l0 lp0 t) = rewrap $ Factorial.spanMaybe' (p0, l0, lp0) f' t 368 where f' (p, l, lp) prime = if f (LinePositioned p l lp prime) 369 then let p' = succ p 370 l' = succ l 371 in Just $! p' `seq` case characterPrefix prime 372 of Just '\n' -> l' `seq` (p', l', p) 373 Just '\f' -> l' `seq` (p', l', p) 374 Just '\r' -> (p', l, p) 375 Just '\t' -> (p', l, lp + (p - lp) `mod` 8 - 8) 376 _ -> (p', l, lp) 377 else Nothing 378 rewrap (prefix, suffix, (p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix) 379 splitAt n m@(LinePositioned p l lp c) | n <= 0 = (mempty, m) 380 | n >= length c = (m, mempty) 381 | otherwise = (LinePositioned p l lp prefix, 382 LinePositioned p' (l + lines) (p' - columns) suffix) 383 where (prefix, suffix) = splitAt n c 384 (lines, columns) = linesColumns prefix 385 p' = p + n 386 take n (LinePositioned p l lp c) = LinePositioned p l lp (Factorial.take n c) 387 {-# INLINE splitPrimePrefix #-} 388 {-# INLINE splitPrimeSuffix #-} 389 {-# INLINE span #-} 390 {-# INLINE splitAt #-} 391 {-# INLINE take #-} 392 393instance StableFactorial m => StableFactorial (OffsetPositioned m) 394 395instance (StableFactorial m, TextualMonoid m) => StableFactorial (LinePositioned m) 396 397instance IsString m => IsString (OffsetPositioned m) where 398 fromString = pure . fromString 399 400instance IsString m => IsString (LinePositioned m) where 401 fromString = pure . fromString 402 403instance (StableFactorial m, TextualMonoid m) => TextualMonoid (OffsetPositioned m) where 404 splitCharacterPrefix (OffsetPositioned p t) = fmap rewrap (splitCharacterPrefix t) 405 where rewrap (c, cs) = if null cs then (c, mempty) else (c, OffsetPositioned (succ p) cs) 406 407 fromText = pure . fromText 408 singleton = pure . singleton 409 410 characterPrefix = characterPrefix . extractOffset 411 412 map f (OffsetPositioned p c) = OffsetPositioned p (map f c) 413 concatMap f (OffsetPositioned p c) = OffsetPositioned p (concatMap (extractOffset . f) c) 414 all p = all p . extractOffset 415 any p = any p . extractOffset 416 417 foldl ft fc a0 (OffsetPositioned p0 c0) = fst $ Textual.foldl ft' fc' (a0, p0) c0 418 where ft' (a, p) c = (ft a (OffsetPositioned p c), succ p) 419 fc' (a, p) c = (fc a c, succ p) 420 foldl' ft fc a0 (OffsetPositioned p0 c0) = fst $ Textual.foldl' ft' fc' (a0, p0) c0 421 where ft' (a, p) c = ((,) $! ft a (OffsetPositioned p c)) $! succ p 422 fc' (a, p) c = ((,) $! fc a c) $! succ p 423 foldr ft fc a0 (OffsetPositioned p0 c0) = snd $ Textual.foldr ft' fc' (p0, a0) c0 424 where ft' c (p, a) = (succ p, ft (OffsetPositioned p c) a) 425 fc' c (p, a) = (succ p, fc c a) 426 427 scanl f ch (OffsetPositioned p c) = OffsetPositioned p (Textual.scanl f ch c) 428 scanl1 f (OffsetPositioned p c) = OffsetPositioned p (Textual.scanl1 f c) 429 scanr f ch (OffsetPositioned p c) = OffsetPositioned p (Textual.scanr f ch c) 430 scanr1 f (OffsetPositioned p c) = OffsetPositioned p (Textual.scanr1 f c) 431 mapAccumL f a0 (OffsetPositioned p c) = fmap (OffsetPositioned p) (Textual.mapAccumL f a0 c) 432 mapAccumR f a0 (OffsetPositioned p c) = fmap (OffsetPositioned p) (Textual.mapAccumR f a0 c) 433 434 spanMaybe s0 ft fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe (s0, p0) ft' fc' t 435 where ft' (s, p) prime = do s' <- ft s (OffsetPositioned p prime) 436 let p' = succ p 437 Just $! seq p' (s', p') 438 fc' (s, p) c = do s' <- fc s c 439 let p' = succ p 440 Just $! seq p' (s', p') 441 rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) 442 spanMaybe' s0 ft fc (OffsetPositioned p0 t) = rewrap $! Textual.spanMaybe' (s0, p0) ft' fc' t 443 where ft' (s, p) prime = do s' <- ft s (OffsetPositioned p prime) 444 let p' = succ p 445 Just $! s' `seq` p' `seq` (s', p') 446 fc' (s, p) c = do s' <- fc s c 447 let p' = succ p 448 Just $! s' `seq` p' `seq` (s', p') 449 rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) 450 span ft fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe' p0 ft' fc' t 451 where ft' p prime = if ft (OffsetPositioned p prime) 452 then Just $! succ p 453 else Nothing 454 fc' p c = if fc c 455 then Just $! succ p 456 else Nothing 457 rewrap (prefix, suffix, p) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix) 458 459 split f (OffsetPositioned p0 c0) = rewrap p0 (Textual.split f c0) 460 where rewrap _ [] = [] 461 rewrap p (c:rest) = OffsetPositioned p c : rewrap (p + length c) rest 462 find p = find p . extractOffset 463 464 foldl_ fc a0 (OffsetPositioned _ c) = Textual.foldl_ fc a0 c 465 foldl_' fc a0 (OffsetPositioned _ c) = Textual.foldl_' fc a0 c 466 foldr_ fc a0 (OffsetPositioned _ c) = Textual.foldr_ fc a0 c 467 468 spanMaybe_ s0 fc (OffsetPositioned p0 t) = rewrap $ Textual.spanMaybe_' (s0, p0) fc' t 469 where fc' (s, p) c = do s' <- fc s c 470 let p' = succ p 471 Just $! seq p' (s', p') 472 rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) 473 spanMaybe_' s0 fc (OffsetPositioned p0 t) = rewrap $! Textual.spanMaybe_' (s0, p0) fc' t 474 where fc' (s, p) c = do s' <- fc s c 475 let p' = succ p 476 Just $! s' `seq` p' `seq` (s', p') 477 rewrap (prefix, suffix, (s, p)) = (OffsetPositioned p0 prefix, OffsetPositioned p suffix, s) 478 span_ bt fc (OffsetPositioned p0 t) = rewrap $ Textual.span_ bt fc t 479 where rewrap (prefix, suffix) = (OffsetPositioned p0 prefix, OffsetPositioned (p0 + length prefix) suffix) 480 break_ bt fc (OffsetPositioned p0 t) = rewrap $ Textual.break_ bt fc t 481 where rewrap (prefix, suffix) = (OffsetPositioned p0 prefix, OffsetPositioned (p0 + length prefix) suffix) 482 dropWhile_ bt fc t = snd (span_ bt fc t) 483 takeWhile_ bt fc (OffsetPositioned p t) = OffsetPositioned p (takeWhile_ bt fc t) 484 toString ft (OffsetPositioned _ t) = toString (ft . pure) t 485 toText ft (OffsetPositioned _ t) = toText (ft . pure) t 486 487 {-# INLINE characterPrefix #-} 488 {-# INLINE splitCharacterPrefix #-} 489 {-# INLINE map #-} 490 {-# INLINE concatMap #-} 491 {-# INLINE foldl' #-} 492 {-# INLINE foldr #-} 493 {-# INLINE spanMaybe' #-} 494 {-# INLINE span #-} 495 {-# INLINE foldl_' #-} 496 {-# INLINE foldr_ #-} 497 {-# INLINE any #-} 498 {-# INLINE all #-} 499 {-# INLINE spanMaybe_' #-} 500 {-# INLINE span_ #-} 501 {-# INLINE break_ #-} 502 {-# INLINE dropWhile_ #-} 503 {-# INLINE takeWhile_ #-} 504 {-# INLINE split #-} 505 {-# INLINE find #-} 506 507instance (StableFactorial m, TextualMonoid m) => TextualMonoid (LinePositioned m) where 508 splitCharacterPrefix (LinePositioned p l lp t) = 509 case splitCharacterPrefix t 510 of Nothing -> Nothing 511 Just (c, rest) | null rest -> Just (c, mempty) 512 Just ('\n', rest) -> Just ('\n', LinePositioned p' (succ l) p rest) 513 Just ('\f', rest) -> Just ('\f', LinePositioned p' (succ l) p rest) 514 Just ('\r', rest) -> Just ('\r', LinePositioned p' l p rest) 515 Just ('\t', rest) -> Just ('\t', LinePositioned p' l (lp + (p - lp) `mod` 8 - 8) rest) 516 Just (ch, rest) -> Just (ch, LinePositioned p' l lp rest) 517 where p' = succ p 518 519 fromText = pure . fromText 520 singleton = pure . singleton 521 522 characterPrefix = characterPrefix . extractLines 523 524 map f (LinePositioned p l lp c) = LinePositioned p l lp (map f c) 525 concatMap f (LinePositioned p l lp c) = LinePositioned p l lp (concatMap (extractLines . f) c) 526 all p = all p . extractLines 527 any p = any p . extractLines 528 529 foldl ft fc a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $ Textual.foldl ft' fc' (a0, p0, l0, lp0) c0 530 where ft' (a, p, l, lp) c = (ft a (LinePositioned p l lp c), succ p, l, lp) 531 fc' (a, p, l, _lp) '\n' = (fc a '\n', succ p, succ l, p) 532 fc' (a, p, l, _lp) '\f' = (fc a '\f', succ p, succ l, p) 533 fc' (a, p, l, _lp) '\r' = (fc a '\r', succ p, l, p) 534 fc' (a, p, l, lp) '\t' = (fc a '\t', succ p, l, lp + (p - lp) `mod` 8 - 8) 535 fc' (a, p, l, lp) c = (fc a c, succ p, l, lp) 536 foldl' ft fc a0 (LinePositioned p0 l0 lp0 c0) = fstOf4 $ Textual.foldl' ft' fc' (a0, p0, l0, lp0) c0 537 where ft' (a, p, l, lp) c = let a' = ft a (LinePositioned p l lp c) 538 p' = succ p 539 in a' `seq` p' `seq` (a', p', l, lp) 540 fc' (a, p, l, lp) c = let a' = fc a c 541 p' = succ p 542 l' = succ l 543 in a' `seq` p' `seq` case c 544 of '\n' -> l' `seq` (a', p', l', p) 545 '\f' -> l' `seq` (a', p', l', p) 546 '\r' -> (a', p', l, p) 547 '\t' -> (a', p', l, lp + (p - lp) `mod` 8 - 8) 548 _ -> (a', p', l, lp) 549 foldr ft fc a0 (LinePositioned p0 l0 lp0 c0) = Textual.foldr ft' fc' (const3 a0) c0 p0 l0 lp0 550 where ft' c cont p l lp = ft (LinePositioned p l lp c) $ (cont $! succ p) l lp 551 fc' c cont p l lp 552 | c == '\n' = fc c $ ((cont $! succ p) $! succ l) p 553 | c == '\f' = fc c $ ((cont $! succ p) $! succ l) p 554 | c == '\r' = fc c $ (cont $! succ p) l p 555 | c == '\t' = fc c $ (cont $! succ p) l (lp + (p - lp) `mod` 8 - 8) 556 | otherwise = fc c $ (cont $! succ p) l lp 557 558 spanMaybe s0 ft fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe (s0, p0, l0, lp0) ft' fc' t 559 where ft' (s, p, l, lp) prime = do s' <- ft s (LinePositioned p l lp prime) 560 let p' = succ p 561 Just $! seq p' (s', p', l, lp) 562 fc' (s, p, l, lp) c = fc s c 563 >>= \s'-> Just $! seq p' (if c == '\n' || c == '\f' then seq l' (s', p', l', p) 564 else if c == '\r' then (s', p', l, p) 565 else if c == '\t' then (s', p', l, lp + (p - lp) `mod` 8 - 8) 566 else (s', p', l, lp)) 567 where p' = succ p 568 l' = succ l 569 rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s) 570 spanMaybe' s0 ft fc (LinePositioned p0 l0 lp0 t) = rewrap $! Textual.spanMaybe' (s0, p0, l0, lp0) ft' fc' t 571 where ft' (s, p, l, lp) prime = do s' <- ft s (LinePositioned p l lp prime) 572 let p' = succ p 573 Just $! s' `seq` p' `seq` (s', p', l, lp) 574 fc' (s, p, l, lp) c = do s' <- fc s c 575 let p' = succ p 576 l' = succ l 577 Just $! s' `seq` p' `seq` (if c == '\n' || c == '\f' then seq l' (s', p', l', p) 578 else if c == '\r' then (s', p', l, p) 579 else if c == '\t' then (s', p', l, lp + (p - lp) `mod` 8 - 8) 580 else (s', p', l, lp)) 581 rewrap (prefix, suffix, (s, p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix, s) 582 span ft fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe' (p0, l0, lp0) ft' fc' t 583 where ft' (p, l, lp) prime = if ft (LinePositioned p l lp prime) 584 then let p' = succ p 585 in p' `seq` Just (p', l, lp) 586 else Nothing 587 fc' (p, l, lp) c | fc c = Just $! seq p' 588 $ if c == '\n' || c == '\f' then seq l' (p', l', p) 589 else if c == '\r' then (p', l, p) 590 else if c == '\t' then (p', l, lp + (p - lp) `mod` 8 - 8) 591 else (p', l, lp) 592 | otherwise = Nothing 593 where p' = succ p 594 l' = succ l 595 rewrap (prefix, suffix, (p, l, lp)) = (LinePositioned p0 l0 lp0 prefix, LinePositioned p l lp suffix) 596 597 scanl f ch (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanl f ch c) 598 scanl1 f (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanl1 f c) 599 scanr f ch (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanr f ch c) 600 scanr1 f (LinePositioned p l lp c) = LinePositioned p l lp (Textual.scanr1 f c) 601 mapAccumL f a0 (LinePositioned p l lp c) = fmap (LinePositioned p l lp) (Textual.mapAccumL f a0 c) 602 mapAccumR f a0 (LinePositioned p l lp c) = fmap (LinePositioned p l lp) (Textual.mapAccumR f a0 c) 603 604 split f (LinePositioned p0 l0 lp0 c0) = rewrap p0 l0 lp0 (Textual.split f c0) 605 where rewrap _ _ _ [] = [] 606 rewrap p l lp (c:rest) = LinePositioned p l lp c 607 : rewrap p' (l + lines) (if lines == 0 then lp else p' - columns) rest 608 where p' = p + length c 609 (lines, columns) = linesColumns c 610 find p = find p . extractLines 611 612 foldl_ fc a0 (LinePositioned _ _ _ t) = Textual.foldl_ fc a0 t 613 foldl_' fc a0 (LinePositioned _ _ _ t) = Textual.foldl_' fc a0 t 614 foldr_ fc a0 (LinePositioned _ _ _ t) = Textual.foldr_ fc a0 t 615 616 spanMaybe_ s0 fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe_ s0 fc t 617 where rewrap (prefix, suffix, s) = (LinePositioned p0 l0 lp0 prefix, 618 LinePositioned p1 (l0 + l) (if l == 0 then lp0 else p1 - col) suffix, 619 s) 620 where (l, col) = linesColumns prefix 621 p1 = p0 + length prefix 622 spanMaybe_' s0 fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.spanMaybe_' s0 fc t 623 where rewrap (prefix, suffix, s) = p1 `seq` l1 `seq` lp1 `seq` 624 (LinePositioned p0 l0 lp0 prefix, LinePositioned p1 l1 lp1 suffix, s) 625 where (l, col) = linesColumns' prefix 626 p1 = p0 + length prefix 627 l1 = l0 + l 628 lp1 = if l == 0 then lp0 else p1 - col 629 span_ bt fc (LinePositioned p0 l0 lp0 t) = rewrap $ Textual.span_ bt fc t 630 where rewrap (prefix, suffix) = (LinePositioned p0 l0 lp0 prefix, 631 LinePositioned p1 (l0 + l) (if l == 0 then lp0 else p1 - col) suffix) 632 where (l, col) = linesColumns' prefix 633 p1 = p0 + length prefix 634 break_ bt fc t = span_ (not bt) (not . fc) t 635 dropWhile_ bt fc t = snd (span_ bt fc t) 636 takeWhile_ bt fc (LinePositioned p l lp t) = LinePositioned p l lp (takeWhile_ bt fc t) 637 toString ft lpt = toString (ft . pure) (extractLines lpt) 638 toText ft lpt = toText (ft . pure) (extractLines lpt) 639 640 {-# INLINE characterPrefix #-} 641 {-# INLINE splitCharacterPrefix #-} 642 {-# INLINE map #-} 643 {-# INLINE concatMap #-} 644 {-# INLINE foldl' #-} 645 {-# INLINE foldr #-} 646 {-# INLINE spanMaybe' #-} 647 {-# INLINE span #-} 648 {-# INLINE split #-} 649 {-# INLINE find #-} 650 {-# INLINE foldl_' #-} 651 {-# INLINE foldr_ #-} 652 {-# INLINE any #-} 653 {-# INLINE all #-} 654 {-# INLINE spanMaybe_' #-} 655 {-# INLINE span_ #-} 656 {-# INLINE break_ #-} 657 {-# INLINE dropWhile_ #-} 658 {-# INLINE takeWhile_ #-} 659 660linesColumns :: TextualMonoid m => m -> (Int, Int) 661linesColumns t = Textual.foldl (const . fmap succ) fc (0, 1) t 662 where fc (l, _) '\n' = (succ l, 1) 663 fc (l, _) '\f' = (succ l, 1) 664 fc (l, _) '\r' = (l, 1) 665 fc (l, c) '\t' = (l, c + 9 - c `mod` 8) 666 fc (l, c) _ = (l, succ c) 667linesColumns' :: TextualMonoid m => m -> (Int, Int) 668linesColumns' t = Textual.foldl' (const . fmap succ) fc (0, 1) t 669 where fc (l, _) '\n' = let l' = succ l in seq l' (l', 1) 670 fc (l, _) '\f' = let l' = succ l in seq l' (l', 1) 671 fc (l, _) '\r' = (l, 1) 672 fc (l, c) '\t' = (l, c + 9 - c `mod` 8) 673 fc (l, c) _ = let c' = succ c in seq c' (l, c') 674{-# INLINE linesColumns #-} 675{-# INLINE linesColumns' #-} 676 677const3 :: a -> b -> c -> d -> a 678const3 a _p _l _lp = a 679{-# INLINE const3 #-} 680 681fstOf4 :: (a, b, c, d) -> a 682fstOf4 (a, _, _, _) = a 683{-# INLINE fstOf4 #-} 684