{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

{-|
Module      : Headroom.Header.Sanitize
Description : Logic for sanitizing license headers
Copyright   : (c) 2019-2021 Vaclav Svejcar
License     : BSD-3-Clause
Maintainer  : vaclav.svejcar@gmail.com
Stability   : experimental
Portability : POSIX

This module contains functions related to sanitizing license headers. Because
license headers are just regular comments in given programming language, they
need to have correct syntax in order to avoid causing compile/runtime errors.
Because header manipulation done by /Headroom/ can disrupt the comment syntax
structure, sanitizing the header is the last step done in the flow, making
sure that license header syntax is not broken.
-}

module Headroom.Header.Sanitize
  ( findPrefix
  , sanitizeSyntax
  , stripCommentSyntax
  )
where

import           Headroom.Configuration.Types        ( HeaderSyntax(..) )
import qualified Headroom.Data.Regex                as R
import qualified Headroom.Data.Text                 as T
import           RIO
import qualified RIO.Text                           as T


------------------------------  PUBLIC FUNCTIONS  ------------------------------

-- | Tries to find comment prefix in given comment. By /prefix/ it's meant
-- either the line prefix used for block comment syntax (like @*@ at start of
-- each line between opening and closing pattern - @/* */@) or line comment
-- syntax (just the syntax for comment itself - like @//@ or @--@). If such
-- prefix is found, it's then added to the input 'HeaderSyntax'.
--
-- >>> :set -XQuasiQuotes
-- >>> import Headroom.Data.Regex (re)
-- >>> findPrefix (BlockComment [re|^\/\*|] [re|\*\/$|] Nothing) "/*\n * foo\n * bar\n */"
-- BlockComment "^\\/\\*" "\\*\\/$" (Just " *")
findPrefix :: HeaderSyntax
           -- ^ describes comment syntax of the header
           -> Text
           -- ^ text containint the comment
           -> HeaderSyntax
           -- ^ input 'HeaderSyntax' with added prefix (if found)
findPrefix :: HeaderSyntax -> Text -> HeaderSyntax
findPrefix HeaderSyntax
syntax Text
text = case HeaderSyntax
syntax of
  BlockComment Regex
s Regex
e Maybe Text
_ -> Regex -> Regex -> Maybe Text -> HeaderSyntax
BlockComment Regex
s Regex
e Maybe Text
prefix
  LineComment Regex
s Maybe Text
_    -> Regex -> Maybe Text -> HeaderSyntax
LineComment Regex
s Maybe Text
prefix
 where
  filtered :: [Text]
filtered = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
cond ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.toLines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
text
  cond :: Text -> Bool
cond     = \Text
t -> (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text
t) Bool -> Bool -> Bool
&& HeaderSyntax -> Text -> Bool
isCommentBody HeaderSyntax
syntax Text
t
  prefix :: Maybe Text
prefix   = (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.stripEnd (Text -> Maybe Text
T.commonLinesPrefix (Text -> Maybe Text) -> ([Text] -> Text) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.fromLines ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text]
filtered)


-- | Sanitizes given header text to make sure that each comment line starts with
-- appropriate prefix (if defined within given 'HeaderSyntax'). For block
-- comments, this is to make it visually unified, but for line comments it's
-- necessary in order not to break syntax of target source code file.
--
-- >>> :set -XQuasiQuotes
-- >>> import Headroom.Data.Regex (re)
-- >>> sanitizeSyntax (LineComment [re|^--|] (Just "--")) "-- foo\nbar"
-- "-- foo\n-- bar"
sanitizeSyntax :: HeaderSyntax
               -- ^ header syntax definition that may contain prefix
               -> Text
               -- ^ header to sanitize
               -> Text
               -- ^ sanitized header
sanitizeSyntax :: HeaderSyntax -> Text -> Text
sanitizeSyntax HeaderSyntax
syntax = HeaderSyntax -> (Text -> Maybe Text) -> Text -> Text
forall (t :: * -> *).
Foldable t =>
HeaderSyntax -> (Text -> t Text) -> Text -> Text
mapCommentLines HeaderSyntax
syntax (Maybe Text -> Text -> Maybe Text
addPrefix Maybe Text
mPrefix)
 where
  addPrefix :: Maybe Text -> Text -> Maybe Text
addPrefix Maybe Text
Nothing Text
l = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
l
  addPrefix (Just Text
p) Text
l | Text
p Text -> Text -> Bool
`T.isPrefixOf` Text
l = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
l
                       | Bool
otherwise          = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l
  mPrefix :: Maybe Text
mPrefix = case HeaderSyntax
syntax of
    BlockComment Regex
_ Regex
_ Maybe Text
p -> Maybe Text
p
    LineComment Regex
_ Maybe Text
p    -> Maybe Text
p


-- | Strips comment syntax from given text.
--
-- >>> :set -XQuasiQuotes
-- >>> import Headroom.Data.Regex (re)
-- >>> stripCommentSyntax (LineComment [re|^--|] (Just "--")) "-- a\n-- b"
-- "a\n b"
stripCommentSyntax :: HeaderSyntax
                   -- ^ copyright header syntax
                   -> Text
                   -- ^ input text from which to strip the syntax
                   -> Text
                   -- ^ processed text
stripCommentSyntax :: HeaderSyntax -> Text -> Text
stripCommentSyntax HeaderSyntax
syntax = Text -> Text
T.strip (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.fromLines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text] -> [Text]
go [] ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.toLines (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip
 where
  (Maybe Regex
s, Maybe Regex
e, Maybe Text
p) = case HeaderSyntax
syntax of
    BlockComment Regex
s' Regex
e' Maybe Text
p' -> (Regex -> Maybe Regex
forall a. a -> Maybe a
Just Regex
s', Regex -> Maybe Regex
forall a. a -> Maybe a
Just Regex
e', Maybe Text
p')
    LineComment Regex
s' Maybe Text
p'     -> (Regex -> Maybe Regex
forall a. a -> Maybe a
Just Regex
s', Maybe Regex
forall a. Maybe a
Nothing, Maybe Text
p')
  nil :: b -> b -> Text
nil = (b -> Text) -> b -> b -> Text
forall a b. a -> b -> a
const ((b -> Text) -> b -> b -> Text)
-> (Text -> b -> Text) -> Text -> b -> b -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> b -> Text
forall a b. a -> b -> a
const (Text -> b -> b -> Text) -> Text -> b -> b -> Text
forall a b. (a -> b) -> a -> b
$ Text
""
  rep :: Maybe Regex -> Text -> Text
rep = \Maybe Regex
pt Text
l -> Text -> (Regex -> Text) -> Maybe Regex -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
l (\Regex
pt' -> Regex -> (Text -> [Text] -> Text) -> Text -> Text
R.replaceFirst Regex
pt' Text -> [Text] -> Text
forall b b. b -> b -> Text
nil Text
l) Maybe Regex
pt
  dp :: Maybe Text -> Text -> Text
dp  = \Maybe Text
pt Text
l -> Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
l (\Text
pt' -> Text -> Text -> Text -> Text
T.replaceFirst Text
pt' Text
"" Text
l) Maybe Text
pt
  go :: [Text] -> [Text] -> [Text]
go [Text]
agg []       = [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
agg
  go []  (Text
x : [Text]
xs) = [Text] -> [Text] -> [Text]
go [Maybe Regex -> Text -> Text
rep Maybe Regex
s (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Regex -> Text -> Text
rep Maybe Regex
e (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Text -> Text
dp Maybe Text
p (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
x] [Text]
xs
  go [Text]
agg [Text
x     ] = [Text] -> [Text] -> [Text]
go ((Maybe Regex -> Text -> Text
rep Maybe Regex
e (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Text -> Text
dp Maybe Text
p (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
x) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
agg) []
  go [Text]
agg (Text
x : [Text]
xs) = [Text] -> [Text] -> [Text]
go (Maybe Text -> Text -> Text
dp Maybe Text
p Text
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
agg) [Text]
xs


------------------------------  PRIVATE FUNCTIONS  -----------------------------

mapCommentLines :: Foldable t
                => HeaderSyntax
                -> (Text -> t Text)
                -> Text
                -> Text
mapCommentLines :: HeaderSyntax -> (Text -> t Text) -> Text -> Text
mapCommentLines HeaderSyntax
syntax Text -> t Text
f = (Text -> [Text]) -> Text -> Text
forall (t :: * -> *).
Foldable t =>
(Text -> t Text) -> Text -> Text
T.mapLinesF ((Text -> [Text]) -> Text -> Text)
-> (Text -> [Text]) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ \case
  Text
line | HeaderSyntax -> Text -> Bool
isCommentBody HeaderSyntax
syntax Text
line -> t Text -> [Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (t Text -> [Text]) -> (Text -> t Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> t Text
f (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
line
       | Bool
otherwise                 -> [Text
line]


isCommentBody :: HeaderSyntax -> Text -> Bool
isCommentBody :: HeaderSyntax -> Text -> Bool
isCommentBody (LineComment Regex
_ Maybe Text
_   ) Text
_ = Bool
True
isCommentBody (BlockComment Regex
s Regex
e Maybe Text
_) Text
l = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Regex -> Text -> Bool
R.isMatch Regex
s Text
l Bool -> Bool -> Bool
|| Regex -> Text -> Bool
R.isMatch Regex
e Text
l