{-# LANGUAGE OverloadedStrings #-}
module Text.Parser.Input.Position (Position(..), fromStart, fromEnd, context, lineAndColumn) where
import Data.Char (isSpace)
import Data.String (IsString(fromString))
import Data.Monoid ((<>))
import Data.Ord (Down(Down))
import qualified Data.Monoid.Factorial as Factorial
import qualified Data.Monoid.Textual as Textual
import Data.Monoid.Factorial (FactorialMonoid)
import Data.Monoid.Textual (TextualMonoid)
class Ord p => Position p where
distance :: p -> p -> Int
move :: Int -> p -> p
offset :: FactorialMonoid s => s -> p -> Int
instance Position Int where
distance :: Int -> Int -> Int
distance = (Int -> Int -> Int) -> Int -> Int -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip (-)
move :: Int -> Int -> Int
move = Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
offset :: s -> Int -> Int
offset = (Int -> Int) -> s -> Int -> Int
forall a b. a -> b -> a
const Int -> Int
forall a. a -> a
id
instance Position a => Position (Down a) where
distance :: Down a -> Down a -> Int
distance (Down a
p1) (Down a
p2) = a -> a -> Int
forall p. Position p => p -> p -> Int
distance a
p2 a
p1
move :: Int -> Down a -> Down a
move Int
distance (Down a
p) = a -> Down a
forall a. a -> Down a
Down (Int -> a -> a
forall p. Position p => Int -> p -> p
move (Int -> Int
forall a. Num a => a -> a
negate Int
distance) a
p)
offset :: s -> Down a -> Int
offset s
wholeInput (Down a
p) = s -> Int
forall m. Factorial m => m -> Int
Factorial.length s
wholeInput Int -> Int -> Int
forall a. Num a => a -> a -> a
- s -> a -> Int
forall p s. (Position p, FactorialMonoid s) => s -> p -> Int
offset s
wholeInput a
p
fromStart :: Int -> Int
fromStart :: Int -> Int
fromStart = Int -> Int
forall a. a -> a
id
fromEnd :: Int -> Down Int
fromEnd :: Int -> Down Int
fromEnd = Int -> Down Int
forall a. a -> Down a
Down
context :: (Eq s, TextualMonoid s, Position p) => s -> p -> Int -> s
context :: s -> p -> Int -> s
context s
input p
pos Int
contextLineCount =
(s -> s) -> [s] -> s
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"\n") [s]
prevLines s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
lastLinePadding
s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"at line " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> String -> s
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [s] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [s]
allPrevLines) s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
", column " s -> s -> s
forall a. Semigroup a => a -> a -> a
<> String -> s
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Int
columnInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"\n"
where ([s]
allPrevLines, Int
column) = s -> p -> ([s], Int)
forall s p.
(Eq s, IsString s, FactorialMonoid s, Position p) =>
s -> p -> ([s], Int)
lineAndColumn s
input p
pos
lastLinePadding :: s
lastLinePadding
| (s
lastLine:[s]
_) <- [s]
allPrevLines, s
paddingPrefix <- Bool -> (Char -> Bool) -> s -> s
forall t. TextualMonoid t => Bool -> (Char -> Bool) -> t -> t
Textual.takeWhile_ Bool
False Char -> Bool
isSpace s
lastLine =
Int -> s -> s
forall m. FactorialMonoid m => Int -> m -> m
Factorial.take Int
column (s
paddingPrefix s -> s -> s
forall a. Semigroup a => a -> a -> a
<> String -> s
forall a. IsString a => String -> a
fromString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
column Char
' ')) s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"^\n"
| Bool
otherwise = s
""
prevLines :: [s]
prevLines = [s] -> [s]
forall a. [a] -> [a]
reverse (Int -> [s] -> [s]
forall a. Int -> [a] -> [a]
take Int
contextLineCount [s]
allPrevLines)
lineAndColumn :: (Eq s, IsString s, FactorialMonoid s, Position p) => s -> p -> ([s], Int)
lineAndColumn :: s -> p -> ([s], Int)
lineAndColumn s
input p
pos = [s] -> Int -> [s] -> ([s], Int)
forall a.
(IsString a, Factorial a) =>
[a] -> Int -> [a] -> ([a], Int)
context [] (s -> p -> Int
forall p s. (Position p, FactorialMonoid s) => s -> p -> Int
offset s
input p
pos) ((s -> Bool) -> s -> [s]
forall m. FactorialMonoid m => (m -> Bool) -> m -> [m]
Factorial.split (s -> s -> Bool
forall a. Eq a => a -> a -> Bool
== s
"\n") s
input)
where context :: [a] -> Int -> [a] -> ([a], Int)
context [a]
revLines Int
restCount []
| Int
restCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = ([a
"Error: the offset is beyond the input length"], -Int
1)
| Bool
otherwise = ([a]
revLines, Int
restCount)
context [a]
revLines Int
restCount (a
next:[a]
rest)
| Int
restCount' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = (a
nexta -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
revLines, Int
restCount)
| Bool
otherwise = [a] -> Int -> [a] -> ([a], Int)
context (a
nexta -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
revLines) Int
restCount' [a]
rest
where nextLength :: Int
nextLength = a -> Int
forall m. Factorial m => m -> Int
Factorial.length a
next
restCount' :: Int
restCount' = Int
restCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nextLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1