TransInteract.hs

module DDCI.Core.Command.TransInteract
        ( cmdTransInteract
	, cmdTransInteractLoop)
where
import DDCI.Core.Output
import DDCI.Core.State
import DDC.Driver.Command.Check
import DDC.Driver.Command.Trans
import DDC.Build.Language
import DDC.Core.Fragment
import DDC.Core.Simplifier.Parser
import DDC.Core.Transform.Reannotate
import DDC.Core.Compounds
import DDC.Core.Check
import DDC.Core.Module
import DDC.Base.Pretty
import qualified Data.Map       as Map
import qualified Data.Set       as Set


-- TransInteract --------------------------------------------------------------
-- | Apply the current transform to an expression.
cmdTransInteract :: State -> Source -> String -> IO State
cmdTransInteract state source str
 | Language bundle      <- stateLanguage state
 , fragment             <- bundleFragment   bundle
 , modules              <- bundleModules    bundle
 =   cmdParseCheckExp fragment modules Recon False False source str 
 >>= goStore bundle
 where
        -- Expression is well-typed.
        goStore bundle (Just xx, _)
         = do   
                let xx'         = reannotate (\a -> a { annotTail = () }) xx
                let annot       = annotOfExp xx'
                let t1          = annotType annot
                let eff1        = annotEffect annot
                let clo1        = annotClosure annot

                let hist   = TransHistory
			     { historyExp	    = (xx', t1, eff1, clo1)
			     , historySteps	    = []
                             , historyBundle        = bundle }

		return state { stateTransInteract = Just hist }

        -- Expression had a parse or type error.
        goStore _ _
         = do   return state
        

cmdTransInteractLoop :: State -> String -> IO State
cmdTransInteractLoop state str
 | Just hist    <- stateTransInteract state
 , TransHistory (x,t,e,c) steps bundle <- hist
 , fragment     <- bundleFragment bundle
 , profile      <- fragmentProfile fragment
 = case str of
    ":back" -> do
	let steps' = case steps of
		      []     -> []
		      (_:ss) -> ss

	putStrLn "Going back: "
	let x' = case steps' of
		   []    -> x
		   ((xz,_):_) -> xz
	outDocLn state $ ppr x'

	let hist'      = TransHistory (x,t,e,c) steps' bundle
	return state { stateTransInteract = Just hist' }

    ":done" -> do
	let simps = reverse $ map (indent 4 . ppr . snd) steps
	outStrLn state "* TRANSFORM SEQUENCE:"
	mapM_ (outDocLn state) simps
	return state { stateTransInteract = Nothing }

    _	    -> do

 	let tr = parseSimplifier 
                    (fragmentReadName fragment)
		    (SimplifierDetails
                        (bundleMakeNamifierT bundle) 
                        (bundleMakeNamifierX bundle)
        		(Map.assocs $ bundleRewriteRules bundle) 
                        (Map.elems  $ bundleModules      bundle))
		    str

	let x' = case steps of
		[]    -> x
		((xz,_):_) -> xz

	case tr of
            Left _err -> do
                putStrLn "Error parsing simplifier"
                return state

	    Right tr' -> do
                let kenv    = modulesExportTypes
                                (bundleModules bundle) 
                                (profilePrimKinds profile)

                let tenv    = modulesExportValues
                                (bundleModules bundle) 
                                (profilePrimTypes profile)

		x_trans  <- transExp
                                (Set.member TraceTrans $ stateModes state)
                                profile kenv tenv
			        (bundleStateInit bundle) tr' x'

		case x_trans of
		    Nothing -> return state
		    Just x_trans' -> do
			outDocLn state $ ppr x_trans'
			let steps' = (x_trans', tr') : steps
		        let hist'  = TransHistory (x,t,e,c) steps' bundle
			return state { stateTransInteract = Just hist' }

 | otherwise = error "No transformation history!"