msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

move gf.cabal and all compiler dependent files into src/compiler

Browse Source
This commit is contained in:
Krasimir Angelov
2022-06-18 20:42:31 +02:00
parent 96c8218564
commit a8ad145aeb
264 changed files with 71 additions and 71 deletions
Download Patch File Download Diff File Expand all files Collapse all files

72
src/compiler/GF/Infra/Cache.hs Normal file
View File

@@ -0,0 +1,72 @@
-- | A file cache to avoid reading and parsing the same file many times
module GF.Infra.Cache (Cache,newCache,flushCache,expireCache,listCache,readCache,readCache') where
import Control.Concurrent.MVar
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Foldable as T(mapM_)
import Data.Maybe(mapMaybe)
import System.Directory (getModificationTime)
import System.Mem(performGC)
import Data.Time (UTCTime,getCurrentTime,diffUTCTime)
--import Data.Time.Compat (toUTCTime)
data Cache a = Cache {
cacheLoad :: Maybe a -> FilePath -> IO a,
cacheObjects :: MVar (Map FilePath (MVar (Maybe (FileInfo a))))
}
type FileInfo a = (UTCTime,UTCTime,a) -- modification time, access time, contents
-- | Create a new cache that uses the given function to read and parse files
newCache :: (Maybe a -> FilePath -> IO a) -> IO (Cache a)
newCache load =
do objs <- newMVar Map.empty
return $ Cache { cacheLoad = load, cacheObjects = objs }
-- | Forget all cached objects
flushCache :: Cache a -> IO ()
flushCache c = do modifyMVar_ (cacheObjects c) (const (return Map.empty))
performGC
-- | Forget cached objects that have been unused for longer than the given time
expireCache age c =
do now <- getCurrentTime
let expire object@(Just (_,t,_)) | diffUTCTime now t>age = return Nothing
expire object = return object
withMVar (cacheObjects c) (T.mapM_ (flip modifyMVar_ expire))
performGC
-- | List currently cached files
listCache :: Cache a -> IO [(FilePath,UTCTime)]
listCache c =
fmap (mapMaybe id) . mapM check . Map.toList =<< readMVar (cacheObjects c)
where
check (path,v) = maybe Nothing (Just . (,) path . fst3) `fmap` readMVar v
fst3 (x,y,z) = x
-- | Lookup a cached object (or read the file if it is not in the cache or if
-- it has been modified)
readCache :: Cache a -> FilePath -> IO a
readCache c file = snd `fmap` readCache' c file
-- | Like 'readCache', but also return the last modification time of the file
readCache' :: Cache a -> FilePath -> IO (UTCTime,a)
readCache' c file =
do v <- modifyMVar (cacheObjects c) findEntry
modifyMVar v readObject
where
-- Find the cache entry, inserting a new one if neccessary.
findEntry objs = case Map.lookup file objs of
Just v -> return (objs,v)
Nothing -> do v <- newMVar Nothing
return (Map.insert file v objs, v)
-- Check time stamp, and reload if different than the cache entry
readObject m = do t' <- {-toUTCTime `fmap`-} getModificationTime file
now <- getCurrentTime
x' <- case m of
Just (t,_,x) | t' == t -> return x
| otherwise -> cacheLoad c (Just x) file
_ -> cacheLoad c Nothing file
return (Just (t',now,x'), (t',x'))

10
src/compiler/GF/Server.hs
View File

@@ -32,7 +32,7 @@ import Network.URI(URI(..))
import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache)
--import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
import Network.CGI(handleErrors,liftIO)
import CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile
import GF.Server.CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile
import Text.JSON(encode,showJSON,makeObj)
--import System.IO.Silently(hCapture)
import System.Process(readProcessWithExitCode)
@@ -41,13 +41,13 @@ import Codec.Binary.UTF8.String(decodeString,encodeString)
import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn)
import GF.Infra.SIO(captureSIO)
import GF.Data.Utilities(apSnd,mapSnd)
import qualified PGFService as PS
import qualified GF.Server.PGFService as PS
import Data.Version(showVersion)
import Paths_gf(getDataDir,version)
import GF.Infra.BuildInfo (buildInfo)
import SimpleEditor.Convert(parseModule)
import RunHTTP(cgiHandler)
import URLEncoding(decodeQuery)
import GF.Server.SimpleEditor.Convert(parseModule)
import GF.Server.RunHTTP(cgiHandler)
import GF.Server.URLEncoding(decodeQuery)
--logFile :: FilePath
--logFile = "pgf-error.log"

11
src/compiler/GF/Server/CGI.hs Normal file
View File

@@ -0,0 +1,11 @@
-- | Isolate dependencies on the problematic cgi package to this module
module GF.Server.CGI(module C) where
import Network.CGI as C(
CGI,ContentType(..),Accept(..),Language(..),
getVarWithDefault,readInput,negotiate,requestAcceptLanguage,getInput,
setHeader,output,outputFPS,outputError,
handleErrors,
liftIO)
import Network.CGI.Protocol as C(CGIResult(..),CGIRequest(..),Input(..),
Headers,HeaderName(..))
import Network.CGI.Monad as C(runCGIT)

108
src/compiler/GF/Server/CGIUtils.hs Normal file
View File

@@ -0,0 +1,108 @@
{-# LANGUAGE DeriveDataTypeable, CPP #-}
-- | CGI utility functions for output, error handling and logging
module GF.Server.CGIUtils (throwCGIError, handleCGIErrors,
stderrToFile,logError,
outputJSONP,outputEncodedJSONP,
outputPNG,outputBinary,outputBinary',
outputHTML,outputPlain,outputText) where
import Control.Exception(Exception(..),SomeException(..),throw)
import Data.Typeable(Typeable,cast)
import Prelude hiding (catch)
import System.IO(hPutStrLn,stderr)
#ifndef mingw32_HOST_OS
import System.Posix
#endif
import GF.Server.CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
getInput)
import Text.JSON
import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
import qualified Data.ByteString.Lazy as BS
import Control.Monad.Catch (MonadThrow(throwM))
import Network.CGI.Monad (catchCGI)
import Control.Monad.Catch (MonadCatch(catch))
-- * Logging
#ifndef mingw32_HOST_OS
logError :: String -> IO ()
logError s = hPutStrLn stderr s
stderrToFile :: FilePath -> IO ()
stderrToFile file =
do let mode = ownerReadMode<>ownerWriteMode<>groupReadMode<>otherReadMode
(<>) = unionFileModes
flags = defaultFileFlags { append = True }
fileFd <- openFd file WriteOnly (Just mode) flags
dupTo fileFd stdError
return ()
#else
logError :: String -> IO ()
logError s = return ()
stderrToFile :: FilePath -> IO ()
stderrToFile s = return ()
#endif
-- * General CGI Error exception mechanism
data CGIError = CGIError { cgiErrorCode :: Int, cgiErrorMessage :: String, cgiErrorText :: [String] }
deriving (Show,Typeable)
instance Exception CGIError where
toException e = SomeException e
fromException (SomeException e) = cast e
throwCGIError :: Int -> String -> [String] -> CGI a
throwCGIError c m t = throwM $ toException $ CGIError c m t
handleCGIErrors :: CGI CGIResult -> CGI CGIResult
handleCGIErrors x =
x `catch` \e -> case fromException e of
Nothing -> throw e
Just (CGIError c m t) -> do setXO; outputError c m t
-- * General CGI and JSON stuff
outputJSONP :: JSON a => a -> CGI CGIResult
outputJSONP = outputEncodedJSONP . encode
outputEncodedJSONP :: String -> CGI CGIResult
outputEncodedJSONP json =
do mc <- getInput "jsonp"
let (ty,str) = case mc of
Nothing -> ("json",json)
Just c -> ("javascript",c ++ "(" ++ json ++ ")")
ct = "application/"++ty++"; charset=utf-8"
outputText ct str
outputPNG :: BS.ByteString -> CGI CGIResult
outputPNG = outputBinary' "image/png"
outputBinary :: BS.ByteString -> CGI CGIResult
outputBinary = outputBinary' "application/binary"
outputBinary' :: String -> BS.ByteString -> CGI CGIResult
outputBinary' ct x = do
setHeader "Content-Type" ct
setXO
outputFPS x
outputHTML :: String -> CGI CGIResult
outputHTML = outputText "text/html; charset=utf-8"
outputPlain :: String -> CGI CGIResult
outputPlain = outputText "text/plain; charset=utf-8"
outputText ct = outputStrict ct . UTF8.encodeString
outputStrict :: String -> String -> CGI CGIResult
outputStrict ct x | x == x = do setHeader "Content-Type" ct
setXO
output x
| otherwise = fail "I am the pope."
setXO = setHeader "Access-Control-Allow-Origin" "*"
-- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS

340
src/compiler/GF/Server/LICENSE Normal file
View File

