Set.hs

-- | Display and toggle active interpreter modes.
module DDCI.Core.Command.Set
        ( Mode(..)
        , cmdSet)
where
import DDCI.Core.State
import DDCI.Core.Mode
import DDCI.Core.Output
import DDC.Build.Builder
import DDC.Build.Language
import DDC.Core.Fragment
import DDC.Core.Simplifier.Parser
import DDC.Base.Pretty
import Control.Monad
import Data.Char
import Data.List
import qualified DDCI.Core.Rewrite		as R
import qualified Data.Map			as Map
import qualified Data.Set                       as Set


cmdSet ::  State -> String -> IO State

-- Display the active modes.
cmdSet state []
 | Language bundle      <- stateLanguage state
 , fragment             <- bundleFragment   bundle
 , modules              <- bundleModules    bundle
 , simpl                <- bundleSimplifier bundle
 = do
        let langName    = profileName (fragmentProfile fragment)

        putStrLn $ renderIndent
         $ vcat  [ text "Modes:      " <> text (show $ Set.toList $ stateModes state)
                 , text "Language:   " <> text langName
                 , text "Simplifier: " <> ppr  simpl
                 , text "Builder:    " <> text (show $ liftM builderName $ stateBuilder state) ]
         <$> vcat (text "With:       " : map ppr (Map.keys modules))
         <$> vcat (text "With Lite:  " : map ppr (Map.keys (stateWithLite state)))
         <$> vcat (text "With Salt:  " : map ppr (Map.keys (stateWithSalt state)))

        return state

-- Toggle active modes.
cmdSet state cmd
 | ["lang", name]       <- words cmd
 = do   case lookup name languages of
         Just language
          -> do putStrLn "ok"
                return $ state { stateLanguage = language }

         Nothing
          -> do putStrLn "unknown language"
                return state

 | "trans" : rest       <- words cmd
 , Language bundle      <- stateLanguage state
 , modules              <- bundleModules       bundle
 , rules                <- bundleRewriteRules  bundle 
 , mkNamT               <- bundleMakeNamifierT bundle
 , mkNamX               <- bundleMakeNamifierX bundle
 , fragment             <- bundleFragment      bundle
 = do   case parseSimplifier 
                (fragmentReadName fragment)
                (SimplifierDetails
                        mkNamT mkNamX 
                        (Map.assocs rules) 
                        (Map.elems  modules))
                (concat $ intersperse " " rest) of

         Left _err
          -> do putStrLn $ "transform spec parse error"
                return state

         Right simpl
          -> do chatStrLn state "ok"
                let bundle'     = bundle { bundleSimplifier = simpl }
                return $ state { stateLanguage = Language bundle' }


 | ("rule", rest)       <- R.parseFirstWord cmd
 , Language bundle      <- stateLanguage state
 , fragment             <- bundleFragment      bundle
 , modules              <- bundleModules       bundle
 , rules                <- bundleRewriteRules  bundle 
 = case R.parseRewrite fragment modules rest of
	Right (R.SetAdd name rule)
	 -> do	chatStrLn state $ "ok, added " ++ name
		let rules'  = Map.insert name rule rules
                let bundle' = bundle { bundleRewriteRules = rules' }
		return $ state { stateLanguage = Language bundle' }

	Right (R.SetRemove name)
	 -> do	chatStrLn state $ "ok, removed " ++ name
		let rules'  = Map.delete name rules
                let bundle' = bundle { bundleRewriteRules = rules' }
                return $ state { stateLanguage = Language bundle' }

	Right R.SetList
	 -> do	let rules' = Map.toList rules
		mapM_ (uncurry $ R.showRule state 0) rules'
		return state
	
	Left e
	 -> do	chatStrLn state e
		return state

 | "builder" : name : []     <- words cmd
 = do   config  <- getDefaultBuilderConfig
        case find (\b -> builderName b == name) (builders config) of
         Nothing
          -> do  putStrLn "unknown builder"
                 return state

         Just builder
          -> do  chatStrLn state "ok"
                 return state { stateBuilder = Just builder }

 | "outputdir" : dir : []    <- words cmd
 = return $ state { stateOutputDir  = Just dir }

 | "output" : file : []      <- words cmd
 = return $ state { stateOutputFile = Just file }

 | otherwise
 = case parseModeChanges cmd of
        Just changes
         -> do  let state'  = foldr (uncurry adjustMode) state changes
                chatStrLn state "ok"
                return state'
        
        Nothing
         -> do  chatStrLn state "mode parse error"
                return state


-- | Parse a string of mode changes.
parseModeChanges :: String -> Maybe [(Bool, Mode)]
parseModeChanges str
        = sequence $ map parseModeChange $ words str


-- | Parse a mode change setting.
--   "Mode" or "+Mode" to enable. "-Mode" to disable.
parseModeChange  :: String -> Maybe (Bool, Mode)
parseModeChange str
 = case str of
        ('+' : strMode)
         | Just mode    <- readMode strMode
         -> Just (True, mode)
        
        ('/' : strMode)
         | Just mode    <- readMode strMode
         -> Just (False, mode)

        (c : strMode)
         | isUpper c 
         , Just mode    <- readMode (c : strMode)
         -> Just (True, mode)

        _ -> Nothing