{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE TypeFamilies      #-}

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

This module is the heart of /Headroom/ as it contains functions for working with
the /license headers/ and the /source code files/.
-}

module Headroom.Header
  ( -- * Header Info Extraction
    extractHeaderInfo
  , extractHeaderTemplate
    -- * License header manipulation
  , addHeader
  , dropHeader
  , replaceHeader
    -- * Copyright Header Detection
  , findHeader
  , findBlockHeader
  , findLineHeader
  , splitSource
  )
where

import           Headroom.Configuration.Types        ( CtHeaderConfig
                                                     , CtHeaderConfig
                                                     , CtHeadersConfig
                                                     , HeaderConfig(..)
                                                     , HeaderConfig(..)
                                                     , HeaderSyntax(..)
                                                     , HeaderSyntax(..)
                                                     )
import           Headroom.Data.Coerce                ( coerce
                                                     , inner
                                                     )
import           Headroom.Data.Lens                  ( suffixLensesFor )
import           Headroom.Data.Regex                 ( Regex
                                                     , isMatch
                                                     )
import           Headroom.FileSupport                ( fileSupport )
import           Headroom.FileSupport.Types          ( FileSupport(..) )
import           Headroom.FileType                   ( configByFileType )
import           Headroom.FileType.Types             ( FileType )
import           Headroom.Header.Sanitize            ( findPrefix )
import           Headroom.Header.Types               ( HeaderInfo(..)
                                                     , HeaderTemplate(..)
                                                     )
import           Headroom.Meta                       ( TemplateType )
import           Headroom.SourceCode                 ( CodeLine
                                                     , LineType(..)
                                                     , SourceCode(..)
                                                     , firstMatching
                                                     , fromText
                                                     , lastMatching
                                                     , stripEnd
                                                     , stripStart
                                                     )
import           Headroom.Template                   ( Template(..) )
import           RIO
import qualified RIO.List                           as L
import qualified RIO.Text                           as T



suffixLensesFor ["hcHeaderSyntax"] ''HeaderConfig
suffixLensesFor ["hiHeaderPos"]    ''HeaderInfo


-- | Extracts info about the processed file to be later used by the header
-- detection/manipulation functions.
extractHeaderInfo :: HeaderTemplate
                  -- ^ template info
                  -> SourceCode
                  -- ^ text used for detection
                  -> HeaderInfo
                  -- ^ resulting file info
extractHeaderInfo :: HeaderTemplate -> SourceCode -> HeaderInfo
extractHeaderInfo ht :: HeaderTemplate
ht@HeaderTemplate {TemplateData
FileType
TemplateType
CtHeaderConfig
htTemplate :: HeaderTemplate -> TemplateType
htFileType :: HeaderTemplate -> FileType
htTemplateData :: HeaderTemplate -> TemplateData
htConfig :: HeaderTemplate -> CtHeaderConfig
htTemplate :: TemplateType
htFileType :: FileType
htTemplateData :: TemplateData
htConfig :: CtHeaderConfig
..} SourceCode
source =
  let hiFileType :: FileType
hiFileType     = FileType
htFileType
      hiHeaderConfig :: CtHeaderConfig
hiHeaderConfig = CtHeaderConfig
htConfig
      hiHeaderPos :: Maybe (Int, Int)
hiHeaderPos    = CtHeaderConfig -> SourceCode -> Maybe (Int, Int)
findHeader CtHeaderConfig
hiHeaderConfig SourceCode
source
      hiVariables :: Variables
hiVariables    = ExtractVariablesFn
fsExtractVariables HeaderTemplate
ht Maybe (Int, Int)
hiHeaderPos SourceCode
source
  in  HeaderInfo :: FileType
-> CtHeaderConfig -> Maybe (Int, Int) -> Variables -> HeaderInfo
HeaderInfo { Maybe (Int, Int)
FileType
Variables
CtHeaderConfig
hiVariables :: Variables
hiHeaderPos :: Maybe (Int, Int)
hiHeaderConfig :: CtHeaderConfig
hiFileType :: FileType
hiVariables :: Variables
hiHeaderPos :: Maybe (Int, Int)
hiHeaderConfig :: CtHeaderConfig
hiFileType :: FileType
.. }
  where FileSupport {FileType
SyntaxAnalysis
ExtractVariablesFn
ExtractTemplateDataFn
fsFileType :: FileSupport -> FileType
fsExtractVariables :: FileSupport -> ExtractVariablesFn
fsExtractTemplateData :: FileSupport -> ExtractTemplateDataFn
fsSyntaxAnalysis :: FileSupport -> SyntaxAnalysis
fsFileType :: FileType
fsExtractTemplateData :: ExtractTemplateDataFn
fsSyntaxAnalysis :: SyntaxAnalysis
fsExtractVariables :: ExtractVariablesFn
..} = FileType -> FileSupport
fileSupport FileType
htFileType


