GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 11:42:49 -06:00
Code Issues Packages Projects Releases Wiki Activity

Reduced clutter in monadic code

Browse Source 
+ 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.
This commit is contained in:
hallgren
2013-11-20 00:45:33 +00:00
parent ddac5f9e5a
commit 018c9838ed
21 changed files with 196 additions and 214 deletions
Download Patch File Download Diff File Expand all files Collapse all files

49
src/compiler/GF/Compile.hs
View File

@@ -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