msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests 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 c29326d074
commit c8cbd4477f
21 changed files with 196 additions and 214 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
src/compiler/GF.hs
View File

@@ -12,7 +12,6 @@ import Data.Version
import System.Directory import System.Directory
import System.Environment (getArgs) import System.Environment (getArgs)
import System.Exit import System.Exit
import System.IO
import GF.System.Console (setConsoleEncoding) import GF.System.Console (setConsoleEncoding)
main :: IO () main :: IO ()
@@ -23,8 +22,8 @@ main = do
Ok (opts,files) -> do curr_dir <- getCurrentDirectory Ok (opts,files) -> do curr_dir <- getCurrentDirectory
lib_dir <- getLibraryDirectory opts lib_dir <- getLibraryDirectory opts
mainOpts (fixRelativeLibPaths curr_dir lib_dir opts) files mainOpts (fixRelativeLibPaths curr_dir lib_dir opts) files
Bad err -> do hPutStrLn stderr err Bad err -> do ePutStrLn err
hPutStrLn stderr "You may want to try --help." ePutStrLn "You may want to try --help."
exitFailure exitFailure
mainOpts :: Options -> [FilePath] -> IO () mainOpts :: Options -> [FilePath] -> IO ()

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

@@ -51,8 +51,8 @@ link opts cnc gr = do
putPointE Normal opts "linking ... " $ do putPointE Normal opts "linking ... " $ do
let abs = err (const cnc) id $ abstractOfConcrete gr cnc let abs = err (const cnc) id $ abstractOfConcrete gr cnc
pgf <- mkCanon2pgf opts gr abs pgf <- mkCanon2pgf opts gr abs
probs <- ioeIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf) probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
ioeIO $ when (verbAtLeast opts Normal) $ putStrFlush "OK" when (verbAtLeast opts Normal) $ putStrE "OK"
return $ setProbabilities probs return $ setProbabilities probs
$ if flag optOptimizePGF opts then optimizePGF pgf else pgf $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
@@ -73,14 +73,14 @@ compileSourceGrammar opts gr = do
-- to output an intermediate stage -- to output an intermediate stage
intermOut :: Options -> Dump -> Doc -> IOE () intermOut :: Options -> Dump -> Doc -> IOE ()
intermOut opts d doc 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 () | otherwise = return ()
warnOut opts warnings warnOut opts warnings
| null warnings = return () | null warnings = return ()
| otherwise = ioeIO $ hPutStrLn stderr ws `catch` oops | otherwise = liftIO $ ePutStrLn ws `catch` oops
where where
oops _ = hPutStrLn stderr "" -- prevent crash on character encoding problem oops _ = ePutStrLn "" -- prevent crash on character encoding problem
ws = if flag optVerbosity opts == Normal ws = if flag optVerbosity opts == Normal
then '\n':warnings then '\n':warnings
else warnings else warnings
@@ -99,37 +99,37 @@ compileModule opts1 env file = do
file <- getRealFile file file <- getRealFile file
opts0 <- getOptionsFromFile file opts0 <- getOptionsFromFile file
curr_dir <- return $ dropFileName 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 let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
ps0 <- ioeIO $ extendPathEnv opts ps0 <- liftIO $ extendPathEnv opts
let ps = nub (curr_dir : ps0) 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 let (_,sgr,rfs) = env
files <- getAllFiles opts ps rfs file 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 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 foldM (compileOne opts) (0,sgr,rfs) files
where where
getRealFile file = do getRealFile file = do
exists <- ioeIO $ doesFileExist file exists <- liftIO $ doesFileExist file
if exists if exists
then return file then return file
else if isRelative file else if isRelative file
then do lib_dir <- ioeIO $ getLibraryDirectory opts1 then do lib_dir <- liftIO $ getLibraryDirectory opts1
let file1 = lib_dir </> file let file1 = lib_dir </> file
exists <- ioeIO $ doesFileExist file1 exists <- liftIO $ doesFileExist file1
if exists if exists
then return file1 then return file1
else ioeErr $ Bad (render (text "None of these files exists:" $$ nest 2 (text file $$ text file1))) else raise (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 "File" <+> text file <+> text "does not exist."))
compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
compileOne opts env@(_,srcgr,_) file = do compileOne opts env@(_,srcgr,_) file = do
let putpOpt v m act let putpOpt v m act
| verbAtLeast opts Verbose = putPointE Normal opts v 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 | otherwise = putPointE Verbose opts v act
let path = dropFileName file let path = dropFileName file
@@ -140,13 +140,14 @@ compileOne opts env@(_,srcgr,_) file = do
-- for compiled gf, read the file and update environment -- for compiled gf, read the file and update environment
-- also undo common subexp optimization, to enable normal computations -- also undo common subexp optimization, to enable normal computations
".gfo" -> do ".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}) let sm0 = (fst sm00, (snd sm00) {mflags = mflags (snd sm00) `addOptions` opts})
intermOut opts (Dump Source) (ppModule Internal sm0) intermOut opts (Dump Source) (ppModule Internal sm0)
let sm1 = unsubexpModule 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 warnOut opts warnings
if flag optTagsOnly opts if flag optTagsOnly opts
@@ -158,14 +159,14 @@ compileOne opts env@(_,srcgr,_) file = do
-- for gf source, do full compilation and generate code -- for gf source, do full compilation and generate code
_ -> do _ -> do
b1 <- ioeIO $ doesFileExist file b1 <- liftIO $ doesFileExist file
if not b1 if not b1
then compileOne opts env $ (gf2gfo opts file) then compileOne opts env $ (gf2gfo opts file)
else do else do
sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $
getSourceModule opts 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 let sm = decodeStringsInModule enc sm00
intermOut opts (Dump Source) (ppModule Internal sm) 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 idump pass = intermOut opts (Dump pass) . ppModule Internal
-- * Impedance matching -- * Impedance matching
runPass = runPass' fst fst snd (ioeErr . runCheck) runPass = runPass' fst fst snd (liftErr . runCheck)
runPass2 = runPass2e ioeErr runPass2 = runPass2e liftErr
runPass2' = runPass2e id id Canon runPass2' = runPass2e id id Canon
runPass2e lift f = runPass' id f (const "") lift runPass2e lift f = runPass' id f (const "") lift
@@ -234,7 +235,7 @@ writeGFO opts file mo = do
let mo1 = subexpModule mo let mo1 = subexpModule mo
mo2 = case mo1 of mo2 = case mo1 of
(m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)}) (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 -- auxiliaries
@@ -247,7 +248,7 @@ extendCompileEnvInt (_,gr,menv) k mfile mo = do
menv2 <- case mfile of menv2 <- case mfile of
Just file -> do Just file -> do
let (mod,imps) = importsOfModule mo let (mod,imps) = importsOfModule mo
t <- ioeIO $ getModificationTime file t <- liftIO $ getModificationTime file
return $ Map.insert mod (t,imps) menv return $ Map.insert mod (t,imps) menv
_ -> return menv _ -> return menv
return (k,prependModule gr mo,menv2) --- reverse later return (k,prependModule gr mo,menv2) --- reverse later

12
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -50,10 +50,10 @@ checkModule opts sgr mo@(m,mi) = do
checkRestrictedInheritance sgr mo checkRestrictedInheritance sgr mo
mo <- case mtype mi of mo <- case mtype mi of
MTConcrete a -> do let gr = prependModule sgr mo MTConcrete a -> do let gr = prependModule sgr mo
abs <- checkErr $ lookupModule gr a abs <- lookupModule gr a
checkCompleteGrammar opts gr (a,abs) mo checkCompleteGrammar opts gr (a,abs) mo
_ -> return mo _ -> return mo
infoss <- checkErr $ topoSortJments2 mo infoss <- topoSortJments2 mo
foldM updateCheckInfos mo infoss foldM updateCheckInfos mo infoss
where where
updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
@@ -246,7 +246,7 @@ checkInfo opts sgr (m,mo) c info = do
ResOverload os tysts -> chIn NoLoc "overloading" $ do ResOverload os tysts -> chIn NoLoc "overloading" $ do
tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones
tysts0 <- checkErr $ lookupOverload gr (m,c) -- check against inherited ones too tysts0 <- lookupOverload gr (m,c) -- check against inherited ones too
tysts1 <- mapM (uncurry $ flip (checkLType gr [])) tysts1 <- mapM (uncurry $ flip (checkLType gr []))
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0] [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
--- this can only be a partial guarantee, since matching --- this can only be a partial guarantee, since matching
@@ -267,7 +267,7 @@ checkInfo opts sgr (m,mo) c info = do
nest 2 (text "Happened in" <+> text cat <+> ppIdent c)) nest 2 (text "Happened in" <+> text cat <+> ppIdent c))
mkPar (f,co) = do mkPar (f,co) = do
vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
return $ map (mkApp (QC (m,f))) vs return $ map (mkApp (QC (m,f))) vs
checkUniq xss = case xss of checkUniq xss = case xss of
@@ -317,13 +317,13 @@ linTypeOfType cnc m typ = do
let vars = mkRecType varLabel $ replicate n typeStr let vars = mkRecType varLabel $ replicate n typeStr
symb = argIdent n cat i symb = argIdent n cat i
rec <- if n==0 then return val else rec <- if n==0 then return val else
checkErr $ errIn (render (text "extending" $$ errIn (render (text "extending" $$
nest 2 (ppTerm Unqualified 0 vars) $$ nest 2 (ppTerm Unqualified 0 vars) $$
text "with" $$ text "with" $$
nest 2 (ppTerm Unqualified 0 val))) $ nest 2 (ppTerm Unqualified 0 val))) $
plusRecType vars val plusRecType vars val
return (Explicit,symb,rec) return (Explicit,symb,rec)
lookLin (_,c) = checks [ --- rather: update with defLinType ? lookLin (_,c) = checks [ --- rather: update with defLinType ?
checkErr (lookupLincat cnc m c) >>= computeLType cnc [] lookupLincat cnc m c >>= computeLType cnc []
,return defLinType ,return defLinType
] ]

