-- this module has to be called this because a module A.B's private elements are
-- still visible to A.B.C, even if they're in different packages. which i don't
-- think is a good idea but i also don't want to fork prettier over it
--
-- also i adapted this code from stefan höck's prettier-ansi package
-- (https://github.com/idris-community/idris2-ansi)
module Text.PrettyPrint.Bernardy.Core.Decorate

import public Text.PrettyPrint.Bernardy.Core
import Data.DPair
import Data.String
import Derive.Prelude

%language ElabReflection


public export
record Highlight where
  constructor MkHighlight
  before, after : String
%name Highlight h
%runElab derive "Highlight" [Eq]

export
emptyHL : Highlight
emptyHL = MkHighlight "" ""


-- lifted from prettier-ansi
private
decorateImpl : Highlight ->
               (ss : SnocList String) -> (0 _ : NonEmptySnoc ss) =>
               Subset (SnocList String) NonEmptySnoc
decorateImpl h [< x]     = Element [< h.before ++ x ++ h.after] %search
decorateImpl h (sx :< x) = Element (go [] sx :< (x ++ h.after)) %search
  where
    go : List String -> SnocList String -> SnocList String
    go strs [< x]     = [< h.before ++ x] <>< strs
    go strs (sx :< x) = go (x :: strs) sx
    go strs [<]       = [<] <>< strs

||| Decorate a `Layout` with the given ANSI codes *without*
||| changing its stats like width or height.
export
decorateLayout : Highlight -> Layout -> Layout
decorateLayout h (MkLayout content stats) =
  layout (decorateImpl h content) stats

||| Decorate a `Doc` with the given highlighting *without*
||| changing its stats like width or height.
export
decorate : {opts : LayoutOpts} -> Highlight -> Doc opts -> Doc opts
decorate h doc =
  if h == emptyHL then doc else doc >>= pure . decorateLayout h


-- this function has nothing to do with highlighting but it's here because it
-- _also_ needs access to the private stuff
||| render a doc with no line breaks at all
export
renderInfinite : Doc opts -> String
renderInfinite (MkDoc (MkLayout content _) _) = unwords content where
  unwords : SnocList String -> String
  unwords [<]       = ""
  unwords (xs :< x) = foldMap (++ " ") xs ++ x