@@ -0,0 +1,340 @@
GNU GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1989, 1991 Free Software Foundation, Inc.
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users. This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it. (Some other Free Software Foundation software is covered by
the GNU Library General Public License instead.) You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have. You must make sure that they, too, receive or can get the
source code. And you must show them these terms so they know their
rights.
We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.
Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software. If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.
Finally, any free program is threatened constantly by software
patents. We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary. To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.
The precise terms and conditions for copying, distribution and
modification follow.
GNU GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License. The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language. (Hereinafter, translation is included without limitation in
the term "modification".) Each licensee is addressed as "you".
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.
1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.
You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.
2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) You must cause the modified files to carry prominent notices
stating that you changed the files and the date of any change.
b) You must cause any work that you distribute or publish, that in
whole or in part contains or is derived from the Program or any
part thereof, to be licensed as a whole at no charge to all third
parties under the terms of this License.
c) If the modified program normally reads commands interactively
when run, you must cause it, when started running for such
interactive use in the most ordinary way, to print or display an
announcement including an appropriate copyright notice and a
notice that there is no warranty (or else, saying that you provide
a warranty) and that users may redistribute the program under
these conditions, and telling the user how to view a copy of this
License. (Exception: if the Program itself is interactive but
does not normally print such an announcement, your work based on
the Program is not required to print an announcement.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.
In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:
a) Accompany it with the complete corresponding machine-readable
source code, which must be distributed under the terms of Sections
1 and 2 above on a medium customarily used for software interchange; or,
b) Accompany it with a written offer, valid for at least three
years, to give any third party, for a charge no more than your
cost of physically performing source distribution, a complete
machine-readable copy of the corresponding source code, to be
distributed under the terms of Sections 1 and 2 above on a medium
customarily used for software interchange; or,
c) Accompany it with the information you received as to the offer
to distribute corresponding source code. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form with such
an offer, in accord with Subsection b above.)
The source code for a work means the preferred form of the work for
making modifications to it. For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable. However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.
If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.
4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.
5. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Program or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.
6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.
7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all. For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.
If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded. In such case, this License incorporates
the limitation as if written in the body of this License.
9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation. If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.
10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission. For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this. Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.
NO WARRANTY
11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.
12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
<one line to give the program's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Also add information on how to contact you by electronic and paper mail.
If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:
Gnomovision version 69, Copyright (C) year name of author
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the program
`Gnomovision' (which makes passes at compilers) written by James Hacker.
<signature of Ty Coon>, 1 April 1989
Ty Coon, President of Vice
This General Public License does not permit incorporating your program into
proprietary programs. If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library. If this is what you want to do, use the GNU Library General
Public License instead of this License.

486
src/compiler/GF/Server/PGFService.hs Normal file
View File

@@ -0,0 +1,486 @@
{-# LANGUAGE CPP #-}
module GF.Server.PGFService(cgiMain,cgiMain',getPath,
logFile,stderrToFile,
Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
import PGF2
import PGF2.Transactions
import GF.Text.Lexing
import GF.Infra.Cache
import GF.Server.CGIUtils(outputJSONP,outputPlain,outputHTML,outputText,
outputBinary,outputBinary',
logError,handleCGIErrors,throwCGIError,stderrToFile)
import GF.Server.CGI(CGI,readInput,getInput,getVarWithDefault,
CGIResult,requestAcceptLanguage,handleErrors,setHeader,
Accept(..),Language(..),negotiate,liftIO)
import GF.Server.URLEncoding
import Data.Time.Clock(UTCTime)
import Data.Time.Format(formatTime)
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format(defaultTimeLocale,rfc822DateFormat)
#else
import System.Locale(defaultTimeLocale,rfc822DateFormat)
#endif
import Text.JSON
import Text.PrettyPrint as PP(render, text, (<+>))
import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
import qualified Data.ByteString.Lazy as BS
import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.State(State,evalState,get,put)
import Control.Monad.Catch(bracket_)
import Data.Char
--import Data.Function (on)
import Data.List ({-sortBy,-}intersperse,mapAccumL,nub,isSuffixOf,nubBy,stripPrefix)
import qualified Data.Map as Map
import Data.Maybe
import System.Random
import System.Process
import System.Exit
import System.IO
import System.IO.Error(isDoesNotExistError)
import System.Directory(removeFile)
import System.FilePath(takeExtension,dropExtension,takeDirectory,(</>),(<.>))
import System.Mem(performGC)
catchIOE :: IO a -> (E.IOException -> IO a) -> IO a
catchIOE = E.catch
withQSem qsem = bracket_ (liftIO $ waitQSem qsem) (liftIO $ signalQSem qsem)
logFile :: FilePath
logFile = "pgf-error.log"
data Caches = Caches { qsem :: QSem,
pgfCache :: Cache PGF,
labelsCache :: Cache Labels }
newPGFCache jobs = do let n = maybe 4 id jobs
qsem <- newQSem n
pgfCache <- newCache' readGrammar
lblCache <- newCache' (const (fmap getDepLabels . readFile))
return $ Caches qsem pgfCache lblCache
flushPGFCache c = do flushCache (pgfCache c)
flushCache (labelsCache c)
listPGFCache c = listCache (pgfCache c)
readGrammar mb_pgf path =
case takeExtension path of
".pgf" -> readPGF path
".ngf" -> case mb_pgf of
Nothing -> readNGF path
Just gr -> checkoutPGF gr
_ -> error "Extension must be .pgf or .ngf"
newCache' rd = do c <- newCache rd
forkIO $ forever $ clean c
return c
where
clean c = do threadDelay 2000000000 -- 2000 seconds, i.e. ~33 minutes
expireCache (24*60*60) c -- 24 hours
getPath =
do path <- getVarWithDefault "PATH_TRANSLATED" "" -- apache mod_fastcgi
if null path
then getVarWithDefault "SCRIPT_FILENAME" "" -- lighttpd
else return path
cgiMain :: Caches -> CGI CGIResult
cgiMain cache = handleErrors . handleCGIErrors $
cgiMain' cache =<< getPath
cgiMain' :: Caches -> FilePath -> CGI CGIResult
cgiMain' cache path =
do command <- liftM (maybe "grammar" (urlDecodeUnicode . UTF8.decodeString))
(getInput "command")
case command of
"download" -> outputBinary =<< getFile BS.readFile path
_ -> do tpgf <- getFile (readCache' (pgfCache cache)) path
pgfMain (qsem cache) command tpgf
getFile get path =
either failed return =<< liftIO (E.try (get path))
where
failed e = if isDoesNotExistError e
then notFound path
else liftIO $ ioError e
pgfMain qsem command (t,pgf) =
case command of
"parse" -> withQSem qsem $
out t=<< join (parse # input % cat % start % limit % treeopts)
-- "parseToChart" -> withQSem qsem $
-- out t=<< join (parseToChart # input % cat % limit)
"linearize" -> out t=<< lin # tree % to
"bracketedLinearize"
-> out t=<< bracketedLin # tree % to
"linearizeAll" -> out t=<< linAll # tree % to
"translate" -> withQSem qsem $
out t=<<join(trans # input % cat % to % start % limit%treeopts)
"lookupmorpho" -> out t=<< morpho # from1 % textInput
"lookupcohorts" -> out t=<< cohorts # from1 % getInput "filter" % textInput
"flush" -> out t=<< flush
"grammar" -> out t grammar
"abstrtree" -> outputGraphviz=<< graphvizAbstractTree pgf graphvizDefaults # tree
"parsetree" -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from1 %tree
"wordforword" -> out t =<< wordforword # input % cat % to
_ -> badRequest "Unknown command" command
where
flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
performGC
return $ showJSON ()
cat :: CGI Type
cat =
do mcat <- getInput1 "cat"
case mcat of
Nothing -> return (startCat pgf)
Just cat -> case readType cat of
Nothing -> badRequest "Bad category" cat
Just typ -> return typ
langs = languages pgf
grammar = showJSON $ makeObj
["name".=abstractName pgf,
"lastmodified".=show t,
"startcat".=showType [] (startCat pgf),
"languages".=languages]
where
languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs]
parse input@((from,_),_) cat start mlimit (trie,json) =
do r <- parse' cat start mlimit input
return $ showJSON [makeObj ("from".=from:jsonParseResult json r)]
jsonParseResult json = either bad good
where
bad err = ["parseFailed".=err]
good trees = "trees".=map tp trees :[] -- :addTrie trie trees
tp (tree,prob) = makeObj ["tree".=tree
,"prob".=prob
]
-- Without caching parse results:
parse' cat start mlimit ((from,concr),input) =
case parseWithHeuristics concr cat input (-1) callbacks of
ParseOk ts -> return (Right (maybe id take mlimit (drop start ts)))
ParseFailed _ tok -> return (Left tok)
ParseIncomplete -> return (Left "")
where
callbacks = undefined
parseToChart ((from,concr),input) cat mlimit = undefined {-
do r <- case C.parseToChart concr cat input (-1) callbacks (fromMaybe 5 mlimit) of
ParseOk chart -> return (good chart)
ParseFailed _ tok -> return (bad tok)
ParseIncomplete -> return (bad "")
return $ showJSON [makeObj ("from".=from:r)]
where
callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.literalCallbacks
cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs]
bad err = ["parseFailed".=err]
good (roots,chart) = ["roots".=showJSON roots,
"chart".=makeObj [show fid .= mkChartObj inf | (fid,inf)<-Map.toList chart]]
mkChartObj (brackets,prods,cat) =
makeObj ["brackets".=map mkChartBracket brackets
,"prods" .=map mkChartProd prods
,"cat" .=cat
]
mkChartBracket (s,e,ann) =
makeObj ["start".=s,"end".=e,"ann".=ann]
mkChartProd (expr,args,prob) =
makeObj ["tree".=expr,"args".=map mkChartPArg args,"prob".=prob]
mkChartPArg (PArg _ fid) = showJSON fid
-}
linAll tree to = showJSON (linAll' tree to)
linAll' tree (tos,unlex) =
[makeObj ["to".=to,
"texts".=map unlex (linearizeAll c tree)]|(to,c)<-tos]
lin tree to = showJSON (lin' tree to)
lin' tree (tos,unlex) =
[makeObj ["to".=to,"text".=unlex (linearize c tree)]|(to,c)<-tos]
bracketedLin tree to = showJSON (bracketedLin' tree to)
bracketedLin' tree (tos,unlex) =
[makeObj ["to".=to,"brackets".=showJSON (bracketedLinearize c tree)]|(to,c)<-tos]
trans input@((from,_),_) cat to start mlimit (trie,jsontree) =
do parses <- parse' cat start mlimit input
return $
showJSON [ makeObj ["from".=from,
"translations".= jsonParses parses]]
where
jsonParses = either bad good
where
bad err = [makeObj ["error".=err]]
good parses = [makeObj ["tree".=tree
,"prob".=prob
,"linearizations".=lin' tree to]
| (tree,prob) <- parses]
morpho (from,concr) input =
showJSON [makeObj ["lemma".=l
,"analysis".=a
,"prob".=p]
| (l,a,p)<-lookupMorpho concr input]
cohorts (from,concr) filter input =
showJSON [makeObj ["start" .=showJSON s
,"word" .=showJSON w
,"morpho".=showJSON [makeObj ["lemma".=l
,"analysis".=a
,"prob".=p]
| (l,a,p)<-ms]
,"end" .=showJSON e
]
| (s,w,ms,e) <- (case filter of
Just "longest" -> filterLongest
Just "best" -> filterBest
_ -> id)
(lookupCohorts concr input)]
wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat
jsonWFW from rs =
showJSON
[makeObj
["from".=from,
"translations".=[makeObj ["linearizations".=
[makeObj["to".=to,"text".=text]
| (to,text)<-rs]]]]]
wordforword' inp@((from,concr),input) cat (tos,unlex) =
[(to,unlex . unwords $ map (lin_word' c) pws)
|let pws=map parse_word' (words input),(to,c)<-tos]
where
lin_word' c = either id (lin1 c)
lin1 c = dropq . linearize c
where
dropq (q:' ':s) | q `elem` "+*" = s
dropq s = s
parse_word' w = if all (\c->isSpace c||isPunctuation c) w
then Left w
else parse_word w
parse_word w =
maybe (Left ("["++w++"]")) Right $
msum [parse1 w,parse1 ow,morph w,morph ow]
where
ow = case w of
c:cs | isLower c -> toUpper c : cs
| isUpper c -> toLower c : cs
s -> s
parse1 s = case PGF2.parse concr cat s of
ParseOk ((t,_):ts) -> Just t
_ -> Nothing
morph w = listToMaybe
[t | (f,a,p)<-lookupMorpho concr w,
t<-maybeToList (readExpr f)]
---
input = lexit # from % textInput
where
lexit (from,lex) input = (from,lex input)
from = maybe (missing "from") getlexer =<< from'
where
getlexer f@(_,concr) = (,) f # c_lexer concr
from1 = maybe (missing "from") return =<< from'
from' = getLang "from"
to = (,) # getLangs "to" % unlexerC (const False)
getLangs = getLangs' readLang
getLang = getLang' readLang
readLang :: String -> CGI (String,Concr)
readLang lang =
case Map.lookup lang langs of
Nothing -> badRequest "Bad language" lang
Just c -> return (lang,c)
tree = do s <- maybe (missing "tree") return =<< getInput1 "tree"
maybe (badRequest "bad tree" s) return (readExpr s)
c_lexer concr = lexer (not . null . lookupMorpho concr)
--------------------------------------------------------------------------------
-- * Lexing
-- | Standard lexers
lexer good = maybe (return id) lexerfun =<< getInput "lexer"
where
lexerfun name =
case stringOp good ("lex"++name) of
Just fn -> return fn
Nothing -> badRequest "Unknown lexer" name
type Unlexer = String->String
-- | Unlexing for the C runtime system, &+ is already applied
unlexerC :: (String -> Bool) -> CGI Unlexer
unlexerC = unlexer' id
-- | Unlexing for the Haskell runtime system, the default is to just apply &+
unlexerH :: CGI Unlexer
unlexerH = unlexer' (unwords . bindTok . words) (const False)
unlexer' defaultUnlexer good =
maybe (return defaultUnlexer) unlexerfun =<< getInput "unlexer"
where
unlexerfun name =
case stringOp good ("unlex"++name) of
Just fn -> return (fn . cleanMarker)
Nothing -> badRequest "Unknown unlexer" name
cleanMarker ('+':cs) = cs
cleanMarker ('*':cs) = cs
cleanMarker cs = cs
out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t
setHeader "Last-Modified" fmt
outputJSONP r
getInput1 x = nonEmpty # getInput x
nonEmpty (Just "") = Nothing
nonEmpty r = r
textInput :: CGI String
textInput = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input"
getLangs' readLang i = mapM readLang . maybe [] words =<< getInput i
getLang' readLang i =
do mlang <- getInput i
case mlang of
Just l@(_:_) -> Just # readLang l
_ -> return Nothing
limit, depth :: CGI (Maybe Int)
limit = readInput "limit"
depth = readInput "depth"
start :: CGI Int
start = maybe 0 id # readInput "start"
treeopts :: CGI TreeOpts
treeopts = (,) # getBool "trie" % getBool "jsontree"
getBool x = maybe False toBool # getInput x
toBool s = s `elem` ["","yes","true","True"]
missing = badRequest "Missing parameter"
errorMissingId = badRequest "Missing identifier" ""
notFound = throw 404 "Not found"
badRequest = throw 400
throw code msg extra =
throwCGIError code msg [msg ++(if null extra then "" else ": "++extra)]
format def = maybe def id # getInput "format"
type From = (Maybe Concr,String)
type To = ([Concr],Unlexer)
type TreeOpts = (Bool,Bool) -- (trie,jsontree)
outputGraphviz code =
do fmt <- format "png"
case fmt of
"gv" -> outputPlain code
_ -> outputFPS' fmt =<< liftIO (pipeIt2graphviz fmt code)
where
outputFPS' = outputBinary' . mimeType
mimeType fmt =
case fmt of
"png" -> "image/png"
"gif" -> "image/gif"
"svg" -> "image/svg+xml"
-- ...
_ -> "application/binary"
pipeIt2graphviz :: String -> String -> IO BS.ByteString
pipeIt2graphviz fmt code = do
(Just inh, Just outh, _, pid) <-
createProcess (proc "dot" ["-T",fmt])
{ std_in = CreatePipe,
std_out = CreatePipe,
std_err = Inherit }
hSetBinaryMode outh True
hSetEncoding inh utf8
-- fork off a thread to start consuming the output
output <- BS.hGetContents outh
outMVar <- newEmptyMVar
_ <- forkIO $ E.evaluate (BS.length output) >> putMVar outMVar ()
-- now write and flush any input
hPutStr inh code
hFlush inh
hClose inh -- done with stdin
-- wait on the output
takeMVar outMVar
hClose outh
-- wait on the process
ex <- waitForProcess pid
case ex of
ExitSuccess -> return output
ExitFailure r -> fail ("pipeIt2graphviz: (exit " ++ show r ++ ")")
instance JSON Expr where
readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . readExpr
showJSON = showJSON . showExpr []
instance JSON BracketedString where
readJSON x = return (Leaf "")
showJSON (Bracket cat fid index fun bs) =
makeObj ["cat".=cat, "fid".=fid, "index".=index, "fun".=fun, "children".=bs]
showJSON BIND = makeObj ["bind".=True]
showJSON (Leaf s) = makeObj ["token".=s]
-- * PGF utilities
selectLanguage :: PGF -> Maybe (Accept Language) -> Concr
selectLanguage pgf macc = case acceptable of
[] -> case Map.elems (languages pgf) of
[] -> error "No concrete syntaxes in PGF grammar."
l:_ -> l
Language c:_ -> fromJust (langCodeLanguage pgf c)
where langCodes = mapMaybe languageCode (Map.elems (languages pgf))
acceptable = negotiate (map Language langCodes) macc
langCodeLanguage :: PGF -> String -> Maybe Concr
langCodeLanguage pgf code = listToMaybe [concr | concr <- Map.elems (languages pgf), languageCode concr == Just code]
-- * General utilities
infixl 2 #,%
f .= v = (f,showJSON v)
f # x = fmap f x
f % x = ap f x

45
src/compiler/GF/Server/RunHTTP.hs Normal file
View File

@@ -0,0 +1,45 @@
module GF.Server.RunHTTP(runHTTP,Options(..),cgiHandler) where
import GF.Server.CGI(ContentType(..),
CGIResult(..),CGIRequest(..),Input(..),
Headers,HeaderName(..),
runCGIT)
import GF.Server.URLEncoding(decodeQuery)
import Network.URI(uriPath,uriQuery)
import Network.Shed.Httpd(initServer,Request(..),Response(..))
import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack,empty)
import qualified Data.Map as M(fromList)
data Options = Options { documentRoot :: String, port :: Int } deriving Show
runHTTP (Options root port) = initServer port . cgiHandler root
cgiHandler root h = fmap httpResp . runCGIT h . cgiReq root
httpResp :: (Headers,CGIResult) -> Response
httpResp (hdrs,r) = Response code (map name hdrs) (body r)
where
code = maybe 200 (read.head.words) (lookup (HeaderName "Status") hdrs)
body CGINothing = ""
body (CGIOutput s) = BS.unpack s
name (HeaderName n,v) = (n,v)
cgiReq :: String -> Request -> CGIRequest
cgiReq root (Request method uri hdrs body)
| method == "POST" = CGIRequest vars (map input (decodeQuery body)) BS.empty
| otherwise = CGIRequest vars (map input (decodeQuery qs )) BS.empty -- assumes method=="GET"
where
vars = M.fromList [("REQUEST_METHOD",method),
("REQUEST_URI",show uri),
("SCRIPT_FILENAME",root++uriPath uri),
("QUERY_STRING",qs),
("HTTP_ACCEPT_LANGUAGE",al)]
qs = case uriQuery uri of
'?':'&':s -> s -- httpd-shed bug workaround
'?':s -> s
s -> s
al = maybe "" id $ lookup "Accept-Language" hdrs
input (name,val) = (name,Input (BS.pack val) Nothing plaintext)
plaintext = ContentType "text" "plain" []

26
src/compiler/GF/Server/ServeStaticFile.hs Normal file
View File

@@ -0,0 +1,26 @@
module ServeStaticFile where
import System.FilePath
import System.Directory(doesDirectoryExist)
import CGI(setHeader,outputFPS,liftIO)
import qualified Data.ByteString.Lazy.Char8 as BS
serveStaticFile path =
do b <- liftIO $ doesDirectoryExist path
let path' = if b then path </> "index.html" else path
serveStaticFile' path'
serveStaticFile' path =
do setHeader "Content-Type" (contentTypeFromExt (takeExtension path))
outputFPS =<< liftIO (BS.readFile path)
contentTypeFromExt ext =
case ext of
".html" -> "text/html"
".htm" -> "text/html"
".xml" -> "text/xml"
".txt" -> "text/plain"
".css" -> "text/css"
".js" -> "text/javascript"
".png" -> "image/png"
".jpg" -> "image/jpg"
_ -> "application/octet-stream"

91
src/compiler/GF/Server/Setup.hs Normal file
View File

@@ -0,0 +1,91 @@
{-# OPTIONS_GHC -fwarn-unused-imports #-}
import Control.Monad(when)
import System.Directory(createDirectoryIfMissing,doesFileExist,
getDirectoryContents,copyFile,removeFile)
import System.FilePath((</>))
import System.Process(system)
import System.Exit(ExitCode(..))
import Distribution.Simple
import Distribution.Simple.Setup
import Distribution.Simple.LocalBuildInfo(datadir,buildDir,absoluteInstallDirs)
main :: IO ()
main = defaultMainWithHooks simpleUserHooks{ postInst = instWWW
, postCopy = copyWWW
}
--------------------------------------------------------------------------------
-- To test the GF web service and minibar, use "cabal install" (or
-- "runhaskell Setup.hs install") to install the program pgf-http, the
-- example grammars listed below, and the minibar. Then start the server with
-- the command "pgf-http" and open http://localhost:41296/minibar/minibar.html
-- in your web browser (Firefox, Safari, Opera or Chrome).
example_grammars =
-- (pgf, tmp, src)
[("Foods.pgf","foods",
".."</>".."</>"contrib"</>"summerschool"</>"foods"</>"Foods???.gf"),
("Letter.pgf","letter",
".."</>".."</>"examples"</>"letter"</>"Letter???.gf")]
minibar_src = ".."</>"www"</>"minibar"
--------------------------------------------------------------------------------
instWWW args flags pki lbi = setupWWW args dest pki lbi
where
dest = NoCopyDest
copyWWW args flags pki lbi = setupWWW args dest pki lbi
where
dest = case copyDest flags of
NoFlag -> NoCopyDest
Flag d -> d
setupWWW args dest pkg lbi =
do mapM_ (createDirectoryIfMissing True) [grammars_dir,minibar_dir]
mapM_ build_pgf example_grammars
copy_minibar
create_root_index
where
grammars_dir = www_dir </> "grammars"
minibar_dir = www_dir </> "minibar"
www_dir = datadir (absoluteInstallDirs pkg lbi dest) </> "www"
gfo_dir = buildDir lbi </> "gfo"
build_pgf (pgf,tmp,src) =
do createDirectoryIfMissing True tmp_dir
execute cmd
copyFile pgf (grammars_dir</>pgf)
removeFile pgf
where
tmp_dir = gfo_dir</>tmp
cmd = "gf -make -s -optimize-pgf --gfo-dir="++tmp_dir++
-- " --output-dir="++grammars_dir++ -- has no effect?!
" "++src
copy_minibar =
do files <- getDirectoryContents minibar_src
mapM_ copy files
where
copy file =
do isFile <- doesFileExist src
when isFile $ copyFile src (minibar_dir</>file)
where
src = minibar_src</>file
create_root_index = writeFile (www_dir</>"index.html") index_html
index_html = "<h1>PGF service</h1>\n<h2>Available demos</h2>\n"
++"<ul><li><a href=\"minibar/minibar.html\">Minibar</a></ul>"
++"Additional grammars can be installed in"
++"<blockquote><code>"++grammars_dir++"</code></blockquote>"
++"<a href=\"http://www.grammaticalframework.org/\">"
++"Grammatical Framework</a>"
execute command =
do putStrLn command
e <- system command
case e of
ExitSuccess -> return ()
_ -> fail "Command failed"
return ()

6
src/compiler/SimpleEditor/Convert.hs → src/compiler/GF/Server/SimpleEditor/Convert.hs
View File

@@ -1,5 +1,5 @@
{-# LANGUAGE NoMonomorphismRestriction #-}
module SimpleEditor.Convert where
module GF.Server.SimpleEditor.Convert where
import Control.Monad(unless,foldM,ap,mplus)
import Data.List(sortBy)
@@ -19,8 +19,8 @@ import GF.Grammar.Lexer(Posn(..))
import GF.Data.ErrM
import PGF2(Literal(LStr))
import SimpleEditor.Syntax as S
import SimpleEditor.JSON
import GF.Server.SimpleEditor.Syntax as S
import GF.Server.SimpleEditor.JSON
parseModule (path,source) =

4
src/compiler/SimpleEditor/JSON.hs → src/compiler/GF/Server/SimpleEditor/JSON.hs
View File

@@ -1,8 +1,8 @@
module SimpleEditor.JSON where
module GF.Server.SimpleEditor.JSON where
import Text.JSON
import SimpleEditor.Syntax
import GF.Server.SimpleEditor.Syntax
instance JSON Grammar where

2
src/compiler/SimpleEditor/Syntax.hs → src/compiler/GF/Server/SimpleEditor/Syntax.hs
View File

@@ -2,7 +2,7 @@
Abstract syntax for the small subset of GF grammars supported
in gfse, the JavaScript-based simple grammar editor.
-}
module SimpleEditor.Syntax where
module GF.Server.SimpleEditor.Syntax where
type Id = String -- all sorts of identifiers
type ModId = Id -- module name

61
src/compiler/GF/Server/URLEncoding.hs Normal file
View File

@@ -0,0 +1,61 @@
module GF.Server.URLEncoding(urlDecodeUnicode,decodeQuery) where
import Data.Bits (shiftL, (.|.))
import Data.Char (chr,digitToInt,isHexDigit)
-- | Decode hexadecimal escapes
urlDecodeUnicode :: String -> String
urlDecodeUnicode [] = ""
urlDecodeUnicode ('%':'u':x1:x2:x3:x4:s)
| all isHexDigit [x1,x2,x3,x4] =
chr ( digitToInt x1 `shiftL` 12
.|. digitToInt x2 `shiftL` 8
.|. digitToInt x3 `shiftL` 4
.|. digitToInt x4) : urlDecodeUnicode s
urlDecodeUnicode ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 =
chr ( digitToInt x1 `shiftL` 4
.|. digitToInt x2) : urlDecodeUnicode s
urlDecodeUnicode (c:s) = c : urlDecodeUnicode s
--------------------------------------------------------------------------------
type Query = [(String,String)]
-- | Decode application/x-www-form-urlencoded
decodeQuery :: String -> Query
decodeQuery = map (aboth decode . breakAt '=') . chopList (breakAt '&')
aboth f (x,y) = (f x,f y)
-- | Decode "+" and hexadecimal escapes
decode [] = []
decode ('%':'u':d1:d2:d3:d4:cs)
| all isHexDigit [d1,d2,d3,d4] = chr(fromhex4 d1 d2 d3 d4):decode cs
decode ('%':d1:d2:cs)
| all isHexDigit [d1,d2] = chr(fromhex2 d1 d2):decode cs
decode ('+':cs) = ' ':decode cs
decode (c:cs) = c:decode cs
fromhex4 d1 d2 d3 d4 = 256*fromhex2 d1 d2+fromhex2 d3 d4
fromhex2 d1 d2 = 16*digitToInt d1+digitToInt d2
-- From hbc-library ListUtil ---------------------------------------------------
-- Repeatedly extract (and transform) values until a predicate hold. Return the list of values.
unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
unfoldr f p x | p x = []
| otherwise = y:unfoldr f p x'
where (y, x') = f x
chopList :: ([a] -> (b, [a])) -> [a] -> [b]
chopList f l = unfoldr f null l
breakAt :: (Eq a) => a -> [a] -> ([a], [a])
breakAt _ [] = ([], [])
breakAt x (x':xs) =
if x == x' then
([], xs)
else
let (ys, zs) = breakAt x xs
in (x':ys, zs)

16
src/compiler/GF/Server/exec/pgf-fcgi.hs Normal file
View File

@@ -0,0 +1,16 @@
{-# LANGUAGE CPP #-}
import Control.Concurrent(forkIO)
import Network.FastCGI(runFastCGI,runFastCGIConcurrent')
import PGFService(cgiMain,newPGFCache,stderrToFile,logFile)
main = do stderrToFile logFile
fcgiMain =<< newPGFCache Nothing
fcgiMain cache =
#ifndef mingw32_HOST_OS
runFastCGIConcurrent' forkIO 100 (cgiMain cache)
#else
runFastCGI (cgiMain cache)
#endif

49
src/compiler/GF/Server/exec/pgf-http.hs Normal file
View File

@@ -0,0 +1,49 @@
import Network.CGI(requestMethod,getVarWithDefault,logCGI,handleErrors,liftIO)
import System.Environment(getArgs)
import System.Directory(getDirectoryContents)
import System.FilePath(takeExtension,takeFileName,takeDirectory,(</>))
import RunHTTP(runHTTP,Options(..))
import ServeStaticFile(serveStaticFile)
import PGFService(cgiMain',getPath,stderrToFile,logFile,newPGFCache)
import CGIUtils(outputJSONP,handleCGIErrors)
import Paths_gf_server(getDataDir)
main :: IO ()
main = do datadir <- getDataDir
let defaults = Options { documentRoot = datadir</>"www",
port = 41296 }
cache <- newPGFCache
args <- getArgs
options <- case args of
[] -> return defaults
[port] -> do p <- readIO port
return defaults{port=p}
putStrLn $ "Starting HTTP server, open http://localhost:"
++show (port options)++"/ in your web browser.\n"
print options
putStrLn $ "logFile="++logFile
stderrToFile logFile
httpMain cache options
httpMain cache options = runHTTP options (do log ; serve =<< getPath)
where
log = do method <- requestMethod
uri <- getVarWithDefault "REQUEST_URI" "-"
logCGI $ method++" "++uri
serve path =
handleErrors . handleCGIErrors $
if takeExtension path==".pgf"
then cgiMain' cache path
else if takeFileName path=="grammars.cgi"
then grammarList (takeDirectory path)
else serveStaticFile path
grammarList dir =
do paths <- liftIO $ getDirectoryContents dir
let pgfs = [path|path<-paths, takeExtension path==".pgf"]
outputJSONP pgfs

122
src/compiler/GF/Server/gf-server-jsapi.js Normal file
View File

@@ -0,0 +1,122 @@
var gf = new Object();
var pgf_base_url = "pgf";
gf.grammars = function (callback) {
gf.httpGetJSONP(pgf_base_url, callback);
};
gf.grammar = function (grammar, callback) {
gf.callFunction(grammar, "", [], callback);
};
gf.parse = function (grammar,input,from,cat,callback) {
var args = [];
args["input"] = input;
args["from"] = from;
args["cat"] = cat;
gf.callFunction(grammar, "parse", args, callback);
};
gf.complete = function (grammar,input,from,cat,callback) {
var args = [];
args["input"] = input;
args["from"] = from;
args["cat"] = cat;
gf.callFunction(grammar, "complete", args, callback);
};
gf.linearize = function (grammar,tree,to,callback) {
var args = [];
args["tree"] = tree;
args["to"] = to;
gf.callFunction(grammar, "linearize", args, callback);
};
gf.random = function (grammar,cat,limit,callback) {
var args = [];
args["cat"] = cat;
args["limit"] = limit;
gf.callFunction(grammar, "random", args, callback);
};
gf.translate = function (grammar,input,from,to,cat,callback) {
var args = [];
args["input"] = input;
args["from"] = from;
args["to"] = to;
args["cat"] = cat;
gf.callFunction(grammar, "translate", args, callback);
};
gf.callFunction = function (grammar, fun, args, callback) {
var query = "";
for (var i in args) {
query += (query == "") ? "?" : "&";
query += i + "=" + encodeURIComponent(args[i]);
}
var url = pgf_base_url + "/" + grammar +"/" + fun + query;
// FIXME: if same domain, use gf.httpGetText
gf.httpGetJSONP(url, callback);
}
gf.httpGetJSONP = function (url, callback) {
var script = document.createElement("script");
if (!window.jsonCallbacks) {
window.jsonCallbacks = new Array();
}
var callbackIndex = window.jsonCallbacks.length;
window.jsonCallbacks.push(function (output) {
// get rid of the script tag
document.getElementsByTagName("head")[0].removeChild(script);
// let this function be garbage-collected
window.jsonCallbacks[callbackIndex] = null;
// shrink the array if possible
while (window.jsonCallbacks.length > 0 && window.jsonCallbacks[window.jsonCallbacks.length-1] == null) {
window.jsonCallbacks.pop();
}
callback(output);
});
var callbackName = "jsonCallbacks[" + callbackIndex + "]";
var questionMarkPos = url.indexOf("?");
if (questionMarkPos > -1) {
url += (questionMarkPos < url.length-1) ? "&" : "";
} else {
url += "?";
}
url += "jsonp=" + callbackName;
script.setAttribute("src", url);
script.setAttribute("type", "text/javascript");
document.getElementsByTagName("head")[0].appendChild(script);
};
gf.httpGetText = function (url, callback) {
var XMLHttpRequestObject = false;
if (window.XMLHttpRequest) {
XMLHttpRequestObject = new XMLHttpRequest();
} else if (window.ActiveXObject) {
XMLHttpRequestObject = new ActiveXObject("Microsoft.XMLHTTP");
}
if (XMLHttpRequestObject) {
XMLHttpRequestObject.open("GET", url);
XMLHttpRequestObject.onreadystatechange = function () {
if (XMLHttpRequestObject.readyState == 4 && XMLHttpRequestObject.status == 200) {
callback(XMLHttpRequestObject.responseText);
delete XMLHttpRequestObject;
XMLHttpRequestObject = null;
}
}
XMLHttpRequestObject.send(null);
}
};
gf.readJSON = function (text) {
return eval("("+text+")");
};

99
src/compiler/GF/Server/lighttpd.conf Normal file
View File

@@ -0,0 +1,99 @@
# Run with (with -D for no-daemon)
# /usr/sbin/lighttpd -f lighttpd.conf -D
#
server.modules = (
"mod_access",
"mod_fastcgi",
"mod_accesslog",
"mod_redirect",
"mod_cgi"
)
var.basedir = var.CWD
# John: no longer valid after removing `src/ui` 2018-11-15
server.document-root = basedir + "/../ui/gwt/www"
server.errorlog = basedir + "/error.log"
cgi.assign = ( ".cgi" => "" )
cgi.execute-x-only = "enable"
index-file.names = ( "index.html" )
## set the event-handler (read the performance section in the manual)
# server.event-handler = "freebsd-kqueue" # needed on OS X # Crashes on osx
#server.event-handler = "poll"
server.event-handler = "select"
# mimetype mapping
mimetype.assign = (
".gif" => "image/gif",
".jpg" => "image/jpeg",
".jpeg" => "image/jpeg",
".png" => "image/png",
".css" => "text/css",
".html" => "text/html",
".htm" => "text/html",
".js" => "text/javascript",
# default mime type
"" => "application/octet-stream",
)
accesslog.filename = basedir + "/access.log"
debug.log-request-header = "disable"
debug.log-response-header = "disable"
debug.log-request-handling = "disable"
$HTTP["host"] =~ "^(.*)$" {
url.redirect = ( "^/$" => "http://%1/translate/" )
}
fastcgi.debug = 0
fastcgi.server = (".pgf" =>
((
"socket" => basedir + "/" + var.PID + "-pgf.socket",
"bin-path" => basedir + "/dist/build/pgf-service/pgf-service",
# Use 2 OS threads (to be able to use 2 cores).
# Limit heap size to 512 MB.
"bin-environment" => ("GHCRTS" => "-N2 -M512M"),
"min-procs" => 1,
"max-procs" => 1,
"broken-scriptfilename" => "disable",
"check-local" => "disable"
)),
".fcgi" =>
((
"socket" => basedir + "/" + var.PID + "-morpho.socket",
# "bin-path" => basedir + "/dist/build/morpho-server/morpho-server",
"bin-environment" => ("GHCRTS" => "-M512M"),
"min-procs" => 1,
"max-procs" => 1,
"broken-scriptfilename" => "disable",
"check-local" => "disable"
))
)
## deny access the file-extensions
#
# ~ is for backupfiles from vi, emacs, joe, ...
# .inc is often used for code includes which should in general not be part
# of the document-root
url.access-deny = ( "~", ".inc" )
$HTTP["url"] =~ "\.pdf$" {
server.range-requests = "disable"
}
##
# which extensions should not be handle via static-file transfer
#
# .php, .pl, .fcgi are most often handled by mod_fastcgi or mod_cgi
static-file.exclude-extensions = ( ".php", ".pl", ".fcgi" )
######### Options that are good to be but not neccesary to be changed #######
## bind to port (default: 80)
server.port = 41296

111
src/compiler/GF/Server/simple-client.html Normal file
View File

@@ -0,0 +1,111 @@
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
<meta name="viewport" content="initial-scale=2.3" />
<meta name="viewport" content="width=320; initial-scale=1.0; maximum-scale=1.0;" />
<link rel="stylesheet" type="text/css" href="translator.css" />
<script type="text/javascript" src="gf-server-jsapi.js"></script>
<script type="text/javascript" src="translator.js"></script>
<script type="text/javascript">
function getGrammar () {
return document.getElementById('grammar').value;
}
function updateTranslation () {
var input = document.getElementById('inputText').value;
var fromLang = document.getElementById('fromLang').value;
var toLang = document.getElementById('toLang').value;
var output = document.getElementById('translation');
var callback = function(translation) {
clearTranslation();
output.appendChild(formatTranslation(translation));
};
gf.translate(getGrammar(), input, fromLang, toLang, '', callback);
}
function updateGrammars () {
gf.grammars(populateGrammars);
}
function populateGrammars (grammars) {
var l = document.getElementById('grammar');
var langs = grammar.languages;
for (var i in grammars) {
addOption(l, grammars[i].name, grammars[i].name);
}
updateLanguages();
}
function updateLanguages () {
gf.grammar(getGrammar(), populateLangs);
}
function populateLangs (grammar) {
var f = document.getElementById('fromLang');
var t = document.getElementById('toLang');
var langs = grammar.languages;
for (var i in langs) {
if (langs[i].canParse) {
addOption(f, langs[i].name, langs[i].name);
}
addOption(t, langs[i].name, langs[i].name);
}
}
function updateCompletion() {
var input = document.getElementById('inputText').value;
var fromLang = document.getElementById('fromLang').value;
var completions = document.getElementById('completion');
// if (document.getElementById('enableCompletion').checked) {
var callback = function(output) {
clearCompletion();
completions.appendChild(formatCompletions(output));
};
gf.complete(getGrammar(), input, fromLang, '', callback);
// }
}
function update() {
// updateCompletion();
updateTranslation();
}
function clearTranslation() {
var output = document.getElementById('translation');
removeChildren(output);
}
function clearCompletion() {
var completions = document.getElementById('completion');
removeChildren(completions);
}
function initialize() {
updateGrammars();
}
</script>
<title>AJAX GF Translator</title>
</head>
<body onload="initialize()">
<div id="translator">
<form onsubmit="update(); return false;">
<p>
<input type="text" id="inputText" value="" size="50" />
</p>
<p>
<label>Grammar: <select id="grammar" onchange="updateLanguages()"></select></label>
<label>From: <select id="fromLang" onchange="update()"><option value="" selected="selected">Any language</option></select></label>
<label>To: <select id="toLang" onchange="update()"><option value="" selected="selected">All languages</option></select></label>
<input type="button" value="Completions" onclick="updateCompletion()" />
<input type="submit" value="Translate" />
</p>
</form>
<div id="completion"></div>
<div id="translation"></div>
</div>
</body>
</html>

32
src/compiler/GF/Server/transfer/Fold.hs Normal file
View File

@@ -0,0 +1,32 @@
module Fold where
import PGF2
import Data.Map as M (lookup, fromList)
--import Debug.Trace
foldable = fromList [(c, "bin_" ++ c) | c <- ops]
where ops = words "plus times and or xor cartesian_product intersect union"
fold :: Expr -> Expr
fold t =
case unApp t of
Just (i,[x]) ->
case M.lookup i foldable of
Just j -> appFold j x
_ -> mkApp i [fold x]
Just (i,xs) -> mkApp i $ map fold xs
_ -> t
<<<<<<< HEAD
appFold :: Fun -> Expr -> Expr
appFold j t =
=======
appFold :: CId -> Tree -> Tree
appFold j t =
>>>>>>> master
case unApp t of
Just (i,[t,ts]) | isPre i "Cons" -> mkApp j [fold t, appFold j ts]
Just (i,[t,s]) | isPre i "Base" -> mkApp j [fold t, fold s]
where isPre i s = take 4 (show i) == s

76
src/compiler/GF/Server/translator.css Normal file
View File

@@ -0,0 +1,76 @@
body {
color: black;
background-color: white;
font-family: sans-serif;
}
dl {
margin: 0;
padding: 0;
}
dt {
margin: 0;
padding: 0;
}
dl dd {
margin: 0;
padding: 0;
}
ul {
margin: 0;
padding: 0;
}
li {
list-style-type: none;
margin: 0;
padding: 0;
}
/* Translator widget */
#translator {
}
/* Translations */
#translation {
clear: both;
}
#translation dl {
border-width: 0 0 1px 0;
border-style: solid;
border-color: #c0c0c0;
}
#translation dt {
display: none;
}
#translation dd {
border-width: 1px 0 0 0;
border-style: solid;
border-color: #c0c0c0;
}
/* Completions */
#completion {
font-size: 80%;
color: #c0c0c0;
white-space: nowrap;
width: 100%;
overflow: hidden;
}
#completion li {
display: inline;
padding: 0 0.1em;
}

51
src/compiler/GF/Server/translator.js Normal file
View File

@@ -0,0 +1,51 @@
function formatTranslation (outputs) {
var dl1 = document.createElement("dl");
for (var i in outputs) {
var o = outputs[i];
addDefinition(dl1, document.createTextNode(o.to), document.createTextNode(o.text));
}
return dl1;
}
function formatCompletions (compls) {
var ul = document.createElement("ul");
for (var i in compls) {
var c = compls[i];
addItem(ul, document.createTextNode(c.text));
}
return ul;
}
/* DOM utilities for specific tags */
function addDefinition (dl, t, d) {
var dt = document.createElement("dt");
dt.appendChild(t);
dl.appendChild(dt);
var dd = document.createElement("dd");
dd.appendChild(d);
dl.appendChild(dd);
}
function addItem (ul, i) {
var li = document.createElement("li");
li.appendChild(i);
ul.appendChild(li);
}
function addOption (select, value, content) {
var option = document.createElement("option");
option.value = value;
option.appendChild(document.createTextNode(content));
select.appendChild(option);
}
/* General DOM utilities */
/* Removes all the children of a node */
function removeChildren(node) {
while (node.hasChildNodes()) {
node.removeChild(node.firstChild);
}
}

557
src/compiler/LICENSE Normal file
View File

@@ -0,0 +1,557 @@
Grammatical Framework is a software package consisting of several different
components. The common wish of the GF development team is to provide software
that is easy to use for everyone with no restrictions. Still in some cases
we want to reserve some rights, in other cases the software that we provide
is derived from someone else's work and we have to respect the rights for the
other. For this reason the different components have different licenses.
In summary:
- the GF compiler in the folder src/compiler and the PGF Web service in src/server
are under the GNU GENERAL PUBLIC LICENSE.
- the GF runtime in src/runtime is under dual GNU LESSER GENERAL PUBLIC LICENSE and BSD LICENSE
The rest of this document contains copies of the GPL, LGPL and BSD licenses
which are applicable to the different components of Grammatical Framework
as it is described above.
GNU GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1989, 1991 Free Software Foundation, Inc.
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users. This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it. (Some other Free Software Foundation software is covered by
the GNU Library General Public License instead.) You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have. You must make sure that they, too, receive or can get the
source code. And you must show them these terms so they know their
rights.
We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.
Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software. If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.
Finally, any free program is threatened constantly by software
patents. We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary. To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.
The precise terms and conditions for copying, distribution and
modification follow.
GNU GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License. The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language. (Hereinafter, translation is included without limitation in
the term "modification".) Each licensee is addressed as "you".
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.
1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.
You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.
2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) You must cause the modified files to carry prominent notices
stating that you changed the files and the date of any change.
b) You must cause any work that you distribute or publish, that in
whole or in part contains or is derived from the Program or any
part thereof, to be licensed as a whole at no charge to all third
parties under the terms of this License.
c) If the modified program normally reads commands interactively
when run, you must cause it, when started running for such
interactive use in the most ordinary way, to print or display an
announcement including an appropriate copyright notice and a
notice that there is no warranty (or else, saying that you provide
a warranty) and that users may redistribute the program under
these conditions, and telling the user how to view a copy of this
License. (Exception: if the Program itself is interactive but
does not normally print such an announcement, your work based on
the Program is not required to print an announcement.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.
In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:
a) Accompany it with the complete corresponding machine-readable
source code, which must be distributed under the terms of Sections
1 and 2 above on a medium customarily used for software interchange; or,
b) Accompany it with a written offer, valid for at least three
years, to give any third party, for a charge no more than your
cost of physically performing source distribution, a complete
machine-readable copy of the corresponding source code, to be
distributed under the terms of Sections 1 and 2 above on a medium
customarily used for software interchange; or,
c) Accompany it with the information you received as to the offer
to distribute corresponding source code. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form with such
an offer, in accord with Subsection b above.)
The source code for a work means the preferred form of the work for
making modifications to it. For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable. However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.
If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.
4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.
5. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Program or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.
6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.
7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all. For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.
If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded. In such case, this License incorporates
the limitation as if written in the body of this License.
9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation. If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.
10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission. For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this. Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.
NO WARRANTY
11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.
12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
<one line to give the program's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Also add information on how to contact you by electronic and paper mail.
If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:
Gnomovision version 69, Copyright (C) year name of author
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the program
`Gnomovision' (which makes passes at compilers) written by James Hacker.
<signature of Ty Coon>, 1 April 1989
Ty Coon, President of Vice
This General Public License does not permit incorporating your program into
proprietary programs. If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library. If this is what you want to do, use the GNU Library General
Public License instead of this License.
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.
BSD LICENSE
Copyright (c) 1998, Grammatical Framework
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
* Neither the name of the <organization> nor the
names of its contributors may be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