12
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -23,10 +23,9 @@ import GF.Grammar.Predef
import GF.Grammar.Lockfield (isLockLabel) import GF.Grammar.Lockfield (isLockLabel)
import GF.Data.BacktrackM import GF.Data.BacktrackM
import GF.Data.Operations import GF.Data.Operations
import GF.Infra.UseIO (IOE) import GF.Infra.UseIO (IOE,ePutStr,ePutStrLn)
import GF.Data.Utilities (updateNthM) --updateNth import GF.Data.Utilities (updateNthM) --updateNth
import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues,ppL) import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues,ppL)
import System.IO(hPutStr,hPutStrLn,stderr)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.List as List import qualified Data.List as List
@@ -39,7 +38,6 @@ import Data.Array.Unboxed
--import Data.Char (isDigit) --import Data.Char (isDigit)
import Control.Monad import Control.Monad
import Control.Monad.Identity import Control.Monad.Identity
import Control.Monad.Trans (liftIO)
--import Control.Exception --import Control.Exception
---------------------------------------------------------------------- ----------------------------------------------------------------------
@@ -48,7 +46,7 @@ import Control.Monad.Trans (liftIO)
generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
generatePMCFG opts sgr opath cmo@(cm,cmi) = do generatePMCFG opts sgr opath cmo@(cm,cmi) = do
(seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv opath am cm) Map.empty (jments cmi) (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv opath am cm) Map.empty (jments cmi)
when (verbAtLeast opts Verbose) $ liftIO $ hPutStrLn stderr "" when (verbAtLeast opts Verbose) $ ePutStrLn ""
return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js}) return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
where where
cenv = resourceValues gr cenv = resourceValues gr
@@ -87,9 +85,9 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
!funs_cnt = e-s+1 !funs_cnt = e-s+1
in (prods_cnt,funs_cnt) in (prods_cnt,funs_cnt)
when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs))) when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id ++ " " ++ show (product (map catFactor pargs)))
seqs1 `seq` stats `seq` return () seqs1 `seq` stats `seq` return ()
when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr (" "++show stats) when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg)) return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
where where
(ctxt,res,_) = err bug typeForm (lookupFunType gr am id) (ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
@@ -128,7 +126,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc
let pmcfg = getPMCFG pmcfgEnv2 let pmcfg = getPMCFG pmcfgEnv2
when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pcat)) when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat))
seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg)) seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg))
where where
addLindef lins (newCat', newArgs') env0 = addLindef lins (newCat', newArgs') env0 =

54
src/compiler/GF/Compile/ReadFiles.hs
View File

@@ -35,8 +35,6 @@ import GF.Grammar.Grammar
import GF.Grammar.Binary import GF.Grammar.Binary
import Control.Monad import Control.Monad
--import Data.Char
--import Data.List
import Data.Maybe(isJust) import Data.Maybe(isJust)
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map import qualified Data.Map as Map
@@ -52,11 +50,11 @@ type ModEnv = Map.Map ModName (UTCTime,[ModName])
-- | Returns a list of all files to be compiled in topological order i.e. -- | Returns a list of all files to be compiled in topological order i.e.
-- the low level (leaf) modules are first. -- the low level (leaf) modules are first.
getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath] getAllFiles :: (MonadIO m,ErrorMonad m) => Options -> [InitPath] -> ModEnv -> FileName -> m [FullPath]
getAllFiles opts ps env file = do getAllFiles opts ps env file = do
-- read module headers from all files recursively -- read module headers from all files recursively
ds <- liftM reverse $ get [] [] (justModuleName file) ds <- liftM reverse $ get [] [] (justModuleName file)
ioeIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_,_) <- ds] liftIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_,_) <- ds]
return $ paths ds return $ paths ds
where where
-- construct list of paths to read -- construct list of paths to read
@@ -71,12 +69,12 @@ getAllFiles opts ps env file = do
-- | traverses the dependency graph and returns a topologicaly sorted -- | traverses the dependency graph and returns a topologicaly sorted
-- list of ModuleInfo. An error is raised if there is circular dependency -- list of ModuleInfo. An error is raised if there is circular dependency
get :: [ModName] -- ^ keeps the current path in the dependency graph to avoid cycles {- get :: [ModName] -- ^ keeps the current path in the dependency graph to avoid cycles
-> [ModuleInfo] -- ^ a list of already traversed modules -> [ModuleInfo] -- ^ a list of already traversed modules
-> ModName -- ^ the current module -> ModName -- ^ the current module
-> IOE [ModuleInfo] -- ^ the final -> IOE [ModuleInfo] -- ^ the final -}
get trc ds name get trc ds name
| name `elem` trc = ioeErr $ Bad $ "circular modules" +++ unwords trc | name `elem` trc = raise $ "circular modules" +++ unwords trc
| (not . null) [n | (n,_,_,_,_,_) <- ds, name == n] --- file already read | (not . null) [n | (n,_,_,_,_,_) <- ds, name == n] --- file already read
= return ds = return ds
| otherwise = do | otherwise = do
@@ -91,20 +89,20 @@ getAllFiles opts ps env file = do
-- searches for module in the search path and if it is found -- searches for module in the search path and if it is found
-- returns 'ModuleInfo'. It fails if there is no such module -- returns 'ModuleInfo'. It fails if there is no such module
findModule :: ModName -> IOE ModuleInfo --findModule :: ModName -> IOE ModuleInfo
findModule name = do findModule name = do
(file,gfTime,gfoTime) <- do (file,gfTime,gfoTime) <- do
mb_gfFile <- ioeIO $ getFilePath ps (gfFile name) mb_gfFile <- getFilePath ps (gfFile name)
case mb_gfFile of case mb_gfFile of
Just gfFile -> do gfTime <- ioeIO $ toUTCTime `fmap` getModificationTime gfFile Just gfFile -> do gfTime <- liftIO $ toUTCTime `fmap` getModificationTime gfFile
mb_gfoTime <- ioeIO $ catch (liftM Just $ toUTCTime `fmap` getModificationTime (gf2gfo opts gfFile)) mb_gfoTime <- liftIO $ catch (liftM Just $ toUTCTime `fmap` getModificationTime (gf2gfo opts gfFile))
(\_->return Nothing) (\_->return Nothing)
return (gfFile, Just gfTime, mb_gfoTime) return (gfFile, Just gfTime, mb_gfoTime)
Nothing -> do mb_gfoFile <- ioeIO $ getFilePath (maybe id (:) (flag optGFODir opts) ps) (gfoFile name) Nothing -> do mb_gfoFile <- getFilePath (maybe id (:) (flag optGFODir opts) ps) (gfoFile name)
case mb_gfoFile of case mb_gfoFile of
Just gfoFile -> do gfoTime <- ioeIO $ toUTCTime `fmap` getModificationTime gfoFile Just gfoFile -> do gfoTime <- liftIO $ toUTCTime `fmap` getModificationTime gfoFile
return (gfoFile, Nothing, Just gfoTime) return (gfoFile, Nothing, Just gfoTime)
Nothing -> ioeErr $ Bad (render (text "File" <+> text (gfFile name) <+> text "does not exist." $$ Nothing -> raise (render (text "File" <+> text (gfFile name) <+> text "does not exist." $$
text "searched in:" <+> vcat (map text ps))) text "searched in:" <+> vcat (map text ps)))
@@ -114,21 +112,21 @@ getAllFiles opts ps env file = do
(st,(mname,imps)) <- (st,(mname,imps)) <-
case st of case st of
CSEnv -> return (st, (name, maybe [] snd mb_envmod)) CSEnv -> return (st, (name, maybe [] snd mb_envmod))
CSRead -> do mb_mo <- ioeIO $ decodeModuleHeader ((if isGFO file then id else gf2gfo opts) file) CSRead -> do mb_mo <- liftIO $ decodeModuleHeader ((if isGFO file then id else gf2gfo opts) file)
case mb_mo of case mb_mo of
Just mo -> return (st,importsOfModule mo) Just mo -> return (st,importsOfModule mo)
Nothing Nothing
| isGFO file -> ioeErr $ Bad (file ++ " is compiled with different GF version and I can't find the source file") | isGFO file -> raise (file ++ " is compiled with different GF version and I can't find the source file")
| otherwise -> do s <- ioeIO $ BS.readFile file | otherwise -> do s <- liftIO $ BS.readFile file
case runP pModHeader s of case runP pModHeader s of
Left (Pn l c,msg) -> ioeBad (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg) Left (Pn l c,msg) -> raise (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
Right mo -> return (CSComp,importsOfModule mo) Right mo -> return (CSComp,importsOfModule mo)
CSComp -> do s <- ioeIO $ BS.readFile file CSComp -> do s <- liftIO $ BS.readFile file
case runP pModHeader s of case runP pModHeader s of
Left (Pn l c,msg) -> ioeBad (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg) Left (Pn l c,msg) -> raise (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
Right mo -> return (st,importsOfModule mo) Right mo -> return (st,importsOfModule mo)
ioeErr $ testErr (mname == name) testErr (mname == name)
("module name" +++ mname +++ "differs from file name" +++ name) ("module name" +++ mname +++ "differs from file name" +++ name)
return (name,st,t,isJust gfTime,imps,dropFileName file) return (name,st,t,isJust gfTime,imps,dropFileName file)
isGFO :: FilePath -> Bool isGFO :: FilePath -> Bool
@@ -212,16 +210,16 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
modName = showIdent modName = showIdent
-- | options can be passed to the compiler by comments in @--#@, in the main file -- | options can be passed to the compiler by comments in @--#@, in the main file
getOptionsFromFile :: FilePath -> IOE Options getOptionsFromFile :: (MonadIO m,ErrorMonad m) => FilePath -> m Options
getOptionsFromFile file = do getOptionsFromFile file = do
s <- ioe $ catch (fmap Ok $ BS.readFile file) s <- handle (liftIO $ BS.readFile file)
(\_ -> return (Bad $ "File " ++ file ++ " does not exist")) (\_ -> raise $ "File " ++ file ++ " does not exist")
let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls
ioeErr $ parseModuleOptions fs liftErr $ parseModuleOptions fs
getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) getFilePath :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath)
getFilePath paths file = get paths getFilePath paths file = liftIO $ get paths
where where
get [] = return Nothing get [] = return Nothing
get (p:ps) = do get (p:ps) = do

