{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# Language TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}
-- | Boolean instances
module Csound.Dynamic.Build.Logic(
    when1, whens,
    ifExp,
    ifElseBlock,
    -- ifBegin, ifEnd, elseBegin,
    untilBlock,
    whileBlock,

    -- untilDo,
    -- untilBegin, untilEnd,
    -- whileDo,
    -- whileBegin,
    whileRef, whileEnd
) where

import Control.Monad
import Control.Monad.Trans.State.Strict (State, state, evalState, runStateT, StateT(..))
import qualified Data.IntMap as IM(fromList)

import Data.Boolean
import Csound.Dynamic.Types
import Csound.Dynamic.Build(onExp, toExp)
import Data.List qualified as List
import Data.Fix

ifT :: forall m . Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m E
ifT ifRate check (DepT th) (DepT el) = DepT $ StateT $ \s -> do
  (_thE, thS) <- runStateT th (startSt s)
  (_elE, elS) <- runStateT el (startSt thS)
  let thDeps = expDependency thS
      elDeps = expDependency elS
      a  = noRate $ IfElseBlock ifRate (condInfo $ setIfRate ifRate check) (CodeBlock $ PrimOr $ Right thDeps) (CodeBlock $ PrimOr $ Right elDeps)
      a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum elS) }
      s1 = elS
            { newLineNum = succ $ newLineNum elS
            , expDependency = a1
            -- depends (expDependency thS) (depends (expDependency elS) a1)
            }
  pure (a1, s1)
  where
    startSt s = s
      { expDependency = rehashE $ Fix $ (unFix $ noRate Starts) { ratedExpDepends = Just (newLineNum s) }
      , newLineNum = succ $ newLineNum s
      }


ifT1, untilT, whileT :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m E

ifT1 = ifT1By IfBlock
untilT = ifT1By UntilBlock
whileT = ifT1By WhileBlock

ifT1By :: Monad m
  => (IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E)
  -> IfRate -> E -> DepT m (CodeBlock E) -> DepT m E
ifT1By cons ifRate check (DepT th) = DepT $ StateT $ \s -> do
  (_thE, thS)  <- runStateT th (startSt s)
  let thDeps = expDependency thS
      a  = noRate $ cons ifRate (condInfo $ setIfRate ifRate check) (CodeBlock $ PrimOr $ Right thDeps)
      a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum thS) }
      s1 = thS
            { newLineNum = succ $ newLineNum thS
            , expDependency = a1
            -- depends (expDependency thS) (depends (expDependency elS) a1)
            }
  pure (a1, s1)
  where
    startSt s = s
      { expDependency = rehashE $ Fix $ (unFix $ noRate Starts) { ratedExpDepends = Just (newLineNum s) }
      , newLineNum = succ $ newLineNum s
      }



------------------------------------------------------
-- imperative if-then-else

setIfRate :: IfRate -> E -> E
setIfRate rate = setRate (fromIfRate rate)

when1 :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()
when1 ifRate p body = void $ ifT1 ifRate p body

whens :: Monad m => IfRate -> [(E, DepT m (CodeBlock E))] -> DepT m (CodeBlock E) -> DepT m ()
whens rate bodies el =
  void $ List.foldl' go el (List.reverse bodies)
  where
    go res (check, th) = CodeBlock <$> ifT rate check th res

ifElseBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m ()
ifElseBlock rate p th el = void $ ifElseBlock rate p th el

{-
ifElseBlock' :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m (CodeBlock E)
ifElseBlock' ifRate p th el = do
  thE <- th
  elE <- el
  fmap CodeBlock $ depT $ noRate $
    IfElseBlock ifRate
      (condInfo $ setIfRate ifRate p)
      (PrimOr . Right <$> thE)
      (PrimOr . Right <$> elE)
-}
-- withCond ifRate stmt p = depT_ $ noRate $ stmt (condInfo $ setIfRate ifRate p)

{-
ifBegin :: Monad m => IfRate -> E -> DepT m ()
ifBegin ifRate = withCond ifRate $ (IfBegin ifRate)

elseBegin :: Monad m => DepT m ()
elseBegin = stmtOnlyT ElseBegin

ifEnd :: Monad m => DepT m ()
ifEnd = stmtOnlyT IfEnd
-}

untilBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()
untilBlock ifRate p body = void $ untilT ifRate p body

whileBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()
whileBlock ifRate p body = void $ whileT ifRate p body

