{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
{-# LANGUAGE CPP #-}
-- , GADTs, PatternGuards #-}

#include "gadts.h"

module Darcs.Patch.Core
       ( Patch(..), Named(..),
         joinPatchesFL, concatFL, flattenFL,
         nullP, isNullPatch, infopatch,
         nFn,
         adddeps, namepatch, anonymous,
         mergerUndo, isMerger,
         getdeps,
         patch2patchinfo, patchname, patchcontents,
       )
       where

import Prelude hiding ( pi )
import Darcs.Patch.Info ( PatchInfo, patchinfo, makeFilename )
import Darcs.Patch.Patchy ( Patchy )
import Darcs.Witnesses.Ordered
import Darcs.Patch.Prim ( Prim(..), FromPrim(..), Effect(effect, effectRL), nFn )
#include "impossible.h"

data Patch C(x y) where
    PP :: Prim C(x y) -> Patch C(x y)
    ComP :: FL Patch C(x y) -> Patch C(x y)
    Merger :: Patch C(x y)
           -> RL Patch C(x b)
           -> Patch C(c b)
           -> Patch C(c d)
           -> Patch C(x y)
    Regrem :: Patch C(x y)
           -> RL Patch C(x b)
           -> Patch C(c b)
           -> Patch C(c a)
           -> Patch C(y x)

instance FromPrim Patch where
    fromPrim = PP

-- | The @Named@ type adds a patch info about a patch, that is a name.
data Named p C(x y) where
    NamedP :: !PatchInfo
           -> ![PatchInfo]
           -> !(p C(x y))
           -> Named p C(x y)
-- ^ @NamedP info deps p@ represents patch @p@ with name
-- @info@. @deps@ is a list of dependencies added at the named patch
-- level, compared with the unnamed level (ie, dependencies added with
-- @darcs record --ask-deps@).

instance Effect p => Effect (Named p) where
    effect (NamedP _ _ p) = effect p
    effectRL (NamedP _ _ p) = effectRL p

isNullPatch :: Patch C(x y) -> Bool
isNullPatch (ComP ps) = and $ mapFL isNullPatch ps
isNullPatch _ = False

nullP :: Patch C(x y) -> EqCheck C(x y)
nullP (ComP NilFL) = IsEq
nullP (ComP (x:>:xs)) | IsEq <- nullP x = nullP (ComP xs)
nullP _ = NotEq

isMerger :: Patch C(a b) -> Bool
isMerger (Merger _ _ _ _) = True
isMerger (Regrem _ _ _ _) = True
isMerger _ = False

mergerUndo :: Patch C(x y) -> Patch C(x y)
mergerUndo (Merger undo _ _ _) = undo
mergerUndo _ = impossible

{- INLINE flattenFL -}
flattenFL :: Patch C(x y) -> FL Patch C(x y)
flattenFL (ComP ps) = concatFL (mapFL_FL flattenFL ps)
flattenFL (PP Identity) = NilFL
flattenFL p = p :>: NilFL

joinPatchesFL :: FL Patch C(x y) -> Patch C(x y)
joinPatchesFL ps = ComP $! ps

infopatch :: Patchy p => PatchInfo -> p C(x y) -> Named p C(x y)
adddeps :: Named p C(x y) -> [PatchInfo] -> Named p C(x y)
getdeps :: Named p C(x y) -> [PatchInfo]

namepatch :: Patchy p => String -> String -> String -> [String] -> p C(x y) -> IO (Named p C(x y))
namepatch date name author desc p
    | '\n' `elem` name = error "Patch names cannot contain newlines."
    | otherwise = do pinf <- patchinfo date name author desc
                     return $ NamedP pinf [] p

anonymous :: Patchy p => p C(x y) -> IO (Named p C(x y))
anonymous p = namepatch "today" "anonymous" "unknown" ["anonymous"] p

infopatch pi p = NamedP pi [] p
adddeps (NamedP pi _ p) ds = NamedP pi ds p
getdeps (NamedP _ ds _) = ds

patch2patchinfo :: Named p C(x y) -> PatchInfo
patch2patchinfo (NamedP i _ _) = i

patchname :: Named p C(x y) -> String
patchname (NamedP i _ _) = makeFilename i

patchcontents :: Named p C(x y) -> p C(x y)
patchcontents (NamedP _ _ p) = p