{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}
-- | Access to things that Debian policy says should be in a valid
-- control file.  The pure functions will not throw ControlFileError
-- if they are operating on a DebianControl value returned by
-- validateDebianControl.  However, they might if they are created
-- using unsafeDebianControl.
module Debian.Control.Policy
    ( -- * Validated debian control file type
      DebianControl(unDebianControl)
    , validateDebianControl
    , unsafeDebianControl
    , parseDebianControlFromFile
    , parseDebianControl
    , ControlFileError(..)
    -- * Class of things that contain one DebianControl value
    , HasDebianControl(debianControl)
    -- * Pure functions that operate on validated control files
    , debianSourceParagraph
    , debianBinaryParagraphs
    , debianPackageParagraphs
    , debianPackageNames
    , debianSourcePackageName
    , debianBinaryPackageNames
    , debianRelations
    , debianBuildDeps
    , debianBuildDepsIndep
    ) where

import Control.Exception (Exception, throw)
import Control.Monad.Catch (MonadCatch, try)
import Data.List (intercalate)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Data.ListLike (toList)
import Debian.Control.Common (Control'(..), Paragraph'(..), Field'(..), fieldValue, ControlFunctions(parseControlFromFile, parseControl))
import Debian.Control.Text ()
import Debian.Loc (__LOC__)
import Debian.Pretty (prettyShow)
import Debian.Relation (SrcPkgName(..), BinPkgName(..), Relations, parseRelations)
import Debian.Relation.Text ()
import Language.Haskell.TH (Loc(..))
import Prelude hiding (ioError)
-- import qualified Debug.ShowPlease as Please
import Text.Parsec.Error (ParseError)

-- | Opaque (constructor not exported) type to hold a validated Debian
-- Control File
data DebianControl = DebianControl {unDebianControl :: Control' Text}

instance Show DebianControl where
    show c = "(parseDebianControl \"\" " ++ show (prettyShow (unDebianControl c)) ++ ")"

-- | Validate and return a control file in an opaque wrapper.  May
-- throw a ControlFileError.  Currently we only verify that it has a
-- Source field in the first paragraph and one or more subsequent
-- paragraphs each with a Package field, and no syntax errors in the
-- build dependencies (though they may be absent.)
validateDebianControl :: MonadCatch m => Control' Text -> m (Either ControlFileError DebianControl)
validateDebianControl ctl =
    try (do _ <- return $ debianPackageNames (DebianControl ctl)
            _ <- return $ debianBuildDeps (DebianControl ctl)
            _ <- return $ debianBuildDepsIndep (DebianControl ctl)
            return ()) >>=
    return . either Left (\ _ -> Right $ DebianControl ctl)

unsafeDebianControl :: Control' Text -> DebianControl
unsafeDebianControl = DebianControl

parseDebianControl :: MonadCatch m => String -> Text -> m (Either ControlFileError DebianControl)
parseDebianControl sourceName s = either (return . Left . ParseControlError [$__LOC__]) validateDebianControl (parseControl sourceName s)

parseDebianControlFromFile :: FilePath -> IO (Either ControlFileError DebianControl)
parseDebianControlFromFile controlPath =
  try (parseControlFromFile controlPath) >>=
  either (return . Left . IOError [$__LOC__])
         (either (return . Left . ParseControlError [$__LOC__]) validateDebianControl)

-- | Class of things that contain a validated Debian control file.
class Show a => HasDebianControl a where
    debianControl :: a -> DebianControl

instance HasDebianControl DebianControl where
    debianControl = id

class HasControl a where
    control :: a -> Control' Text

instance HasControl (Control' Text) where
    control = id

instance HasControl DebianControl where
    control = unDebianControl

-- | Errors that control files might throw, with source file name and
-- line number generated by template haskell.
data ControlFileError
    = NoParagraphs        {locs :: [Loc]}
    | NoBinaryParagraphs  {locs :: [Loc], ctl :: String}
    | MissingField        {locs :: [Loc], field :: String}
    | ParseRelationsError {locs :: [Loc], parseError :: ParseError}
    | ParseControlError   {locs :: [Loc], parseError :: ParseError}
    | IOError             {locs :: [Loc], ioError :: IOError}
    deriving Typeable

instance Show ControlFileError where
    show (NoParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoParagraphs"
    show (NoBinaryParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoBinaryParagraphs"
    show (MissingField {..}) = intercalate ", " (map showLoc locs) ++ ": MissingField " ++ show field
    show (ParseRelationsError {..}) = intercalate ", " (map showLoc locs) ++ ": ParseRelationsError " ++ show parseError
    show (ParseControlError {..}) = intercalate ", " (map showLoc locs) ++ ": ParseControlError " ++ show parseError
    show (IOError {..}) = intercalate ", " (map showLoc locs) ++ ": IOError " ++ show ioError

showLoc :: Loc -> String
showLoc x = show (loc_filename x) ++ "(line " ++ show (fst (loc_start x)) ++ ", column " ++ show (snd (loc_start x)) ++ ")"

-- instance Please.Show ControlFileError where
--     show (IOError e) = "(IOError " ++ Please.show e ++ ")"
--     show (ParseRelationsError e) = "(ParseRelationsError " ++ Please.show e ++ ")"
--     show (ParseControlError e) = "(ParseControlError " ++ Please.show e ++ ")"
--     show x = show x

instance Exception ControlFileError

instance Eq ControlFileError where
    _ == _ = False

debianPackageParagraphs :: HasDebianControl a => a -> (Paragraph' Text, [Paragraph' Text])
debianPackageParagraphs ctl =
    case removeCommentParagraphs ctl of
      DebianControl (Control [_]) -> throw $ NoBinaryParagraphs [$__LOC__] (show ctl)
      DebianControl (Control []) -> throw $ NoParagraphs [$__LOC__]
      DebianControl (Control (sourceParagraph : binParagraphs)) -> (sourceParagraph, binParagraphs)

-- | Comment paragraphs are rare, but they happen.
removeCommentParagraphs :: HasDebianControl a => a -> DebianControl
removeCommentParagraphs c =
    DebianControl (Control (filter (not . isCommentParagraph) (unControl (unDebianControl (debianControl c)))))
    where
      isCommentParagraph (Paragraph fields) = all isCommentField fields
      isCommentField (Comment _) = True
      isCommentField _ = False

debianSourceParagraph :: HasDebianControl a => a -> Paragraph' Text
debianSourceParagraph = fst . debianPackageParagraphs

debianBinaryParagraphs :: HasDebianControl a => a -> [Paragraph' Text]
debianBinaryParagraphs = snd . debianPackageParagraphs

debianPackageNames :: HasDebianControl a => a -> (SrcPkgName, [BinPkgName])
debianPackageNames c =
  let (srcParagraph, binParagraphs) = debianPackageParagraphs c in
  (mapFieldValue (SrcPkgName . toList) "Source" srcParagraph, map (mapFieldValue (BinPkgName . toList) "Package") binParagraphs)

debianSourcePackageName :: HasDebianControl a => a -> SrcPkgName
debianSourcePackageName = fst . debianPackageNames

debianBinaryPackageNames :: HasDebianControl a => a -> [BinPkgName]
debianBinaryPackageNames = snd . debianPackageNames

debianBuildDepsIndep :: HasDebianControl a => a -> Maybe Relations
debianBuildDepsIndep ctl = either throw id $ debianRelations "Build-Depends-Indep" (debianControl ctl)

debianBuildDeps :: HasDebianControl a => a -> Maybe Relations
debianBuildDeps ctl = either throw id $ debianRelations "Build-Depends" (debianControl ctl)

-- | Version of fieldValue that may throw a ControlFileError.  We only
-- use this internally on fields that we already validated.
fieldValue' :: ControlFunctions text => String -> Paragraph' text -> text
fieldValue' fieldName paragraph = maybe (throw $ MissingField [$__LOC__] fieldName) id $ fieldValue fieldName paragraph

-- | This could access fields we haven't validated, so
-- it can return an error.  Additionally, the field might
-- be absent, in which case it returns Nothing.
debianRelations :: HasDebianControl a => String -> a -> Either ControlFileError (Maybe Relations)
debianRelations fieldName ctl = maybe (Right Nothing) (either (Left . ParseRelationsError [$__LOC__]) (Right . Just) . parseRelations) $ fieldValue fieldName (debianSourceParagraph ctl)

-- | Apply a function to the text from a named field in a control file paragraph.
mapFieldValue :: (Text -> a) -> String -> Paragraph' Text -> a
mapFieldValue f fieldName paragraph = f $ fieldValue' fieldName paragraph