{-# language DeriveFunctor #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}

module DhallToCabal.ConfigTree ( ConfigTree(..), toConfigTree ) where

import Control.Monad
import Data.Semigroup ( Semigroup ( (<>) ) )
import Dhall.Core hiding ( Const )


-- | 'ConfigTree' captures a logic-monad like expansion of the result of
-- Bool-valued expressions.

data ConfigTree cond a
  = Leaf a
  | Branch cond ( ConfigTree cond a ) ( ConfigTree cond a )
  deriving (Functor, Show)

instance Applicative ( ConfigTree cond ) where
  pure = Leaf
  (<*>) = ap

instance Monad ( ConfigTree cond ) where
  return = pure

  Leaf a >>= f = f a
  Branch cond l r >>= f = Branch cond ( l >>= f ) ( r >>= f )

instance ( Semigroup a ) => Semigroup ( ConfigTree cond a ) where
  (<>) = liftM2 (<>)

instance ( Monoid a ) => Monoid ( ConfigTree cond a ) where
  mempty = pure mempty
  mappend = liftM2 mappend


-- | Given a Dhall expression that is of the form @λ( config : Config ) -> a@,
-- find all saturated uses of @config@, and substitute in either @True@ or
-- @False@. The two substitutions are captured in a 'Branch'.

toConfigTree
  :: ( Eq a )
  => Expr s a
  -> ConfigTree ( Expr s a ) ( Expr s a )
toConfigTree e =
  let
    v =
      "config"

    saturated =
      normalize ( App e ( Var v ) )

    loop e =
      case normalize <$> rewriteConfigUse v e of
        Leaf a ->
          Leaf a

        Branch cond l r ->
          Branch cond ( loop =<< l ) ( loop =<< r )

  in loop saturated



-- | Find all config-like uses of a given variable, and expand them into all
-- possible results of evaluation.

rewriteConfigUse :: Var -> Expr s a -> ConfigTree (Expr s a) (Expr s a)
rewriteConfigUse v =
 transformMOf
   subExpressions
   ( \expr ->
       if isConfigUse expr then
         Branch
           expr
             ( pure ( BoolLit True ) )
             ( pure ( BoolLit False ) )
       else
         pure expr
   )

  where

    isConfigUse (App (Field (Var x') "os") _)           | v == x' = True
    isConfigUse (App (Field (Var x') "arch") _)         | v == x' = True
    isConfigUse (App (App (Field (Var x') "impl") _) _) | v == x' = True
    isConfigUse (App (Field (Var x') "flag") _)         | v == x' = True
    isConfigUse _ = False


-- | Transform every element in a tree using a user supplied 'Traversal' in a
-- bottom-up manner with a monadic effect.
transformMOf
  :: Monad m =>
  ( ( t -> m b ) -> t -> m a ) -> ( a -> m b ) -> t -> m b
transformMOf l f = go where
  go t = l go t >>= f
{-# INLINE transformMOf #-}