{-# LANGUAGE DeriveDataTypeable #-}
# LANGUAGE DeriveGeneric #
# LANGUAGE DeriveFunctor #
# LANGUAGE DeriveFoldable #
{-# LANGUAGE DeriveTraversable #-}

module Distribution.Types.CondTree (
    CondTree(..),
    CondBranch(..),
    condIfThen,
    condIfThenElse,
    mapCondTree,
    mapTreeConstrs,
    mapTreeConds,
    mapTreeData,
    extractCondition,
    simplifyCondTree,
    ignoreConditions,
) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Types.Condition

-- | A 'CondTree' is used to represent the conditional structure of
  a Cabal file , reflecting a syntax element subject to constraints ,
-- and then any number of sub-elements which may be enabled subject
  to some condition .   Both @a@ and @c@ are usually ' Monoid 's .
--
-- To be more concrete, consider the following fragment of a @Cabal@
-- file:
--
-- @
  build - depends : base > = 4.0
  if flag(extra )
      build - depends : base > = 4.2
-- @
--
  One way to represent this is to have  ' ' ConfVar '
-- ['Dependency'] 'BuildInfo'@.  Here, 'condTreeData' represents
-- the actual fields which are not behind any conditional, while
-- 'condTreeComponents' recursively records any further fields
-- which are behind a conditional.  'condTreeConstraints' records
  the constraints ( in this case , @base > = 4.0@ ) which would
-- be applied if you use this syntax; in general, this is
-- derived off of 'targetBuildInfo' (perhaps a good refactoring
-- would be to convert this into an opaque type, with a smart
-- constructor that pre-computes the dependencies.)
--
data CondTree v c a = CondNode
    { condTreeData        :: a
    , condTreeConstraints :: c
    , condTreeComponents  :: [CondBranch v c a]
    }
    deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable)

instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a)

  | A ' CondBranch ' represents a conditional branch , e.g. , @if
  flag(foo)@ on some syntax    It also has an optional false
-- branch.
--
data CondBranch v c a = CondBranch
    { condBranchCondition :: Condition v
    , condBranchIfTrue    :: CondTree v c a
    , condBranchIfFalse   :: Maybe (CondTree v c a)
    }
    deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable)

  This instance is written by hand because GHC 8.0.1/8.0.2 infinite
-- loops when trying to derive it with optimizations.  See
-- 
instance Foldable (CondBranch v c) where
    foldMap f (CondBranch _ c Nothing) = foldMap f c
    foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a

instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a)

condIfThen :: Condition v -> CondTree v c a -> CondBranch v c a
condIfThen c t = CondBranch c t Nothing

condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a
condIfThenElse c t e = CondBranch c t (Just e)

mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w)
            -> CondTree v c a -> CondTree w d b
mapCondTree fa fc fcnd (CondNode a c ifs) =
    CondNode (fa a) (fc c) (map g ifs)
  where
    g (CondBranch cnd t me)
        = CondBranch (fcnd cnd)
                     (mapCondTree fa fc fcnd t)
                     (fmap (mapCondTree fa fc fcnd) me)

mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a
mapTreeConstrs f = mapCondTree id f id

mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a
mapTreeConds f = mapCondTree id id f

mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b
mapTreeData f = mapCondTree f id id


-- | Extract the condition matched by the given predicate from a cond tree.
--
-- We use this mainly for extracting buildable conditions (see the Note above),
-- but the function is in fact more general.
extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v
extractCondition p = go
  where
    go (CondNode x _ cs) | not (p x) = Lit False
                         | otherwise = goList cs

    goList []               = Lit True
    goList (CondBranch c t e : cs) =
      let
        ct = go t
        ce = maybe (Lit True) go e
      in
        ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs

-- | Flattens a CondTree using a partial flag assignment.  When a condition
-- cannot be evaluated, both branches are ignored.
simplifyCondTree :: (Monoid a, Monoid d) =>
                    (v -> Either v Bool)
                 -> CondTree v d a
                 -> (d, a)
simplifyCondTree env (CondNode a d ifs) =
    mconcat $ (d, a) : mapMaybe simplifyIf ifs
  where
    simplifyIf (CondBranch cnd t me) =
        case simplifyCondition cnd env of
          (Lit True, _) -> Just $ simplifyCondTree env t
          (Lit False, _) -> fmap (simplifyCondTree env) me
          _ -> Nothing

  | Flatten a CondTree .   This will resolve the CondTree by taking all
--  possible paths into account.  Note that since branches represent exclusive
   choices this may not result in a \"sane\ " result .
ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c)
ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs)
  where f (CondBranch _ t me) = ignoreConditions t
                       : maybeToList (fmap ignoreConditions me)

