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

reorganize the directories under src, and rescue the JavaScript interpreter from deprecated

Browse Source
This commit is contained in:
krasimir
2009-12-13 18:50:29 +00:00
parent 15305efa5a
commit c92f9d1c0c
189 changed files with 2 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -0,0 +1,77 @@
----------------------------------------------------------------------
-- |
-- 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, Message, runCheck,
checkError, checkCond, checkWarn,
checkErr, checkIn, checkMap
) where
import GF.Data.Operations
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Printer
import qualified Data.Map as Map
import Text.PrettyPrint
type Message = Doc
data CheckResult a
= Fail [Message]
| Success a [Message]
newtype Check a = Check {unCheck :: Context -> [Message] -> CheckResult a}
instance Monad Check where
return x = Check (\ctxt msgs -> Success x msgs)
f >>= g = Check (\ctxt msgs -> case unCheck f ctxt msgs of
Success x msgs -> unCheck (g x) ctxt msgs
Fail msgs -> Fail msgs)
instance ErrorMonad Check where
raise s = checkError (text s)
handle f h = Check (\ctxt msgs -> case unCheck f ctxt msgs of
Success x msgs -> Success x msgs
Fail (msg:msgs) -> unCheck (h (render msg)) ctxt msgs)
checkError :: Message -> Check a
checkError msg = Check (\ctxt 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 (\ctxt msgs -> Success () ((text "Warning:" <+> msg) : msgs))
runCheck :: Check a -> Err (a,String)
runCheck c =
case unCheck c [] [] of
Fail msgs -> Bad ( render (vcat (reverse msgs)))
Success v msgs -> Ok (v, render (vcat (reverse msgs)))
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)
checkErr :: Err a -> Check a
checkErr (Ok x) = return x
checkErr (Bad err) = checkError (text err)
checkIn :: Doc -> Check a -> Check a
checkIn msg c = Check $ \ctxt msgs ->
case unCheck c ctxt [] of
Fail msgs' -> Fail ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs)
Success v msgs' | null msgs' -> Success v msgs
| otherwise -> Success v ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs)

22
src/compiler/GF/Infra/CompactPrint.hs Normal file
View File

@@ -0,0 +1,22 @@
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"]

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

@@ -0,0 +1,61 @@
module GF.Infra.Dependencies (
depGraph
) where
import GF.Grammar.Grammar
import GF.Infra.Modules
import GF.Infra.Ident
depGraph :: SourceGrammar -> String
depGraph = prDepGraph . grammar2moddeps
prDepGraph :: [(Ident,ModDeps)] -> String
prDepGraph deps = unlines $ [
"digraph {"
] ++
map mkNode deps ++
concatMap mkArrows deps ++ [
"}"
]
where
mkNode (i,dep) = unwords [showIdent 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 [showIdent i,"->",showIdent j,"[",arrowAttr "of","]"] | j <- ofs dep] ++
[unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++
[unwords [showIdent i,"->",showIdent j,"[",arrowAttr "op","]"] | j <- openeds dep] ++
[unwords [showIdent i,"->",showIdent 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 Ident,
ofs :: [Ident],
extendeds :: [Ident],
openeds :: [Ident],
extrads :: [Ident],
functors :: [Ident],
interfaces :: [Ident],
instances :: [Ident]
}
noModDeps = ModDeps MTAbstract [] [] [] [] [] [] []
grammar2moddeps :: SourceGrammar -> [(Ident,ModDeps)]
grammar2moddeps gr = [(i,depMod m) | (i,m) <- modules gr] where
depMod m = noModDeps{
modtype = mtype m,
ofs = case mtype m of
MTConcrete i -> [i]
MTInstance i -> [i]
_ -> [],
extendeds = map fst (extend m),
openeds = map openedModule (opens m),
extrads = mexdeps m
}

381
src/compiler/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.
-}

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

@@ -0,0 +1,152 @@
----------------------------------------------------------------------
-- |
-- 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, showIdent,
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 "_"
showIdent :: Ident -> String
showIdent 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"))
-}