{-
untilDo :: Monad m => IfRate -> E -> DepT m () -> DepT m ()
untilDo ifRate p body = do
    untilBegin ifRate p
    body
    untilEnd

untilBegin :: Monad m => IfRate -> E -> DepT m ()
untilBegin ifRate = withCond ifRate (UntilBegin ifRate)

untilEnd :: Monad m => DepT m ()
untilEnd = stmtOnlyT UntilEnd
-}

{-
whileDo :: Monad m => IfRate -> E -> DepT m () -> DepT m ()
whileDo ifRate p body = do
    whileBegin ifRate p
    body
    whileEnd

whileBegin :: Monad m => IfRate -> E -> DepT m ()
whileBegin ifRate = withCond IfKr (WhileBegin ifRate)
-}

whileRef :: Monad m => Var -> DepT m ()
whileRef var = stmtOnlyT $ WhileRefBegin var

whileEnd :: Monad m => DepT m ()
whileEnd = stmtOnlyT WhileEnd

{-
withCond :: Monad m => IfRate -> (CondInfo (PrimOr E) -> MainExp (PrimOr E)) -> E -> DepT m ()
withCond ifRate stmt p = depT_ $ noRate $ stmt (condInfo $ setIfRate ifRate p)
-}

instance Boolean E where
    true = boolOp0 TrueOp
    false = boolOp0 FalseOp
    notB = notE
    (&&*) = boolOp2 And
    (||*) = boolOp2 Or

-- instances

type instance BooleanOf E = E

instance EqB E where
    (==*) = boolOp2 Equals
    (/=*) = boolOp2 NotEquals

instance OrdB E where
    (<*) = boolOp2 Less
    (>*) = boolOp2 Greater
    (<=*) = boolOp2 LessEquals
    (>=*) = boolOp2 GreaterEquals

--------------------------------------------------------------------------
-- if-then-else
--
-- performs inlining of the boolean expressions

boolExp :: a -> [b] -> PreInline a b
boolExp = PreInline

ifExp :: IfRate -> E -> E -> E -> E
ifExp ifRate c = mkCond (condInfo (setIfRate ifRate c))
    where mkCond :: CondInfo (PrimOr E) -> E -> E -> E
          mkCond pr th el
            | isTrue pr = th
            | isFalse pr = el
            | otherwise = noRate $ If ifRate pr (toPrimOr th) (toPrimOr el)

condInfo :: E -> CondInfo (PrimOr E)
condInfo p = go $ toPrimOr p
    where
        go :: PrimOr E -> CondInfo (PrimOr E)
        go expr = (\(a, b) -> Inline a (IM.fromList b)) $ evalState (condInfo' expr) 0

        condInfo' :: PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)])
        condInfo' e = maybe (onLeaf e) (onExpr e) $ parseNode e

        onLeaf e = state $ \n -> ((InlinePrim n, [(n, e)]), n+1)

        onExpr  _ (op, args) = fmap mkNode $ mapM condInfo' args
            where mkNode as = (InlineExp op (map fst as), concat $ map snd as)

        parseNode :: PrimOr E -> Maybe (CondOp, [PrimOr E])
        parseNode x = case unPrimOr $ fmap toExp x of
          Right (ExpBool (PreInline op args)) -> Just (op, args)
          _ -> Nothing

--------------------------------------------------------------------------------
-- constructors for boolean expressions

boolOps :: CondOp -> [E] -> E
boolOps op as = noRate $ ExpBool $ boolExp op $ fmap toPrimOr as

boolOp0 :: CondOp -> E
boolOp2 :: CondOp -> E -> E -> E

boolOp0 op = boolOps op []

boolOp2 op a b = boolOps op [a, b]

-----------------------------------------------------------------------------
-- no support for not in csound so we perform not-elimination
notE :: E -> E
notE x = onExp phi x
    where phi (ExpBool (PreInline op args)) = ExpBool $ case op of
            TrueOp            -> boolExp FalseOp        []
            FalseOp           -> boolExp TrueOp         []
            And               -> boolExp Or             $ fmap (fmap notE) args
            Or                -> boolExp And            $ fmap (fmap notE) args
            Equals            -> boolExp NotEquals      args
            NotEquals         -> boolExp Equals         args
            Less              -> boolExp GreaterEquals  args
            Greater           -> boolExp LessEquals     args
            LessEquals        -> boolExp Greater        args
            GreaterEquals     -> boolExp Less           args

          phi _ = error "Logic.hs:notE - expression is not Boolean"