-- | Constructs new 'HeaderTemplate' from provided data.
extractHeaderTemplate :: CtHeadersConfig
                      -- ^ configuration for license headers
                      -> FileType
                      -- ^ type of source code files this template is for
                      -> TemplateType
                      -- ^ parsed template
                      -> HeaderTemplate
                      -- ^ resulting template info
extractHeaderTemplate :: CtHeadersConfig -> FileType -> TemplateType -> HeaderTemplate
extractHeaderTemplate CtHeadersConfig
configs FileType
fileType TemplateType
template =
  let htConfig :: CtHeaderConfig
htConfig       = CtHeaderConfig -> CtHeaderConfig
withP (CtHeadersConfig -> FileType -> CtHeaderConfig
configByFileType CtHeadersConfig
configs FileType
fileType)
      htTemplateData :: TemplateData
htTemplateData = TemplateType -> HeaderSyntax -> TemplateData
ExtractTemplateDataFn
fsExtractTemplateData TemplateType
template (CtHeaderConfig -> 'Complete ::: HeaderSyntax
forall (p :: Phase). HeaderConfig p -> p ::: HeaderSyntax
hcHeaderSyntax CtHeaderConfig
htConfig)
      htFileType :: FileType
htFileType     = FileType
fileType
      htTemplate :: TemplateType
htTemplate     = TemplateType
template
  in  HeaderTemplate :: CtHeaderConfig
-> TemplateData -> FileType -> TemplateType -> HeaderTemplate
HeaderTemplate { TemplateData
FileType
TemplateType
CtHeaderConfig
htTemplate :: TemplateType
htFileType :: FileType
htTemplateData :: TemplateData
htConfig :: CtHeaderConfig
htTemplate :: TemplateType
htFileType :: FileType
htTemplateData :: TemplateData
htConfig :: CtHeaderConfig
.. }
 where
  FileSupport {FileType
SyntaxAnalysis
ExtractVariablesFn
ExtractTemplateDataFn
fsFileType :: FileType
fsExtractVariables :: ExtractVariablesFn
fsSyntaxAnalysis :: SyntaxAnalysis
fsExtractTemplateData :: ExtractTemplateDataFn
fsFileType :: FileSupport -> FileType
fsExtractVariables :: FileSupport -> ExtractVariablesFn
fsExtractTemplateData :: FileSupport -> ExtractTemplateDataFn
fsSyntaxAnalysis :: FileSupport -> SyntaxAnalysis
..} = FileType -> FileSupport
fileSupport FileType
fileType
  withP :: CtHeaderConfig -> CtHeaderConfig
withP            = \CtHeaderConfig
config -> CtHeaderConfig
config CtHeaderConfig
-> (CtHeaderConfig -> CtHeaderConfig) -> CtHeaderConfig
forall a b. a -> (a -> b) -> b
& (HeaderSyntax -> Identity HeaderSyntax)
-> CtHeaderConfig -> Identity CtHeaderConfig
forall (p :: Phase). Lens' (HeaderConfig p) (p ::: HeaderSyntax)
hcHeaderSyntaxL ((HeaderSyntax -> Identity HeaderSyntax)
 -> CtHeaderConfig -> Identity CtHeaderConfig)
-> (HeaderSyntax -> HeaderSyntax)
-> CtHeaderConfig
-> CtHeaderConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ HeaderSyntax -> HeaderSyntax
headerSyntax
  headerSyntax :: HeaderSyntax -> HeaderSyntax
headerSyntax     = \HeaderSyntax
hs -> HeaderSyntax -> Text -> HeaderSyntax
findPrefix HeaderSyntax
hs (TemplateType -> Text
forall a. Template a => a -> Text
rawTemplate TemplateType
template)


-- | Adds given header at position specified by the 'HeaderInfo'. Does nothing
-- if any header is already present, use 'replaceHeader' if you need to
-- override it.
addHeader :: HeaderInfo
          -- ^ additional info about the header
          -> Text
          -- ^ text of the new header
          -> SourceCode
          -- ^ source code where to add the header
          -> SourceCode
          -- ^ resulting source code with added header
