From 018c9838ed31571b699118ae75b1d62d5527fd77 Mon Sep 17 00:00:00 2001 From: hallgren Date: Wed, 20 Nov 2013 00:45:33 +0000 Subject: Reduced clutter in monadic code + Eliminated vairous ad-hoc coersion functions between specific monads (IO, Err, IOE, Check) in favor of more general lifting functions (liftIO, liftErr). + Generalized many basic monadic operations from specific monads to arbitrary monads in the appropriate class (MonadIO and/or ErrorMonad), thereby completely eliminating the need for lifting functions in lots of places. This can be considered a small step forward towards a cleaner compiler API and more malleable compiler code in general. --- src/compiler/GF/Compile.hs | 49 +++++++++++++++++++++++----------------------- 1 file changed, 25 insertions(+), 24 deletions(-) (limited to 'src/compiler/GF/Compile.hs') diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index 00eec6e30..e22ded71e 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -51,8 +51,8 @@ link opts cnc gr = do putPointE Normal opts "linking ... " $ do let abs = err (const cnc) id $ abstractOfConcrete gr cnc pgf <- mkCanon2pgf opts gr abs - probs <- ioeIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf) - ioeIO $ when (verbAtLeast opts Normal) $ putStrFlush "OK" + probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf) + when (verbAtLeast opts Normal) $ putStrE "OK" return $ setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf @@ -73,14 +73,14 @@ compileSourceGrammar opts gr = do -- to output an intermediate stage intermOut :: Options -> Dump -> Doc -> IOE () intermOut opts d doc - | dump opts d = ioeIO (hPutStrLn stderr (render (text "\n\n--#" <+> text (show d) $$ doc))) + | dump opts d = ePutStrLn (render (text "\n\n--#" <+> text (show d) $$ doc)) | otherwise = return () warnOut opts warnings | null warnings = return () - | otherwise = ioeIO $ hPutStrLn stderr ws `catch` oops + | otherwise = liftIO $ ePutStrLn ws `catch` oops where - oops _ = hPutStrLn stderr "" -- prevent crash on character encoding problem + oops _ = ePutStrLn "" -- prevent crash on character encoding problem ws = if flag optVerbosity opts == Normal then '\n':warnings else warnings @@ -99,37 +99,37 @@ compileModule opts1 env file = do file <- getRealFile file opts0 <- getOptionsFromFile file curr_dir <- return $ dropFileName file - lib_dir <- ioeIO $ getLibraryDirectory (addOptions opts0 opts1) + lib_dir <- liftIO $ getLibraryDirectory (addOptions opts0 opts1) let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1 - ps0 <- ioeIO $ extendPathEnv opts + ps0 <- liftIO $ extendPathEnv opts let ps = nub (curr_dir : ps0) - ioeIO $ putIfVerb opts $ "module search path:" +++ show ps ---- + liftIO $ putIfVerb opts $ "module search path:" +++ show ps ---- let (_,sgr,rfs) = env files <- getAllFiles opts ps rfs file - ioeIO $ putIfVerb opts $ "files to read:" +++ show files ---- + liftIO $ putIfVerb opts $ "files to read:" +++ show files ---- let names = map justModuleName files - ioeIO $ putIfVerb opts $ "modules to include:" +++ show names ---- + liftIO $ putIfVerb opts $ "modules to include:" +++ show names ---- foldM (compileOne opts) (0,sgr,rfs) files where getRealFile file = do - exists <- ioeIO $ doesFileExist file + exists <- liftIO $ doesFileExist file if exists then return file else if isRelative file - then do lib_dir <- ioeIO $ getLibraryDirectory opts1 + then do lib_dir <- liftIO $ getLibraryDirectory opts1 let file1 = lib_dir file - exists <- ioeIO $ doesFileExist file1 + exists <- liftIO $ doesFileExist file1 if exists then return file1 - else ioeErr $ Bad (render (text "None of these files exists:" $$ nest 2 (text file $$ text file1))) - else ioeErr $ Bad (render (text "File" <+> text file <+> text "does not exist.")) + else raise (render (text "None of these files exists:" $$ nest 2 (text file $$ text file1))) + else raise (render (text "File" <+> text file <+> text "does not exist.")) compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv compileOne opts env@(_,srcgr,_) file = do let putpOpt v m act | verbAtLeast opts Verbose = putPointE Normal opts v act - | verbAtLeast opts Normal = ioeIO (putStrFlush m) >> act + | verbAtLeast opts Normal = putStrE m >> act | otherwise = putPointE Verbose opts v act let path = dropFileName file @@ -140,13 +140,14 @@ compileOne opts env@(_,srcgr,_) file = do -- for compiled gf, read the file and update environment -- also undo common subexp optimization, to enable normal computations ".gfo" -> do - sm00 <- putPointE Verbose opts ("+ reading" +++ file) $ ioeIO (decodeModule file) + sm00 <- putPointE Verbose opts ("+ reading" +++ file) $ liftIO (decodeModule file) let sm0 = (fst sm00, (snd sm00) {mflags = mflags (snd sm00) `addOptions` opts}) intermOut opts (Dump Source) (ppModule Internal sm0) let sm1 = unsubexpModule sm0 - (sm,warnings) <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ runCheck $ extendModule srcgr sm1 + (sm,warnings) <- {- putPointE Normal opts "creating indirections" $ -} + runCheck $ extendModule srcgr sm1 warnOut opts warnings if flag optTagsOnly opts @@ -158,14 +159,14 @@ compileOne opts env@(_,srcgr,_) file = do -- for gf source, do full compilation and generate code _ -> do - b1 <- ioeIO $ doesFileExist file + b1 <- liftIO $ doesFileExist file if not b1 then compileOne opts env $ (gf2gfo opts file) else do sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ getSourceModule opts file - enc <- ioeIO $ mkTextEncoding (renameEncoding (flag optEncoding (mflags (snd sm00)))) + enc <- liftIO $ mkTextEncoding (renameEncoding (flag optEncoding (mflags (snd sm00)))) let sm = decodeStringsInModule enc sm00 intermOut opts (Dump Source) (ppModule Internal sm) @@ -215,8 +216,8 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do idump pass = intermOut opts (Dump pass) . ppModule Internal -- * Impedance matching - runPass = runPass' fst fst snd (ioeErr . runCheck) - runPass2 = runPass2e ioeErr + runPass = runPass' fst fst snd (liftErr . runCheck) + runPass2 = runPass2e liftErr runPass2' = runPass2e id id Canon runPass2e lift f = runPass' id f (const "") lift @@ -234,7 +235,7 @@ writeGFO opts file mo = do let mo1 = subexpModule mo mo2 = case mo1 of (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)}) - putPointE Normal opts (" write file" +++ file) $ ioeIO $ encodeModule file mo2 + putPointE Normal opts (" write file" +++ file) $ liftIO $ encodeModule file mo2 -- auxiliaries @@ -247,7 +248,7 @@ extendCompileEnvInt (_,gr,menv) k mfile mo = do menv2 <- case mfile of Just file -> do let (mod,imps) = importsOfModule mo - t <- ioeIO $ getModificationTime file + t <- liftIO $ getModificationTime file return $ Map.insert mod (t,imps) menv _ -> return menv return (k,prependModule gr mo,menv2) --- reverse later -- cgit v1.2.3