8
src/compiler/GF/Compile/Rename.hs
View File

@@ -45,7 +45,7 @@ import Text.PrettyPrint
-- | this gives top-level access to renaming term input in the cc command -- | this gives top-level access to renaming term input in the cc command
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
renameSourceTerm g m t = do renameSourceTerm g m t = do
mi <- checkErr $ lookupModule g m mi <- lookupModule g m
status <- buildStatus g (m,mi) status <- buildStatus g (m,mi)
renameTerm status [] t renameTerm status [] t
@@ -72,12 +72,12 @@ renameIdentTerm' env@(act,imps) t0 =
Cn c -> ident (\_ s -> checkError s) c Cn c -> ident (\_ s -> checkError s) c
Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0 Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
Q (m',c) -> do Q (m',c) -> do
m <- checkErr (lookupErr m' qualifs) m <- lookupErr m' qualifs
f <- lookupTree showIdent c m f <- lookupTree showIdent c m
return $ f c return $ f c
QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0 QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
QC (m',c) -> do QC (m',c) -> do
m <- checkErr (lookupErr m' qualifs) m <- lookupErr m' qualifs
f <- lookupTree showIdent c m f <- lookupTree showIdent c m
return $ f c return $ f c
_ -> return t0 _ -> return t0
@@ -127,7 +127,7 @@ buildStatus :: SourceGrammar -> SourceModule -> Check Status
buildStatus gr mo@(m,mi) = checkIn (ppLocation (msrc mi) NoLoc <> colon) $ do buildStatus gr mo@(m,mi) = checkIn (ppLocation (msrc mi) NoLoc <> colon) $ do
let gr1 = prependModule gr mo let gr1 = prependModule gr mo
exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m] exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m]
ops <- checkErr $ mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi) ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi)
let sts = map modInfo2status (exts++ops) let sts = map modInfo2status (exts++ops)
return (if isModCnc mi return (if isModCnc mi
then (emptyBinTree, reverse sts) -- the module itself does not define any names then (emptyBinTree, reverse sts) -- the module itself does not define any names

2
src/compiler/GF/Compile/Tags.hs
View File

@@ -19,7 +19,7 @@ writeTags opts gr file mo = do
let imports = getImports opts gr mo let imports = getImports opts gr mo
locals = getLocalTags [] mo locals = getLocalTags [] mo
txt = unlines ((Set.toList . Set.fromList) (imports++locals)) txt = unlines ((Set.toList . Set.fromList) (imports++locals))
putPointE Normal opts (" write file" +++ file) $ ioeIO $ writeFile file txt putPointE Normal opts (" write file" +++ file) $ liftIO $ writeFile file txt
getLocalTags x (m,mi) = getLocalTags x (m,mi) =
[showIdent i ++ "\t" ++ k ++ "\t" ++ l ++ "\t" ++ t [showIdent i ++ "\t" ++ k ++ "\t" ++ l ++ "\t" ++ t

28
src/compiler/GF/Compile/TypeCheck/Concrete.hs
View File

@@ -23,7 +23,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
| isPredefConstant ty -> return ty ---- shouldn't be needed | isPredefConstant ty -> return ty ---- shouldn't be needed
Q (m,ident) -> checkIn (text "module" <+> ppIdent m) $ do Q (m,ident) -> checkIn (text "module" <+> ppIdent m) $ do
ty' <- checkErr (lookupResDef gr (m,ident)) ty' <- lookupResDef gr (m,ident)
if ty' == ty then return ty else comp g ty' --- is this necessary to test? if ty' == ty then return ty else comp g ty' --- is this necessary to test?
Vr ident -> checkLookup ident g -- never needed to compute! Vr ident -> checkLookup ident g -- never needed to compute!
@@ -50,7 +50,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
r' <- comp g r r' <- comp g r
s' <- comp g s s' <- comp g s
case (r',s') of case (r',s') of
(RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp g (RecType rs, RecType ss) -> plusRecType r' s' >>= comp g
_ -> return $ ExtR r' s' _ -> return $ ExtR r' s'
RecType fs -> do RecType fs -> do
@@ -59,7 +59,7 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
ELincat c t -> do ELincat c t -> do
t' <- comp g t t' <- comp g t
checkErr $ lockRecType c t' ---- locking to be removed AR 20/6/2009 lockRecType c t' ---- locking to be removed AR 20/6/2009
_ | ty == typeTok -> return typeStr _ | ty == typeTok -> return typeStr
_ | isPredefConstant ty -> return ty _ | isPredefConstant ty -> return ty
@@ -76,9 +76,9 @@ inferLType gr g trm = case trm of
Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident) Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
Q ident -> checks [ Q ident -> checks [
termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g termWith trm $ lookupResType gr ident >>= computeLType gr g
, ,
checkErr (lookupResDef gr ident) >>= inferLType gr g lookupResDef gr ident >>= inferLType gr g
, ,
checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm) checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
] ]
@@ -88,9 +88,9 @@ inferLType gr g trm = case trm of
Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident) Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
QC ident -> checks [ QC ident -> checks [
termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g termWith trm $ lookupResType gr ident >>= computeLType gr g
, ,
checkErr (lookupResDef gr ident) >>= inferLType gr g lookupResDef gr ident >>= inferLType gr g
, ,
checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm) checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
] ]
@@ -214,10 +214,10 @@ inferLType gr g trm = case trm of
sT' <- computeLType gr g sT sT' <- computeLType gr g sT
let trm' = ExtR r' s' let trm' = ExtR r' s'
---- trm' <- checkErr $ plusRecord r' s' ---- trm' <- plusRecord r' s'
case (rT', sT') of case (rT', sT') of
(RecType rs, RecType ss) -> do (RecType rs, RecType ss) -> do
rt <- checkErr $ plusRecType rT' sT' rt <- plusRecType rT' sT'
checkLType gr g trm' rt ---- return (trm', rt) checkLType gr g trm' rt ---- return (trm', rt)
_ | rT' == typeType && sT' == typeType -> return (trm', typeType) _ | rT' == typeType && sT' == typeType -> return (trm', typeType)
_ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm) _ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm)
@@ -249,7 +249,7 @@ inferLType gr g trm = case trm of
ELin c trm -> do ELin c trm -> do
(trm',ty) <- inferLType gr g trm (trm',ty) <- inferLType gr g trm
ty' <- checkErr $ lockRecType c ty ---- lookup c; remove lock AR 20/6/2009 ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
return $ (ELin c trm', ty') return $ (ELin c trm', ty')
_ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm) _ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
@@ -289,7 +289,7 @@ inferLType gr g trm = case trm of
_ -> False _ -> False
inferPatt p = case p of inferPatt p = case p of
PP (q,c) ps | q /= cPredef -> checkErr $ liftM valTypeCnc (lookupResType gr (q,c)) PP (q,c) ps | q /= cPredef -> liftM valTypeCnc (lookupResType gr (q,c))
PAs _ p -> inferPatt p PAs _ p -> inferPatt p
PNeg p -> inferPatt p PNeg p -> inferPatt p
PAlt p q -> checks [inferPatt p, inferPatt q] PAlt p q -> checks [inferPatt p, inferPatt q]
@@ -423,7 +423,7 @@ checkLType gr g trm typ0 = do
case allParamValues gr arg of case allParamValues gr arg of
Ok vs -> do Ok vs -> do
let ps0 = map fst cs let ps0 = map fst cs
ps <- checkErr $ testOvershadow ps0 vs ps <- testOvershadow ps0 vs
if null ps if null ps
then return () then return ()
else checkWarn (text "patterns never reached:" $$ else checkWarn (text "patterns never reached:" $$
@@ -511,7 +511,7 @@ checkLType gr g trm typ0 = do
checkLType gr g (Let (x,(Just ty,def')) body) typ checkLType gr g (Let (x,(Just ty,def')) body) typ
ELin c tr -> do ELin c tr -> do
tr1 <- checkErr $ unlockRecord c tr tr1 <- unlockRecord c tr
checkLType gr g tr1 typ checkLType gr g tr1 typ
_ -> do _ -> do
@@ -547,7 +547,7 @@ pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
pattContext env g typ p = case p of pattContext env g typ p = case p of
PV x -> return [(Explicit,x,typ)] PV x -> return [(Explicit,x,typ)]
PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
t <- checkErr $ lookupResType env (q,c) t <- lookupResType env (q,c)
let (cont,v) = typeFormCnc t let (cont,v) = typeFormCnc t
checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
(length cont == length ps) (length cont == length ps)

12
src/compiler/GF/Compile/Update.hs
View File

@@ -55,7 +55,7 @@ extendModule gr (name,m)
return (name,m') return (name,m')
where where
extOne mo (n,cond) = do extOne mo (n,cond) = do
m0 <- checkErr $ lookupModule gr n m0 <- lookupModule gr n
-- test that the module types match, and find out if the old is complete -- test that the module types match, and find out if the old is complete
unless (sameMType (mtype m) (mtype mo)) unless (sameMType (mtype m) (mtype mo))
@@ -93,7 +93,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_))
text "has open interfaces and must therefore be declared incomplete")) text "has open interfaces and must therefore be declared incomplete"))
case mt of case mt of
MTInstance (i0,mincl) -> do MTInstance (i0,mincl) -> do
m1 <- checkErr $ lookupModule gr i0 m1 <- lookupModule gr i0
unless (isModRes m1) unless (isModRes m1)
(checkError (text "interface expected instead of" <+> ppIdent i0)) (checkError (text "interface expected instead of" <+> ppIdent i0))
js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi) js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
@@ -101,7 +101,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_))
case extends mi of case extends mi of
[] -> return mi{jments=js'} [] -> return mi{jments=js'}
j0s -> do j0s -> do
m0s <- checkErr $ mapM (lookupModule gr) j0s m0s <- mapM (lookupModule gr) j0s
let notInM0 c _ = all (not . isInBinTree c . jments) m0s let notInM0 c _ = all (not . isInBinTree c . jments) m0s
let js2 = filterBinTree notInM0 js' let js2 = filterBinTree notInM0 js'
return mi{jments=js2} return mi{jments=js2}
@@ -114,7 +114,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_))
[i | i <- is, notElem i infs] [i | i <- is, notElem i infs]
unless (stat' == MSComplete || stat == MSIncomplete) unless (stat' == MSComplete || stat == MSIncomplete)
(checkError (text "module" <+> ppIdent i <+> text "remains incomplete")) (checkError (text "module" <+> ppIdent i <+> text "remains incomplete"))
ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- checkErr $ lookupModule gr ext ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
let ops1 = nub $ let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already ops_ ++ -- N.B. js has been name-resolved already
[OQualif i j | (i,j) <- ops] ++ [OQualif i j | (i,j) <- ops] ++
@@ -145,10 +145,10 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
Just j -> case unifyAnyInfo name i j of Just j -> case unifyAnyInfo name i j of
Ok k -> return $ updateTree (c,k) new Ok k -> return $ updateTree (c,k) new
Bad _ -> do (base,j) <- case j of Bad _ -> do (base,j) <- case j of
AnyInd _ m -> checkErr $ lookupOrigInfo gr (m,c) AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (base,j) _ -> return (base,j)
(name,i) <- case i of (name,i) <- case i of
AnyInd _ m -> checkErr $ lookupOrigInfo gr (m,c) AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (name,i) _ -> return (name,i)
checkError (text "cannot unify the information" $$ checkError (text "cannot unify the information" $$
nest 4 (ppJudgement Qualified (c,i)) $$ nest 4 (ppJudgement Qualified (c,i)) $$

29
src/compiler/GF/Data/Operations.hs
View File

@@ -21,7 +21,7 @@ module GF.Data.Operations (-- * misc functions
Err(..), err, maybeErr, testErr, errVal, errIn, Err(..), err, maybeErr, testErr, errVal, errIn,
lookupErr, lookupErr,
mapPairListM, mapPairsM, pairM, mapPairListM, mapPairsM, pairM,
singleton, mapsErr, mapsErrTree, singleton, --mapsErr, mapsErrTree,
-- ** checking -- ** checking
checkUnique, checkUnique,
@@ -55,7 +55,8 @@ module GF.Data.Operations (-- * misc functions
STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM, done, STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM, done,
-- * error monad class -- * error monad class
ErrorMonad(..), checkAgain, checks, allChecks, doUntil ErrorMonad(..), checkAgain, checks, allChecks, doUntil,
liftErr
) where ) where
@@ -85,19 +86,19 @@ err d f e = case e of
Bad s -> d s Bad s -> d s
-- | add msg s to @Maybe@ failures -- | add msg s to @Maybe@ failures
maybeErr :: String -> Maybe a -> Err a maybeErr :: ErrorMonad m => String -> Maybe a -> m a
maybeErr s = maybe (Bad s) Ok maybeErr s = maybe (raise s) return
testErr :: Bool -> String -> Err () testErr :: ErrorMonad m => Bool -> String -> m ()
testErr cond msg = if cond then return () else Bad msg testErr cond msg = if cond then return () else raise msg
errVal :: a -> Err a -> a errVal :: a -> Err a -> a
errVal a = err (const a) id errVal a = err (const a) id
errIn :: String -> Err a -> Err a errIn :: ErrorMonad m => String -> m a -> m a
errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg))
lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b lookupErr :: (ErrorMonad m,Eq a,Show a) => a -> [(a,b)] -> m b
lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs) lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs)
mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)] mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)]
@@ -313,6 +314,8 @@ stm = STM
stmr :: (s -> (a,s)) -> STM s a stmr :: (s -> (a,s)) -> STM s a
stmr f = stm (\s -> return (f s)) stmr f = stm (\s -> return (f s))
instance Functor (STM s) where fmap = liftM
instance Monad (STM s) where instance Monad (STM s) where
return a = STM (\s -> return (a,s)) return a = STM (\s -> return (a,s))
STM c >>= f = STM (\s -> do STM c >>= f = STM (\s -> do
@@ -332,7 +335,7 @@ writeSTM s = stmr (const ((),s))
done :: Monad m => m () done :: Monad m => m ()
done = return () done = return ()
class Monad m => ErrorMonad m where class (Functor m,Monad m) => ErrorMonad m where
raise :: String -> m a raise :: String -> m a
handle :: m a -> (String -> m a) -> m a handle :: m a -> (String -> m a) -> m a
handle_ :: m a -> m a -> m a handle_ :: m a -> m a -> m a
@@ -343,12 +346,14 @@ instance ErrorMonad Err where
handle a@(Ok _) _ = a handle a@(Ok _) _ = a
handle (Bad i) f = f i handle (Bad i) f = f i
liftErr e = err raise return e
instance ErrorMonad (STM s) where instance ErrorMonad (STM s) where
raise msg = STM (\s -> raise msg) raise msg = STM (\s -> raise msg)
handle (STM f) g = STM (\s -> (f s) handle (STM f) g = STM (\s -> (f s)
`handle` (\e -> let STM g' = (g e) in `handle` (\e -> let STM g' = (g e) in
g' s)) g' s))
{-
-- error recovery with multiple reporting AR 30/5/2008 -- error recovery with multiple reporting AR 30/5/2008
mapsErr :: (a -> Err b) -> [a] -> Err [b] mapsErr :: (a -> Err b) -> [a] -> Err [b]
@@ -364,7 +369,7 @@ mapsErr f = seqs . map f where
mapsErrTree :: (Ord a) => ((a,b) -> Err (a,c)) -> BinTree a b -> Err (BinTree a c) mapsErrTree :: (Ord a) => ((a,b) -> Err (a,c)) -> BinTree a b -> Err (BinTree a c)
mapsErrTree f t = mapsErr f (tree2list t) >>= return . sorted2tree mapsErrTree f t = mapsErr f (tree2list t) >>= return . sorted2tree
-}
-- | if the first check fails try another one -- | if the first check fails try another one
checkAgain :: ErrorMonad m => m a -> m a -> m a checkAgain :: ErrorMonad m => m a -> m a -> m a

12
src/compiler/GF/Grammar/CF.hs
View File

@@ -28,14 +28,14 @@ import Data.Char
import Data.List import Data.List
--import System.FilePath --import System.FilePath
getCF :: FilePath -> String -> Err SourceGrammar getCF :: ErrorMonad m => FilePath -> String -> m SourceGrammar
getCF fpath = fmap (cf2gf fpath . uniqueFuns) . pCF getCF fpath = fmap (cf2gf fpath . uniqueFuns) . pCF
--------------------- ---------------------
-- the parser ------- -- the parser -------
--------------------- ---------------------
pCF :: String -> Err CF pCF :: ErrorMonad m => String -> m CF
pCF s = do pCF s = do
rules <- mapM getCFRule $ filter isRule $ lines s rules <- mapM getCFRule $ filter isRule $ lines s
return $ concat rules return $ concat rules
@@ -48,14 +48,14 @@ pCF s = do
-- fun. C -> item1 item2 ... where unquoted items are treated as cats -- fun. C -> item1 item2 ... where unquoted items are treated as cats
-- Actually would be nice to add profiles to this. -- Actually would be nice to add profiles to this.
getCFRule :: String -> Err [CFRule] getCFRule :: ErrorMonad m => String -> m [CFRule]
getCFRule s = getcf (wrds s) where getCFRule s = getcf (wrds s) where
getcf ws = case ws of getcf ws = case ws of
fun : cat : a : its | isArrow a -> fun : cat : a : its | isArrow a ->
Ok [L NoLoc (init fun, (cat, map mkIt its))] return [L NoLoc (init fun, (cat, map mkIt its))]
cat : a : its | isArrow a -> cat : a : its | isArrow a ->
Ok [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its] return [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
_ -> Bad (" invalid rule:" +++ s) _ -> raise (" invalid rule:" +++ s)
isArrow a = elem a ["->", "::="] isArrow a = elem a ["->", "::="]
mkIt w = case w of mkIt w = case w of
('"':w@(_:_)) -> Right (init w) ('"':w@(_:_)) -> Right (init w)

8
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -195,17 +195,17 @@ mGrammar ms = MGrammar (Map.fromList ms) ms
-- | we store the module type with the identifier -- | we store the module type with the identifier
abstractOfConcrete :: SourceGrammar -> Ident -> Err Ident abstractOfConcrete :: ErrorMonad m => SourceGrammar -> Ident -> m Ident
abstractOfConcrete gr c = do abstractOfConcrete gr c = do
n <- lookupModule gr c n <- lookupModule gr c
case mtype n of case mtype n of
MTConcrete a -> return a MTConcrete a -> return a
_ -> Bad $ render (text "expected concrete" <+> ppIdent c) _ -> raise $ render (text "expected concrete" <+> ppIdent c)
lookupModule :: SourceGrammar -> Ident -> Err SourceModInfo lookupModule :: ErrorMonad m => SourceGrammar -> Ident -> m SourceModInfo
lookupModule gr m = case Map.lookup m (moduleMap gr) of lookupModule gr m = case Map.lookup m (moduleMap gr) of
Just i -> return i Just i -> return i
Nothing -> Bad $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr))) Nothing -> raise $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
isModAbs :: SourceModInfo -> Bool isModAbs :: SourceModInfo -> Bool
isModAbs m = isModAbs m =

4
src/compiler/GF/Grammar/Lockfield.hs
View File

@@ -20,9 +20,9 @@ import GF.Infra.Ident
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Data.Operations import GF.Data.Operations(ErrorMonad,Err(..))
lockRecType :: Ident -> Type -> Err Type lockRecType :: ErrorMonad m => Ident -> Type -> m Type
lockRecType c t@(RecType rs) = lockRecType c t@(RecType rs) =
let lab = lockLabel c in let lab = lockLabel c in
return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"] return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]

44
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -50,19 +50,19 @@ lock c = lockRecType c -- return
unlock c = unlockRecord c -- return unlock c = unlockRecord c -- return
-- to look up a constant etc in a search tree --- why here? AR 29/5/2008 -- to look up a constant etc in a search tree --- why here? AR 29/5/2008
lookupIdent :: Ident -> BinTree Ident b -> Err b lookupIdent :: ErrorMonad m => Ident -> BinTree Ident b -> m b
lookupIdent c t = lookupIdent c t =
case lookupTree showIdent c t of case lookupTree showIdent c t of
Ok v -> return v Ok v -> return v
Bad _ -> Bad ("unknown identifier" +++ showIdent c) Bad _ -> raise ("unknown identifier" +++ showIdent c)
lookupIdentInfo :: SourceModInfo -> Ident -> Err Info lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info
lookupIdentInfo mo i = lookupIdent i (jments mo) lookupIdentInfo mo i = lookupIdent i (jments mo)
lookupQIdentInfo :: SourceGrammar -> QIdent -> Err Info lookupQIdentInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m Info
lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m
lookupResDef :: SourceGrammar -> QIdent -> Err Term lookupResDef :: ErrorMonad m => SourceGrammar -> QIdent -> m Term
lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x) lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
lookupResDefLoc gr (m,c) lookupResDefLoc gr (m,c)
@@ -83,9 +83,9 @@ lookupResDefLoc gr (m,c)
AnyInd _ n -> look n c AnyInd _ n -> look n c
ResParam _ _ -> return (noLoc (QC (m,c))) ResParam _ _ -> return (noLoc (QC (m,c)))
ResValue _ -> return (noLoc (QC (m,c))) ResValue _ -> return (noLoc (QC (m,c)))
_ -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m) _ -> raise $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
lookupResType :: SourceGrammar -> QIdent -> Err Type lookupResType :: ErrorMonad m => SourceGrammar -> QIdent -> m Type
lookupResType gr (m,c) = do lookupResType gr (m,c) = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
@@ -99,9 +99,9 @@ lookupResType gr (m,c) = do
AnyInd _ n -> lookupResType gr (n,c) AnyInd _ n -> lookupResType gr (n,c)
ResParam _ _ -> return typePType ResParam _ _ -> return typePType
ResValue (L _ t) -> return t ResValue (L _ t) -> return t
_ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m) _ -> raise $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
lookupOverload :: SourceGrammar -> QIdent -> Err [([Type],(Type,Term))] lookupOverload :: ErrorMonad m => SourceGrammar -> QIdent -> m [([Type],(Type,Term))]
lookupOverload gr (m,c) = do lookupOverload gr (m,c) = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
@@ -112,10 +112,10 @@ lookupOverload gr (m,c) = do
concat tss concat tss
AnyInd _ n -> lookupOverload gr (n,c) AnyInd _ n -> lookupOverload gr (n,c)
_ -> Bad $ render (ppIdent c <+> text "is not an overloaded operation") _ -> raise $ render (ppIdent c <+> text "is not an overloaded operation")
-- | returns the original 'Info' and the module where it was found -- | returns the original 'Info' and the module where it was found
lookupOrigInfo :: SourceGrammar -> QIdent -> Err (Ident,Info) lookupOrigInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m (Ident,Info)
lookupOrigInfo gr (m,c) = do lookupOrigInfo gr (m,c) = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
@@ -127,14 +127,14 @@ allOrigInfos gr m = errVal [] $ do
mo <- lookupModule gr m mo <- lookupModule gr m
return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]] return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
lookupParamValues :: SourceGrammar -> QIdent -> Err [Term] lookupParamValues :: ErrorMonad m => SourceGrammar -> QIdent -> m [Term]
lookupParamValues gr c = do lookupParamValues gr c = do
(_,info) <- lookupOrigInfo gr c (_,info) <- lookupOrigInfo gr c
case info of case info of
ResParam _ (Just pvs) -> return pvs ResParam _ (Just pvs) -> return pvs
_ -> Bad $ render (ppQIdent Qualified c <+> text "has no parameter values defined") _ -> raise $ render (ppQIdent Qualified c <+> text "has no parameter values defined")
allParamValues :: SourceGrammar -> Type -> Err [Term] allParamValues :: ErrorMonad m => SourceGrammar -> Type -> m [Term]
allParamValues cnc ptyp = allParamValues cnc ptyp =
case ptyp of case ptyp of
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]] _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
@@ -148,12 +148,12 @@ allParamValues cnc ptyp =
pvs <- allParamValues cnc pt pvs <- allParamValues cnc pt
vvs <- allParamValues cnc vt vvs <- allParamValues cnc vt
return [V pt ts | ts <- combinations (replicate (length pvs) vvs)] return [V pt ts | ts <- combinations (replicate (length pvs) vvs)]
_ -> Bad (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp)) _ -> raise (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
where where
-- to normalize records and record types -- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation]) lookupAbsDef :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m (Maybe Int,Maybe [Equation])
lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
@@ -161,32 +161,32 @@ lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c))
AnyInd _ n -> lookupAbsDef gr n c AnyInd _ n -> lookupAbsDef gr n c
_ -> return (Nothing,Nothing) _ -> return (Nothing,Nothing)
lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type lookupLincat :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed? lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
lookupLincat gr m c = do lookupLincat gr m c = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
CncCat (Just (L _ t)) _ _ _ _ -> return t CncCat (Just (L _ t)) _ _ _ _ -> return t
AnyInd _ n -> lookupLincat gr n c AnyInd _ n -> lookupLincat gr n c
_ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m)) _ -> raise (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
-- | this is needed at compile time -- | this is needed at compile time
lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type lookupFunType :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
lookupFunType gr m c = do lookupFunType gr m c = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
AbsFun (Just (L _ t)) _ _ _ -> return t AbsFun (Just (L _ t)) _ _ _ -> return t
AnyInd _ n -> lookupFunType gr n c AnyInd _ n -> lookupFunType gr n c
_ -> Bad (render (text "cannot find type of" <+> ppIdent c)) _ -> raise (render (text "cannot find type of" <+> ppIdent c))
-- | this is needed at compile time -- | this is needed at compile time
lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context lookupCatContext :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Context
lookupCatContext gr m c = do lookupCatContext gr m c = do
info <- lookupQIdentInfo gr (m,c) info <- lookupQIdentInfo gr (m,c)
case info of case info of
AbsCat (Just (L _ co)) -> return co AbsCat (Just (L _ co)) -> return co
AnyInd _ n -> lookupCatContext gr n c AnyInd _ n -> lookupCatContext gr n c
_ -> Bad (render (text "unknown category" <+> ppIdent c)) _ -> raise (render (text "unknown category" <+> ppIdent c))
-- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations -- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations

22
src/compiler/GF/Grammar/Macros.hs
View File

@@ -262,22 +262,22 @@ mkWildCases = mkCases identW
mkFunType :: [Type] -> Type -> Type mkFunType :: [Type] -> Type -> Type
mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod
plusRecType :: Type -> Type -> Err Type --plusRecType :: Type -> Type -> Err Type
plusRecType t1 t2 = case (t1, t2) of plusRecType t1 t2 = case (t1, t2) of
(RecType r1, RecType r2) -> case (RecType r1, RecType r2) -> case
filter (`elem` (map fst r1)) (map fst r2) of filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2)) [] -> return (RecType (r1 ++ r2))
ls -> fail $ render (text "clashing labels" <+> hsep (map ppLabel ls)) ls -> raise $ render (text "clashing labels" <+> hsep (map ppLabel ls))
_ -> fail $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) _ -> raise $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
plusRecord :: Term -> Term -> Err Term --plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 = plusRecord t1 t2 =
case (t1,t2) of case (t1,t2) of
(R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields (R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2)) (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
(_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV (_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV
(FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV (FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
_ -> fail $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) _ -> raise $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
-- | default linearization type -- | default linearization type
defLinType :: Type defLinType :: Type
@@ -444,7 +444,7 @@ strsFromTerm t = case t of
] ]
FV ts -> mapM strsFromTerm ts >>= return . concat FV ts -> mapM strsFromTerm ts >>= return . concat
Strs ts -> mapM strsFromTerm ts >>= return . concat Strs ts -> mapM strsFromTerm ts >>= return . concat
_ -> fail (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t)) _ -> raise (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg -- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
stringFromTerm :: Term -> String stringFromTerm :: Term -> String
@@ -599,20 +599,20 @@ allDependencies ism b =
AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co] AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
_ -> [] _ -> []
topoSortJments :: SourceModule -> Err [(Ident,Info)] topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
topoSortJments (m,mi) = do topoSortJments (m,mi) = do
is <- either is <- either
return return
(\cyc -> Bad (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc))))) (\cyc -> raise (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc)))))
(topoTest (allDependencies (==m) (jments mi))) (topoTest (allDependencies (==m) (jments mi)))
return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]]) return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]])
topoSortJments2 :: SourceModule -> Err [[(Ident,Info)]] topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
topoSortJments2 (m,mi) = do topoSortJments2 (m,mi) = do
iss <- either iss <- either
return return
(\cyc -> fail (render (text "circular definitions:" (\cyc -> raise (render (text "circular definitions:"
<+> fsep (map ppIdent (head cyc))))) <+> fsep (map ppIdent (head cyc)))))
(topoTest2 (allDependencies (==m) (jments mi))) (topoTest2 (allDependencies (==m) (jments mi)))
return return
[[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss] [[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss]

18
src/compiler/GF/Grammar/PatternMatch.hs
View File

@@ -29,10 +29,10 @@ import Control.Monad
import Text.PrettyPrint import Text.PrettyPrint
--import Debug.Trace --import Debug.Trace
matchPattern :: [(Patt,rhs)] -> Term -> Err (rhs, Substitution) matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
matchPattern pts term = matchPattern pts term =
if not (isInConstantForm term) if not (isInConstantForm term)
then Bad (render (text "variables occur in" <+> ppTerm Unqualified 0 term)) then raise (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
else do else do
term' <- mkK term term' <- mkK term
errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $ errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $
@@ -49,20 +49,20 @@ matchPattern pts term =
K w -> return [w] K w -> return [w]
C v w -> liftM2 (++) (getS v) (getS w) C v w -> liftM2 (++) (getS v) (getS w)
Empty -> return [] Empty -> return []
_ -> Bad (render (text "cannot get string from" <+> ppTerm Unqualified 0 s)) _ -> raise (render (text "cannot get string from" <+> ppTerm Unqualified 0 s))
testOvershadow :: [Patt] -> [Term] -> Err [Patt] testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt]
testOvershadow pts vs = do testOvershadow pts vs = do
let numpts = zip pts [0..] let numpts = zip pts [0..]
let cases = [(p,EInt i) | (p,i) <- numpts] let cases = [(p,EInt i) | (p,i) <- numpts]
ts <- mapM (liftM fst . matchPattern cases) vs ts <- mapM (liftM fst . matchPattern cases) vs
return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ] return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
findMatch :: [([Patt],rhs)] -> [Term] -> Err (rhs, Substitution) findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
findMatch cases terms = case cases of findMatch cases terms = case cases of
[] -> Bad (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms)))) [] -> raise (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms))))
(patts,_):_ | length patts /= length terms -> (patts,_):_ | length patts /= length terms ->
Bad (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+> raise (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+>
text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms))) text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of (patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (val, concat substs) Ok substs -> return (val, concat substs)
@@ -116,7 +116,7 @@ tryMatch (p,t) = do
(PNeg p',_) -> case tryMatch (p',t) of (PNeg p',_) -> case tryMatch (p',t) of
Bad _ -> return [] Bad _ -> return []
_ -> Bad (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p)) _ -> raise (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p))
(PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s (PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s
(PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
@@ -130,7 +130,7 @@ tryMatch (p,t) = do
(PChar, ([],K [_], [])) -> return [] (PChar, ([],K [_], [])) -> return []
(PChars cs, ([],K [c], [])) | elem c cs -> return [] (PChars cs, ([],K [c], [])) | elem c cs -> return []
_ -> Bad (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t)) _ -> raise (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t))
matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s
--matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s --matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s

12
src/compiler/GF/Infra/CheckM.hs
View File

@@ -15,7 +15,7 @@
module GF.Infra.CheckM module GF.Infra.CheckM
(Check, CheckResult, Message, runCheck, (Check, CheckResult, Message, runCheck,
checkError, checkCond, checkWarn, checkWarnings, checkAccumError, checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
checkErr, checkIn, checkMap, checkMapRecover, {-checkErr,-} checkIn, checkMap, checkMapRecover,
parallelCheck, accumulateError, commitCheck, parallelCheck, accumulateError, commitCheck,
) where ) where
@@ -92,14 +92,14 @@ commitCheck c =
list = vcat . reverse list = vcat . reverse
-- | Run an error check, report errors and warnings -- | Run an error check, report errors and warnings
runCheck :: Check a -> Err (a,String) runCheck :: ErrorMonad m => Check a -> m (a,String)
runCheck c = runCheck c =
case unCheck c {-[]-} ([],[]) of case unCheck c {-[]-} ([],[]) of
(([],ws),Success v) -> Ok (v,render (list ws)) (([],ws),Success v) -> return (v,render (list ws))
(msgs ,Success v) -> bad msgs (msgs ,Success v) -> bad msgs
((es,ws),Fail e) -> bad ((e:es),ws) ((es,ws),Fail e) -> bad ((e:es),ws)
where where
bad (es,ws) = Bad (render $ list ws $$ list es) bad (es,ws) = raise (render $ list ws $$ list es)
list = vcat . reverse list = vcat . reverse
parallelCheck :: [Check a] -> Check [a] parallelCheck :: [Check a] -> Check [a]
@@ -135,10 +135,6 @@ checkMapRecover f mp = do
return (Map.fromAscList kx) return (Map.fromAscList kx)
-} -}
checkErr :: Err a -> Check a
checkErr (Ok x) = return x
checkErr (Bad err) = checkError (text err)
checkIn :: Doc -> Check a -> Check a checkIn :: Doc -> Check a -> Check a
checkIn msg c = Check $ \{-ctxt-} msgs0 -> checkIn msg c = Check $ \{-ctxt-} msgs0 ->
case unCheck c {-ctxt-} ([],[]) of case unCheck c {-ctxt-} ([],[]) of