addHeader :: HeaderInfo -> Text -> SourceCode -> SourceCode
addHeader HeaderInfo {Maybe (Int, Int)
FileType
Variables
CtHeaderConfig
hiVariables :: Variables
hiHeaderPos :: Maybe (Int, Int)
hiHeaderConfig :: CtHeaderConfig
hiFileType :: FileType
hiVariables :: HeaderInfo -> Variables
hiHeaderPos :: HeaderInfo -> Maybe (Int, Int)
hiHeaderConfig :: HeaderInfo -> CtHeaderConfig
hiFileType :: HeaderInfo -> FileType
..} Text
_ SourceCode
source | Maybe (Int, Int) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Int, Int)
hiHeaderPos = SourceCode
source
addHeader HeaderInfo {Maybe (Int, Int)
FileType
Variables
CtHeaderConfig
hiVariables :: Variables
hiHeaderPos :: Maybe (Int, Int)
hiHeaderConfig :: CtHeaderConfig
hiFileType :: FileType
hiVariables :: HeaderInfo -> Variables
hiHeaderPos :: HeaderInfo -> Maybe (Int, Int)
hiHeaderConfig :: HeaderInfo -> CtHeaderConfig
hiFileType :: HeaderInfo -> FileType
..} Text
header SourceCode
source                 = [SourceCode] -> SourceCode
forall a. Monoid a => [a] -> a
mconcat [SourceCode]
chunks
 where
  HeaderConfig {'Complete ::: Int
'Complete ::: [Text]
'Complete ::: [Regex]
'Complete ::: HeaderSyntax
hcPutBefore :: forall (p :: Phase). HeaderConfig p -> p ::: [Regex]
hcPutAfter :: forall (p :: Phase). HeaderConfig p -> p ::: [Regex]
hcMarginBottomFile :: forall (p :: Phase). HeaderConfig p -> p ::: Int
hcMarginBottomCode :: forall (p :: Phase). HeaderConfig p -> p ::: Int
hcMarginTopFile :: forall (p :: Phase). HeaderConfig p -> p ::: Int
hcMarginTopCode :: forall (p :: Phase). HeaderConfig p -> p ::: Int
hcFileExtensions :: forall (p :: Phase). HeaderConfig p -> p ::: [Text]
hcHeaderSyntax :: 'Complete ::: HeaderSyntax
hcPutBefore :: 'Complete ::: [Regex]
hcPutAfter :: 'Complete ::: [Regex]
hcMarginBottomFile :: 'Complete ::: Int
hcMarginBottomCode :: 'Complete ::: Int
hcMarginTopFile :: 'Complete ::: Int
hcMarginTopCode :: 'Complete ::: Int
hcFileExtensions :: 'Complete ::: [Text]
hcHeaderSyntax :: forall (p :: Phase). HeaderConfig p -> p ::: HeaderSyntax
..}       = CtHeaderConfig
hiHeaderConfig
  (SourceCode
before, SourceCode
middle, SourceCode
after) = [Regex]
-> [Regex] -> SourceCode -> (SourceCode, SourceCode, SourceCode)
splitSource [Regex]
'Complete ::: [Regex]
hcPutAfter [Regex]
'Complete ::: [Regex]
hcPutBefore SourceCode
source
  header' :: SourceCode
header'                 = [Any] -> (Text -> State [Any] LineType) -> Text -> SourceCode
forall a. a -> (Text -> State a LineType) -> Text -> SourceCode
fromText [] (State [Any] LineType -> Text -> State [Any] LineType
forall a b. a -> b -> a
const (State [Any] LineType -> Text -> State [Any] LineType)
-> State [Any] LineType -> Text -> State [Any] LineType
forall a b. (a -> b) -> a -> b
$ LineType -> State [Any] LineType
forall (f :: * -> *) a. Applicative f => a -> f a
pure LineType
Comment) Text
header
  before' :: SourceCode
before'                 = SourceCode -> SourceCode
stripEnd SourceCode
before
  middle' :: SourceCode
middle'                 = SourceCode -> SourceCode
stripStart SourceCode
middle
  margin :: SourceCode -> Int -> Int -> p
margin (SourceCode [CodeLine]
ls) Int
mInner Int
mOuter
    | [CodeLine] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [CodeLine]
ls = [CodeLine] -> p
coerce ([CodeLine] -> p) -> [CodeLine] -> p
forall a b. (a -> b) -> a -> b
$ Int -> CodeLine -> [CodeLine]
forall a. Int -> a -> [a]
replicate Int
mOuter (LineType
Code, Text
T.empty)
    | Bool
otherwise = [CodeLine] -> p
coerce ([CodeLine] -> p) -> [CodeLine] -> p
forall a b. (a -> b) -> a -> b
$ Int -> CodeLine -> [CodeLine]
forall a. Int -> a -> [a]
replicate Int
mInner (LineType
Code, Text
T.empty)
  marginT :: SourceCode
marginT = SourceCode -> Int -> Int -> SourceCode
forall p. Coercible p [CodeLine] => SourceCode -> Int -> Int -> p
margin SourceCode
before' Int
'Complete ::: Int
hcMarginTopCode Int
'Complete ::: Int
hcMarginTopFile
  marginB :: SourceCode
marginB = SourceCode -> Int -> Int -> SourceCode
forall p. Coercible p [CodeLine] => SourceCode -> Int -> Int -> p
margin (SourceCode
middle' SourceCode -> SourceCode -> SourceCode
forall a. Semigroup a => a -> a -> a
<> SourceCode
after) Int
'Complete ::: Int
hcMarginBottomCode Int
'Complete ::: Int
hcMarginBottomFile
  chunks :: [SourceCode]
