{-# LANGUAGE OverloadedStrings #-}

-- | A parser's position in the input.

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)

-- | A class for representing position values. The methods satisfy these laws:
--
-- > move (distance pos1 pos2) pos1 == pos2
-- > (pos1 < pos2) == (distance pos1 pos2 > 0)
class Ord p => Position p where
   -- | Distance from the first position to the second
   distance :: p -> p -> Int
   -- | Move the position by the given distance.
   move :: Int -> p -> p
   -- | Map the position into its offset from the beginning of the full input.
   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

-- | Construct a 'Position' given the offset from the beginning of the full input.
fromStart :: Int -> Int
fromStart :: Int -> Int
fromStart = Int -> Int
forall a. a -> a
id

-- | Construct a 'Position' given the length remaining from the position to the end of the input.
fromEnd :: Int -> Down Int
fromEnd :: Int -> Down Int
fromEnd = Int -> Down Int
forall a. a -> Down a
Down

-- | Given the parser input, a 'Position' within it, and desired number of context lines, returns a description of
-- the offset position in English.
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)

-- | Given the full input and an offset within it, returns all the input lines up to and including the offset
-- in reverse order, as well as the zero-based column number of the offset
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