diff options
| author | aarne <aarne@cs.chalmers.se> | 2008-06-25 16:54:35 +0000 |
|---|---|---|
| committer | aarne <aarne@cs.chalmers.se> | 2008-06-25 16:54:35 +0000 |
| commit | e9e80fc389365e24d4300d7d5390c7d833a96c50 (patch) | |
| tree | f0b58473adaa670bd8fc52ada419d8cad470ee03 /src-3.0/GF/Infra | |
| parent | b96b36f43de3e2f8b58d5f539daa6f6d47f25870 (diff) | |
changed names of resource-1.3; added a note on homepage on release
Diffstat (limited to 'src-3.0/GF/Infra')
| -rw-r--r-- | src-3.0/GF/Infra/CheckM.hs | 89 | ||||
| -rw-r--r-- | src-3.0/GF/Infra/CompactPrint.hs | 22 | ||||
| -rw-r--r-- | src-3.0/GF/Infra/GetOpt.hs | 381 | ||||
| -rw-r--r-- | src-3.0/GF/Infra/Ident.hs | 152 | ||||
| -rw-r--r-- | src-3.0/GF/Infra/Modules.hs | 429 | ||||
| -rw-r--r-- | src-3.0/GF/Infra/Option.hs | 549 | ||||
| -rw-r--r-- | src-3.0/GF/Infra/PrintClass.hs | 51 | ||||
| -rw-r--r-- | src-3.0/GF/Infra/UseIO.hs | 277 |
8 files changed, 0 insertions, 1950 deletions
diff --git a/src-3.0/GF/Infra/CheckM.hs b/src-3.0/GF/Infra/CheckM.hs deleted file mode 100644 index 251ed2b8b..000000000 --- a/src-3.0/GF/Infra/CheckM.hs +++ /dev/null @@ -1,89 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CheckM --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:33 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Infra.CheckM (Check, - checkError, checkCond, checkWarn, checkUpdate, checkInContext, - checkUpdates, checkReset, checkResets, checkGetContext, - checkLookup, checkStart, checkErr, checkVal, checkIn, - prtFail - ) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.PrGrammar - --- | the strings are non-fatal warnings -type Check a = STM (Context,[String]) a - -checkError :: String -> Check a -checkError = raise - -checkCond :: String -> Bool -> Check () -checkCond s b = if b then return () else checkError s - --- | warnings should be reversed in the end -checkWarn :: String -> Check () -checkWarn s = updateSTM (\ (cont,msg) -> (cont, s:msg)) - -checkUpdate :: Decl -> Check () -checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg)) - -checkInContext :: [Decl] -> Check r -> Check r -checkInContext g ch = do - i <- checkUpdates g - r <- ch - checkResets i - return r - -checkUpdates :: [Decl] -> Check Int -checkUpdates ds = mapM checkUpdate ds >> return (length ds) - -checkReset :: Check () -checkReset = checkResets 1 - -checkResets :: Int -> Check () -checkResets i = updateSTM (\ (cont,msg) -> (drop i cont, msg)) - -checkGetContext :: Check Context -checkGetContext = do - (co,_) <- readSTM - return co - -checkLookup :: Ident -> Check Type -checkLookup x = do - co <- checkGetContext - checkErr $ maybe (prtBad "unknown variable" x) return $ lookup x co - -checkStart :: Check a -> Err (a,(Context,[String])) -checkStart c = appSTM c ([],[]) - -checkErr :: Err a -> Check a -checkErr e = stm (\s -> do - v <- e - return (v,s) - ) - -checkVal :: a -> Check a -checkVal v = return v - -prtFail :: Print a => String -> a -> Check b -prtFail s t = checkErr $ prtBad s t - -checkIn :: String -> Check a -> Check a -checkIn msg c = stm $ \s@(g,ws) -> case appSTM c s of - Bad e -> Bad $ msg ++++ e - Ok (v,(g',ws')) -> Ok (v,(g',ws2)) where - new = take (length ws' - length ws) ws' - ws2 = [msg ++++ w | w <- new] ++ ws diff --git a/src-3.0/GF/Infra/CompactPrint.hs b/src-3.0/GF/Infra/CompactPrint.hs deleted file mode 100644 index 486c9e183..000000000 --- a/src-3.0/GF/Infra/CompactPrint.hs +++ /dev/null @@ -1,22 +0,0 @@ -module GF.Infra.CompactPrint where -import Data.Char - -compactPrint = compactPrintCustom keywordGF (const False) - -compactPrintGFCC = compactPrintCustom (const False) keywordGFCC - -compactPrintCustom pre post = dps . concat . map (spaceIf pre post) . words - -dps = dropWhile isSpace - -spaceIf pre post w = case w of - _ | pre w -> "\n" ++ w - _ | post w -> w ++ "\n" - c:_ | isAlpha c || isDigit c -> " " ++ w - '_':_ -> " " ++ w - _ -> w - -keywordGF w = elem w ["cat","fun","lin","lincat","lindef","oper","param"] -keywordGFCC w = - last w == ';' || - elem w ["flags","fun","cat","lin","oper","lincat","lindef","printname","param"] diff --git a/src-3.0/GF/Infra/GetOpt.hs b/src-3.0/GF/Infra/GetOpt.hs deleted file mode 100644 index ede561c90..000000000 --- a/src-3.0/GF/Infra/GetOpt.hs +++ /dev/null @@ -1,381 +0,0 @@ --- This is a version of System.Console.GetOpt which has been hacked to --- support long options with a single dash. Since we don't want the annoying --- clash with short options that start with the same character as a long --- one, we don't allow short options to be given together (e.g. -zxf), --- nor do we allow options to be given as any unique prefix. - ------------------------------------------------------------------------------ --- | --- Module : System.Console.GetOpt --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- This library provides facilities for parsing the command-line options --- in a standalone program. It is essentially a Haskell port of the GNU --- @getopt@ library. --- ------------------------------------------------------------------------------ - -{- -Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small -changes Dec. 1997) - -Two rather obscure features are missing: The Bash 2.0 non-option hack -(if you don't already know it, you probably don't want to hear about -it...) and the recognition of long options with a single dash -(e.g. '-help' is recognised as '--help', as long as there is no short -option 'h'). - -Other differences between GNU's getopt and this implementation: - -* To enforce a coherent description of options and arguments, there - are explanation fields in the option/argument descriptor. - -* Error messages are now more informative, but no longer POSIX - compliant... :-( - -And a final Haskell advertisement: The GNU C implementation uses well -over 1100 lines, we need only 195 here, including a 46 line example! -:-) --} - ---module System.Console.GetOpt ( -module GF.Infra.GetOpt ( - -- * GetOpt - getOpt, getOpt', - usageInfo, - ArgOrder(..), - OptDescr(..), - ArgDescr(..), - - -- * Examples - - -- |To hopefully illuminate the role of the different data structures, - -- here are the command-line options for a (very simple) compiler, - -- done in two different ways. - -- The difference arises because the type of 'getOpt' is - -- parameterized by the type of values derived from flags. - - -- ** Interpreting flags as concrete values - -- $example1 - - -- ** Interpreting flags as transformations of an options record - -- $example2 -) where - -import Prelude -- necessary to get dependencies right - -import Data.List ( isPrefixOf, find ) - --- |What to do with options following non-options -data ArgOrder a - = RequireOrder -- ^ no option processing after first non-option - | Permute -- ^ freely intersperse options and non-options - | ReturnInOrder (String -> a) -- ^ wrap non-options into options - -{-| -Each 'OptDescr' describes a single option. - -The arguments to 'Option' are: - -* list of short option characters - -* list of long option strings (without \"--\") - -* argument descriptor - -* explanation of option for user --} -data OptDescr a = -- description of a single options: - Option [Char] -- list of short option characters - [String] -- list of long option strings (without "--") - (ArgDescr a) -- argument descriptor - String -- explanation of option for user - --- |Describes whether an option takes an argument or not, and if so --- how the argument is injected into a value of type @a@. -data ArgDescr a - = NoArg a -- ^ no argument expected - | ReqArg (String -> a) String -- ^ option requires argument - | OptArg (Maybe String -> a) String -- ^ optional argument - -data OptKind a -- kind of cmd line arg (internal use only): - = Opt a -- an option - | UnreqOpt String -- an un-recognized option - | NonOpt String -- a non-option - | EndOfOpts -- end-of-options marker (i.e. "--") - | OptErr String -- something went wrong... - --- | Return a string describing the usage of a command, derived from --- the header (first argument) and the options described by the --- second argument. -usageInfo :: String -- header - -> [OptDescr a] -- option descriptors - -> String -- nicely formatted decription of options -usageInfo header optDescr = unlines (header:table) - where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr - table = zipWith3 paste (sameLen ss) (sameLen ls) ds - paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z - sameLen xs = flushLeft ((maximum . map length) xs) xs - flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] - -fmtOpt :: OptDescr a -> [(String,String,String)] -fmtOpt (Option sos los ad descr) = - case lines descr of - [] -> [(sosFmt,losFmt,"")] - (d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ] - where sepBy _ [] = "" - sepBy _ [x] = x - sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs - sosFmt = sepBy ',' (map (fmtShort ad) sos) - losFmt = sepBy ',' (map (fmtLong ad) los) - -fmtShort :: ArgDescr a -> Char -> String -fmtShort (NoArg _ ) so = "-" ++ [so] -fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad -fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]" - -fmtLong :: ArgDescr a -> String -> String -fmtLong (NoArg _ ) lo = "--" ++ lo -fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad -fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" - -{-| -Process the command-line, and return the list of values that matched -(and those that didn\'t). The arguments are: - -* The order requirements (see 'ArgOrder') - -* The option descriptions (see 'OptDescr') - -* The actual command line arguments (presumably got from - 'System.Environment.getArgs'). - -'getOpt' returns a triple consisting of the option arguments, a list -of non-options, and a list of error messages. --} -getOpt :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String],[String]) -- (options,non-options,error messages) -getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) - where (os,xs,us,es) = getOpt' ordering optDescr args - -{-| -This is almost the same as 'getOpt', but returns a quadruple -consisting of the option arguments, a list of non-options, a list of -unrecognized options, and a list of error messages. --} -getOpt' :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) -getOpt' _ _ [] = ([],[],[],[]) -getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering - where procNextOpt (Opt o) _ = (o:os,xs,us,es) - procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) - procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) - procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) - procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) - procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) - procNextOpt EndOfOpts Permute = ([],rest,[],[]) - procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) - procNextOpt (OptErr e) _ = (os,xs,us,e:es) - - (opt,rest) = getNext arg args optDescr - (os,xs,us,es) = getOpt' ordering optDescr rest - --- take a look at the next cmd line arg and decide what to do with it -getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) -getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr -getNext ('-' :xs) rest optDescr = longOpt xs rest optDescr -getNext a rest _ = (NonOpt a,rest) - --- handle long option -longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -longOpt ls rs optDescr = long ads arg rs - where (opt,arg) = break (=='=') ls - options = [ o | o@(Option ss xs _ _) <- optDescr - , opt `elem` map (:[]) ss || opt `elem` xs ] - ads = [ ad | Option _ _ ad _ <- options ] - optStr = ("--"++opt) - - long (_:_:_) _ rest = (errAmbig options optStr,rest) - long [NoArg a ] [] rest = (Opt a,rest) - long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) - long [ReqArg _ d] [] [] = (errReq d optStr,[]) - long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) - long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) - long [OptArg f _] [] rest = (Opt (f Nothing),rest) - long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) - long _ _ rest = (UnreqOpt ("--"++ls),rest) - - --- miscellaneous error formatting - -errAmbig :: [OptDescr a] -> String -> OptKind a -errAmbig ods optStr = OptErr (usageInfo header ods) - where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" - -errReq :: String -> String -> OptKind a -errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") - -errUnrec :: String -> String -errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" - -errNoArg :: String -> OptKind a -errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") - -{- ------------------------------------------------------------------------------------------ --- and here a small and hopefully enlightening example: - -data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show - -options :: [OptDescr Flag] -options = - [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", - Option ['V','?'] ["version","release"] (NoArg Version) "show version info", - Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", - Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] - -out :: Maybe String -> Flag -out Nothing = Output "stdout" -out (Just o) = Output o - -test :: ArgOrder Flag -> [String] -> String -test order cmdline = case getOpt order options cmdline of - (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" - (_,_,errs) -> concat errs ++ usageInfo header options - where header = "Usage: foobar [OPTION...] files..." - --- example runs: --- putStr (test RequireOrder ["foo","-v"]) --- ==> options=[] args=["foo", "-v"] --- putStr (test Permute ["foo","-v"]) --- ==> options=[Verbose] args=["foo"] --- putStr (test (ReturnInOrder Arg) ["foo","-v"]) --- ==> options=[Arg "foo", Verbose] args=[] --- putStr (test Permute ["foo","--","-v"]) --- ==> options=[] args=["foo", "-v"] --- putStr (test Permute ["-?o","--name","bar","--na=baz"]) --- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] --- putStr (test Permute ["--ver","foo"]) --- ==> option `--ver' is ambiguous; could be one of: --- -v --verbose verbosely list files --- -V, -? --version, --release show version info --- Usage: foobar [OPTION...] files... --- -v --verbose verbosely list files --- -V, -? --version, --release show version info --- -o[FILE] --output[=FILE] use FILE for dump --- -n USER --name=USER only dump USER's files ------------------------------------------------------------------------------------------ --} - -{- $example1 - -A simple choice for the type associated with flags is to define a type -@Flag@ as an algebraic type representing the possible flags and their -arguments: - -> module Opts1 where -> -> import System.Console.GetOpt -> import Data.Maybe ( fromMaybe ) -> -> data Flag -> = Verbose | Version -> | Input String | Output String | LibDir String -> deriving Show -> -> options :: [OptDescr Flag] -> options = -> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" -> , Option ['V','?'] ["version"] (NoArg Version) "show version number" -> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" -> , Option ['c'] [] (OptArg inp "FILE") "input FILE" -> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" -> ] -> -> inp,outp :: Maybe String -> Flag -> outp = Output . fromMaybe "stdout" -> inp = Input . fromMaybe "stdin" -> -> compilerOpts :: [String] -> IO ([Flag], [String]) -> compilerOpts argv = -> case getOpt Permute options argv of -> (o,n,[] ) -> return (o,n) -> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) -> where header = "Usage: ic [OPTION...] files..." - -Then the rest of the program will use the constructed list of flags -to determine it\'s behaviour. - --} - -{- $example2 - -A different approach is to group the option values in a record of type -@Options@, and have each flag yield a function of type -@Options -> Options@ transforming this record. - -> module Opts2 where -> -> import System.Console.GetOpt -> import Data.Maybe ( fromMaybe ) -> -> data Options = Options -> { optVerbose :: Bool -> , optShowVersion :: Bool -> , optOutput :: Maybe FilePath -> , optInput :: Maybe FilePath -> , optLibDirs :: [FilePath] -> } deriving Show -> -> defaultOptions = Options -> { optVerbose = False -> , optShowVersion = False -> , optOutput = Nothing -> , optInput = Nothing -> , optLibDirs = [] -> } -> -> options :: [OptDescr (Options -> Options)] -> options = -> [ Option ['v'] ["verbose"] -> (NoArg (\ opts -> opts { optVerbose = True })) -> "chatty output on stderr" -> , Option ['V','?'] ["version"] -> (NoArg (\ opts -> opts { optShowVersion = True })) -> "show version number" -> , Option ['o'] ["output"] -> (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output") -> "FILE") -> "output FILE" -> , Option ['c'] [] -> (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input") -> "FILE") -> "input FILE" -> , Option ['L'] ["libdir"] -> (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR") -> "library directory" -> ] -> -> compilerOpts :: [String] -> IO (Options, [String]) -> compilerOpts argv = -> case getOpt Permute options argv of -> (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) -> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) -> where header = "Usage: ic [OPTION...] files..." - -Similarly, each flag could yield a monadic function transforming a record, -of type @Options -> IO Options@ (or any other monad), allowing option -processing to perform actions of the chosen monad, e.g. printing help or -version messages, checking that file arguments exist, etc. - --} diff --git a/src-3.0/GF/Infra/Ident.hs b/src-3.0/GF/Infra/Ident.hs deleted file mode 100644 index 45ebf3a5b..000000000 --- a/src-3.0/GF/Infra/Ident.hs +++ /dev/null @@ -1,152 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Ident --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/15 11:43:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.8 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Infra.Ident (-- * Identifiers - Ident(..), ident2bs, prIdent, - identC, identV, identA, identAV, identW, - argIdent, varStr, varX, isWildIdent, varIndex, - -- * refreshing identifiers - IdState, initIdStateN, initIdState, - lookVar, refVar, refVarPlus - ) where - -import GF.Data.Operations -import qualified Data.ByteString.Char8 as BS --- import Monad - - --- | the constructors labelled /INTERNAL/ are --- internal representation never returned by the parser -data Ident = - IC {-# UNPACK #-} !BS.ByteString -- ^ raw identifier after parsing, resolved in Rename - | IW -- ^ wildcard --- --- below this constructor: internal representation never returned by the parser - | IV {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int -- ^ /INTERNAL/ variable - | IA {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat at position - | IAV {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat with bindings at position --- - - deriving (Eq, Ord, Show, Read) - -ident2bs :: Ident -> BS.ByteString -ident2bs i = case i of - IC s -> s - IV s n -> BS.append s (BS.pack ('_':show n)) - IA s j -> BS.append s (BS.pack ('_':show j)) - IAV s b j -> BS.append s (BS.pack ('_':show b ++ '_':show j)) - IW -> BS.pack "_" - -prIdent :: Ident -> String -prIdent i = BS.unpack $! ident2bs i - -identC :: BS.ByteString -> Ident -identV :: BS.ByteString -> Int -> Ident -identA :: BS.ByteString -> Int -> Ident -identAV:: BS.ByteString -> Int -> Int -> Ident -identW :: Ident -(identC, identV, identA, identAV, identW) = - (IC, IV, IA, IAV, IW) - --- normal identifier --- ident s = IC s - --- | to mark argument variables -argIdent :: Int -> Ident -> Int -> Ident -argIdent 0 (IC c) i = identA c i -argIdent b (IC c) i = identAV c b i - --- | used in lin defaults -varStr :: Ident -varStr = identA (BS.pack "str") 0 - --- | refreshing variables -varX :: Int -> Ident -varX = identV (BS.pack "x") - -isWildIdent :: Ident -> Bool -isWildIdent x = case x of - IW -> True - IC s | s == BS.pack "_" -> True - _ -> False - -varIndex :: Ident -> Int -varIndex (IV _ n) = n -varIndex _ = -1 --- other than IV should not count - --- refreshing identifiers - -type IdState = ([(Ident,Ident)],Int) - -initIdStateN :: Int -> IdState -initIdStateN i = ([],i) - -initIdState :: IdState -initIdState = initIdStateN 0 - -lookVar :: Ident -> STM IdState Ident -lookVar a@(IA _ _) = return a -lookVar x = do - (sys,_) <- readSTM - stm (\s -> maybe (Bad ("cannot find" +++ show x +++ prParenth (show sys))) - return $ - lookup x sys >>= (\y -> return (y,s))) - -refVar :: Ident -> STM IdState Ident -----refVar IW = return IW --- no update of wildcard -refVar x = do - (_,m) <- readSTM - let x' = IV (ident2bs x) m - updateSTM (\(sys,mx) -> ((x, x'):sys, mx + 1)) - return x' - -refVarPlus :: Ident -> STM IdState Ident -----refVarPlus IW = refVar (identC "h") -refVarPlus x = refVar x - - -{- ------------------------------- --- to test - -refreshExp :: Exp -> Err Exp -refreshExp e = err Bad (return . fst) (appSTM (refresh e) initState) - -refresh :: Exp -> STM State Exp -refresh e = case e of - Atom x -> lookVar x >>= return . Atom - App f a -> liftM2 App (refresh f) (refresh a) - Abs x b -> liftM2 Abs (refVar x) (refresh b) - Fun xs a b -> do - a' <- refresh a - xs' <- mapM refVar xs - b' <- refresh b - return $ Fun xs' a' b' - -data Exp = - Atom Ident - | App Exp Exp - | Abs Ident Exp - | Fun [Ident] Exp Exp - deriving Show - -exp1 = Abs (IC "y") (Atom (IC "y")) -exp2 = Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y"))) -exp3 = Abs (IC "y") (Abs (IC "z") (App (Atom (IC "y")) (Atom (IC "z")))) -exp4 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "z")))) -exp5 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y")))) -exp6 = Abs (IC "y") (Fun [IC "x", IC "y"] (Atom (IC "y")) (Atom (IC "y"))) -exp7 = Abs (IL "8") (Atom (IC "y")) - --} diff --git a/src-3.0/GF/Infra/Modules.hs b/src-3.0/GF/Infra/Modules.hs deleted file mode 100644 index 797f729c8..000000000 --- a/src-3.0/GF/Infra/Modules.hs +++ /dev/null @@ -1,429 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Modules --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/09 15:14:30 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.26 $ --- --- Datastructures and functions for modules, common to GF and GFC. --- --- AR 29\/4\/2003 --- --- The same structure will be used in both source code and canonical. --- The parameters tell what kind of data is involved. --- Invariant: modules are stored in dependency order ------------------------------------------------------------------------------ - -module GF.Infra.Modules ( - MGrammar(..), ModInfo(..), Module(..), ModuleType(..), - MReuseType(..), MInclude (..), - extends, isInherited,inheritAll, - updateMGrammar, updateModule, replaceJudgements, addFlag, - addOpenQualif, flagsModule, allFlags, mapModules, - MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..), - oSimple, oQualif, - ModuleStatus(..), - openedModule, allOpens, depPathModule, allDepsModule, partOfGrammar, - allExtends, allExtendSpecs, allExtendsPlus, allExtensions, - searchPathModule, addModule, - emptyMGrammar, emptyModInfo, emptyModule, - IdentM(..), - typeOfModule, abstractOfConcrete, abstractModOfConcrete, - lookupModule, lookupModuleType, lookupModMod, lookupInfo, - lookupPosition, showPosition, - allModMod, isModAbs, isModRes, isModCnc, isModTrans, - sameMType, isCompilableModule, isCompleteModule, - allAbstracts, greatestAbstract, allResources, - greatestResource, allConcretes, allConcreteModules - ) where - -import GF.Infra.Ident -import GF.Infra.Option -import GF.Data.Operations - -import Data.List - - --- AR 29/4/2003 - --- The same structure will be used in both source code and canonical. --- The parameters tell what kind of data is involved. --- Invariant: modules are stored in dependency order - -data MGrammar i a = MGrammar {modules :: [(i,ModInfo i a)]} - deriving Show - -data ModInfo i a = - ModMainGrammar (MainGrammar i) - | ModMod (Module i a) - | ModWith (Module i a) (i,MInclude i) [OpenSpec i] - deriving Show - -data Module i a = Module { - mtype :: ModuleType i , - mstatus :: ModuleStatus , - flags :: ModuleOptions, - extend :: [(i,MInclude i)], - opens :: [OpenSpec i] , - jments :: BinTree i a , - positions :: BinTree i (String,(Int,Int)) -- file, first line, last line - } ---- deriving Show -instance Show (Module i a) where - show _ = "cannot show Module with FiniteMap" - --- | encoding the type of the module -data ModuleType i = - MTAbstract - | MTTransfer (OpenSpec i) (OpenSpec i) - | MTResource - | MTConcrete i - -- ^ up to this, also used in GFC. Below, source only. - | MTInterface - | MTInstance i - | MTReuse (MReuseType i) - | MTUnion (ModuleType i) [(i,[i])] -- ^ not meant to be recursive - deriving (Eq,Show) - -data MReuseType i = MRInterface i | MRInstance i i | MRResource i - deriving (Show,Eq) - -data MInclude i = MIAll | MIOnly [i] | MIExcept [i] - deriving (Show,Eq) - -extends :: Module i a -> [i] -extends = map fst . extend - -isInherited :: Eq i => MInclude i -> i -> Bool -isInherited c i = case c of - MIAll -> True - MIOnly is -> elem i is - MIExcept is -> notElem i is - -inheritAll :: i -> (i,MInclude i) -inheritAll i = (i,MIAll) - --- destructive update - --- | dep order preserved since old cannot depend on new -updateMGrammar :: Ord i => MGrammar i a -> MGrammar i a -> MGrammar i a -updateMGrammar old new = MGrammar $ - [(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns - where - os = modules old - ns = modules new - -updateModule :: Ord i => Module i t -> i -> t -> Module i t -updateModule (Module mt ms fs me ops js ps) i t = - Module mt ms fs me ops (updateTree (i,t) js) ps - -replaceJudgements :: Module i t -> BinTree i t -> Module i t -replaceJudgements (Module mt ms fs me ops _ ps) js = Module mt ms fs me ops js ps - -addOpenQualif :: i -> i -> Module i t -> Module i t -addOpenQualif i j (Module mt ms fs me ops js ps) = - Module mt ms fs me (oQualif i j : ops) js ps - -addFlag :: ModuleOptions -> Module i t -> Module i t -addFlag f mo = mo {flags = addModuleOptions (flags mo) f} - -flagsModule :: (i,ModInfo i a) -> ModuleOptions -flagsModule (_,mi) = case mi of - ModMod m -> flags m - _ -> noModuleOptions - -allFlags :: MGrammar i a -> ModuleOptions -allFlags gr = concatModuleOptions $ map flags $ [m | (_, ModMod m) <- modules gr] - -mapModules :: (Module i a -> Module i a) - -> MGrammar i a -> MGrammar i a -mapModules f = MGrammar . map (onSnd mapModules') . modules - where mapModules' (ModMod m) = ModMod (f m) - mapModules' m = m - -data MainGrammar i = MainGrammar { - mainAbstract :: i , - mainConcretes :: [MainConcreteSpec i] - } - deriving Show - -data MainConcreteSpec i = MainConcreteSpec { - concretePrintname :: i , - concreteName :: i , - transferIn :: Maybe (OpenSpec i) , -- ^ if there is an in-transfer - transferOut :: Maybe (OpenSpec i) -- ^ if there is an out-transfer - } - deriving Show - -data OpenSpec i = - OSimple OpenQualif i - | OQualif OpenQualif i i - deriving (Eq,Show) - -data OpenQualif = - OQNormal - | OQInterface - | OQIncomplete - deriving (Eq,Show) - -oSimple :: i -> OpenSpec i -oSimple = OSimple OQNormal - -oQualif :: i -> i -> OpenSpec i -oQualif = OQualif OQNormal - -data ModuleStatus = - MSComplete - | MSIncomplete - deriving (Eq,Show) - -openedModule :: OpenSpec i -> i -openedModule o = case o of - OSimple _ m -> m - OQualif _ _ m -> m - -allOpens :: Module i a -> [OpenSpec i] -allOpens m = case mtype m of - MTTransfer a b -> a : b : opens m - _ -> opens m - --- | initial dependency list -depPathModule :: Ord i => Module i a -> [OpenSpec i] -depPathModule m = fors m ++ exts m ++ opens m where - fors m = case mtype m of - MTTransfer i j -> [i,j] - MTConcrete i -> [oSimple i] - MTInstance i -> [oSimple i] - _ -> [] - exts m = map oSimple $ extends m - --- | all dependencies -allDepsModule :: Ord i => MGrammar i a -> Module i a -> [OpenSpec i] -allDepsModule gr m = iterFix add os0 where - os0 = depPathModule m - add os = [m | o <- os, Just (ModMod n) <- [lookup (openedModule o) mods], - m <- depPathModule n] - mods = modules gr - --- | select just those modules that a given one depends on, including itself -partOfGrammar :: Ord i => MGrammar i a -> (i,ModInfo i a) -> MGrammar i a -partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor] - where - mods = modules gr - modsFor = case m of - ModMod n -> (i:) $ map openedModule $ allDepsModule gr n - ---- ModWith n i os -> i : map openedModule os ++ partOfGrammar (ModMod n) ---- - _ -> [i] - --- | all modules that a module extends, directly or indirectly, without restricts -allExtends :: (Show i,Ord i) => MGrammar i a -> i -> [i] -allExtends gr i = case lookupModule gr i of - Ok (ModMod m) -> case extends m of - [] -> [i] - is -> i : concatMap (allExtends gr) is - _ -> [] - --- | all modules that a module extends, directly or indirectly, with restricts -allExtendSpecs :: (Show i,Ord i) => MGrammar i a -> i -> [(i,MInclude i)] -allExtendSpecs gr i = case lookupModule gr i of - Ok (ModMod m) -> case extend m of - [] -> [(i,MIAll)] - is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is - _ -> [] - --- | this plus that an instance extends its interface -allExtendsPlus :: (Show i,Ord i) => MGrammar i a -> i -> [i] -allExtendsPlus gr i = case lookupModule gr i of - Ok (ModMod m) -> i : concatMap (allExtendsPlus gr) (exts m) - _ -> [] - where - exts m = extends m ++ [j | MTInstance j <- [mtype m]] - --- | conversely: all modules that extend a given module, incl. instances of interface -allExtensions :: (Show i,Ord i) => MGrammar i a -> i -> [i] -allExtensions gr i = case lookupModule gr i of - Ok (ModMod m) -> let es = exts i in es ++ concatMap (allExtensions gr) es - _ -> [] - where - exts i = [j | (j,m) <- mods, elem i (extends m) - || elem (MTInstance i) [mtype m]] - mods = [(j,m) | (j,ModMod m) <- modules gr] - --- | initial search path: the nonqualified dependencies -searchPathModule :: Ord i => Module i a -> [i] -searchPathModule m = [i | OSimple _ i <- depPathModule m] - --- | a new module can safely be added to the end, since nothing old can depend on it -addModule :: Ord i => - MGrammar i a -> i -> ModInfo i a -> MGrammar i a -addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)]) - -emptyMGrammar :: MGrammar i a -emptyMGrammar = MGrammar [] - -emptyModInfo :: ModInfo i a -emptyModInfo = ModMod emptyModule - -emptyModule :: Module i a -emptyModule = Module - MTResource MSComplete noModuleOptions [] [] emptyBinTree emptyBinTree - --- | we store the module type with the identifier -data IdentM i = IdentM { - identM :: i , - typeM :: ModuleType i - } - deriving (Eq,Show) - -typeOfModule :: ModInfo i a -> ModuleType i -typeOfModule mi = case mi of - ModMod m -> mtype m - -abstractOfConcrete :: (Show i, Eq i) => MGrammar i a -> i -> Err i -abstractOfConcrete gr c = do - m <- lookupModule gr c - case m of - ModMod n -> case mtype n of - MTConcrete a -> return a - _ -> Bad $ "expected concrete" +++ show c - _ -> Bad $ "expected concrete" +++ show c - -abstractModOfConcrete :: (Show i, Eq i) => - MGrammar i a -> i -> Err (Module i a) -abstractModOfConcrete gr c = do - a <- abstractOfConcrete gr c - m <- lookupModule gr a - case m of - ModMod n -> return n - _ -> Bad $ "expected abstract" +++ show c - - --- the canonical file name - ---- canonFileName s = prt s ++ ".gfc" - -lookupModule :: (Show i,Eq i) => MGrammar i a -> i -> Err (ModInfo i a) -lookupModule gr m = case lookup m (modules gr) of - Just i -> return i - _ -> Bad $ "unknown module" +++ show m - +++ "among" +++ unwords (map (show . fst) (modules gr)) ---- debug - -lookupModuleType :: (Show i,Eq i) => MGrammar i a -> i -> Err (ModuleType i) -lookupModuleType gr m = do - mi <- lookupModule gr m - return $ typeOfModule mi - -lookupModMod :: (Show i,Eq i) => MGrammar i a -> i -> Err (Module i a) -lookupModMod gr i = do - mo <- lookupModule gr i - case mo of - ModMod m -> return m - _ -> Bad $ "expected proper module, not" +++ show i - -lookupInfo :: (Show i, Ord i) => Module i a -> i -> Err a -lookupInfo mo i = lookupTree show i (jments mo) - -lookupPosition :: (Show i, Ord i) => Module i a -> i -> Err (String,(Int,Int)) -lookupPosition mo i = lookupTree show i (positions mo) - -showPosition :: (Show i, Ord i) => Module i a -> i -> String -showPosition mo i = case lookupPosition mo i of - Ok (f,(b,e)) | b == e -> "in" +++ f ++ ", line" +++ show b - Ok (f,(b,e)) -> "in" +++ f ++ ", lines" +++ show b ++ "-" ++ show e - _ -> "" - - -allModMod :: (Show i,Eq i) => MGrammar i a -> [(i,Module i a)] -allModMod gr = [(i,m) | (i, ModMod m) <- modules gr] - -isModAbs :: Module i a -> Bool -isModAbs m = case mtype m of - MTAbstract -> True ----- MTUnion t -> isModAbs t - _ -> False - -isModRes :: Module i a -> Bool -isModRes m = case mtype m of - MTResource -> True - MTReuse _ -> True ----- MTUnion t -> isModRes t --- maybe not needed, since eliminated early - MTInterface -> True --- - MTInstance _ -> True - _ -> False - -isModCnc :: Module i a -> Bool -isModCnc m = case mtype m of - MTConcrete _ -> True ----- MTUnion t -> isModCnc t - _ -> False - -isModTrans :: Module i a -> Bool -isModTrans m = case mtype m of - MTTransfer _ _ -> True ----- MTUnion t -> isModTrans t - _ -> False - -sameMType :: Eq i => ModuleType i -> ModuleType i -> Bool -sameMType m n = case (n,m) of - (MTConcrete _, MTConcrete _) -> True - - (MTInstance _, MTInstance _) -> True - (MTInstance _, MTResource) -> True - (MTInstance _, MTConcrete _) -> True - - (MTInterface, MTInstance _) -> True - (MTInterface, MTResource) -> True -- for reuse - (MTInterface, MTAbstract) -> True -- for reuse - - (MTResource, MTInstance _) -> True - (MTResource, MTConcrete _) -> True -- for reuse - - _ -> m == n - --- | don't generate code for interfaces and for incomplete modules -isCompilableModule :: ModInfo i a -> Bool -isCompilableModule m = case m of - ModMod m -> case mtype m of - MTInterface -> False - _ -> mstatus m == MSComplete - _ -> False --- - --- | interface and "incomplete M" are not complete -isCompleteModule :: (Eq i) => Module i a -> Bool -isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface - - --- | all abstract modules sorted from least to most dependent -allAbstracts :: Eq i => MGrammar i a -> [i] -allAbstracts gr = topoSort - [(i,extends m) | (i,ModMod m) <- modules gr, mtype m == MTAbstract] - --- | the last abstract in dependency order (head of list) -greatestAbstract :: Eq i => MGrammar i a -> Maybe i -greatestAbstract gr = case allAbstracts gr of - [] -> Nothing - as -> return $ last as - --- | all resource modules -allResources :: MGrammar i a -> [i] -allResources gr = [i | (i,ModMod m) <- modules gr, isModRes m || isModCnc m] - --- | the greatest resource in dependency order -greatestResource :: MGrammar i a -> Maybe i -greatestResource gr = case allResources gr of - [] -> Nothing - a -> return $ head a ---- why not last as in Abstract? works though AR 24/5/2008 - --- | all concretes for a given abstract -allConcretes :: Eq i => MGrammar i a -> i -> [i] -allConcretes gr a = - [i | (i, ModMod m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m] - --- | all concrete modules for any abstract -allConcreteModules :: Eq i => MGrammar i a -> [i] -allConcreteModules gr = - [i | (i, ModMod m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m] diff --git a/src-3.0/GF/Infra/Option.hs b/src-3.0/GF/Infra/Option.hs deleted file mode 100644 index 380cb3af7..000000000 --- a/src-3.0/GF/Infra/Option.hs +++ /dev/null @@ -1,549 +0,0 @@ -module GF.Infra.Option - ( - -- * Option types - Options, ModuleOptions, - Flags(..), ModuleFlags(..), - Mode(..), Phase(..), Verbosity(..), Encoding(..), OutputFormat(..), - SISRFormat(..), Optimization(..), - Dump(..), Printer(..), Recomp(..), - -- * Option parsing - parseOptions, parseModuleOptions, - -- * Option pretty-printing - moduleOptionsGFO, - -- * Option manipulation - addOptions, concatOptions, noOptions, - moduleOptions, - addModuleOptions, concatModuleOptions, noModuleOptions, - helpMessage, - -- * Checking specific options - flag, moduleFlag, - -- * Setting specific options - setOptimization, - -- * Convenience methods for checking options - verbAtLeast, dump - ) where - -import Control.Monad -import Data.Char (toLower) -import Data.List -import Data.Maybe -import GF.Infra.GetOpt ---import System.Console.GetOpt -import System.FilePath - -import GF.Data.ErrM - -import Data.Set (Set) -import qualified Data.Set as Set - - - - -usageHeader :: String -usageHeader = unlines - ["Usage: gfc [OPTIONS] [FILE [...]]", - "", - "How each FILE is handled depends on the file name suffix:", - "", - ".gf Normal or old GF source, will be compiled.", - ".gfo Compiled GF source, will be loaded as is.", - ".gfe Example-based GF source, will be converted to .gf and compiled.", - ".ebnf Extended BNF format, will be converted to .gf and compiled.", - ".cf Context-free (BNF) format, will be converted to .gf and compiled.", - "", - "If multiple FILES are given, they must be normal GF source, .gfo or .gfe files.", - "For the other input formats, only one file can be given.", - "", - "Command-line options:"] - - -helpMessage :: String -helpMessage = usageInfo usageHeader optDescr - - --- FIXME: do we really want multi-line errors? -errors :: [String] -> Err a -errors = fail . unlines - --- Types - -data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeCompiler - deriving (Show,Eq,Ord) - -data Verbosity = Quiet | Normal | Verbose | Debug - deriving (Show,Eq,Ord,Enum,Bounded) - -data Phase = Preproc | Convert | Compile | Link - deriving (Show,Eq,Ord) - -data Encoding = UTF_8 | ISO_8859_1 | CP_1251 - deriving (Show,Eq,Ord) - -data OutputFormat = FmtPGF - | FmtJavaScript - | FmtHaskell - | FmtHaskell_GADT - | FmtBNF - | FmtSRGS_XML - | FmtSRGS_ABNF - | FmtJSGF - | FmtGSL - | FmtVoiceXML - | FmtSLF - | FmtRegExp - | FmtFA - deriving (Eq,Ord) - -data SISRFormat = - -- | SISR Working draft 1 April 2003 - -- <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/> - SISR_WD20030401 - | SISR_1_0 - deriving (Show,Eq,Ord) - -data Optimization = OptStem | OptCSE | OptExpand | OptParametrize | OptValues - deriving (Show,Eq,Ord) - -data Warning = WarnMissingLincat - deriving (Show,Eq,Ord) - -data Dump = DumpRebuild | DumpExtend | DumpRename | DumpTypeCheck | DumpRefresh | DumpOptimize | DumpCanon - deriving (Show,Eq,Ord) - --- | Pretty-printing options -data Printer = PrinterStrip -- ^ Remove name qualifiers. - deriving (Show,Eq,Ord) - -data Recomp = AlwaysRecomp | RecompIfNewer | NeverRecomp - deriving (Show,Eq,Ord) - -data ModuleFlags = ModuleFlags { - optName :: Maybe String, - optAbsName :: Maybe String, - optCncName :: Maybe String, - optResName :: Maybe String, - optPreprocessors :: [String], - optEncoding :: Encoding, - optOptimizations :: Set Optimization, - optLibraryPath :: [FilePath], - optStartCat :: Maybe String, - optSpeechLanguage :: Maybe String, - optLexer :: Maybe String, - optUnlexer :: Maybe String, - optErasing :: Bool, - optBuildParser :: Bool, - optWarnings :: [Warning], - optDump :: [Dump] - } - deriving (Show) - -data Flags = Flags { - optMode :: Mode, - optStopAfterPhase :: Phase, - optVerbosity :: Verbosity, - optShowCPUTime :: Bool, - optEmitGFO :: Bool, - optGFODir :: FilePath, - optOutputFormats :: [OutputFormat], - optSISR :: Maybe SISRFormat, - optOutputFile :: Maybe FilePath, - optOutputDir :: Maybe FilePath, - optRecomp :: Recomp, - optPrinter :: [Printer], - optProb :: Bool, - optRetainResource :: Bool, - optModuleFlags :: ModuleFlags - } - deriving (Show) - -newtype Options = Options (Flags -> Flags) - -instance Show Options where - show (Options o) = show (o defaultFlags) - -newtype ModuleOptions = ModuleOptions (ModuleFlags -> ModuleFlags) - --- Option parsing - -parseOptions :: [String] -> Err (Options, [FilePath]) -parseOptions args - | not (null errs) = errors errs - | otherwise = do opts <- liftM concatOptions $ sequence optss - return (opts, files) - where (optss, files, errs) = getOpt RequireOrder optDescr args - -parseModuleOptions :: [String] -> Err ModuleOptions -parseModuleOptions args - | not (null errs) = errors errs - | not (null files) = errors $ map ("Non-option among module options: " ++) files - | otherwise = liftM concatModuleOptions $ sequence flags - where (flags, files, errs) = getOpt RequireOrder moduleOptDescr args - --- Showing options - --- | Pretty-print the module options that are preserved in .gfo files. -moduleOptionsGFO :: ModuleOptions -> [(String,String)] -moduleOptionsGFO (ModuleOptions o) = - maybe [] (\x -> [("language",x)]) (optSpeechLanguage mfs) - ++ maybe [] (\x -> [("startcat",x)]) (optStartCat mfs) --- ++ maybe [] (\x -> [("coding", e2s x)]) (Just (optEncoding mfs)) - ++ (if optErasing mfs then [("erasing","on")] else []) - where - mfs = o defaultModuleFlags - e2s e = maybe [] id $ lookup e [(s,e) | (e,s) <- encodings] - --- Option manipulation - -noOptions :: Options -noOptions = Options id - -addOptions :: Options -- ^ Existing options. - -> Options -- ^ Options to add (these take preference). - -> Options -addOptions (Options o1) (Options o2) = Options (o2 . o1) - -concatOptions :: [Options] -> Options -concatOptions = foldr addOptions noOptions - -moduleOptions :: ModuleOptions -> Options -moduleOptions (ModuleOptions f) = Options (\o -> o { optModuleFlags = f (optModuleFlags o) }) - -addModuleOptions :: ModuleOptions -- ^ Existing options. - -> ModuleOptions -- ^ Options to add (these take preference). - -> ModuleOptions -addModuleOptions (ModuleOptions o1) (ModuleOptions o2) = ModuleOptions (o2 . o1) - -concatModuleOptions :: [ModuleOptions] -> ModuleOptions -concatModuleOptions = foldr addModuleOptions noModuleOptions - -noModuleOptions :: ModuleOptions -noModuleOptions = ModuleOptions id - -flag :: (Flags -> a) -> Options -> a -flag f (Options o) = f (o defaultFlags) - -moduleFlag :: (ModuleFlags -> a) -> Options -> a -moduleFlag f = flag (f . optModuleFlags) - -modifyFlags :: (Flags -> Flags) -> Options -modifyFlags = Options - -modifyModuleFlags :: (ModuleFlags -> ModuleFlags) -> Options -modifyModuleFlags = moduleOptions . ModuleOptions - - -{- - -parseModuleFlags :: Options -> [(String,Maybe String)] -> Err ModuleOptions -parseModuleFlags opts flags = - mapM (uncurry (findFlag moduleOptDescr)) flags >>= foldM (flip ($)) (optModuleOptions opts) - -findFlag :: Monad m => [OptDescr a] -> String -> Maybe String -> m a -findFlag opts n mv = - case filter (`flagMatches` n) opts of - [] -> fail $ "Unknown option: " ++ n - [opt] -> flagValue opt n mv - _ -> fail $ n ++ " matches multiple options." - -flagMatches :: OptDescr a -> String -> Bool -flagMatches (Option cs ss _ _) n = n `elem` (map (:[]) cs ++ ss) - -flagValue :: Monad m => OptDescr a -> String -> Maybe String -> m a -flagValue (Option _ _ arg _) n mv = - case (arg, mv) of - (NoArg x, Nothing) -> return x - (NoArg _, Just _ ) -> fail $ "Option " ++ n ++ " does not take a value." - (ReqArg _ _, Nothing) -> fail $ "Option " ++ n ++ " requires a value." - (ReqArg f _, Just x ) -> return (f x) - (OptArg f _, mx ) -> return (f mx) - --} - --- Default options - -defaultModuleFlags :: ModuleFlags -defaultModuleFlags = ModuleFlags { - optName = Nothing, - optAbsName = Nothing, - optCncName = Nothing, - optResName = Nothing, - optPreprocessors = [], - optEncoding = ISO_8859_1, - optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues], - optLibraryPath = [], - optStartCat = Nothing, - optSpeechLanguage = Nothing, - optLexer = Nothing, - optUnlexer = Nothing, - optErasing = False, - optBuildParser = True, - optWarnings = [], - optDump = [] - } - -defaultFlags :: Flags -defaultFlags = Flags { - optMode = ModeInteractive, - optStopAfterPhase = Compile, - optVerbosity = Normal, - optShowCPUTime = False, - optEmitGFO = True, - optGFODir = ".", - optOutputFormats = [FmtPGF], - optSISR = Nothing, - optOutputFile = Nothing, - optOutputDir = Nothing, - optRecomp = RecompIfNewer, - optPrinter = [], - optProb = False, - optRetainResource = False, - optModuleFlags = defaultModuleFlags - } - --- Option descriptions - -moduleOptDescr :: [OptDescr (Err ModuleOptions)] -moduleOptDescr = - [ - Option ['n'] ["name"] (ReqArg name "NAME") - (unlines ["Use NAME as the name of the output. This is used in the output file names, ", - "with suffixes depending on the formats, and, when relevant, ", - "internally in the output."]), - Option [] ["abs"] (ReqArg absName "NAME") - ("Use NAME as the name of the abstract syntax module generated from " - ++ "a grammar in GF 1 format."), - Option [] ["cnc"] (ReqArg cncName "NAME") - ("Use NAME as the name of the concrete syntax module generated from " - ++ "a grammar in GF 1 format."), - Option [] ["res"] (ReqArg resName "NAME") - ("Use NAME as the name of the resource module generated from " - ++ "a grammar in GF 1 format."), - Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.", - Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.", - Option [] ["preproc"] (ReqArg preproc "CMD") - (unlines ["Use CMD to preprocess input files.", - "Multiple preprocessors can be used by giving this option multiple times."]), - Option [] ["coding"] (ReqArg coding "ENCODING") - ("Character encoding of the source grammar, ENCODING = " - ++ concat (intersperse " | " (map fst encodings)) ++ "."), - Option [] ["erasing"] (onOff erasing False) "Generate erasing grammar (default off).", - Option [] ["parser"] (onOff parser True) "Build parser (default on).", - Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.", - Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.", - Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.", - Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.", - Option [] ["optimize"] (ReqArg optimize "OPT") - "Select an optimization package. OPT = all | values | parametrize | none", - Option [] ["stem"] (onOff (toggleOptimize OptStem) True) "Perform stem-suffix analysis (default on).", - Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).", - dumpOption "rebuild" DumpRebuild, - dumpOption "extend" DumpExtend, - dumpOption "rename" DumpRename, - dumpOption "tc" DumpTypeCheck, - dumpOption "refresh" DumpRefresh, - dumpOption "opt" DumpOptimize, - dumpOption "canon" DumpCanon - ] - where - name x = set $ \o -> o { optName = Just x } - absName x = set $ \o -> o { optAbsName = Just x } - cncName x = set $ \o -> o { optCncName = Just x } - resName x = set $ \o -> o { optResName = Just x } - addLibDir x = set $ \o -> o { optLibraryPath = x:optLibraryPath o } - setLibPath x = set $ \o -> o { optLibraryPath = splitInModuleSearchPath x } - preproc x = set $ \o -> o { optPreprocessors = optPreprocessors o ++ [x] } - coding x = case lookup x encodings of - Just c -> set $ \o -> o { optEncoding = c } - Nothing -> fail $ "Unknown character encoding: " ++ x - erasing x = set $ \o -> o { optErasing = x } - parser x = set $ \o -> o { optBuildParser = x } - startcat x = set $ \o -> o { optStartCat = Just x } - language x = set $ \o -> o { optSpeechLanguage = Just x } - lexer x = set $ \o -> o { optLexer = Just x } - unlexer x = set $ \o -> o { optUnlexer = Just x } - - optimize x = case lookup x optimizationPackages of - Just p -> set $ \o -> o { optOptimizations = p } - Nothing -> fail $ "Unknown optimization package: " ++ x - - toggleOptimize x b = set $ setOptimization' x b - - dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.") - - set = return . ModuleOptions - -optDescr :: [OptDescr (Err Options)] -optDescr = - [ - Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.", - Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.", - Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 2.", - Option ['q','s'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.", - Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.", - Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).", - Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).", - Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.", - Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .", - Option [] ["make"] (NoArg (phase Link)) "Build .pgf file and other output files.", - Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.", - Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).", - Option [] ["emit-gfo"] (NoArg (emitGFO True)) "Create .gfo files (default).", - Option [] ["no-emit-gfo"] (NoArg (emitGFO False)) "Do not create .gfo files.", - Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').", - Option ['f'] ["output-format"] (ReqArg outFmt "FMT") - (unlines ["Output format. FMT can be one of:", - "Multiple concrete: pgf (default), gar, js, ...", - "Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...", - "Abstract only: haskell, ..."]), - Option [] ["sisr"] (ReqArg sisrFmt "FMT") - (unlines ["Include SISR tags in generated speech recognition grammars.", - "FMT can be one of: old, 1.0"]), - Option ['o'] ["output-file"] (ReqArg outFile "FILE") - "Save output in FILE (default is out.X, where X depends on output format.", - Option ['D'] ["output-dir"] (ReqArg outDir "DIR") - "Save output files (other than .gfc files) in DIR.", - Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) - "Always recompile from source.", - Option [] ["gfo","recomp-if-newer"] (NoArg (recomp RecompIfNewer)) - "(default) Recompile from source if the source is newer than the .gfo file.", - Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) - "Never recompile from source, if there is already .gfo file.", - Option [] ["strip"] (NoArg (printer PrinterStrip)) - "Remove name qualifiers when pretty-printing.", - Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.", - Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas." - ] ++ map (fmap (liftM moduleOptions)) moduleOptDescr - where phase x = set $ \o -> o { optStopAfterPhase = x } - mode x = set $ \o -> o { optMode = x } - verbosity mv = case mv of - Nothing -> set $ \o -> o { optVerbosity = Verbose } - Just v -> case readMaybe v >>= toEnumBounded of - Just i -> set $ \o -> o { optVerbosity = i } - Nothing -> fail $ "Bad verbosity: " ++ show v - cpu x = set $ \o -> o { optShowCPUTime = x } - emitGFO x = set $ \o -> o { optEmitGFO = x } - gfoDir x = set $ \o -> o { optGFODir = x } - outFmt x = readOutputFormat x >>= \f -> - set $ \o -> o { optOutputFormats = optOutputFormats o ++ [f] } - sisrFmt x = case x of - "old" -> set $ \o -> o { optSISR = Just SISR_WD20030401 } - "1.0" -> set $ \o -> o { optSISR = Just SISR_1_0 } - _ -> fail $ "Unknown SISR format: " ++ show x - outFile x = set $ \o -> o { optOutputFile = Just x } - outDir x = set $ \o -> o { optOutputDir = Just x } - recomp x = set $ \o -> o { optRecomp = x } - printer x = set $ \o -> o { optPrinter = x : optPrinter o } - prob x = set $ \o -> o { optProb = x } - - set = return . Options - -outputFormats :: [(String,OutputFormat)] -outputFormats = - [("pgf", FmtPGF), - ("js", FmtJavaScript), - ("haskell", FmtHaskell), - ("haskell_gadt", FmtHaskell_GADT), - ("bnf", FmtBNF), - ("srgs_xml", FmtSRGS_XML), - ("srgs_abnf", FmtSRGS_ABNF), - ("jsgf", FmtJSGF), - ("gsl", FmtGSL), - ("vxml", FmtVoiceXML), - ("slf", FmtSLF), - ("regexp", FmtRegExp), - ("fa", FmtFA)] - -instance Show OutputFormat where - show = lookupShow outputFormats - -instance Read OutputFormat where - readsPrec = lookupReadsPrec outputFormats - -optimizationPackages :: [(String, Set Optimization)] -optimizationPackages = - [("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]), -- deprecated - ("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]), - ("values", Set.fromList [OptStem,OptCSE,OptExpand,OptValues]), - ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), - ("none", Set.fromList [OptStem,OptCSE,OptExpand]), - ("noexpand", Set.fromList [OptStem,OptCSE])] - -encodings :: [(String,Encoding)] -encodings = - [("utf8", UTF_8), - ("cp1251", CP_1251), - ("latin1", ISO_8859_1) - ] - -lookupShow :: Eq a => [(String,a)] -> a -> String -lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs] - -lookupReadsPrec :: [(String,a)] -> Int -> ReadS a -lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x] - -onOff :: Monad m => (Bool -> m a) -> Bool -> ArgDescr (m a) -onOff f def = OptArg g "[on,off]" - where g ma = maybe (return def) readOnOff ma >>= f - readOnOff x = case map toLower x of - "on" -> return True - "off" -> return False - _ -> fail $ "Expected [on,off], got: " ++ show x - -readOutputFormat :: Monad m => String -> m OutputFormat -readOutputFormat s = - maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats - --- FIXME: this is a copy of the function in GF.Devel.UseIO. -splitInModuleSearchPath :: String -> [FilePath] -splitInModuleSearchPath s = case break isPathSep s of - (f,_:cs) -> f : splitInModuleSearchPath cs - (f,_) -> [f] - where - isPathSep :: Char -> Bool - isPathSep c = c == ':' || c == ';' - --- --- * Convenience functions for checking options --- - -verbAtLeast :: Options -> Verbosity -> Bool -verbAtLeast opts v = flag optVerbosity opts >= v - -dump :: Options -> Dump -> Bool -dump opts d = moduleFlag ((d `elem`) . optDump) opts - --- --- * Convenience functions for setting options --- - -setOptimization :: Optimization -> Bool -> Options -setOptimization o b = modifyModuleFlags (setOptimization' o b) - -setOptimization' :: Optimization -> Bool -> ModuleFlags -> ModuleFlags -setOptimization' o b f = f { optOptimizations = g (optOptimizations f)} - where g = if b then Set.insert o else Set.delete o - --- --- * General utilities --- - -readMaybe :: Read a => String -> Maybe a -readMaybe s = case reads s of - [(x,"")] -> Just x - _ -> Nothing - -toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a -toEnumBounded i = let mi = minBound - ma = maxBound `asTypeOf` mi - in if i >= fromEnum mi && i <= fromEnum ma - then Just (toEnum i `asTypeOf` mi) - else Nothing - - -instance Functor OptDescr where - fmap f (Option cs ss d s) = Option cs ss (fmap f d) s - -instance Functor ArgDescr where - fmap f (NoArg x) = NoArg (f x) - fmap f (ReqArg g s) = ReqArg (f . g) s - fmap f (OptArg g s) = OptArg (f . g) s diff --git a/src-3.0/GF/Infra/PrintClass.hs b/src-3.0/GF/Infra/PrintClass.hs deleted file mode 100644 index 5e94984a6..000000000 --- a/src-3.0/GF/Infra/PrintClass.hs +++ /dev/null @@ -1,51 +0,0 @@ -module GF.Infra.PrintClass where - -import Data.List (intersperse) - -class Print a where - prt :: a -> String - prtList :: [a] -> String - prtList as = "[" ++ prtSep "," as ++ "]" - -prtSep :: Print a => String -> [a] -> String -prtSep sep = concat . intersperse sep . map prt - -prtBefore :: Print a => String -> [a] -> String -prtBefore before = prtBeforeAfter before "" - -prtAfter :: Print a => String -> [a] -> String -prtAfter after = prtBeforeAfter "" after - -prtBeforeAfter :: Print a => String -> String -> [a] -> String -prtBeforeAfter before after as = concat [ before ++ prt a ++ after | a <- as ] - -prtPairList :: (Print a, Print b) => String -> String -> [(a,b)] -> String -prtPairList comma sep xys = prtSep sep [ prt x ++ comma ++ prt y | (x,y) <- xys ] -prIO :: Print a => a -> IO () -prIO = putStr . prt - -instance Print a => Print [a] where - prt = prtList - -instance (Print a, Print b) => Print (a, b) where - prt (a, b) = "(" ++ prt a ++ "," ++ prt b ++ ")" - -instance (Print a, Print b, Print c) => Print (a, b, c) where - prt (a, b, c) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ ")" - -instance (Print a, Print b, Print c, Print d) => Print (a, b, c, d) where - prt (a, b, c, d) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ "," ++ prt d ++ ")" - -instance Print Char where - prt = return - prtList = id - -instance Print Int where - prt = show - -instance Print Integer where - prt = show - -instance Print a => Print (Maybe a) where - prt (Just a) = prt a - prt Nothing = "Nothing" diff --git a/src-3.0/GF/Infra/UseIO.hs b/src-3.0/GF/Infra/UseIO.hs deleted file mode 100644 index 00b956708..000000000 --- a/src-3.0/GF/Infra/UseIO.hs +++ /dev/null @@ -1,277 +0,0 @@ -{-# OPTIONS -cpp #-} ----------------------------------------------------------------------- --- | --- Module : UseIO --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.17 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Infra.UseIO where - -import GF.Data.Operations -import GF.Infra.Option -import Paths_gf(getDataDir) - -import System.Directory -import System.FilePath -import System.IO -import System.IO.Error -import System.Environment -import System.Exit -import System.CPUTime -import Control.Monad -import Control.Exception(evaluate) -import qualified Data.ByteString.Char8 as BS - -putShow' :: Show a => (c -> a) -> c -> IO () -putShow' f = putStrLn . show . length . show . f - -putIfVerb :: Options -> String -> IO () -putIfVerb opts msg = - when (verbAtLeast opts Verbose) $ putStrLn msg - -putIfVerbW :: Options -> String -> IO () -putIfVerbW opts msg = - when (verbAtLeast opts Verbose) $ putStr (' ' : msg) - -errOptIO :: Options -> a -> Err a -> IO a -errOptIO os e m = case m of - Ok x -> return x - Bad k -> do - putIfVerb os k - return e - -readFileIf f = catch (readFile f) (\_ -> reportOn f) where - reportOn f = do - putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string") - return "" - -readFileIfStrict f = catch (BS.readFile f) (\_ -> reportOn f) where - reportOn f = do - putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string") - return BS.empty - -type FileName = String -type InitPath = String -type FullPath = String - -getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) -getFilePath ps file = getFilePathMsg ("file" +++ file +++ "not found\n") ps file - -getFilePathMsg :: String -> [FilePath] -> String -> IO (Maybe FilePath) -getFilePathMsg msg paths file = get paths where - get [] = putStrFlush msg >> return Nothing - get (p:ps) = do - let pfile = p </> file - exist <- doesFileExist pfile - if not exist - then get ps - else do pfile <- canonicalizePath pfile - return (Just pfile) - -readFileIfPath :: [FilePath] -> String -> IOE (FilePath,BS.ByteString) -readFileIfPath paths file = do - mpfile <- ioeIO $ getFilePath paths file - case mpfile of - Just pfile -> do - s <- ioeIO $ BS.readFile pfile - return (dropFileName pfile,s) - _ -> ioeErr $ Bad ("File " ++ file ++ " does not exist.") - -doesFileExistPath :: [FilePath] -> String -> IOE Bool -doesFileExistPath paths file = do - mpfile <- ioeIO $ getFilePathMsg "" paths file - return $ maybe False (const True) mpfile - -gfLibraryPath = "GF_LIB_PATH" -gfGrammarPathVar = "GF_GRAMMAR_PATH" - -getLibraryPath :: IO FilePath -getLibraryPath = - catch - (getEnv gfLibraryPath) - (\ex -> getDataDir >>= \path -> return (path </> "lib")) - --- | extends the search path with the --- 'gfLibraryPath' and 'gfGrammarPathVar' --- environment variables. Returns only existing paths. -extendPathEnv :: [FilePath] -> IO [FilePath] -extendPathEnv ps = do - b <- getLibraryPath -- e.g. GF_LIB_PATH - s <- catch (getEnv gfGrammarPathVar) (const (return "")) -- e.g. GF_GRAMMAR_PATH - let ss = ps ++ splitSearchPath s - liftM concat $ mapM allSubdirs $ ss ++ [b </> s | s <- ss ++ ["prelude"]] - where - allSubdirs :: FilePath -> IO [FilePath] - allSubdirs [] = return [[]] - allSubdirs p = case last p of - '*' -> do let path = init p - fs <- getSubdirs path - return [path </> f | f <- fs] - _ -> do exists <- doesDirectoryExist p - if exists - then return [p] - else return [] - -getSubdirs :: FilePath -> IO [FilePath] -getSubdirs dir = do - fs <- catch (getDirectoryContents dir) (const $ return []) - foldM (\fs f -> do let fpath = dir </> f - p <- getPermissions fpath - if searchable p && not (take 1 f==".") - then return (fpath:fs) - else return fs ) [] fs - -justModuleName :: FilePath -> String -justModuleName = dropExtension . takeFileName - -splitInModuleSearchPath :: String -> [FilePath] -splitInModuleSearchPath s = case break isPathSep s of - (f,_:cs) -> f : splitInModuleSearchPath cs - (f,_) -> [f] - where - isPathSep :: Char -> Bool - isPathSep c = c == ':' || c == ';' - --- - -getLineWell :: IO String -> IO String -getLineWell ios = - catch getLine (\e -> if (isEOFError e) then ios else ioError e) - -putStrFlush :: String -> IO () -putStrFlush s = putStr s >> hFlush stdout - -putStrLnFlush :: String -> IO () -putStrLnFlush s = putStrLn s >> hFlush stdout - --- * a generic quiz session - -type QuestionsAndAnswers = [(String, String -> (Integer,String))] - -teachDialogue :: QuestionsAndAnswers -> String -> IO () -teachDialogue qas welc = do - putStrLn $ welc ++++ genericTeachWelcome - teach (0,0) qas - where - teach _ [] = do putStrLn "Sorry, ran out of problems" - teach (score,total) ((question,grade):quas) = do - putStr ("\n" ++ question ++ "\n> ") - answer <- getLine - if (answer == ".") then return () else do - let (result, feedback) = grade answer - score' = score + result - total' = total + 1 - putStr (feedback ++++ "Score" +++ show score' ++ "/" ++ show total') - if (total' > 9 && fromInteger score' / fromInteger total' >= 0.75) - then do putStrLn "\nCongratulations - you passed!" - else teach (score',total') quas - - genericTeachWelcome = - "The quiz is over when you have done at least 10 examples" ++++ - "with at least 75 % success." +++++ - "You can interrupt the quiz by entering a line consisting of a dot ('.').\n" - - --- * IO monad with error; adapted from state monad - -newtype IOE a = IOE (IO (Err a)) - -appIOE :: IOE a -> IO (Err a) -appIOE (IOE iea) = iea - -ioe :: IO (Err a) -> IOE a -ioe = IOE - -ioeIO :: IO a -> IOE a -ioeIO io = ioe (io >>= return . return) - -ioeErr :: Err a -> IOE a -ioeErr = ioe . return - -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 - -ioeBad :: String -> IOE a -ioeBad = ioe . return . Bad - -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 f s xs = case xs of - [] -> return (s,Nothing) - x:xx -> do - ev <- ioeIO $ appIOE (f s x) - case ev of - Ok v -> foldIOE f v xx - Bad m -> return $ (s, Just m) - -dieIOE :: IOE a -> IO a -dieIOE x = appIOE x >>= err die return - -die :: String -> IO a -die s = do hPutStrLn stderr s - exitFailure - -putStrLnE :: String -> IOE () -putStrLnE = ioeIO . putStrLnFlush - -putStrE :: String -> IOE () -putStrE = ioeIO . putStrFlush - -putPointE :: Verbosity -> Options -> String -> IOE a -> IOE a -putPointE v opts msg act = do - when (verbAtLeast opts v) $ ioeIO $ putStrFlush msg - - t1 <- ioeIO $ getCPUTime - a <- act >>= ioeIO . evaluate - t2 <- ioeIO $ getCPUTime - - if flag optShowCPUTime opts - then putStrLnE (" " ++ show ((t2 - t1) `div` 1000000000) ++ " msec") - else when (verbAtLeast opts v) $ putStrLnE "" - - return a - - --- ((do {s <- readFile f; return (return s)}) ) -readFileIOE :: FilePath -> IOE BS.ByteString -readFileIOE f = ioe $ catch (BS.readFile f >>= return . return) - (\e -> return (Bad (show e))) - --- | like readFileIOE but look also in the GF library if file not found --- --- intended semantics: if file is not found, try @\$GF_LIB_PATH\/file@ --- (even if file is an absolute path, but this should always fail) --- it returns not only contents of the file, but also the path used -readFileLibraryIOE :: String -> FilePath -> IOE (FilePath, BS.ByteString) -readFileLibraryIOE ini f = ioe $ do - lp <- getLibraryPath - tryRead ini $ \_ -> - tryRead lp $ \e -> - return (Bad (show e)) - where - tryRead path onError = - catch (BS.readFile fpath >>= \s -> return (return (fpath,s))) - onError - where - fpath = path </> f - --- | example -koeIOE :: IO () -koeIOE = useIOE () $ do - s <- ioeIO $ getLine - s2 <- ioeErr $ mapM (!? 2) $ words s - ioeIO $ putStrLn s2 - |
