GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-06 01:32:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

reintroduce the compiler API

Browse Source
This commit is contained in:
Krasimir Angelov
2024-01-18 20:58:10 +01:00
parent 282c6fc50f
commit a82095d117
138 changed files with 84 additions and 342 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
src/compiler/api/GF/Infra/BuildInfo.hs Normal file
View File

@@ -0,0 +1,16 @@
{-# LANGUAGE CPP #-}
module GF.Infra.BuildInfo where
import System.Info
import Data.Version(showVersion)
{-# NOINLINE buildInfo #-}
buildInfo =
"Built on "++os++"/"++arch
++" with "++compilerName++"-"++showVersion compilerVersion
++", flags:"
#ifdef USE_INTERRUPT
++" interrupt"
#endif
#ifdef SERVER_MODE
++" server"
#endif

145
src/compiler/api/GF/Infra/CheckM.hs Normal file
View File

@@ -0,0 +1,145 @@
----------------------------------------------------------------------
-- |
-- 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(..), CheckResult(..), Message, runCheck, runCheck',
checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
checkIn, checkInModule, checkMap, checkMapRecover,
accumulateError, commitCheck,
) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Data.Operations
--import GF.Infra.Ident
--import GF.Grammar.Grammar(msrc) -- ,Context
import GF.Infra.Location(ppLocation,sourcePath)
import GF.Infra.Option(Options,noOptions,verbAtLeast,Verbosity(..))
import qualified Data.Map as Map
import GF.Text.Pretty
import System.FilePath(makeRelative)
import Control.Parallel.Strategies(parList,rseq,using)
import Control.Monad(liftM,ap)
import Control.Applicative(Applicative(..))
import qualified Control.Monad.Fail as Fail
type Message = Doc
type Error = Message
type Warning = Message
type NonFatal = ([Error],[Warning])
data CheckResult a b = Fail Error b | Success a b
newtype Check a
= Check {unCheck :: NonFatal -> CheckResult a NonFatal}
instance Functor Check where fmap = liftM
instance Monad Check where
return x = Check $ \msgs -> Success x msgs
f >>= g = Check $ \ws ->
case unCheck f ws of
Success x msgs -> unCheck (g x) msgs
Fail msg msgs -> Fail msg msgs
instance Fail.MonadFail Check where
fail = raise
instance Applicative Check where
pure = return
(<*>) = ap
instance ErrorMonad Check where
raise s = checkError (pp s)
handle f h = handle' f (h . render)
handle' f h = Check (\msgs -> case unCheck f {-ctxt-} msgs of
Success x msgs -> Success x msgs
Fail msg msgs -> unCheck (h msg) msgs)
-- | Report a fatal error
checkError :: Message -> Check a
checkError msg = Check (\msgs -> Fail msg msgs)
checkCond :: Message -> Bool -> Check ()
checkCond s b = if b then return () else checkError s
-- | warnings should be reversed in the end
checkWarn :: Message -> Check ()
checkWarn msg = Check $ \(es,ws) -> Success () (es,("Warning:" <+> msg) : ws)
checkWarnings ms = mapM_ checkWarn ms
-- | Report a nonfatal (accumulated) error
checkAccumError :: Message -> Check ()
checkAccumError msg = Check $ \(es,ws) -> Success () (msg:es,ws)
-- | Turn a fatal error into a nonfatal (accumulated) error
accumulateError :: (a -> Check a) -> a -> Check a
accumulateError chk a =
handle' (chk a) $ \ msg -> do checkAccumError msg; return a
-- | Turn accumulated errors into a fatal error
commitCheck :: Check a -> Check a
commitCheck c =
Check $ \msgs0@(es0,ws0) ->
case unCheck c ([],[]) of
(Success v ([],ws)) -> Success v (es0,ws++ws0)
(Success _ msgs) -> bad msgs0 msgs
(Fail e (es,ws)) -> bad msgs0 ((e:es),ws)
where
bad (es0,ws0) (es,ws) = (Fail (list es) (es0,ws++ws0))
list = vcat . reverse
-- | Run an error check, report errors and warnings
runCheck c = runCheck' noOptions c
-- | Run an error check, report errors and (optionally) warnings
runCheck' :: ErrorMonad m => Options -> Check a -> m (a,String)
runCheck' opts c =
case unCheck c ([],[]) of
Success v ([],ws) -> return (v,render (wlist ws))
Success v msgs -> bad msgs
Fail e (es,ws) -> bad ((e:es),ws)
where
bad (es,ws) = raise (render $ wlist ws $$ list es)
list = vcat . reverse
wlist ws = if verbAtLeast opts Normal then list ws else empty
checkMap :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
checkMap f map = do xs <- mapM (\(k,v) -> do v <- f k v
return (k,v)) (Map.toList map)
return (Map.fromAscList xs)
checkMapRecover :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
checkMapRecover f = fmap Map.fromList . mapM f' . Map.toList
where f' (k,v) = fmap ((,)k) (f k v)
checkIn :: Doc -> Check a -> Check a
checkIn msg c = Check $ \msgs0 ->
case unCheck c ([],[]) of
Fail msg msgs -> Fail (augment1 msg) (augment msgs0 msgs)
Success v msgs -> Success v (augment msgs0 msgs)
where
augment (es0,ws0) (es,ws) = (augment' es0 es,augment' ws0 ws)
augment' msgs0 [] = msgs0
augment' msgs0 msgs' = (msg $$ nest 3 (vcat (reverse msgs'))):msgs0
augment1 msg' = msg $$ nest 3 msg'
-- | Augment error messages with a relative path to the source module and
-- an contextual hint (which can be left 'empty')
checkInModule cwd mi loc context =
checkIn (ppLocation relpath loc <> ':' $$ nest 2 context)
where
relpath = makeRelative cwd (sourcePath mi)

48
src/compiler/api/GF/Infra/Concurrency.hs Normal file
View File

@@ -0,0 +1,48 @@
-- | Lifted concurrency operators and a some useful concurrency abstractions
module GF.Infra.Concurrency(
module GF.Infra.Concurrency,
C.forkIO,
C.MVar,C.modifyMVar,C.modifyMVar_,
C.Chan
) where
import qualified Control.Concurrent as C
import System.IO.Unsafe(unsafeInterleaveIO)
import Control.Monad((<=<))
import Control.Monad.Trans(MonadIO(..))
-- * Futures
newtype Future a = Future {now::IO a}
spawn io = do v <- newEmptyMVar
C.forkIO $ putMVar v =<< io
return (Future (readMVar v))
parMapM f = mapM now <=< mapM (spawn . f)
-- * Single-threaded logging
newLog put =
do logchan <- newChan
liftIO $ C.forkIO (mapM_ put =<< getChanContents logchan)
return (writeChan logchan)
-- * Lifted concurrency operators
newMVar x = liftIO $ C.newMVar x
readMVar v = liftIO $ C.readMVar v
putMVar v = liftIO . C.putMVar v
newEmptyMVar :: MonadIO io => io (C.MVar a)
newEmptyMVar = liftIO C.newEmptyMVar
newChan :: MonadIO io => io (C.Chan a)
newChan = liftIO C.newChan
getChanContents ch = liftIO $ C.getChanContents ch
writeChan ch = liftIO . C.writeChan ch
-- * Delayed IO
lazyIO = unsafeInterleaveIO

74
src/compiler/api/GF/Infra/Dependencies.hs Normal file
View File

@@ -0,0 +1,74 @@
module GF.Infra.Dependencies (
depGraph
) where
import GF.Grammar.Grammar
--import GF.Infra.Ident(Ident)
import GF.Text.Pretty(render)
import Data.List (nub,isPrefixOf)
-- the list gives the only modules to show, e.g. to hide the library details
depGraph :: Maybe [String] -> Grammar -> String
depGraph only = prDepGraph . grammar2moddeps only
prDepGraph :: [(ModuleName,ModDeps)] -> String
prDepGraph deps = unlines $ [
"digraph {"
] ++
map mkNode deps ++
concatMap mkArrows deps ++ [
"}"
]
where
mkNode (i,dep) = unwords [render i, "[",nodeAttr (modtype dep),"]"]
nodeAttr ty = case ty of
MTAbstract -> "style = \"solid\", shape = \"box\""
MTConcrete _ -> "style = \"solid\", shape = \"ellipse\""
_ -> "style = \"dashed\", shape = \"ellipse\""
mkArrows (i,dep) =
[unwords [render i,"->",render j,"[",arrowAttr "of","]"] | j <- ofs dep] ++
[unwords [render i,"->",render j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++
[unwords [render i,"->",render j,"[",arrowAttr "op","]"] | j <- openeds dep] ++
[unwords [render i,"->",render j,"[",arrowAttr "ed","]"] | j <- extrads dep]
arrowAttr s = case s of
"of" -> "style = \"solid\", arrowhead = \"empty\""
"ex" -> "style = \"solid\""
"op" -> "style = \"dashed\""
"ed" -> "style = \"dotted\""
data ModDeps = ModDeps {
modtype :: ModuleType,
ofs :: [ModuleName],
extendeds :: [ModuleName],
openeds :: [ModuleName],
extrads :: [ModuleName],
functors :: [ModuleName],
interfaces :: [ModuleName],
instances :: [ModuleName]
}
noModDeps = ModDeps MTAbstract [] [] [] [] [] [] []
grammar2moddeps :: Maybe [String] -> Grammar -> [(ModuleName,ModDeps)]
grammar2moddeps monly gr = [(i,depMod i m) | (i,m) <- modules gr, yes i]
where
depMod i m =
noModDeps{
modtype = mtype m,
ofs = case mtype m of
MTConcrete i -> [i | yes i]
MTInstance (i,_) -> [i | yes i]
_ -> [],
extendeds = nub $ filter yes $ map fst (mextend m),
openeds = nub $ filter yes $ map openedModule (mopens m),
extrads = nub $ filter yes $ mexdeps m
}
yes i = case monly of
Just only -> match (render i) only
_ -> True
match s os = any (\x -> doMatch x s) os
doMatch x s = case last x of
'*' -> isPrefixOf (init x) s
_ -> x == s

381
src/compiler/api/GF/Infra/GetOpt.hs Normal file
View File

@@ -0,0 +1,381 @@
-- 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.
-}

137
src/compiler/api/GF/Infra/Ident.hs Normal file
View File

@@ -0,0 +1,137 @@
----------------------------------------------------------------------
-- |
-- 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
ModuleName(..), moduleNameS,
Ident, ident2utf8, showIdent, prefixIdent,
-- *** Normal identifiers (returned by the parser)
identS, identC, identW,
-- *** Special identifiers for internal use
identV,
varStr, varX, varIndex, varIndex',
-- *** Raw identifiers
RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
isPrefixOf, showRawIdent
) where
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
-- Limit use of BS functions to the ones that work correctly on
-- UTF-8-encoded bytestrings!
import Data.Char(isDigit)
import Data.Binary(Binary(..))
import GF.Text.Pretty
-- | Module names
newtype ModuleName = MN Ident deriving (Eq,Ord)
moduleNameS = MN . identS
instance Show ModuleName where showsPrec d (MN m) = showsPrec d m
instance Pretty ModuleName where pp (MN m) = pp m
instance Binary ModuleName where
put (MN id) = put id
get = fmap MN get
-- | the constructors labelled /INTERNAL/ are
-- internal representation never returned by the parser
data Ident =
IC {-# UNPACK #-} !RawIdent -- ^ raw identifier after parsing, resolved in Rename
| IW -- ^ wildcard
--
-- below this constructor: internal representation never returned by the parser
| IV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ variable
deriving (Eq, Ord, Show, Read)
-- | Identifiers are stored as UTF-8-encoded bytestrings.
-- (It is also possible to use regular Haskell 'String's, with somewhat
-- reduced performance and increased memory use.)
newtype RawIdent = Id { rawId2utf8 :: UTF8.ByteString }
deriving (Eq, Ord, Show, Read)
pack = UTF8.fromString
unpack = UTF8.toString
rawIdentS = Id . pack
rawIdentC = Id
showRawIdent = unpack . rawId2utf8
prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y
instance Binary Ident where
put id = put (ident2utf8 id)
get = do bs <- get
if bs == wild
then return identW
else return (identC (rawIdentC bs))
instance Binary RawIdent where
put = put . rawId2utf8
get = fmap rawIdentC get
-- | This function should be used with care, since the returned ByteString is
-- UTF-8-encoded.
ident2utf8 :: Ident -> UTF8.ByteString
ident2utf8 i = case i of
IC (Id s) -> s
IV (Id s) n -> BS.append s (pack ('_':show n))
IW -> wild
ident2raw :: Ident -> RawIdent
ident2raw = Id . ident2utf8
showIdent :: Ident -> String
showIdent i = unpack $! ident2utf8 i
instance Pretty Ident where pp = pp . showIdent
instance Pretty RawIdent where pp = pp . showRawIdent
identS :: String -> Ident
identS = identC . rawIdentS
identC :: RawIdent -> Ident
identW :: Ident
prefixIdent :: String -> Ident -> Ident
prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8
identV :: RawIdent -> Int -> Ident
(identC, identV, identW) =
(IC, IV, IW)
-- | used in lin defaults
varStr :: Ident
varStr = identS "str"
-- | refreshing variables
varX :: Int -> Ident
varX = identV (rawIdentS "x")
wild = pack "_"
varIndex :: Ident -> Int
varIndex (IV _ n) = n
varIndex _ = -1 --- other than IV should not count
varIndex' :: RawIdent -> Ident -> Int
varIndex' x (IC y)
| x == y = 0
varIndex' x (IV y n)
| x == y = n
varIndex' _ _ = -1 --- other than IV should not count

41
src/compiler/api/GF/Infra/Location.hs Normal file
View File

@@ -0,0 +1,41 @@
-- | Source locations
module GF.Infra.Location where
import Prelude hiding ((<>))
import GF.Text.Pretty
-- ** Source locations
class HasSourcePath a where sourcePath :: a -> FilePath
data Location
= NoLoc
| Local Int Int
| External FilePath Location
deriving (Show,Eq,Ord)
-- | Attaching location information
data L a = L Location a deriving Show
instance Functor L where fmap f (L loc x) = L loc (f x)
unLoc :: L a -> a
unLoc (L _ x) = x
noLoc = L NoLoc
ppLocation :: FilePath -> Location -> Doc
ppLocation fpath NoLoc = pp fpath
ppLocation fpath (External p l) = ppLocation p l
ppLocation fpath (Local b e) =
opt (fpath/="") (fpath <> ":") <> b <> opt (b/=e) ("-" <> e)
where
opt False x = empty
opt True x = x
ppL (L loc x) msg = hang (loc<>":") 4 ("In"<+>x<>":"<+>msg)
instance Pretty Location where pp = ppLocation ""
instance Pretty a => Pretty (L a) where pp (L loc x) = loc<>":"<>x

642
src/compiler/api/GF/Infra/Option.hs Normal file
View File

@@ -0,0 +1,642 @@
module GF.Infra.Option
(
-- ** Command line options
-- *** Option types
Options,
Flags(..),
Mode(..), Phase(..), Verbosity(..), RetainMode(..),
OutputFormat(..),
SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
Dump(..), Pass(..), Recomp(..),
outputFormatsExpl,
-- *** Option parsing
parseOptions, parseModuleOptions, fixRelativeLibPaths,
-- *** Option pretty-printing
optionsGFO,
optionsPGF,
-- *** Option manipulation
addOptions, concatOptions, noOptions,
modifyFlags,
helpMessage,
-- *** Checking specific options
flag, cfgTransform, haskellOption, readOutputFormat,
isLexicalCat, isLiteralCat, renameEncoding, getEncoding, defaultEncoding,
-- *** Setting specific options
setOptimization, setCFGTransform,
-- *** Convenience methods for checking options
verbAtLeast, dump
) where
import Control.Monad
import Data.Char (toLower, isDigit)
import Data.List
import Data.Maybe
import GF.Infra.Ident
import GF.Infra.GetOpt
import GF.Grammar.Predef
import System.FilePath
import PGF2(Literal(..))
import GF.Data.Operations(Err,ErrorMonad(..),liftErr)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Control.Monad.Fail as Fail
usageHeader :: String
usageHeader = unlines
["Usage: gf [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 :: ErrorMonad err => [String] -> err a
errors = raise . unlines
-- Types
data Mode = ModeVersion | ModeHelp
| ModeInteractive | ModeRun
| ModeCompiler
| ModeServer {-port::-}Int
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 OutputFormat = FmtPGFPretty
| FmtCanonicalGF
| FmtCanonicalJson
| FmtJavaScript
| FmtJSON
| FmtPython
| FmtHaskell
| FmtJava
| FmtBNF
| FmtEBNF
| FmtRegular
| FmtNoLR
| FmtSRGS_XML
| FmtSRGS_XML_NonRec
| FmtSRGS_ABNF
| FmtSRGS_ABNF_NonRec
| FmtJSGF
| FmtGSL
| FmtVoiceXML
| FmtSLF
| FmtRegExp
| FmtFA
| FmtLR
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
deriving (Show,Eq,Ord)
data CFGTransform = CFGNoLR
| CFGRegular
| CFGTopDownFilter
| CFGBottomUpFilter
| CFGStartCatOnly
| CFGMergeIdentical
| CFGRemoveCycles
deriving (Show,Eq,Ord)
data HaskellOption = HaskellNoPrefix
| HaskellGADT
| HaskellLexical
| HaskellConcrete
| HaskellVariants
| HaskellData
| HaskellPGF2
deriving (Show,Eq,Ord)
data Warning = WarnMissingLincat
deriving (Show,Eq,Ord)
newtype Dump = Dump Pass deriving (Show,Eq,Ord)
data Pass = Source | Rebuild | Extend | Rename | TypeCheck | Refresh | Optimize | Canon
deriving (Show,Eq,Ord)
data Recomp = AlwaysRecomp | RecompIfNewer | NeverRecomp
deriving (Show,Eq,Ord)
data RetainMode = RetainAll | RetainSource | RetainCompiled
deriving Show
data Flags = Flags {
optMode :: Mode,
optStopAfterPhase :: Phase,
optVerbosity :: Verbosity,
optShowCPUTime :: Bool,
optOutputFormats :: [OutputFormat],
optLinkTargets :: (Bool,Bool), -- pgf,ngf files
optBlank :: Maybe String,
optSISR :: Maybe SISRFormat,
optHaskellOptions :: Set HaskellOption,
optLexicalCats :: Set String,
optLiteralCats :: Set Ident,
optGFODir :: Maybe FilePath,
optOutputDir :: Maybe FilePath,
optGFLibPath :: Maybe FilePath,
optDocumentRoot :: Maybe FilePath, -- For --server mode
optRecomp :: Recomp,
optProbsFile :: Maybe FilePath,
optRetainResource :: RetainMode,
optName :: Maybe String,
optPreprocessors :: [String],
optEncoding :: Maybe String,
optPMCFG :: Bool,
optOptimizations :: Set Optimization,
optOptimizePGF :: Bool,
optCFGTransforms :: Set CFGTransform,
optLibraryPath :: [FilePath],
optStartCat :: Maybe String,
optSpeechLanguage :: Maybe String,
optLexer :: Maybe String,
optUnlexer :: Maybe String,
optWarnings :: [Warning],
optDump :: [Dump],
optTagsOnly :: Bool,
optHeuristicFactor :: Maybe Double,
optCaseSensitive :: Bool,
optPlusAsBind :: Bool,
optJobs :: Maybe (Maybe Int)
}
deriving Show
newtype Options = Options (Flags -> Flags)
instance Show Options where
show (Options o) = show (o defaultFlags)
-- Option parsing
parseOptions :: ErrorMonad err =>
[String] -- ^ list of string arguments
-> err (Options, [FilePath])
parseOptions args
| not (null errs) = errors errs
| otherwise = do opts <- concatOptions `fmap` liftErr (sequence optss)
return (opts, files)
where
(optss, files, errs) = getOpt RequireOrder optDescr args
parseModuleOptions :: ErrorMonad err =>
[String] -- ^ list of string arguments
-> err Options
parseModuleOptions args = do
(opts,nonopts) <- parseOptions args
if null nonopts
then return opts
else errors $ map ("Non-option among module options: " ++) nonopts
fixRelativeLibPaths curr_dir lib_dir (Options o) = Options (fixPathFlags . o)
where
fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [curr_dir </> dir, lib_dir </> dir]) path}
-- Showing options
-- | Pretty-print the options that are preserved in .gfo files.
optionsGFO :: Options -> [(String,Literal)]
optionsGFO opts = optionsPGF opts
++ [("coding", LStr (getEncoding opts))]
-- | Pretty-print the options that are preserved in .pgf files.
optionsPGF :: Options -> [(String,Literal)]
optionsPGF opts =
maybe [] (\x -> [("language",LStr x)]) (flag optSpeechLanguage opts)
++ maybe [] (\x -> [("startcat",LStr x)]) (flag optStartCat opts)
++ maybe [] (\x -> [("heuristic_search_factor",LFlt x)]) (flag optHeuristicFactor opts)
++ (if flag optCaseSensitive opts then [] else [("case_sensitive",LStr "off")])
-- Option manipulation
flag :: (Flags -> a) -> Options -> a
flag f (Options o) = f (o defaultFlags)
addOptions :: Options -> Options -> Options
addOptions (Options o1) (Options o2) = Options (o2 . o1)
noOptions :: Options
noOptions = Options id
concatOptions :: [Options] -> Options
concatOptions = foldr addOptions noOptions
modifyFlags :: (Flags -> Flags) -> Options
modifyFlags = Options
getEncoding :: Options -> String
getEncoding = renameEncoding . maybe defaultEncoding id . flag optEncoding
defaultEncoding = "UTF-8"
-- Default options
defaultFlags :: Flags
defaultFlags = Flags {
optMode = ModeInteractive,
optStopAfterPhase = Compile,
optVerbosity = Normal,
optShowCPUTime = False,
optOutputFormats = [],
optLinkTargets = (True,False),
optBlank = Nothing,
optSISR = Nothing,
optHaskellOptions = Set.empty,
optLiteralCats = Set.fromList [cString,cInt,cFloat],
optLexicalCats = Set.empty,
optGFODir = Nothing,
optOutputDir = Nothing,
optGFLibPath = Nothing,
optDocumentRoot = Nothing,
optRecomp = RecompIfNewer,
optProbsFile = Nothing,
optRetainResource = RetainCompiled,
optName = Nothing,
optPreprocessors = [],
optEncoding = Nothing,
optPMCFG = True,
optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
optOptimizePGF = False,
optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
CFGTopDownFilter, CFGMergeIdentical],
optLibraryPath = [],
optStartCat = Nothing,
optSpeechLanguage = Nothing,
optLexer = Nothing,
optUnlexer = Nothing,
optWarnings = [],
optDump = [],
optTagsOnly = False,
optHeuristicFactor = Nothing,
optCaseSensitive = True,
optPlusAsBind = False,
optJobs = Nothing
}
-- | Option descriptions
{-# NOINLINE optDescr #-}
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 ['j'] ["jobs"] (OptArg jobs "N") "Compile N modules in parallel with -batch (default 1).",
Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
Option [] ["server"] (OptArg modeServer "port") $
"Run in HTTP server mode on given port (default "++show defaultPort++").",
Option [] ["document-root"] (ReqArg gfDocuRoot "DIR")
"Overrides the default document root for --server mode.",
Option [] ["tags"] (NoArg (set $ \o -> o{optMode = ModeCompiler, optTagsOnly = True})) "Build TAGS file and exit.",
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 (liftM2 addOptions (mode ModeCompiler) (phase Link))) "Build .pgf file and other output files and exit.",
Option [] ["boot"] (NoArg (set $ \o -> o {optLinkTargets = (True,True)})) "Boot an .ngf database for fast grammar reloading",
Option [] ["boot-only"] (NoArg (set $ \o -> o {optLinkTargets = (False,True)})) "Boot the .ngf database and don't write a .pgf file",
Option [] ["blank"] (ReqArg (\x -> set $ \o -> o { optBlank = Just x }) "ABSTR_NAME") "Create a blank database with an empty abstract syntax.",
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 [] ["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:",
"Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
"Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar,
"Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
"Abstract only: haskell, ..."]), -- prolog_abs,
Option [] ["sisr"] (ReqArg sisrFmt "FMT")
(unlines ["Include SISR tags in generated speech recognition grammars.",
"FMT can be one of: old, 1.0"]),
Option [] ["haskell"] (ReqArg hsOption "OPTION")
("Turn on an optional feature when generating Haskell data types. OPTION = "
++ concat (intersperse " | " (map fst haskellOptionNames))),
Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
"Treat CAT as a lexical category.",
Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
"Treat CAT as a literal category.",
Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
"Save output files (other than .gfo files) in DIR.",
Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
"Overrides the value of GF_LIB_PATH.",
Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
"Always recompile from source.",
Option [] ["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 [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = RetainAll })) "Retain the source and well as the compiled grammar.",
Option [] ["resource"] (NoArg (set $ \o -> o { optRetainResource = RetainSource })) "Load the source grammar as a resource only.",
Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
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 ['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 = utf8, latin1, cp1251, ..."),
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 [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).",
Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).",
Option [] ["optimize"] (ReqArg optimize "OPT")
"Select an optimization package. OPT = all | values | parametrize | none",
Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
"Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file",
Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...",
Option [] ["heuristic_search_factor"] (ReqArg (readDouble (\d o -> o { optHeuristicFactor = Just d })) "FACTOR") "Set the heuristic search factor for statistical parsing",
Option [] ["case_sensitive"] (onOff (\v -> set $ \o -> o{optCaseSensitive=v}) True) "Set the parser in case-sensitive/insensitive mode [sensitive by default]",
Option [] ["plus-as-bind"] (NoArg (set $ \o -> o{optPlusAsBind=True})) "Uses of (+) with runtime variables automatically generate BIND (experimental feature).",
dumpOption "source" Source,
dumpOption "rebuild" Rebuild,
dumpOption "extend" Extend,
dumpOption "rename" Rename,
dumpOption "tc" TypeCheck,
dumpOption "refresh" Refresh,
dumpOption "opt" Optimize,
dumpOption "canon" Canon
]
where phase x = set $ \o -> o { optStopAfterPhase = x }
mode x = set $ \o -> o { optMode = x }
defaultPort = 41296
modeServer = maybe (ms defaultPort) readPort
where
ms = mode . ModeServer
readPort p = maybe err ms (readMaybe p)
where err = fail $ "Bad server port: "++p
jobs = maybe (setjobs Nothing) number
where
number s = maybe err (setjobs . Just) (readMaybe s)
where err = fail $ "Bad number of jobs: " ++ s
setjobs j = set $ \ o -> o { optJobs = Just j }
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 }
gfoDir x = set $ \o -> o { optGFODir = Just 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
hsOption x = case lookup x haskellOptionNames of
Just p -> set $ \o -> o { optHaskellOptions = Set.insert p (optHaskellOptions o) }
Nothing -> fail $ "Unknown Haskell option: " ++ x
++ " Known: " ++ show (map fst haskellOptionNames)
literalCat x = set $ \o -> o { optLiteralCats = foldr Set.insert (optLiteralCats o) ((map identS . splitBy (==',')) x) }
lexicalCat x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
outDir x = set $ \o -> o { optOutputDir = Just x }
gfLibPath x = set $ \o -> o { optGFLibPath = Just x }
gfDocuRoot x = set $ \o -> o { optDocumentRoot = Just x }
recomp x = set $ \o -> o { optRecomp = x }
probsFile x = set $ \o -> o { optProbsFile = Just x }
name x = set $ \o -> o { optName = 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 = set $ \o -> o { optEncoding = Just 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 }
pmcfg x = set $ \o -> o { optPMCFG = x }
optimize x = case lookup x optimizationPackages of
Just p -> set $ \o -> o { optOptimizations = p }
Nothing -> fail $ "Unknown optimization package: " ++ x
optimize_pgf x = set $ \o -> o { optOptimizePGF = x }
cfgTransform x = let (x', b) = case x of
'n':'o':'-':rest -> (rest, False)
_ -> (x, True)
in case lookup x' cfgTransformNames of
Just t -> set $ setCFGTransform' t b
Nothing -> fail $ "Unknown CFG transformation: " ++ x'
++ " Known: " ++ show (map fst cfgTransformNames)
readDouble f x = case reads x of
[(d,"")] -> set $ f d
_ -> fail "A floating point number is expected"
dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = Dump d:optDump o})) ("Dump output of the " ++ s ++ " phase.")
set = return . Options
outputFormats :: [(String,OutputFormat)]
outputFormats = map fst outputFormatsExpl
outputFormatsExpl :: [((String,OutputFormat),String)]
outputFormatsExpl =
[(("pgf_pretty", FmtPGFPretty),"human-readable pgf"),
(("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
(("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
(("json", FmtJSON),"JSON (whole grammar)"),
(("haskell", FmtHaskell),"Haskell (abstract syntax)"),
(("java", FmtJava),"Java (abstract syntax)"),
(("bnf", FmtBNF),"BNF (context-free grammar)"),
(("ebnf", FmtEBNF),"Extended BNF"),
(("regular", FmtRegular),"* regular grammar"),
(("nolr", FmtNoLR),"* context-free with no left recursion"),
(("srgs_xml", FmtSRGS_XML),"SRGS speech recognition format in XML"),
(("srgs_xml_nonrec", FmtSRGS_XML_NonRec),"SRGS XML, recursion eliminated"),
(("srgs_abnf", FmtSRGS_ABNF),"SRGS speech recognition format in ABNF"),
(("srgs_abnf_nonrec", FmtSRGS_ABNF_NonRec),"SRGS ABNF, recursion eliminated"),
(("jsgf", FmtJSGF),"JSGF speech recognition format"),
(("gsl", FmtGSL),"Nuance speech recognition format"),
(("vxml", FmtVoiceXML),"Voice XML based on abstract syntax"),
(("slf", FmtSLF),"SLF speech recognition format"),
(("regexp", FmtRegExp),"regular expression"),
(("fa", FmtFA),"finite automaton in graphviz format"),
(("lr", FmtLR),"LR(0) automaton for PMCFG in graphviz format")
]
instance Show OutputFormat where
show = lookupShow outputFormats
instance Read OutputFormat where
readsPrec = lookupReadsPrec outputFormats
optimizationPackages :: [(String, Set Optimization)]
optimizationPackages =
[("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("values", Set.fromList [OptStem,OptCSE,OptExpand]),
("noexpand", Set.fromList [OptStem,OptCSE]),
-- deprecated
("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("none", Set.fromList [OptStem,OptCSE,OptExpand])
]
cfgTransformNames :: [(String, CFGTransform)]
cfgTransformNames =
[("nolr", CFGNoLR),
("regular", CFGRegular),
("topdown", CFGTopDownFilter),
("bottomup", CFGBottomUpFilter),
("startcatonly", CFGStartCatOnly),
("merge", CFGMergeIdentical),
("removecycles", CFGRemoveCycles)]
haskellOptionNames :: [(String, HaskellOption)]
haskellOptionNames =
[("noprefix", HaskellNoPrefix),
("gadt", HaskellGADT),
("lexical", HaskellLexical),
("concrete", HaskellConcrete),
("variants", HaskellVariants),
("data", HaskellData),
("pgf2", HaskellPGF2)]
-- | This is for bacward compatibility. Since GHC 6.12 we
-- started using the native Unicode support in GHC but it
-- uses different names for the code pages.
renameEncoding :: String -> String
renameEncoding "utf8" = "UTF-8"
renameEncoding "latin1" = "CP1252"
renameEncoding ('c':'p':s) | all isDigit s = 'C':'P':s
renameEncoding s = s
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 :: Fail.MonadFail 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 :: Fail.MonadFail 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 = flag ((d `elem`) . optDump) opts
cfgTransform :: Options -> CFGTransform -> Bool
cfgTransform opts t = Set.member t (flag optCFGTransforms opts)
haskellOption :: Options -> HaskellOption -> Bool
haskellOption opts o = Set.member o (flag optHaskellOptions opts)
isLiteralCat :: Options -> Ident -> Bool
isLiteralCat opts c = Set.member c (flag optLiteralCats opts)
isLexicalCat :: Options -> String -> Bool
isLexicalCat opts c = Set.member c (flag optLexicalCats opts)
--
-- * Convenience functions for setting options
--
setOptimization :: Optimization -> Bool -> Options
setOptimization o b = modifyFlags (setOptimization' o b)
setOptimization' :: Optimization -> Bool -> Flags -> Flags
setOptimization' o b f = f { optOptimizations = toggle o b (optOptimizations f)}
setCFGTransform :: CFGTransform -> Bool -> Options
setCFGTransform t b = modifyFlags (setCFGTransform' t b)
setCFGTransform' :: CFGTransform -> Bool -> Flags -> Flags
setCFGTransform' t b f = f { optCFGTransforms = toggle t b (optCFGTransforms f) }
toggle :: Ord a => a -> Bool -> Set a -> Set a
toggle o True = Set.insert o
toggle o False = 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
splitBy :: (a -> Bool) -> [a] -> [[a]]
splitBy _ [] = []
splitBy p s = case break p s of
(l, _ : t@(_ : _)) -> l : splitBy p t
(l, _) -> [l]
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

145
src/compiler/api/GF/Infra/SIO.hs Normal file
View File

@@ -0,0 +1,145 @@
-- | Shell IO: a monad that can restrict acesss to arbitrary IO and has the
-- ability to capture output that normally would be sent to stdout.
{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}
module GF.Infra.SIO(
-- * The SIO monad
SIO,MonadSIO(..),
-- * Running SIO operations
runSIO,hRunSIO,captureSIO,
-- * Unrestricted, safe operations
-- ** From the standard libraries
getCPUTime,getCurrentDirectory,getLibraryDirectory,
newStdGen,print,putStr,putStrLn,
-- ** Specific to GF
importGrammar,importSource, link,
putStrLnFlush,runInterruptibly,
modifyPGF, checkoutPGF,
startTransaction, commitTransaction, rollbackTransaction,
inTransaction,
-- * Restricted accesss to arbitrary (potentially unsafe) IO operations
-- | If the environment variable GF_RESTRICTED is defined, these
-- operations will fail. Otherwise, they will be executed normally.
-- Output to stdout will /not/ be captured or redirected.
restricted,restrictedSystem
) where
import Prelude hiding (putStr,putStrLn,print)
import Control.Applicative(Applicative(..))
import Control.Monad(liftM,ap)
import Control.Monad.Trans(MonadTrans(..))
import System.IO(hPutStr,hFlush,stdout)
import System.IO.Error(isUserError,ioeGetErrorString)
import GF.System.Catch(try)
import System.Process(system)
import System.Environment(getEnv)
import Control.Concurrent.Chan(newChan,writeChan,getChanContents)
import GF.Infra.UseIO(Output(..))
import GF.Data.Operations(ErrorMonad(..))
import qualified System.CPUTime as IO(getCPUTime)
import qualified System.Directory as IO(getCurrentDirectory)
import qualified System.Random as IO(newStdGen)
import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
import qualified GF.System.Signal as IO(runInterruptibly)
import qualified GF.Command.Importing as GF(importGrammar, importSource)
import qualified GF.Compile as GF(link)
import qualified Control.Monad.Fail as Fail
import qualified PGF2.Transactions as PGFT
import Control.Exception
-- * The SIO monad
type PutStr = String -> IO ()
newtype SIO a = SIO {unS::PutStr->IO a}
instance Functor SIO where fmap = liftM
instance Applicative SIO where
pure = return
(<*>) = ap
instance Monad SIO where
return x = SIO (const (return x))
SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h
instance Fail.MonadFail SIO where
fail = lift0 . fail
instance Output SIO where
ePutStr = lift0 . ePutStr
ePutStrLn = lift0 . ePutStrLn
putStrLnE = putStrLnFlush
putStrE = putStr
instance ErrorMonad SIO where
raise = fail
handle m h = SIO $ \putStr ->
catch (unS m putStr) $
\e -> if isUserError e
then unS (h (ioeGetErrorString e)) putStr
else ioError e
class {- Monad m => -} MonadSIO m where liftSIO :: SIO a -> m a
-- ^ If the Monad m superclass is included, then the generic instance
-- for monad transformers below would require UndecidableInstances
instance MonadSIO SIO where liftSIO = id
instance (MonadTrans t,Monad m,MonadSIO m) => MonadSIO (t m) where
liftSIO = lift . liftSIO
-- * Running SIO operations
-- | Run normally
runSIO = hRunSIO stdout
-- | Redirect 'stdout' to the given handle
hRunSIO h sio = unS sio (\s->hPutStr h s>>hFlush h)
-- | Capture 'stdout'
captureSIO :: SIO a -> IO (String,a)
captureSIO sio = do ch <- newChan
result <- unS sio (writeChan ch . Just)
writeChan ch Nothing
output <- fmap takeJust (getChanContents ch)
return (output,result)
where
takeJust (Just xs:ys) = xs++takeJust ys
takeJust _ = []
-- * Restricted accesss to arbitrary (potentially unsafe) IO operations
restricted io = SIO (const (restrictedIO io))
restrictedSystem = restricted . system
restrictedIO io =
either (const io) (const $ fail message) =<< GF.System.Catch.try (getEnv "GF_RESTRICTED")
where
message =
"This operation is not allowed when GF is running in restricted mode."
-- * Unrestricted, safe IO operations
lift0 io = SIO $ const io
lift1 f io = SIO $ f . unS io
putStr = putStrFlush
putStrFlush s = SIO ($ s)
putStrLn = putStrLnFlush
putStrLnFlush s = putStr s >> putStrFlush "\n"
print x = putStrLn (show x)
getCPUTime = lift0 IO.getCPUTime
getCurrentDirectory = lift0 IO.getCurrentDirectory
getLibraryDirectory = lift0 . IO.getLibraryDirectory
newStdGen = lift0 IO.newStdGen
runInterruptibly = lift1 IO.runInterruptibly
importGrammar readNGF pgf opts files = lift0 $ GF.importGrammar readNGF pgf opts files
importSource opts files = lift0 $ GF.importSource opts files
link opts pgf src = lift0 $ GF.link opts pgf src
modifyPGF gr t = lift0 (PGFT.modifyPGF gr t)
checkoutPGF gr = lift0 (PGFT.checkoutPGF gr)
startTransaction gr = lift0 (PGFT.startTransaction gr)
commitTransaction tr = lift0 (PGFT.commitTransaction tr)
rollbackTransaction tr = lift0 (PGFT.rollbackTransaction tr)
inTransaction tr f = lift0 (PGFT.inTransaction tr f)

273
src/compiler/api/GF/Infra/UseIO.hs Normal file
View File

@@ -0,0 +1,273 @@
----------------------------------------------------------------------
-- |
-- 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(-- ** Files and IO
module GF.Infra.UseIO,
-- *** Reused
MonadIO(..),liftErr) where
import Prelude hiding (catch)
import GF.Data.Operations
import GF.Infra.Option
import GF.System.Catch
import Paths_gf(getDataDir)
import GF.System.Directory
import GF.System.Console
import GF.Text.Pretty
import System.FilePath
import System.IO
import System.IO.Error(isUserError,ioeGetErrorString)
import System.Environment
import System.Exit
import System.CPUTime
import Text.Printf
import Control.Monad(when,liftM,foldM)
import Control.Monad.Trans(MonadIO(..))
import Control.Monad.State(StateT,lift)
import Control.Exception(evaluate)
--putIfVerb :: MonadIO io => Options -> String -> io ()
putIfVerb opts msg = when (verbAtLeast opts Verbose) $ putStrLnE msg
-- *** GF files path and library path manipulation
type FileName = String
type InitPath = String -- ^ the directory portion of a pathname
type FullPath = String
gfLibraryPath = "GF_LIB_PATH"
gfGrammarPathVar = "GF_GRAMMAR_PATH"
getLibraryDirectory :: MonadIO io => Options -> io FilePath
getLibraryDirectory opts =
case flag optGFLibPath opts of
Just path -> return path
Nothing -> liftIO $ catch (getEnv gfLibraryPath)
(\ex -> fmap (</> "lib") getDataDir)
getGrammarPath :: MonadIO io => FilePath -> io [FilePath]
getGrammarPath lib_dir = liftIO $ do
catch (fmap splitSearchPath $ getEnv gfGrammarPathVar)
(\_ -> return [lib_dir </> "alltenses",lib_dir </> "prelude"]) -- e.g. GF_GRAMMAR_PATH
-- | extends the search path with the
-- 'gfLibraryPath' and 'gfGrammarPathVar'
-- environment variables. Returns only existing paths.
extendPathEnv :: MonadIO io => Options -> io [FilePath]
extendPathEnv opts = liftIO $ do
let opt_path = flag optLibraryPath opts -- e.g. paths given as options
lib_dir <- getLibraryDirectory opts -- e.g. GF_LIB_PATH
grm_path <- getGrammarPath lib_dir -- e.g. GF_GRAMMAR_PATH
let paths = opt_path ++ [lib_dir] ++ grm_path
ps <- liftM concat $ mapM allSubdirs paths
mapM canonicalizePath ps
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 do when (verbAtLeast opts Verbose) $ putStrLn ("ignore path "++p)
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
isGF,isGFO :: FilePath -> Bool
isGF = (== ".gf") . takeExtensions
isGFO = (== ".gfo") . takeExtensions
gfFile,gfoFile :: FilePath -> FilePath
gfFile f = addExtension f "gf"
gfoFile f = addExtension f "gfo"
gf2gfo :: Options -> FilePath -> FilePath
gf2gfo = gf2gfo' . flag optGFODir
gf2gfo' gfoDir file = maybe (gfoFile (dropExtension file))
(\dir -> dir </> gfoFile (takeBaseName file))
gfoDir
--------------------------------------------------------------------------------
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 == ';'
--
-- *** Error handling in the IO monad
-- | Was: @newtype IOE a = IOE { appIOE :: IO (Err a) }@
type IOE a = IO a
--ioe :: IO (Err a) -> IOE a
--ioe io = err fail return =<< io
-- | Catch exceptions caused by calls to 'raise' or 'fail' in the 'IO' monad.
-- To catch all 'IO' exceptions, use 'try' instead.
tryIOE :: IOE a -> IO (Err a)
tryIOE ioe = handle (fmap Ok ioe) (return . Bad)
--runIOE :: IOE a -> IO a
--runIOE = id
-- instance MonadIO IOE where liftIO io = ioe (io >>= return . return)
-- | Make raise and handle mimic behaviour of the old IOE monad
instance ErrorMonad IO where
raise = fail
handle m h = catch m $ \ e -> if isUserError e
then h (ioeGetErrorString e)
else ioError e
{-
-- Control.Monad.Fail import will become redundant in GHC 8.8+
import qualified Control.Monad.Fail as Fail
instance Functor IOE where fmap = liftM
instance Applicative IOE where
pure = return
(<*>) = ap
instance Monad IOE where
return a = ioe (return (return a))
IOE c >>= f = IOE $ do
x <- c -- Err a
appIOE $ err raise f x -- f :: a -> IOE a
#if !(MIN_VERSION_base(4,13,0))
fail = raise
#endif
instance Fail.MonadFail IOE where
fail = raise
-}
-- | Print the error message and return a default value if the IO operation 'fail's
useIOE :: a -> IOE a -> IO a
useIOE a ioe = handle ioe (\s -> putStrLn s >> return a)
maybeIO io = either (const Nothing) Just `fmap` liftIO (try io)
{-
--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 <- liftIO $ appIOE (f s x)
case ev of
Ok v -> foldIOE f v xx
Bad m -> return $ (s, Just m)
-}
die :: String -> IO a
die s = do hPutStrLn stderr s
exitFailure
-- *** Diagnostic output
class Monad m => Output m where
ePutStr, ePutStrLn, putStrE, putStrLnE :: String -> m ()
instance Output IO where
ePutStr s = hPutStr stderr s `catch` oops
where oops _ = return () -- prevent crash on character encoding problem
ePutStrLn s = hPutStrLn stderr s `catch` oops
where oops _ = ePutStrLn "" -- prevent crash on character encoding problem
putStrLnE s = putStrLn s >> hFlush stdout
putStrE s = putStr s >> hFlush stdout
{-
instance Output IOE where
ePutStr = liftIO . ePutStr
ePutStrLn = liftIO . ePutStrLn
putStrLnE = liftIO . putStrLnE
putStrE = liftIO . putStrE
-}
instance Output m => Output (StateT s m) where
ePutStr = lift . ePutStr
ePutStrLn = lift . ePutStrLn
putStrE = lift . putStrE
putStrLnE = lift . putStrLnE
--putPointE :: Verbosity -> Options -> String -> IO a -> IO a
putPointE v opts msg act = do
when (verbAtLeast opts v) $ putStrE msg
(t,a) <- timeIt act
if flag optShowCPUTime opts
then do let msec = t `div` 1000000000
putStrLnE (printf " %5d msec" msec)
else when (verbAtLeast opts v) $ putStrLnE ""
return a
dumpOut opts pass doc
| dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
| otherwise = return ()
where
d = (Dump pass)
warnOut opts warnings
| null warnings = return ()
| otherwise = do t <- getTermColors
ePutStr (blueFg t);ePutStr ws;ePutStrLn (restore t)
where
ws = if flag optVerbosity opts == Normal
then '\n':warnings
else warnings
-- | Because GHC adds the confusing text "user error" for failures caused by
-- calls to 'fail'.
ioErrorText e = if isUserError e
then ioeGetErrorString e
else show e
-- *** Timing
timeIt act =
do t1 <- liftIO $ getCPUTime
a <- liftIO . evaluate =<< act
t2 <- liftIO $ getCPUTime
return (t2-t1,a)
-- *** File IO
writeUTF8File :: FilePath -> String -> IO ()
writeUTF8File fpath content =
withFile fpath WriteMode $ \ h -> do hSetEncoding h utf8
hPutStr h content
readBinaryFile path = hGetContents =<< openBinaryFile path ReadMode
writeBinaryFile path s = withBinaryFile path WriteMode (flip hPutStr s)