{- |
Module      : Prosidy.Source.LineMap
Description : Binary-search tree for finding the position of new lines.
Copyright   : (c) James Alexander Feldman-Crough, 2019
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Trustworthy #-}
module Prosidy.Source.LineMap
    ( LineMap
    , lineOffsets
    , lineToOffset
    , offsetToLine
    , fromOffsets
    )
where

import qualified Data.Vector.Unboxed           as V
import qualified Data.Vector.Generic           as VG
import qualified Data.Vector.Generic.Mutable   as VGM
import           Data.Vector.Unboxed            ( Vector
                                                , MVector
                                                , Unbox
                                                )

import           Data.Foldable
import           Data.List                      ( sort )

import           Prosidy.Internal.Classes
import           Prosidy.Source.Units

-- | A dense vector containing offsets poiting to the start of each line. That
-- is, the starting position of the third line of a file can be found at
-- position 2.
newtype LineMap = LineMap (Vector Offset)
  deriving stock (LineMap -> LineMap -> Bool
(LineMap -> LineMap -> Bool)
-> (LineMap -> LineMap -> Bool) -> Eq LineMap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LineMap -> LineMap -> Bool
$c/= :: LineMap -> LineMap -> Bool
== :: LineMap -> LineMap -> Bool
$c== :: LineMap -> LineMap -> Bool
Eq, (forall x. LineMap -> Rep LineMap x)
-> (forall x. Rep LineMap x -> LineMap) -> Generic LineMap
forall x. Rep LineMap x -> LineMap
forall x. LineMap -> Rep LineMap x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LineMap x -> LineMap
$cfrom :: forall x. LineMap -> Rep LineMap x
Generic)
  deriving newtype (Int -> LineMap -> ShowS
[LineMap] -> ShowS
LineMap -> String
(Int -> LineMap -> ShowS)
-> (LineMap -> String) -> ([LineMap] -> ShowS) -> Show LineMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LineMap] -> ShowS
$cshowList :: [LineMap] -> ShowS
show :: LineMap -> String
$cshow :: LineMap -> String
showsPrec :: Int -> LineMap -> ShowS
$cshowsPrec :: Int -> LineMap -> ShowS
Show, LineMap -> ()
(LineMap -> ()) -> NFData LineMap
forall a. (a -> ()) -> NFData a
rnf :: LineMap -> ()
$crnf :: LineMap -> ()
NFData)

instance Binary LineMap where
    get :: Get LineMap
get = ([Offset] -> LineMap) -> Get [Offset] -> Get LineMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vector Offset -> LineMap
LineMap (Vector Offset -> LineMap)
-> ([Offset] -> Vector Offset) -> [Offset] -> LineMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Offset] -> Vector Offset
forall a. Unbox a => [a] -> Vector a
V.fromList) Get [Offset]
forall t. Binary t => Get t
get
    put :: LineMap -> Put
put (LineMap v :: Vector Offset
v) = [Offset] -> Put
forall t. Binary t => t -> Put
put (Vector Offset -> [Offset]
forall a. Unbox a => Vector a -> [a]
V.toList Vector Offset
v)

instance Hashable LineMap where
    hashWithSalt :: Int -> LineMap -> Int
hashWithSalt salt :: Int
salt (LineMap v :: Vector Offset
v) = (Int -> Offset -> Int) -> Int -> Vector Offset -> Int
forall b a. Unbox b => (a -> b -> a) -> a -> Vector b -> a
V.foldl' Int -> Offset -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt Vector Offset
v

fromOffsets :: Foldable f => f Offset -> LineMap
fromOffsets :: f Offset -> LineMap
fromOffsets = Vector Offset -> LineMap
LineMap (Vector Offset -> LineMap)
-> (f Offset -> Vector Offset) -> f Offset -> LineMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Offset] -> Vector Offset
forall a. Unbox a => [a] -> Vector a
V.fromList ([Offset] -> Vector Offset)
-> (f Offset -> [Offset]) -> f Offset -> Vector Offset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Offset] -> [Offset]
forall a. Ord a => [a] -> [a]
sort ([Offset] -> [Offset])
-> (f Offset -> [Offset]) -> f Offset -> [Offset]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Offset -> [Offset]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | Convert a 'LineMap' into a list of 'Offset's, corresponding to the first
-- character of a line. Note that the initial offset is omitted-- the offset at
-- index 0 will be the offset of the /second/ line.
lineOffsets :: LineMap -> [Offset]
lineOffsets :: LineMap -> [Offset]
lineOffsets (LineMap v :: Vector Offset
v) = Vector Offset -> [Offset]
forall a. Unbox a => Vector a -> [a]
V.toList Vector Offset
v

