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

src/compiler/GF/Infra/Cache.hs

@@ -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'))

src/compiler/GF/Server.hs

@@ -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"

src/compiler/GF/Server/CGI.hs

@@ -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)

src/compiler/GF/Server/CGIUtils.hs

@@ -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

src/compiler/GF/Server/LICENSE

@@ -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.

src/compiler/GF/Server/PGFService.hs

@@ -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

src/compiler/GF/Server/RunHTTP.hs

@@ -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" []

src/compiler/GF/Server/ServeStaticFile.hs

@@ -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"

src/compiler/GF/Server/Setup.hs

@@ -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 ()

src/compiler/GF/Server/SimpleEditor/Convert.hs

@@ -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) =

src/compiler/GF/Server/SimpleEditor/JSON.hs

@@ -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

src/compiler/GF/Server/SimpleEditor/Syntax.hs

@@ -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

src/compiler/GF/Server/URLEncoding.hs

@@ -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)

src/compiler/GF/Server/exec/pgf-fcgi.hs

@@ -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

src/compiler/GF/Server/exec/pgf-http.hs

@@ -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

src/compiler/GF/Server/gf-server-jsapi.js

@@ -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+")");
+};

src/compiler/GF/Server/lighttpd.conf

@@ -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

src/compiler/GF/Server/simple-client.html

@@ -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>

src/compiler/GF/Server/transfer/Fold.hs

@@ -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

src/compiler/GF/Server/translator.css

@@ -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;
+}
+

src/compiler/GF/Server/translator.js

@@ -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);
+  }
+}

src/compiler/LICENSE

@@ -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.

src/compiler/Setup.hs

@@ -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

src/compiler/WebSetup.hs

@@ -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
+          _ -> ""

src/compiler/gf-main.hs

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

src/compiler/gf.cabal

@@ -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

src/compiler/testsuite/canonical/.gitignore

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

src/compiler/testsuite/canonical/gold/FoodsFin.gf

@@ -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 = ""};
+}

src/compiler/testsuite/canonical/gold/PhrasebookBul.gf

@@ -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}};
+}

src/compiler/testsuite/canonical/gold/PhrasebookGer.gf

@@ -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 = ""}};
+}

src/compiler/testsuite/canonical/grammars/Foods.gf

@@ -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;
+}

src/compiler/testsuite/canonical/grammars/FoodsFin.gf

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

src/compiler/testsuite/canonical/grammars/FoodsI.gf

@@ -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 ;
+}

src/compiler/testsuite/canonical/grammars/LexFoods.gf

@@ -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 ;
+}

src/compiler/testsuite/canonical/grammars/LexFoodsFin.gf

@@ -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>" ;
+}

src/compiler/testsuite/canonical/grammars/Phrasebook.gf

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

src/compiler/testsuite/canonical/grammars/PhrasebookBul.gf

@@ -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 ;
+
+}

src/compiler/testsuite/canonical/grammars/PhrasebookGer.gf

@@ -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> ;
+
+}

src/compiler/testsuite/canonical/run-on-grammar.sh

@@ -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

src/compiler/testsuite/canonical/run.sh

@@ -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

src/compiler/testsuite/compiler/check/abstract-operations/Nat.gf

@@ -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 ;
+
+}

src/compiler/testsuite/compiler/check/abstract-operations/abstract-operations.gfs

@@ -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))

src/compiler/testsuite/compiler/check/abstract-operations/abstract-operations.gfs.gold

@@ -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)
+

src/compiler/testsuite/compiler/check/cyclic/abs-types/Test1Abs.gf

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

src/compiler/testsuite/compiler/check/cyclic/abs-types/Test2Abs.gf

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

src/compiler/testsuite/compiler/check/cyclic/abs-types/Test3Abs.gf

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

src/compiler/testsuite/compiler/check/cyclic/abs-types/test1.gfs

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

src/compiler/testsuite/compiler/check/cyclic/abs-types/test1.gfs.gold

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

src/compiler/testsuite/compiler/check/cyclic/abs-types/test2.gfs

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

src/compiler/testsuite/compiler/check/cyclic/abs-types/test2.gfs.gold

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

src/compiler/testsuite/compiler/check/cyclic/abs-types/test3.gfs

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

