summaryrefslogtreecommitdiff
path: root/src-3.0/GF/Infra
diff options
context:
space:
mode:
authoraarne <aarne@cs.chalmers.se>2008-06-25 16:54:35 +0000
committeraarne <aarne@cs.chalmers.se>2008-06-25 16:54:35 +0000
commite9e80fc389365e24d4300d7d5390c7d833a96c50 (patch)
treef0b58473adaa670bd8fc52ada419d8cad470ee03 /src-3.0/GF/Infra
parentb96b36f43de3e2f8b58d5f539daa6f6d47f25870 (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.hs89
-rw-r--r--src-3.0/GF/Infra/CompactPrint.hs22
-rw-r--r--src-3.0/GF/Infra/GetOpt.hs381
-rw-r--r--src-3.0/GF/Infra/Ident.hs152
-rw-r--r--src-3.0/GF/Infra/Modules.hs429
-rw-r--r--src-3.0/GF/Infra/Option.hs549
-rw-r--r--src-3.0/GF/Infra/PrintClass.hs51
-rw-r--r--src-3.0/GF/Infra/UseIO.hs277
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
-