module DDC.Driver.Command.Trans
( cmdTransDetect
, cmdTransModule
, cmdTransExp
, cmdTransExpCont
, transExp)
where
import DDC.Driver.Config
import DDC.Driver.Output
import DDC.Driver.Command.Check
import DDC.Build.Language
import DDC.Build.Pipeline
import DDC.Interface.Source
import DDC.Core.Transform.Reannotate
import DDC.Core.Load
import DDC.Core.Fragment
import DDC.Core.Simplifier
import DDC.Core.Exp
import DDC.Core.Compounds
import DDC.Type.Equiv
import DDC.Type.Subsumes
import DDC.Base.Pretty
import DDC.Core.Module
import Data.Typeable
import Control.Monad
import Control.Monad.Trans.Error
import Control.Monad.IO.Class
import DDC.Type.Env as Env
import qualified DDC.Core.Check as C
import qualified Control.Monad.State.Strict as S
cmdTransDetect
:: Config
-> Language
-> Bool
-> Source
-> String
-> ErrorT String IO ()
cmdTransDetect config language shouldPrintInfo
source str
| "module" : _ <- words str
= cmdTransModule config language shouldPrintInfo
source str
| otherwise
= cmdTransExp config language shouldPrintInfo
source str
cmdTransModule
:: Config
-> Language
-> Bool
-> Source
-> String
-> ErrorT String IO ()
cmdTransModule config language _shouldPrintInfo source str
| Language bundle <- language
, fragment <- bundleFragment bundle
, simpl <- bundleSimplifier bundle
, zero <- bundleStateInit bundle
= let
pmode = prettyModeOfConfig $ configPretty config
pipeTrans
= pipeText (nameOfSource source) (lineStartOfSource source) str
$ PipeTextLoadCore fragment
(if configInferTypes config then C.Synth else C.Recon)
SinkDiscard
[ PipeCoreReannotate (\a -> a { annotTail = ()})
[ PipeCoreSimplify fragment zero simpl
[ PipeCoreCheck fragment C.Recon SinkDiscard
[ PipeCoreOutput pmode SinkStdout ]]]]
in do
errs <- liftIO pipeTrans
case errs of
[] -> return ()
es -> throwError $ renderIndent $ vcat $ map ppr es
cmdTransExp
:: Config
-> Language
-> Bool
-> Source
-> String
-> ErrorT String IO ()
cmdTransExp config language traceTrans
source str
= liftIO
$ cmdTransExpCont config traceTrans language
(\_ -> return ())
source str
cmdTransExpCont
:: Config
-> Bool
-> Language
-> (forall n. Typeable n
=> Exp (AnTEC () n) n -> IO ())
-> Source
-> String
-> IO ()
cmdTransExpCont _config traceTrans language eatExp source str
| Language bundle <- language
, fragment <- bundleFragment bundle
, modules <- bundleModules bundle
, simpl <- bundleSimplifier bundle
, zero <- bundleStateInit bundle
, profile <- fragmentProfile fragment
= cmdParseCheckExp fragment modules Recon False False source str
>>= goStore profile modules zero simpl
where
goStore profile modules zero simpl (Just x, _)
= do let kenv = modulesExportTypes modules (profilePrimKinds profile)
let tenv = modulesExportValues modules (profilePrimTypes profile)
tr <- transExp traceTrans profile kenv tenv zero simpl
$ reannotate (\a -> a { annotTail = ()}) x
case tr of
Nothing -> return ()
Just x'
-> do outDocLn $ ppr x'
eatExp x'
goStore _ _ _ _ _
= do return ()
transExp
:: (Eq n, Ord n, Pretty n, Show n)
=> Bool
-> Profile n
-> KindEnv n
-> TypeEnv n
-> s
-> Simplifier s (AnTEC () n) n
-> Exp (AnTEC () n) n
-> IO (Maybe (Exp (AnTEC () n) n))
transExp traceTrans profile kenv tenv zero simpl xx
= do
let annot = annotOfExp xx
let t1 = annotType annot
let eff1 = annotEffect annot
let clo1 = annotClosure annot
let tx = flip S.evalState zero
$ applySimplifierX profile kenv tenv simpl xx
let x' = reannotate (const ()) $ result tx
when (traceTrans)
$ case (resultInfo tx) of
TransformInfo inf
-> outDocLn
$ text "* TRANSFORM INFORMATION: " <$> indent 4 (ppr inf) <$> text ""
case fst $ C.checkExp (C.configOfProfile profile) kenv tenv x' Recon of
Right (x2, t2, eff2, clo2)
| equivT t1 t2
, subsumesT kEffect eff1 eff2
, subsumesT kClosure clo1 clo2
-> do return (Just x2)
| otherwise
-> do outDocLn $ vcat
[ text "* CRASH AND BURN: Transform is not type preserving."
, ppr x'
, text ":: 1 " <+> ppr t1
, text ":: 2 " <+> ppr t2
, text ":!:1 " <+> ppr eff1
, text ":!:2 " <+> ppr eff2
, text ":$:1 " <+> ppr clo1
, text ":$:2 " <+> ppr clo2 ]
return Nothing
Left err
-> do outDocLn $ vcat
[ text "* CRASH AND BURN: Type error in transformed program."
, ppr err
, text "" ]
outDocLn $ text "Transformed expression:"
outDocLn $ ppr x'
return Nothing