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.Core.Fragment
import DDC.Core.Simplifier.Parser
import DDC.Core.Transform.Reannotate
import DDC.Base.Pretty
import Control.Monad
import Data.Char
import Data.List
import qualified DDC.Build.Builder              as Build
import qualified DDC.Core.Check                 as Check
import qualified DDCI.Core.Rewrite              as R
import qualified Data.Map                       as Map
import qualified Data.Set                       as Set
import Prelude                                  hiding ((<$>))


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 Build.builderName $ stateBuilder state) ]
         <$> vcat (text "With:       " : map ppr (Map.keys modules))
         <$> 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 rule'   = reannotate (\a -> a { Check.annotTail = ()}) rule
                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
        mHost   <- Build.determineDefaultBuilderHost

        case mHost of
         Nothing
          -> do  putStrLn "cannot determine build environment"
                 return state

         Just host
          -> case find (\b -> Build.builderName b == name) 
                       (Build.builders config host) 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