mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
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.
This commit is contained in:
hallgren
@@ -12,7 +12,6 @@ import Data.Version
|
||||
import System.Directory
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import GF.System.Console (setConsoleEncoding)
|
||||
|
||||
main :: IO ()
|
||||
@@ -23,8 +22,8 @@ main = do
|
||||
Ok (opts,files) -> do curr_dir <- getCurrentDirectory
|
||||
lib_dir <- getLibraryDirectory opts
|
||||
mainOpts (fixRelativeLibPaths curr_dir lib_dir opts) files
|
||||
Bad err -> do hPutStrLn stderr err
|
||||
hPutStrLn stderr "You may want to try --help."
|
||||
Bad err -> do ePutStrLn err
|
||||
ePutStrLn "You may want to try --help."
|
||||
exitFailure
|
||||
|
||||
mainOpts :: Options -> [FilePath] -> IO ()
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -50,10 +50,10 @@ checkModule opts sgr mo@(m,mi) = do
|
||||
checkRestrictedInheritance sgr mo
|
||||
mo <- case mtype mi of
|
||||
MTConcrete a -> do let gr = prependModule sgr mo
|
||||
abs <- checkErr $ lookupModule gr a
|
||||
abs <- lookupModule gr a
|
||||
checkCompleteGrammar opts gr (a,abs) mo
|
||||
_ -> return mo
|
||||
infoss <- checkErr $ topoSortJments2 mo
|
||||
infoss <- topoSortJments2 mo
|
||||
foldM updateCheckInfos mo infoss
|
||||
where
|
||||
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
|
||||
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 []))
|
||||
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
|
||||
--- 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))
|
||||
|
||||
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
|
||||
|
||||
checkUniq xss = case xss of
|
||||
@@ -317,13 +317,13 @@ linTypeOfType cnc m typ = do
|
||||
let vars = mkRecType varLabel $ replicate n typeStr
|
||||
symb = argIdent n cat i
|
||||
rec <- if n==0 then return val else
|
||||
checkErr $ errIn (render (text "extending" $$
|
||||
errIn (render (text "extending" $$
|
||||
nest 2 (ppTerm Unqualified 0 vars) $$
|
||||
text "with" $$
|
||||
nest 2 (ppTerm Unqualified 0 val))) $
|
||||
plusRecType vars val
|
||||
return (Explicit,symb,rec)
|
||||
lookLin (_,c) = checks [ --- rather: update with defLinType ?
|
||||
checkErr (lookupLincat cnc m c) >>= computeLType cnc []
|
||||
lookupLincat cnc m c >>= computeLType cnc []
|
||||
,return defLinType
|
||||
]
|
||||
|
||||
@@ -23,10 +23,9 @@ import GF.Grammar.Predef
|
||||
import GF.Grammar.Lockfield (isLockLabel)
|
||||
import GF.Data.BacktrackM
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.UseIO (IOE)
|
||||
import GF.Infra.UseIO (IOE,ePutStr,ePutStrLn)
|
||||
import GF.Data.Utilities (updateNthM) --updateNth
|
||||
import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues,ppL)
|
||||
import System.IO(hPutStr,hPutStrLn,stderr)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.List as List
|
||||
@@ -39,7 +38,6 @@ import Data.Array.Unboxed
|
||||
--import Data.Char (isDigit)
|
||||
import Control.Monad
|
||||
import Control.Monad.Identity
|
||||
import Control.Monad.Trans (liftIO)
|
||||
--import Control.Exception
|
||||
|
||||
----------------------------------------------------------------------
|
||||
@@ -48,7 +46,7 @@ import Control.Monad.Trans (liftIO)
|
||||
generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
|
||||
generatePMCFG opts sgr opath cmo@(cm,cmi) = do
|
||||
(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})
|
||||
where
|
||||
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
|
||||
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 ()
|
||||
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))
|
||||
where
|
||||
(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
|
||||
|
||||
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))
|
||||
where
|
||||
addLindef lins (newCat', newArgs') env0 =
|
||||
|
||||
@@ -35,8 +35,6 @@ import GF.Grammar.Grammar
|
||||
import GF.Grammar.Binary
|
||||
|
||||
import Control.Monad
|
||||
--import Data.Char
|
||||
--import Data.List
|
||||
import Data.Maybe(isJust)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
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.
|
||||
-- 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
|
||||
-- read module headers from all files recursively
|
||||
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
|
||||
where
|
||||
-- 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
|
||||
-- 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
|
||||
-> ModName -- ^ the current module
|
||||
-> IOE [ModuleInfo] -- ^ the final
|
||||
-> IOE [ModuleInfo] -- ^ the final -}
|
||||
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
|
||||
= return ds
|
||||
| otherwise = do
|
||||
@@ -91,20 +89,20 @@ getAllFiles opts ps env file = do
|
||||
|
||||
-- searches for module in the search path and if it is found
|
||||
-- returns 'ModuleInfo'. It fails if there is no such module
|
||||
findModule :: ModName -> IOE ModuleInfo
|
||||
--findModule :: ModName -> IOE ModuleInfo
|
||||
findModule name = do
|
||||
(file,gfTime,gfoTime) <- do
|
||||
mb_gfFile <- ioeIO $ getFilePath ps (gfFile name)
|
||||
mb_gfFile <- getFilePath ps (gfFile name)
|
||||
case mb_gfFile of
|
||||
Just gfFile -> do gfTime <- ioeIO $ toUTCTime `fmap` getModificationTime gfFile
|
||||
mb_gfoTime <- ioeIO $ catch (liftM Just $ toUTCTime `fmap` getModificationTime (gf2gfo opts gfFile))
|
||||
Just gfFile -> do gfTime <- liftIO $ toUTCTime `fmap` getModificationTime gfFile
|
||||
mb_gfoTime <- liftIO $ catch (liftM Just $ toUTCTime `fmap` getModificationTime (gf2gfo opts gfFile))
|
||||
(\_->return Nothing)
|
||||
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
|
||||
Just gfoFile -> do gfoTime <- ioeIO $ toUTCTime `fmap` getModificationTime gfoFile
|
||||
Just gfoFile -> do gfoTime <- liftIO $ toUTCTime `fmap` getModificationTime gfoFile
|
||||
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)))
|
||||
|
||||
|
||||
@@ -114,21 +112,21 @@ getAllFiles opts ps env file = do
|
||||
(st,(mname,imps)) <-
|
||||
case st of
|
||||
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
|
||||
Just mo -> return (st,importsOfModule mo)
|
||||
Nothing
|
||||
| isGFO file -> ioeErr $ Bad (file ++ " is compiled with different GF version and I can't find the source file")
|
||||
| otherwise -> do s <- ioeIO $ BS.readFile file
|
||||
| isGFO file -> raise (file ++ " is compiled with different GF version and I can't find the source file")
|
||||
| otherwise -> do s <- liftIO $ BS.readFile file
|
||||
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)
|
||||
CSComp -> do s <- ioeIO $ BS.readFile file
|
||||
CSComp -> do s <- liftIO $ BS.readFile file
|
||||
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)
|
||||
ioeErr $ testErr (mname == name)
|
||||
("module name" +++ mname +++ "differs from file name" +++ name)
|
||||
testErr (mname == name)
|
||||
("module name" +++ mname +++ "differs from file name" +++ name)
|
||||
return (name,st,t,isJust gfTime,imps,dropFileName file)
|
||||
|
||||
isGFO :: FilePath -> Bool
|
||||
@@ -212,16 +210,16 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
|
||||
modName = showIdent
|
||||
|
||||
-- | 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
|
||||
s <- ioe $ catch (fmap Ok $ BS.readFile file)
|
||||
(\_ -> return (Bad $ "File " ++ file ++ " does not exist"))
|
||||
s <- handle (liftIO $ BS.readFile file)
|
||||
(\_ -> raise $ "File " ++ file ++ " does not exist")
|
||||
let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
|
||||
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 paths file = get paths
|
||||
getFilePath :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath)
|
||||
getFilePath paths file = liftIO $ get paths
|
||||
where
|
||||
get [] = return Nothing
|
||||
get (p:ps) = do
|
||||
|
||||
@@ -45,7 +45,7 @@ import Text.PrettyPrint
|
||||
-- | this gives top-level access to renaming term input in the cc command
|
||||
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
|
||||
renameSourceTerm g m t = do
|
||||
mi <- checkErr $ lookupModule g m
|
||||
mi <- lookupModule g m
|
||||
status <- buildStatus g (m,mi)
|
||||
renameTerm status [] t
|
||||
|
||||
@@ -72,12 +72,12 @@ renameIdentTerm' env@(act,imps) t0 =
|
||||
Cn c -> ident (\_ s -> checkError s) c
|
||||
Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
|
||||
Q (m',c) -> do
|
||||
m <- checkErr (lookupErr m' qualifs)
|
||||
m <- lookupErr m' qualifs
|
||||
f <- lookupTree showIdent c m
|
||||
return $ f c
|
||||
QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
|
||||
QC (m',c) -> do
|
||||
m <- checkErr (lookupErr m' qualifs)
|
||||
m <- lookupErr m' qualifs
|
||||
f <- lookupTree showIdent c m
|
||||
return $ f c
|
||||
_ -> return t0
|
||||
@@ -127,7 +127,7 @@ buildStatus :: SourceGrammar -> SourceModule -> Check Status
|
||||
buildStatus gr mo@(m,mi) = checkIn (ppLocation (msrc mi) NoLoc <> colon) $ do
|
||||
let gr1 = prependModule gr mo
|
||||
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)
|
||||
return (if isModCnc mi
|
||||
then (emptyBinTree, reverse sts) -- the module itself does not define any names
|
||||
|
||||
@@ -19,7 +19,7 @@ writeTags opts gr file mo = do
|
||||
let imports = getImports opts gr mo
|
||||
locals = getLocalTags [] mo
|
||||
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) =
|
||||
[showIdent i ++ "\t" ++ k ++ "\t" ++ l ++ "\t" ++ t
|
||||
|
||||
@@ -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
|
||||
|
||||
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?
|
||||
|
||||
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
|
||||
s' <- comp g s
|
||||
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'
|
||||
|
||||
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
|
||||
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
|
||||
_ | isPredefConstant ty -> return ty
|
||||
@@ -76,9 +76,9 @@ inferLType gr g trm = case trm of
|
||||
Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
|
||||
|
||||
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)
|
||||
]
|
||||
@@ -88,9 +88,9 @@ inferLType gr g trm = case trm of
|
||||
Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
|
||||
|
||||
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)
|
||||
]
|
||||
@@ -214,10 +214,10 @@ inferLType gr g trm = case trm of
|
||||
sT' <- computeLType gr g sT
|
||||
|
||||
let trm' = ExtR r' s'
|
||||
---- trm' <- checkErr $ plusRecord r' s'
|
||||
---- trm' <- plusRecord r' s'
|
||||
case (rT', sT') of
|
||||
(RecType rs, RecType ss) -> do
|
||||
rt <- checkErr $ plusRecType rT' sT'
|
||||
rt <- plusRecType rT' sT'
|
||||
checkLType gr g trm' rt ---- return (trm', rt)
|
||||
_ | rT' == typeType && sT' == typeType -> return (trm', typeType)
|
||||
_ -> 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
|
||||
(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')
|
||||
|
||||
_ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
|
||||
@@ -289,7 +289,7 @@ inferLType gr g trm = case trm of
|
||||
_ -> False
|
||||
|
||||
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
|
||||
PNeg p -> inferPatt p
|
||||
PAlt p q -> checks [inferPatt p, inferPatt q]
|
||||
@@ -423,7 +423,7 @@ checkLType gr g trm typ0 = do
|
||||
case allParamValues gr arg of
|
||||
Ok vs -> do
|
||||
let ps0 = map fst cs
|
||||
ps <- checkErr $ testOvershadow ps0 vs
|
||||
ps <- testOvershadow ps0 vs
|
||||
if null ps
|
||||
then return ()
|
||||
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
|
||||
|
||||
ELin c tr -> do
|
||||
tr1 <- checkErr $ unlockRecord c tr
|
||||
tr1 <- unlockRecord c tr
|
||||
checkLType gr g tr1 typ
|
||||
|
||||
_ -> do
|
||||
@@ -547,7 +547,7 @@ pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
|
||||
pattContext env g typ p = case p of
|
||||
PV x -> return [(Explicit,x,typ)]
|
||||
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
|
||||
checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
|
||||
(length cont == length ps)
|
||||
|
||||
@@ -55,7 +55,7 @@ extendModule gr (name,m)
|
||||
return (name,m')
|
||||
where
|
||||
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
|
||||
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"))
|
||||
case mt of
|
||||
MTInstance (i0,mincl) -> do
|
||||
m1 <- checkErr $ lookupModule gr i0
|
||||
m1 <- lookupModule gr i0
|
||||
unless (isModRes m1)
|
||||
(checkError (text "interface expected instead of" <+> ppIdent i0))
|
||||
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
|
||||
[] -> return mi{jments=js'}
|
||||
j0s -> do
|
||||
m0s <- checkErr $ mapM (lookupModule gr) j0s
|
||||
m0s <- mapM (lookupModule gr) j0s
|
||||
let notInM0 c _ = all (not . isInBinTree c . jments) m0s
|
||||
let js2 = filterBinTree notInM0 js'
|
||||
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]
|
||||
unless (stat' == MSComplete || stat == MSIncomplete)
|
||||
(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 $
|
||||
ops_ ++ -- N.B. js has been name-resolved already
|
||||
[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
|
||||
Ok k -> return $ updateTree (c,k) new
|
||||
Bad _ -> do (base,j) <- case j of
|
||||
AnyInd _ m -> checkErr $ lookupOrigInfo gr (m,c)
|
||||
AnyInd _ m -> lookupOrigInfo gr (m,c)
|
||||
_ -> return (base,j)
|
||||
(name,i) <- case i of
|
||||
AnyInd _ m -> checkErr $ lookupOrigInfo gr (m,c)
|
||||
AnyInd _ m -> lookupOrigInfo gr (m,c)
|
||||
_ -> return (name,i)
|
||||
checkError (text "cannot unify the information" $$
|
||||
nest 4 (ppJudgement Qualified (c,i)) $$
|
||||
|
||||
@@ -21,7 +21,7 @@ module GF.Data.Operations (-- * misc functions
|
||||
Err(..), err, maybeErr, testErr, errVal, errIn,
|
||||
lookupErr,
|
||||
mapPairListM, mapPairsM, pairM,
|
||||
singleton, mapsErr, mapsErrTree,
|
||||
singleton, --mapsErr, mapsErrTree,
|
||||
|
||||
-- ** checking
|
||||
checkUnique,
|
||||
@@ -55,7 +55,8 @@ module GF.Data.Operations (-- * misc functions
|
||||
STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM, done,
|
||||
|
||||
-- * error monad class
|
||||
ErrorMonad(..), checkAgain, checks, allChecks, doUntil
|
||||
ErrorMonad(..), checkAgain, checks, allChecks, doUntil,
|
||||
liftErr
|
||||
|
||||
) where
|
||||
|
||||
@@ -85,19 +86,19 @@ err d f e = case e of
|
||||
Bad s -> d s
|
||||
|
||||
-- | add msg s to @Maybe@ failures
|
||||
maybeErr :: String -> Maybe a -> Err a
|
||||
maybeErr s = maybe (Bad s) Ok
|
||||
maybeErr :: ErrorMonad m => String -> Maybe a -> m a
|
||||
maybeErr s = maybe (raise s) return
|
||||
|
||||
testErr :: Bool -> String -> Err ()
|
||||
testErr cond msg = if cond then return () else Bad msg
|
||||
testErr :: ErrorMonad m => Bool -> String -> m ()
|
||||
testErr cond msg = if cond then return () else raise msg
|
||||
|
||||
errVal :: a -> Err a -> a
|
||||
errVal a = err (const a) id
|
||||
|
||||
errIn :: String -> Err a -> Err a
|
||||
errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return
|
||||
errIn :: ErrorMonad m => String -> m a -> m a
|
||||
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)
|
||||
|
||||
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 f = stm (\s -> return (f s))
|
||||
|
||||
instance Functor (STM s) where fmap = liftM
|
||||
|
||||
instance Monad (STM s) where
|
||||
return a = STM (\s -> return (a,s))
|
||||
STM c >>= f = STM (\s -> do
|
||||
@@ -332,7 +335,7 @@ writeSTM s = stmr (const ((),s))
|
||||
done :: Monad m => m ()
|
||||
done = return ()
|
||||
|
||||
class Monad m => ErrorMonad m where
|
||||
class (Functor m,Monad m) => ErrorMonad m where
|
||||
raise :: String -> m a
|
||||
handle :: m a -> (String -> m a) -> m a
|
||||
handle_ :: m a -> m a -> m a
|
||||
@@ -343,12 +346,14 @@ instance ErrorMonad Err where
|
||||
handle a@(Ok _) _ = a
|
||||
handle (Bad i) f = f i
|
||||
|
||||
liftErr e = err raise return e
|
||||
|
||||
instance ErrorMonad (STM s) where
|
||||
raise msg = STM (\s -> raise msg)
|
||||
handle (STM f) g = STM (\s -> (f s)
|
||||
`handle` (\e -> let STM g' = (g e) in
|
||||
g' s))
|
||||
|
||||
{-
|
||||
-- error recovery with multiple reporting AR 30/5/2008
|
||||
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 f t = mapsErr f (tree2list t) >>= return . sorted2tree
|
||||
|
||||
-}
|
||||
|
||||
-- | if the first check fails try another one
|
||||
checkAgain :: ErrorMonad m => m a -> m a -> m a
|
||||
|
||||
@@ -28,14 +28,14 @@ import Data.Char
|
||||
import Data.List
|
||||
--import System.FilePath
|
||||
|
||||
getCF :: FilePath -> String -> Err SourceGrammar
|
||||
getCF :: ErrorMonad m => FilePath -> String -> m SourceGrammar
|
||||
getCF fpath = fmap (cf2gf fpath . uniqueFuns) . pCF
|
||||
|
||||
---------------------
|
||||
-- the parser -------
|
||||
---------------------
|
||||
|
||||
pCF :: String -> Err CF
|
||||
pCF :: ErrorMonad m => String -> m CF
|
||||
pCF s = do
|
||||
rules <- mapM getCFRule $ filter isRule $ lines s
|
||||
return $ concat rules
|
||||
@@ -48,14 +48,14 @@ pCF s = do
|
||||
-- fun. C -> item1 item2 ... where unquoted items are treated as cats
|
||||
-- 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
|
||||
getcf ws = case ws of
|
||||
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 ->
|
||||
Ok [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
|
||||
_ -> Bad (" invalid rule:" +++ s)
|
||||
return [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
|
||||
_ -> raise (" invalid rule:" +++ s)
|
||||
isArrow a = elem a ["->", "::="]
|
||||
mkIt w = case w of
|
||||
('"':w@(_:_)) -> Right (init w)
|
||||
|
||||
@@ -195,17 +195,17 @@ mGrammar ms = MGrammar (Map.fromList ms) ms
|
||||
|
||||
-- | we store the module type with the identifier
|
||||
|
||||
abstractOfConcrete :: SourceGrammar -> Ident -> Err Ident
|
||||
abstractOfConcrete :: ErrorMonad m => SourceGrammar -> Ident -> m Ident
|
||||
abstractOfConcrete gr c = do
|
||||
n <- lookupModule gr c
|
||||
case mtype n of
|
||||
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
|
||||
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 m =
|
||||
|
||||
@@ -20,9 +20,9 @@ import GF.Infra.Ident
|
||||
import GF.Grammar.Grammar
|
||||
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) =
|
||||
let lab = lockLabel c in
|
||||
return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]
|
||||
|
||||
@@ -50,19 +50,19 @@ lock c = lockRecType c -- return
|
||||
unlock c = unlockRecord c -- return
|
||||
|
||||
-- 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 =
|
||||
case lookupTree showIdent c t of
|
||||
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)
|
||||
|
||||
lookupQIdentInfo :: SourceGrammar -> QIdent -> Err Info
|
||||
lookupQIdentInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m Info
|
||||
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)
|
||||
|
||||
lookupResDefLoc gr (m,c)
|
||||
@@ -83,9 +83,9 @@ lookupResDefLoc gr (m,c)
|
||||
AnyInd _ n -> look n c
|
||||
ResParam _ _ -> 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
|
||||
info <- lookupQIdentInfo gr (m,c)
|
||||
case info of
|
||||
@@ -99,9 +99,9 @@ lookupResType gr (m,c) = do
|
||||
AnyInd _ n -> lookupResType gr (n,c)
|
||||
ResParam _ _ -> return typePType
|
||||
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
|
||||
info <- lookupQIdentInfo gr (m,c)
|
||||
case info of
|
||||
@@ -112,10 +112,10 @@ lookupOverload gr (m,c) = do
|
||||
concat tss
|
||||
|
||||
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
|
||||
lookupOrigInfo :: SourceGrammar -> QIdent -> Err (Ident,Info)
|
||||
lookupOrigInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m (Ident,Info)
|
||||
lookupOrigInfo gr (m,c) = do
|
||||
info <- lookupQIdentInfo gr (m,c)
|
||||
case info of
|
||||
@@ -127,14 +127,14 @@ allOrigInfos gr m = errVal [] $ do
|
||||
mo <- lookupModule gr m
|
||||
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
|
||||
(_,info) <- lookupOrigInfo gr c
|
||||
case info of
|
||||
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 =
|
||||
case ptyp of
|
||||
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
|
||||
@@ -148,12 +148,12 @@ allParamValues cnc ptyp =
|
||||
pvs <- allParamValues cnc pt
|
||||
vvs <- allParamValues cnc vt
|
||||
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
|
||||
-- to normalize records and record types
|
||||
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
|
||||
info <- lookupQIdentInfo gr (m,c)
|
||||
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
|
||||
_ -> 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 = do
|
||||
info <- lookupQIdentInfo gr (m,c)
|
||||
case info of
|
||||
CncCat (Just (L _ t)) _ _ _ _ -> return t
|
||||
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
|
||||
lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
|
||||
lookupFunType :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
|
||||
lookupFunType gr m c = do
|
||||
info <- lookupQIdentInfo gr (m,c)
|
||||
case info of
|
||||
AbsFun (Just (L _ t)) _ _ _ -> return t
|
||||
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
|
||||
lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
|
||||
lookupCatContext :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Context
|
||||
lookupCatContext gr m c = do
|
||||
info <- lookupQIdentInfo gr (m,c)
|
||||
case info of
|
||||
AbsCat (Just (L _ co)) -> return co
|
||||
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
|
||||
|
||||
@@ -262,22 +262,22 @@ mkWildCases = mkCases identW
|
||||
mkFunType :: [Type] -> Type -> Type
|
||||
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
|
||||
(RecType r1, RecType r2) -> case
|
||||
filter (`elem` (map fst r1)) (map fst r2) of
|
||||
[] -> return (RecType (r1 ++ r2))
|
||||
ls -> fail $ 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)
|
||||
ls -> raise $ render (text "clashing labels" <+> hsep (map ppLabel ls))
|
||||
_ -> 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 =
|
||||
case (t1,t2) of
|
||||
(R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
|
||||
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
|
||||
(_, FV rs) -> mapM (plusRecord t1) 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
|
||||
defLinType :: Type
|
||||
@@ -444,7 +444,7 @@ strsFromTerm t = case t of
|
||||
]
|
||||
FV 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
|
||||
stringFromTerm :: Term -> String
|
||||
@@ -599,20 +599,20 @@ allDependencies ism b =
|
||||
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
|
||||
is <- either
|
||||
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)))
|
||||
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
|
||||
iss <- either
|
||||
return
|
||||
(\cyc -> fail (render (text "circular definitions:"
|
||||
<+> fsep (map ppIdent (head cyc)))))
|
||||
(\cyc -> raise (render (text "circular definitions:"
|
||||
<+> fsep (map ppIdent (head cyc)))))
|
||||
(topoTest2 (allDependencies (==m) (jments mi)))
|
||||
return
|
||||
[[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss]
|
||||
|
||||
@@ -29,10 +29,10 @@ import Control.Monad
|
||||
import Text.PrettyPrint
|
||||
--import Debug.Trace
|
||||
|
||||
matchPattern :: [(Patt,rhs)] -> Term -> Err (rhs, Substitution)
|
||||
matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
|
||||
matchPattern pts 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
|
||||
term' <- mkK term
|
||||
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]
|
||||
C v w -> liftM2 (++) (getS v) (getS w)
|
||||
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
|
||||
let numpts = zip pts [0..]
|
||||
let cases = [(p,EInt i) | (p,i) <- numpts]
|
||||
ts <- mapM (liftM fst . matchPattern cases) vs
|
||||
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
|
||||
[] -> 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 ->
|
||||
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)))
|
||||
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
|
||||
Ok substs -> return (val, concat substs)
|
||||
@@ -116,7 +116,7 @@ tryMatch (p,t) = do
|
||||
|
||||
(PNeg p',_) -> case tryMatch (p',t) of
|
||||
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
|
||||
(PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
|
||||
@@ -130,7 +130,7 @@ tryMatch (p,t) = do
|
||||
(PChar, ([],K [_], [])) -> 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
|
||||
--matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s
|
||||
|
||||
@@ -15,7 +15,7 @@
|
||||
module GF.Infra.CheckM
|
||||
(Check, CheckResult, Message, runCheck,
|
||||
checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
|
||||
checkErr, checkIn, checkMap, checkMapRecover,
|
||||
{-checkErr,-} checkIn, checkMap, checkMapRecover,
|
||||
parallelCheck, accumulateError, commitCheck,
|
||||
) where
|
||||
|
||||
@@ -92,14 +92,14 @@ commitCheck c =
|
||||
list = vcat . reverse
|
||||
|
||||
-- | Run an error check, report errors and warnings
|
||||
runCheck :: Check a -> Err (a,String)
|
||||
runCheck :: ErrorMonad m => Check a -> m (a,String)
|
||||
runCheck c =
|
||||
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
|
||||
((es,ws),Fail e) -> bad ((e:es),ws)
|
||||
where
|
||||
bad (es,ws) = Bad (render $ list ws $$ list es)
|
||||
bad (es,ws) = raise (render $ list ws $$ list es)
|
||||
list = vcat . reverse
|
||||
|
||||
parallelCheck :: [Check a] -> Check [a]
|
||||
@@ -135,10 +135,6 @@ checkMapRecover f mp = do
|
||||
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 msg c = Check $ \{-ctxt-} msgs0 ->
|
||||
case unCheck c {-ctxt-} ([],[]) of
|
||||
|
||||
@@ -13,7 +13,7 @@
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Infra.UseIO where
|
||||
module GF.Infra.UseIO(module GF.Infra.UseIO,MonadIO(..),liftErr) where
|
||||
|
||||
import Prelude hiding (catch)
|
||||
|
||||
@@ -35,8 +35,8 @@ import Control.Monad
|
||||
import Control.Monad.Trans(MonadIO(..))
|
||||
import Control.Exception(evaluate)
|
||||
|
||||
putShow' :: Show a => (c -> a) -> c -> IO ()
|
||||
putShow' f = putStrLn . show . length . show . f
|
||||
--putShow' :: Show a => (c -> a) -> c -> IO ()
|
||||
--putShow' f = putStrLn . show . length . show . f
|
||||
|
||||
putIfVerb :: Options -> String -> IO ()
|
||||
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
|
||||
|
||||
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 = IOE
|
||||
|
||||
ioeIO :: IO a -> IOE a
|
||||
ioeIO io = ioe (io >>= return . return)
|
||||
instance MonadIO IOE where liftIO io = ioe (io >>= return . return)
|
||||
|
||||
ioeErr :: Err a -> IOE a
|
||||
ioeErr = ioe . return
|
||||
|
||||
ioeErrIn :: String -> IOE a -> IOE a
|
||||
ioeErrIn msg (IOE ioe) = IOE (fmap (errIn msg) ioe)
|
||||
instance ErrorMonad IOE where
|
||||
raise = ioe . return . Bad
|
||||
handle m h = ioe $ err (appIOE . h) (return . Ok) =<< appIOE m
|
||||
|
||||
instance Functor IOE where fmap = liftM
|
||||
|
||||
@@ -146,22 +137,17 @@ instance Monad IOE where
|
||||
return a = ioe (return (return a))
|
||||
IOE c >>= f = IOE $ do
|
||||
x <- c -- Err a
|
||||
appIOE $ err ioeBad f x -- f :: a -> IOE a
|
||||
fail = ioeBad
|
||||
|
||||
instance MonadIO IOE where liftIO = ioeIO
|
||||
|
||||
ioeBad :: String -> IOE a
|
||||
ioeBad = ioe . return . Bad
|
||||
appIOE $ err raise f x -- f :: a -> IOE a
|
||||
fail = raise
|
||||
|
||||
useIOE :: a -> IOE a -> IO a
|
||||
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
|
||||
[] -> return (s,Nothing)
|
||||
x:xx -> do
|
||||
ev <- ioeIO $ appIOE (f s x)
|
||||
ev <- liftIO $ appIOE (f s x)
|
||||
case ev of
|
||||
Ok v -> foldIOE f v xx
|
||||
Bad m -> return $ (s, Just m)
|
||||
@@ -170,19 +156,19 @@ die :: String -> IO a
|
||||
die s = do hPutStrLn stderr s
|
||||
exitFailure
|
||||
|
||||
putStrLnE :: String -> IOE ()
|
||||
putStrLnE = ioeIO . putStrLnFlush
|
||||
ePutStr, ePutStrLn, putStrE, putStrLnE :: MonadIO m => String -> m ()
|
||||
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 ()
|
||||
putStrE = ioeIO . putStrFlush
|
||||
|
||||
putPointE :: Verbosity -> Options -> String -> IOE a -> IOE a
|
||||
putPointE :: MonadIO m => Verbosity -> Options -> String -> m a -> m a
|
||||
putPointE v opts msg act = do
|
||||
when (verbAtLeast opts v) $ ioeIO $ putStrFlush msg
|
||||
when (verbAtLeast opts v) $ putStrE msg
|
||||
|
||||
t1 <- ioeIO $ getCPUTime
|
||||
a <- act >>= ioeIO . evaluate
|
||||
t2 <- ioeIO $ getCPUTime
|
||||
t1 <- liftIO $ getCPUTime
|
||||
a <- act >>= liftIO . evaluate
|
||||
t2 <- liftIO $ getCPUTime
|
||||
|
||||
if flag optShowCPUTime opts
|
||||
then do let msec = (t2 - t1) `div` 1000000000
|
||||
|
||||
@@ -55,9 +55,9 @@ compileSourceFiles opts fs =
|
||||
|
||||
compileCFFiles :: Options -> [FilePath] -> IOE ()
|
||||
compileCFFiles opts fs =
|
||||
do s <- ioeIO $ fmap unlines $ mapM readFile fs
|
||||
do s <- liftIO $ fmap unlines $ mapM readFile fs
|
||||
let cnc = justModuleName (last fs)
|
||||
gf <- ioeErr $ getCF cnc s
|
||||
gf <- getCF cnc s
|
||||
gr <- compileSourceGrammar opts gf
|
||||
if flag optStopAfterPhase opts == Compile
|
||||
then return ()
|
||||
@@ -76,7 +76,7 @@ unionPGFFiles opts fs =
|
||||
then putStrLnE $ "Refusing to overwrite " ++ pgfFile
|
||||
else writePGF 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 opts pgf = do
|
||||
@@ -93,7 +93,7 @@ writeByteCode opts pgf
|
||||
path = case flag optOutputDir opts of
|
||||
Nothing -> file
|
||||
Just dir -> dir </> file
|
||||
in putPointE Normal opts ("Writing " ++ path ++ "...") $ ioeIO $
|
||||
in putPointE Normal opts ("Writing " ++ path ++ "...") $ liftIO $
|
||||
bracket
|
||||
(openFile path WriteMode)
|
||||
(hClose)
|
||||
@@ -109,14 +109,14 @@ writeByteCode opts pgf
|
||||
writePGF :: Options -> PGF -> IOE ()
|
||||
writePGF opts pgf = do
|
||||
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 opts pgf = fromMaybe (showCId (absname pgf)) (flag optName opts)
|
||||
|
||||
writeOutput :: Options -> FilePath-> String -> IOE ()
|
||||
writeOutput opts file str =
|
||||
putPointE Normal opts ("Writing " ++ path ++ "...") $ ioeIO $
|
||||
putPointE Normal opts ("Writing " ++ path ++ "...") $ liftIO $
|
||||
writeUTF8File path str
|
||||
where
|
||||
path = maybe id (</>) (flag optOutputDir opts) file
|
||||
|
||||
@@ -8,8 +8,7 @@ import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,emptyCommandE
|
||||
import GF.Command.Commands(flags,options)
|
||||
import GF.Command.Abstract
|
||||
import GF.Command.Parse(readCommandLine,pCommand)
|
||||
import GF.Data.ErrM
|
||||
import GF.Data.Operations (chunks,err)
|
||||
import GF.Data.Operations (Err(..),chunks,err,raise)
|
||||
import GF.Grammar hiding (Ident,isPrefixOf)
|
||||
import GF.Grammar.Analyse
|
||||
import GF.Grammar.Parser (runP, pExp)
|
||||
@@ -326,7 +325,7 @@ printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
|
||||
|
||||
checkComputeTerm = checkComputeTerm' False
|
||||
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
|
||||
inferLType sgr [] t
|
||||
t1 <- if new
|
||||
|
||||
@@ -7,7 +7,7 @@ import Control.Monad(when)
|
||||
import Control.Monad.State(StateT(..),get,gets,put)
|
||||
import Control.Monad.Error(ErrorT(..),Error(..))
|
||||
import System.Random(randomRIO)
|
||||
import System.IO(stderr,hPutStrLn)
|
||||
--import System.IO(stderr,hPutStrLn)
|
||||
import GF.System.Catch(try)
|
||||
import System.IO.Error(isAlreadyExistsError)
|
||||
import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory,
|
||||
@@ -33,7 +33,7 @@ import Text.JSON(encode,showJSON,makeObj)
|
||||
import System.Process(readProcessWithExitCode)
|
||||
import System.Exit(ExitCode(..))
|
||||
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 qualified PGFService as PS
|
||||
import qualified ExampleService as ES
|
||||
@@ -334,7 +334,7 @@ serveStaticFile' path =
|
||||
return (resp404 path)
|
||||
|
||||
-- * Logging
|
||||
logPutStrLn s = liftIO . hPutStrLn stderr $ s
|
||||
logPutStrLn s = ePutStrLn s
|
||||
|
||||
-- * JSONP output
|
||||
|
||||
|
||||
Reference in New Issue
Block a user