-- -*- Mode: Haskell; -*-
--
-- Environment is formed via evaluation of definitions. This module
-- describes minimal MIDA environment in form of monad transformer.
--
-- Copyright © 2014, 2015 Mark Karpov
--
-- MIDA is free software: you can redistribute it and/or modify it under the
-- terms of the GNU General Public License as published by the Free Software
-- Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- MIDA is distributed in the hope that it will be useful, but WITHOUT ANY
-- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
-- details.
--
-- You should have received a copy of the GNU General Public License along
-- with this program. If not, see <http://www.gnu.org/licenses/>.

module Mida.Language.Environment
  ( MidaEnv (..)
  , runMidaEnv
  , addDef
  , remDef
  , clearDefs
  , getPrin
  , getSrc
  , fullSrc
  , getRefs
  , purgeEnv
  , checkRecur
  , setRandGen
  , newRandGen )
where

import Control.Arrow ((***), (>>>))
import Control.Monad.State.Strict
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import System.Random (split)
import qualified Data.Map.Strict as M
import qualified Data.Text.Lazy as T

import System.Random.TF (TFGen, mkTFGen)

import Mida.Language.SyntaxTree
import Mida.Representation.Base (noteAlias, modifiers)
import Mida.Representation.Show (showDefinition)

data MidaEnvSt = MidaEnvSt
  { stDefs    :: Defs
  , stRandGen :: TFGen }

type Defs = M.Map String SyntaxTree

newtype MidaEnv m a = MidaEnv
  { unMidaEnv :: StateT MidaEnvSt m a }
  deriving ( Functor
           , Applicative
           , Monad
           , MonadState MidaEnvSt
           , MonadTrans
           , MonadIO )

runMidaEnv :: Monad m => MidaEnv m a -> m a
runMidaEnv e = evalStateT (unMidaEnv e) MidaEnvSt
               { stDefs    = defaultDefs
               , stRandGen = mkTFGen 0 }

defaultDefs :: Defs
defaultDefs = M.fromList $ zip noteAlias (f <$> [0..])
            <> zip modifiers (f <$> [128,256..])
  where f = return . Value

getDefs :: Monad m => MidaEnv m Defs
getDefs = gets stDefs

setDefs :: Monad m => Defs -> MidaEnv m ()
setDefs x = modify $ \e -> e { stDefs = x }

addDef :: Monad m => String -> SyntaxTree -> MidaEnv m ()
addDef name tree = M.insert name tree <$> getDefs >>= setDefs

remDef :: Monad m => String -> MidaEnv m ()
remDef name = M.delete name <$> getDefs >>= setDefs

clearDefs :: Monad m => MidaEnv m ()
clearDefs = setDefs defaultDefs

getPrin :: Monad m => String -> MidaEnv m SyntaxTree
getPrin name = (fromMaybe [] . M.lookup name) <$> getDefs

getSrc :: Monad m => String -> MidaEnv m T.Text
getSrc name = showDefinition name <$> getPrin name

fullSrc :: Monad m => MidaEnv m T.Text
fullSrc = (M.foldMapWithKey showDefinition . (M.\\ defaultDefs)) <$> getDefs

getRefs :: Monad m => MidaEnv m [String]
getRefs = M.keys <$> getDefs

tDefs :: String -> Defs -> [String]
tDefs name defs = maybe mzero cm $ name `M.lookup` defs
  where cm               = (>>= f)
        f (Value      _) = mempty
        f (Section    x) = cm x
        f (Multi      x) = cm x
        f (CMulti     x) = x >>= (cm *** cm >>> uncurry (<>))
        f (Reference  x) = return x <> tDefs x defs
        f (Range    _ _) = mempty
        f (Product  x y) = f x <> f y
        f (Division x y) = f x <> f y
        f (Sum      x y) = f x <> f y
        f (Diff     x y) = f x <> f y
        f (Loop     x y) = f x <> f y
        f (Rotation x y) = f x <> f y
        f (Reverse    x) = f x

purgeEnv :: Monad m => [String] -> MidaEnv m ()
purgeEnv tops = f <$> getDefs >>= setDefs
  where f defs = M.intersection defs $ M.unions [ts, ms defs, defaultDefs]
        ms     = M.unions . fmap toDefs . zipWith tDefs tops . repeat
        ts     = toDefs tops

checkRecur :: Monad m => String -> SyntaxTree -> MidaEnv m Bool
checkRecur name tree = check <$> getDefs
  where check = elem name . tDefs name . M.insert name tree

setRandGen :: Monad m => Int -> MidaEnv m ()
setRandGen x = modify $ \e -> e { stRandGen = mkTFGen x }

newRandGen :: Monad m => MidaEnv m TFGen
newRandGen = do
  (g, g') <- split <$> gets stRandGen
  modify $ \e -> e { stRandGen = g' }
  return g

toDefs :: [String] -> Defs
toDefs = M.fromList . fmap (, [])