chunks  = [SourceCode
before', SourceCode
marginT, SourceCode
header', SourceCode
marginB, SourceCode
middle', SourceCode
after]


-- | Drops header at position specified by the 'HeaderInfo' from the given
-- source code. Does nothing if no header is present.
dropHeader :: HeaderInfo
           -- ^ additional info about the header
           -> SourceCode
           -- ^ text of the file from which to drop the header
           -> SourceCode
           -- ^ resulting text with dropped header
dropHeader :: HeaderInfo -> SourceCode -> SourceCode
dropHeader (HeaderInfo FileType
_ CtHeaderConfig
_ Maybe (Int, Int)
Nothing             Variables
_) SourceCode
source = SourceCode
source
dropHeader (HeaderInfo FileType
_ CtHeaderConfig
_ (Just (Int
start, Int
end)) Variables
_) SourceCode
source = SourceCode
result
 where
  before :: SourceCode
before = ([CodeLine] -> [CodeLine]) -> SourceCode -> SourceCode
forall a b. Coercible a b => (b -> b) -> a -> a
inner @_ @[CodeLine] (Int -> [CodeLine] -> [CodeLine]
forall a. Int -> [a] -> [a]
take Int
start) SourceCode
source
  after :: SourceCode
after  = ([CodeLine] -> [CodeLine]) -> SourceCode -> SourceCode
forall a b. Coercible a b => (b -> b) -> a -> a
inner @_ @[CodeLine] (Int -> [CodeLine] -> [CodeLine]
forall a. Int -> [a] -> [a]
drop (Int -> [CodeLine] -> [CodeLine])
-> Int -> [CodeLine] -> [CodeLine]
forall a b. (a -> b) -> a -> b
$ Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) SourceCode
source
  result :: SourceCode
result = SourceCode -> SourceCode
stripEnd SourceCode
before SourceCode -> SourceCode -> SourceCode
forall a. Semigroup a => a -> a -> a
<> SourceCode -> SourceCode
stripStart SourceCode
after


-- | Replaces existing header at position specified by the 'HeaderInfo' in the
-- given text. Basically combines 'addHeader' with 'dropHeader'. If no header
-- is present, then the given one is added to the text.
replaceHeader :: HeaderInfo
              -- ^ additional info about the header
              -> Text
              -- ^ text of the new header
              -> SourceCode
              -- ^ text of the file where to replace the header
              -> SourceCode
              -- ^ resulting text with replaced header
replaceHeader :: HeaderInfo -> Text -> SourceCode -> SourceCode
replaceHeader HeaderInfo
fileInfo Text
header = SourceCode -> SourceCode
addHeader' (SourceCode -> SourceCode)
-> (SourceCode -> SourceCode) -> SourceCode -> SourceCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceCode -> SourceCode
dropHeader'
 where
  addHeader' :: SourceCode -> SourceCode
addHeader'     = HeaderInfo -> Text -> SourceCode -> SourceCode
addHeader HeaderInfo
infoWithoutPos Text
header
  dropHeader' :: SourceCode -> SourceCode
dropHeader'    = HeaderInfo -> SourceCode -> SourceCode
dropHeader HeaderInfo
fileInfo
  infoWithoutPos :: HeaderInfo
infoWithoutPos = HeaderInfo
fileInfo HeaderInfo -> (HeaderInfo -> HeaderInfo) -> HeaderInfo
forall a b. a -> (a -> b) -> b
& (Maybe (Int, Int) -> Identity (Maybe (Int, Int)))
-> HeaderInfo -> Identity HeaderInfo
Lens' HeaderInfo (Maybe (Int, Int))
hiHeaderPosL ((Maybe (Int, Int) -> Identity (Maybe (Int, Int)))
 -> HeaderInfo -> Identity HeaderInfo)
-> Maybe (Int, Int) -> HeaderInfo -> HeaderInfo
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Int, Int)
forall a. Maybe a
Nothing


