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.Exp.Annot
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!"