-- | Fetch the 'Offset' for the given 'Line'. Evaluates to 'Nothing' if the
-- given 'Line' does not appear in the LineMap
lineToOffset :: Line -> LineMap -> Maybe Offset
lineToOffset :: Line -> LineMap -> Maybe Offset
lineToOffset (Line 0  ) _            = Offset -> Maybe Offset
forall a. a -> Maybe a
Just (Offset -> Maybe Offset) -> Offset -> Maybe Offset
forall a b. (a -> b) -> a -> b
$ Word -> Offset
Offset 0
lineToOffset (Line nth :: Word
nth) (LineMap xs :: Vector Offset
xs) = Vector Offset
xs Vector Offset -> Int -> Maybe Offset
forall a. Unbox a => Vector a -> Int -> Maybe a
V.!? Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Word
forall a. Enum a => a -> a
pred Word
nth)

-- | Fetch the 'Line' number for a given 'Offset'. Newlines will be attributed
-- the line that they terminate, rather than the line started immediately 
-- afterwards.
offsetToLine :: Offset -> LineMap -> Line
offsetToLine :: Offset -> LineMap -> Line
offsetToLine offset :: Offset
offset (LineMap xs :: Vector Offset
xs) = Word -> Line
Line (Word -> Line) -> (Int -> Word) -> Int -> Line
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Line) -> Int -> Line
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Int -> Int -> Int
go Maybe Int
forall a. Maybe a
Nothing
                                                            0
                                                            (Vector Offset -> Int
forall a. Unbox a => Vector a -> Int
V.length Vector Offset
xs)
  where
    go :: Maybe Int -> Int -> Int -> Int
go result :: Maybe Int
result min :: Int
min max :: Int
max
        | Int
min Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
max
        = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 0 Int -> Int
forall a. Enum a => a -> a
succ Maybe Int
result
        | Bool
otherwise
        = let nthIndex :: Int
