{-# language BangPatterns #-}
{-# language DeriveDataTypeable #-}
{-# language DeriveGeneric #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language OverloadedStrings #-}
{-# language RoleAnnotations #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}

---------------------------------------------------------------------------------
-- |
-- Copyright :  (c) Edward Kmett 2017-2018
-- License   :  BSD-2-Clause OR Apache-2.0
-- Maintainer:  Edward Kmett <ekmett@gmail.com>
-- Stability :  experimental
-- Portability: non-portable
--
---------------------------------------------------------------------------------

module Rope
  ( Rope(..)
  , splitAtPosition
  , splitAtDelta
  , insertAt
  , deleteRange
  , replaceRange
  , deltaToPosition
  , positionToDelta
  -- * Lines
  , Line(..)
  , foldLines
  , FromText(..)
  -- * Summarizing Lines
  , LineMeasure(..)
  , HasLineMeasure(..)
  ) where

import Control.Lens
import Data.Data
import Data.Default
import Data.Hashable
import Data.Profunctor.Unsafe
import Data.Semigroup
import Data.String
import Data.Text as Text hiding (split)
import qualified Data.Text.Array as Text
import Data.Text.Internal (Text(..))
import Data.Text.Unsafe as Text
import GHC.Generics
import Prelude hiding (lex)

import FingerTree hiding (SearchResult(..))
import qualified FingerTree as F
import Language.Server.Protocol hiding (error)
import Relative.Delta
import Syntax.FromText

import Dyck
import Lexer
import Summary

data Line = Line { runLine :: {-# unpack #-} !Text, content :: {-# unpack #-} !Dyck }
  deriving (Eq, Ord, Show, Read)

instance Hashable Line where
  hashWithSalt e = hashWithSalt e . runLine
  {-# inline hashWithSalt #-}
  hash = hash . runLine
  {-# inline hash #-}

instance FromText Line where
  fromText t = Line t (lex t)

instance IsString Line where
  fromString = fromText . fromString

instance HasDelta Line where
  delta = Delta #. Text.lengthWord16 . runLine

instance Default Line where
  def = fromText ""

cr, lf, crlf :: Text
cr   = "\r"
lf   = "\n"
crlf = "\r\n"

-- TODO: This should split up in parallel with a monoid
-- TODO: Consider copying the Text to new arrays. That way when
-- we do incremental updates on the Text we don't need to hold the
-- entire original Text. OTOH, this would expand our memory footprint
-- and the common case is that we do small edits to big initial
-- sets of lines
foldLines :: (a -> Text -> a) -> a -> Text -> a
foldLines f z0 (Text a0 o0 l0) = go o0 o0 (o0+l0) a0 z0 where
  -- go :: Int -> Int -> Int -> Array -> a -> a
  go !s !i !e !a z
    | i < e = case Text.unsafeIndex a i of
      10             -> go (i+1) (i+1) e a $ f z $ if s < i then Text a s (i+1-s) else lf
      13 | i+1 < e -> case Text.unsafeIndex a (i+1) of
           10        -> go (i+2) (i+2) e a $ f z $ if s < i then Text a s (i+2-s) else crlf
           _         -> go (i+1) (i+1) e a $ f z $ if s < i then Text a s (i+1-s) else cr
         | otherwise -> go (i+1) (i+1) e a $ f z $ if s < i then Text a s (i+1-s) else cr
      _ -> go s (i+1) e a z
    | s < e = f z $ Text a s (e-s)
    | otherwise = z


--------------------------------------------------------------------------------
-- LineMeasure
--------------------------------------------------------------------------------

-- | 'LineMeasure' is not 'Position'
--
-- This measures line count and total number of code-units over all lines
-- not the number of code-units on the current line.
--
-- Also when used to measure a 'FingerTree' you can use the 'FingerTree' to convert
-- back and forth between 'Delta' and 'Position' in /O(log l)/ time, while still
-- letting us use the compact single-integer Abelian group 'Delta' representation
-- internally for almost all positioning.
--
data LineMeasure = LineMeasure {-# unpack #-} !Int {-# unpack #-} !Delta {-# unpack #-} !Summary
  deriving (Eq, Ord, Show, Read, Data, Generic)

instance HasDelta LineMeasure where
  delta (LineMeasure _ d _) = d

instance Hashable LineMeasure

instance Semigroup LineMeasure where
  LineMeasure l d v <> LineMeasure l' d' v' = LineMeasure (l + l') (d + d') (mergeSummary l d v l' d' v')

instance Monoid LineMeasure where
  mempty = LineMeasure 0 0 def
  mappend = (<>)

-- Measured a is somewhat the wrong constraint here
instance Measured Line where
  type Measure Line = LineMeasure
  measure (Line l a) = LineMeasure 1 (Delta $ Text.lengthWord16 l) (summarize l a)

instance Default LineMeasure where
  def = LineMeasure 0 0 def

--------------------------------------------------------------------------------
-- HasLineMeasure
--------------------------------------------------------------------------------

class HasDelta t => HasLineMeasure t where
  lineMeasure :: t -> LineMeasure

  lineCount :: t -> Int
  lineCount = lineCount . lineMeasure

instance HasLineMeasure LineMeasure where
  lineCount (LineMeasure l _ _) = l
  lineMeasure = id

-- instance (RelativeMonoid (Measure a), Measured a) => HasLineMeasure (Line a) (Measure a) where
--  lineMeasure = measure

--------------------------------------------------------------------------------
-- Ropes
--------------------------------------------------------------------------------

newtype Rope = Rope (FingerTree Line)
  deriving Show

instance Semigroup Rope where
  Rope l <> Rope r = Rope $ case l of
    ll :> Line m _
      | Text.lengthWord16 m > 0 -> case Text.last m of
        '\n' -> l <> r
        '\r' -> case r of
          Line "\n" _ :< rr -> ll <> (fromText (Text.snoc m '\n') <| rr) -- avoid associativity problems re the "\r\n" line terminator
          _ -> l <> r
        _ -> case r of -- last line in the first rope is incomplete
          Line n _ :< rr -> ll <> (fromText (mappend m n) <| rr)
          _ -> l -- but there is no right rope
     | otherwise -> ll <> r
    _ -> r

instance Monoid Rope where
  mempty = Rope mempty
  mappend = (<>)

instance Measured Rope where
  type Measure Rope = LineMeasure
  measure (Rope r) = measure r

instance FromText Rope where
  fromText = foldLines step (Rope mempty) where
    step (Rope xs) x = Rope (xs |> fromText x)

instance IsString Rope where
 fromString = fromText . pack

splitAtPosition :: Position -> Rope -> (Rope, Rope)
splitAtPosition (Position lno cno) (Rope xs) = case search (\x _ -> lineCount x >= lno) xs of
  F.Position l lm@(Line m _) r
    | cno < Text.lengthWord16 m ->
      (Rope $ l |> fromText (Text.takeWord16 cno m), Rope $ fromText (Text.dropWord16 cno m) <| r)
    | otherwise -> (Rope (l |> lm), Rope r)
  F.OnLeft -> (Rope xs, mempty)
  F.OnRight -> (mempty, Rope xs)
  F.Nowhere -> error "splitAtPosition: nowhere"

splitAtDelta :: Delta -> Rope -> (Rope, Rope)
splitAtDelta d (Rope xs) = case search (\x _ -> delta x >= d) xs of
  F.Position l (Line m _) r
      | !cno <- units d - units (measure l) ->
        (Rope $ l |> fromText (Text.takeWord16 cno m), Rope $ fromText (Text.dropWord16 cno m) <| r)
  F.OnLeft -> (Rope xs, mempty)
  F.OnRight -> (mempty, Rope xs)
  F.Nowhere -> error "splitAtDelta: nowhere"

insertAt :: Position -> Text -> Rope -> Rope
insertAt p t rope = case splitAtPosition p rope of
  (l, r) -> l <> fromText t <> r

deleteRange :: Range -> Rope -> Rope
deleteRange (Range lo hi) doc = case splitAtPosition hi doc of
  (m, r) -> fst (splitAtPosition lo m) <> r

replaceRange :: Range -> Text -> Rope -> Rope
replaceRange (Range lo hi) t doc = case splitAtPosition hi doc of
  (m, r) -> fst (splitAtPosition lo m) <> fromText t <> r

-- | Compute an Language Server Protocol 'Position' from a 'Delta' given the associated text
--
-- Takes /O(log l)/ where l is the number of lines
deltaToPosition :: Rope -> Delta -> Position
deltaToPosition (Rope t) (Delta d) = case split (\x -> units x >= d) t of
  (l, _) | ml <- measure l -> Position (lineCount ml) (d - units ml)

-- | Convert from a Language Server Protocol 'Position' to a 'Delta' given the associated text.
--
-- /O(log l)/ where l is the number of lines
positionToDelta :: Rope -> Position -> Delta
positionToDelta (Rope t) (Position nl c16) = case split (\x -> lineCount x >= nl) t of
  (l, _) -> Delta $ units (measure l) + c16