    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE ViewPatterns #-}
    module Hpack.CabalFile where

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

    import           Hpack.Util

    makeVersion :: [Int] -> Version
    makeVersion v = Version v []

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

    readCabalFile :: FilePath -> IO (Maybe CabalFile)
    readCabalFile cabalFile = fmap parse <$> tryReadFile cabalFile
      where
        parse :: String -> CabalFile
        parse (splitHeader -> (h, c)) = CabalFile (extractVersion h) (extractHash h) c

        splitHeader :: String -> ([String], [String])
        splitHeader (removeGitConflictMarkers . lines -> c) =
          case span (not . isComment) c of
            (cabalVersion, xs) -> case span isComment xs of
              (header, body) -> (header, cabalVersion ++ dropWhile null body)

        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 = ">>>>>>> "