349
src/compiler/GF/Infra/Modules.hs Normal file
View File

@@ -0,0 +1,349 @@
----------------------------------------------------------------------
-- |
-- 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(..), ModuleType(..),
MInclude (..),
extends, isInherited,inheritAll,
updateMGrammar, updateModule, replaceJudgements, addFlag,
addOpenQualif, flagsModule, allFlags, mapModules,
OpenSpec(..),
ModuleStatus(..),
openedModule, depPathModule, allDepsModule, partOfGrammar,
allExtends, allExtendSpecs, allExtendsPlus, allExtensions,
searchPathModule, addModule,
emptyMGrammar, emptyModInfo,
IdentM(..),
abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupInfo,
lookupPosition, ppPosition,
isModAbs, isModRes, isModCnc,
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
import Text.PrettyPrint
-- 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
newtype MGrammar i a = MGrammar {modules :: [(i,ModInfo i a)]}
deriving Show
data ModInfo i a = ModInfo {
mtype :: ModuleType i ,
mstatus :: ModuleStatus ,
flags :: Options,
extend :: [(i,MInclude i)],
mwith :: Maybe (i,MInclude i,[(i,i)]),
opens :: [OpenSpec i] ,
mexdeps :: [i] ,
jments :: BinTree i a ,
positions :: BinTree i (String,(Int,Int)) -- file, first line, last line
}
deriving Show
-- | encoding the type of the module
data ModuleType i =
MTAbstract
| MTResource
| MTConcrete i
-- ^ up to this, also used in GFC. Below, source only.
| MTInterface
| MTInstance i
deriving (Eq,Ord,Show)
data MInclude i = MIAll | MIOnly [i] | MIExcept [i]
deriving (Eq,Ord,Show)
extends :: ModInfo 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 => ModInfo i t -> i -> t -> ModInfo i t
updateModule (ModInfo mt ms fs me mw ops med js ps) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js) ps
replaceJudgements :: ModInfo i t -> BinTree i t -> ModInfo i t
replaceJudgements (ModInfo mt ms fs me mw ops med _ ps) js = ModInfo mt ms fs me mw ops med js ps
addOpenQualif :: i -> i -> ModInfo i t -> ModInfo i t
addOpenQualif i j (ModInfo mt ms fs me mw ops med js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) med js ps
addFlag :: Options -> ModInfo i t -> ModInfo i t
addFlag f mo = mo {flags = flags mo `addOptions` f}
flagsModule :: (i,ModInfo i a) -> Options
flagsModule (_,mi) = flags mi
allFlags :: MGrammar i a -> Options
allFlags gr = concatOptions [flags m | (_,m) <- modules gr]
mapModules :: (ModInfo i a -> ModInfo i a) -> MGrammar i a -> MGrammar i a
mapModules f (MGrammar ms) = MGrammar (map (onSnd f) ms)
data OpenSpec i =
OSimple i
| OQualif i i
deriving (Eq,Ord,Show)
data ModuleStatus =
MSComplete
| MSIncomplete
deriving (Eq,Ord,Show)
openedModule :: OpenSpec i -> i
openedModule o = case o of
OSimple m -> m
OQualif _ m -> m
-- | initial dependency list
depPathModule :: Ord i => ModInfo i a -> [OpenSpec i]
depPathModule m = fors m ++ exts m ++ opens m
where
fors m =
case mtype m of
MTConcrete i -> [OSimple i]
MTInstance i -> [OSimple i]
_ -> []
exts m = map OSimple (extends m)
-- | all dependencies
allDepsModule :: Ord i => MGrammar i a -> ModInfo i a -> [OpenSpec i]
allDepsModule gr m = iterFix add os0 where
os0 = depPathModule m
add os = [m | o <- os, Just 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 = (i:) $ map openedModule $ allDepsModule gr m
-- | 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 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 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 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 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 = modules gr
-- | initial search path: the nonqualified dependencies
searchPathModule :: Ord i => ModInfo 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 = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree emptyBinTree
-- | we store the module type with the identifier
data IdentM i = IdentM {
identM :: i ,
typeM :: ModuleType i
}
deriving (Eq,Ord,Show)
abstractOfConcrete :: (Show i, Eq i) => MGrammar i a -> i -> Err i
abstractOfConcrete gr c = do
n <- lookupModule gr c
case mtype n of
MTConcrete a -> return a
_ -> Bad $ "expected concrete" +++ show c
abstractModOfConcrete :: (Show i, Eq i) =>
MGrammar i a -> i -> Err (ModInfo i a)
abstractModOfConcrete gr c = do
a <- abstractOfConcrete gr c
lookupModule gr a
-- 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 $ mtype mi
lookupInfo :: (Show i, Ord i) => ModInfo i a -> i -> Err a
lookupInfo mo i = lookupTree show i (jments mo)
lookupPosition :: (Show i, Ord i) => ModInfo i a -> i -> Err (String,(Int,Int))
lookupPosition mo i = lookupTree show i (positions mo)
ppPosition :: (Show i, Ord i) => ModInfo i a -> i -> Doc
ppPosition mo i = case lookupPosition mo i of
Ok (f,(b,e)) | b == e -> text "in" <+> text f <> text ", line" <+> int b
| otherwise -> text "in" <+> text f <> text ", lines" <+> int b <> text "-" <> int e
_ -> empty
isModAbs :: ModInfo i a -> Bool
isModAbs m = case mtype m of
MTAbstract -> True
---- MTUnion t -> isModAbs t
_ -> False
isModRes :: ModInfo i a -> Bool
isModRes m = case mtype m of
MTResource -> True
MTInterface -> True ---
MTInstance _ -> True
_ -> False
isModCnc :: ModInfo i a -> Bool
isModCnc m = case mtype m of
MTConcrete _ -> True
_ -> 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
(MTInterface, MTConcrete _) -> 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 mtype m of
MTInterface -> False
_ -> mstatus m == MSComplete
-- | interface and "incomplete M" are not complete
isCompleteModule :: (Eq i) => ModInfo i a -> Bool
isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
-- | all abstract modules sorted from least to most dependent
allAbstracts :: (Ord i, Show i) => MGrammar i a -> [i]
allAbstracts gr =
case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
Left is -> is
Right cycles -> error $ "Cyclic abstract modules: " ++ show cycles
-- | the last abstract in dependency order (head of list)
greatestAbstract :: (Ord i, Show 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,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, 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, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]

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

@@ -0,0 +1,609 @@
module GF.Infra.Option
(
-- * Option types
Options,
Flags(..),
Mode(..), Phase(..), Verbosity(..), Encoding(..), OutputFormat(..),
SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
Dump(..), Printer(..), Recomp(..), BuildParser(..),
-- * 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, encodings,
-- * Setting specific options
setOptimization, setCFGTransform,
-- * 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 | ModeRun | 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_1250 | CP_1251 | CP_1252
deriving (Eq,Ord)
data OutputFormat = FmtPGFPretty
| FmtPMCFGPretty
| FmtJavaScript
| FmtHaskell
| FmtProlog
| FmtProlog_Abs
| FmtBNF
| FmtEBNF
| FmtRegular
| FmtNoLR
| FmtSRGS_XML
| FmtSRGS_XML_NonRec
| FmtSRGS_ABNF
| FmtSRGS_ABNF_NonRec
| 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
deriving (Show,Eq,Ord)
data CFGTransform = CFGNoLR
| CFGRegular
| CFGTopDownFilter
| CFGBottomUpFilter
| CFGStartCatOnly
| CFGMergeIdentical
| CFGRemoveCycles
deriving (Show,Eq,Ord)
data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
deriving (Show,Eq,Ord)
data Warning = WarnMissingLincat
deriving (Show,Eq,Ord)
data Dump = DumpSource | 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 BuildParser = BuildParser | DontBuildParser | BuildParserOnDemand
deriving (Show,Eq,Ord)
data Flags = Flags {
optMode :: Mode,
optStopAfterPhase :: Phase,
optVerbosity :: Verbosity,
optProf :: Bool,
optShowCPUTime :: Bool,
optEmitGFO :: Bool,
optOutputFormats :: [OutputFormat],
optSISR :: Maybe SISRFormat,
optHaskellOptions :: Set HaskellOption,
optLexicalCats :: Set String,
optGFODir :: Maybe FilePath,
optOutputFile :: Maybe FilePath,
optOutputDir :: Maybe FilePath,
optGFLibPath :: Maybe FilePath,
optRecomp :: Recomp,
optPrinter :: [Printer],
optProb :: Bool,
optRetainResource :: Bool,
optName :: Maybe String,
optAbsName :: Maybe String,
optCncName :: Maybe String,
optResName :: Maybe String,
optPreprocessors :: [String],
optEncoding :: Encoding,
optOptimizations :: Set Optimization,
optCFGTransforms :: Set CFGTransform,
optLibraryPath :: [FilePath],
optStartCat :: Maybe String,
optSpeechLanguage :: Maybe String,
optLexer :: Maybe String,
optUnlexer :: Maybe String,
optErasing :: Bool,
optBuildParser :: BuildParser,
optWarnings :: [Warning],
optDump :: [Dump]
}
deriving (Show)
newtype Options = Options (Flags -> Flags)
instance Show Options where
show (Options o) = show (o defaultFlags)
-- Option parsing
parseOptions :: [String] -- ^ list of string arguments
-> 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] -- ^ 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,String)]
optionsGFO opts = optionsPGF opts
++ [("coding", show (flag optEncoding opts))]
-- | Pretty-print the options that are preserved in .pgf files.
optionsPGF :: Options -> [(String,String)]
optionsPGF opts =
maybe [] (\x -> [("language",x)]) (flag optSpeechLanguage opts)
++ maybe [] (\x -> [("startcat",x)]) (flag optStartCat opts)
++ (if flag optErasing opts then [("erasing","on")] else [])
++ (if flag optBuildParser opts == BuildParserOnDemand then [("parser","ondemand")] else [])
-- 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
-- Default options
defaultFlags :: Flags
defaultFlags = Flags {
optMode = ModeInteractive,
optStopAfterPhase = Compile,
optVerbosity = Normal,
optProf = False,
optShowCPUTime = False,
optEmitGFO = True,
optOutputFormats = [],
optSISR = Nothing,
optHaskellOptions = Set.empty,
optLexicalCats = Set.empty,
optGFODir = Nothing,
optOutputFile = Nothing,
optOutputDir = Nothing,
optGFLibPath = Nothing,
optRecomp = RecompIfNewer,
optPrinter = [],
optProb = False,
optRetainResource = False,
optName = Nothing,
optAbsName = Nothing,
optCncName = Nothing,
optResName = Nothing,
optPreprocessors = [],
optEncoding = ISO_8859_1,
optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
CFGTopDownFilter, CFGMergeIdentical],
optLibraryPath = [],
optStartCat = Nothing,
optSpeechLanguage = Nothing,
optLexer = Nothing,
optUnlexer = Nothing,
optErasing = True,
optBuildParser = BuildParser,
optWarnings = [],
optDump = []
}
-- Option descriptions
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 [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
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 [] ["prof"] (NoArg (prof True)) "Dump profiling information when compiling to PMCFG",
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, prolog, ...",
"Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...",
"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 ['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 .gfo files) in DIR.",
Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
"Overides the value of GF_LIB_PATH.",
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.",
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"] (ReqArg buildParser "VALUE") "Build parser (default on). VALUE = on | off | ondemand",
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).",
Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...",
dumpOption "source" DumpSource,
dumpOption "rebuild" DumpRebuild,
dumpOption "extend" DumpExtend,
dumpOption "rename" DumpRename,
dumpOption "tc" DumpTypeCheck,
dumpOption "refresh" DumpRefresh,
dumpOption "opt" DumpOptimize,
dumpOption "canon" DumpCanon
]
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
prof x = set $ \o -> o { optProf = x }
cpu x = set $ \o -> o { optShowCPUTime = x }
emitGFO x = set $ \o -> o { optEmitGFO = 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)
lexicalCat x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
outFile x = set $ \o -> o { optOutputFile = Just x }
outDir x = set $ \o -> o { optOutputDir = Just x }
gfLibPath x = set $ \o -> o { optGFLibPath = 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 }
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 }
buildParser x = do v <- case x of
"on" -> return BuildParser
"off" -> return DontBuildParser
"ondemand" -> return BuildParserOnDemand
set $ \o -> o { optBuildParser = v }
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
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)
dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.")
set = return . Options
outputFormats :: [(String,OutputFormat)]
outputFormats =
[("pgf_pretty", FmtPGFPretty),
("pmcfg_pretty", FmtPMCFGPretty),
("js", FmtJavaScript),
("haskell", FmtHaskell),
("prolog", FmtProlog),
("prolog_abs", FmtProlog_Abs),
("bnf", FmtBNF),
("ebnf", FmtEBNF),
("regular", FmtRegular),
("nolr", FmtNoLR),
("srgs_xml", FmtSRGS_XML),
("srgs_xml_nonrec", FmtSRGS_XML_NonRec),
("srgs_abnf", FmtSRGS_ABNF),
("srgs_abnf_nonrec", FmtSRGS_ABNF_NonRec),
("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", 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)]
encodings :: [(String,Encoding)]
encodings =
[("utf8", UTF_8),
("cp1250", CP_1250),
("cp1251", CP_1251),
("cp1252", CP_1252),
("latin1", ISO_8859_1)
]
instance Show Encoding where
show = lookupShow encodings
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 = 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)
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

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