81
src/compiler/Setup.hs Normal file
View File

@@ -0,0 +1,81 @@
import Distribution.System(Platform(..),OS(..))
import Distribution.Simple(defaultMainWithHooks,UserHooks(..),simpleUserHooks)
import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..),absoluteInstallDirs,datadir)
import Distribution.Simple.Setup(BuildFlags(..),Flag(..),InstallFlags(..),CopyDest(..),CopyFlags(..),SDistFlags(..))
import Distribution.PackageDescription(PackageDescription(..),emptyHookedBuildInfo)
import Distribution.Simple.BuildPaths(exeExtension)
import System.FilePath((</>),(<.>))
import WebSetup
-- | Notice about RGL not built anymore
noRGLmsg :: IO ()
noRGLmsg = putStrLn "Notice: the RGL is not built as part of GF anymore. See https://github.com/GrammaticalFramework/gf-rgl"
main :: IO ()
main = defaultMainWithHooks simpleUserHooks
{ preBuild = gfPreBuild
, postBuild = gfPostBuild
, preInst = gfPreInst
, postInst = gfPostInst
, postCopy = gfPostCopy
}
where
gfPreBuild args = gfPre args . buildDistPref
gfPreInst args = gfPre args . installDistPref
gfPre args distFlag = do
return emptyHookedBuildInfo
gfPostBuild args flags pkg lbi = do
-- noRGLmsg
let gf = default_gf lbi
buildWeb gf flags (pkg,lbi)
gfPostInst args flags pkg lbi = do
-- noRGLmsg
saveInstallPath args flags (pkg,lbi)
installWeb (pkg,lbi)
gfPostCopy args flags pkg lbi = do
-- noRGLmsg
saveCopyPath args flags (pkg,lbi)
copyWeb flags (pkg,lbi)
-- `cabal sdist` will not make a proper dist archive, for that see `make sdist`
-- However this function should exit quietly to allow building gf in sandbox
gfSDist pkg lbi hooks flags = do
return ()
saveInstallPath :: [String] -> InstallFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
saveInstallPath args flags bi = do
let
dest = NoCopyDest
dir = datadir (uncurry absoluteInstallDirs bi dest)
writeFile dataDirFile dir
saveCopyPath :: [String] -> CopyFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
saveCopyPath args flags bi = do
let
dest = case copyDest flags of
NoFlag -> NoCopyDest
Flag d -> d
dir = datadir (uncurry absoluteInstallDirs bi dest)
writeFile dataDirFile dir
-- | Name of file where installation's data directory is recording
-- This is a last-resort way in which the seprate RGL build script
-- can determine where to put the compiled RGL files
dataDirFile :: String
dataDirFile = "DATA_DIR"
-- | Get path to locally-built gf
default_gf :: LocalBuildInfo -> FilePath
default_gf lbi = buildDir lbi </> exeName' </> exeNameReal
where
-- shadows Distribution.Simple.BuildPaths.exeExtension, which changed type signature in Cabal 2.4
exeExtension = case hostPlatform lbi of
Platform arch Windows -> "exe"
_ -> ""
exeName' = "gf"
exeNameReal = exeName' <.> exeExtension