56
src/compiler/GF/Infra/UseIO.hs
View File

@@ -13,7 +13,7 @@
-- (Description of the module) -- (Description of the module)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Infra.UseIO where module GF.Infra.UseIO(module GF.Infra.UseIO,MonadIO(..),liftErr) where
import Prelude hiding (catch) import Prelude hiding (catch)
@@ -35,8 +35,8 @@ import Control.Monad
import Control.Monad.Trans(MonadIO(..)) import Control.Monad.Trans(MonadIO(..))
import Control.Exception(evaluate) import Control.Exception(evaluate)
putShow' :: Show a => (c -> a) -> c -> IO () --putShow' :: Show a => (c -> a) -> c -> IO ()
putShow' f = putStrLn . show . length . show . f --putShow' f = putStrLn . show . length . show . f
putIfVerb :: Options -> String -> IO () putIfVerb :: Options -> String -> IO ()
putIfVerb opts msg = putIfVerb opts msg =
@@ -118,12 +118,6 @@ splitInModuleSearchPath s = case break isPathSep s of
-- --
putStrFlush :: String -> IO ()
putStrFlush s = putStr s >> hFlush stdout
putStrLnFlush :: String -> IO ()
putStrLnFlush s = putStrLn s >> hFlush stdout
-- * IO monad with error; adapted from state monad -- * IO monad with error; adapted from state monad
newtype IOE a = IOE { appIOE :: IO (Err a) } newtype IOE a = IOE { appIOE :: IO (Err a) }
@@ -131,14 +125,11 @@ newtype IOE a = IOE { appIOE :: IO (Err a) }
ioe :: IO (Err a) -> IOE a ioe :: IO (Err a) -> IOE a
ioe = IOE ioe = IOE
ioeIO :: IO a -> IOE a instance MonadIO IOE where liftIO io = ioe (io >>= return . return)
ioeIO io = ioe (io >>= return . return)
ioeErr :: Err a -> IOE a instance ErrorMonad IOE where
ioeErr = ioe . return raise = ioe . return . Bad
handle m h = ioe $ err (appIOE . h) (return . Ok) =<< appIOE m
ioeErrIn :: String -> IOE a -> IOE a
ioeErrIn msg (IOE ioe) = IOE (fmap (errIn msg) ioe)
instance Functor IOE where fmap = liftM instance Functor IOE where fmap = liftM
@@ -146,22 +137,17 @@ instance Monad IOE where
return a = ioe (return (return a)) return a = ioe (return (return a))
IOE c >>= f = IOE $ do IOE c >>= f = IOE $ do
x <- c -- Err a x <- c -- Err a
appIOE $ err ioeBad f x -- f :: a -> IOE a appIOE $ err raise f x -- f :: a -> IOE a
fail = ioeBad fail = raise
instance MonadIO IOE where liftIO = ioeIO
ioeBad :: String -> IOE a
ioeBad = ioe . return . Bad
useIOE :: a -> IOE a -> IO a useIOE :: a -> IOE a -> IO a
useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return
foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String) --foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String)
foldIOE f s xs = case xs of foldIOE f s xs = case xs of
[] -> return (s,Nothing) [] -> return (s,Nothing)
x:xx -> do x:xx -> do
ev <- ioeIO $ appIOE (f s x) ev <- liftIO $ appIOE (f s x)
case ev of case ev of
Ok v -> foldIOE f v xx Ok v -> foldIOE f v xx
Bad m -> return $ (s, Just m) Bad m -> return $ (s, Just m)
@@ -170,19 +156,19 @@ die :: String -> IO a
die s = do hPutStrLn stderr s die s = do hPutStrLn stderr s
exitFailure exitFailure
putStrLnE :: String -> IOE () ePutStr, ePutStrLn, putStrE, putStrLnE :: MonadIO m => String -> m ()
putStrLnE = ioeIO . putStrLnFlush ePutStr s = liftIO $ hPutStr stderr s
ePutStrLn s = liftIO $ hPutStrLn stderr s
putStrLnE s = liftIO $ putStrLn s >> hFlush stdout
putStrE s = liftIO $ putStr s >> hFlush stdout
putStrE :: String -> IOE () putPointE :: MonadIO m => Verbosity -> Options -> String -> m a -> m a
putStrE = ioeIO . putStrFlush
putPointE :: Verbosity -> Options -> String -> IOE a -> IOE a
putPointE v opts msg act = do putPointE v opts msg act = do
when (verbAtLeast opts v) $ ioeIO $ putStrFlush msg when (verbAtLeast opts v) $ putStrE msg
t1 <- ioeIO $ getCPUTime t1 <- liftIO $ getCPUTime
a <- act >>= ioeIO . evaluate a <- act >>= liftIO . evaluate
t2 <- ioeIO $ getCPUTime t2 <- liftIO $ getCPUTime
if flag optShowCPUTime opts if flag optShowCPUTime opts
then do let msec = (t2 - t1) `div` 1000000000 then do let msec = (t2 - t1) `div` 1000000000

