content: {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  module HaskellCodeExplorer.Preprocessor
    ( createSourceCodeTransformation
    ) where
  
  import Control.Applicative ((<|>))
  import qualified Data.Attoparsec.Text as AT
  import Data.Foldable (foldl')
  import qualified Data.HashMap.Strict as HM
  import qualified Data.List as L
  import qualified Data.Set as S
  import qualified Data.Text as T
  import HaskellCodeExplorer.Types
    ( FileLocation(..)
    , HaskellFilePath(..)
    , HaskellModulePath(..)
    , LinePragma(..)
    , SourceCodeTransformation(..)
    , haskellPreprocessorExtensions
    )
  import System.FilePath (normalise,takeExtension,takeFileName)
  
  -- | Finds locations of line pragmas and creates an index
  createSourceCodeTransformation ::
       HaskellModulePath -> T.Text -> T.Text -> (SourceCodeTransformation, T.Text)
  createSourceCodeTransformation currentModulePath originalSourceCode sourceCodeAfterPreprocessing =
    let sourceCodeLines = T.splitOn "\n" sourceCodeAfterPreprocessing
        numberedLines = zip [1 :: Int ..] sourceCodeLines
        currentFilePath =
          HaskellFilePath . getHaskellModulePath $ currentModulePath
        addPragma :: [LinePragma] -> (Int, T.Text) -> [LinePragma]
        addPragma acc (lineNumber, line) =
          case AT.parseOnly linePragmaParser line of
            Right (originalLineNumber, mbFileName) ->
              LinePragma
                (maybe
                   currentFilePath
                   (HaskellFilePath . T.pack . normalise . T.unpack)
                   mbFileName)
                lineNumber
                originalLineNumber :
              acc
            Left _ -> acc
        totalLines = length numberedLines
        pragmas = L.reverse . L.foldl' addPragma [] $ numberedLines
        pragmaPath = filePath :: LinePragma -> HaskellFilePath
        currentFileExtension =
          takeExtension . T.unpack . getHaskellFilePath $ currentFilePath
        standardHeaderFiles =
          [ "stdc-predef.h"
          , "cabal_macros.h"
          , "ghcversion.h"
          , "HsVersions.h"
          , "ghc_boot_platform.h"
          , "ghcautoconf.h"
          ]
        hasIncludedFiles =
          L.any
            ((\path ->
                let fileName = takeFileName . T.unpack . getHaskellFilePath $ path
                 in (path /= currentFilePath) &&
                    (path /= HaskellFilePath "<built-in>") &&
                    (path /= HaskellFilePath "<command-line>") &&
                    not ("ghc_" `L.isPrefixOf` fileName) &&
                    (fileName `notElem` standardHeaderFiles)) .
             pragmaPath)
            pragmas
     in if hasIncludedFiles ||
           currentFileExtension `elem` haskellPreprocessorExtensions
          then ( SourceCodeTransformation
                   totalLines
                   currentModulePath
                   (S.fromList pragmas)
                   (indexLocations totalLines currentFilePath pragmas)
               , sourceCodeAfterPreprocessing)
          else ( SourceCodeTransformation
                   (length $ T.splitOn "\n" originalSourceCode)
                   currentModulePath
                   S.empty
                   HM.empty
               , originalSourceCode)
  
  -- | Parses line pragma
  linePragmaParser :: AT.Parser (Int, Maybe T.Text)
  linePragmaParser = pragma1 <|> pragma2
    where
      pragma1 :: AT.Parser (Int, Maybe T.Text)
      pragma1 = parser "#" "line"
  
      pragma2 :: AT.Parser (Int, Maybe T.Text)
      pragma2 = parser "{-#" "LINE"
  
      parser :: T.Text -> T.Text -> AT.Parser (Int, Maybe T.Text)
      parser start line = do
        _ <- AT.string start
        _ <- AT.takeWhile (== ' ')
        _ <- AT.string line <|> return ""
        _ <- AT.takeWhile (== ' ')
        num <- AT.decimal
        _ <- AT.takeWhile (== ' ')
        mbName <- (Just <$> fileName) <|> return Nothing
        return (num, mbName)
  
      fileName :: AT.Parser T.Text
      fileName = AT.string "\"" *> AT.takeTill (== '\"') <* AT.string "\""
  
  data Line = FirstLine | LastLine Int | Pragma LinePragma deriving (Show,Eq)
  
  -- | Creates a HashMap whose keys are filenames and values are locations in a
  -- preprocessed source code
  indexLocations ::
       Int
    -> HaskellFilePath
    -> [LinePragma]
    -> HM.HashMap HaskellFilePath (S.Set FileLocation)
  indexLocations totalLines preprocessedFilePath pragmas =
    foldl' add HM.empty . (zip <*> tail) $
    (FirstLine : map Pragma pragmas) ++ [LastLine totalLines]
    where
      add ::
           HM.HashMap HaskellFilePath (S.Set FileLocation)
        -> (Line, Line)
        -> HM.HashMap HaskellFilePath (S.Set FileLocation)
      -- Interval between the first line and the first pragma
      add hMap (FirstLine, Pragma LinePragma {..})
        | lineNumberPreprocessed > 1 =
          HM.insertWith
            S.union
            preprocessedFilePath
            (S.singleton (FileLocation 1 lineNumberPreprocessed 0))
            hMap
        | otherwise = hMap
      -- Interval between two pragmas
      add hMap (Pragma (LinePragma fileName lineNumberPreprocessed1 lineNumberOriginal1),
                Pragma (LinePragma _ lineNumberPreprocessed2 _))
        | lineNumberPreprocessed2 - lineNumberPreprocessed1 > 1 =
          HM.insertWith
            S.union
            fileName
            (S.singleton
               (FileLocation
                  lineNumberOriginal1
                  (lineNumberOriginal1 +
                   (lineNumberPreprocessed2 - lineNumberPreprocessed1 - 2))
                  (lineNumberPreprocessed1 - lineNumberOriginal1 + 1)))
            hMap
        | otherwise = hMap
      -- Interval between the last pragma and the last line
      add hMap (Pragma (LinePragma fileName lineNumberPreprocessed lineNumberOriginal),
                LastLine lastLineNumberPreprocessed)
        | lastLineNumberPreprocessed - lineNumberPreprocessed > 1 =
          HM.insertWith
            S.union
            fileName
            (S.singleton
               (FileLocation
                  lineNumberOriginal
                  (lineNumberOriginal + (lastLineNumberPreprocessed - lineNumberPreprocessed - 2))
                  (lineNumberPreprocessed - lineNumberOriginal + 1)))
            hMap
        | otherwise = hMap
      add hMap _ = hMap
  