diff --git a/src/Ohua/Stage.hs b/src/Ohua/Stage.hs new file mode 100644 index 0000000..a73d3b9 --- /dev/null +++ b/src/Ohua/Stage.hs @@ -0,0 +1,11 @@ +module Ohua.Stage (stage) where + +import Ohua.Prelude + +stage :: (MonadReadEnvironment m, MonadIO m, Show code, Pretty code) => StageName -> code -> m () +stage stName code = do + stageH <- fromEnv stageHandling + let (dumpInstructions, shouldAbort) = stageH stName + + + when shouldAbort exitSuccess diff --git a/src/Ohua/Types.hs b/src/Ohua/Types.hs index a49b71a..f1be9b6 100644 --- a/src/Ohua/Types.hs +++ b/src/Ohua/Types.hs @@ -46,9 +46,6 @@ module Ohua.Types , NameGenerator , simpleNameList , takenNames - , callEnvExpr - , callLocalFunction - , transformRecursiveFunctions , options , Annotated(Annotated) , TyExprF(..) @@ -358,11 +355,20 @@ type instance SourceType (OhuaState envExpr) = instance Make (OhuaState envExpr) where make (ng, fnid, exprs) = pure $ OhuaState ng fnid exprs +type StageName = Text +type AbortCompilation = Bool +data DumpCode + = Don'tDump + | DumpShow + | DumpPretty + | DumpOther Text +type StageHandling = StageName -> (AbortCompilation, DumpCode) + -- | The read only compiler environment -newtype Environment = Environment Options +newtype Environment = Environment Options StageHandling instance Default Environment where - def = Environment def + def = Environment def (const (Don'tDump, True)) nameGenerator :: Lens' (OhuaState envExpr) NameGenerator nameGenerator f (OhuaState gen counter envExprs) = @@ -404,7 +410,10 @@ transformRecursiveFunctions :: Lens' Options Bool transformRecursiveFunctions f (Options c l e) = f e <&> Options c l options :: Lens' Environment Options -options f (Environment opts) = Environment <$> f opts +options f (Environment opts s) = (\a -> Environment a s) <$> f opts + +stageHandling :: Lens' Environment Options +stageHandling f (Environment opts s) = Environment opts <$> f s -- | Generic way of attaching arbitrary, alterable data to some type. --