nthIndex  = ((Int
max Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
min) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
min
              nthOffset :: Offset
nthOffset = Vector Offset
xs Vector Offset -> Int -> Offset
forall a. Unbox a => Vector a -> Int -> a
V.! Int
nthIndex
          in  case Offset
nthOffset Offset -> Offset -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Offset
offset of
                  EQ -> Int -> Int
forall a. Enum a => a -> a
succ Int
nthIndex
                  LT -> Maybe Int -> Int -> Int -> Int
go (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
nthIndex) (Int
nthIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int
max
                  GT -> Maybe Int -> Int -> Int -> Int
go Maybe Int
result Int
min Int
nthIndex

newtype instance MVector s Offset = MV_Offset (MVector s Word)

instance VGM.MVector MVector Offset where
    basicLength :: MVector s Offset -> Int
basicLength (MV_Offset m) = MVector s Word -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
VGM.basicLength MVector s Word
m
    {-# INLINE basicLength #-}

    basicUnsafeSlice :: Int -> Int -> MVector s Offset -> MVector s Offset
basicUnsafeSlice ix :: Int
ix len :: Int
len (MV_Offset m) =
        MVector s Word -> MVector s Offset
forall s. MVector s Word -> MVector s Offset
MV_Offset (MVector s Word -> MVector s Offset)
-> MVector s Word -> MVector s Offset
forall a b. (a -> b) -> a -> b
$ Int -> Int -> MVector s Word -> MVector s Word
forall (v :: * -> * -> *) a s.
MVector v a =>
Int -> Int -> v s a -> v s a
VGM.basicUnsafeSlice Int
ix Int
len MVector s Word
m
    {-# INLINE basicUnsafeSlice #-}

    basicOverlaps :: MVector s Offset -> MVector s Offset -> Bool
basicOverlaps (MV_Offset x) (MV_Offset y) = MVector s Word -> MVector s Word -> Bool
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> Bool
VGM.basicOverlaps MVector s Word
x MVector s Word
y
    {-# INLINE basicOverlaps #-}

    basicUnsafeNew :: Int -> m (MVector (PrimState m) Offset)
basicUnsafeNew len :: Int
len = MVector (PrimState m) Word -> MVector (PrimState m) Offset
forall s. MVector s Word -> MVector s Offset
MV_Offset (MVector (PrimState m) Word -> MVector (PrimState m) Offset)
-> m (MVector (PrimState m) Word)
-> m (MVector (PrimState m) Offset)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m (MVector (PrimState m) Word)
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
Int -> m (v (PrimState m) a)
VGM.basicUnsafeNew Int
len
    {-# INLINE basicUnsafeNew #-}

    basicInitialize :: MVector (PrimState m) Offset -> m ()
basicInitialize (MV_Offset v) = MVector (PrimState m) Word -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> m ()
VGM.basicInitialize MVector (PrimState m) Word
v
    {-# INLINE basicInitialize #-}

    basicUnsafeRead :: MVector (PrimState m) Offset -> Int -> m Offset
basicUnsafeRead (MV_Offset v) = (Word -> Offset) -> m Word -> m Offset
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word -> Offset
Offset (m Word -> m Offset) -> (Int -> m Word) -> Int -> m Offset
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState m) Word -> Int -> m Word
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> Int -> m a
VGM.basicUnsafeRead MVector (PrimState m) Word
v
    {-# INLINE basicUnsafeRead #-}

    basicUnsafeWrite :: MVector (PrimState m) Offset -> Int -> Offset -> m ()
basicUnsafeWrite (MV_Offset v) ix :: Int
ix (Offset w :: Word
w) = MVector (PrimState m) Word -> Int -> Word -> m ()
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
v (PrimState m) a -> Int -> a -> m ()
VGM.basicUnsafeWrite MVector (PrimState m) Word
v Int
ix Word
w
    {-# INLINE basicUnsafeWrite #-}

newtype instance Vector Offset = V_Offset (Vector Word)

instance VG.Vector Vector Offset where
    basicUnsafeFreeze :: Mutable Vector (PrimState m) Offset -> m (Vector Offset)
basicUnsafeFreeze (MV_Offset v) = Vector Word -> Vector Offset
V_Offset (Vector Word -> Vector Offset)
-> m (Vector Word) -> m (Vector Offset)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mutable Vector (PrimState m) Word -> m (Vector Word)
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
Mutable v (PrimState m) a -> m (v a)
VG.basicUnsafeFreeze MVector (PrimState m) Word
Mutable Vector (PrimState m) Word
v
    {-# INLINE basicUnsafeFreeze #-}

    basicUnsafeThaw :: Vector Offset -> m (Mutable Vector (PrimState m) Offset)
basicUnsafeThaw (V_Offset v) = MVector (PrimState m) Word -> MVector (PrimState m) Offset
forall s. MVector s Word -> MVector s Offset
MV_Offset (MVector (PrimState m) Word -> MVector (PrimState m) Offset)
-> m (MVector (PrimState m) Word)
-> m (MVector (PrimState m) Offset)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Word -> m (Mutable Vector (PrimState m) Word)
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, PrimMonad m) =>
v a -> m (Mutable v (PrimState m) a)
VG.basicUnsafeThaw Vector Word
v
    {-# INLINE basicUnsafeThaw #-}

    basicLength :: Vector Offset -> Int
basicLength (V_Offset v) = Vector Word -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
VG.basicLength Vector Word
v
    {-# INLINE basicLength #-}

    basicUnsafeSlice :: Int -> Int -> Vector Offset -> Vector Offset
basicUnsafeSlice ix :: Int
ix len :: Int
len (V_Offset v) =
        Vector Word -> Vector Offset
V_Offset (Vector Word -> Vector Offset) -> Vector Word -> Vector Offset
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word -> Vector Word
forall (v :: * -> *) a. Vector v a => Int -> Int -> v a -> v a
VG.basicUnsafeSlice Int
ix Int
len Vector Word
v
    {-# INLINE basicUnsafeSlice #-}

    basicUnsafeIndexM :: Vector Offset -> Int -> m Offset
basicUnsafeIndexM (V_Offset v) ix :: Int
ix = Word -> Offset
Offset (Word -> Offset) -> m Word -> m Offset
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Word -> Int -> m Word
forall (v :: * -> *) a (m :: * -> *).
(Vector v a, Monad m) =>
v a -> Int -> m a
VG.basicUnsafeIndexM Vector Word
v Int
ix
    {-# INLINE basicUnsafeIndexM #-}

instance Unbox Offset where