146
src/compiler/WebSetup.hs Normal file
View File

@@ -0,0 +1,146 @@
module WebSetup(buildWeb,installWeb,copyWeb,numJobs,execute) where
import System.Directory(createDirectoryIfMissing,copyFile,doesDirectoryExist,doesFileExist)
import System.FilePath((</>),dropExtension)
import System.Process(rawSystem)
import System.Exit(ExitCode(..))
import Distribution.Simple.Setup(BuildFlags(..),Flag(..),CopyFlags(..),CopyDest(..),copyDest)
import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..),datadir,buildDir,absoluteInstallDirs)
import Distribution.PackageDescription(PackageDescription(..))
{-
To test the GF web services, the minibar and the grammar editor, use
"cabal install" (or "runhaskell Setup.hs install") to install gf as usual.
Then start the server with the command "gf -server" and open
http://localhost:41296/ in your web browser (Firefox, Safari, Opera or
Chrome). The example grammars listed below will be available in the minibar.
-}
{-
Update 2018-07-04
The example grammars have now been removed from the GF repository.
This script will look for them in ../gf-contrib and build them from there if possible.
If not, the user will be given a message and nothing is build or copied.
(Unfortunately cabal install seems to hide all messages from stdout,
so users won't see this message unless they check the log.)
-}
-- | Notice about contrib grammars
noContribMsg :: IO ()
noContribMsg = putStr $ unlines
[ "Example grammars are no longer included in the main GF repository, but have moved to gf-contrib."
, "If you want them to be built, clone the following repository in the same directory as gf-core:"
, "https://github.com/GrammaticalFramework/gf-contrib.git"
]
example_grammars :: [(String, String, [String])] -- [(pgf, subdir, source modules)]
example_grammars =
[("Letter.pgf","letter",letterSrc)
,("Foods.pgf","foods",foodsSrc)
,("Phrasebook.pgf","phrasebook",phrasebookSrc)
]
where
foodsSrc = ["Foods"++lang++".gf"|lang<-foodsLangs]
foodsLangs = words "Afr Amh Bul Cat Cze Dut Eng Epo Fin Fre Ger Gle Heb Hin Ice Ita Jpn Lav Mlt Mon Nep Pes Por Ron Spa Swe Tha Tsn Tur Urd"
phrasebookSrc = ["Phrasebook"++lang++".gf"|lang<-phrasebookLangs]
phrasebookLangs = words "Bul Cat Chi Dan Dut Eng Lav Hin Nor Spa Swe Tha" -- only fastish languages
letterSrc = ["Letter"++lang++".gf"|lang<-letterLangs]
letterLangs = words "Eng Fin Fre Heb Rus Swe"
contrib_dir :: FilePath
contrib_dir = ".."</>"gf-contrib"
buildWeb :: String -> BuildFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
buildWeb gf flags (pkg,lbi) = do
contrib_exists <- doesDirectoryExist contrib_dir
if contrib_exists
then mapM_ build_pgf example_grammars
-- else noContribMsg
else return ()
where
gfo_dir = buildDir lbi </> "examples"
build_pgf :: (String, String, [String]) -> IO Bool
build_pgf (pgf,subdir,src) =
do createDirectoryIfMissing True tmp_dir
putStrLn $ "Building "++pgf
execute gf args
where
tmp_dir = gfo_dir</>subdir
dir = contrib_dir</>subdir
dest = NoCopyDest
gf_lib_path = datadir (absoluteInstallDirs pkg lbi dest) </> "lib"
args = numJobs flags++["-make","-s"] -- ,"-optimize-pgf"
++["--gfo-dir="++tmp_dir,
--"--gf-lib-path="++gf_lib_path,
"--name="++dropExtension pgf,
"--output-dir="++gfo_dir]
++[dir</>file|file<-src]
installWeb :: (PackageDescription, LocalBuildInfo) -> IO ()
installWeb = setupWeb NoCopyDest
copyWeb :: CopyFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
copyWeb flags = setupWeb dest
where
dest = case copyDest flags of
NoFlag -> NoCopyDest
Flag d -> d
setupWeb :: CopyDest -> (PackageDescription, LocalBuildInfo) -> IO ()
setupWeb dest (pkg,lbi) = do
mapM_ (createDirectoryIfMissing True) [grammars_dir,cloud_dir]
contrib_exists <- doesDirectoryExist contrib_dir
if contrib_exists
then mapM_ copy_pgf example_grammars
else return () -- message already displayed from buildWeb
copyGFLogo
where
grammars_dir = www_dir </> "grammars"
cloud_dir = www_dir </> "tmp" -- hmm
logo_dir = www_dir </> "Logos"
www_dir = datadir (absoluteInstallDirs pkg lbi dest) </> "www"
gfo_dir = buildDir lbi </> "examples"
copy_pgf :: (String, String, [String]) -> IO ()
copy_pgf (pgf,subdir,_) =
do let src = gfo_dir </> pgf
let dst = grammars_dir </> pgf
ex <- doesFileExist src
if ex then do putStrLn $ "Installing "++dst
copyFile src dst
else putStrLn $ "Not installing "++dst
gf_logo = "gf0.png"
copyGFLogo =
do createDirectoryIfMissing True logo_dir
copyFile (".."</>".."</>"doc"</>"Logos"</>gf_logo) (logo_dir</>gf_logo)
-- | Run an arbitrary system command, returning False on failure
execute :: String -> [String] -> IO Bool
execute command args =
do let cmdline = command ++ " " ++ unwords (map showArg args)
e <- rawSystem command args
case e of
ExitSuccess -> return True
ExitFailure i -> do putStrLn $ "Ran: " ++ cmdline
putStrLn $ command++" exited with exit code: " ++ show i
return False
where
showArg arg = if ' ' `elem` arg then "'" ++ arg ++ "'" else arg
-- | This function is used to enable parallel compilation of the RGL and example grammars
numJobs :: BuildFlags -> [String]
numJobs flags =
if null n
then ["-j","+RTS","-A20M","-N","-RTS"]
else ["-j="++n,"+RTS","-A20M","-N"++n,"-RTS"]
where
-- buildNumJobs is only available in Cabal>=1.20
n = case buildNumJobs flags of
Flag mn | mn/=Just 1-> maybe "" show mn
_ -> ""

5
src/compiler/gf-main.hs Normal file
View File

@@ -0,0 +1,5 @@
module Main where
import qualified GF
main = GF.main

255
src/compiler/gf.cabal Normal file
View File

@@ -0,0 +1,255 @@
name: gf
version: 3.11.0-git
cabal-version: 1.22
build-type: Custom
license: OtherLicense
license-file: LICENSE
category: Natural Language Processing, Compiler
synopsis: Grammatical Framework
description: GF, Grammatical Framework, is a programming language for multilingual grammar applications
maintainer: John J. Camilleri <john@digitalgrammars.com>
homepage: https://www.grammaticalframework.org/
bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4, GHC==9.0.2
data-files:
www/*.html
www/*.css
www/P/*.png
www/gfse/*.html
www/gfse/*.css
www/gfse/*.js
www/gfse/P/*.png
www/gfse/P/*.jpg
www/js/*.js
www/minibar/*.html
www/minibar/*.css
www/minibar/*.js
www/minibar/*.png
www/syntax-editor/*.html
www/syntax-editor/*.css
www/syntax-editor/*.js
www/TransQuiz/*.html
www/TransQuiz/*.css
www/TransQuiz/*.js
www/TransQuiz/*.png
www/translator/*.html
www/translator/*.css
www/translator/*.js
custom-setup
setup-depends:
base >= 4.9.1 && < 4.16,
Cabal >= 1.22.0.0,
directory >= 1.3.0 && < 1.4,
filepath >= 1.4.1 && < 1.5,
process >= 1.0.1.1 && < 1.7
source-repository head
type: git
location: https://github.com/GrammaticalFramework/gf-core.git
flag interrupt
Description: Enable Ctrl+Break in the shell
Default: True
flag server
Description: Include --server mode
Default: True
flag network-uri
description: Get Network.URI from the network-uri package
default: True
executable gf
main-is: gf-main.hs
default-language: Haskell2010
build-depends: pgf2,
base >= 4.6 && <5,
array,
containers,
bytestring,
utf8-string,
random,
pretty,
mtl,
exceptions,
ghc-prim,
filepath, directory>=1.2, time,
process, haskeline, parallel>=3, json
ghc-options: -threaded
other-modules:
GF
GF.Support
GF.Text.Pretty
GF.Text.Lexing
GF.Grammar.Canonical
GF.Main GF.Compiler GF.Interactive
GF.Compile GF.CompileInParallel GF.CompileOne GF.Compile.GetGrammar
GF.Grammar
GF.Data.Operations GF.Infra.Option GF.Infra.UseIO
GF.Command.Abstract
GF.Command.CommandInfo
GF.Command.Commands
GF.Command.CommonCommands
GF.Command.SourceCommands
GF.Command.Help
GF.Command.Importing
GF.Command.Interpreter
GF.Command.Messages
GF.Command.Parse
GF.Command.TreeOperations
GF.Compile.CFGtoPGF
GF.Compile.CheckGrammar
GF.Compile.Compute.Concrete
GF.Compile.ExampleBased
GF.Compile.Export
GF.Compile.GenerateBC
GF.Compile.GeneratePMCFG
GF.Compile.GrammarToPGF
GF.Compile.Multi
GF.Compile.OptimizePGF
GF.Compile.PGFtoHaskell
GF.Compile.PGFtoJava
GF.Haskell
GF.Compile.ConcreteToHaskell
GF.Compile.GrammarToCanonical
GF.Grammar.CanonicalJSON
GF.Compile.ReadFiles
GF.Compile.Rename
GF.Compile.SubExOpt
GF.Compile.Tags
GF.Compile.ToAPI
GF.Compile.TypeCheck.Abstract
GF.Compile.TypeCheck.Concrete
GF.Compile.TypeCheck.ConcreteNew
GF.Compile.TypeCheck.Primitives
GF.Compile.TypeCheck.TC
GF.Compile.Update
GF.Data.BacktrackM
GF.Data.ErrM
GF.Data.Graph
GF.Data.Graphviz
GF.Data.Relation
GF.Data.Str
GF.Data.Utilities
GF.Data.XML
GF.Grammar.Analyse
GF.Grammar.Binary
GF.Grammar.CFG
GF.Grammar.EBNF
GF.Grammar.BNFC
GF.Grammar.Grammar
GF.Grammar.Lexer
GF.Grammar.Lockfield
GF.Grammar.Lookup
GF.Grammar.Macros
GF.Grammar.Parser
GF.Grammar.PatternMatch
GF.Grammar.Predef
GF.Grammar.Printer
GF.Grammar.ShowTerm
GF.Grammar.Unify
GF.Grammar.Values
GF.Infra.BuildInfo
GF.Infra.CheckM
GF.Infra.Concurrency
GF.Infra.Dependencies
GF.Infra.GetOpt
GF.Infra.Ident
GF.Infra.Location
GF.Infra.SIO
GF.Infra.Cache
GF.JavaScript.AbsJS
GF.JavaScript.PrintJS
GF.Quiz
GF.Speech.CFGToFA
GF.Speech.FiniteState
GF.Speech.GSL
GF.Speech.JSGF
GF.Speech.PGFToCFG
GF.Speech.PrRegExp
GF.Speech.RegExp
GF.Speech.SISR
GF.Speech.SLF
GF.Speech.SRG
GF.Speech.SRGS_ABNF
GF.Speech.SRGS_XML
GF.Speech.VoiceXML
GF.System.Catch
GF.System.Concurrency
GF.System.Console
GF.System.Directory
GF.System.Process
GF.System.Signal
GF.System.NoSignal
GF.Text.Clitics
GF.Text.Coding
GF.Text.Lexing
GF.Text.Transliterations
Paths_gf
-- not really part of GF but I have changed the original binary library
-- and we have to keep the copy for now.
Data.Binary
Data.Binary.Put
Data.Binary.Get
Data.Binary.Builder
Data.Binary.IEEE754
if os(windows)
build-depends:
Win32 >= 2.3.1.1 && < 2.7
else
build-depends:
terminfo >=0.4.0 && < 0.5,
unix >= 2.7.2 && < 2.8
if flag(server)
build-depends:
cgi >= 3001.3.0.2 && < 3001.6,
httpd-shed >= 0.4.0 && < 0.5,
network>=2.3 && <3.2
if flag(network-uri)
build-depends:
network-uri >= 2.6.1.0 && < 2.7,
network>=2.6 && <3.2
else
build-depends:
network >= 2.5 && <3.2
cpp-options: -DSERVER_MODE
other-modules:
GF.Server
GF.Server.PGFService
GF.Server.RunHTTP
GF.Server.SimpleEditor.Convert
GF.Server.SimpleEditor.JSON
GF.Server.SimpleEditor.Syntax
GF.Server.URLEncoding
GF.Server.CGI
GF.Server.CGIUtils
if flag(interrupt)
cpp-options: -DUSE_INTERRUPT
other-modules: GF.System.UseSignal
else
other-modules: GF.System.NoSignal
test-suite gf-tests
type: exitcode-stdio-1.0
main-is: run.hs
hs-source-dirs: testsuite
build-depends:
base >= 4.9.1 && < 4.16,
Cabal >= 1.8,
directory >= 1.3.0 && < 1.4,
filepath >= 1.4.1 && < 1.5,
process >= 1.4.3 && < 1.7
build-tool-depends: gf:gf
default-language: Haskell2010

1
src/compiler/testsuite/canonical/.gitignore vendored Normal file
View File

@@ -0,0 +1 @@
canonical/

102
src/compiler/testsuite/canonical/gold/FoodsFin.gf Normal file
View File

@@ -0,0 +1,102 @@
concrete FoodsFin of Foods = {
param ParamX_Number = ParamX_Sg | ParamX_Pl;
param Prelude_Bool = Prelude_False | Prelude_True;
param ResFin_Agr = ResFin_Ag ParamX_Number ParamX_Person | ResFin_AgPol;
param ParamX_Person = ParamX_P1 | ParamX_P2 | ParamX_P3;
param ResFin_Harmony = ResFin_Back | ResFin_Front;
param ResFin_NForm =
ResFin_NCase ParamX_Number ResFin_Case | ResFin_NComit | ResFin_NInstruct |
ResFin_NPossNom ParamX_Number | ResFin_NPossGen ParamX_Number |
ResFin_NPossTransl ParamX_Number | ResFin_NPossIllat ParamX_Number |
ResFin_NCompound;
param ResFin_Case =
ResFin_Nom | ResFin_Gen | ResFin_Part | ResFin_Transl | ResFin_Ess |
ResFin_Iness | ResFin_Elat | ResFin_Illat | ResFin_Adess | ResFin_Ablat |
ResFin_Allat | ResFin_Abess;
param ResFin_NPForm = ResFin_NPCase ResFin_Case | ResFin_NPAcc | ResFin_NPSep;
lincat Comment = {s : Str};
Item =
{s : ResFin_NPForm => Str; a : ResFin_Agr; isNeg : Prelude_Bool;
isPron : Prelude_Bool};
Kind =
{s : ResFin_NForm => Str; h : ResFin_Harmony;
postmod : ParamX_Number => Str};
Quality =
{s : Prelude_Bool => ResFin_NForm => Str; hasPrefix : Prelude_Bool;
p : Str};
lin Expensive =
{s =
table {Prelude_False =>
table {ResFin_NCase ParamX_Sg ResFin_Nom => "kallis";
ResFin_NCase ParamX_Sg ResFin_Gen => "kalliin";
ResFin_NCase ParamX_Sg ResFin_Part => "kallista";
ResFin_NCase ParamX_Sg ResFin_Transl => "kalliiksi";
ResFin_NCase ParamX_Sg ResFin_Ess => "kalliina";
ResFin_NCase ParamX_Sg ResFin_Iness => "kalliissa";
ResFin_NCase ParamX_Sg ResFin_Elat => "kalliista";
ResFin_NCase ParamX_Sg ResFin_Illat => "kalliiseen";
ResFin_NCase ParamX_Sg ResFin_Adess => "kalliilla";
ResFin_NCase ParamX_Sg ResFin_Ablat => "kalliilta";
ResFin_NCase ParamX_Sg ResFin_Allat => "kalliille";
ResFin_NCase ParamX_Sg ResFin_Abess => "kalliitta";
ResFin_NCase ParamX_Pl ResFin_Nom => "kalliit";
ResFin_NCase ParamX_Pl ResFin_Gen => "kalliiden";
ResFin_NCase ParamX_Pl ResFin_Part => "kalliita";
ResFin_NCase ParamX_Pl ResFin_Transl => "kalliiksi";
ResFin_NCase ParamX_Pl ResFin_Ess => "kalliina";
ResFin_NCase ParamX_Pl ResFin_Iness => "kalliissa";
ResFin_NCase ParamX_Pl ResFin_Elat => "kalliista";
ResFin_NCase ParamX_Pl ResFin_Illat => "kalliisiin";
ResFin_NCase ParamX_Pl ResFin_Adess => "kalliilla";
ResFin_NCase ParamX_Pl ResFin_Ablat => "kalliilta";
ResFin_NCase ParamX_Pl ResFin_Allat => "kalliille";
ResFin_NCase ParamX_Pl ResFin_Abess => "kalliitta";
ResFin_NComit => "kalliine";
ResFin_NInstruct => "kalliin";
ResFin_NPossNom ParamX_Sg => "kallii";
ResFin_NPossNom ParamX_Pl => "kallii";
ResFin_NPossGen ParamX_Sg => "kallii";
ResFin_NPossGen ParamX_Pl => "kalliide";
ResFin_NPossTransl ParamX_Sg => "kalliikse";
ResFin_NPossTransl ParamX_Pl => "kalliikse";
ResFin_NPossIllat ParamX_Sg => "kalliisee";
ResFin_NPossIllat ParamX_Pl => "kalliisii";
ResFin_NCompound => "kallis"};
Prelude_True =>
table {ResFin_NCase ParamX_Sg ResFin_Nom => "kallis";
ResFin_NCase ParamX_Sg ResFin_Gen => "kalliin";
ResFin_NCase ParamX_Sg ResFin_Part => "kallista";
ResFin_NCase ParamX_Sg ResFin_Transl => "kalliiksi";
ResFin_NCase ParamX_Sg ResFin_Ess => "kalliina";
ResFin_NCase ParamX_Sg ResFin_Iness => "kalliissa";
ResFin_NCase ParamX_Sg ResFin_Elat => "kalliista";
ResFin_NCase ParamX_Sg ResFin_Illat => "kalliiseen";
ResFin_NCase ParamX_Sg ResFin_Adess => "kalliilla";
ResFin_NCase ParamX_Sg ResFin_Ablat => "kalliilta";
ResFin_NCase ParamX_Sg ResFin_Allat => "kalliille";
ResFin_NCase ParamX_Sg ResFin_Abess => "kalliitta";
ResFin_NCase ParamX_Pl ResFin_Nom => "kalliit";
ResFin_NCase ParamX_Pl ResFin_Gen => "kalliiden";
ResFin_NCase ParamX_Pl ResFin_Part => "kalliita";
ResFin_NCase ParamX_Pl ResFin_Transl => "kalliiksi";
ResFin_NCase ParamX_Pl ResFin_Ess => "kalliina";
ResFin_NCase ParamX_Pl ResFin_Iness => "kalliissa";
ResFin_NCase ParamX_Pl ResFin_Elat => "kalliista";
ResFin_NCase ParamX_Pl ResFin_Illat => "kalliisiin";
ResFin_NCase ParamX_Pl ResFin_Adess => "kalliilla";
ResFin_NCase ParamX_Pl ResFin_Ablat => "kalliilta";
ResFin_NCase ParamX_Pl ResFin_Allat => "kalliille";
ResFin_NCase ParamX_Pl ResFin_Abess => "kalliitta";
ResFin_NComit => "kalliine";
ResFin_NInstruct => "kalliin";
ResFin_NPossNom ParamX_Sg => "kallii";
ResFin_NPossNom ParamX_Pl => "kallii";
ResFin_NPossGen ParamX_Sg => "kallii";
ResFin_NPossGen ParamX_Pl => "kalliide";
ResFin_NPossTransl ParamX_Sg => "kalliikse";
ResFin_NPossTransl ParamX_Pl => "kalliikse";
ResFin_NPossIllat ParamX_Sg => "kalliisee";
ResFin_NPossIllat ParamX_Pl => "kalliisii";
ResFin_NCompound => "kallis"}};
hasPrefix = Prelude_False; p = ""};
}

29
src/compiler/testsuite/canonical/gold/PhrasebookBul.gf Normal file
View File

@@ -0,0 +1,29 @@
concrete PhrasebookBul of Phrasebook = {
param Prelude_Bool = Prelude_False | Prelude_True;
param ResBul_AGender = ResBul_AMasc ResBul_Animacy | ResBul_AFem | ResBul_ANeut;
param ResBul_Animacy = ResBul_Human | ResBul_NonHuman;
param ResBul_Case = ResBul_Acc | ResBul_Dat | ResBul_WithPrep | ResBul_CPrep;
param ResBul_NForm =
ResBul_NF ParamX_Number ResBul_Species | ResBul_NFSgDefNom |
ResBul_NFPlCount | ResBul_NFVocative;
param ParamX_Number = ParamX_Sg | ParamX_Pl;
param ResBul_Species = ResBul_Indef | ResBul_Def;
lincat PlaceKind =
{at : {s : Str; c : ResBul_Case}; isPl : Prelude_Bool;
name : {s : ResBul_NForm => Str; g : ResBul_AGender};
to : {s : Str; c : ResBul_Case}};
VerbPhrase = {s : Str};
lin Airport =
{at = {s = "на"; c = ResBul_Acc}; isPl = Prelude_False;
name =
{s =
table {ResBul_NF ParamX_Sg ResBul_Indef => "летище";
ResBul_NF ParamX_Sg ResBul_Def => "летището";
ResBul_NF ParamX_Pl ResBul_Indef => "летища";
ResBul_NF ParamX_Pl ResBul_Def => "летищата";
ResBul_NFSgDefNom => "летището";
ResBul_NFPlCount => "летища";
ResBul_NFVocative => "летище"};
g = ResBul_ANeut};
to = {s = "до"; c = ResBul_CPrep}};
}

251
src/compiler/testsuite/canonical/gold/PhrasebookGer.gf Normal file
View File

@@ -0,0 +1,251 @@
concrete PhrasebookGer of Phrasebook = {
param Prelude_Bool = Prelude_False | Prelude_True;
param ResGer_Agr = ResGer_Ag ResGer_Gender ParamX_Number ParamX_Person;
param ParamX_Number = ParamX_Sg | ParamX_Pl;
param ParamX_Person = ParamX_P1 | ParamX_P2 | ParamX_P3;
param ResGer_Gender = ResGer_Masc | ResGer_Fem | ResGer_Neutr;
param ResGer_Control = ResGer_SubjC | ResGer_ObjC | ResGer_NoC;
param ResGer_PCase = ResGer_NPC ResGer_Case | ResGer_NPP ResGer_CPrep;
param ResGer_CPrep =
ResGer_CAnDat | ResGer_CInAcc | ResGer_CInDat | ResGer_CZuDat |
ResGer_CVonDat;
param ResGer_Case = ResGer_Nom | ResGer_Acc | ResGer_Dat | ResGer_Gen;
param ResGer_VAux = ResGer_VHaben | ResGer_VSein;
param ResGer_VForm =
ResGer_VInf Prelude_Bool | ResGer_VFin Prelude_Bool ResGer_VFormFin |
ResGer_VImper ParamX_Number | ResGer_VPresPart ResGer_AForm |
ResGer_VPastPart ResGer_AForm;
param ResGer_AForm = ResGer_APred | ResGer_AMod ResGer_GenNum ResGer_Case;
param ResGer_GenNum = ResGer_GSg ResGer_Gender | ResGer_GPl;
param ResGer_VFormFin =
ResGer_VPresInd ParamX_Number ParamX_Person |
ResGer_VPresSubj ParamX_Number ParamX_Person;
param ResGer_VType = ResGer_VAct | ResGer_VRefl ResGer_Case;
lincat PlaceKind = {s : Str};
VerbPhrase =
{s :
{s : ResGer_VForm => Str; aux : ResGer_VAux; particle : Str;
prefix : Str; vtype : ResGer_VType};
a1 : Str; a2 : Str; adj : Str; ext : Str;
inf : {s : Str; ctrl : ResGer_Control; isAux : Prelude_Bool};
infExt : Str; isAux : Prelude_Bool;
nn :
ResGer_Agr =>
{p1 : Str; p2 : Str; p3 : Str; p4 : Str; p5 : Str; p6 : Str};
subjc :
{s : Str; c : ResGer_PCase; isPrep : Prelude_Bool; s2 : Str}};
lin VRead =
{s =
{s =
table {ResGer_VInf Prelude_False => "lesen";
ResGer_VInf Prelude_True => "zu" ++ "lesen";
ResGer_VFin Prelude_False
(ResGer_VPresInd ParamX_Sg ParamX_P1) =>
"lese";
ResGer_VFin Prelude_False
(ResGer_VPresInd ParamX_Sg ParamX_P2) =>
"liest";
ResGer_VFin Prelude_False
(ResGer_VPresInd ParamX_Sg ParamX_P3) =>
"liest";
ResGer_VFin Prelude_False
(ResGer_VPresInd ParamX_Pl ParamX_P1) =>
"lesen";
ResGer_VFin Prelude_False
(ResGer_VPresInd ParamX_Pl ParamX_P2) =>
"lest";
ResGer_VFin Prelude_False
(ResGer_VPresInd ParamX_Pl ParamX_P3) =>
"lesen";
ResGer_VFin Prelude_False
(ResGer_VPresSubj ParamX_Sg ParamX_P1) =>
"lese";
ResGer_VFin Prelude_False
(ResGer_VPresSubj ParamX_Sg ParamX_P2) =>
"lesest";
ResGer_VFin Prelude_False
(ResGer_VPresSubj ParamX_Sg ParamX_P3) =>
"lese";
ResGer_VFin Prelude_False
(ResGer_VPresSubj ParamX_Pl ParamX_P1) =>
"lesen";
ResGer_VFin Prelude_False
(ResGer_VPresSubj ParamX_Pl ParamX_P2) =>
"leset";
ResGer_VFin Prelude_False
(ResGer_VPresSubj ParamX_Pl ParamX_P3) =>
"lesen";
ResGer_VFin Prelude_True
(ResGer_VPresInd ParamX_Sg ParamX_P1) =>
"lese";
ResGer_VFin Prelude_True
(ResGer_VPresInd ParamX_Sg ParamX_P2) =>
"liest";
ResGer_VFin Prelude_True
(ResGer_VPresInd ParamX_Sg ParamX_P3) =>
"liest";
ResGer_VFin Prelude_True
(ResGer_VPresInd ParamX_Pl ParamX_P1) =>
"lesen";
ResGer_VFin Prelude_True
(ResGer_VPresInd ParamX_Pl ParamX_P2) =>
"lest";
ResGer_VFin Prelude_True
(ResGer_VPresInd ParamX_Pl ParamX_P3) =>
"lesen";
ResGer_VFin Prelude_True
(ResGer_VPresSubj ParamX_Sg ParamX_P1) =>
"lese";
ResGer_VFin Prelude_True
(ResGer_VPresSubj ParamX_Sg ParamX_P2) =>
"lesest";
ResGer_VFin Prelude_True
(ResGer_VPresSubj ParamX_Sg ParamX_P3) =>
"lese";
ResGer_VFin Prelude_True
(ResGer_VPresSubj ParamX_Pl ParamX_P1) =>
"lesen";
ResGer_VFin Prelude_True
(ResGer_VPresSubj ParamX_Pl ParamX_P2) =>
"leset";
ResGer_VFin Prelude_True
(ResGer_VPresSubj ParamX_Pl ParamX_P3) =>
"lesen";
ResGer_VImper ParamX_Sg => "les";
ResGer_VImper ParamX_Pl => "lest";
ResGer_VPresPart ResGer_APred => "lesend";
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
ResGer_Nom) =>
"lesender";
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
ResGer_Acc) =>
"lesenden";
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
ResGer_Dat) =>
"lesendem";
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
ResGer_Gen) =>
"lesenden";
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
ResGer_Nom) =>
"lesende";
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
ResGer_Acc) =>
"lesende";
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
ResGer_Dat) =>
"lesender";
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
ResGer_Gen) =>
"lesender";
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
ResGer_Nom) =>
"lesendes";
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
ResGer_Acc) =>
"lesendes";
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
ResGer_Dat) =>
"lesendem";
ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
ResGer_Gen) =>
"lesenden";
ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Nom) =>
"lesende";
ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Acc) =>
"lesende";
ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Dat) =>
"lesenden";
ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Gen) =>
"lesender";
ResGer_VPastPart ResGer_APred => "gelesen";
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
ResGer_Nom) =>
"gelesener";
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
ResGer_Acc) =>
"gelesenen";
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
ResGer_Dat) =>
"gelesenem";
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
ResGer_Gen) =>
"gelesenen";
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
ResGer_Nom) =>
"gelesene";
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
ResGer_Acc) =>
"gelesene";
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
ResGer_Dat) =>
"gelesener";
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
ResGer_Gen) =>
"gelesener";
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
ResGer_Nom) =>
"gelesenes";
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
ResGer_Acc) =>
"gelesenes";
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
ResGer_Dat) =>
"gelesenem";
ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
ResGer_Gen) =>
"gelesenen";
ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Nom) =>
"gelesene";
ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Acc) =>
"gelesene";
ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Dat) =>
"gelesenen";
ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Gen) =>
"gelesener"};
aux = ResGer_VHaben; particle = ""; prefix = "";
vtype = ResGer_VAct};
a1 = ""; a2 = ""; adj = ""; ext = "";
inf = {s = ""; ctrl = ResGer_NoC; isAux = Prelude_True}; infExt = "";
isAux = Prelude_False;
nn =
table {ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P1 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P2 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P3 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P1 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P2 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P3 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P1 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P2 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P3 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P1 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P2 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P3 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P1 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P2 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P3 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P1 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P2 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P3 =>
{p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}};
subjc =
{s = ""; c = ResGer_NPC ResGer_Nom; isPrep = Prelude_False;
s2 = ""}};
}

16
src/compiler/testsuite/canonical/grammars/Foods.gf Normal file
View File

@@ -0,0 +1,16 @@
-- (c) 2009 Aarne Ranta under LGPL
abstract Foods = {
flags startcat = Comment ;
cat
Comment ; Item ; Kind ; Quality ;
fun
-- Pred : Item -> Quality -> Comment ;
-- This, That, These, Those : Kind -> Item ;
-- Mod : Quality -> Kind -> Kind ;
-- Wine, Cheese, Fish, Pizza : Kind ;
-- Very : Quality -> Quality ;
-- Fresh, Warm, Italian,
-- Expensive, Delicious, Boring : Quality ;
Expensive: Quality;
}

6
src/compiler/testsuite/canonical/grammars/FoodsFin.gf Normal file
View File

@@ -0,0 +1,6 @@
-- (c) 2009 Aarne Ranta under LGPL
concrete FoodsFin of Foods = FoodsI with
(Syntax = SyntaxFin),
(LexFoods = LexFoodsFin) ;

29
src/compiler/testsuite/canonical/grammars/FoodsI.gf Normal file
View File

@@ -0,0 +1,29 @@
-- (c) 2009 Aarne Ranta under LGPL
incomplete concrete FoodsI of Foods =
open Syntax, LexFoods in {
lincat
Comment = Utt ;
Item = NP ;
Kind = CN ;
Quality = AP ;
lin
Pred item quality = mkUtt (mkCl item quality) ;
This kind = mkNP this_Det kind ;
That kind = mkNP that_Det kind ;
These kind = mkNP these_Det kind ;
Those kind = mkNP those_Det kind ;
Mod quality kind = mkCN quality kind ;
Very quality = mkAP very_AdA quality ;
Wine = mkCN wine_N ;
Pizza = mkCN pizza_N ;
Cheese = mkCN cheese_N ;
Fish = mkCN fish_N ;
Fresh = mkAP fresh_A ;
Warm = mkAP warm_A ;
Italian = mkAP italian_A ;
Expensive = mkAP expensive_A ;
Delicious = mkAP delicious_A ;
Boring = mkAP boring_A ;
}

15
src/compiler/testsuite/canonical/grammars/LexFoods.gf Normal file
View File

@@ -0,0 +1,15 @@
-- (c) 2009 Aarne Ranta under LGPL
interface LexFoods = open Syntax in {
oper
wine_N : N ;
pizza_N : N ;
cheese_N : N ;
fish_N : N ;
fresh_A : A ;
warm_A : A ;
italian_A : A ;
expensive_A : A ;
delicious_A : A ;
boring_A : A ;
}

21
src/compiler/testsuite/canonical/grammars/LexFoodsFin.gf Normal file
View File

@@ -0,0 +1,21 @@
-- (c) 2009 Aarne Ranta under LGPL
--# -coding=latin1
instance LexFoodsFin of LexFoods =
open SyntaxFin, ParadigmsFin in {
oper
wine_N = mkN "viini" ;
pizza_N = mkN "pizza" ;
cheese_N = mkN "juusto" ;
fish_N = mkN "kala" ;
fresh_A = mkA "tuore" ;
warm_A = mkA
(mkN "l<>mmin" "l<>mpim<69>n" "l<>mmint<6E>" "l<>mpim<69>n<EFBFBD>" "l<>mpim<69><6D>n"
"l<>mpimin<69>" "l<>mpimi<6D>" "l<>mpimien" "l<>mpimiss<73>" "l<>mpimiin"
)
"l<>mpim<69>mpi" "l<>mpimin" ;
italian_A = mkA "italialainen" ;
expensive_A = mkA "kallis" ;
delicious_A = mkA "herkullinen" ;
boring_A = mkA "tyls<6C>" ;
}

9
src/compiler/testsuite/canonical/grammars/Phrasebook.gf Normal file
View File

@@ -0,0 +1,9 @@
abstract Phrasebook = {
cat PlaceKind ;
fun Airport : PlaceKind ;
cat VerbPhrase ;
fun VRead : VerbPhrase ;
}

31
src/compiler/testsuite/canonical/grammars/PhrasebookBul.gf Normal file
View File

@@ -0,0 +1,31 @@
--# -path=.:present
concrete PhrasebookBul of Phrasebook =
open
SyntaxBul,
(R = ResBul),
ParadigmsBul,
Prelude in {
lincat
PlaceKind = CNPlace ;
oper
CNPlace : Type = {name : CN ; at : Prep ; to : Prep; isPl : Bool} ;
mkPlace : N -> Prep -> {name : CN ; at : Prep ; to : Prep; isPl : Bool} = \n,p ->
mkCNPlace (mkCN n) p to_Prep ;
mkCNPlace : CN -> Prep -> Prep -> CNPlace = \p,i,t -> {
name = p ;
at = i ;
to = t ;
isPl = False
} ;
na_Prep = mkPrep "на" R.Acc ;
lin
Airport = mkPlace (mkN066 "летище") na_Prep ;
}

14
src/compiler/testsuite/canonical/grammars/PhrasebookGer.gf Normal file
View File

@@ -0,0 +1,14 @@
--# -path=.:present
concrete PhrasebookGer of Phrasebook =
open
SyntaxGer,
LexiconGer in {
lincat
VerbPhrase = VP ;
lin
VRead = mkVP <lin V read_V2 : V> ;
}

36
src/compiler/testsuite/canonical/run-on-grammar.sh Executable file
View File

@@ -0,0 +1,36 @@
#!/usr/bin/env sh
# For a given grammar, compile into canonical format,
# then ensure that the canonical format itself is compilable.
if [ $# -lt 1 ]; then
echo "Please specify concrete modules to test with, e.g.:"
echo "./run-on-grammar.sh ../../../gf-contrib/foods/FoodsEng.gf ../../../gf-contrib/foods/FoodsFin.gf"
exit 2
fi
FAILURES=0
for CNC_PATH in "$@"; do
CNC_FILE=$(basename "$CNC_PATH")
stack run -- --batch --output-format=canonical_gf "$CNC_PATH"
if [ $? -ne 0 ]; then
echo "Failed to compile into canonical"
FAILURES=$((FAILURES+1))
continue
fi
stack run -- --batch "canonical/$CNC_FILE"
if [ $? -ne 0 ]; then
echo "Failed to compile canonical"
FAILURES=$((FAILURES+1))
fi
done
# Summary
if [ $FAILURES -ne 0 ]; then
echo "Failures: $FAILURES"
exit 1
else
echo "All tests passed"
fi

54
src/compiler/testsuite/canonical/run.sh Executable file
View File

@@ -0,0 +1,54 @@
#!/usr/bin/env sh
FAILURES=0
# https://github.com/GrammaticalFramework/gf-core/issues/100
stack run -- --batch --output-format=canonical_gf grammars/PhrasebookBul.gf
stack run -- --batch canonical/PhrasebookBul.gf
if [ $? -ne 0 ]; then
echo "Canonical grammar doesn't compile: FAIL"
FAILURES=$((FAILURES+1))
else
# echo "Canonical grammar compiles: OK"
diff canonical/PhrasebookBul.gf gold/PhrasebookBul.gf
if [ $? -ne 0 ]; then
echo "Canonical grammar doesn't match gold version: FAIL"
FAILURES=$((FAILURES+1))
else
echo "Canonical grammar matches gold version: OK"
fi
fi
echo ""
# https://github.com/GrammaticalFramework/gf-core/issues/101
stack run -- --batch --output-format=canonical_gf grammars/PhrasebookGer.gf
diff canonical/PhrasebookGer.gf gold/PhrasebookGer.gf
if [ $? -ne 0 ]; then
echo "Canonical grammar doesn't match gold version: FAIL"
FAILURES=$((FAILURES+1))
else
echo "Canonical grammar matches gold version: OK"
fi
echo ""
# https://github.com/GrammaticalFramework/gf-core/issues/102
stack run -- --batch --output-format=canonical_gf grammars/FoodsFin.gf
diff canonical/FoodsFin.gf gold/FoodsFin.gf
if [ $? -ne 0 ]; then
echo "Canonical grammar doesn't match gold version: FAIL"
FAILURES=$((FAILURES+1))
else
echo "Canonical grammar matches gold version: OK"
fi
echo ""
# Summary
if [ $FAILURES -ne 0 ]; then
echo "Failures: $FAILURES"
exit 1
else
echo "All tests passed"
fi

13
src/compiler/testsuite/compiler/check/abstract-operations/Nat.gf Normal file
View File

@@ -0,0 +1,13 @@
abstract Nat = {
cat Nat ;
data zero : Nat ;
succ : Nat -> Nat ;
oper plus : Nat -> Nat -> Nat ;
def plus zero y = y ;
plus (succ x) y = succ (plus x y) ;
oper twice : Nat -> Nat = \x -> plus x x ;
}

5
src/compiler/testsuite/compiler/check/abstract-operations/abstract-operations.gfs Normal file
View File

@@ -0,0 +1,5 @@
-- here we test that the abstract operations are not used for proof search
i testsuite/compiler/check/abstract-operations/Nat.gf
gt -cat=Nat -number=11 -depth=10
pt -compute (twice (succ zero))

14
src/compiler/testsuite/compiler/check/abstract-operations/abstract-operations.gfs.gold Normal file
View File

@@ -0,0 +1,14 @@
succ (succ (succ (succ (succ (succ (succ (succ (succ (succ zero)))))))))
succ (succ (succ (succ (succ (succ (succ (succ (succ zero))))))))
succ (succ (succ (succ (succ (succ (succ (succ zero)))))))
succ (succ (succ (succ (succ (succ (succ zero))))))
succ (succ (succ (succ (succ (succ zero)))))
succ (succ (succ (succ (succ zero))))
succ (succ (succ (succ zero)))
succ (succ (succ zero))
succ (succ zero)
succ zero
zero
succ (succ zero)

7
src/compiler/testsuite/compiler/check/cyclic/abs-types/Test1Abs.gf Normal file
View File

@@ -0,0 +1,7 @@
abstract Test1Abs = {
cat
A B ;
B A ;
}

10
src/compiler/testsuite/compiler/check/cyclic/abs-types/Test2Abs.gf Normal file
View File

@@ -0,0 +1,10 @@
abstract Test2Abs = {
cat
A ;
B A ;
fun f : (x : A) -> B (g x) ;
g : (x : A) -> B (f x) ;
}

11
src/compiler/testsuite/compiler/check/cyclic/abs-types/Test3Abs.gf Normal file
View File

@@ -0,0 +1,11 @@
abstract Test3Abs = {
cat A ;
fun f : A -> A ;
def f = g ;
fun g : A -> A ;
def g = f ;
}

1
src/compiler/testsuite/compiler/check/cyclic/abs-types/test1.gfs Normal file
View File

@@ -0,0 +1 @@
i -src testsuite/compiler/check/cyclic/abs-types/Test1Abs.gf

4
src/compiler/testsuite/compiler/check/cyclic/abs-types/test1.gfs.gold Normal file
View File

@@ -0,0 +1,4 @@
testsuite/compiler/check/cyclic/abs-types/Test1Abs.gf:
circular definitions: A B

1
src/compiler/testsuite/compiler/check/cyclic/abs-types/test2.gfs Normal file
View File

@@ -0,0 +1 @@
i -src testsuite/compiler/check/cyclic/abs-types/Test2Abs.gf

4
src/compiler/testsuite/compiler/check/cyclic/abs-types/test2.gfs.gold Normal file
View File

@@ -0,0 +1,4 @@
testsuite/compiler/check/cyclic/abs-types/Test2Abs.gf:
circular definitions: f g

1
src/compiler/testsuite/compiler/check/cyclic/abs-types/test3.gfs Normal file
View File

@@ -0,0 +1 @@
i -src testsuite/compiler/check/cyclic/abs-types/Test3Abs.gf

0
src/compiler/testsuite/compiler/check/cyclic/abs-types/test3.gfs.gold Normal file
View File

10
src/compiler/testsuite/compiler/check/cyclic/opers/TestOperTypes.gf Normal file
View File

@@ -0,0 +1,10 @@
resource TestOperTypes = {
flags
optimize=noexpand;
oper
A : T = Str ;
T : Type = A ;
}

10
src/compiler/testsuite/compiler/check/cyclic/opers/TestOpers.gf Normal file
View File

@@ -0,0 +1,10 @@
resource TestOpers = {
flags
optimize=noexpand;
oper
A : Str = B ;
B : Str = A ;
}

2
src/compiler/testsuite/compiler/check/cyclic/opers/test.gfs Normal file
View File

@@ -0,0 +1,2 @@
i -src testsuite/compiler/check/cyclic/opers/TestOpers.gf
i -src testsuite/compiler/check/cyclic/opers/TestOperTypes.gf

8
src/compiler/testsuite/compiler/check/cyclic/opers/test.gfs.gold Normal file
View File

@@ -0,0 +1,8 @@
testsuite/compiler/check/cyclic/opers/TestOpers.gf:
circular definitions: A B
testsuite/compiler/check/cyclic/opers/TestOperTypes.gf:
circular definitions: A T

7
src/compiler/testsuite/compiler/check/cyclic/params/TestParams.gf Normal file
View File

@@ -0,0 +1,7 @@
resource TestParams = {
param
A = A1 B ;
B = B1 A ;
}

1
src/compiler/testsuite/compiler/check/cyclic/params/test.gfs Normal file
View File

@@ -0,0 +1 @@
i -src testsuite/compiler/check/cyclic/params/TestParams.gf

4
src/compiler/testsuite/compiler/check/cyclic/params/test.gfs.gold Normal file
View File

@@ -0,0 +1,4 @@
testsuite/compiler/check/cyclic/params/TestParams.gf:
circular definitions: A B

48
src/compiler/testsuite/compiler/check/lincat-types/Predef.gf Normal file
View File

@@ -0,0 +1,48 @@
--1 Predefined functions for concrete syntax
-- The definitions of these constants are hard-coded in GF, and defined
-- in Predef.hs (gf-core/src/compiler/GF/Compile/Compute/Predef.hs).
-- Applying them to run-time variables leads to compiler errors that are
-- often only detected at the code generation time.
resource Predef = {
-- This type of booleans is for internal use only.
param PBool = PTrue | PFalse ;
oper Error : Type = variants {} ; -- the empty type
oper Float : Type = variants {} ; -- the type of floats
oper Int : Type = variants {} ; -- the type of integers
oper Ints : Int -> PType = variants {} ; -- the type of integers from 0 to n
oper error : Str -> Error = variants {} ; -- forms error message
oper length : Tok -> Int = variants {} ; -- length of string
oper drop : Int -> Tok -> Tok = variants {} ; -- drop prefix of length
oper take : Int -> Tok -> Tok = variants {} ; -- take prefix of length
oper tk : Int -> Tok -> Tok = variants {} ; -- drop suffix of length
oper dp : Int -> Tok -> Tok = variants {} ; -- take suffix of length
oper eqInt : Int -> Int -> PBool = variants {} ; -- test if equal integers
oper lessInt: Int -> Int -> PBool = variants {} ; -- test order of integers
oper plus : Int -> Int -> Int = variants {} ; -- add integers
oper eqStr : Tok -> Tok -> PBool = variants {} ; -- test if equal strings
oper occur : Tok -> Tok -> PBool = variants {} ; -- test if occurs as substring
oper occurs : Tok -> Tok -> PBool = variants {} ; -- test if any char occurs
oper isUpper : Tok -> PBool = variants {} ; -- test if all chars are upper-case
oper toUpper : Tok -> Tok = variants {} ; -- map all chars to upper case
oper toLower : Tok -> Tok = variants {} ; -- map all chars to lower case
oper show : (P : Type) -> P -> Tok = variants {} ; -- convert param to string
oper read : (P : Type) -> Tok -> P = variants {} ; -- convert string to param
oper eqVal : (P : Type) -> P -> P -> PBool = variants {} ; -- test if equal values
oper toStr : (L : Type) -> L -> Str = variants {} ; -- find the "first" string
oper mapStr : (L : Type) -> (Str -> Str) -> L -> L = variants {} ;
-- map all strings in a data structure; experimental ---
oper nonExist : Str = variants {} ; -- a placeholder for non-existant morphological forms
oper BIND : Str = variants {} ; -- a token for gluing
oper SOFT_BIND : Str = variants {} ; -- a token for soft gluing
oper SOFT_SPACE : Str = variants {} ; -- a token for soft space
oper CAPIT : Str = variants {} ; -- a token for capitalization
oper ALL_CAPIT : Str = variants {} ; -- a token for capitalization of abreviations
} ;

5
src/compiler/testsuite/compiler/check/lincat-types/Test.gf Normal file
View File

@@ -0,0 +1,5 @@
abstract Test = {
cat S;
}

5
src/compiler/testsuite/compiler/check/lincat-types/TestCnc.gf Normal file
View File

@@ -0,0 +1,5 @@
concrete TestCnc of Test = open Predef in {
lincat S = PTrue ;
}

1
src/compiler/testsuite/compiler/check/lincat-types/test.gfs Normal file
View File

@@ -0,0 +1 @@
i -src testsuite/compiler/check/lincat-types/TestCnc.gf

9
src/compiler/testsuite/compiler/check/lincat-types/test.gfs.gold Normal file
View File

@@ -0,0 +1,9 @@
testsuite/compiler/check/lincat-types/TestCnc.gf:
testsuite/compiler/check/lincat-types/TestCnc.gf:3:
Happened in linearization type of S
type of PTrue
expected: Type
inferred: Predef.PBool

9
src/compiler/testsuite/compiler/check/lins/lins.gf Normal file
View File

@@ -0,0 +1,9 @@
abstract lins = {
cat Nat ;
cat C Nat ;
fun zero : Nat ;
test : C zero ;
}

2
src/compiler/testsuite/compiler/check/lins/lins.gfs Normal file
View File

@@ -0,0 +1,2 @@
i -src testsuite/compiler/check/lins/linsCnc.gf
pg -printer=pgf_pretty

41
src/compiler/testsuite/compiler/check/lins/lins.gfs.gold Normal file
View File

@@ -0,0 +1,41 @@
abstract lins {
cat C Nat ;
cat Float ;
cat Int ;
cat Nat ;
cat String ;
fun test : C zero ;
fun zero : Nat ;
}
concrete linsCnc {
productions
C1 -> F4[]
lindefs
C0 -> F0[CVar]
C1 -> F2[CVar]
linrefs
CVar -> F1[C0]
CVar -> F3[C1]
lin
F0 := (S2) ['lindef C']
F1 := (S1) ['lindef C']
F2 := () ['lindef Nat']
F3 := (S0) ['lindef Nat']
F4 := () [zero]
sequences
S0 :=
S1 := <0,0>
S2 := {0,0}
categories
C := range [C0 .. C0]
labels ["s"]
Float := range [CFloat .. CFloat]
labels ["s"]
Int := range [CInt .. CInt]
labels ["s"]
Nat := range [C1 .. C1]
labels []
String := range [CString .. CString]
labels ["s"]
printnames
}

11
src/compiler/testsuite/compiler/check/lins/linsCnc.gf Normal file
View File

@@ -0,0 +1,11 @@
concrete linsCnc of lins = {
lincat Nat = {} ;
-- we expect warnings because the lines bellow are commented out
-- we don't expect warning for zero because Nat = {}
-- lincat C = {s : Str} ;
-- lin test = {s = "test"} ;
}

5
src/compiler/testsuite/compiler/check/oper-definition/Res.gf Normal file
View File

@@ -0,0 +1,5 @@
resource Res = {
oper my_oper : Str -> Str ;
}

1
src/compiler/testsuite/compiler/check/oper-definition/test.gfs Normal file
View File

@@ -0,0 +1 @@
i testsuite/compiler/check/oper-definition/Res.gf

6
src/compiler/testsuite/compiler/check/oper-definition/test.gfs.gold Normal file
View File

@@ -0,0 +1,6 @@
testsuite/compiler/check/oper-definition/Res.gf:
testsuite/compiler/check/oper-definition/Res.gf:3:
Happened in operation my_oper
No definition given to the operation

5
src/compiler/testsuite/compiler/check/params/Params.gf Normal file
View File

@@ -0,0 +1,5 @@
resource Params = {
param P = P1 Str ;
}

8
src/compiler/testsuite/compiler/check/restricted-inheritance/A.gf Normal file
View File

@@ -0,0 +1,8 @@
abstract A = {
cat A1; A2 ;
fun f1 : A1 ;
f2 : A1 ;
g : A2 ;
}

3
src/compiler/testsuite/compiler/check/restricted-inheritance/B.gf Normal file
View File

@@ -0,0 +1,3 @@
abstract B = A - [A1] ** {
}

161
src/compiler/testsuite/compiler/check/strMatch/Prelude.gf Normal file
View File

@@ -0,0 +1,161 @@
--1 The GF Prelude
-- This file defines some prelude facilities usable in all grammars.
resource Prelude = Predef[nonExist, BIND, SOFT_BIND, SOFT_SPACE, CAPIT, ALL_CAPIT] ** open (Predef=Predef) in {
oper
--2 Strings, records, and tables
SS : Type = {s : Str} ;
ss : Str -> SS = \s -> {s = s} ;
ss2 : (_,_ : Str) -> SS = \x,y -> ss (x ++ y) ;
ss3 : (_,_ ,_: Str) -> SS = \x,y,z -> ss (x ++ y ++ z) ;
cc2 : (_,_ : SS) -> SS = \x,y -> ss (x.s ++ y.s) ;
cc3 : (_,_,_ : SS) -> SS = \x,y,z -> ss (x.s ++ y.s ++ z.s) ;
SS1 : PType -> Type = \P -> {s : P => Str} ;
ss1 : (A : PType) -> Str -> SS1 A = \A,s -> {s = table {_ => s}} ;
SP1 : Type -> Type = \P -> {s : Str ; p : P} ;
sp1 : (A : Type) -> Str -> A -> SP1 A = \_,s,a -> {s = s ; p = a} ;
constTable : (A : PType) -> (B : Type) -> B -> A => B = \u,v,b -> \\_ => b ;
constStr : (A : PType) -> Str -> A => Str = \A -> constTable A Str ;
-- Discontinuous constituents.
SD2 : Type = {s1,s2 : Str} ;
sd2 : (_,_ : Str) -> SD2 = \x,y -> {s1 = x ; s2 = y} ;
--2 Optional elements
-- Optional string with preference on the string vs. empty.
optStr : Str -> Str = \s -> variants {s ; []} ;
strOpt : Str -> Str = \s -> variants {[] ; s} ;
-- Free order between two strings.
bothWays : Str -> Str -> Str = \x,y -> variants {x ++ y ; y ++ x} ;
-- Parametric order between two strings.
preOrPost : Bool -> Str -> Str -> Str = \pr,x,y ->
if_then_Str pr (x ++ y) (y ++ x) ;
--2 Infixes. prefixes, and postfixes
-- Fixes with precedences are defined in [Precedence Precedence.html].
infixSS : Str -> SS -> SS -> SS = \f,x,y -> ss (x.s ++ f ++ y.s) ;
prefixSS : Str -> SS -> SS = \f,x -> ss (f ++ x.s) ;
postfixSS : Str -> SS -> SS = \f,x -> ss (x.s ++ f) ;
embedSS : Str -> Str -> SS -> SS = \f,g,x -> ss (f ++ x.s ++ g) ;
--2 Booleans
param Bool = False | True ;
oper
if_then_else : (A : Type) -> Bool -> A -> A -> A = \_,c,d,e ->
case c of {
True => d ; ---- should not need to qualify
False => e
} ;
andB : (_,_ : Bool) -> Bool = \a,b -> if_then_else Bool a b False ;
orB : (_,_ : Bool) -> Bool = \a,b -> if_then_else Bool a True b ;
notB : Bool -> Bool = \a -> if_then_else Bool a False True ;
if_then_Str : Bool -> Str -> Str -> Str = if_then_else Str ;
onlyIf : Bool -> Str -> Str = \b,s -> case b of {
True => s ;
_ => nonExist
} ;
-- Interface to internal booleans
pbool2bool : Predef.PBool -> Bool = \b -> case b of {
Predef.PFalse => False ; Predef.PTrue => True
} ;
init : Tok -> Tok = Predef.tk 1 ;
last : Tok -> Tok = Predef.dp 1 ;
--2 High-level acces to Predef operations
isNil : Tok -> Bool = \b -> pbool2bool (Predef.eqStr [] b) ;
ifTok : (A : Type) -> Tok -> Tok -> A -> A -> A = \A,t,u,a,b ->
case Predef.eqStr t u of {Predef.PTrue => a ; Predef.PFalse => b} ;
--2 Lexer-related operations
-- Bind together two tokens in some lexers, either obligatorily or optionally
oper
glue : Str -> Str -> Str = \x,y -> x ++ BIND ++ y ;
glueOpt : Str -> Str -> Str = \x,y -> variants {glue x y ; x ++ y} ;
noglueOpt : Str -> Str -> Str = \x,y -> variants {x ++ y ; glue x y} ;
-- Force capitalization of next word in some unlexers
capitalize : Str -> Str = \s -> CAPIT ++ s ;
-- These should be hidden, and never changed since they are hardcoded in (un)lexers
PARA : Str = "&-" ;
-- Embed between commas, where the latter one disappears in front of other punctuation
embedInCommas : Str -> Str = \s -> bindComma ++ s ++ endComma ;
endComma : Str = pre {"," | "." => []; "" => bindComma ; _ => []} ;
bindComma : Str = SOFT_BIND ++ "," ;
optComma : Str = bindComma | [] ;
optCommaSS : SS -> SS = \s -> ss (s.s ++ optComma) ;
--2 Miscellaneous
-- Identity function
id : (A : Type) -> A -> A = \_,a -> a ;
-- Parentheses
paren : Str -> Str = \s -> "(" ++ s ++ ")" ;
parenss : SS -> SS = \s -> ss (paren s.s) ;
-- Zero, one, two, or more (elements in a list etc)
param
ENumber = E0 | E1 | E2 | Emore ;
oper
eNext : ENumber -> ENumber = \e -> case e of {
E0 => E1 ; E1 => E2 ; _ => Emore} ;
-- convert initial to upper/lower
toUpperFirst : Str -> Str = \s -> case s of {
x@? + xs => Predef.toUpper x + xs ;
_ => s
} ;
toLowerFirst : Str -> Str = \s -> case s of {
x@? + xs => Predef.toLower x + xs ;
_ => s
} ;
-- handling errors caused by temporarily missing definitions
notYet : Str -> Predef.Error = \s ->
Predef.error ("NOT YET IMPLEMENTED:" ++ s) ;
}

5
src/compiler/testsuite/compiler/check/strMatch/strMatch.gf Normal file
View File

@@ -0,0 +1,5 @@
abstract strMatch = {
cat S ;
fun f : S -> S ;
z : S ;
}

2
src/compiler/testsuite/compiler/check/strMatch/strMatch.gfs Normal file
View File

@@ -0,0 +1,2 @@
i testsuite/compiler/check/strMatch/strMatch.gf
l f z

1
src/compiler/testsuite/compiler/check/strMatch/strMatch.gfs.gold Normal file
View File

@@ -0,0 +1 @@

8
src/compiler/testsuite/compiler/check/strMatch/strMatchCnc.gf Normal file
View File

@@ -0,0 +1,8 @@
concrete strMatchCnc of strMatch = open Prelude in {
lincat S = {s : Str; b : Bool} ;
lin f x = case x.s of {
"" => {s="empty"; b=False} ;
_ => x
} ;
lin z = {s=""; b=False} ;
}

3
src/compiler/testsuite/compiler/compute/lambda.gfs Normal file
View File

@@ -0,0 +1,3 @@
i -retain prelude/Predef.gfo
cc <\x,x -> x : Str -> Str -> Str>
cc <\x -> (<\y,x->y : Str -> Str -> Str>) x : Str -> Str -> Str>

2
src/compiler/testsuite/compiler/compute/lambda.gfs.gold Normal file
View File

@@ -0,0 +1,2 @@
\x,x_1 -> x_1
\x,x_1 -> x

14
src/compiler/testsuite/compiler/compute/param_table.gf Normal file
View File

@@ -0,0 +1,14 @@
resource param_table = {
param Q = Q1 | Q2 ;
param P = P1 | P2 Q ;
oper ab_patt = #["ab"];
oper test : Str -> Q = \s ->
case s of {
#ab_patt + _ => Q1 ;
_ => Q2
} ;
}

17
src/compiler/testsuite/compiler/compute/param_table.gfs Normal file
View File

@@ -0,0 +1,17 @@
i -retain testsuite/compiler/compute/param_table.gf
cc P2 Q1
cc table {P1 => "p1"; P2 _ => "p2"} ! P1
cc table {P1 => "p1"; P2 _ => "p2"} ! P2 Q1
cc table {P1 => "p1"; P2 _ => "p2"} ! P2 (Q1|Q2)
cc table {P1 => "p1"; P2 q => "p2"} ! P2 (Q1|Q2)
cc table P ["p1"; "p2q1"; "p2q2"] ! P1
cc table P ["p1"; "p2q1"; "p2q2"] ! P2 Q1
cc table P ["p1"; "p2q1"; "p2q2"] ! P2 Q2
cc table {P1 => "p1"; P2 Q1 => "p2q1"; P2 Q2 => "p2q2"} ! P2 (Q1|Q2)
cc table {P1 => "p1"; P2 Q1 => "p2q1"; P2 Q2 => "p2q2"} ! P2 Q1
cc table {P1 => "p1"; P2 q => case q of {Q1 => "p2q1"; Q2 => "p2q2"}} ! P2 Q1
cc case <Q1,Q2> of {<Q1,Q1> => "11"; <Q1,Q2> => "12"; _ => "??"}
cc case <Q2,Q2> of {<Q1,Q1> => "11"; <Q1,Q2> => "12"; _ => "??"}
cc <\x -> case x of {Q1 => "q1"; Q2 => "q2"} : Q -> Str>
cc <\x -> case P2 x of {P1 => "p1"; P2 q => "p2"} : Q -> Str>
cc <\x -> case P2 x of {P1 => "p1"; P2 q => case q of {Q1 => "q"+"1"; Q2 => "q"+"2"}} : Q -> Str>

22
src/compiler/testsuite/compiler/compute/param_table.gfs.gold Normal file
View File

@@ -0,0 +1,22 @@
param_table.P2 param_table.Q1
"p1"
"p2"
"p2"
"p2"
"p1"
"p2q1"
"p2q2"
variants {"p2q1"; "p2q2"}
"p2q1"
"p2q1"
"12"
"??"
\x -> case <x : param_table.Q> of {
param_table.Q1 => "q1";
param_table.Q2 => "q2"
}
\x -> "p2"
\x -> case <x : param_table.Q> of {
param_table.Q1 => "q1";
param_table.Q2 => "q2"
}

47
src/compiler/testsuite/compiler/compute/predef.gfs Normal file
View File

@@ -0,0 +1,47 @@
i -retain prelude/Predef.gfo
cc length "abcd"
cc length ("ab"++"cd")
cc length nonExist
cc <\x -> length x : Str -> Int>
cc take 2 "abcd"
cc drop 2 "abcd"
cc tk 1 "abcd"
cc dp 1 "abcd"
cc toUpper "abcd"
cc toLower "ABCD"
cc isUpper "abcd"
cc isUpper "ABCD"
cc isUpper "AbCd"
cc case isUpper "abcd" of {PTrue => "yes"; PFalse => "no"}
cc case isUpper "ABCD" of {PTrue => "yes"; PFalse => "no"}
cc case isUpper "AbCd" of {PTrue => "yes"; PFalse => "no"}
cc eqStr "ab cd" ("ab"++"cd")
cc occur "bc" "abcd"
cc occur "bc" "acbd"
cc occurs "bc" "xxxxbxxx"
cc occurs "bc" "xxxxcxxx"
cc occurs "bc" "xxxxxxxx"
cc eqInt (length "abcd") 4
cc lessInt (length "abcd") 3
cc lessInt (length "abcd") 5
cc plus (length "abcd") 1
cc error "user error"++"!"
cc "x"++nonExist++"y"
cc "x"++BIND++"y"
cc "x"++SOFT_BIND++"y"
cc "x"++SOFT_SPACE++"y"
cc "x"++CAPIT++"y"
cc "x"++ALL_CAPIT++"y"
cc "a"+"b"
cc <\x->x+"b" : Str -> Str>
cc eqInt (length ("a"+"b")) 2
cc take 10 ("aa"++BIND++"bb")
cc take 10 ("aa"++CAPIT++BIND++"bb")
cc take 10 ("aa"++BIND++CAPIT++"bb")
cc take 10 ("aa"++ALL_CAPIT++BIND++"bb")
cc take 10 ("aa"++BIND++ALL_CAPIT++"bb")
cc take 10 ("aa"++nonExist++"bb")
cc take 10 (pre {"b"=>"B"; _=>"X"})
cc take 10 ("aa"++pre {"b"=>"B"; _=>"X"})
cc take 10 ("aa"++pre {"b"=>"B"; _=>"X"}++"cc")
cc take 10 ("aa"++pre {"b"=>"B"; _=>"X"}++"bb")

46
src/compiler/testsuite/compiler/compute/predef.gfs.gold Normal file
View File

@@ -0,0 +1,46 @@
4
5
Predef.length Predef.nonExist
\x -> Predef.length x
"ab"
"cd"
"abc"
"d"
"ABCD"
"abcd"
Predef.PFalse
Predef.PTrue
Predef.PFalse
"no"
"yes"
"no"
Predef.PTrue
Predef.PTrue
Predef.PFalse
Predef.PTrue
Predef.PTrue
Predef.PFalse
Predef.PTrue
Predef.PFalse
Predef.PTrue
5
user error
"x" ++ Predef.nonExist ++ "y"
"x" ++ Predef.BIND ++ "y"
"x" ++ Predef.SOFT_BIND ++ "y"
"x" ++ Predef.SOFT_SPACE ++ "y"
"x" ++ Predef.CAPIT ++ "y"
"x" ++ Predef.ALL_CAPIT ++ "y"
"ab"
\x -> x + "b"
Predef.PTrue
"aabb"
"aaBb"
"aaBb"
"aaBB"
"aaBB"
Predef.nonExist
"X"
"aa" ++ "X"
"aa" ++ "X" ++ "cc"
"aa" ++ "B" ++ "bb"

12
src/compiler/testsuite/compiler/compute/record.gf Normal file
View File

@@ -0,0 +1,12 @@
resource record = {
param P = A;
oper
hello = id "hello";
-- Id should be an identity function for Str
--id : Str -> Str = \ s -> s ;
id : Str -> Str = \ s -> ({a=s}**f r).a;
f : { b:Str } -> { b:Str } = \ x -> x;
r : { a:P; b:Str} = {a=A;b="b"};
}

10
src/compiler/testsuite/compiler/compute/record.gfs Normal file
View File

@@ -0,0 +1,10 @@
i -retain testsuite/compiler/compute/record.gf
cc hello
cc {x="x"; y="y"}.x
cc {x="x"; y="y"}.y
cc <\r -> r.x : {x:Str; y:Str} -> Str>
cc <{x="x"; y="y"} ** {z="z"} : {x,y,z:Str}>
cc <{x="x"; y="y"} ** {y="y'"} : {x,y:Str}>
cc <\r -> r ** {y="y'"} : {x,y:Str} -> {y:Str}>
cc <\r -> r ** {y="y'"} : {x,y:Str} -> {x,y:Str}>
cc <\r -> f r ** {b="b"} : {b:Str} -> {b:Str}>

9
src/compiler/testsuite/compiler/compute/record.gfs.gold Normal file
View File

@@ -0,0 +1,9 @@
"hello"
"x"
"y"
\r -> r.x
{x = "x"; y = "y"; z = "z"}
{x = "x"; y = "y'"}
\r -> {y = "y'"}
\r -> {x = r.x; y = "y'"}
\r -> {b = "b"}

30
src/compiler/testsuite/compiler/compute/string_matching.gfs Normal file
View File

@@ -0,0 +1,30 @@
i -retain testsuite/compiler/compute/param_table.gf
cc "a b c"
cc case "abc" of {"abc" => Q1; _ => Q2}
cc case "def" of {"abc" => Q1; _ => Q2}
cc case "x" of {? => Q1; _ => Q2}
cc case "xy" of {? => Q1; _ => Q2}
cc case "x" of {["abc"] => Q1; _ => Q2}
cc case "b" of {["abc"] => Q1; _ => Q2}
cc case "xy" of {["abc"] => Q1; _ => Q2}
cc case "abc" of {"abc"|"xyz" => Q1; _ => Q2}
cc case "xyz" of {"abc"|"xyz" => Q1; _ => Q2}
cc case "def" of {"abc"|"xyz" => Q1; _ => Q2}
cc case <<"start","abc","end"> : Str*Str*Str> of {<s,m@("abc"|"xyz"),e> => s++m++e; _ => "zero"}
cc case <<"start","xyz","end"> : Str*Str*Str> of {<s,m@("abc"|"xyz"),e> => s++m++e; _ => "zero"}
cc case <<"start","def","end"> : Str*Str*Str> of {<s,m@("abc"|"xyz"),e> => s++m++e; _ => "zero"}
cc <case "abcdefghi" of {"abc"+x+"ghi" => x; _ => "?"} : Str>
cc <case "abcdef" of {"abc"+x+"ghi" => x; _ => "?"} : Str>
cc <case "defghi" of {"abc"+x+"ghi" => x; _ => "?"} : Str>
cc <case "abc def ghi" of {"ab"+x+"hi" => x; _ => "?"} : Str>
cc <case "abc def ghi" of {"ab"+x => x; _ => "?"} : Str>
cc <case "abc def ghi" of {x+"hi" => x; _ => "?"} : Str>
cc <case "abcdefghi" of {""+x => x; _ => "?"} : Str>
cc <case "abcdefghi" of {x+"" => x; _ => "?"} : Str>
cc <case "aaaaxy" of {"a"* + x => x; _ => "?"} : Str>
cc <case "xybbbbb" of {x + "b"* => x; _ => "?"} : Str>
cc <case "xyababbbab" of {x + #ab_patt* => x; _ => "?"} : Str>
cc test "abcd"
cc test "xyz"
cc <\x -> case x of {"q1" => Q1; _ => Q2} : Str -> Q>
cc pre {"в"|"ф"=>"във"; _=>"в"}

32
src/compiler/testsuite/compiler/compute/string_matching.gfs.gold Normal file
View File

@@ -0,0 +1,32 @@
"a" ++ "b" ++ "c"
param_table.Q1
param_table.Q2
param_table.Q1
param_table.Q2
param_table.Q2
param_table.Q1
param_table.Q2
param_table.Q1
param_table.Q1
param_table.Q2
"start" ++ "abc" ++ "end"
"start" ++ "xyz" ++ "end"
"zero"
"def"
"?"
"?"
"c" ++ "def" ++ "g"
"c" ++ "def" ++ "ghi"
"abc" ++ "def" ++ "g"
"abcdefghi"
"abcdefghi"
"aaaaxy"
"xy"
"xy"
param_table.Q1
param_table.Q2
\x -> case <x : Str> of {
"q1" => param_table.Q1;
_ => param_table.Q2
}
pre {"в"; "във" / strs {"в"; "ф"}}

7
src/compiler/testsuite/compiler/compute/variant.gf Normal file
View File

@@ -0,0 +1,7 @@
resource variant = {
oper
hello = r.f "hello";
r = { f:Str->Str = (id|dup) };
id : Str->Str = \ s -> s;
dup : Str->Str = \ s -> s++s;
}

12
src/compiler/testsuite/compiler/compute/variant.gfs Normal file
View File

@@ -0,0 +1,12 @@
i -retain testsuite/compiler/compute/variant.gf
cc hello
cc <\x -> x++x : Str -> Str> ("a"|"b")
cc <\x -> x : Str -> Str> ("a"|"b")
cc <\x -> "c" : Str -> Str> ("a"|"b")
cc <let x = ("a"|"b") in x++x : Str>
cc <let x = ("a"|"b") in x : Str>
cc <let x = ("a"|"b") in "c" : Str>
cc <\x -> x.p1++x.p1 : Str*Str -> Str> <"a"|"b","c">
cc <\x -> x.p1 : Str*Str -> Str> <"a"|"b","c">
cc <\x -> x.p2++x.p2 : Str*Str -> Str> <"a"|"b","c">
cc <\x -> x.p2 : Str*Str -> Str> <"a"|"b","c">

11
src/compiler/testsuite/compiler/compute/variant.gfs.gold Normal file
View File

@@ -0,0 +1,11 @@
variants {"hello"; "hello" ++ "hello"}
variants {"a" ++ "a"; "b" ++ "b"}
variants {"a"; "b"}
"c"
variants {"a" ++ "a"; "b" ++ "b"}
variants {"a"; "b"}
"c"
variants {"a" ++ "a"; "b" ++ "b"}
variants {"a"; "b"}
"c" ++ "c"
"c"

7
src/compiler/testsuite/compiler/params/params.gf Normal file
View File

@@ -0,0 +1,7 @@
abstract params = {
cat S; NP ;
fun test : NP -> S ;
}

1
src/compiler/testsuite/compiler/params/params.gfs Normal file
View File

@@ -0,0 +1 @@
i testsuite/compiler/params/paramsCnc.gf

0
src/compiler/testsuite/compiler/params/params.gfs.gold Normal file
View File

20
src/compiler/testsuite/compiler/params/paramsCnc.gf Normal file
View File

@@ -0,0 +1,20 @@
concrete paramsCnc of params = {
param
Number = Sg | Pl ;
Person = P1 | P2 | P3 ;
oper
Agr = {n : Number; p : Person} ;
param
Case = Nom | Acc | Abess Agr ;
lincat
S = {s : Str} ;
NP = {s : Case => Str} ;
lin
test np = {s = np.s ! Abess {n=Sg;p=P3}} ;
}

14
src/compiler/testsuite/compiler/renamer/funpatt.gf Normal file
View File

@@ -0,0 +1,14 @@
abstract funpatt = {
-- this should raise error
-- we cannot pattern match on functions
cat D ;
fun D1 : Int -> D ;
D2 : Int -> D ;
fun d : D -> Int ;
def d (D1 _) = 1 ;
d (D2 _) = 2 ;
}

1
src/compiler/testsuite/compiler/renamer/funpatt.gfs Normal file
View File

@@ -0,0 +1 @@
i -src testsuite/compiler/renamer/funpatt.gf

Some files were not shown because too many files have changed in this diff Show More