# LANGUAGE DeriveDataTypeable #
# LANGUAGE DeriveTraversable #
 | A 'CondTree' is used to represent the conditional structure of
 and then any number of sub-elements which may be enabled subject

 To be more concrete, consider the following fragment of a @Cabal@
 file:

 @
 @

 ['Dependency'] 'BuildInfo'@.  Here, 'condTreeData' represents
 the actual fields which are not behind any conditional, while
 'condTreeComponents' recursively records any further fields
 which are behind a conditional.  'condTreeConstraints' records
 be applied if you use this syntax; in general, this is
 derived off of 'targetBuildInfo' (perhaps a good refactoring
 would be to convert this into an opaque type, with a smart
 constructor that pre-computes the dependencies.)

 branch.

 loops when trying to derive it with optimizations.  See
 
 | Extract the condition matched by the given predicate from a cond tree.

 We use this mainly for extracting buildable conditions (see the Note above),
 but the function is in fact more general.
 | Flattens a CondTree using a partial flag assignment.  When a condition
 cannot be evaluated, both branches are ignored.
  possible paths into account.  Note that since branches represent exclusive
# LANGUAGE DeriveGeneric #
# LANGUAGE DeriveFunctor #
# LANGUAGE DeriveFoldable #

module Distribution.Types.CondTree (
    CondTree(..),
    CondBranch(..),
    condIfThen,
    condIfThenElse,
    mapCondTree,
    mapTreeConstrs,
    mapTreeConds,
    mapTreeData,
    extractCondition,
    simplifyCondTree,
    ignoreConditions,
) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Types.Condition

  a Cabal file , reflecting a syntax element subject to constraints ,
  to some condition .   Both @a@ and @c@ are usually ' Monoid 's .
  build - depends : base > = 4.0
  if flag(extra )
      build - depends : base > = 4.2
  One way to represent this is to have  ' ' ConfVar '
  the constraints ( in this case , @base > = 4.0@ ) which would
data CondTree v c a = CondNode
    { condTreeData        :: a
    , condTreeConstraints :: c
    , condTreeComponents  :: [CondBranch v c a]
    }
    deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable)

instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a)

  | A ' CondBranch ' represents a conditional branch , e.g. , @if
  flag(foo)@ on some syntax    It also has an optional false
data CondBranch v c a = CondBranch
    { condBranchCondition :: Condition v
    , condBranchIfTrue    :: CondTree v c a
    , condBranchIfFalse   :: Maybe (CondTree v c a)
    }
    deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable)

  This instance is written by hand because GHC 8.0.1/8.0.2 infinite
instance Foldable (CondBranch v c) where
    foldMap f (CondBranch _ c Nothing) = foldMap f c
    foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a

instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a)

condIfThen :: Condition v -> CondTree v c a -> CondBranch v c a
condIfThen c t = CondBranch c t Nothing

condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a
condIfThenElse c t e = CondBranch c t (Just e)

mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w)
            -> CondTree v c a -> CondTree w d b
mapCondTree fa fc fcnd (CondNode a c ifs) =
    CondNode (fa a) (fc c) (map g ifs)
  where
    g (CondBranch cnd t me)
        = CondBranch (fcnd cnd)
                     (mapCondTree fa fc fcnd t)
                     (fmap (mapCondTree fa fc fcnd) me)

mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a
mapTreeConstrs f = mapCondTree id f id

mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a
mapTreeConds f = mapCondTree id id f

mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b
mapTreeData f = mapCondTree f id id


extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v
extractCondition p = go
  where
    go (CondNode x _ cs) | not (p x) = Lit False
                         | otherwise = goList cs

    goList []               = Lit True
    goList (CondBranch c t e : cs) =
      let
        ct = go t
        ce = maybe (Lit True) go e
      in
        ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs

simplifyCondTree :: (Monoid a, Monoid d) =>
                    (v -> Either v Bool)
                 -> CondTree v d a
                 -> (d, a)
simplifyCondTree env (CondNode a d ifs) =
    mconcat $ (d, a) : mapMaybe simplifyIf ifs
  where
    simplifyIf (CondBranch cnd t me) =
        case simplifyCondition cnd env of
          (Lit True, _) -> Just $ simplifyCondTree env t
          (Lit False, _) -> fmap (simplifyCondTree env) me
          _ -> Nothing

  | Flatten a CondTree .   This will resolve the CondTree by taking all
   choices this may not result in a \"sane\ " result .
ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c)
ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs)
  where f (CondBranch _ t me) = ignoreConditions t
                       : maybeToList (fmap ignoreConditions me)
