CabalFile.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Hpack.CabalFile (
  CabalFile(..)
, GitConflictMarkers(..)
, ExistingCabalFile
, NewCabalFile
, readCabalFile
, parseVersion
#ifdef TEST
, extractVersion
, removeGitConflictMarkers
#endif
) where

import           Imports

import           Data.Maybe
import           Data.Version (Version(..))
import qualified Data.Version as Version
import           Text.ParserCombinators.ReadP

import           Hpack.Util

data CabalFile a = CabalFile {
  cabalFileCabalVersion :: [String]
, cabalFileHpackVersion :: Maybe Version
, cabalFileHash :: Maybe Hash
, cabalFileContents :: [String]
, cabalFileGitConflictMarkers :: a
} deriving (Eq, Show)

data GitConflictMarkers = HasGitConflictMarkers | DoesNotHaveGitConflictMarkers
  deriving (Show, Eq)

type ExistingCabalFile = CabalFile GitConflictMarkers
type NewCabalFile = CabalFile ()

readCabalFile :: FilePath -> IO (Maybe ExistingCabalFile)
readCabalFile cabalFile = fmap parseCabalFile <$> tryReadFile cabalFile

parseCabalFile :: String -> ExistingCabalFile
parseCabalFile (lines -> input) = case span isComment <$> span (not . isComment) clean of
  (cabalVersion, (header, body)) -> CabalFile {
    cabalFileCabalVersion = cabalVersion
  , cabalFileHpackVersion = extractVersion header
  , cabalFileHash = extractHash header
  , cabalFileContents = dropWhile null body
  , cabalFileGitConflictMarkers = gitConflictMarkers
  }
  where
    clean :: [String]
    clean = removeGitConflictMarkers input

    gitConflictMarkers :: GitConflictMarkers
    gitConflictMarkers
      | input == clean = DoesNotHaveGitConflictMarkers
      | otherwise = HasGitConflictMarkers

    isComment :: String -> Bool
    isComment = ("--" `isPrefixOf`)

extractHash :: [String] -> Maybe Hash
extractHash = extract "-- hash: " Just

extractVersion :: [String] -> Maybe Version
extractVersion = extract prefix (stripFileName >=> parseVersion . safeInit)
  where
    prefix = "-- This file has been generated from "
    stripFileName :: String -> Maybe String
    stripFileName = listToMaybe . mapMaybe (stripPrefix " by hpack version ") . tails

extract :: String -> (String -> Maybe a) -> [String] -> Maybe a
extract prefix parse = listToMaybe . mapMaybe (stripPrefix prefix >=> parse)

safeInit :: [a] -> [a]
safeInit [] = []
safeInit xs = init xs

parseVersion :: String -> Maybe Version
parseVersion xs = case [v | (v, "") <- readP_to_S Version.parseVersion xs] of
  [v] -> Just v
  _ -> Nothing

removeGitConflictMarkers :: [String] -> [String]
removeGitConflictMarkers = takeBoth
  where
    takeBoth input = case break (isPrefixOf marker) input of
      (both, _marker : rest) -> both ++ takeOurs rest
      (both, []) -> both
      where
        marker = "<<<<<<< "

    takeOurs input = case break (== marker) input of
      (ours, _marker : rest) -> ours ++ dropTheirs rest
      (ours, []) -> ours
      where
        marker = "======="

    dropTheirs input = case break (isPrefixOf marker) input of
      (_theirs, _marker : rest) -> takeBoth rest
      (_theirs, []) -> []
      where
        marker = ">>>>>>> "