12
src/compiler/GFC.hs
View File

@@ -55,9 +55,9 @@ compileSourceFiles opts fs =
compileCFFiles :: Options -> [FilePath] -> IOE () compileCFFiles :: Options -> [FilePath] -> IOE ()
compileCFFiles opts fs = compileCFFiles opts fs =
do s <- ioeIO $ fmap unlines $ mapM readFile fs do s <- liftIO $ fmap unlines $ mapM readFile fs
let cnc = justModuleName (last fs) let cnc = justModuleName (last fs)
gf <- ioeErr $ getCF cnc s gf <- getCF cnc s
gr <- compileSourceGrammar opts gf gr <- compileSourceGrammar opts gf
if flag optStopAfterPhase opts == Compile if flag optStopAfterPhase opts == Compile
then return () then return ()
@@ -76,7 +76,7 @@ unionPGFFiles opts fs =
then putStrLnE $ "Refusing to overwrite " ++ pgfFile then putStrLnE $ "Refusing to overwrite " ++ pgfFile
else writePGF opts pgf else writePGF opts pgf
writeOutputs opts pgf writeOutputs opts pgf
where readPGFVerbose f = putPointE Normal opts ("Reading " ++ f ++ "...") $ ioeIO $ readPGF f where readPGFVerbose f = putPointE Normal opts ("Reading " ++ f ++ "...") $ liftIO $ readPGF f
writeOutputs :: Options -> PGF -> IOE () writeOutputs :: Options -> PGF -> IOE ()
writeOutputs opts pgf = do writeOutputs opts pgf = do
@@ -93,7 +93,7 @@ writeByteCode opts pgf
path = case flag optOutputDir opts of path = case flag optOutputDir opts of
Nothing -> file Nothing -> file
Just dir -> dir </> file Just dir -> dir </> file
in putPointE Normal opts ("Writing " ++ path ++ "...") $ ioeIO $ in putPointE Normal opts ("Writing " ++ path ++ "...") $ liftIO $
bracket bracket
(openFile path WriteMode) (openFile path WriteMode)
(hClose) (hClose)
@@ -109,14 +109,14 @@ writeByteCode opts pgf
writePGF :: Options -> PGF -> IOE () writePGF :: Options -> PGF -> IOE ()
writePGF opts pgf = do writePGF opts pgf = do
let outfile = grammarName opts pgf <.> "pgf" let outfile = grammarName opts pgf <.> "pgf"
putPointE Normal opts ("Writing " ++ outfile ++ "...") $ ioeIO $ encodeFile outfile pgf putPointE Normal opts ("Writing " ++ outfile ++ "...") $ liftIO $ encodeFile outfile pgf
grammarName :: Options -> PGF -> String grammarName :: Options -> PGF -> String
grammarName opts pgf = fromMaybe (showCId (absname pgf)) (flag optName opts) grammarName opts pgf = fromMaybe (showCId (absname pgf)) (flag optName opts)
writeOutput :: Options -> FilePath-> String -> IOE () writeOutput :: Options -> FilePath-> String -> IOE ()
writeOutput opts file str = writeOutput opts file str =
putPointE Normal opts ("Writing " ++ path ++ "...") $ ioeIO $ putPointE Normal opts ("Writing " ++ path ++ "...") $ liftIO $
writeUTF8File path str writeUTF8File path str
where where
path = maybe id (</>) (flag optOutputDir opts) file path = maybe id (</>) (flag optOutputDir opts) file