@@ -0,0 +1,186 @@
{-# 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 Text.Printf
import Control.Monad
import Control.Exception(evaluate)
import qualified Data.ByteString.Char8 as BS
import Data.List(nub)
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
type FileName = String
type InitPath = String
type FullPath = String
gfLibraryPath = "GF_LIB_PATH"
gfGrammarPathVar = "GF_GRAMMAR_PATH"
getLibraryDirectory :: Options -> IO FilePath
getLibraryDirectory opts =
case flag optGFLibPath opts of
Just path -> return path
Nothing -> catch
(getEnv gfLibraryPath)
(\ex -> getDataDir >>= \path -> return (path </> "lib"))
getGrammarPath :: FilePath -> IO [FilePath]
getGrammarPath lib_dir = do
catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) (\_ -> return [lib_dir </> "prelude"]) -- e.g. GF_GRAMMAR_PATH
-- | extends the search path with the
-- 'gfLibraryPath' and 'gfGrammarPathVar'
-- environment variables. Returns only existing paths.
extendPathEnv :: Options -> IO [FilePath]
extendPathEnv opts = do
opt_path <- return $ 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 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 == ';'
--
putStrFlush :: String -> IO ()
putStrFlush s = putStr s >> hFlush stdout
putStrLnFlush :: String -> IO ()
putStrLnFlush s = putStrLn s >> hFlush stdout
-- * IO monad with error; adapted from state monad
newtype IOE a = IOE (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 do let msec = (t2 - t1) `div` 1000000000
putStrLnE (printf " %5d msec" msec)
else when (verbAtLeast opts v) $ putStrLnE ""
return a