-- | Finds header position in given text, where position is represented by
-- line number of first and last line of the header (numbered from zero).
-- Based on the 'HeaderSyntax' specified in given 'HeaderConfig', this function
-- delegates its work to either 'findBlockHeader' or 'findLineHeader'.
--
-- >>> :set -XFlexibleContexts -XTypeFamilies -XQuasiQuotes
-- >>> import Headroom.Data.Regex (re)
-- >>> let hc = HeaderConfig ["hs"] 0 0 0 0 [] [] (BlockComment [re|^{-|] [re|(?<!#)-}$|] Nothing)
-- >>> findHeader hc $ SourceCode [(Code, "foo"), (Code, "bar"), (Comment, "{- HEADER -}")]
-- Just (2,2)
findHeader :: CtHeaderConfig
           -- ^ appropriate header configuration
           -> SourceCode
           -- ^ text in which to detect the header
           -> Maybe (Int, Int)
           -- ^ header position @(startLine, endLine)@
findHeader :: CtHeaderConfig -> SourceCode -> Maybe (Int, Int)
findHeader HeaderConfig {'Complete ::: Int
'Complete ::: [Text]
'Complete ::: [Regex]
'Complete ::: HeaderSyntax
hcHeaderSyntax :: 'Complete ::: HeaderSyntax
hcPutBefore :: 'Complete ::: [Regex]
hcPutAfter :: 'Complete ::: [Regex]
hcMarginBottomFile :: 'Complete ::: Int
hcMarginBottomCode :: 'Complete ::: Int
hcMarginTopFile :: 'Complete ::: Int
hcMarginTopCode :: 'Complete ::: Int
hcFileExtensions :: 'Complete ::: [Text]
hcPutBefore :: forall (p :: Phase). HeaderConfig p -> p ::: [Regex]
hcPutAfter :: forall (p :: Phase). HeaderConfig p -> p ::: [Regex]
hcMarginBottomFile :: forall (p :: Phase). HeaderConfig p -> p ::: Int
hcMarginBottomCode :: forall (p :: Phase). HeaderConfig p -> p ::: Int
hcMarginTopFile :: forall (p :: Phase). HeaderConfig p -> p ::: Int
hcMarginTopCode :: forall (p :: Phase). HeaderConfig p -> p ::: Int
hcFileExtensions :: forall (p :: Phase). HeaderConfig p -> p ::: [Text]
hcHeaderSyntax :: forall (p :: Phase). HeaderConfig p -> p ::: HeaderSyntax
..} SourceCode
input = case 'Complete ::: HeaderSyntax
hcHeaderSyntax of
  BlockComment start end _ -> Regex -> Regex -> SourceCode -> Int -> Maybe (Int, Int)
findBlockHeader Regex
start Regex
end SourceCode
headerArea Int
splitAt
  LineComment prefix _     -> Regex -> SourceCode -> Int -> Maybe (Int, Int)
findLineHeader Regex
prefix SourceCode
headerArea Int
splitAt
 where
  (SourceCode
before, SourceCode
headerArea, SourceCode
_) = [Regex]
-> [Regex] -> SourceCode -> (SourceCode, SourceCode, SourceCode)
splitSource [Regex]
'Complete ::: [Regex]
hcPutAfter [Regex]
'Complete ::: [Regex]
hcPutBefore SourceCode
input
  splitAt :: Int
splitAt                 = [CodeLine] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (SourceCode -> [CodeLine]
coerce SourceCode
before :: [CodeLine])


-- | Finds header in the form of /multi-line comment/ syntax, which is delimited
-- with starting and ending pattern.
--
-- >>> :set -XQuasiQuotes
-- >>> import Headroom.Data.Regex (re)
-- >>> let sc = SourceCode [(Code, ""), (Comment, "{- HEADER -}"), (Code, ""), (Code,"")]
-- >>> findBlockHeader [re|^{-|] [re|(?<!#)-}$|] sc 0
-- Just (1,1)
findBlockHeader :: Regex
                -- ^ starting pattern (e.g. @{-@ or @/*@)
                -> Regex
                -- ^ ending pattern (e.g. @-}@ or @*/@)
                -> SourceCode
                -- ^ source code in which to detect the header
                -> Int
                -- ^ line number offset (adds to resulting position)
                -> Maybe (Int, Int)
                -- ^ header position @(startLine + offset, endLine + offset)@
findBlockHeader :: Regex -> Regex -> SourceCode -> Int -> Maybe (Int, Int)
findBlockHeader Regex
start Regex
end SourceCode
sc Int
offset = (Int -> Int) -> (Int, Int) -> (Int, Int)
forall a b. (a -> b) -> (a, a) -> (b, b)
mapT2 (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset) ((Int, Int) -> (Int, Int)) -> Maybe (Int, Int) -> Maybe (Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, Int)
position
 where
  ls :: [(Int, CodeLine)]
ls          = [Int] -> [CodeLine] -> [(Int, CodeLine)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] ([CodeLine] -> [(Int, CodeLine)])
-> [CodeLine] -> [(Int, CodeLine)]
forall a b. (a -> b) -> a -> b
$ SourceCode -> [CodeLine]
coerce SourceCode
sc
  isMatch' :: Regex -> Text -> Bool
isMatch'    = \Regex
p Text
t -> Regex -> Text -> Bool
isMatch Regex
p (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
  allComments :: [(a, (LineType, b))] -> Bool
allComments = ((a, (LineType, b)) -> Bool) -> [(a, (LineType, b))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(a
_, (LineType
lt, b
_)) -> LineType
lt LineType -> LineType -> Bool
forall a. Eq a => a -> a -> Bool
== LineType
Comment)
  hasStart :: [(Int, CodeLine)] -> Bool
hasStart    = Bool -> ((Int, CodeLine) -> Bool) -> Maybe (Int, CodeLine) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\(Int
_, (LineType
_, Text
t)) -> Regex -> Text -> Bool
isMatch' Regex
start Text
t) (Maybe (Int, CodeLine) -> Bool)
-> ([(Int, CodeLine)] -> Maybe (Int, CodeLine))
-> [(Int, CodeLine)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, CodeLine)] -> Maybe (Int, CodeLine)
forall a. [a] -> Maybe a
L.headMaybe
  hasEnd :: [(Int, CodeLine)] -> Bool
hasEnd      = Bool -> ((Int, CodeLine) -> Bool) -> Maybe (Int, CodeLine) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\(Int
_, (LineType
_, Text
t)) -> Regex -> Text -> Bool
isMatch' Regex
end Text
t) (Maybe (Int, CodeLine) -> Bool)
-> ([(Int, CodeLine)] -> Maybe (Int, CodeLine))
-> [(Int, CodeLine)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, CodeLine)] -> Maybe (Int, CodeLine)
forall a. [a] -> Maybe a
L.lastMaybe
  position :: Maybe (Int, Int)
position    = (,) (Int -> Int -> (Int, Int))
-> Maybe Int -> Maybe (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe [Int]
header Maybe [Int] -> ([Int] -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> Maybe Int
forall a. [a] -> Maybe a
L.headMaybe) Maybe (Int -> (Int, Int)) -> Maybe Int -> Maybe (Int, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe [Int]
header Maybe [Int] -> ([Int] -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> Maybe Int
forall a. [a] -> Maybe a
L.lastMaybe)
  header :: Maybe [Int]
header =
    (([(Int, CodeLine)] -> [Int])
-> Maybe [(Int, CodeLine)] -> Maybe [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([(Int, CodeLine)] -> [Int])
 -> Maybe [(Int, CodeLine)] -> Maybe [Int])
-> (((Int, CodeLine) -> Int) -> [(Int, CodeLine)] -> [Int])
-> ((Int, CodeLine) -> Int)
-> Maybe [(Int, CodeLine)]
-> Maybe [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, CodeLine) -> Int) -> [(Int, CodeLine)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Int, CodeLine) -> Int
forall a b. (a, b) -> a
fst
      (Maybe [(Int, CodeLine)] -> Maybe [Int])
-> ([(Int, CodeLine)] -> Maybe [(Int, CodeLine)])
-> [(Int, CodeLine)]
-> Maybe [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Int, CodeLine)] -> Bool)
-> [[(Int, CodeLine)]] -> Maybe [(Int, CodeLine)]
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\[(Int, CodeLine)]
g -> [(Int, CodeLine)] -> Bool
forall a b. [(a, (LineType, b))] -> Bool
allComments [(Int, CodeLine)]
g Bool -> Bool -> Bool
&& [(Int, CodeLine)] -> Bool
hasStart [(Int, CodeLine)]
g Bool -> Bool -> Bool
&& [(Int, CodeLine)] -> Bool
hasEnd [(Int, CodeLine)]
g)
      ([[(Int, CodeLine)]] -> Maybe [(Int, CodeLine)])
-> ([(Int, CodeLine)] -> [[(Int, CodeLine)]])
-> [(Int, CodeLine)]
-> Maybe [(Int, CodeLine)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, CodeLine) -> (Int, CodeLine) -> Bool)
-> [(Int, CodeLine)] -> [[(Int, CodeLine)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (\(Int
_, (LineType
lt1, Text
_)) (Int
_, (LineType
lt2, Text
_)) -> LineType
lt1 LineType -> LineType -> Bool
forall a. Eq a => a -> a -> Bool
== LineType
lt2)
      ([(Int, CodeLine)] -> Maybe [Int])
-> [(Int, CodeLine)] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ [(Int, CodeLine)]
ls


-- | Finds header in the form of /single-line comment/ syntax, which is
-- delimited with the prefix pattern.
--
-- >>> :set -XQuasiQuotes
-- >>> import Headroom.Data.Regex (re)
-- >>> let sc = SourceCode [(Code, ""), (Code, "a"), (Comment, "-- first"), (Comment, "-- second"), (Code, "foo")]
-- >>> findLineHeader [re|^--|] sc 0
-- Just (2,3)
findLineHeader :: Regex
               -- ^ prefix pattern (e.g. @--@ or @//@)
               -> SourceCode
               -- ^ source code in which to detect the header
               -> Int
               -- ^ line number offset (adds to resulting position)
               -> Maybe (Int, Int)
               -- ^ header position @(startLine + offset, endLine + offset)@
findLineHeader :: Regex -> SourceCode -> Int -> Maybe (Int, Int)
findLineHeader Regex
prefix SourceCode
sc Int
offset = (Int -> Int) -> (Int, Int) -> (Int, Int)
forall a b. (a -> b) -> (a, a) -> (b, b)
mapT2 (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset) ((Int, Int) -> (Int, Int)) -> Maybe (Int, Int) -> Maybe (Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, Int)
position
 where
  ls :: [(Int, CodeLine)]
ls       = [Int] -> [CodeLine] -> [(Int, CodeLine)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] ([CodeLine] -> [(Int, CodeLine)])
-> [CodeLine] -> [(Int, CodeLine)]
forall a b. (a -> b) -> a -> b
$ SourceCode -> [CodeLine]
coerce SourceCode
sc
  isMatch' :: Regex -> Text -> Bool
isMatch' = \Regex
p Text
t -> Regex -> Text -> Bool
isMatch Regex
p (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
  position :: Maybe (Int, Int)
position = (,) (Int -> Int -> (Int, Int))
-> Maybe Int -> Maybe (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe [Int]
header Maybe [Int] -> ([Int] -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> Maybe Int
forall a. [a] -> Maybe a
L.headMaybe) Maybe (Int -> (Int, Int)) -> Maybe Int -> Maybe (Int, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe [Int]
header Maybe [Int] -> ([Int] -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> Maybe Int
forall a. [a] -> Maybe a
L.lastMaybe)
  header :: Maybe [Int]
header =
    (([(Int, CodeLine)] -> [Int])
-> Maybe [(Int, CodeLine)] -> Maybe [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([(Int, CodeLine)] -> [Int])
 -> Maybe [(Int, CodeLine)] -> Maybe [Int])
-> (((Int, CodeLine) -> Int) -> [(Int, CodeLine)] -> [Int])
-> ((Int, CodeLine) -> Int)
-> Maybe [(Int, CodeLine)]
-> Maybe [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, CodeLine) -> Int) -> [(Int, CodeLine)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Int, CodeLine) -> Int
forall a b. (a, b) -> a
fst
      (Maybe [(Int, CodeLine)] -> Maybe [Int])
-> ([(Int, CodeLine)] -> Maybe [(Int, CodeLine)])
-> [(Int, CodeLine)]
-> Maybe [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Int, CodeLine)] -> Bool)
-> [[(Int, CodeLine)]] -> Maybe [(Int, CodeLine)]
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (((Int, CodeLine) -> Bool) -> [(Int, CodeLine)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Int
_, (LineType
lt, Text
t)) -> LineType
lt LineType -> LineType -> Bool
forall a. Eq a => a -> a -> Bool
== LineType
Comment Bool -> Bool -> Bool
&& Regex -> Text -> Bool
isMatch' Regex
prefix Text
t))
      ([[(Int, CodeLine)]] -> Maybe [(Int, CodeLine)])
-> ([(Int, CodeLine)] -> [[(Int, CodeLine)]])
-> [(Int, CodeLine)]
-> Maybe [(Int, CodeLine)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, CodeLine) -> (Int, CodeLine) -> Bool)
-> [(Int, CodeLine)] -> [[(Int, CodeLine)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (\(Int
_, (LineType
lt1, Text
_)) (Int
_, (LineType
lt2, Text
_)) -> LineType
lt1 LineType -> LineType -> Bool
forall a. Eq a => a -> a -> Bool
== LineType
lt2)
      ([(Int, CodeLine)] -> Maybe [Int])
-> [(Int, CodeLine)] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ [(Int, CodeLine)]
ls


-- | Splits input source code into three parts:
--
--     1. all lines located before the very last occurence of one of the
--        conditions from the first condition list
--     2. all lines between the first and last lists
--     3. all lines located after the very first occurence of one of the
--        conditions from the second condition list
--
-- If both first and second patterns are empty, then all lines are returned in
-- the middle part.
--
-- >>> :set -XQuasiQuotes
-- >>> import Headroom.Data.Regex (re)
--
-- >>> let ls = [(Code, "text"), (Code, "->"), (Code, "RESULT"), (Code, "<-"), (Code, "foo")]
-- >>> splitSource [[re|->|]] [[re|<-|]] $ SourceCode ls
-- (SourceCode [(Code,"text"),(Code,"->")],SourceCode [(Code,"RESULT")],SourceCode [(Code,"<-"),(Code,"foo")])
--
-- >>> let ls = [(Code, "text"), (Code, "->"), (Code, "RESULT"), (Code, "<-"), (Code, "foo")]
-- >>> splitSource [] [[re|<-|]] $ SourceCode ls
-- (SourceCode [],SourceCode [(Code,"text"),(Code,"->"),(Code,"RESULT")],SourceCode [(Code,"<-"),(Code,"foo")])
--
-- >>> splitSource [] [] $ SourceCode [(Code,"foo"), (Code,"bar")]
-- (SourceCode [],SourceCode [(Code,"foo"),(Code,"bar")],SourceCode [])
splitSource :: [Regex]
            -> [Regex]
            -> SourceCode
            -> (SourceCode, SourceCode, SourceCode)
splitSource :: [Regex]
-> [Regex] -> SourceCode -> (SourceCode, SourceCode, SourceCode)
splitSource []    []    SourceCode
sc = (SourceCode
forall a. Monoid a => a
mempty, SourceCode
sc, SourceCode
forall a. Monoid a => a
mempty)
splitSource [Regex]
fstPs [Regex]
sndPs SourceCode
sc = (SourceCode
before, SourceCode
middle, SourceCode
after)
 where
  allLines :: [CodeLine]
allLines          = SourceCode -> [CodeLine]
coerce SourceCode
sc
  (SourceCode
middle', SourceCode
after ) = ([CodeLine] -> SourceCode)
-> ([CodeLine], [CodeLine]) -> (SourceCode, SourceCode)
forall a b. (a -> b) -> (a, a) -> (b, b)
mapT2 [CodeLine] -> SourceCode
SourceCode (([CodeLine], [CodeLine]) -> (SourceCode, SourceCode))
-> ([CodeLine], [CodeLine]) -> (SourceCode, SourceCode)
forall a b. (a -> b) -> a -> b
$ Int -> [CodeLine] -> ([CodeLine], [CodeLine])
forall a. Int -> [a] -> ([a], [a])
L.splitAt Int
sndSplit [CodeLine]
allLines
  (SourceCode
before , SourceCode
middle) = ([CodeLine] -> SourceCode)
-> ([CodeLine], [CodeLine]) -> (SourceCode, SourceCode)
forall a b. (a -> b) -> (a, a) -> (b, b)
mapT2 [CodeLine] -> SourceCode
SourceCode (([CodeLine], [CodeLine]) -> (SourceCode, SourceCode))
-> ([CodeLine], [CodeLine]) -> (SourceCode, SourceCode)
forall a b. (a -> b) -> a -> b
$ Int -> [CodeLine] -> ([CodeLine], [CodeLine])
forall a. Int -> [a] -> ([a], [a])
L.splitAt Int
fstSplitAt (SourceCode -> [CodeLine]
coerce SourceCode
middle')
  fstSplitAt :: Int
fstSplitAt        = Int -> ((Int, CodeLine) -> Int) -> Maybe (Int, CodeLine) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 ((Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> ((Int, CodeLine) -> Int) -> (Int, CodeLine) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, CodeLine) -> Int
forall a b. (a, b) -> a
fst) (Maybe (Int, CodeLine) -> Int) -> Maybe (Int, CodeLine) -> Int
forall a b. (a -> b) -> a -> b
$ (CodeLine -> Maybe CodeLine) -> SourceCode -> Maybe (Int, CodeLine)
forall a. (CodeLine -> Maybe a) -> SourceCode -> Maybe (Int, a)
lastMatching ([Regex] -> CodeLine -> Maybe CodeLine
cond [Regex]
fstPs) SourceCode
middle'
  sndSplit :: Int
sndSplit          = Int -> ((Int, CodeLine) -> Int) -> Maybe (Int, CodeLine) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
len (Int, CodeLine) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, CodeLine) -> Int) -> Maybe (Int, CodeLine) -> Int
forall a b. (a -> b) -> a -> b
$ (CodeLine -> Maybe CodeLine) -> SourceCode -> Maybe (Int, CodeLine)
forall a. (CodeLine -> Maybe a) -> SourceCode -> Maybe (Int, a)
firstMatching ([Regex] -> CodeLine -> Maybe CodeLine
cond [Regex]
sndPs) SourceCode
sc
  len :: Int
len               = [CodeLine] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CodeLine]
allLines
  cond :: [Regex] -> CodeLine -> Maybe CodeLine
cond              = \[Regex]
ps cl :: CodeLine
cl@(LineType
lt, Text
t) ->
    if LineType
lt LineType -> LineType -> Bool
forall a. Eq a => a -> a -> Bool
== LineType
Code Bool -> Bool -> Bool
&& (Regex -> Bool) -> [Regex] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Regex -> Text -> Bool
`isMatch` Text
t) [Regex]
ps then CodeLine -> Maybe CodeLine
forall a. a -> Maybe a
Just CodeLine
cl else Maybe CodeLine
forall a. Maybe a
Nothing



mapT2 :: (a -> b) -> (a, a) -> (b, b)
mapT2 :: (a -> b) -> (a, a) -> (b, b)
mapT2 = ((a -> b) -> (a -> b) -> (a, a) -> (b, b))
-> (a -> b) -> (a, a) -> (b, b)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (a -> b) -> (a -> b) -> (a, a) -> (b, b)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***)