5
src/compiler/GFI.hs
View File

@@ -8,8 +8,7 @@ import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,emptyCommandE
import GF.Command.Commands(flags,options) import GF.Command.Commands(flags,options)
import GF.Command.Abstract import GF.Command.Abstract
import GF.Command.Parse(readCommandLine,pCommand) import GF.Command.Parse(readCommandLine,pCommand)
import GF.Data.ErrM import GF.Data.Operations (Err(..),chunks,err,raise)
import GF.Data.Operations (chunks,err)
import GF.Grammar hiding (Ident,isPrefixOf) import GF.Grammar hiding (Ident,isPrefixOf)
import GF.Grammar.Analyse import GF.Grammar.Analyse
import GF.Grammar.Parser (runP, pExp) import GF.Grammar.Parser (runP, pExp)
@@ -326,7 +325,7 @@ printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
checkComputeTerm = checkComputeTerm' False checkComputeTerm = checkComputeTerm' False
checkComputeTerm' new sgr t = do checkComputeTerm' new sgr t = do
mo <- maybe (Bad "no source grammar in scope") return $ greatestResource sgr mo <- maybe (raise "no source grammar in scope") return $ greatestResource sgr
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
inferLType sgr [] t inferLType sgr [] t
t1 <- if new t1 <- if new