src/compiler/testsuite/compiler/check/cyclic/opers/TestOperTypes.gf

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

src/compiler/testsuite/compiler/check/cyclic/opers/TestOpers.gf

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

src/compiler/testsuite/compiler/check/cyclic/opers/test.gfs

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

src/compiler/testsuite/compiler/check/cyclic/opers/test.gfs.gold

@@ -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

src/compiler/testsuite/compiler/check/cyclic/params/TestParams.gf

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

src/compiler/testsuite/compiler/check/cyclic/params/test.gfs

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

src/compiler/testsuite/compiler/check/cyclic/params/test.gfs.gold

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

src/compiler/testsuite/compiler/check/lincat-types/Predef.gf

@@ -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
+
+} ;

src/compiler/testsuite/compiler/check/lincat-types/Test.gf

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

src/compiler/testsuite/compiler/check/lincat-types/TestCnc.gf

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

src/compiler/testsuite/compiler/check/lincat-types/test.gfs

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

src/compiler/testsuite/compiler/check/lincat-types/test.gfs.gold

@@ -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
+      

src/compiler/testsuite/compiler/check/lins/lins.gf

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

src/compiler/testsuite/compiler/check/lins/lins.gfs

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

src/compiler/testsuite/compiler/check/lins/lins.gfs.gold

@@ -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
+}

src/compiler/testsuite/compiler/check/lins/linsCnc.gf

@@ -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"} ;
+
+}

src/compiler/testsuite/compiler/check/oper-definition/Res.gf

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

src/compiler/testsuite/compiler/check/oper-definition/test.gfs

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

src/compiler/testsuite/compiler/check/oper-definition/test.gfs.gold

@@ -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

src/compiler/testsuite/compiler/check/params/Params.gf

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

src/compiler/testsuite/compiler/check/restricted-inheritance/A.gf

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

src/compiler/testsuite/compiler/check/restricted-inheritance/B.gf

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

src/compiler/testsuite/compiler/check/strMatch/Prelude.gf

@@ -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) ;
+
+}

src/compiler/testsuite/compiler/check/strMatch/strMatch.gf

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

src/compiler/testsuite/compiler/check/strMatch/strMatch.gfs

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

src/compiler/testsuite/compiler/check/strMatch/strMatch.gfs.gold

@@ -0,0 +1 @@
+

src/compiler/testsuite/compiler/check/strMatch/strMatchCnc.gf

@@ -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} ;
+}

src/compiler/testsuite/compiler/compute/lambda.gfs

@@ -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>

src/compiler/testsuite/compiler/compute/lambda.gfs.gold

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

src/compiler/testsuite/compiler/compute/param_table.gf

@@ -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
+  } ;
+
+}

src/compiler/testsuite/compiler/compute/param_table.gfs

@@ -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>

src/compiler/testsuite/compiler/compute/param_table.gfs.gold

@@ -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"
+      }

src/compiler/testsuite/compiler/compute/predef.gfs

@@ -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")

src/compiler/testsuite/compiler/compute/predef.gfs.gold

@@ -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"

src/compiler/testsuite/compiler/compute/record.gf

@@ -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"};
+}

src/compiler/testsuite/compiler/compute/record.gfs

@@ -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}>

src/compiler/testsuite/compiler/compute/record.gfs.gold

@@ -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"}

src/compiler/testsuite/compiler/compute/string_matching.gfs

@@ -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 {"в"|"ф"=>"във"; _=>"в"}

src/compiler/testsuite/compiler/compute/string_matching.gfs.gold

@@ -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 {"в"; "ф"}}

src/compiler/testsuite/compiler/compute/variant.gf

@@ -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;
+}

src/compiler/testsuite/compiler/compute/variant.gfs

@@ -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">

src/compiler/testsuite/compiler/compute/variant.gfs.gold

@@ -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"

src/compiler/testsuite/compiler/params/params.gf

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

src/compiler/testsuite/compiler/params/params.gfs

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

src/compiler/testsuite/compiler/params/paramsCnc.gf

@@ -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}} ;
+
+}

src/compiler/testsuite/compiler/renamer/funpatt.gf

@@ -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 ;
+
+}

src/compiler/testsuite/compiler/renamer/funpatt.gfs

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