6
src/compiler/GFServer.hs
View File

@@ -7,7 +7,7 @@ import Control.Monad(when)
import Control.Monad.State(StateT(..),get,gets,put) import Control.Monad.State(StateT(..),get,gets,put)
import Control.Monad.Error(ErrorT(..),Error(..)) import Control.Monad.Error(ErrorT(..),Error(..))
import System.Random(randomRIO) import System.Random(randomRIO)
import System.IO(stderr,hPutStrLn) --import System.IO(stderr,hPutStrLn)
import GF.System.Catch(try) import GF.System.Catch(try)
import System.IO.Error(isAlreadyExistsError) import System.IO.Error(isAlreadyExistsError)
import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory, import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory,
@@ -33,7 +33,7 @@ import Text.JSON(encode,showJSON,makeObj)
import System.Process(readProcessWithExitCode) import System.Process(readProcessWithExitCode)
import System.Exit(ExitCode(..)) import System.Exit(ExitCode(..))
import Codec.Binary.UTF8.String(decodeString,encodeString) import Codec.Binary.UTF8.String(decodeString,encodeString)
import GF.Infra.UseIO(readBinaryFile,writeBinaryFile) import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn)
import GF.Infra.SIO(captureSIO) import GF.Infra.SIO(captureSIO)
import qualified PGFService as PS import qualified PGFService as PS
import qualified ExampleService as ES import qualified ExampleService as ES
@@ -334,7 +334,7 @@ serveStaticFile' path =
return (resp404 path) return (resp404 path)
-- * Logging -- * Logging
logPutStrLn s = liftIO . hPutStrLn stderr $ s logPutStrLn s = ePutStrLn s
-- * JSONP output -- * JSONP output