moved all old source code to src-2.9 ; src will be for GF 3 development

src-2.9/FILES

@@ -0,0 +1,260 @@
+
+Code map for GF source files. 
+
+$Author: peb $
+$Date: 2005/02/07 10:58:08 $
+
+Directories:
+
+[top level] GF main function and runtime-related modules
+api         high-level access to GF functionalities
+canonical   GFC (= GF Canonical) basic functionalities
+cf          context-free skeleton used in parsing
+cfgm        multilingual context-free skeleton exported to Java
+compile     compilation phases from GF to GFC
+conversions [OBSOLETE] formats used in parser generation
+for-ghc     GHC-specific files (Glasgow Haskell Compiler)
+for-hugs    Hugs-specific files (a Haskell interpreter)
+for-windows Windows-specific files (an operating system from Microsoft)
+grammar     basic functionalities of GF grammars used in compilation
+infra       GF-independent infrastructure and auxiliaries
+newparsing  parsing with GF grammars: current version (cf. parsing)
+notrace     debugging utilities for parser development (cf. trace)
+parsers     parsers of GF and GFC files
+parsing     [OBSOLETE] parsing with GF grammars: old version (cf. newparsing)
+shell       interaction shells
+source      utilities for reading in GF source files
+speech      generation of speech recognition grammars
+trace       debugging utilities for parser development (cf. notrace)
+useGrammar  grammar functionalities for applications
+util        utilities for using GF
+
+
+Individual files:
+
+GF.hs                  the Main module
+GFModes.hs
+HelpFile.hs            [AUTO] help file generated by util/MkHelpFile
+Today.hs               [AUTO] file generated by "make today"
+
+api/API.hs             high-level access to GF functionalities
+api/BatchTranslate.hs
+api/GetMyTree.hs
+api/GrammarToHaskell.hs
+api/IOGrammar.hs
+api/MyParser.hs        slot for defining your own parser
+
+canonical/AbsGFC.hs    [AUTO] abstract syntax of GFC
+canonical/CanonToGrammar.hs
+canonical/CMacros.hs
+canonical/ErrM.hs
+canonical/GetGFC.hs
+canonical/GFC.cf       [LBNF] source of GFC parser
+canonical/GFC.hs
+canonical/LexGFC.hs
+canonical/Look.hs
+canonical/MkGFC.hs
+canonical/PrExp.hs
+canonical/PrintGFC.hs  pretty-printer of GFC
+canonical/Share.hs
+canonical/SkelGFC.hs   [AUTO]
+canonical/TestGFC.hs   [AUTO]
+canonical/Unlex.hs
+
+cf/CanonToCF.hs
+cf/CF.hs               abstract syntax of context-free grammars
+cf/CFIdent.hs
+cf/CFtoGrammar.hs
+cf/CFtoSRG.hs
+cf/ChartParser.hs      the current default parsing method
+cf/EBNF.hs
+cf/PPrCF.hs
+cf/PrLBNF.hs
+cf/Profile.hs
+
+cfgm/CFG.cf             [LBNF] source
+cfgm/AbsCFG.hs          [AUTO]
+cfgm/LexCFG.hs          [AUTO]
+cfgm/ParCFG.hs          [AUTO]
+cfgm/PrintCFG.hs        [AUTO]
+cfgm/PrintCFGrammar.hs
+
+compile/CheckGrammar.hs
+compile/Compile.hs      the complete compiler pipeline
+compile/Extend.hs
+compile/GetGrammar.hs
+compile/GrammarToCanon.hs
+compile/MkResource.hs
+compile/MkUnion.hs
+compile/ModDeps.hs
+compile/Optimize.hs
+compile/PGrammar.hs
+compile/PrOld.hs
+compile/Rebuild.hs
+compile/RemoveLiT.hs
+compile/Rename.hs
+compile/ShellState.hs   the run-time multilingual grammar datastructure
+compile/Update.hs
+
+for-ghc/ArchEdit.hs
+for-ghc/Arch.hs
+
+for-ghc-nofud/ArchEdit.hs@
+for-ghc-nofud/Arch.hs@
+
+for-hugs/ArchEdit.hs
+for-hugs/Arch.hs
+for-hugs/JGF.hs
+for-hugs/MoreCustom.hs
+for-hugs/Unicode.hs
+
+for-hugs/Arch.hs
+for-hugs/ArchEdit.hs
+for-hugs/JGF.hs
+for-hugs/LexCFG.hs         dummy CFG lexer
+for-hugs/LexGF.hs          dummy GF lexer
+for-hugs/LexGFC.hs         dummy GFC lexer
+for-hugs/MoreCustom.hs
+for-hugs/ParCFG.hs         dummy CFG parser 
+for-hugs/ParGFC.hs         dummy GFC parser
+for-hugs/ParGF.hs          dummy GF parser
+for-hugs/Tracing.hs
+for-hugs/Unicode.hs
+
+for-windows/ArchEdit.hs
+for-windows/Arch.hs
+
+grammar/AbsCompute.hs
+grammar/Abstract.hs        GF and GFC abstract syntax datatypes
+grammar/AppPredefined.hs
+grammar/Compute.hs
+grammar/Grammar.hs         GF source grammar datatypes
+grammar/LookAbs.hs
+grammar/Lookup.hs          
+grammar/Macros.hs          macros for creating GF terms and types
+grammar/MMacros.hs         more macros, mainly for abstract syntax
+grammar/PatternMatch.hs
+grammar/PrGrammar.hs       the top-level grammar printer
+grammar/Refresh.hs
+grammar/ReservedWords.hs
+grammar/TC.hs              Coquand's type checking engine
+grammar/TypeCheck.hs
+grammar/Unify.hs
+grammar/Values.hs
+
+infra/Arabic.hs             ASCII coding of Arabic Unicode
+infra/Assoc.hs              finite maps/association lists as binary search trees
+infra/CheckM.hs
+infra/Comments.hs
+infra/Devanagari.hs         ASCII coding of Devanagari Unicode
+infra/ErrM.hs
+infra/Ethiopic.hs
+infra/EventF.hs
+infra/ExtendedArabic.hs
+infra/ExtraDiacritics.hs
+infra/FudgetOps.hs
+infra/Glue.hs
+infra/Greek.hs
+infra/Hebrew.hs
+infra/Hiragana.hs
+infra/Ident.hs
+infra/LatinASupplement.hs
+infra/Map.hs                finite maps as red black trees
+infra/Modules.hs
+infra/OCSCyrillic.hs
+infra/Operations.hs         library of strings, search trees, error monads
+infra/Option.hs
+infra/OrdMap2.hs            abstract class of finite maps + implementation as association lists
+infra/OrdSet.hs             abstract class of sets + implementation as sorted lists
+infra/Parsers.hs
+infra/ReadFiles.hs
+infra/RedBlack.hs           red black trees
+infra/RedBlackSet.hs        sets and maps as red black trees
+infra/Russian.hs
+infra/SortedList.hs         sets as sorted lists
+infra/Str.hs
+infra/Tamil.hs
+infra/Text.hs
+infra/Trie2.hs
+infra/Trie.hs
+infra/UnicodeF.hs
+infra/Unicode.hs
+infra/UseIO.hs
+infra/UTF8.hs               UTF3 en/decoding
+infra/Zipper.hs
+
+newparsing/CFGrammar.hs                type definitions for context-free grammars
+newparsing/CFParserGeneral.hs          several variants of general CFG chart parsing
+newparsing/CFParserIncremental.hs      several variants of incremental (Earley-style) CFG chart parsing
+newparsing/ConvertGFCtoMCFG.hs         converting GFC to MCFG
+newparsing/ConvertGrammar.hs           conversions between different grammar formats
+newparsing/ConvertMCFGtoCFG.hs         converting MCFG to CFG
+newparsing/GeneralChart.hs             Haskell framework for "parsing as deduction"
+newparsing/GrammarTypes.hs             instantiations of grammar types
+newparsing/IncrementalChart.hs         Haskell framework for incremental chart parsing
+newparsing/MCFGrammar.hs               type definitions for multiple CFG
+newparsing/MCFParserBasic.hs           MCFG chart parser
+newparsing/MCFRange.hs                 ranges for MCFG parsing
+newparsing/ParseCFG.hs                 parsing of CFG
+newparsing/ParseCF.hs                  parsing of the CF format
+newparsing/ParseGFC.hs                 parsing of GFC
+newparsing/ParseMCFG.hs                parsing of MCFG
+newparsing/Parser.hs                   general definitions for parsers
+newparsing/PrintParser.hs              pretty-printing class for parsers
+newparsing/PrintSimplifiedTerm.hs      simplified pretty-printing for GFC terms
+
+notrace/Tracing.hs          tracing predicates when we DON'T want tracing capabilities (normal case)
+
+parsers/ParGFC.hs           [AUTO]
+parsers/ParGF.hs            [AUTO]
+
+shell/CommandF.hs
+shell/CommandL.hs           line-based syntax of editor commands
+shell/Commands.hs           commands of GF editor shell
+shell/IDE.hs
+shell/JGF.hs
+shell/PShell.hs
+shell/ShellCommands.hs      commands of GF main shell
+shell/Shell.hs
+shell/SubShell.hs
+shell/TeachYourself.hs
+
+source/AbsGF.hs             [AUTO]
+source/ErrM.hs
+source/GF.cf                [LBNF] source of GF parser
+source/GrammarToSource.hs
+source/LexGF.hs             [AUTO]
+source/PrintGF.hs           [AUTO]
+source/SourceToGrammar.hs
+
+speech/PrGSL.hs
+speech/PrJSGF.hs
+speech/SRG.hs
+speech/TransformCFG.hs
+
+trace/Tracing.hs            tracing predicates when we want tracing capabilities
+
+translate/GFT.hs            Main module of html-producing batch translator
+
+useGrammar/Custom.hs        database for customizable commands
+useGrammar/Editing.hs
+useGrammar/Generate.hs
+useGrammar/GetTree.hs
+useGrammar/Information.hs
+useGrammar/Linear.hs        the linearization algorithm
+useGrammar/MoreCustom.hs
+useGrammar/Morphology.hs
+useGrammar/Paraphrases.hs
+useGrammar/Parsing.hs       the top-level parsing algorithm
+useGrammar/Randomized.hs
+useGrammar/RealMoreCustom.hs
+useGrammar/Session.hs
+useGrammar/TeachYourself.hs
+useGrammar/Tokenize.hs      lexer definitions (listed in Custom)
+useGrammar/Transfer.hs
+
+util/GFDoc.hs              utility for producing LaTeX and HTML from GF
+util/HelpFile              source of ../HelpFile.hs
+util/Htmls.hs              utility for chopping a HTML document to slides
+util/MkHelpFile.hs
+util/WriteF.hs

src-2.9/GF-embed.cabal

@@ -0,0 +1,52 @@
+Name: gf-embed
+Version: 2.8
+Cabal-version: >= 1.2
+Build-type: Simple
+License: GPL
+License-file: ../LICENSE
+Synopsis: Grammatical Framework embedded API.
+
+Flag split-base
+
+Library
+  Build-depends: mtl, haskell98
+  if flag(split-base)
+    Build-depends: base >= 3.0, array, containers, directory, random
+  else
+    Build-depends: base < 3.0
+  Ghc-options: -O2
+  Extensions: 
+  Exposed-Modules: 
+    GF.GFCC.API
+    -- needed by code generated by -haskell
+    GF.GFCC.DataGFCC
+    GF.GFCC.CId
+  Other-modules:
+    GF.Conversion.SimpleToFCFG
+    GF.Data.Assoc
+    GF.Data.Utilities
+    GF.Data.SortedList
+    GF.Data.BacktrackM
+    GF.Data.ErrM
+    GF.Data.GeneralDeduction
+    GF.Data.RedBlackSet
+    GF.Text.UTF8
+    GF.Infra.CompactPrint
+    GF.Infra.PrintClass
+    GF.Formalism.FCFG
+    GF.Formalism.Utilities
+    GF.Parsing.FCFG
+    GF.Parsing.FCFG.PInfo
+    GF.Parsing.FCFG.Range
+    GF.Parsing.FCFG.Active
+    GF.Command.PPrTree
+    GF.Command.AbsGFShell
+    GF.Command.PrintGFShell
+    GF.Command.ParGFShell
+    GF.Command.LexGFShell
+    GF.GFCC.Macros
+    GF.GFCC.Generate
+    GF.GFCC.Linearize
+    GF.GFCC.Raw.AbsGFCCRaw
+    GF.GFCC.Raw.ParGFCCRaw
+    GF.GFCC.Raw.ConvertGFCC

src-2.9/GF.hs

@@ -0,0 +1,153 @@
+{-# OPTIONS -cpp #-}
+----------------------------------------------------------------------
+-- |
+-- Module      : Main
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stability)
+-- Portability : (portability)
+--
+-- > CVS $Date: 2005/06/30 11:36:49 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.29 $
+--
+-- The Main module of GF program.
+-----------------------------------------------------------------------------
+
+module Main (main) where
+
+import GF.GFModes (gfInteract, gfBatch, batchCompile)
+import GF.Data.Operations
+import GF.Infra.UseIO
+import GF.Infra.Option
+import GF.API.IOGrammar
+import GF.Compile.ShellState
+import GF.Compile.Compile
+import GF.Compile.MkConcrete
+import GF.Compile.Wordlist
+import GF.Shell
+import GF.Shell.SubShell
+import GF.Shell.ShellCommands
+import GF.Shell.PShell
+import GF.Shell.JGF
+import GF.System.Signal
+import GF.Text.UTF8
+
+import GF.Today (today,version,libdir)
+import GF.System.Arch
+import System (getArgs,system,getEnv)
+import System.FilePath
+import Control.Monad (foldM,liftM)
+import Data.List (nub)
+
+#ifdef mingw32_HOST_OS
+import System.Win32.Console
+import System.Win32.NLS
+#endif
+
+-- AR 19/4/2000 -- 21/3/2006
+
+main :: IO ()
+main = do
+#ifdef mingw32_HOST_OS
+  codepage <- getACP
+  setConsoleCP codepage
+  setConsoleOutputCP codepage
+#endif
+  
+  xs <- getArgs
+  let 
+   (os,fs) = getOptions "-" xs
+   opt j   = oElem j os
+   st0     = optInitShellState os
+   ifNotSil c = if oElem beSilent os then return () else c 
+
+   doGF os fs = case 0 of
+
+    _ | opt getHelp || any opt (map iOpt ["h", "-help", "-h"])-> do
+      putStrLnFlush $ encodeUTF8 helpMsg
+
+    _ | opt forJava -> do
+      welcome <- welcomeMsgLib
+      putStrLnFlush $ encodeUTF8 welcome 
+      st <- useIOE st0 $ 
+              foldM (shellStateFromFiles os) st0 fs
+      sessionLineJ True st
+      return ()
+
+    _ | opt doMake -> do
+      mapM_ (batchCompile os) fs
+      return ()
+
+    _ | opt makeConcrete -> do
+        mkConcretes os fs
+
+    _ | opt openEditor -> do
+        system $ "jgf" +++ unwords xs
+        return ()
+
+    _ | opt doBatch -> do
+      if opt beSilent then return () else putStrLnFlush "<gfbatch>"
+      st <- useIOE st0 $ 
+              foldM (shellStateFromFiles os) st0 fs
+      gfBatch (initHState st) 
+      if opt beSilent then return () else putStrLnFlush "</gfbatch>"
+      return ()
+    _ -> do
+      welcome <- welcomeMsgLib
+      ifNotSil $ putStrLnFlush $ welcome
+      st <- useIOE st0 $ 
+              foldM (shellStateFromFiles os) st0 fs
+      if null fs then return () else (ifNotSil putCPU) 
+      blockInterrupt (gfInteract (initHState st)) 
+      return ()
+  -- preprocessing gfe
+  if opt fromExamples 
+    then do
+        es <- liftM (nub . concat) $ mapM (getGFEFiles os) fs
+        mkConcretes os es
+        doGF (removeOption fromExamples os) fs
+  -- preprocessing gfwl
+    else if (length fs == 1 && takeExtensions (head fs) == ".gfwl")
+    then do
+      fs' <- mkWordlist (head fs)
+      doGF os fs'
+    else doGF os fs
+
+helpMsg = unlines [
+  "Usage: gf <option>* <file>*",
+  "Options:",
+  "  -batch        structure session by XML tags (use > to send into a file)",
+  "  -edit         start the editor GUI (same as command 'jgf')",
+  "  -ex           first compile .gfe files as needed, then .gf files",
+  "  -examples     batch-compile .gfe files by parsing examples",
+  "     -treebank  use a treebank, instead of a grammar, as parser",
+  "  -make         batch-compile files",
+  "     -noemit      do not emit code when compiling",
+  "     -v           be verbose when compiling",
+  "  -help         show this message",
+  "Also all flags for import (i) are interpreted; see 'help import'.",
+  "An example combination of flags is",
+  "  gf -batch -nocpu -s",
+  "which suppresses all messages except the output and fatal errors."
+  ]
+
+welcomeMsgLib = do
+  lib <- getLibraryPath
+  return $ welcomeMsg lib
+
+welcomeMsg lib = 
+  "Welcome to " ++ authorMsg ++++ 
+  "If \228 and \246 (umlaut letters) look strange, see 'h -coding'." ++
+  "\nGF_LIB_PATH is set to " ++ lib ++
+  "\n\nType 'h' for help, and 'h [Command] for more detailed help.\n"
+
+authorMsg = unlines [
+ "Grammatical Framework, Version " ++ version,
+ "Compiled " ++ today,
+ "Copyright (c)", 
+ "Krasimir Angelov, Bj\246rn Bringert, H\229kan Burden, Hans-Joachim Daniels,",
+ "Markus Forsberg, Thomas Hallgren, Harald Hammarstr\246m, Kristofer Johannisson,",
+ "Janna Khegai, Peter Ljungl\246f, Petri M\228enp\228\228, and", 
+ "Aarne Ranta, 1998-2006, under GNU General Public License (GPL)",
+ "Bug reports to aarne@cs.chalmers.se"
+ ]

src-2.9/GF/API.hs

@@ -0,0 +1,472 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : API
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/14 16:03:40 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.39 $
+--
+-- Application Programmer's Interface to GF; also used by Shell. AR 10/11/2001
+-----------------------------------------------------------------------------
+
+module GF.API where
+
+import qualified GF.Source.AbsGF as GF
+import qualified GF.Canon.AbsGFC as A
+import qualified GF.Compile.Rename as R
+import GF.UseGrammar.GetTree
+import GF.Canon.GFC
+--- import qualified Values as V
+import GF.Grammar.Values
+
+-----import GetGrammar
+import GF.Compile.Compile
+import GF.API.IOGrammar
+import GF.UseGrammar.Linear
+import GF.UseGrammar.Parsing
+import GF.UseGrammar.Morphology
+import GF.CF.PPrCF
+import GF.CF.CFIdent
+import GF.Compile.PGrammar
+import GF.UseGrammar.Randomized (mkRandomTree)
+
+import GF.Grammar.MMacros
+import qualified GF.Grammar.Macros as M
+import GF.Grammar.TypeCheck
+import GF.Canon.CMacros
+import GF.UseGrammar.Transfer
+import qualified GF.UseGrammar.Generate as Gen
+
+import GF.Text.Text (untokWithXML)
+import GF.Infra.Option
+import GF.UseGrammar.Custom
+import GF.Compile.ShellState
+import GF.UseGrammar.Linear
+import GF.Canon.GFC
+import qualified GF.Grammar.Grammar as G
+import GF.Infra.Modules
+import GF.Grammar.PrGrammar
+import qualified GF.Grammar.Compute as Co
+import qualified GF.Grammar.AbsCompute as AC
+import qualified GF.Infra.Ident as I
+import qualified GF.Compile.GrammarToCanon as GC
+import qualified GF.Canon.CanonToGrammar as CG
+import qualified GF.Canon.MkGFC as MC
+import qualified GF.Embed.EmbedAPI as EA
+
+import GF.UseGrammar.Editing
+
+import GF.System.SpeechInput (recognizeSpeech)
+
+----import GrammarToXML 
+
+----import GrammarToMGrammar as M
+
+import qualified Transfer.InterpreterAPI as T
+
+import GF.System.Arch (myStdGen)
+
+import GF.Text.UTF8
+import GF.Data.Operations
+import GF.Infra.UseIO
+import GF.Data.Zipper
+
+import Data.List (nub)
+import Data.Char (toLower)
+import Data.Maybe (fromMaybe)
+import Control.Monad (liftM)
+import System (system)
+import System.FilePath
+
+type GFGrammar = StateGrammar
+type GFCat     = CFCat
+type Ident     = I.Ident
+--- type Tree      = V.Tree
+
+-- these are enough for many simple applications
+
+file2grammar :: FilePath -> IO GFGrammar
+file2grammar file = do
+  egr <- appIOE $ optFile2grammar (iOpts [beSilent]) file
+  err (\s -> putStrLn s >> return emptyStateGrammar) return egr
+
+linearize :: GFGrammar -> Tree -> String
+linearize sgr = err id id . optLinearizeTree opts sgr where
+  opts = addOption firstLin $ stateOptions sgr
+
+term2tree :: GFGrammar -> G.Term -> Tree
+term2tree gr = errVal uTree . annotate (grammar gr) . qualifTerm (absId gr)
+
+tree2term :: Tree -> G.Term
+tree2term = tree2exp
+
+linearizeToAll :: [GFGrammar] -> Tree -> [String]
+linearizeToAll grs t = [linearize gr t | gr <- grs]
+
+parse :: GFGrammar -> GFCat -> String -> [Tree]
+parse sgr cat = errVal [] . parseString noOptions sgr cat
+
+parseAny :: [GFGrammar] -> GFCat -> String -> [Tree]
+parseAny grs cat s = 
+  concat [errVal [] (parseString (options [iOpt "trynextlang"]) gr cat s) | gr <- grs]
+
+translate :: GFGrammar -> GFGrammar -> GFCat -> String -> [String]
+translate ig og cat = map (linearize og) . parse ig cat
+
+translateToAll :: GFGrammar -> [GFGrammar] -> GFCat -> String -> [String]
+translateToAll ig ogs cat = concat . map (linearizeToAll ogs) . parse ig cat
+
+translateFromAny :: [GFGrammar] -> GFGrammar -> GFCat -> String -> [String]
+translateFromAny igs og cat s = concat [translate ig og cat s | ig <- igs]
+
+translateBetweenAll :: [GFGrammar] -> GFCat -> String -> [String]
+translateBetweenAll grs cat = 
+  concat . map (linearizeToAll grs) . parseAny grs cat
+
+homonyms :: GFGrammar -> GFCat -> Tree -> [Tree]
+homonyms gr cat = nub . parse gr cat . linearize gr
+
+hasAmbiguousLin :: GFGrammar -> GFCat -> Tree -> Bool
+hasAmbiguousLin gr cat t = case (homonyms gr cat t) of
+  _:_:_ -> True
+  _ -> False
+
+{- ----
+-- returns printname if one exists; othewrise linearizes with metas
+printOrLin :: GFGrammar -> Fun -> String
+printOrLin gr = printOrLinearize (stateGrammarST gr)
+
+-- reads a syntax file and writes it in a format wanted
+transformGrammarFile :: Options -> FilePath -> IO String
+transformGrammarFile opts file = do
+  sy <- useIOE GF.emptySyntax $ getSyntax opts file
+  return $ optPrintSyntax opts sy
+-}
+
+prIdent :: Ident -> String
+prIdent = prt
+
+string2GFCat :: String -> String -> GFCat
+string2GFCat = string2CFCat
+
+-- then stg for customizable and internal use
+
+optFile2grammar :: Options -> FilePath -> IOE GFGrammar
+optFile2grammar os f  
+  | takeExtensions f == ".gfcm" = ioeIO $ liftM firstStateGrammar $ EA.file2grammar f
+  | otherwise = do
+      ((_,_,gr,_),_) <- compileModule os emptyShellState f
+      ioeErr $ grammar2stateGrammar os gr
+
+optFile2grammarE :: Options -> FilePath -> IOE GFGrammar
+optFile2grammarE = optFile2grammar
+
+
+string2treeInState :: GFGrammar -> String -> State -> Err Tree
+string2treeInState gr s st = do
+  let metas = allMetas st
+      xs    = map fst $ actBinds st
+  t0 <- pTerm s
+  let t = qualifTerm (absId gr) $ M.mkAbs xs $ refreshMetas metas $ t0
+  annotateExpInState (grammar gr) t st 
+
+string2srcTerm :: G.SourceGrammar -> I.Ident -> String -> Err G.Term
+string2srcTerm gr m s = do
+  t <- pTerm s
+  R.renameSourceTerm gr m t
+
+randomTreesIO :: Options -> GFGrammar -> Int -> IO [Tree]
+randomTreesIO opts gr n = do
+  gen <- myStdGen mx
+  t   <- err (\s -> putS s >> return []) 
+             (return . singleton) $ 
+                mkRandomTree gen mx g catfun
+  ts  <- if n==1 then return [] else randomTreesIO opts gr (n-1)
+  return $ t ++ ts
+ where
+   catfun = case getOptVal opts withFun of
+     Just fun -> Right $ (absId gr, I.identC fun)
+     _ -> Left $ firstAbsCat opts gr
+   g   = grammar gr
+   mx  = optIntOrN opts flagDepth 41
+   putS s = if oElem beSilent opts then return () else putStrLnFlush s
+
+
+generateTrees :: Options -> GFGrammar -> Maybe Tree -> [Tree]
+generateTrees opts gr mt =
+  optIntOrAll opts flagNumber  
+    [tr | t <- Gen.generateTrees opts gr' cat dpt mn mt, Ok tr <- [mkTr t]]
+  where
+    mkTr = annotate gr' . qualifTerm (absId gr) 
+    gr' = grammar gr
+    cat = firstAbsCat opts gr
+    dpt = maybe 3 id $ getOptInt opts flagDepth
+    mn  = getOptInt opts flagAlts
+
+speechGenerate :: Options -> String -> IO ()
+speechGenerate opts str = do
+  let lan = maybe "" (" --language" +++) $ getOptVal opts speechLanguage
+  system ("flite" +++ "\" " ++ str ++ "\"")
+---  system ("echo" +++ "\"" ++ str ++ "\" | festival --tts" ++ lan)
+  return ()
+
+speechInput :: Options -> StateGrammar -> IO [String]
+speechInput opt s = recognizeSpeech name language cfg cat number
+  where
+  opts = addOptions opt (stateOptions s)
+  name = cncId s
+  cfg = stateCFG s -- FIXME: use lang flag to select grammar
+  language = fromMaybe "en_UK" (getOptVal opts speechLanguage)
+  cat = prCFCat (firstCatOpts opts s) ++ "{}.s"
+  number = optIntOrN opts flagNumber 1
+
+optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String
+optLinearizeTreeVal opts gr = err id id . optLinearizeTree opts gr
+
+optLinearizeTree :: Options -> GFGrammar -> Tree -> Err String
+optLinearizeTree opts0 gr t = case getOptVal opts transferFun of
+  Just m -> useByTransfer flin g (I.identC m) t
+  _ -> flin t
+ where
+  opts = addOptions opts0 (stateOptions gr)
+  flin = case getOptVal opts markLin of
+    Just mk
+     | mk == markOptXML    -> lin markXML
+     | mk == markOptJava   -> lin markXMLjgf
+     | mk == markOptStruct -> lin markBracket
+     | mk == markOptFocus  -> lin markFocus
+     | mk == "metacat"     -> lin metaCatMark
+     | otherwise           -> lin noMark
+    _ -> lin noMark
+
+  lin mk
+    | oElem showRecord opts = liftM prt . linearizeNoMark g c
+    | oElem tableLin opts   = liftM (unlines . map untok . prLinTable True) . 
+                                allLinTables True g c
+    | oElem showFields opts = liftM (unlines . map untok) .
+                                allLinBranchFields g c
+    | oElem showAll opts    = liftM (unlines . map untok . prLinTable False) . 
+                                allLinTables False g c
+    | otherwise = return . unlines . map untok . optIntOrOne . linTree2strings mk g c
+  g = grammar gr
+  c = cncId gr
+  untok = if False ---- oElem (markLin markOptXML) opts 
+            then untokWithXML unt
+            else unt  
+  unt = customOrDefault opts useUntokenizer customUntokenizer gr
+  optIntOrOne = take $ optIntOrN opts flagNumber 1
+
+{- ----
+        untoksl . lin where
+  gr = concreteOf (stateGrammarST sgr)
+  lin -- options mutually exclusive, with priority: struct, rec, table, one
+   | oElem showStruct opts = markedLinString True gr . tree2loc
+   | oElem showRecord opts = err id prt                  . linTerm gr
+   | oElem tableLin opts   = err id (concatMap prLinTable)  . allLinsAsStrs gr
+   | oElem firstLin opts   = unlines . map sstr . take 1 . allLinStrings gr
+   | otherwise = unlines . map sstr . optIntOrAll opts flagNumber . allLinStrings gr
+  untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr
+  opts' = addOptions opts $ stateOptions sgr
+  untoksl = unlines . map untoks . lines
+-}
+
+{-
+optLinearizeArgForm :: Options -> StateGrammar -> [Term] -> Term -> String
+optLinearizeArgForm opts sgr fs ts0 = untoksl $ lin ts where
+  gr = concreteOf (stateGrammarST sgr) 
+  ts = annotateTrm sgr ts0
+  ms = map (renameTrm (lookupConcrete gr)) fs
+  lin -- options mutually exclusive, with priority: struct, rec, table
+   | oElem tableLin opts = err id (concatMap prLinTable) . allLinsForForms gr ms
+   | otherwise = err id (unlines . map sstr . tkStrs . concat) . allLinsForForms gr ms
+  tkStrs = concat . map snd . concat . map snd
+  untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr
+  opts' = addOptions opts $ stateOptions sgr
+  untoksl = unlines . map untoks . lines
+-}
+
+optParseArg :: Options -> GFGrammar -> String -> [Tree]
+optParseArg opts gr =  err (const []) id . optParseArgErr opts gr
+
+optParseArgAny :: Options -> [GFGrammar] -> String -> [Tree]
+optParseArgAny opts grs s = concat [pars gr s | gr <- grs] where
+  pars gr = optParseArg opts gr --- grammar options!
+
+optParseArgErr :: Options -> GFGrammar -> String -> Err [Tree]
+optParseArgErr opts gr = liftM fst . optParseArgErrMsg opts gr
+
+optParseArgErrMsg :: Options -> GFGrammar -> String -> Err ([Tree],String)
+optParseArgErrMsg opts gr s = do
+  let cat = firstCatOpts opts gr
+      g   = grammar gr
+  (ts,m) <- parseStringMsg opts gr cat s
+  ts' <- case getOptVal opts transferFun of
+    Just m -> mkByTransfer (const $ return ts) g (I.identC m) s
+    _ -> return ts
+  return (ts',m)
+
+-- | analyses word by word
+morphoAnalyse :: Options -> GFGrammar -> String -> String
+morphoAnalyse opts gr
+  | oElem (iOpt "status") opts = morphoTextStatus mo 
+  | oElem beShort opts = morphoTextShort mo 
+  | otherwise = morphoText mo 
+ where
+  mo = morpho gr
+
+isKnownWord :: GFGrammar -> String -> Bool
+isKnownWord gr s = GF.UseGrammar.Morphology.isKnownWord (morpho gr) s
+
+unknownTokens :: GFGrammar -> [CFTok] -> [String]
+unknownTokens gr ts = 
+  [w | TC w <- ts, unk w && unk (uncap w)] ++ [w | TS w <- ts, unk w]
+ where
+   unk w = not $ GF.API.isKnownWord gr w
+   uncap (c:cs) = toLower c : cs
+   uncap s = s
+
+
+{-
+prExpXML :: StateGrammar -> Term -> [String]
+prExpXML gr = prElementX . term2elemx (stateAbstract gr) 
+
+prMultiGrammar :: Options -> ShellState -> String
+prMultiGrammar opts = M.showMGrammar (oElem optimizeCanon opts)
+-}
+-- access to customizable commands
+
+optPrintGrammar :: Options -> StateGrammar -> String
+optPrintGrammar opts = pg opts
+    where
+    pg = customOrDefault opts grammarPrinter customGrammarPrinter
+
+optPrintMultiGrammar :: Options -> CanonGrammar -> String
+optPrintMultiGrammar opts = encodeId . pmg opts . encode
+    where 
+    pmg = customOrDefault opts grammarPrinter customMultiGrammarPrinter
+    -- if -utf8 was given, convert from language specific codings
+    encode = if oElem useUTF8 opts then mapModules moduleToUTF8 else id
+    -- if -utf8id was given, convert non-literals to UTF8
+    encodeId = if oElem useUTF8id opts then nonLiteralsToUTF8 else id
+    moduleToUTF8 m = 
+	m{ jments = mapTree (onSnd (mapInfoTerms code)) (jments m),
+	   flags = setFlag "coding" "utf8" (flags m) }
+	where code = onTokens (anyCodingToUTF8 (moduleOpts m))
+	      moduleOpts = Opts . okError . mapM CG.redFlag . flags
+
+optPrintSyntax :: Options -> GF.Grammar -> String
+optPrintSyntax opts = customOrDefault opts grammarPrinter customSyntaxPrinter
+
+optPrintTree :: Options -> GFGrammar -> Tree -> String
+optPrintTree opts = customOrDefault opts grammarPrinter customTermPrinter
+
+-- | look for string command (-filter=x)
+optStringCommand :: Options -> GFGrammar -> String -> String
+optStringCommand opts g = 
+  optIntOrAll opts flagLength .  
+  customOrDefault opts filterString customStringCommand g
+
+optTermCommand :: Options -> GFGrammar -> Tree -> [Tree]
+optTermCommand opts st = 
+  optIntOrAll opts flagNumber .  
+  customOrDefault opts termCommand customTermCommand st
+
+
+-- wraps term in a function and optionally computes the result
+
+wrapByFun :: Options -> GFGrammar -> Ident -> Tree -> Tree
+wrapByFun opts gr f t = 
+  if oElem doCompute opts 
+  then err (const t) id $ AC.computeAbsTerm (grammar gr) t' >>= annotate g
+  else err (const t) id $ annotate g t'
+ where
+   t' = qualifTerm (absId gr) $ M.appCons f [tree2exp t]
+   g = grammar gr
+
+applyTransfer :: Options -> GFGrammar -> [(Ident,T.Env)] ->
+                 (Maybe Ident,Ident) -> Tree -> Err [Tree]
+applyTransfer opts gr trs (mm,f) t = mapM (annotate g) ts'
+ where
+   ts' = map (qualifTerm (absId gr)) $ trans tr f $ tree2exp t
+   g = grammar gr
+   tr = case mm of
+     Just m -> maybe empty id $ lookup m trs
+     _ -> ifNull empty (snd . head) trs
+   -- FIXME: if the returned value is a list,
+   -- return a list of trees
+   trans :: T.Env -> Ident -> Exp -> [Exp]
+   trans tr f = (:[]) . core2exp . T.evaluateExp tr . exp2core f
+   empty = T.builtin
+
+{-
+optTransfer :: Options -> StateGrammar -> G.Term -> G.Term
+optTransfer opts g = case getOptVal opts transferFun of
+  Just f -> wrapByFun (addOption doCompute opts) g (M.zIdent f)
+  _ -> id
+-}
+
+optTokenizerResult :: Options -> GFGrammar -> String -> [[CFTok]]
+optTokenizerResult opts gr = customOrDefault opts useTokenizer customTokenizer gr
+
+optTokenizer :: Options -> GFGrammar -> String -> String
+optTokenizer opts gr = show . optTokenizerResult opts gr
+
+-- performs UTF8 if the language does not have flag coding=utf8; replaces name*U
+
+-- | convert a Unicode string into a UTF8 encoded string
+optEncodeUTF8 :: GFGrammar -> String -> String
+optEncodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of
+  Just "utf8" -> id
+  _ -> encodeUTF8
+
+-- | convert a UTF8 encoded string into a Unicode string
+optDecodeUTF8 :: GFGrammar -> String -> String
+optDecodeUTF8 gr = case getOptVal (stateOptions gr) uniCoding of
+  Just "utf8" -> decodeUTF8 
+  _ -> id
+
+-- | convert a string encoded with some coding given by the coding flag to UTF8
+anyCodingToUTF8 :: Options -> String -> String
+anyCodingToUTF8 opts = 
+    encodeUTF8 . customOrDefault opts uniCoding customUniCoding
+
+
+-- | Convert all text not inside double quotes to UTF8
+nonLiteralsToUTF8 :: String -> String
+nonLiteralsToUTF8 "" = ""
+nonLiteralsToUTF8 ('"':cs) = '"' : l ++ nonLiteralsToUTF8 rs
+    where 
+    (l,rs) = takeStringLit cs
+    -- | Split off an initial string ended by double quotes
+    takeStringLit :: String -> (String,String)
+    takeStringLit "" = ("","")
+    takeStringLit ('"':cs) = (['"'],cs)
+    takeStringLit ('\\':'"':cs) = ('\\':'"':xs,ys)
+      where (xs,ys) = takeStringLit cs 
+    takeStringLit (c:cs) = (c:xs,ys)
+      where (xs,ys) = takeStringLit cs
+nonLiteralsToUTF8 (c:cs) = encodeUTF8 [c] ++ nonLiteralsToUTF8 cs 
+
+
+printParadigm :: G.Term -> String
+printParadigm term = 
+  if hasTable term then
+    (unlines . map prBranch . branches . head . tables) term
+  else
+    prt term
+ where
+   tables t = case t of
+     G.R rs   -> concatMap (tables . snd . snd) rs
+     G.T _ cs -> [cs]
+     _        -> []
+   hasTable t = not $ null $ tables t
+   branches cs = [(p:ps,s) | 
+                    (p,t) <- cs, 
+                    let ts = tables t,
+                    (ps,s) <- if null ts then [([],t)] 
+                                else concatMap branches ts
+                 ]
+   prBranch (ps,s) = unwords (map prt ps ++ [prt s])

src-2.9/GF/API/BatchTranslate.hs

@@ -0,0 +1,43 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : BatchTranslate
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:05 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- translate OCL, etc, files in batch mode
+-----------------------------------------------------------------------------
+
+module GF.API.BatchTranslate (translate) where
+
+import GF.API
+import GetMyTree (file2tree)
+
+translate :: FilePath -> FilePath -> IO ()
+translate fgr txt = do
+  gr <- file2grammar fgr
+  s  <- file2tree txt
+  putStrLn $ linearize gr s
+
+
+{- headers for model-specific grammars:
+
+abstract userDefined = oclLibrary ** {
+
+--# -path=.:abstract:prelude:English:ExtraEng
+concrete userDefinedEng of userDefined = oclLibraryEng ** open externalOperEng in {
+
+--# -path=.:abstract:prelude:German:ExtraGer
+concrete userDefinedGer of userDefined = oclLibraryGer ** open
+externalOperGer in {
+
+
+It seems we should add open 
+
+   ParadigmsX, ResourceExtX, PredicationX
+
+-}

src-2.9/GF/API/GrammarToHaskell.hs

@@ -0,0 +1,271 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GrammarToHaskell
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/17 12:39:07 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- to write a GF abstract grammar into a Haskell module with translations from
+-- data objects into GF trees. Example: GSyntax for Agda.
+-- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004
+-----------------------------------------------------------------------------
+
+module GF.API.GrammarToHaskell (grammar2haskell, grammar2haskellGADT) where
+
+import qualified GF.Canon.GFC as GFC
+import GF.Grammar.Macros
+
+import GF.Infra.Modules
+import GF.Data.Operations
+
+import Data.List (isPrefixOf, find, intersperse)
+import Data.Maybe (fromMaybe)
+
+-- | the main function
+grammar2haskell :: GFC.CanonGrammar -> String
+grammar2haskell gr = foldr (++++) [] $  
+  haskPreamble ++ [datatypes gr', gfinstances gr', fginstances gr']
+    where gr' = hSkeleton gr
+
+grammar2haskellGADT :: GFC.CanonGrammar -> String
+grammar2haskellGADT gr = foldr (++++) [] $  
+  ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ 
+  haskPreamble ++ [datatypesGADT gr', composInstance gr', showInstanceGADT gr', 
+                   gfinstances gr', fginstances gr']
+    where gr' = hSkeleton gr
+
+-- | by this you can prefix all identifiers with stg; the default is 'G'
+gId :: OIdent -> OIdent 
+gId i = 'G':i
+
+haskPreamble =
+ [
+  "module GSyntax where",
+  "",
+  "import GF.Infra.Ident",
+  "import GF.Grammar.Grammar",
+  "import GF.Grammar.PrGrammar",
+  "import GF.Grammar.Macros",
+  "import GF.Data.Compos",
+  "import GF.Data.Operations",
+  "",
+  "import Control.Applicative (pure,(<*>))",
+  "import Data.Traversable (traverse)",
+  "----------------------------------------------------",
+  "-- automatic translation from GF to Haskell",
+  "----------------------------------------------------",
+  "", 
+  "class Gf a where gf :: a -> Trm",
+  "class Fg a where fg :: Trm -> a",
+  "",
+  predefInst "GString" "String" "K s",
+  "",
+  predefInst "GInt" "Integer" "EInt s",
+  "",
+  predefInst "GFloat" "Double" "EFloat s",
+  "",
+  "----------------------------------------------------",
+  "-- below this line machine-generated",
+  "----------------------------------------------------",
+  ""
+ ]
+
+predefInst gtyp typ patt = 
+  "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++
+  "instance Gf" +++ gtyp +++ "where" ++++
+  "  gf (" ++ gtyp +++ "s) =" +++ patt +++++
+  "instance Fg" +++ gtyp +++ "where" ++++
+  "  fg t =" ++++
+  "    case termForm t of" ++++
+  "      Ok ([]," +++ patt +++ ",[]) ->" +++ gtyp +++ "s" ++++
+  "      _ -> error (\"no" +++ gtyp +++ "\" ++ prt t)"
+
+type OIdent = String
+
+type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
+
+datatypes, gfinstances, fginstances :: (String,HSkeleton) -> String
+datatypes   = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd
+gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (hInstance m)) g
+fginstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (fInstance m)) g
+
+hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String
+hInstance, fInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String
+
+hDatatype ("Cn",_) = "" ---
+hDatatype (cat,[]) = ""
+hDatatype (cat,rules) | isListCat (cat,rules) = 
+ "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" 
+  +++ "deriving Show"
+hDatatype (cat,rules) =
+ "data" +++ gId cat +++ "=" ++
+ (if length rules == 1 then "" else "\n  ") +++
+ foldr1 (\x y -> x ++ "\n |" +++ y) 
+        [gId f +++ foldr (+++) "" (map gId xx) | (f,xx) <- rules] ++++
+ "  deriving Show"
+
+-- GADT version of data types
+datatypesGADT :: (String,HSkeleton) -> String
+datatypesGADT (_,skel) = 
+    unlines (concatMap hCatTypeGADT skel)
+    +++++
+    "data Tree :: * -> * where" ++++ unlines (concatMap (map ("  "++) . hDatatypeGADT) skel)
+
+hCatTypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String]
+hCatTypeGADT (cat,rules)
+    = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_",
+       "data"+++gId cat++"_"]
+
+hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String]
+hDatatypeGADT (cat, rules) 
+    | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
+    | otherwise =
+        [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ]
+  where t = "Tree" +++ gId cat ++ "_"
+
+
+----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
+hInstance m (cat,[]) = "" 
+hInstance m (cat,rules) 
+ | isListCat (cat,rules) =
+  "instance Gf" +++ gId cat +++ "where" ++++
+     " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" 
+           +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
+     " gf (" ++ gId cat +++ "(x:xs)) = " 
+           ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] 
+-- no show for GADTs
+--     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" 
+ | otherwise =
+  "instance Gf" +++ gId cat +++ "where" ++
+  (if length rules == 1 then "" else "\n") +++
+  foldr1 (\x y -> x ++ "\n" +++ y) [mkInst f xx | (f,xx) <- rules]
+ where
+   ec = elemCat cat
+   baseVars = mkVars (baseSize (cat,rules))
+   mkInst f xx = let xx' = mkVars (length xx) in "gf " ++
+     (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
+     "=" +++ mkRHS f xx'
+   mkVars n = ["x" ++ show i | i <- [1..n]]
+   mkRHS f vars = "appqc \"" ++ m ++ "\" \"" ++ f ++ "\"" +++ 
+		   "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
+
+
+----fInstance m ("Cn",_) = "" ---
+fInstance m (cat,[]) = ""
+fInstance m (cat,rules) =
+  "instance Fg" +++ gId cat +++ "where" ++++
+  " fg t =" ++++
+  "  case termForm t of" ++++
+  foldr1 (\x y -> x ++ "\n" ++ y) [mkInst f xx | (f,xx) <- rules] ++++
+  "    _ -> error (\"no" +++ cat ++ " \" ++ prt t)"
+   where
+    mkInst f xx =
+     "    Ok ([], Q (IC \"" ++ m ++ "\") (IC \"" ++ f ++ "\")," ++
+     "[" ++ prTList "," xx' ++ "])" +++
+     "->" +++ mkRHS f xx'
+       where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
+	     mkRHS f vars 
+		 | isListCat (cat,rules) =
+		     if "Base" `isPrefixOf` f then
+			gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
+		      else
+                       let (i,t) = (init vars,last vars)
+                        in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++ 
+                          gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"]))
+		 | otherwise = 
+		     gId f +++  
+		     prTList " " [prParenth ("fg" +++ x) | x <- vars]
+
+composInstance :: (String,HSkeleton) -> String
+composInstance (_,skel) = unlines $
+    ["instance Compos Tree where",
+     "  compos f t = case t of"]
+    ++ map ("      "++) (concatMap prComposCat skel
+                         ++ if not allRecursive then ["_ -> pure t"] else [])
+    where
+    prComposCat c@(cat, fs) 
+        | isListCat c = [gId cat +++ "xs" +++ "->" 
+                         +++ "pure" +++ gId cat +++ "<*> traverse f" +++ "xs"]
+        | otherwise = concatMap (prComposFun cat) fs
+    prComposFun :: OIdent -> (OIdent,[OIdent]) -> [String]
+    prComposFun cat c@(fun,args) 
+	| any isTreeType args = [gId fun +++ unwords vars +++ "->" +++ rhs]
+        | otherwise = []
+      where vars = ["x" ++ show n | n <- [1..length args]]
+            rhs = "pure" +++ gId fun +++ unwords (zipWith prRec vars args)
+	        where prRec var typ
+                          | not (isTreeType typ) = "<*>" +++ "pure" +++ var
+			  | otherwise = "<*>" +++ "f" +++ var
+    allRecursive = and [any isTreeType args | (_,fs) <- skel, (_,args) <- fs] 
+    isTreeType cat = cat `elem` (map fst skel ++ builtin)
+    isList cat = case filter ((==cat) . fst) skel of
+                   [] -> error $ "Unknown cat " ++ show cat
+                   x:_ -> isListCat x
+    builtin = ["GString", "GInt", "GFloat"]
+
+showInstanceGADT :: (String,HSkeleton) -> String
+showInstanceGADT (_,skel) = unlines $
+            ["instance Show (Tree c) where",
+	     "  showsPrec n t = case t of"]
+	     ++ map ("    "++) (concatMap prShowCat skel)
+	     ++ ["   where opar n = if n > 0 then showChar '(' else id",
+	         "         cpar n = if n > 0 then showChar ')' else id"]
+  where 
+  prShowCat c@(cat, fs)
+      | isListCat c = [gId cat +++ "xs" +++ "->" +++ "showList" +++ "xs"]
+      | otherwise = map (prShowFun cat) fs
+  prShowFun :: OIdent -> (OIdent,[OIdent]) -> String
+  prShowFun cat (fun,args) 
+      | null vars = gId fun +++ "->" +++ "showString" +++ show fun
+      | otherwise = gId fun +++ unwords vars +++ "->" 
+			     +++ "opar n . showString" +++ show fun
+			     +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | x <- vars]
+			     +++ ". cpar n"
+      where vars = ["x" ++ show n | n <- [1..length args]]
+
+hSkeleton :: GFC.CanonGrammar -> (String,HSkeleton)
+hSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where
+  collectR rr hh =
+   case rr of
+     (fun,typ):rs -> case catSkeleton typ of
+        Ok (cats,cat) -> 
+             collectR rs (updateSkeleton (symid (snd cat)) hh (fun,
+	                                                    map (symid . snd) cats))
+        _ -> collectR rs hh
+     _ -> hh
+  cats =  [symid cat | (cat,GFC.AbsCat _ _) <- defs]
+  rules = [(symid fun, typ) | (fun,GFC.AbsFun typ _) <- defs]
+
+  defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m]
+  name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m]
+
+updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
+updateSkeleton cat skel rule =
+ case skel of
+   (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr
+   (cat0,rules):rr               -> (cat0, rules) : updateSkeleton cat rr rule
+   _ -> error $ cat ++ ": updating empty skeleton with" +++ show rule
+
+isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
+isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
+		    && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
+    where c = elemCat cat
+	  fs = map fst rules
+
+-- | Gets the element category of a list category.
+elemCat :: OIdent -> OIdent
+elemCat = drop 4
+
+isBaseFun :: OIdent -> Bool
+isBaseFun f = "Base" `isPrefixOf` f
+
+isConsFun :: OIdent -> Bool
+isConsFun f = "Cons" `isPrefixOf` f
+
+baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int
+baseSize (_,rules) = length bs
+    where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules

src-2.9/GF/API/GrammarToTransfer.hs

@@ -0,0 +1,94 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GrammarToTransfer
+-- Maintainer  : Björn Bringert
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/17 12:39:07 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- Creates a data type definition in the transfer language
+-- for an abstract module.
+-----------------------------------------------------------------------------
+
+module GF.API.GrammarToTransfer (grammar2transfer) where
+
+import qualified GF.Canon.GFC as GFC
+import qualified GF.Grammar.Abstract as A
+import GF.Grammar.Macros
+
+import GF.Infra.Modules
+import GF.Data.Operations
+
+import Transfer.Syntax.Abs as S
+import Transfer.Syntax.Print
+
+
+-- | the main function
+grammar2transfer :: GFC.CanonGrammar -> String
+grammar2transfer gr = printTree $ S.Module imports decls
+  where
+  cat = S.Ident "Cat" -- FIXME
+  tree = S.Ident "Tree" -- FIXME
+  defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m]
+  -- get category name and context
+  cats = [(cat, c) | (cat,GFC.AbsCat c _) <- defs]
+  -- get function name and type
+  funs = [(fun, typ) | (fun,GFC.AbsFun typ _) <- defs]
+  name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m]
+  imports = [Import (S.Ident "prelude")]
+  decls = [cats2cat cat tree cats, funs2tree cat tree funs] ++ instances tree
+
+
+-- | Create a declaration of the type of categories given a list
+--   of category names and their contexts.
+cats2cat :: S.Ident -- ^ the name of the Cat type
+         -> S.Ident -- ^ the name of the Tree type
+         -> [(A.Ident,A.Context)] -> Decl
+cats2cat cat tree = S.DataDecl cat S.EType . map (uncurry catCons)
+  where
+  catCons i c = S.ConsDecl (id2id i) (catConsType c)
+  catConsType = foldr pi (S.EVar cat)
+  pi (i,x) t = mkPi (id2pv i) (addTree tree $ term2exp x) t
+
+funs2tree :: S.Ident -- ^ the name of the Cat type
+          -> S.Ident -- ^ the name of the Tree type
+          -> [(A.Ident,A.Type)] -> Decl
+funs2tree cat tree = 
+    S.DataDecl tree (S.EPiNoVar (S.EVar cat) S.EType) . map (uncurry funCons)
+  where 
+  funCons i t = S.ConsDecl (id2id i) (addTree tree $ term2exp t)
+
+term2exp :: A.Term -> S.Exp
+term2exp t = case t of
+  A.Vr i         -> S.EVar (id2id i)
+  A.App t1 t2    -> S.EApp (term2exp t1) (term2exp t2)
+  A.Abs i t1     -> S.EAbs (id2pv i) (term2exp t1)
+  A.Prod i t1 t2 -> mkPi (id2pv i) (term2exp t1) (term2exp t2)
+  A.Q m i        -> S.EVar (id2id i)
+  _ -> error $ "term2exp: can't handle " ++ show t
+
+mkPi :: S.VarOrWild -> S.Exp -> S.Exp -> S.Exp 
+mkPi VWild t e = S.EPiNoVar t e
+mkPi v     t e = S.EPi v t e
+
+id2id :: A.Ident -> S.Ident
+id2id = S.Ident . symid
+
+id2pv :: A.Ident -> S.VarOrWild
+id2pv i = case symid i of
+                       "h_" -> S.VWild -- FIXME: hacky?
+                       x    -> S.VVar (S.Ident x)
+
+-- FIXME: I think this is not general enoguh.
+addTree :: S.Ident -> S.Exp -> S.Exp
+addTree tree x = case x of
+  S.EPi i t e -> S.EPi i (addTree tree t) (addTree tree e)
+  S.EPiNoVar t e -> S.EPiNoVar (addTree tree t) (addTree tree e)
+  e -> S.EApp (S.EVar tree) e
+
+instances :: S.Ident -> [S.Decl]
+instances tree = [DeriveDecl (S.Ident "Eq") tree, 
+                  DeriveDecl (S.Ident "Compos") tree]

src-2.9/GF/API/IOGrammar.hs

@@ -0,0 +1,96 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : IOGrammar
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/14 16:03:40 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.20 $
+--
+-- for reading grammars and terms from strings and files
+-----------------------------------------------------------------------------
+
+module GF.API.IOGrammar (shellStateFromFiles,
+		  getShellStateFromFiles) where
+
+import GF.Grammar.Abstract
+import qualified GF.Canon.GFC as GFC
+import GF.Compile.PGrammar
+import GF.Grammar.TypeCheck
+import GF.Compile.Compile
+import GF.Compile.ShellState
+import GF.Compile.NoParse
+import GF.Probabilistic.Probabilistic
+import GF.UseGrammar.Treebank
+
+import GF.Infra.Modules
+import GF.Infra.ReadFiles (isOldFile)
+import GF.Infra.Option
+import GF.Data.Operations
+import GF.Infra.UseIO
+import GF.System.Arch
+
+import qualified Transfer.InterpreterAPI as T
+
+import Control.Monad (liftM)
+import System.FilePath
+
+-- | a heuristic way of renaming constants is used
+string2absTerm :: String -> String -> Term 
+string2absTerm m = renameTermIn m . pTrm
+
+renameTermIn :: String -> Term -> Term
+renameTermIn m = refreshMetas [] . rename [] where
+  rename vs t = case t of
+    Abs x b -> Abs x (rename (x:vs) b)
+    Vr c    -> if elem c vs then t else Q (zIdent m) c
+    App f a -> App (rename vs f) (rename vs a)
+    _ -> t
+
+string2annotTree :: GFC.CanonGrammar -> Ident -> String -> Err Tree
+string2annotTree gr m = annotate gr . string2absTerm (prt m) ---- prt
+
+----string2paramList :: ConcreteST -> String -> [Term]
+---string2paramList st = map (renameTrm (lookupConcrete st) . patt2term) . pPattList
+
+shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState
+shellStateFromFiles opts st file = do
+ ign <- ioeIO $ getNoparseFromFile opts file
+ let top = identC $ justModuleName file
+ sh <- case takeExtensions file of
+  ".trc" -> do
+     env <- ioeIO $ T.loadFile file
+     return $ addTransfer (top,env) st
+  ".gfcm" -> do
+     cenv <- compileOne opts (compileEnvShSt st []) file
+     ioeErr $ updateShellState opts ign Nothing st cenv
+  s | elem s [".cf",".ebnf"] -> do
+     let osb = addOptions (options []) opts
+     grts <- compileModule osb st file
+     ioeErr $ updateShellState opts ign Nothing st grts
+  s | oElem (iOpt "treebank") opts -> do
+     tbs <- ioeIO $ readUniTreebanks file
+     return $ addTreebanks tbs st
+  _ -> do
+     b <- ioeIO $ isOldFile file
+     let opts' = if b then (addOption showOld opts) else opts
+
+     let osb = if oElem showOld opts' 
+                 then addOptions (options []) opts' -- for old no emit
+                 else addOptions (options [emitCode]) opts'
+     grts <- compileModule osb st file
+     let mtop = if oElem showOld opts' then Nothing else Just top
+     ioeErr $ updateShellState opts' ign mtop st grts
+ if (isSetFlag opts probFile || oElem (iOpt "prob") opts)
+       then do 
+         probs <- ioeIO $ getProbsFromFile opts file
+         let lang = maybe top id $ concrete sh --- to work with cf, too
+         ioeErr $ addProbs (lang,probs) sh
+       else return sh
+
+getShellStateFromFiles :: Options -> FilePath -> IO ShellState
+getShellStateFromFiles os = 
+  useIOE emptyShellState . 
+  shellStateFromFiles os emptyShellState

src-2.9/GF/API/MyParser.hs

@@ -0,0 +1,25 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MyParser
+-- Maintainer  : Peter Ljunglöf
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:07 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- template to define your own parser (obsolete?)
+-----------------------------------------------------------------------------
+
+module GF.API.MyParser (myParser) where
+
+import GF.Compile.ShellState
+import GF.CF.CFIdent
+import GF.CF.CF
+import GF.Data.Operations
+
+-- type CFParser = [CFTok] -> ([(CFTree,[CFTok])],String)
+
+myParser :: StateGrammar -> CFCat -> CFParser
+myParser gr cat toks = ([],"Would you like to add your own parser?")

src-2.9/GF/CF/CF.hs

@@ -0,0 +1,213 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CF
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:07 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- context-free grammars. AR 15\/12\/1999 -- 30\/3\/2000 -- 2\/6\/2001 -- 3\/12\/2001
+-----------------------------------------------------------------------------
+
+module GF.CF.CF (-- * Types
+	   CF(..), CFRule, CFRuleGroup, 
+	   CFItem(..), CFTree(..), CFPredef, CFParser,
+	   RegExp(..), CFWord,
+	   -- * Functions
+	   cfParseResults,
+	   -- ** to construct CF grammars
+	   emptyCF, emptyCFPredef, rules2CF, groupCFRules,
+	   -- ** to construct rules
+	   atomCFRule, atomCFTerm, atomRegExp, altsCFTerm,
+	   -- ** to construct trees
+	   atomCFTree, buildCFTree,
+	   -- ** to decide whether a token matches a terminal item
+	   matchCFTerm, satRegExp,
+	   -- ** to analyse a CF grammar
+	   catsOfCF, rulesOfCF, ruleGroupsOfCF, rulesForCFCat, 
+	   valCatCF, valItemsCF, valFunCF, 
+	   startCat, predefOfCF, appCFPredef, valCFItem,
+	   cfTokens, wordsOfRegExp, forCFItem, 
+	   isCircularCF, predefRules
+	  ) where
+
+import GF.Data.Operations
+import GF.Data.Str
+import GF.Canon.AbsGFC
+import GF.Canon.GFC
+import GF.CF.CFIdent
+import Data.List (nub,nubBy)
+import Data.Char (isUpper, isLower, toUpper, toLower)
+
+-- CF grammar data types
+
+-- | abstract type CF. 
+-- Invariant: each category has all its rules grouped with it 
+--      also: the list is never empty (the category is just missing then)
+newtype CF  = CF ([CFRuleGroup], CFPredef) 
+type CFRule = (CFFun, (CFCat, [CFItem]))
+type CFRuleGroup = (CFCat,[CFRule])
+
+-- | CFPredef is a hack for variable symbols and literals; normally = @const []@
+data CFItem = CFTerm RegExp | CFNonterm CFCat deriving (Eq, Ord,Show)
+
+newtype CFTree = CFTree (CFFun,(CFCat, [CFTree])) deriving (Eq, Show)
+
+-- | recognize literals, variables, etc
+type CFPredef  = CFTok -> [(CFCat, CFFun)]
+
+-- | Wadler style + return information
+type CFParser = [CFTok] -> ([(CFTree,[CFTok])],String)
+
+cfParseResults :: ([(CFTree,[CFTok])],String) -> [CFTree]
+cfParseResults rs = [b | (b,[]) <- fst rs]
+
+-- | terminals are regular expressions on words; to be completed to full regexp
+data RegExp = 
+    RegAlts [CFWord]         -- ^ list of alternative words
+  | RegSpec CFTok            -- ^ special token
+  deriving (Eq, Ord, Show)
+
+type CFWord = String
+
+-- the above types should be kept abstract, and the following functions used
+
+-- to construct CF grammars
+
+emptyCF :: CF
+emptyCF = CF ([], emptyCFPredef)
+
+emptyCFPredef :: CFPredef
+emptyCFPredef = const []
+
+rules2CF :: [CFRule] -> CF
+rules2CF rs = CF (groupCFRules rs, emptyCFPredef)
+
+groupCFRules :: [CFRule] -> [(CFCat,[CFRule])]
+groupCFRules = foldr ins [] where
+  ins rule crs = case crs of
+    (c,r) : rs | compatCF c cat -> (c,rule:r) : rs
+    cr    : rs            -> cr         : ins rule rs
+    _                     -> [(cat,[rule])]
+   where
+     cat = valCatCF rule
+
+-- to construct rules
+
+-- | make a rule from a single token without constituents
+atomCFRule :: CFCat -> CFFun -> CFTok -> CFRule
+atomCFRule c f s = (f, (c, [atomCFTerm s]))
+
+-- | usual terminal
+atomCFTerm :: CFTok -> CFItem 
+atomCFTerm = CFTerm . atomRegExp
+
+atomRegExp :: CFTok -> RegExp
+atomRegExp t = case t of
+  TS s -> RegAlts [s] 
+  _    -> RegSpec t
+
+-- | terminal consisting of alternatives
+altsCFTerm :: [String] -> CFItem 
+altsCFTerm = CFTerm . RegAlts
+
+
+-- to construct trees
+
+-- | make a tree without constituents
+atomCFTree :: CFCat -> CFFun -> CFTree
+atomCFTree c f = buildCFTree c f []
+
+-- | make a tree with constituents. 
+buildCFTree :: CFCat -> CFFun -> [CFTree] -> CFTree
+buildCFTree c f trees = CFTree (f,(c,trees))
+
+{- ----
+cfMeta0 :: CFTree
+cfMeta0 = atomCFTree uCFCat metaCFFun
+
+-- used in happy
+litCFTree :: String -> CFTree --- Maybe CFTree
+litCFTree s = maybe cfMeta0 id $ do
+  (c,f) <- getCFLiteral s
+  return $ buildCFTree c f []
+-}
+
+-- to decide whether a token matches a terminal item
+
+matchCFTerm :: CFItem -> CFTok -> Bool
+matchCFTerm (CFTerm t) s = satRegExp t s
+matchCFTerm _ _ = False
+
+satRegExp :: RegExp -> CFTok -> Bool
+satRegExp r t = case (r,t) of 
+  (RegAlts tt, TS s) -> elem s tt
+  (RegAlts tt, TC s) -> or [elem s' tt | s' <- caseUpperOrLower s]
+  (RegSpec x,  _)    -> t == x ---
+  _ -> False
+ where
+   caseUpperOrLower s = case s of
+     c:cs | isUpper c -> [s, toLower c : cs]
+     c:cs | isLower c -> [s, toUpper c : cs]
+     _ -> [s]
+
+-- to analyse a CF grammar
+
+catsOfCF :: CF -> [CFCat]
+catsOfCF (CF (rr,_)) = map fst rr 
+
+rulesOfCF :: CF -> [CFRule]
+rulesOfCF (CF (rr,_)) = concatMap snd rr
+
+ruleGroupsOfCF :: CF -> [(CFCat,[CFRule])]
+ruleGroupsOfCF (CF (rr,_)) = rr
+
+rulesForCFCat :: CF -> CFCat -> [CFRule]
+rulesForCFCat (CF (rr,_)) cat = maybe [] id $ lookup cat rr
+
+valCatCF :: CFRule -> CFCat
+valCatCF (_,(c,_)) = c
+
+valItemsCF :: CFRule -> [CFItem]
+valItemsCF (_,(_,i)) = i
+
+valFunCF :: CFRule -> CFFun
+valFunCF  (f,(_,_)) = f
+
+startCat :: CF -> CFCat
+startCat (CF (rr,_)) = fst (head rr) --- hardly useful
+
+predefOfCF :: CF -> CFPredef
+predefOfCF (CF (_,f)) = f
+
+appCFPredef :: CF -> CFTok -> [(CFCat, CFFun)]
+appCFPredef = ($) . predefOfCF
+
+valCFItem :: CFItem -> Either RegExp CFCat
+valCFItem (CFTerm r)     = Left r
+valCFItem (CFNonterm nt) = Right nt
+
+cfTokens :: CF -> [CFWord]
+cfTokens cf = nub $ concat $ [ wordsOfRegExp i | r <- rulesOfCF cf, 
+                                                 CFTerm i <- valItemsCF r]
+
+wordsOfRegExp :: RegExp -> [CFWord]
+wordsOfRegExp (RegAlts tt) = tt
+wordsOfRegExp _ = []
+
+forCFItem :: CFTok -> CFRule -> Bool
+forCFItem a (_,(_, CFTerm r : _)) = satRegExp r a
+forCFItem _ _ = False
+
+-- | we should make a test of circular chains, too
+isCircularCF :: CFRule -> Bool
+isCircularCF (_,(c', CFNonterm c:[])) = compatCF c' c
+isCircularCF _ = False
+
+-- | coercion to the older predef cf type
+predefRules :: CFPredef -> CFTok -> [CFRule]
+predefRules pre s = [atomCFRule c f s | (c,f) <- pre s]
+

src-2.9/GF/CF/CFIdent.hs

@@ -0,0 +1,253 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CFIdent
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/14 16:03:40 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.13 $
+--
+-- symbols (categories, functions) for context-free grammars.
+-----------------------------------------------------------------------------
+
+module GF.CF.CFIdent (-- * Tokens and categories
+		CFTok(..), CFCat(..),
+		tS, tC, tL, tI, tF, tV, tM, tInt,
+		prCFTok,
+		-- * Function names and profiles
+		CFFun(..), Profile,
+		wordsCFTok,
+		-- * CF Functions
+		mkCFFun, varCFFun, consCFFun, string2CFFun, stringCFFun, 
+                intCFFun, floatCFFun, dummyCFFun,
+		cfFun2String, cfFun2Ident, cfFun2Profile, metaCFFun,
+		-- * CF Categories
+		mkCIdent, ident2CFCat, labels2CFCat, string2CFCat, 
+                catVarCF, cat2CFCat, cfCatString, cfCatInt,cfCatFloat,
+		moduleOfCFCat, cfCat2Cat, cfCat2Ident, lexCFCat,
+		-- * CF Tokens
+		string2CFTok, str2cftoks,
+		-- * Comparisons
+		compatToks, compatTok, compatCFFun, compatCF,
+                wordsLits
+	       ) where
+
+import GF.Data.Operations
+import GF.Canon.GFC
+import GF.Infra.Ident
+import GF.Grammar.Values (cPredefAbs)
+import GF.Canon.AbsGFC
+import GF.Grammar.Macros (ident2label)
+import GF.Grammar.PrGrammar
+import GF.Data.Str
+import Data.Char (toLower, toUpper, isSpace)
+import Data.List (intersperse)
+
+-- | this type should be abstract
+data CFTok = 
+   TS String     -- ^ normal strings
+ | TC String     -- ^ strings that are ambiguous between upper or lower case
+ | TL String     -- ^ string literals
+ | TI Integer    -- ^ integer literals
+ | TF Double     -- ^ float literals
+ | TV Ident      -- ^ variables
+ | TM Int String -- ^ metavariables; the integer identifies it
+  deriving (Eq, Ord, Show)
+
+-- | this type should be abstract
+newtype CFCat = CFCat (CIdent,Label) deriving (Eq, Ord, Show)
+
+tS :: String -> CFTok
+tC :: String -> CFTok
+tL :: String -> CFTok
+tI :: String -> CFTok
+tF :: String -> CFTok
+tV :: String -> CFTok
+tM :: String -> CFTok
+
+tS  = TS
+tC  = TC
+tL  = TL
+tI  = TI . read 
+tF  = TF . read 
+tV  = TV . identC
+tM  = TM 0
+
+tInt :: Integer -> CFTok
+tInt = TI
+
+prCFTok :: CFTok -> String
+prCFTok t = case t of
+  TS s -> s
+  TC s -> s
+  TL s -> s
+  TI i -> show i
+  TF i -> show i
+  TV x -> prt x
+  TM i m -> m --- "?" --- m
+
+-- | to build trees: the Atom contains a GF function, @Cn | Meta | Vr | Literal@
+newtype CFFun = CFFun (Atom, Profile) deriving (Eq,Ord,Show) 
+-- - - - - - - - - - - - - - - - - - - - -         ^^^ added by peb, 21/5-04 
+
+type Profile  = [([[Int]],[Int])]
+
+wordsCFTok :: CFTok -> [String]
+wordsCFTok t = case t of
+  TC (c:cs) -> [c':cs | c' <- [toUpper c, toLower c]]
+  _ -> [prCFTok t]
+
+-- the following functions should be used instead of constructors
+
+-- to construct CF functions
+
+mkCFFun :: Atom -> CFFun
+mkCFFun t = CFFun (t,[])
+
+varCFFun :: Ident -> CFFun
+varCFFun = mkCFFun . AV
+
+consCFFun :: CIdent -> CFFun
+consCFFun = mkCFFun . AC
+
+-- | standard way of making cf fun
+string2CFFun :: String -> String -> CFFun
+string2CFFun m c = consCFFun $ mkCIdent m c
+
+stringCFFun :: String -> CFFun 
+stringCFFun = mkCFFun . AS
+
+intCFFun :: Integer -> CFFun 
+intCFFun = mkCFFun . AI
+
+floatCFFun :: Double -> CFFun 
+floatCFFun = mkCFFun . AF
+
+-- | used in lexer-by-need rules
+dummyCFFun :: CFFun
+dummyCFFun = varCFFun $ identC "_"
+
+cfFun2String :: CFFun -> String
+cfFun2String (CFFun (f,_)) = prt f
+
+cfFun2Ident :: CFFun -> Ident
+cfFun2Ident (CFFun (f,_)) = identC $ prt_ f ---
+
+cfFun2Profile :: CFFun -> Profile
+cfFun2Profile (CFFun (_,p)) = p
+
+{- ----
+strPro2cfFun :: String -> Profile -> CFFun
+strPro2cfFun str p = (CFFun (AC (Ident str), p))
+-}
+
+metaCFFun :: CFFun
+metaCFFun = mkCFFun $ AM 0
+
+-- to construct CF categories
+
+-- | belongs elsewhere
+mkCIdent :: String -> String -> CIdent
+mkCIdent m c = CIQ (identC m) (identC c)
+
+ident2CFCat :: CIdent -> Ident -> CFCat
+ident2CFCat mc d = CFCat (mc, L d)
+
+labels2CFCat :: CIdent -> [Label] -> CFCat
+labels2CFCat mc d = CFCat (mc, L (identC (concat (intersperse "." (map prt d))))) ----
+
+-- | standard way of making cf cat: label s
+string2CFCat :: String -> String -> CFCat
+string2CFCat m c = ident2CFCat (mkCIdent m c) (identC "s")
+
+idents2CFCat :: Ident -> Ident -> CFCat
+idents2CFCat m c = ident2CFCat (CIQ m c) (identC "s")
+
+catVarCF :: CFCat
+catVarCF = ident2CFCat (mkCIdent "_" "#Var") (identC "_") ----
+
+cat2CFCat :: (Ident,Ident) -> CFCat
+cat2CFCat = uncurry idents2CFCat
+
+-- | literals
+cfCatString :: CFCat
+cfCatString = string2CFCat (prt cPredefAbs) "String"
+
+cfCatInt, cfCatFloat :: CFCat
+cfCatInt = string2CFCat (prt cPredefAbs) "Int"
+cfCatFloat = string2CFCat (prt cPredefAbs) "Float"
+
+
+
+{- ----
+uCFCat :: CFCat
+uCFCat = cat2CFCat uCat
+-}
+
+moduleOfCFCat :: CFCat -> Ident
+moduleOfCFCat (CFCat (CIQ m _, _)) = m
+
+-- | the opposite direction
+cfCat2Cat :: CFCat -> (Ident,Ident)
+cfCat2Cat (CFCat (CIQ m c,_)) = (m,c)
+
+cfCat2Ident :: CFCat -> Ident
+cfCat2Ident = snd . cfCat2Cat
+
+lexCFCat :: CFCat -> CFCat
+lexCFCat cat = ident2CFCat (uncurry CIQ (cfCat2Cat cat)) (identC "*")
+
+-- to construct CF tokens
+
+string2CFTok :: String -> CFTok
+string2CFTok = tS
+
+str2cftoks :: Str -> [CFTok]
+str2cftoks = map tS . wordsLits . sstr
+
+-- decide if two token lists look the same (in parser postprocessing)
+
+compatToks :: [CFTok] -> [CFTok] -> Bool
+compatToks ts us = and [compatTok t u | (t,u) <- zip ts us]
+
+compatTok :: CFTok -> CFTok -> Bool
+compatTok (TM _ _) _ = True --- hack because metas are renamed
+compatTok _ (TM _ _) = True
+compatTok t u = any (`elem` (alts t)) (alts u) where
+  alts u = case u of
+    TC (c:s) -> [toLower c : s, toUpper c : s]
+    TL s -> [s, prQuotedString s]
+    _ -> [prCFTok u]
+
+-- | decide if two CFFuns have the same function head (profiles may differ)
+compatCFFun :: CFFun -> CFFun -> Bool
+compatCFFun (CFFun (f,_)) (CFFun (g,_)) = f == g
+
+-- | decide whether two categories match
+-- the modifiers can be from different modules, but on the same extension
+-- path, so there is no clash, and they can be safely ignored ---
+compatCF :: CFCat -> CFCat -> Bool
+----compatCF = (==)
+compatCF (CFCat (CIQ _ c, l)) (CFCat (CIQ _ c', l')) = c==c' && l==l'
+
+-- | Like 'words', but does not split on whitespace inside
+--   double quotes.wordsLits :: String -> [String]
+-- Also treats escaped quotes in quotes (AR 21/12/2005) by breaks
+-- instead of break
+wordsLits [] = []
+wordsLits (c:cs) | isSpace c = wordsLits (dropWhile isSpace cs)
+		 | isQuote c
+		     = let (l,rs) = breaks (==c) cs
+			   rs' = drop 1 rs
+			   in ([c]++l++[c]):wordsLits rs'
+		 | otherwise = let (w,rs) = break isSpaceQ cs
+				   in (c:w):wordsLits rs
+  where
+    breaks c cs = case break c cs of
+      (l@(_:_),d:rs) | last l == '\\' -> 
+        let (r,ts) = breaks c rs in (l++[d]++r, ts)
+      v -> v
+    isQuote c = elem c "\"'" 
+    isSpaceQ c = isSpace c ---- || isQuote c

src-2.9/GF/CF/CFtoGrammar.hs

@@ -0,0 +1,62 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CFtoGrammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:09 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.7 $
+--
+-- 26\/1\/2000 -- 18\/4 -- 24\/3\/2004
+-----------------------------------------------------------------------------
+
+module GF.CF.CFtoGrammar (cf2grammar) where
+
+import GF.Infra.Ident
+import GF.Grammar.Grammar
+import qualified GF.Source.AbsGF as A
+import qualified GF.Source.GrammarToSource as S
+import GF.Grammar.Macros
+
+import GF.CF.CF
+import GF.CF.CFIdent
+import GF.CF.PPrCF
+
+import GF.Data.Operations
+
+import Data.List (nub)
+import Data.Char (isSpace)
+
+cf2grammar :: CF -> [A.TopDef]
+cf2grammar cf = concatMap S.trAnyDef (abs ++ conc) where
+  rules = rulesOfCF cf
+  abs   = cats ++ funs
+  conc  = lintypes ++ lins
+  cats  = [(cat, AbsCat (yes []) (yes [])) | 
+             cat <- nub (concat (map cf2cat rules))] ----notPredef cat
+  lintypes = [(cat, CncCat (yes defLinType) nope nope) | (cat,AbsCat _ _) <- cats]
+  (funs,lins) = unzip (map cf2rule rules)
+
+cf2cat :: CFRule -> [Ident]
+cf2cat (_,(cat, items)) = map cfCat2Ident $ cat : [c | CFNonterm c <- items]
+
+cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
+cf2rule (fun, (cat, items)) = (def,ldef) where
+ f     = cfFun2Ident fun
+ def   = (f, AbsFun (yes (mkProd (args', Cn (cfCat2Ident cat), []))) nope)
+ args0 = zip (map (mkIdent "x") [0..]) items
+ args  = [(v, Cn (cfCat2Ident c)) | (v, CFNonterm c) <- args0]
+ args' = [(zIdent "_", Cn (cfCat2Ident c)) | (_, CFNonterm c) <- args0]
+ ldef  = (f, CncFun 
+               Nothing 
+               (yes (mkAbs (map fst args) 
+                      (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)])))
+               nope)
+ mkIt (v, CFNonterm _) = P (Vr v) theLinLabel
+ mkIt (_, CFTerm (RegAlts [a])) = K a
+ mkIt _ = K "" --- regexp not recognized in input CF ; use EBNF for this
+ foldconcat [] = K ""
+ foldconcat tt = foldr1 C tt
+

src-2.9/GF/CF/CanonToCF.hs

@@ -0,0 +1,214 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CanonToCF
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/14 16:03:41 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.15 $
+--
+-- AR 27\/1\/2000 -- 3\/12\/2001 -- 8\/6\/2003 
+-----------------------------------------------------------------------------
+
+module GF.CF.CanonToCF (canon2cf) where
+
+import GF.System.Tracing -- peb 8/6-04
+
+import GF.Data.Operations
+import GF.Infra.Option
+import GF.Infra.Ident
+import GF.Canon.AbsGFC
+import GF.Grammar.LookAbs (allBindCatsOf)
+import GF.Canon.GFC
+import GF.Grammar.Values (isPredefCat,cPredefAbs)
+import GF.Grammar.PrGrammar
+import GF.Canon.CMacros
+import qualified GF.Infra.Modules as M
+import GF.CF.CF
+import GF.CF.CFIdent
+import GF.UseGrammar.Morphology
+import GF.Data.Trie2
+import Data.List (nub,partition)
+import Control.Monad
+
+-- | The main function: for a given cnc module 'm', build the CF grammar with all the
+-- rules coming from modules that 'm' extends. The categories are qualified by
+-- the abstract module name 'a' that 'm' is of.
+-- The ign argument tells what rules not to generate a parser for.
+canon2cf :: Options -> (Ident -> Bool) -> CanonGrammar -> Ident -> Err CF
+canon2cf opts ign gr c = tracePrt "#size of CF" (err id (show.length.rulesOfCF)) $ do -- peb 8/6-04
+  let ms = M.allExtends gr c
+  a <- M.abstractOfConcrete gr c
+  let cncs = [m | (n, M.ModMod m) <- M.modules gr, elem n ms]
+  let mms  = [(a, tree2list (M.jments m)) | m <- cncs]
+  cnc <- liftM M.jments $ M.lookupModMod gr c
+  rules0 <- liftM concat $ mapM (uncurry (cnc2cfCond opts ign cnc)) mms
+  let bindcats = map snd $ allBindCatsOf gr 
+  let rules = filter (not . isCircularCF) rules0 ---- temporarily here
+  let grules = groupCFRules rules
+  let predef = mkCFPredef opts bindcats grules
+  return $ CF predef
+
+cnc2cfCond :: Options -> (Ident -> Bool) -> BinTree Ident Info -> 
+              Ident -> [(Ident,Info)] -> Err [CFRule]
+cnc2cfCond opts ign cnc m gr = 
+  liftM concat $ 
+  mapM lin2cf [(m,fun,cat,args,lin) | 
+                 (fun, CncFun cat args lin _) <- gr, notign fun, is fun] 
+ where
+   is f = isInBinTree f cnc
+   notign = not . ign
+
+type IFun = Ident
+type ICat = CIdent
+
+-- | all CF rules corresponding to a linearization rule
+lin2cf :: (Ident, IFun, ICat, [ArgVar], Term) -> Err [CFRule]
+lin2cf (m,fun,cat,args,lin) = errIn ("building CF rule for" +++ prt fun) $ do
+  let rhss0 = allLinBranches lin          -- :: [([Label], Term)]
+  rhss1  <- mapM (mkCFItems m) rhss0    -- :: [([Label], [[PreCFItem]])]
+  mapM (mkCfRules m fun cat args) rhss1 >>= return . nub . concat
+
+-- | making sequences of CF items from every branch in a linearization
+mkCFItems :: Ident -> ([Label], Term) -> Err ([Label], [[PreCFItem]])
+mkCFItems m (labs,t) = do
+  items <- term2CFItems m t
+  return (labs, items)
+
+-- | making CF rules from sequences of CF items
+mkCfRules :: Ident -> IFun -> ICat -> [ArgVar] -> ([Label], [[PreCFItem]]) -> Err [CFRule]
+mkCfRules m fun cat args (lab, itss) = mapM mkOneRule itss
+ where
+  mkOneRule its = do
+    let nonterms = zip [0..] [(pos,d,v) | PNonterm _ pos d v <- its]
+        profile  = mkProfile nonterms
+	cfcat    = labels2CFCat (redirectIdent m cat) lab
+        cffun    = CFFun (AC (CIQ m fun), profile)
+        cfits    = map precf2cf its
+    return (cffun,(cfcat,cfits))
+  mkProfile nonterms = map mkOne args 
+    where
+      mkOne (A  c i) = mkOne (AB c 0 i)
+      mkOne (AB _ b i) = (map mkB [0..b-1], [k | (k,(j,_,True)) <- nonterms, j==i])
+        where
+          mkB x = [k | (k,(j, [LV y], False)) <- nonterms, j == i, y == x]
+
+-- | intermediate data structure of CFItems with information for profiles
+data PreCFItem = 
+    PTerm RegExp                         -- ^ like ordinary Terminal 
+  | PNonterm CIdent Integer [Label] Bool -- ^ cat, position, part\/bind, whether arg
+   deriving Eq                    
+
+precf2cf :: PreCFItem -> CFItem
+precf2cf (PTerm r) = CFTerm r
+precf2cf (PNonterm cm _ ls True) = CFNonterm (labels2CFCat cm ls)
+precf2cf (PNonterm _ _ _ False) = CFNonterm catVarCF
+
+
+-- | the main job in translating linearization rules into sequences of cf items 
+term2CFItems :: Ident -> Term -> Err [[PreCFItem]]
+term2CFItems m t = errIn "forming cf items" $ case t of
+   S c _ -> t2c c
+
+   T _ cc -> do
+     its  <- mapM t2c [t | Cas _ t <- cc]
+     tryMkCFTerm (concat its)
+   V _ cc -> do
+     its  <- mapM t2c [t | t <- cc]
+     tryMkCFTerm (concat its)
+
+   C t1 t2 -> do
+     its1 <- t2c t1
+     its2 <- t2c t2
+     return [x ++ y | x <- its1, y <- its2]
+
+   FV ts -> do
+     its <- mapM t2c ts
+     tryMkCFTerm (concat its)
+
+   P (S c _) _ -> t2c c --- w-around for bug in Compute? AR 31/1/2006
+
+   P arg s -> extrR arg s
+
+   K (KS s) -> return [[PTerm (RegAlts [s]) | not (null s)]]
+
+   E -> return [[]]
+
+   K (KP d vs) -> do
+     let its  =  [PTerm (RegAlts [s]) | s <- d]
+     let itss = [[PTerm (RegAlts [s]) | s <- t] | Var t _ <- vs]
+     tryMkCFTerm (its : itss)
+
+   _ -> return [] ---- prtBad "no cf for" t ----
+
+  where 
+
+    t2c = term2CFItems m
+
+    -- optimize the number of rules by a factorization
+    tryMkCFTerm :: [[PreCFItem]] -> Err [[PreCFItem]]  
+    tryMkCFTerm ii@(its:itss) | all (\x -> length x == length its) itss =
+      case mapM mkOne (counterparts ii) of
+        Ok tt -> return [tt]
+        _ -> return ii
+       where
+         mkOne cfits = case mapM mkOneTerm cfits of
+           Ok tt -> return $ PTerm (RegAlts (concat (nub tt)))
+           _ -> mkOneNonTerm cfits
+         mkOneTerm (PTerm (RegAlts t)) = return t
+         mkOneTerm _ = Bad ""
+         mkOneNonTerm (n@(PNonterm _ _ _ _) : cc) = 
+           if all (== n) cc 
+	      then return n
+	      else Bad ""
+         mkOneNonTerm _ = Bad ""
+         counterparts ll = [map (!! i) ll | i <- [0..length (head ll) - 1]]
+    tryMkCFTerm itss = return itss
+
+    extrR arg lab = case (arg0,labs) of
+      (Arg (A  cat pos),   [(LV _)]) -> return [[PNonterm (cIQ cat) pos labs False]]
+      (Arg (AB cat b pos), [(LV _)]) -> return [[PNonterm (cIQ cat) pos labs False]]
+      (Arg (A  cat pos),   _)  -> return [[PNonterm (cIQ cat) pos labs True]]
+      (Arg (AB cat b pos), _)  -> return [[PNonterm (cIQ cat) pos labs True]]
+                                     ---- ??
+      _   -> prtBad "cannot extract record field from" arg
+     where 
+       (arg0,labs) = headProj arg [lab]
+
+    headProj r ls = case r of
+      P r0 l0 -> headProj r0 (l0:ls)
+      S r0 _  -> headProj r0 ls
+      _ -> (r,ls)
+    cIQ c = if isPredefCat c then CIQ cPredefAbs c else CIQ m c
+
+mkCFPredef :: Options -> [Ident] -> [CFRuleGroup] -> ([CFRuleGroup],CFPredef)
+mkCFPredef opts binds rules = (ruls, \s -> preds0 s ++ look s) where
+  (ruls,preds) = if oElem lexerByNeed opts  -- option -cflexer
+                   then predefLexer rules 
+                   else (rules,emptyTrie)
+  preds0 s = 
+    [(cat,         metaCFFun)     | TM _ _ <- [s], cat <- cats] ++
+    [(cat,         varCFFun x)    | TV x   <- [s], cat <- catVarCF : bindcats] ++
+    [(cfCatString, stringCFFun t) | TL t   <- [s]]              ++
+    [(cfCatInt,    intCFFun t)    | TI t   <- [s]] ++
+    [(cfCatFloat,  floatCFFun t)  | TF t   <- [s]]
+  cats = nub [c | (_,rs) <- rules, (_,(_,its)) <- rs, CFNonterm c <- its]
+  bindcats = [c | c <- cats, elem (cfCat2Ident c) binds]
+  look = concatMap snd . map (trieLookup preds) . wordsCFTok --- for TC tokens
+
+--- TODO: integrate with morphology
+--- predefLexer :: [CFRuleGroup] -> ([CFRuleGroup],BinTree (CFTok,[(CFCat, CFFun)]))
+predefLexer groups = (reverse ruls, tcompile preds) where
+  (ruls,preds) = foldr mkOne ([],[]) groups
+  mkOne group@(cat,rules) (rs,ps) = (rule:rs,pre ++ ps) where
+    (rule,pre) = case partition isLexical rules of
+      ([],_) -> (group,[])
+      (ls,rest) -> ((cat,rest), concatMap mkLexRule ls)
+  isLexical (f,(c,its)) = case its of
+    [CFTerm (RegAlts ws)] -> True
+    _ -> False
+  mkLexRule r = case r of
+    (fun,(cat,[CFTerm (RegAlts ws)])) -> [(w, [(cat,fun)]) | w <- ws]
+    _ -> []

src-2.9/GF/CF/ChartParser.hs

@@ -0,0 +1,206 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ChartParser
+-- Maintainer  : Peter Ljunglöf
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:12 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.10 $
+--
+-- Bottom-up Kilbury chart parser from "Pure Functional Parsing", chapter 5.
+-- OBSOLETE -- should use new MCFG parsers instead 
+-----------------------------------------------------------------------------
+
+module GF.CF.ChartParser (chartParser) where
+
+-- import Tracing
+-- import PrintParser
+-- import PrintSimplifiedTerm
+
+import GF.Data.Operations
+import GF.CF.CF
+import GF.CF.CFIdent
+import GF.CF.PPrCF (prCFItem)
+
+import GF.Data.OrdSet
+import GF.Data.OrdMap2
+
+import Data.List (groupBy)
+
+type Token      = CFTok
+type Name       = CFFun
+type Category   = CFItem
+type Grammar    = ([Production], Terminal)
+type Production = (Name, Category, [Category])
+type Terminal   = Token -> [(Category, Maybe Name)]
+type GParser    = Grammar -> Category -> [Token] -> ([ParseTree],String)
+data ParseTree  = Node Name Category [ParseTree] | Leaf Token
+
+maxTake :: Int
+-- maxTake = 1000
+maxTake = maxBound
+
+--------------------------------------------------
+-- converting between GF parsing and CFG parsing
+
+buildParser :: GParser -> CF -> CFCat -> CFParser
+buildParser gparser cf = parse
+  where 
+    parse = \start input -> 
+            let parse2 = parse' (CFNonterm start) input in 
+	    (take maxTake [(parse2tree t, []) | t <- fst parse2], snd parse2) 
+    parse' = gparser (cf2grammar cf)
+
+cf2grammar :: CF -> Grammar
+cf2grammar cf = (productions, terminal)
+  where 
+    productions  = [ (name, CFNonterm cat, rhs) | 
+		     (name, (cat, rhs)) <- cfRules ]
+    terminal tok = [ (CFNonterm cat, Just name) |
+		     (cat, name) <- cfPredef tok ] 
+		   ++
+		   [ (item, Nothing) |
+		     item <- elems rhsItems,
+		     matchCFTerm item tok ]
+    cfRules  = rulesOfCF cf
+    cfPredef = predefOfCF cf
+    rhsItems :: Set Category
+    rhsItems = union [ makeSet rhs | (_, (_, rhs)) <- cfRules ]
+
+parse2tree :: ParseTree -> CFTree
+parse2tree (Node name (CFNonterm cat) trees) = CFTree (name, (cat, trees')) 
+  where
+    trees' = [ parse2tree t | t@(Node _ _ _) <- trees ]   -- ignore leafs
+
+maybeNode :: Maybe Name -> Category -> Token -> ParseTree
+maybeNode (Just name) cat tok = Node name cat [Leaf tok]
+maybeNode Nothing     _   tok = Leaf tok
+
+
+--------------------------------------------------
+-- chart parsing (bottom up kilbury-like)
+
+type Chart   = [CState]
+type CState  = Set Edge 
+type Edge    = (Int, Category, [Category])
+type Passive = (Int, Int, Category)
+
+chartParser :: CF -> CFCat -> CFParser
+chartParser = buildParser chartParser0
+
+chartParser0 :: GParser
+chartParser0 (productions, terminal) = cparse
+  where
+    emptyCats :: Set Category
+    emptyCats = empties emptySet
+      where 
+        empties cats | cats==cats' = cats
+		     | otherwise   = empties cats'
+	  where cats' = makeSet [ cat | (_, cat, rhs) <- productions,
+				        all (`elemSet` cats) rhs ]
+
+    grammarMap :: Map Category [(Name, [Category])]
+    grammarMap = makeMapWith (++) 
+		 [ (cat, [(name,rhs)]) | (name, cat, rhs) <- productions ]
+
+    leftCornerMap :: Map Category (Set (Category,[Category]))
+    leftCornerMap = makeMapWith (<++>) [ (a, unitSet (b, bs)) | 
+					 (_, b, abs) <- productions, 
+					 (a : bs) <- removeNullable abs ]
+
+    removeNullable :: [Category] -> [[Category]]
+    removeNullable [] = []
+    removeNullable cats@(cat:cats')
+	| cat `elemSet` emptyCats = cats : removeNullable cats'
+	| otherwise               = [cats]
+
+    cparse :: Category -> [Token] -> ([ParseTree], String)
+    cparse start input = -- trace "ChartParser" $
+			 case lookup (0, length input, start) $
+			      -- tracePrt "#edgeTrees" (prt . map (length.snd)) $
+			      edgeTrees of
+			   Just trees -> -- tracePrt "#trees" (prt . length . fst) $
+					 (trees, "Chart:" ++++ prChart passiveEdges)
+			   Nothing    -> ([],    "Chart:" ++++ prChart passiveEdges)
+      where 
+        finalChart :: Chart
+        finalChart = map buildState initialChart
+
+        finalChartMap :: [Map Category (Set Edge)]
+	finalChartMap = map stateMap finalChart
+
+        stateMap :: CState -> Map Category (Set Edge)
+	stateMap state = makeMapWith (<++>) [ (a, unitSet (i,b,bs)) |
+					      (i, b, a:bs) <- elems state ]
+
+        initialChart :: Chart
+        initialChart = -- tracePrt "#initialChart" (prt . map (length.elems)) $
+		       emptySet : map initialState (zip [0..] input)
+          where initialState (j, sym) = makeSet [ (j, cat, []) | 
+						  (cat, _) <- terminal sym ]
+
+        buildState :: CState -> CState
+	buildState = limit more
+	  where more (j, a, [])   = ordSet [ (j, b, bs) |
+				             (b, bs) <- elems (lookupWith emptySet leftCornerMap a) ]
+				    <++>
+				    lookupWith emptySet (finalChartMap !! j) a
+		more (j, b, a:bs) = ordSet [ (j, b, bs) |
+					     a `elemSet` emptyCats ]
+
+        passiveEdges :: [Passive]
+	passiveEdges = -- tracePrt "#passiveEdges" (prt . length) $
+		       [ (i, j, cat) |
+			 (j, state) <- zip [0..] $
+			   -- tracePrt "#passiveChart" 
+			   -- (prt . map (length.filter (\(_,_,x)->null x).elems)) $
+			   -- tracePrt "#activeChart" (prt . map (length.elems)) $
+			   finalChart,
+			 (i, cat, []) <- elems state ]
+		       ++
+		       [ (i, i, cat) |
+			 i <- [0 .. length input],
+			 cat <- elems emptyCats ]
+
+        edgeTrees :: [ (Passive, [ParseTree]) ]
+	edgeTrees = [ (edge, treesFor edge) | edge <- passiveEdges ]
+
+        edgeTreesMap :: Map (Int, Category) [(Int, [ParseTree])]
+	edgeTreesMap = makeMapWith (++) [ ((i,c), [(j,trees)]) |
+					  ((i,j,c), trees) <- edgeTrees ]
+
+        treesFor :: Passive -> [ParseTree]
+	treesFor (i, j, cat) = [ Node name cat trees |
+				 (name, rhs) <- lookupWith [] grammarMap cat,
+				 trees <- children rhs i j ]
+			       ++
+			       [ maybeNode name cat tok |
+				 i == j-1,
+				 let tok = input !! i,
+				 Just name <- [lookup cat (terminal tok)] ]
+
+        children :: [Category] -> Int -> Int -> [[ParseTree]]
+	children []     i k = [ [] | i == k ]
+	children (c:cs) i k = [ tree : rest |
+				i <= k,
+				(j, trees) <- lookupWith [] edgeTreesMap (i,c),
+				rest <- children cs j k,
+				tree <- trees ]
+
+
+{-
+instance Print ParseTree where
+    prt (Node name cat trees) = prt name++"."++prt cat++"^{"++prtSep "," trees++"}"
+    prt (Leaf token) = prt token
+-}
+
+-- AR 10/12/2002
+
+prChart :: [Passive] -> String
+prChart = unlines . map (unwords . map prOne) . positions where
+  prOne (i,j,it) = show i ++ "-" ++ show j ++ "-" ++ prCFItem it
+  positions = groupBy (\ (i,_,_) (j,_,_) -> i == j) 
+
+

src-2.9/GF/CF/EBNF.hs

@@ -0,0 +1,191 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : EBNF
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:13 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.5 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.CF.EBNF (pEBNFasGrammar) where
+
+import GF.Data.Operations
+import GF.Data.Parsers
+import GF.Infra.Comments
+import GF.CF.CF
+import GF.CF.CFIdent
+import GF.Grammar.Grammar
+import GF.Grammar.PrGrammar
+import GF.CF.CFtoGrammar
+import qualified GF.Source.AbsGF as A
+
+import Data.List (nub, partition)
+
+-- AR 18/4/2000 - 31/3/2004
+
+-- Extended BNF grammar with token type a
+-- put a = String for simple applications
+
+type EBNF = [ERule]
+type ERule = (ECat, ERHS)
+type ECat = (String,[Int])
+type ETok = String
+
+ebnfID = "EBNF" ---- make this parametric!
+
+data ERHS =
+   ETerm ETok
+ | ENonTerm ECat
+ | ESeq  ERHS ERHS
+ | EAlt  ERHS ERHS
+ | EStar ERHS
+ | EPlus ERHS
+ | EOpt  ERHS
+ | EEmpty
+
+type CFRHS = [CFItem]
+type CFJustRule = (CFCat, CFRHS)
+
+ebnf2gf :: EBNF -> [A.TopDef]
+ebnf2gf = cf2grammar . rules2CF . ebnf2cf
+
+ebnf2cf :: EBNF -> [CFRule]
+ebnf2cf ebnf = [(mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where
+  mkCFF i (CFCat (_,c), _) = string2CFFun ebnfID ("Mk" ++ prt c ++ "_" ++ show i)
+
+normEBNF :: EBNF -> [CFJustRule]
+normEBNF erules = let
+  erules1 = [normERule ([i],r) | (i,r) <- zip [0..] erules]
+  erules2 = erules1 ---refreshECats erules1 --- this seems to be just bad !
+  erules3 = concat (map pickERules erules2)
+  erules4 = nubERules erules3
+ in [(mkCFCatE cat, map eitem2cfitem its) | (cat,itss) <- erules3, its <- itss]
+
+refreshECats :: [NormERule] -> [NormERule]
+refreshECats rules = [recas [i] rule | (i,rule) <- zip [0..] rules] where
+ recas ii (cat,its) = (updECat ii cat, [recss ii 0 s | s <- its])
+ recss ii n [] = []
+ recss ii n (s:ss) = recit (ii ++ [n]) s : recss ii (n+1) ss
+ recit ii it = case it of
+   EINonTerm cat  -> EINonTerm (updECat ii cat)
+   EIStar (cat,t) -> EIStar (updECat ii cat, [recss ii 0 s | s <- t])
+   EIPlus (cat,t) -> EIPlus (updECat ii cat, [recss ii 0 s | s <- t])
+   EIOpt  (cat,t) -> EIOpt  (updECat ii cat, [recss ii 0 s | s <- t])
+   _ -> it
+  
+pickERules :: NormERule -> [NormERule]
+pickERules rule@(cat,alts) = rule : concat (map pics (concat alts)) where
+ pics it = case it of
+   EIStar ru@(cat,t) -> mkEStarRules cat ++ pickERules ru
+   EIPlus ru@(cat,t) -> mkEPlusRules cat ++ pickERules ru
+   EIOpt  ru@(cat,t) -> mkEOptRules cat ++ pickERules ru
+   _ -> []
+ mkEStarRules cat = [(cat', [[],[EINonTerm cat, EINonTerm cat']])] 
+                                        where cat' = mkNewECat cat "Star"
+ mkEPlusRules cat = [(cat', [[EINonTerm cat],[EINonTerm cat, EINonTerm cat']])] 
+                                        where cat' = mkNewECat cat "Plus"
+ mkEOptRules cat  = [(cat', [[],[EINonTerm cat]])] 
+                                        where cat' = mkNewECat cat "Opt"
+
+nubERules :: [NormERule] -> [NormERule]
+nubERules rules = nub optim where 
+  optim = map (substERules (map mkSubst replaces)) irreducibles
+  (replaces,irreducibles) = partition reducible rules
+  reducible (cat,[items]) = isNewCat cat && all isOldIt items
+  reducible _ = False
+  isNewCat (_,ints) = ints == []
+  isOldIt (EITerm _) = True
+  isOldIt (EINonTerm cat) = not (isNewCat cat)
+  isOldIt _ = False
+  mkSubst (cat,its) = (cat, head its) -- def of reducible: its must be singleton
+--- the optimization assumes each cat has at most one EBNF rule.
+
+substERules :: [(ECat,[EItem])] -> NormERule -> NormERule
+substERules g (cat,itss) = (cat, map sub itss) where
+  sub [] = []
+  sub (i@(EINonTerm cat') : ii) = case lookup cat g of
+                                    Just its -> its ++ sub ii 
+                                    _ -> i : sub ii
+  sub (EIStar r : ii) = EIStar (substERules g r) : ii
+  sub (EIPlus r : ii) = EIPlus (substERules g r) : ii
+  sub (EIOpt r : ii)  = EIOpt  (substERules g r) : ii
+
+eitem2cfitem :: EItem -> CFItem 
+eitem2cfitem it = case it of
+  EITerm a       -> atomCFTerm $ tS a
+  EINonTerm cat  -> CFNonterm (mkCFCatE cat)
+  EIStar (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Star"))
+  EIPlus (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Plus"))
+  EIOpt  (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Opt"))
+
+type NormERule = (ECat,[[EItem]]) -- disjunction of sequences of items
+
+data EItem =
+   EITerm String
+ | EINonTerm ECat
+ | EIStar NormERule
+ | EIPlus NormERule
+ | EIOpt  NormERule
+  deriving Eq
+
+normERule :: ([Int],ERule) -> NormERule
+normERule (ii,(cat,rhs)) = 
+ (cat,[map (mkEItem (ii ++ [i])) r' | (i,r') <- zip [0..] (disjNorm rhs)]) where
+  disjNorm r = case r of
+    ESeq r1 r2 -> [x ++ y | x <- disjNorm r1, y <- disjNorm r2]
+    EAlt r1 r2 -> disjNorm r1 ++ disjNorm r2
+    EEmpty -> [[]]
+    _ -> [[r]]
+
+mkEItem :: [Int] -> ERHS -> EItem
+mkEItem ii rhs = case rhs of
+  ETerm a -> EITerm a
+  ENonTerm cat -> EINonTerm cat
+  EStar r -> EIStar (normERule (ii,(mkECat ii, r)))
+  EPlus r -> EIPlus (normERule (ii,(mkECat ii, r)))
+  EOpt  r -> EIOpt  (normERule (ii,(mkECat ii, r)))
+  _ -> EINonTerm ("?????",[])
+--  _ -> error "should not happen in ebnf" ---
+
+mkECat ints = ("C", ints)
+
+prECat (c,[]) = c
+prECat (c,ints) = c ++ "_" ++ prTList "_" (map show ints)
+
+mkCFCatE :: ECat -> CFCat
+mkCFCatE = string2CFCat ebnfID . prECat
+
+updECat _ (c,[]) = (c,[])
+updECat ii (c,_) = (c,ii)
+
+mkNewECat (c,ii) str = (c ++ str,ii)
+
+------ parser for EBNF grammars
+
+pEBNFasGrammar :: String -> Err [A.TopDef]
+pEBNFasGrammar = parseResultErr (pEBNF *** ebnf2gf) . remComments
+
+pEBNF :: Parser Char EBNF
+pEBNF = longestOfMany (pJ pERule)
+
+pERule :: Parser Char ERule
+pERule = pECat ... pJ (literals ":=" ||| literals "::=") +.. pERHS 0 ..+ jL ";"
+
+pERHS :: Int -> Parser Char ERHS
+pERHS 0 = pTList "|" (pERHS 1) *** foldr1 EAlt
+pERHS 1 = longestOfMany (pJ (pERHS 2)) *** foldr ESeq EEmpty
+pERHS 2 = pERHS 3 ... pJ pUnaryEOp *** (\ (a,f) -> f a)
+pERHS 3 = pQuotedString *** ETerm
+          ||| pECat *** ENonTerm ||| pParenth (pERHS 0)
+
+pUnaryEOp :: Parser Char (ERHS -> ERHS)
+pUnaryEOp = 
+ lits "*" <<< EStar ||| lits "+" <<< EPlus ||| lits "?" <<< EOpt ||| succeed id
+
+pECat = pIdent *** (\c -> (c,[]))
+

src-2.9/GF/CF/PPrCF.hs

@@ -0,0 +1,102 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PPrCF
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/15 17:56:13 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.13 $
+--
+-- printing and parsing CF grammars, rules, and trees AR 26/1/2000 -- 9/6/2003
+--
+-- use the Print class instead!
+-----------------------------------------------------------------------------
+
+module GF.CF.PPrCF (prCF, prCFTree, prCFRule, prCFFun, prCFCat, prCFItem, prRegExp, pCF) where
+
+import GF.Data.Operations
+import GF.CF.CF
+import GF.CF.CFIdent
+import GF.Canon.AbsGFC
+import GF.Grammar.PrGrammar
+
+import Data.Char
+import Data.List
+
+prCF :: CF -> String
+prCF = unlines . (map prCFRule) . rulesOfCF -- hiding the literal recogn function
+
+prCFTree :: CFTree -> String
+prCFTree (CFTree (fun, (_,trees))) = prCFFun fun ++ prs trees where 
+ prs [] = ""
+ prs ts = " " ++ unwords (map ps ts)
+ ps t@(CFTree (_,(_,[]))) = prCFTree t
+ ps t = prParenth (prCFTree t)
+{-# NOINLINE prCFTree #-}
+-- Workaround ghc 6.8.2 bug
+
+
+prCFRule :: CFRule -> String
+prCFRule (fun,(cat,its)) = 
+  prCFFun fun ++ "." +++ prCFCat cat +++ "::=" +++ 
+  unwords (map prCFItem its) +++ ";"
+
+prCFFun :: CFFun -> String
+prCFFun = prCFFun' True ---- False -- print profiles for debug
+
+prCFFun' :: Bool -> CFFun -> String
+prCFFun' profs (CFFun (t, p)) = prt_ t ++ pp p where
+    pp p = if (not profs || normal p) then "" else "_" ++ concat (map show p)
+    normal p = and [x==y && null b | ((b,x),y) <- zip p (map (:[]) [0..])]
+
+prCFCat :: CFCat -> String
+prCFCat (CFCat (c,l)) = prt_ c ++ case prt_ l of
+  "s" -> []
+  _   -> "-" ++ prt_ l ----
+
+prCFItem :: CFItem -> String
+prCFItem (CFNonterm c) = prCFCat c
+prCFItem (CFTerm a) = prRegExp a
+
+prRegExp :: RegExp -> String
+prRegExp (RegAlts tt) = case tt of
+  [t] -> prQuotedString t
+  _ -> prParenth (prTList " | " (map prQuotedString tt))
+
+-- rules have an amazingly easy parser, if we use the format
+-- fun. C -> item1 item2 ... where unquoted items are treated as cats
+-- Actually would be nice to add profiles to this.
+
+getCFRule :: String -> String -> Err [CFRule]
+getCFRule mo s = getcf (wrds s) where
+  getcf ws = case ws of
+    fun : cat : a : its | isArrow a -> 
+      Ok [(string2CFFun mo (init fun), 
+            (string2CFCat mo cat, map mkIt its))]
+    cat : a : its | isArrow a -> 
+      Ok [(string2CFFun mo (mkFun cat it), 
+            (string2CFCat mo cat, map mkIt it)) | it <- chunk its]
+    _ -> Bad (" invalid rule:" +++ s)
+  isArrow a = elem a ["->", "::="] 
+  mkIt w = case w of
+    ('"':w@(_:_)) -> atomCFTerm (string2CFTok (init w))
+    _             -> CFNonterm (string2CFCat mo w)
+  chunk its = case its of
+    [] -> [[]]
+    _ -> chunks "|" its
+  mkFun cat its = case its of
+    [] -> cat ++ "_"
+    _ -> concat $ intersperse "_" (cat : map clean its) -- CLE style
+  clean = filter isAlphaNum -- to form valid identifiers
+  wrds = takeWhile (/= ";") . words -- to permit semicolon in the end
+
+pCF :: String -> String -> Err [CFRule]
+pCF mo s = do
+  rules <- mapM (getCFRule mo) $ filter isRule $ lines s
+  return $ concat rules
+ where
+   isRule line = case dropWhile isSpace line of
+     '-':'-':_ -> False
+     _ -> not $ all isSpace line

src-2.9/GF/CF/PrLBNF.hs

@@ -0,0 +1,150 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PrLBNF
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/17 14:15:16 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.11 $
+--
+-- Printing CF grammars generated from GF as LBNF grammar for BNFC.
+-- AR 26/1/2000 -- 9/6/2003 (PPrCF) -- 8/11/2003 -- 27/9/2004.
+-- With primitive error messaging, by rules and rule tails commented out
+-----------------------------------------------------------------------------
+
+module GF.CF.PrLBNF (prLBNF,prBNF) where
+
+import GF.CF.CF
+import GF.CF.CFIdent
+import GF.Canon.AbsGFC
+import GF.Infra.Ident
+import GF.Grammar.PrGrammar
+import GF.Compile.ShellState
+import GF.Canon.GFC
+import GF.Canon.Look
+
+import GF.Data.Operations
+import GF.Infra.Modules
+
+import Data.Char
+import Data.List (nub)
+
+prLBNF :: Bool -> StateGrammar -> String
+prLBNF new gr = unlines $ pragmas ++ (map (prCFRule cs) rules')
+  where    
+    cs = map IC ["Int","String"] ++ [catIdPlus c | (_,(c,_)) <- rules]
+    cf = stateCF gr
+    (pragmas,rules) = if new  -- tries to treat precedence levels
+                         then mkLBNF (stateGrammarST gr) $ rulesOfCF cf
+                         else ([],rulesOfCF cf) -- "normal" behaviour
+    rules' = concatMap expand rules
+    expand (f,(c,its)) = [(f,(c,it)) | it <- combinations (map expIt its)]
+    expIt i = case i of
+      CFTerm (RegAlts ss) -> [CFTerm (RegAlts [s]) | s <- ss]
+      _ -> [i]
+
+-- | a hack to hide the LBNF details
+prBNF :: Bool -> StateGrammar -> String
+prBNF b = unlines . (map (unwords . unLBNF . drop 1 . words)) . lines . prLBNF b
+  where
+    unLBNF r = case r of
+      "---":ts -> ts
+      ";":"---":ts -> ts
+      c:ts -> c : unLBNF ts
+      _ -> r
+
+--- | awful low level code without abstraction over label names etc
+mkLBNF :: CanonGrammar -> [CFRule] -> ([String],[CFRule])
+mkLBNF gr rules = (coercions, nub $ concatMap mkRule rules) where
+  coercions = ["coercions" +++ prt_ c +++ show n +++ ";"  | 
+    (_,ModMod m) <- modules gr,
+    (c,CncCat (RecType ls) _ _) <- tree2list $ jments m,
+    Lbg (L (IC "p")) (TInts n) <- ls
+    ]
+  precedences = [(f,(prec,assoc))  | 
+    (_,ModMod m) <- modules gr,
+    (f,CncFun _ _ (R lin) _) <- tree2list $ jments m,
+    (Just prec, Just assoc) <- [(
+       lookup "p" [(lab,p) | Ass (L (IC lab)) (EInt p) <- lin],
+       lookup "a" [(lab,a) | Ass (L (IC lab)) (Par (CIQ _ (IC a)) []) <- lin]
+       )]
+    ]
+  precfuns = map fst precedences
+  mkRule r@(fun@(CFFun (t, p)),(cat,its)) = case t of
+    AC (CIQ _ c) -> case lookup c precedences of
+      Just (prec,assoc) -> [(fun,(mkCat prec cat,mkIts cat prec assoc 0 its))]
+      _ -> return r
+    AD (CIQ _ c) -> case lookup c precedences of
+      Just (prec,assoc) -> [(fun,(mkCat prec cat,mkIts cat prec assoc 0 its))]
+      _ -> return r
+    _ -> return r
+  mkIts cat prec assoc i its = case its of
+    CFTerm (RegAlts ["("]):n@(CFNonterm k):CFTerm (RegAlts [")"]):rest | k==cat -> 
+      mkIts cat prec assoc i $ n:rest  -- remove variants with parentheses 
+    CFNonterm k:rest | k==cat -> 
+      CFNonterm (mkNonterm prec assoc i k) : mkIts cat prec assoc (i+1) rest
+    it:rest -> it:mkIts cat prec assoc i rest
+    [] -> []
+
+  mkCat prec (CFCat ((CIQ m (IC c)),l)) = CFCat ((CIQ m (IC (c ++ show prec ++ "+"))),l)
+  mkNonterm prec assoc i cat = mkCat prec' cat 
+    where 
+      prec' = case (assoc,i) of
+        ("PL",0) -> prec
+        ("PR",0) -> prec + 1
+        ("PR",_) -> prec
+        _        -> prec + 1
+
+catId ((CFCat ((CIQ _ c),l))) = c
+
+catIdPlus ((CFCat ((CIQ _ c@(IC s)),l))) = case reverse s of
+  '+':cs -> IC $ reverse $ dropWhile isDigit cs
+  _ -> c
+
+prCFRule :: [Ident] -> CFRule -> String
+prCFRule cs (fun,(cat,its)) = 
+  prCFFun cat fun ++ "." +++ prCFCat True cat +++ "::=" +++  --- err in cat -> in syntax
+  unwords (map (prCFItem cs) its) +++ ";"
+
+prCFFun :: CFCat -> CFFun -> String
+prCFFun (CFCat (_,l)) (CFFun (t, p)) = case t of
+  AC (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p)
+  AD (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p)
+  _ -> prErr True $ prt t
+ where
+   lab = prLab l
+   f2 f = if null lab then "" else f
+   prP = concatMap show
+   
+prId b i = case i of
+     IC "Int"  -> "Integer"
+     IC "#Var" -> "Ident"
+     IC "Var"  -> "Ident"
+     IC "id_"  -> "_"
+     IC s@(c:_) | last s == '+' -> init s  -- hack to save precedence information
+     IC s@(c:_) | isUpper c -> s ++ if isDigit (last s) then "_" else ""
+     _ -> prErr b $ prt i
+
+prLab i = case i of
+     L (IC "s") -> "" ---
+     L (IC "_") -> "" ---
+     _ -> let x = prt i in "_" ++ x ++ if isDigit (last x) then "_" else ""
+
+-- | just comment out the rest if you cannot interpret the function name in LBNF
+-- two versions, depending on whether in the beginning of a rule or elsewhere;
+-- in the latter case, error just terminates the rule 
+prErr :: Bool -> String -> String
+prErr b s = (if b then "" else " ;") +++ "---" +++ s
+
+prCFCat :: Bool -> CFCat -> String
+prCFCat b (CFCat ((CIQ _ c),l)) = prId b c ++ prLab l ----
+
+-- | if a category does not have a production of its own, we replace it by Ident
+prCFItem cs (CFNonterm c) = if elem (catIdPlus c) cs then prCFCat False c else "Ident"
+prCFItem _ (CFTerm a) = prRegExp a
+
+prRegExp (RegAlts tt) = case tt of
+  [t] -> prQuotedString t
+  _ -> prErr False $ prParenth (prTList " | " (map prQuotedString tt))

src-2.9/GF/CF/Profile.hs

@@ -0,0 +1,106 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Profile
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:14 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- restoring parse trees for discontinuous constituents, bindings, etc. AR 25/1/2001
+-- revised 8/4/2002 for the new profile structure
+-----------------------------------------------------------------------------
+
+module GF.CF.Profile (postParse) where
+
+import GF.Canon.AbsGFC
+import GF.Canon.GFC
+import qualified GF.Infra.Ident as I
+import GF.Canon.CMacros
+---import MMacros
+import GF.CF.CF
+import GF.CF.CFIdent
+import GF.CF.PPrCF -- for error msg
+import GF.Grammar.PrGrammar
+
+import GF.Data.Operations
+
+import Control.Monad
+import Data.List (nub)
+
+-- | the job is done in two passes: 
+-- 
+--   1. tree2term: restore constituent order from Profile 
+-- 
+--   2. term2trm:  restore Bindings from Binds
+postParse :: CFTree -> Err Exp
+postParse tree = do
+  iterm <- errIn ("postprocessing parse tree" +++ prCFTree tree) $ tree2term tree
+  return $ term2trm  iterm
+
+-- | an intermediate data structure
+data ITerm = ITerm (Atom, BindVs) [ITerm] | IMeta   deriving (Eq,Show)
+type BindVs = [[I.Ident]]
+
+-- | (1) restore constituent order from Profile 
+tree2term :: CFTree -> Err ITerm
+-- tree2term (CFTree (f,(_,[t]))) | f == dummyCFFun = tree2term t -- not used
+tree2term (CFTree (cff@(CFFun (fun,pro)), (_,trees))) = case fun of
+  AM _ -> return IMeta
+  _ -> do
+    args  <- mapM mkArg pro
+    binds <- mapM mkBinds pro
+    return $ ITerm (fun, binds) args
+ where
+   mkArg (_,arg) = case arg of
+     [x] -> do               -- one occurrence
+       trx <- trees !? x
+       tree2term trx
+     []  -> return IMeta     -- suppression
+     _   -> do               -- reduplication
+       trees' <- mapM (trees !?) arg
+       xs1    <- mapM tree2term trees' 
+       xs2    <- checkArity xs1
+       unif xs2
+
+   checkArity xs = if length (nub [length xx | ITerm _ xx <- xs']) > 1 
+                   then Bad "arity error" 
+                   else return xs'
+           where xs' = [t | t@(ITerm _ _) <- xs]
+   unif xs = case [t | t@(ITerm _ _) <- xs] of 
+    [] -> return $ IMeta
+    (ITerm fp@(f,_) xx : ts) -> do
+      let hs = [h | ITerm (h,_) _ <- ts, h /= f]
+      testErr (null hs)                 -- if fails, hs must be nonempty
+              ("unification expects" +++ prt f +++ "but found" +++ prt (head hs))
+      xx' <- mapM unifArg [0 .. length xx - 1]
+      return $ ITerm fp xx'
+    where
+      unifArg i = unif [zz !! i | ITerm _ zz <- xs]
+
+   mkBinds (xss,_) = mapM mkBind xss
+   mkBind xs = do
+     ts <- mapM (trees !?) xs
+     let vs = [x | CFTree (CFFun (AV x,_),(_,[])) <- ts]
+     testErr (length ts == length vs) "non-variable in bound position"
+     case vs of
+       [x]  -> return x
+       []   -> return $ I.identC "h_" ---- uBoundVar
+       y:ys -> do
+         testErr (all (==y) ys) ("fail to unify bindings of" +++ prt y)
+         return y
+
+-- | (2) restore Bindings from Binds
+term2trm :: ITerm -> Exp 
+term2trm IMeta = EAtom (AM 0) ---- mExp0
+term2trm (ITerm (fun, binds) terms) =
+  let bterms = zip binds terms
+  in mkAppAtom fun [mkAbsR xs (term2trm t) |  (xs,t) <- bterms]
+
+ --- these are deprecated
+ where
+   mkAbsR c e = foldr EAbs e c
+   mkAppAtom a = mkApp (EAtom a)
+   mkApp = foldl EApp

src-2.9/GF/CFGM/AbsCFG.hs

@@ -0,0 +1,45 @@
+module GF.CFGM.AbsCFG where
+
+-- Haskell module generated by the BNF converter
+
+newtype Ident = Ident String deriving (Eq,Ord,Show)
+newtype SingleQuoteString = SingleQuoteString String deriving (Eq,Ord,Show)
+data Grammars =
+   Grammars [Grammar]
+  deriving (Eq,Ord,Show)
+
+data Grammar =
+   Grammar Ident [Flag] [Rule]
+  deriving (Eq,Ord,Show)
+
+data Flag =
+   StartCat Category
+  deriving (Eq,Ord,Show)
+
+data Rule =
+   Rule Fun Profiles Category [Symbol]
+  deriving (Eq,Ord,Show)
+
+data Fun =
+   Cons Ident
+ | Coerce
+  deriving (Eq,Ord,Show)
+
+data Profiles =
+   Profiles [Profile]
+  deriving (Eq,Ord,Show)
+
+data Profile =
+   UnifyProfile [Integer]
+ | ConstProfile Ident
+  deriving (Eq,Ord,Show)
+
+data Symbol =
+   CatS Category
+ | TermS String
+  deriving (Eq,Ord,Show)
+
+data Category =
+   Category SingleQuoteString
+  deriving (Eq,Ord,Show)
+

src-2.9/GF/CFGM/CFG.cf

@@ -0,0 +1,36 @@
+entrypoints Grammars;
+
+Grammars. Grammars ::= [Grammar];
+
+Grammar. Grammar ::= "grammar" Ident [Flag] [Rule] "end" "grammar";
+separator Grammar "";
+
+StartCat. Flag ::= "startcat" Category;
+terminator Flag ";";
+
+Rule. Rule ::= Fun ":" Profiles "." Category "->" [Symbol];
+terminator Rule ";";
+
+Cons. Fun ::= Ident ;
+Coerce. Fun ::= "_" ;
+
+Profiles. Profiles ::= "[" [Profile] "]";
+
+separator Profile ",";
+
+UnifyProfile. Profile ::= "[" [Integer] "]";
+ConstProfile. Profile ::= Ident ;
+
+separator Integer ",";
+
+CatS. Symbol ::= Category;
+TermS. Symbol ::= String;
+
+-- separator Symbol "";
+[]. [Symbol] ::= "." ;
+(:[]). [Symbol] ::= Symbol ;
+(:). [Symbol] ::= Symbol [Symbol] ;
+
+Category. Category ::= SingleQuoteString ;
+
+token SingleQuoteString '\'' ((char - ["'\\"]) | ('\\' ["'\\"]))* '\'' ;

src-2.9/GF/CFGM/LexCFG.x

@@ -0,0 +1,135 @@
+-- -*- haskell -*-
+-- This Alex file was machine-generated by the BNF converter
+{
+module LexCFG where
+
+import ErrM
+
+}
+
+
+$l = [a-zA-Z\192 - \255] # [\215 \247]    -- isolatin1 letter FIXME
+$c = [A-Z\192-\221] # [\215]    -- capital isolatin1 letter FIXME
+$s = [a-z\222-\255] # [\247]    -- small isolatin1 letter FIXME
+$d = [0-9]                -- digit
+$i = [$l $d _ ']          -- identifier character
+$u = [\0-\255]          -- universal: any character
+
+@rsyms =    -- reserved words consisting of special symbols
+   \; | \: | \. | \- \> | \_ | \[ | \] | \,
+
+:-
+
+$white+ ;
+@rsyms { tok (\p s -> PT p (TS $ share s)) }
+\' ($u # [\' \\]| \\ [\' \\]) * \' { tok (\p s -> PT p (eitherResIdent (T_SingleQuoteString . share) s)) }
+
+$l $i*   { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
+\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
+
+$d+      { tok (\p s -> PT p (TI $ share s))    }
+
+
+{
+
+tok f p s = f p s
+
+share :: String -> String
+share = id
+
+data Tok =
+   TS !String     -- reserved words
+ | TL !String     -- string literals
+ | TI !String     -- integer literals
+ | TV !String     -- identifiers
+ | TD !String     -- double precision float literals
+ | TC !String     -- character literals
+ | T_SingleQuoteString !String
+
+ deriving (Eq,Show,Ord)
+
+data Token = 
+   PT  Posn Tok
+ | Err Posn
+  deriving (Eq,Show,Ord)
+
+tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
+tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
+tokenPos _ = "end of file"
+
+posLineCol (Pn _ l c) = (l,c)
+mkPosToken t@(PT p _) = (posLineCol p, prToken t)
+
+prToken t = case t of
+  PT _ (TS s) -> s
+  PT _ (TI s) -> s
+  PT _ (TV s) -> s
+  PT _ (TD s) -> s
+  PT _ (TC s) -> s
+  PT _ (T_SingleQuoteString s) -> s
+
+  _ -> show t
+
+data BTree = N | B String Tok BTree BTree deriving (Show)
+
+eitherResIdent :: (String -> Tok) -> String -> Tok
+eitherResIdent tv s = treeFind resWords
+  where
+  treeFind N = tv s
+  treeFind (B a t left right) | s < a  = treeFind left
+                              | s > a  = treeFind right
+                              | s == a = t
+
+resWords = b "grammar" (b "end" N N) (b "startcat" N N)
+   where b s = B s (TS s)
+
+unescapeInitTail :: String -> String
+unescapeInitTail = unesc . tail where
+  unesc s = case s of
+    '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
+    '\\':'n':cs  -> '\n' : unesc cs
+    '\\':'t':cs  -> '\t' : unesc cs
+    '"':[]    -> []
+    c:cs      -> c : unesc cs
+    _         -> []
+
+-------------------------------------------------------------------
+-- Alex wrapper code.
+-- A modified "posn" wrapper.
+-------------------------------------------------------------------
+
+data Posn = Pn !Int !Int !Int
+      deriving (Eq, Show,Ord)
+
+alexStartPos :: Posn
+alexStartPos = Pn 0 1 1
+
+alexMove :: Posn -> Char -> Posn
+alexMove (Pn a l c) '\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)
+alexMove (Pn a l c) '\n' = Pn (a+1) (l+1)   1
+alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)
+
+type AlexInput = (Posn, -- current position,
+		  Char,	-- previous char
+		  String)	-- current input string
+
+tokens :: String -> [Token]
+tokens str = go (alexStartPos, '\n', str)
+    where
+      go :: (Posn, Char, String) -> [Token]
+      go inp@(pos, _, str) =
+    	  case alexScan inp 0 of
+    	    AlexEOF                -> []
+    	    AlexError (pos, _, _)  -> fail $ show pos ++ ": lexical error"
+    	    AlexSkip  inp' len     -> go inp'
+    	    AlexToken inp' len act -> act pos (take len str) : (go inp')
+
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar (p, c, [])    = Nothing
+alexGetChar (p, _, (c:s)) =
+    let p' = alexMove p c
+     in p' `seq` Just (c, (p', c, s))
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (p, c, s) = c
+}

src-2.9/GF/CFGM/ParCFG.hs

@@ -0,0 +1,779 @@
+{-# OPTIONS -fglasgow-exts -cpp #-}
+module GF.CFGM.ParCFG where
+import GF.CFGM.AbsCFG
+import GF.CFGM.LexCFG
+import GF.Data.ErrM
+import Array
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.Exts
+#else
+import GlaExts
+#endif
+
+-- parser produced by Happy Version 1.15
+
+newtype HappyAbsSyn  = HappyAbsSyn (() -> ())
+happyIn4 :: (Ident) -> (HappyAbsSyn )
+happyIn4 x = unsafeCoerce# x
+{-# INLINE happyIn4 #-}
+happyOut4 :: (HappyAbsSyn ) -> (Ident)
+happyOut4 x = unsafeCoerce# x
+{-# INLINE happyOut4 #-}
+happyIn5 :: (Integer) -> (HappyAbsSyn )
+happyIn5 x = unsafeCoerce# x
+{-# INLINE happyIn5 #-}
+happyOut5 :: (HappyAbsSyn ) -> (Integer)
+happyOut5 x = unsafeCoerce# x
+{-# INLINE happyOut5 #-}
+happyIn6 :: (String) -> (HappyAbsSyn )
+happyIn6 x = unsafeCoerce# x
+{-# INLINE happyIn6 #-}
+happyOut6 :: (HappyAbsSyn ) -> (String)
+happyOut6 x = unsafeCoerce# x
+{-# INLINE happyOut6 #-}
+happyIn7 :: (SingleQuoteString) -> (HappyAbsSyn )
+happyIn7 x = unsafeCoerce# x
+{-# INLINE happyIn7 #-}
+happyOut7 :: (HappyAbsSyn ) -> (SingleQuoteString)
+happyOut7 x = unsafeCoerce# x
+{-# INLINE happyOut7 #-}
+happyIn8 :: (Grammars) -> (HappyAbsSyn )
+happyIn8 x = unsafeCoerce# x
+{-# INLINE happyIn8 #-}
+happyOut8 :: (HappyAbsSyn ) -> (Grammars)
+happyOut8 x = unsafeCoerce# x
+{-# INLINE happyOut8 #-}
+happyIn9 :: (Grammar) -> (HappyAbsSyn )
+happyIn9 x = unsafeCoerce# x
+{-# INLINE happyIn9 #-}
+happyOut9 :: (HappyAbsSyn ) -> (Grammar)
+happyOut9 x = unsafeCoerce# x
+{-# INLINE happyOut9 #-}
+happyIn10 :: ([Grammar]) -> (HappyAbsSyn )
+happyIn10 x = unsafeCoerce# x
+{-# INLINE happyIn10 #-}
+happyOut10 :: (HappyAbsSyn ) -> ([Grammar])
+happyOut10 x = unsafeCoerce# x
+{-# INLINE happyOut10 #-}
+happyIn11 :: (Flag) -> (HappyAbsSyn )
+happyIn11 x = unsafeCoerce# x
+{-# INLINE happyIn11 #-}
+happyOut11 :: (HappyAbsSyn ) -> (Flag)
+happyOut11 x = unsafeCoerce# x
+{-# INLINE happyOut11 #-}
+happyIn12 :: ([Flag]) -> (HappyAbsSyn )
+happyIn12 x = unsafeCoerce# x
+{-# INLINE happyIn12 #-}
+happyOut12 :: (HappyAbsSyn ) -> ([Flag])
+happyOut12 x = unsafeCoerce# x
+{-# INLINE happyOut12 #-}
+happyIn13 :: (Rule) -> (HappyAbsSyn )
+happyIn13 x = unsafeCoerce# x
+{-# INLINE happyIn13 #-}
+happyOut13 :: (HappyAbsSyn ) -> (Rule)
+happyOut13 x = unsafeCoerce# x
+{-# INLINE happyOut13 #-}
+happyIn14 :: ([Rule]) -> (HappyAbsSyn )
+happyIn14 x = unsafeCoerce# x
+{-# INLINE happyIn14 #-}
+happyOut14 :: (HappyAbsSyn ) -> ([Rule])
+happyOut14 x = unsafeCoerce# x
+{-# INLINE happyOut14 #-}
+happyIn15 :: (Fun) -> (HappyAbsSyn )
+happyIn15 x = unsafeCoerce# x
+{-# INLINE happyIn15 #-}
+happyOut15 :: (HappyAbsSyn ) -> (Fun)
+happyOut15 x = unsafeCoerce# x
+{-# INLINE happyOut15 #-}
+happyIn16 :: (Profiles) -> (HappyAbsSyn )
+happyIn16 x = unsafeCoerce# x
+{-# INLINE happyIn16 #-}
+happyOut16 :: (HappyAbsSyn ) -> (Profiles)
+happyOut16 x = unsafeCoerce# x
+{-# INLINE happyOut16 #-}
+happyIn17 :: ([Profile]) -> (HappyAbsSyn )
+happyIn17 x = unsafeCoerce# x
+{-# INLINE happyIn17 #-}
+happyOut17 :: (HappyAbsSyn ) -> ([Profile])
+happyOut17 x = unsafeCoerce# x
+{-# INLINE happyOut17 #-}
+happyIn18 :: (Profile) -> (HappyAbsSyn )
+happyIn18 x = unsafeCoerce# x
+{-# INLINE happyIn18 #-}
+happyOut18 :: (HappyAbsSyn ) -> (Profile)
+happyOut18 x = unsafeCoerce# x
+{-# INLINE happyOut18 #-}
+happyIn19 :: ([Integer]) -> (HappyAbsSyn )
+happyIn19 x = unsafeCoerce# x
+{-# INLINE happyIn19 #-}
+happyOut19 :: (HappyAbsSyn ) -> ([Integer])
+happyOut19 x = unsafeCoerce# x
+{-# INLINE happyOut19 #-}
+happyIn20 :: (Symbol) -> (HappyAbsSyn )
+happyIn20 x = unsafeCoerce# x
+{-# INLINE happyIn20 #-}
+happyOut20 :: (HappyAbsSyn ) -> (Symbol)
+happyOut20 x = unsafeCoerce# x
+{-# INLINE happyOut20 #-}
+happyIn21 :: ([Symbol]) -> (HappyAbsSyn )
+happyIn21 x = unsafeCoerce# x
+{-# INLINE happyIn21 #-}
+happyOut21 :: (HappyAbsSyn ) -> ([Symbol])
+happyOut21 x = unsafeCoerce# x
+{-# INLINE happyOut21 #-}
+happyIn22 :: (Category) -> (HappyAbsSyn )
+happyIn22 x = unsafeCoerce# x
+{-# INLINE happyIn22 #-}
+happyOut22 :: (HappyAbsSyn ) -> (Category)
+happyOut22 x = unsafeCoerce# x
+{-# INLINE happyOut22 #-}
+happyInTok :: Token -> (HappyAbsSyn )
+happyInTok x = unsafeCoerce# x
+{-# INLINE happyInTok #-}
+happyOutTok :: (HappyAbsSyn ) -> Token
+happyOutTok x = unsafeCoerce# x
+{-# INLINE happyOutTok #-}
+
+happyActOffsets :: HappyAddr
+happyActOffsets = HappyA# "\x00\x00\x36\x00\x00\x00\x29\x00\x35\x00\x00\x00\x32\x00\x00\x00\x30\x00\x38\x00\x19\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x34\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x31\x00\xfd\xff\x00\x00\x2c\x00\x2a\x00\x23\x00\x22\x00\x2b\x00\x25\x00\x20\x00\x00\x00\xfd\xff\x00\x00\x00\x00\x00\x00\x17\x00\x1c\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
+
+happyGotoOffsets :: HappyAddr
+happyGotoOffsets = HappyA# "\x28\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x21\x00\x05\x00\x01\x00\x00\x00\x1d\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x02\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
+
+happyDefActions :: HappyAddr
+happyDefActions = HappyA# "\xf8\xff\x00\x00\xfe\xff\x00\x00\xfa\xff\xf7\xff\x00\x00\xf5\xff\xf2\xff\x00\x00\x00\x00\x00\x00\xe0\xff\xf6\xff\xfb\xff\xf0\xff\x00\x00\x00\x00\xef\xff\x00\x00\xf4\xff\xf9\xff\x00\x00\xf1\xff\x00\x00\xed\xff\xe9\xff\x00\x00\xec\xff\xe8\xff\x00\x00\x00\x00\xe7\xff\x00\x00\xfd\xff\xed\xff\xee\xff\xeb\xff\xea\xff\xe8\xff\x00\x00\xe4\xff\xe2\xff\xf3\xff\xe5\xff\xe3\xff\xfc\xff\xe6\xff\xe1\xff"#
+
+happyCheck :: HappyAddr
+happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x06\x00\x02\x00\x03\x00\x03\x00\x03\x00\x07\x00\x0c\x00\x00\x00\x0a\x00\x00\x00\x08\x00\x01\x00\x10\x00\x11\x00\x12\x00\x10\x00\x11\x00\x12\x00\x12\x00\x12\x00\x0d\x00\x0e\x00\x0d\x00\x0e\x00\x01\x00\x0f\x00\x00\x00\x05\x00\x03\x00\x0c\x00\x00\x00\x09\x00\x05\x00\x0d\x00\x0c\x00\x09\x00\x07\x00\x0b\x00\x0f\x00\x0e\x00\x0f\x00\x04\x00\x08\x00\x06\x00\x04\x00\x0d\x00\x0f\x00\x08\x00\x07\x00\x03\x00\x06\x00\x02\x00\x0a\x00\x01\x00\x01\x00\x11\x00\x0b\x00\xff\xff\x0f\x00\x0c\x00\x0a\x00\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
+
+happyTable :: HappyAddr
+happyTable = HappyA# "\x00\x00\x29\x00\x0c\x00\x1e\x00\x29\x00\x0c\x00\x0c\x00\x0c\x00\x09\x00\x03\x00\x1a\x00\x0a\x00\x1a\x00\x08\x00\x20\x00\x2a\x00\x30\x00\x2c\x00\x2a\x00\x2b\x00\x2c\x00\x1f\x00\x0d\x00\x25\x00\x1c\x00\x1b\x00\x1c\x00\x20\x00\x2f\x00\x0f\x00\x13\x00\x2e\x00\x18\x00\x07\x00\x14\x00\x05\x00\x23\x00\x03\x00\x10\x00\x27\x00\x11\x00\x21\x00\x2f\x00\x0f\x00\x03\x00\x28\x00\x04\x00\x29\x00\x23\x00\x0f\x00\x24\x00\x25\x00\x1f\x00\x1a\x00\x17\x00\x16\x00\x18\x00\x15\x00\xff\xff\x0c\x00\x00\x00\x0f\x00\x03\x00\x07\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
+
+happyReduceArr = array (1, 31) [
+	(1 , happyReduce_1),
+	(2 , happyReduce_2),
+	(3 , happyReduce_3),
+	(4 , happyReduce_4),
+	(5 , happyReduce_5),
+	(6 , happyReduce_6),
+	(7 , happyReduce_7),
+	(8 , happyReduce_8),
+	(9 , happyReduce_9),
+	(10 , happyReduce_10),
+	(11 , happyReduce_11),
+	(12 , happyReduce_12),
+	(13 , happyReduce_13),
+	(14 , happyReduce_14),
+	(15 , happyReduce_15),
+	(16 , happyReduce_16),
+	(17 , happyReduce_17),
+	(18 , happyReduce_18),
+	(19 , happyReduce_19),
+	(20 , happyReduce_20),
+	(21 , happyReduce_21),
+	(22 , happyReduce_22),
+	(23 , happyReduce_23),
+	(24 , happyReduce_24),
+	(25 , happyReduce_25),
+	(26 , happyReduce_26),
+	(27 , happyReduce_27),
+	(28 , happyReduce_28),
+	(29 , happyReduce_29),
+	(30 , happyReduce_30),
+	(31 , happyReduce_31)
+	]
+
+happy_n_terms = 18 :: Int
+happy_n_nonterms = 19 :: Int
+
+happyReduce_1 = happySpecReduce_1 0# happyReduction_1
+happyReduction_1 happy_x_1
+	 =  case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) -> 
+	happyIn4
+		 (Ident happy_var_1
+	)}
+
+happyReduce_2 = happySpecReduce_1 1# happyReduction_2
+happyReduction_2 happy_x_1
+	 =  case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> 
+	happyIn5
+		 ((read happy_var_1) :: Integer
+	)}
+
+happyReduce_3 = happySpecReduce_1 2# happyReduction_3
+happyReduction_3 happy_x_1
+	 =  case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> 
+	happyIn6
+		 (happy_var_1
+	)}
+
+happyReduce_4 = happySpecReduce_1 3# happyReduction_4
+happyReduction_4 happy_x_1
+	 =  case happyOutTok happy_x_1 of { (PT _ (T_SingleQuoteString happy_var_1)) -> 
+	happyIn7
+		 (SingleQuoteString (happy_var_1)
+	)}
+
+happyReduce_5 = happySpecReduce_1 4# happyReduction_5
+happyReduction_5 happy_x_1
+	 =  case happyOut10 happy_x_1 of { happy_var_1 -> 
+	happyIn8
+		 (Grammars (reverse happy_var_1)
+	)}
+
+happyReduce_6 = happyReduce 6# 5# happyReduction_6
+happyReduction_6 (happy_x_6 `HappyStk`
+	happy_x_5 `HappyStk`
+	happy_x_4 `HappyStk`
+	happy_x_3 `HappyStk`
+	happy_x_2 `HappyStk`
+	happy_x_1 `HappyStk`
+	happyRest)
+	 = case happyOut4 happy_x_2 of { happy_var_2 -> 
+	case happyOut12 happy_x_3 of { happy_var_3 -> 
+	case happyOut14 happy_x_4 of { happy_var_4 -> 
+	happyIn9
+		 (Grammar happy_var_2 (reverse happy_var_3) (reverse happy_var_4)
+	) `HappyStk` happyRest}}}
+
+happyReduce_7 = happySpecReduce_0 6# happyReduction_7
+happyReduction_7  =  happyIn10
+		 ([]
+	)
+
+happyReduce_8 = happySpecReduce_2 6# happyReduction_8
+happyReduction_8 happy_x_2
+	happy_x_1
+	 =  case happyOut10 happy_x_1 of { happy_var_1 -> 
+	case happyOut9 happy_x_2 of { happy_var_2 -> 
+	happyIn10
+		 (flip (:) happy_var_1 happy_var_2
+	)}}
+
+happyReduce_9 = happySpecReduce_2 7# happyReduction_9
+happyReduction_9 happy_x_2
+	happy_x_1
+	 =  case happyOut22 happy_x_2 of { happy_var_2 -> 
+	happyIn11
+		 (StartCat happy_var_2
+	)}
+
+happyReduce_10 = happySpecReduce_0 8# happyReduction_10
+happyReduction_10  =  happyIn12
+		 ([]
+	)
+
+happyReduce_11 = happySpecReduce_3 8# happyReduction_11
+happyReduction_11 happy_x_3
+	happy_x_2
+	happy_x_1
+	 =  case happyOut12 happy_x_1 of { happy_var_1 -> 
+	case happyOut11 happy_x_2 of { happy_var_2 -> 
+	happyIn12
+		 (flip (:) happy_var_1 happy_var_2
+	)}}
+
+happyReduce_12 = happyReduce 7# 9# happyReduction_12
+happyReduction_12 (happy_x_7 `HappyStk`
+	happy_x_6 `HappyStk`
+	happy_x_5 `HappyStk`
+	happy_x_4 `HappyStk`
+	happy_x_3 `HappyStk`
+	happy_x_2 `HappyStk`
+	happy_x_1 `HappyStk`
+	happyRest)
+	 = case happyOut15 happy_x_1 of { happy_var_1 -> 
+	case happyOut16 happy_x_3 of { happy_var_3 -> 
+	case happyOut22 happy_x_5 of { happy_var_5 -> 
+	case happyOut21 happy_x_7 of { happy_var_7 -> 
+	happyIn13
+		 (Rule happy_var_1 happy_var_3 happy_var_5 happy_var_7
+	) `HappyStk` happyRest}}}}
+
+happyReduce_13 = happySpecReduce_0 10# happyReduction_13
+happyReduction_13  =  happyIn14
+		 ([]
+	)
+
+happyReduce_14 = happySpecReduce_3 10# happyReduction_14
+happyReduction_14 happy_x_3
+	happy_x_2
+	happy_x_1
+	 =  case happyOut14 happy_x_1 of { happy_var_1 -> 
+	case happyOut13 happy_x_2 of { happy_var_2 -> 
+	happyIn14
+		 (flip (:) happy_var_1 happy_var_2
+	)}}
+
+happyReduce_15 = happySpecReduce_1 11# happyReduction_15
+happyReduction_15 happy_x_1
+	 =  case happyOut4 happy_x_1 of { happy_var_1 -> 
+	happyIn15
+		 (Cons happy_var_1
+	)}
+
+happyReduce_16 = happySpecReduce_1 11# happyReduction_16
+happyReduction_16 happy_x_1
+	 =  happyIn15
+		 (Coerce
+	)
+
+happyReduce_17 = happySpecReduce_3 12# happyReduction_17
+happyReduction_17 happy_x_3
+	happy_x_2
+	happy_x_1
+	 =  case happyOut17 happy_x_2 of { happy_var_2 -> 
+	happyIn16
+		 (Profiles happy_var_2
+	)}
+
+happyReduce_18 = happySpecReduce_0 13# happyReduction_18
+happyReduction_18  =  happyIn17
+		 ([]
+	)
+
+happyReduce_19 = happySpecReduce_1 13# happyReduction_19
+happyReduction_19 happy_x_1
+	 =  case happyOut18 happy_x_1 of { happy_var_1 -> 
+	happyIn17
+		 ((:[]) happy_var_1
+	)}
+
+happyReduce_20 = happySpecReduce_3 13# happyReduction_20
+happyReduction_20 happy_x_3
+	happy_x_2
+	happy_x_1
+	 =  case happyOut18 happy_x_1 of { happy_var_1 -> 
+	case happyOut17 happy_x_3 of { happy_var_3 -> 
+	happyIn17
+		 ((:) happy_var_1 happy_var_3
+	)}}
+
+happyReduce_21 = happySpecReduce_3 14# happyReduction_21
+happyReduction_21 happy_x_3
+	happy_x_2
+	happy_x_1
+	 =  case happyOut19 happy_x_2 of { happy_var_2 -> 
+	happyIn18
+		 (UnifyProfile happy_var_2
+	)}
+
+happyReduce_22 = happySpecReduce_1 14# happyReduction_22
+happyReduction_22 happy_x_1
+	 =  case happyOut4 happy_x_1 of { happy_var_1 -> 
+	happyIn18
+		 (ConstProfile happy_var_1
+	)}
+
+happyReduce_23 = happySpecReduce_0 15# happyReduction_23
+happyReduction_23  =  happyIn19
+		 ([]
+	)
+
+happyReduce_24 = happySpecReduce_1 15# happyReduction_24
+happyReduction_24 happy_x_1
+	 =  case happyOut5 happy_x_1 of { happy_var_1 -> 
+	happyIn19
+		 ((:[]) happy_var_1
+	)}
+
+happyReduce_25 = happySpecReduce_3 15# happyReduction_25
+happyReduction_25 happy_x_3
+	happy_x_2
+	happy_x_1
+	 =  case happyOut5 happy_x_1 of { happy_var_1 -> 
+	case happyOut19 happy_x_3 of { happy_var_3 -> 
+	happyIn19
+		 ((:) happy_var_1 happy_var_3
+	)}}
+
+happyReduce_26 = happySpecReduce_1 16# happyReduction_26
+happyReduction_26 happy_x_1
+	 =  case happyOut22 happy_x_1 of { happy_var_1 -> 
+	happyIn20
+		 (CatS happy_var_1
+	)}
+
+happyReduce_27 = happySpecReduce_1 16# happyReduction_27
+happyReduction_27 happy_x_1
+	 =  case happyOut6 happy_x_1 of { happy_var_1 -> 
+	happyIn20
+		 (TermS happy_var_1
+	)}
+
+happyReduce_28 = happySpecReduce_1 17# happyReduction_28
+happyReduction_28 happy_x_1
+	 =  happyIn21
+		 ([]
+	)
+
+happyReduce_29 = happySpecReduce_1 17# happyReduction_29
+happyReduction_29 happy_x_1
+	 =  case happyOut20 happy_x_1 of { happy_var_1 -> 
+	happyIn21
+		 ((:[]) happy_var_1
+	)}
+
+happyReduce_30 = happySpecReduce_2 17# happyReduction_30
+happyReduction_30 happy_x_2
+	happy_x_1
+	 =  case happyOut20 happy_x_1 of { happy_var_1 -> 
+	case happyOut21 happy_x_2 of { happy_var_2 -> 
+	happyIn21
+		 ((:) happy_var_1 happy_var_2
+	)}}
+
+happyReduce_31 = happySpecReduce_1 18# happyReduction_31
+happyReduction_31 happy_x_1
+	 =  case happyOut7 happy_x_1 of { happy_var_1 -> 
+	happyIn22
+		 (Category happy_var_1
+	)}
+
+happyNewToken action sts stk [] =
+	happyDoAction 17# (error "reading EOF!") action sts stk []
+
+happyNewToken action sts stk (tk:tks) =
+	let cont i = happyDoAction i tk action sts stk tks in
+	case tk of {
+	PT _ (TS ";") -> cont 1#;
+	PT _ (TS ":") -> cont 2#;
+	PT _ (TS ".") -> cont 3#;
+	PT _ (TS "->") -> cont 4#;
+	PT _ (TS "_") -> cont 5#;
+	PT _ (TS "[") -> cont 6#;
+	PT _ (TS "]") -> cont 7#;
+	PT _ (TS ",") -> cont 8#;
+	PT _ (TS "end") -> cont 9#;
+	PT _ (TS "grammar") -> cont 10#;
+	PT _ (TS "startcat") -> cont 11#;
+	PT _ (TV happy_dollar_dollar) -> cont 12#;
+	PT _ (TI happy_dollar_dollar) -> cont 13#;
+	PT _ (TL happy_dollar_dollar) -> cont 14#;
+	PT _ (T_SingleQuoteString happy_dollar_dollar) -> cont 15#;
+	_ -> cont 16#;
+	_ -> happyError' (tk:tks)
+	}
+
+happyError_ tk tks = happyError' (tk:tks)
+
+happyThen :: () => Err a -> (a -> Err b) -> Err b
+happyThen = (thenM)
+happyReturn :: () => a -> Err a
+happyReturn = (returnM)
+happyThen1 m k tks = (thenM) m (\a -> k a tks)
+happyReturn1 :: () => a -> b -> Err a
+happyReturn1 = \a tks -> (returnM) a
+happyError' :: () => [Token] -> Err a
+happyError' = happyError
+
+pGrammars tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut8 x))
+
+happySeq = happyDontSeq
+
+returnM :: a -> Err a
+returnM = return
+
+thenM :: Err a -> (a -> Err b) -> Err b
+thenM = (>>=)
+
+happyError :: [Token] -> Err a
+happyError ts =
+  Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts)))
+
+myLexer = tokens
+{-# LINE 1 "GenericTemplate.hs" #-}
+-- $Id: ParCFG.hs,v 1.8 2005/05/17 14:04:37 bringert Exp $
+
+
+
+
+
+
+
+
+
+
+
+
+
+{-# LINE 27 "GenericTemplate.hs" #-}
+
+
+
+data Happy_IntList = HappyCons Int# Happy_IntList
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+infixr 9 `HappyStk`
+data HappyStk a = HappyStk a (HappyStk a)
+
+-----------------------------------------------------------------------------
+-- starting the parse
+
+happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
+
+-----------------------------------------------------------------------------
+-- Accepting the parse
+
+-- If the current token is 0#, it means we've just accepted a partial
+-- parse (a %partial parser).  We must ignore the saved token on the top of
+-- the stack in this case.
+happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =
+	happyReturn1 ans
+happyAccept j tk st sts (HappyStk ans _) = 
+	(happyTcHack j (happyTcHack st)) (happyReturn1 ans)
+
+-----------------------------------------------------------------------------
+-- Arrays only: do the next action
+
+
+
+happyDoAction i tk st
+	= {- nothing -}
+
+
+	  case action of
+		0#		  -> {- nothing -}
+				     happyFail i tk st
+		-1# 	  -> {- nothing -}
+				     happyAccept i tk st
+		n | (n <# (0# :: Int#)) -> {- nothing -}
+
+				     (happyReduceArr ! rule) i tk st
+				     where rule = (I# ((negateInt# ((n +# (1# :: Int#))))))
+		n		  -> {- nothing -}
+
+
+				     happyShift new_state i tk st
+				     where new_state = (n -# (1# :: Int#))
+   where off    = indexShortOffAddr happyActOffsets st
+	 off_i  = (off +# i)
+	 check  = if (off_i >=# (0# :: Int#))
+			then (indexShortOffAddr happyCheck off_i ==#  i)
+			else False
+ 	 action | check     = indexShortOffAddr happyTable off_i
+		| otherwise = indexShortOffAddr happyDefActions st
+
+
+
+
+
+
+
+
+
+
+
+indexShortOffAddr (HappyA# arr) off =
+#if __GLASGOW_HASKELL__ > 500
+	narrow16Int# i
+#elif __GLASGOW_HASKELL__ == 500
+	intToInt16# i
+#else
+	(i `iShiftL#` 16#) `iShiftRA#` 16#
+#endif
+  where
+#if __GLASGOW_HASKELL__ >= 503
+	i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
+#else
+	i = word2Int# ((high `shiftL#` 8#) `or#` low)
+#endif
+	high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
+	low  = int2Word# (ord# (indexCharOffAddr# arr off'))
+	off' = off *# 2#
+
+
+
+
+
+data HappyAddr = HappyA# Addr#
+
+
+
+
+-----------------------------------------------------------------------------
+-- HappyState data type (not arrays)
+
+{-# LINE 169 "GenericTemplate.hs" #-}
+
+
+-----------------------------------------------------------------------------
+-- Shifting a token
+
+happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =
+     let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in
+--     trace "shifting the error token" $
+     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)
+
+happyShift new_state i tk st sts stk =
+     happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)
+
+-- happyReduce is specialised for the common cases.
+
+happySpecReduce_0 i fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happySpecReduce_0 nt fn j tk st@((action)) sts stk
+     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)
+
+happySpecReduce_1 i fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')
+     = let r = fn v1 in
+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
+
+happySpecReduce_2 i fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')
+     = let r = fn v1 v2 in
+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
+
+happySpecReduce_3 i fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
+     = let r = fn v1 v2 v3 in
+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
+
+happyReduce k i fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happyReduce k nt fn j tk st sts stk
+     = case happyDrop (k -# (1# :: Int#)) sts of
+	 sts1@((HappyCons (st1@(action)) (_))) ->
+        	let r = fn stk in  -- it doesn't hurt to always seq here...
+       		happyDoSeq r (happyGoto nt j tk st1 sts1 r)
+
+happyMonadReduce k nt fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happyMonadReduce k nt fn j tk st sts stk =
+        happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))
+       where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))
+             drop_stk = happyDropStk k stk
+
+happyDrop 0# l = l
+happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t
+
+happyDropStk 0# l = l
+happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs
+
+-----------------------------------------------------------------------------
+-- Moving to a new state after a reduction
+
+
+happyGoto nt j tk st = 
+   {- nothing -}
+   happyDoAction j tk new_state
+   where off    = indexShortOffAddr happyGotoOffsets st
+	 off_i  = (off +# nt)
+ 	 new_state = indexShortOffAddr happyTable off_i
+
+
+
+
+-----------------------------------------------------------------------------
+-- Error recovery (0# is the error token)
+
+-- parse error if we are in recovery and we fail again
+happyFail  0# tk old_st _ stk =
+--	trace "failing" $ 
+    	happyError_ tk
+
+{-  We don't need state discarding for our restricted implementation of
+    "error".  In fact, it can cause some bogus parses, so I've disabled it
+    for now --SDM
+
+-- discard a state
+happyFail  0# tk old_st (HappyCons ((action)) (sts)) 
+						(saved_tok `HappyStk` _ `HappyStk` stk) =
+--	trace ("discarding state, depth " ++ show (length stk))  $
+	happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))
+-}
+
+-- Enter error recovery: generate an error token,
+--                       save the old token and carry on.
+happyFail  i tk (action) sts stk =
+--      trace "entering error recovery" $
+	happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk)
+
+-- Internal happy errors:
+
+notHappyAtAll = error "Internal Happy error\n"
+
+-----------------------------------------------------------------------------
+-- Hack to get the typechecker to accept our action functions
+
+
+happyTcHack :: Int# -> a -> a
+happyTcHack x y = y
+{-# INLINE happyTcHack #-}
+
+
+-----------------------------------------------------------------------------
+-- Seq-ing.  If the --strict flag is given, then Happy emits 
+--	happySeq = happyDoSeq
+-- otherwise it emits
+-- 	happySeq = happyDontSeq
+
+happyDoSeq, happyDontSeq :: a -> b -> b
+happyDoSeq   a b = a `seq` b
+happyDontSeq a b = b
+
+-----------------------------------------------------------------------------
+-- Don't inline any functions from the template.  GHC has a nasty habit
+-- of deciding to inline happyGoto everywhere, which increases the size of
+-- the generated parser quite a bit.
+
+
+{-# NOINLINE happyDoAction #-}
+{-# NOINLINE happyTable #-}
+{-# NOINLINE happyCheck #-}
+{-# NOINLINE happyActOffsets #-}
+{-# NOINLINE happyGotoOffsets #-}
+{-# NOINLINE happyDefActions #-}
+
+{-# NOINLINE happyShift #-}
+{-# NOINLINE happySpecReduce_0 #-}
+{-# NOINLINE happySpecReduce_1 #-}
+{-# NOINLINE happySpecReduce_2 #-}
+{-# NOINLINE happySpecReduce_3 #-}
+{-# NOINLINE happyReduce #-}
+{-# NOINLINE happyMonadReduce #-}
+{-# NOINLINE happyGoto #-}
+{-# NOINLINE happyFail #-}
+
+-- end of Happy Template.

src-2.9/GF/CFGM/ParCFG.y

@@ -0,0 +1,129 @@
+-- This Happy file was machine-generated by the BNF converter
+{
+module ParCFG where
+import AbsCFG
+import LexCFG
+import ErrM
+}
+
+%name pGrammars Grammars
+
+-- no lexer declaration
+%monad { Err } { thenM } { returnM }
+%tokentype { Token }
+
+%token 
+ ';' { PT _ (TS ";") }
+ ':' { PT _ (TS ":") }
+ '.' { PT _ (TS ".") }
+ '->' { PT _ (TS "->") }
+ '_' { PT _ (TS "_") }
+ '[' { PT _ (TS "[") }
+ ']' { PT _ (TS "]") }
+ ',' { PT _ (TS ",") }
+ 'end' { PT _ (TS "end") }
+ 'grammar' { PT _ (TS "grammar") }
+ 'startcat' { PT _ (TS "startcat") }
+
+L_ident  { PT _ (TV $$) }
+L_integ  { PT _ (TI $$) }
+L_quoted { PT _ (TL $$) }
+L_SingleQuoteString { PT _ (T_SingleQuoteString $$) }
+L_err    { _ }
+
+
+%%
+
+Ident   :: { Ident }   : L_ident  { Ident $1 }
+Integer :: { Integer } : L_integ  { (read $1) :: Integer }
+String  :: { String }  : L_quoted { $1 }
+SingleQuoteString    :: { SingleQuoteString} : L_SingleQuoteString { SingleQuoteString ($1)}
+
+Grammars :: { Grammars }
+Grammars : ListGrammar { Grammars (reverse $1) } 
+
+
+Grammar :: { Grammar }
+Grammar : 'grammar' Ident ListFlag ListRule 'end' 'grammar' { Grammar $2 (reverse $3) (reverse $4) } 
+
+
+ListGrammar :: { [Grammar] }
+ListGrammar : {- empty -} { [] } 
+  | ListGrammar Grammar { flip (:) $1 $2 }
+
+
+Flag :: { Flag }
+Flag : 'startcat' Category { StartCat $2 } 
+
+
+ListFlag :: { [Flag] }
+ListFlag : {- empty -} { [] } 
+  | ListFlag Flag ';' { flip (:) $1 $2 }
+
+
+Rule :: { Rule }
+Rule : Fun ':' Profiles '.' Category '->' ListSymbol { Rule $1 $3 $5 $7 } 
+
+
+ListRule :: { [Rule] }
+ListRule : {- empty -} { [] } 
+  | ListRule Rule ';' { flip (:) $1 $2 }
+
+
+Fun :: { Fun }
+Fun : Ident { Cons $1 } 
+  | '_' { Coerce }
+
+
+Profiles :: { Profiles }
+Profiles : '[' ListProfile ']' { Profiles $2 } 
+
+
+ListProfile :: { [Profile] }
+ListProfile : {- empty -} { [] } 
+  | Profile { (:[]) $1 }
+  | Profile ',' ListProfile { (:) $1 $3 }
+
+
+Profile :: { Profile }
+Profile : '[' ListInteger ']' { UnifyProfile $2 } 
+  | Ident { ConstProfile $1 }
+
+
+ListInteger :: { [Integer] }
+ListInteger : {- empty -} { [] } 
+  | Integer { (:[]) $1 }
+  | Integer ',' ListInteger { (:) $1 $3 }
+
+
+Symbol :: { Symbol }
+Symbol : Category { CatS $1 } 
+  | String { TermS $1 }
+
+
+ListSymbol :: { [Symbol] }
+ListSymbol : '.' { [] } 
+  | Symbol { (:[]) $1 }
+  | Symbol ListSymbol { (:) $1 $2 }
+
+
+Category :: { Category }
+Category : SingleQuoteString { Category $1 } 
+
+
+
+{
+
+returnM :: a -> Err a
+returnM = return
+
+thenM :: Err a -> (a -> Err b) -> Err b
+thenM = (>>=)
+
+happyError :: [Token] -> Err a
+happyError ts =
+  Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts)))
+
+myLexer = tokens
+}
+

src-2.9/GF/CFGM/PrintCFG.hs

@@ -0,0 +1,157 @@
+module GF.CFGM.PrintCFG where
+
+-- pretty-printer generated by the BNF converter
+
+import GF.CFGM.AbsCFG
+import Char
+
+-- the top-level printing method
+printTree :: Print a => a -> String
+printTree = render . prt 0
+
+type Doc = [ShowS] -> [ShowS]
+
+doc :: ShowS -> Doc
+doc = (:)
+
+render :: Doc -> String
+render d = rend 0 (map ($ "") $ d []) "" where
+  rend i ss = case ss of
+    "["      :ts -> showChar '[' . rend i ts
+    "("      :ts -> showChar '(' . rend i ts
+    "{"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts
+    "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
+    "}"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
+    ";"      :ts -> showChar ';' . new i . rend i ts
+    t  : "," :ts -> showString t . space "," . rend i ts
+    t  : ")" :ts -> showString t . showChar ')' . rend i ts
+    t  : "]" :ts -> showString t . showChar ']' . rend i ts
+    t        :ts -> space t . rend i ts
+    _            -> id
+  new i   = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
+  space t = showString t . (\s -> if null s then "" else (' ':s))
+
+parenth :: Doc -> Doc
+parenth ss = doc (showChar '(') . ss . doc (showChar ')')
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+concatD :: [Doc] -> Doc
+concatD = foldr (.) id
+
+replicateS :: Int -> ShowS -> ShowS
+replicateS n f = concatS (replicate n f)
+
+-- the printer class does the job
+class Print a where
+  prt :: Int -> a -> Doc
+  prtList :: [a] -> Doc
+  prtList = concatD . map (prt 0)
+
+instance Print a => Print [a] where
+  prt _ = prtList
+
+instance Print Char where
+  prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
+  prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
+
+mkEsc :: Char -> Char -> ShowS
+mkEsc q s = case s of
+  _ | s == q -> showChar '\\' . showChar s
+  '\\'-> showString "\\\\"
+  '\n' -> showString "\\n"
+  '\t' -> showString "\\t"
+  _ -> showChar s
+
+prPrec :: Int -> Int -> Doc -> Doc
+prPrec i j = if j<i then parenth else id
+
+
+instance Print Integer where
+  prt _ x = doc (shows x)
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+
+instance Print Double where
+  prt _ x = doc (shows x)
+
+
+instance Print Ident where
+  prt _ (Ident i) = doc (showString i)
+
+
+instance Print SingleQuoteString where
+  prt _ (SingleQuoteString i) = doc (showString i)
+
+
+
+instance Print Grammars where
+  prt i e = case e of
+   Grammars grammars -> prPrec i 0 (concatD [prt 0 grammars])
+
+
+instance Print Grammar where
+  prt i e = case e of
+   Grammar id flags rules -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 id , prt 0 flags , prt 0 rules , doc (showString "end") , doc (showString "grammar")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print Flag where
+  prt i e = case e of
+   StartCat category -> prPrec i 0 (concatD [doc (showString "startcat") , prt 0 category])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Rule where
+  prt i e = case e of
+   Rule fun profiles category symbols -> prPrec i 0 (concatD [prt 0 fun , doc (showString ":") , prt 0 profiles , doc (showString ".") , prt 0 category , doc (showString "->") , prt 0 symbols])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Fun where
+  prt i e = case e of
+   Cons id -> prPrec i 0 (concatD [prt 0 id])
+   Coerce  -> prPrec i 0 (concatD [doc (showString "_")])
+
+
+instance Print Profiles where
+  prt i e = case e of
+   Profiles profiles -> prPrec i 0 (concatD [doc (showString "[") , prt 0 profiles , doc (showString "]")])
+
+
+instance Print Profile where
+  prt i e = case e of
+   UnifyProfile ns -> prPrec i 0 (concatD [doc (showString "[") , prt 0 ns , doc (showString "]")])
+   ConstProfile id -> prPrec i 0 (concatD [prt 0 id])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Symbol where
+  prt i e = case e of
+   CatS category -> prPrec i 0 (concatD [prt 0 category])
+   TermS str -> prPrec i 0 (concatD [prt 0 str])
+
+  prtList es = case es of
+   [] -> (concatD [doc (showString ".")])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print Category where
+  prt i e = case e of
+   Category singlequotestring -> prPrec i 0 (concatD [prt 0 singlequotestring])
+
+
+

src-2.9/GF/CFGM/PrintCFGrammar.hs

@@ -0,0 +1,113 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PrintCFGrammar
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/17 14:04:38 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.20 $
+--
+-- Handles printing a CFGrammar in CFGM format.
+-----------------------------------------------------------------------------
+
+module GF.CFGM.PrintCFGrammar (prCanonAsCFGM) where
+
+import GF.Canon.AbsGFC
+import qualified GF.CFGM.PrintCFG as PrintCFG
+import GF.Infra.Ident
+import GF.Canon.GFC
+import GF.Infra.Modules
+
+import qualified GF.Conversion.GFC as Cnv
+import GF.Infra.Print (prt)
+import GF.Formalism.CFG (CFRule(..))
+import qualified GF.Formalism.Utilities as GU
+import qualified GF.Conversion.Types as GT
+import qualified GF.CFGM.AbsCFG as AbsCFG
+import GF.Formalism.Utilities (Symbol(..))
+
+import GF.Data.ErrM
+import GF.Data.Utilities (compareBy)
+import qualified GF.Infra.Option as Option
+
+import Data.List (intersperse, sortBy)
+import Data.Maybe (listToMaybe, maybeToList, maybe)
+
+import GF.Infra.Print
+import GF.System.Tracing
+
+-- | FIXME: should add an Options argument,
+-- to be able to decide which CFG conversion one wants to use
+prCanonAsCFGM :: Option.Options -> CanonGrammar -> String
+prCanonAsCFGM opts gr = unlines $ map (prLangAsCFGM gr) xs 
+    where 
+    cncs = maybe [] (allConcretes gr) (greatestAbstract gr)
+    cncms = map (\i -> (i,fromOk (lookupModule gr i))) cncs
+    fromOk (Ok x) = x
+    fromOk (Bad y) = error y
+    xs = tracePrt "CFGM languages" (prtBefore "\n") 
+	 [ (i, getFlag fs "startcat", getFlag fs "conversion") | 
+	   (i, ModMod (Module{flags=fs})) <- cncms ]
+
+-- | FIXME: need to look in abstract module too
+getFlag :: [Flag] -> String -> Maybe String
+getFlag fs x = listToMaybe [v | Flg (IC k) (IC v) <- fs, k == x]
+
+-- FIXME: (1) Should use 'ShellState.stateCFG'
+-- instead of 'Cnv.gfc2cfg' (which recalculates the grammar every time)
+--
+-- FIXME: (2) Should use the state options, when calculating the CFG
+-- (this is solved automatically if one solves (1) above)
+prLangAsCFGM :: CanonGrammar -> (Ident, Maybe String, Maybe String) -> String
+prLangAsCFGM gr (i, start, cnv) = prCFGrammarAsCFGM (Cnv.gfc2cfg opts (gr, i)) i start
+-- prLangAsCFGM gr i start = prCFGrammarAsCFGM (Cnv.cfg (Cnv.pInfo opts gr i)) i start
+     where opts = Option.Opts $ maybeToList $ fmap Option.gfcConversion cnv
+
+prCFGrammarAsCFGM :: GT.CGrammar -> Ident -> Maybe String -> String
+prCFGrammarAsCFGM gr i start = PrintCFG.printTree $ cfGrammarToCFGM gr i start
+
+cfGrammarToCFGM :: GT.CGrammar -> Ident -> Maybe String -> AbsCFG.Grammar
+cfGrammarToCFGM gr i start = 
+    AbsCFG.Grammar (identToCFGMIdent i) flags $ sortCFGMRules $ map ruleToCFGMRule gr
+    where flags = maybe [] (\c -> [AbsCFG.StartCat $ strToCFGMCat (c++"{}.s")]) start
+          sortCFGMRules = sortBy (compareBy ruleKey)
+          ruleKey (AbsCFG.Rule f ps cat rhs) = (cat,f)
+
+ruleToCFGMRule :: GT.CRule -> AbsCFG.Rule
+ruleToCFGMRule (CFRule c rhs (GU.Name fun profile)) 
+    = AbsCFG.Rule fun' p' c' rhs'
+    where 
+    fun' = identToFun fun
+    p' = profileToCFGMProfile profile
+    c' = catToCFGMCat c
+    rhs' = map symbolToGFCMSymbol rhs
+
+profileToCFGMProfile :: [GU.Profile (GU.SyntaxForest GT.Fun)] -> AbsCFG.Profiles
+profileToCFGMProfile = AbsCFG.Profiles . map cnvProfile
+    where cnvProfile (GU.Unify ns)   = AbsCFG.UnifyProfile $ map fromIntegral ns
+	  -- FIXME: is it always FNode?
+	  cnvProfile (GU.Constant (GU.FNode c _)) = AbsCFG.ConstProfile $ identToCFGMIdent c
+						  
+
+identToCFGMIdent :: Ident -> AbsCFG.Ident
+identToCFGMIdent = AbsCFG.Ident . prt
+
+identToFun :: Ident -> AbsCFG.Fun
+identToFun IW = AbsCFG.Coerce
+identToFun i = AbsCFG.Cons (identToCFGMIdent i)
+
+strToCFGMCat :: String -> AbsCFG.Category
+strToCFGMCat = AbsCFG.Category . AbsCFG.SingleQuoteString . quoteSingle
+
+catToCFGMCat :: GT.CCat -> AbsCFG.Category
+catToCFGMCat = strToCFGMCat . prt
+
+symbolToGFCMSymbol :: Symbol GT.CCat GT.Token -> AbsCFG.Symbol
+symbolToGFCMSymbol (Cat c) = AbsCFG.CatS (catToCFGMCat c)
+symbolToGFCMSymbol (Tok t) = AbsCFG.TermS (prt t)
+
+quoteSingle :: String -> String
+quoteSingle s = "'" ++ escapeSingle s ++ "'"
+    where escapeSingle = concatMap (\c -> if c == '\'' then "\\'" else [c])

src-2.9/GF/Canon/AbsGFC.hs

@@ -0,0 +1,182 @@
+module GF.Canon.AbsGFC where
+
+import GF.Infra.Ident --H
+
+-- Haskell module generated by the BNF converter, except --H
+
+-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H
+
+data Canon =
+   MGr [Ident] Ident [Module]
+ | Gr [Module]
+  deriving (Eq,Ord,Show)
+
+data Line =
+   LMulti [Ident] Ident
+ | LHeader ModType Extend Open
+ | LFlag Flag
+ | LDef Def
+ | LEnd
+  deriving (Eq,Ord,Show)
+
+data Module =
+   Mod ModType Extend Open [Flag] [Def]
+  deriving (Eq,Ord,Show)
+
+data ModType =
+   MTAbs Ident
+ | MTCnc Ident Ident
+ | MTRes Ident
+ | MTTrans Ident Ident Ident
+  deriving (Eq,Ord,Show)
+
+data Extend =
+   Ext [Ident]
+ | NoExt
+  deriving (Eq,Ord,Show)
+
+data Open =
+   Opens [Ident]
+ | NoOpens
+  deriving (Eq,Ord,Show)
+
+data Flag =
+   Flg Ident Ident
+  deriving (Eq,Ord,Show)
+
+data Def =
+   AbsDCat Ident [Decl] [CIdent]
+ | AbsDFun Ident Exp Exp
+ | AbsDTrans Ident Exp
+ | ResDPar Ident [ParDef]
+ | ResDOper Ident CType Term
+ | CncDCat Ident CType Term Term
+ | CncDFun Ident CIdent [ArgVar] Term Term
+ | AnyDInd Ident Status Ident
+  deriving (Eq,Ord,Show)
+
+data ParDef =
+   ParD Ident [CType]
+  deriving (Eq,Ord,Show)
+
+data Status =
+   Canon
+ | NonCan
+  deriving (Eq,Ord,Show)
+
+data CIdent =
+   CIQ Ident Ident
+  deriving (Eq,Ord,Show)
+
+data Exp =
+   EApp Exp Exp
+ | EProd Ident Exp Exp
+ | EAbs Ident Exp
+ | EAtom Atom
+ | EData
+ | EEq [Equation]
+  deriving (Eq,Ord,Show)
+
+data Sort =
+   SType
+  deriving (Eq,Ord,Show)
+
+data Equation =
+   Equ [APatt] Exp
+  deriving (Eq,Ord,Show)
+
+data APatt =
+   APC CIdent [APatt]
+ | APV Ident
+ | APS String
+ | API Integer
+ | APF Double
+ | APW
+  deriving (Eq,Ord,Show)
+
+data Atom =
+   AC CIdent
+ | AD CIdent
+ | AV Ident
+ | AM Integer
+ | AS String
+ | AI Integer
+ | AF Double
+ | AT Sort
+  deriving (Eq,Ord,Show)
+
+data Decl =
+   Decl Ident Exp
+  deriving (Eq,Ord,Show)
+
+data CType =
+   RecType [Labelling]
+ | Table CType CType
+ | Cn CIdent
+ | TStr
+ | TInts Integer
+  deriving (Eq,Ord,Show)
+
+data Labelling =
+   Lbg Label CType
+  deriving (Eq,Ord,Show)
+
+data Term =
+   Arg ArgVar
+ | I CIdent
+ | Par CIdent [Term]
+ | LI Ident
+ | R [Assign]
+ | P Term Label
+ | T CType [Case]
+ | V CType [Term]
+ | S Term Term
+ | C Term Term
+ | FV [Term]
+ | EInt Integer
+ | EFloat Double
+ | K Tokn
+ | E
+  deriving (Eq,Ord,Show)
+
+data Tokn =
+   KS String
+ | KP [String] [Variant]
+ | KM String
+  deriving (Eq,Ord,Show)
+
+data Assign =
+   Ass Label Term
+  deriving (Eq,Ord,Show)
+
+data Case =
+   Cas [Patt] Term
+  deriving (Eq,Ord,Show)
+
+data Variant =
+   Var [String] [String]
+  deriving (Eq,Ord,Show)
+
+data Label =
+   L Ident
+ | LV Integer
+  deriving (Eq,Ord,Show)
+
+data ArgVar =
+   A Ident Integer
+ | AB Ident Integer Integer
+  deriving (Eq,Ord,Show)
+
+data Patt =
+   PC CIdent [Patt]
+ | PV Ident
+ | PW
+ | PR [PattAssign]
+ | PI Integer
+ | PF Double
+  deriving (Eq,Ord,Show)
+
+data PattAssign =
+   PAss Label Patt
+  deriving (Eq,Ord,Show)
+

src-2.9/GF/Canon/AbsToBNF.hs

@@ -0,0 +1,38 @@
+module GF.Canon.AbsToBNF where
+
+import GF.Grammar.SGrammar
+import GF.Data.Operations
+import GF.Infra.Option
+import GF.Canon.GFC (CanonGrammar)
+
+-- AR 10/5/2007
+
+abstract2bnf :: CanonGrammar -> String
+abstract2bnf = sgrammar2bnf . gr2sgr noOptions emptyProbs
+
+sgrammar2bnf :: SGrammar -> String
+sgrammar2bnf = unlines . map (prBNFRule . mkBNF) . allRules
+
+prBNFRule :: BNFRule -> String
+prBNFRule = id
+
+type BNFRule = String
+
+mkBNF :: SRule -> BNFRule
+mkBNF (pfun,(args,cat)) = 
+  fun ++ "." +++ gfId cat +++ "::=" +++ rhs +++ ";"
+ where
+   fun = gfId (snd pfun)
+   rhs = case args of
+     [] -> prQuotedString (snd pfun)
+     _ -> unwords (map gfId args)
+
+-- good for GF
+gfId i = i
+
+-- good for BNFC
+gfIdd i = case i of
+  "Int"    -> "Integer"
+  "String" -> i 
+  "Float"  -> "Double"
+  _   -> "G" ++ i ++ "_"

src-2.9/GF/Canon/CMacros.hs

@@ -0,0 +1,334 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CMacros
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/14 16:03:41 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.29 $
+--
+-- Macros for building and analysing terms in GFC concrete syntax.
+--
+-- macros for concrete syntax in GFC that do not need lookup in a grammar
+-----------------------------------------------------------------------------
+
+module GF.Canon.CMacros where
+
+import GF.Infra.Ident
+import GF.Canon.AbsGFC
+import GF.Canon.GFC
+import qualified GF.Infra.Ident as A ---- no need to qualif? 21/9
+import qualified GF.Grammar.Values as V
+import qualified GF.Grammar.MMacros as M
+import GF.Grammar.PrGrammar
+import GF.Data.Str
+
+import GF.Data.Operations
+
+import Data.Char
+import Control.Monad
+
+-- | how to mark subtrees, dep. on node, position, whether focus
+type JustMarker = V.TrNode -> [Int] -> Bool -> (String, String)
+
+-- | also to process the text (needed for escapes e.g. in XML)
+type Marker = (JustMarker, Maybe (String -> String))
+
+defTMarker :: JustMarker -> Marker
+defTMarker = flip (curry id) Nothing
+
+markSubtree :: Marker -> V.TrNode -> [Int] -> Bool -> Term -> Term
+markSubtree (mk,esc) n is = markSubterm esc . mk n is
+
+escapeMkString :: Marker -> Maybe (String -> String)
+escapeMkString = snd
+
+-- | if no marking is wanted, use the following
+noMark :: Marker
+noMark = defTMarker mk where
+  mk _ _ _ = ("","")
+
+-- | mark metas with their categories
+metaCatMark :: Marker
+metaCatMark = defTMarker mk where
+  mk nod _ _ = case nod of
+    V.N (_,V.AtM _,val,_,_) -> ("", '+':prt val)
+    _ -> ("","")
+
+-- | for vanilla brackets, focus, and position, use
+markBracket :: Marker
+markBracket = defTMarker mk where
+  mk n p b = if b then ("[*" ++ show p,"*]") else ("[" ++ show p,"]")
+
+-- | for focus only
+markFocus :: Marker
+markFocus = defTMarker mk where
+  mk n p b = if b then ("[*","*]") else ("","")
+
+-- | for XML, use
+markJustXML :: JustMarker
+markJustXML n i b = 
+  if b 
+    then ("<focus"   +++ p +++ c ++ s ++ ">", "</focus>") 
+    else ("<subtree" +++ p +++ c ++ s ++ ">", "</subtree>") 
+   where 
+     c = "type=" ++ prt (M.valNode n)
+     p = "position=" ++ (show $ reverse i)
+     s = if (null (M.constrsNode n)) then "" else " status=incorrect"
+
+markXML :: Marker
+markXML = (markJustXML, Just esc) where
+  esc s = case s of
+   '\\':'<':cs  -> '\\':'<':esc cs
+   '\\':'>':cs  -> '\\':'>':esc cs
+   '\\':'\\':cs -> '\\':'\\':esc cs
+   ----- the first 3 needed because marking may revisit; needs to be fixed
+
+   '<':cs  -> '\\':'<':esc cs
+   '>':cs  -> '\\':'>':esc cs
+   '\\':cs -> '\\':'\\':esc cs
+   c  :cs  -> c     :esc cs
+   _ -> s
+
+-- | for XML in JGF 1, use
+markXMLjgf :: Marker
+markXMLjgf = defTMarker mk where
+ mk n p b = 
+  if b 
+    then ("<focus" +++ c ++ ">", "</focus>") 
+    else ("","")
+   where 
+     c = "type=" ++ prt (M.valNode n)
+
+-- | the marking engine
+markSubterm :: Maybe (String -> String) -> (String,String) -> Term -> Term
+markSubterm esc (beg, end) t = case t of
+  R rs -> R $ map markField rs 
+  T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs]
+  FV ts -> FV $ map mark ts
+  _    -> foldr1 C (tm beg ++ [mkEscIf t] ++ tm end)  -- t : Str guaranteed?
+ where
+   mark = markSubterm esc (beg, end)
+   markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt
+   tm s = if null s then [] else [tM s]
+   mkEscIf t = case esc of
+     Just f -> mkEsc f t
+     _ -> t
+   mkEsc f t = case t of
+     K (KS s) -> K (KS (f s))
+     C u v    -> C (mkEsc f u) (mkEsc f v)
+     FV ts    -> FV (map (mkEsc f) ts)
+     _ -> t ---- do we need to look at other cases?
+
+tK,tM :: String -> Term
+tK = K . KS
+tM = K . KM
+
+term2patt :: Term -> Err Patt
+term2patt trm = case trm of
+  Par c aa -> do
+    aa' <- mapM term2patt aa
+    return (PC c aa')
+  R r -> do
+    let (ll,aa) = unzip [(l,a) | Ass l a <- r]
+    aa' <- mapM term2patt aa
+    return (PR (map (uncurry PAss) (zip ll aa')))
+  LI x -> return $ PV x
+  EInt i -> return $ PI i
+  EFloat i -> return $ PF i
+  FV (t:_) -> term2patt t ----
+  _ -> prtBad "no pattern corresponds to term" trm
+
+patt2term :: Patt -> Term
+patt2term p = case p of
+  PC x ps -> Par x (map patt2term ps)
+  PV x    -> LI x
+  PW      -> anyTerm ----
+  PR pas  -> R [ Ass lbl (patt2term q) | PAss lbl q <- pas ]
+  PI i    -> EInt i
+  PF i    -> EFloat i
+
+anyTerm :: Term
+anyTerm  = LI (A.identC "_") --- should not happen
+
+matchPatt :: [Case] -> Term -> Err Term
+matchPatt cs0 (FV ts) = liftM FV $ mapM (matchPatt cs0) ts
+matchPatt cs0 trm = term2patt trm >>= match cs0 where
+  match cs t = 
+    case cs of
+      Cas ps b  :_ | elem t ps -> return b
+      _:cs'                    -> match cs' t
+      []                       -> Bad $ "pattern not found for" +++ prt t 
+              +++ "among" ++++ unlines (map prt cs0)  ---- debug 
+
+defLinType :: CType
+defLinType = RecType [Lbg (L (A.identC "s")) TStr]
+
+defLindef :: Term
+defLindef = R [Ass (L (A.identC "s")) (Arg (A (A.identC "str") 0))]
+
+isDiscontinuousCType :: CType -> Bool
+isDiscontinuousCType t = case t of
+  RecType rs -> length [t | Lbg _ t <- rs, valTableType t == TStr] > 1
+  _ -> True --- does not occur; would not behave well in lin commands
+
+valTableType :: CType -> CType
+valTableType t = case t of
+  Table _ v -> valTableType v
+  _ -> t
+
+strsFromTerm :: Term -> Err [Str]
+strsFromTerm t = case t of
+  K (KS s) -> return [str s]
+  K (KM s) -> return [str s]
+  K (KP d vs) -> return $ [Str [TN d [(s,v) | Var s v <- vs]]]
+  C s t -> do
+    s' <- strsFromTerm s
+    t' <- strsFromTerm t
+    return [plusStr x y | x <- s', y <- t']
+  FV ts -> liftM concat $ mapM strsFromTerm ts
+  E -> return [str []]
+  _ -> return [str ("BUG[" ++ prt t ++ "]")] ---- debug
+----  _ -> prtBad "cannot get Str from term " t
+
+-- | recursively collect all branches in a table
+allInTable :: Term -> [Term]
+allInTable t =  case t of
+  T _ ts -> concatMap (\ (Cas _ v) -> allInTable v) ts --- expand ?
+  _    -> [t]
+
+-- | to gather s-fields; assumes term in normal form, preserves label
+allLinFields :: Term -> Err [[(Label,Term)]]
+allLinFields trm = case trm of
+----  R rs  -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good
+  R rs  -> return [[(l,t) | Ass l t <- rs, isLinLabel l]] ---- bad
+  FV ts -> do
+    lts <- mapM allLinFields ts
+    return $ concat lts
+
+  T _ ts -> liftM concat $ mapM allLinFields [t | Cas _ t <- ts]
+  V _ ts -> liftM concat $ mapM allLinFields ts
+  S t _  -> allLinFields t
+
+  _ -> prtBad "fields can only be sought in a record not in" trm
+
+-- | deprecated
+isLinLabel :: Label -> Bool
+isLinLabel l = case l of
+     L (A.IC ('s':cs)) | all isDigit cs -> True
+     -- peb (28/4-04), for MCFG grammars to work:
+     L (A.IC cs) | null cs || head cs `elem` ".!" -> True
+     _ -> False
+
+-- | to gather ultimate cases in a table; preserves pattern list
+allCaseValues :: Term -> [([Patt],Term)]
+allCaseValues trm = case trm of
+  T _ cs -> [(p:ps, t) | Cas pp t0 <- cs, p <- pp, (ps,t) <- allCaseValues t0]
+  _      -> [([],trm)]
+
+-- | to gather all linearizations; assumes normal form, preserves label and args
+allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]]
+allLinValues trm = do
+  lts <- allLinFields trm
+  mapM (mapPairsM (return . allCaseValues)) lts
+
+-- | to gather all fields; does not assume s naming of fields; 
+-- used in Morpho only
+allAllLinValues :: Term -> Err [[(Label,[([Patt],Term)])]]
+allAllLinValues trm = do
+  lts <- allFields trm
+  mapM (mapPairsM (return . allCaseValues)) lts
+ where
+  allFields trm = case trm of
+    R rs  -> return [[(l,t) | Ass l t <- rs]]
+    FV ts -> do
+      lts <- mapM allFields ts
+      return $ concat lts
+    _ -> prtBad "fields can only be sought in a record not in" trm
+
+-- | to gather all linearizations, even from nested records; params ignored
+allLinBranches :: Term -> [([Label],Term)]
+allLinBranches trm = case trm of
+  R rs   -> [(l:ls,u) | Ass l t <- rs, (ls,u) <- allLinBranches t] 
+  FV ts  -> concatMap allLinBranches ts
+  T _ ts -> concatMap allLinBranches [t | Cas _ t <- ts]
+  V _ ts -> concatMap allLinBranches ts
+  _ -> [([],trm)]
+
+redirectIdent :: A.Ident -> CIdent -> CIdent
+redirectIdent n f@(CIQ _ c) = CIQ n c
+
+ciq :: A.Ident -> A.Ident -> CIdent
+ciq n f = CIQ n f
+
+wordsInTerm :: Term -> [String]
+wordsInTerm trm = filter (not . null) $ case trm of
+   K (KS s) -> [s]
+   S c _   -> wo c
+   R rs    -> concat [wo t | Ass _ t <- rs]
+   T _ cs  -> concat [wo t | Cas _ t <- cs]
+   V _ cs  -> concat [wo t | t <- cs]
+   C s t   -> wo s ++ wo t
+   FV ts   -> concatMap wo ts
+   K (KP ss vs) -> ss ++ concat [s | Var s _ <- vs]
+   P t _   -> wo t --- not needed ?
+   _       -> []
+ where wo = wordsInTerm
+
+onTokens :: (String -> String) -> Term -> Term
+onTokens f t = case t of
+   K (KS s) -> K (KS (f s))
+   K (KP ss vs) -> K (KP (map f ss) [Var (map f x) (map f y) | Var x y <- vs])
+   _ -> composSafeOp (onTokens f) t
+
+-- | to define compositional term functions
+composSafeOp :: (Term -> Term) -> Term -> Term
+composSafeOp op trm = case composOp (mkMonadic op) trm of
+  Ok t -> t
+  _ -> error "the operation is safe isn't it ?"
+ where
+ mkMonadic f = return . f
+
+-- | to define compositional term functions
+composOp :: Monad m => (Term -> m Term) -> Term -> m Term
+composOp co trm = 
+ case trm of
+  Par x as ->
+      do
+      as' <- mapM co as
+      return (Par x as')
+  R as -> 
+      do
+      let onAss (Ass l t) = liftM (Ass l) (co t)
+      as' <- mapM onAss as
+      return (R as')
+  P a x ->
+      do
+      a' <- co a
+      return (P a' x)
+  T x as ->
+      do
+      let onCas (Cas ps t) = liftM (Cas ps) (co t)
+      as' <- mapM onCas as
+      return (T x as')
+  S a b ->
+      do
+      a' <- co a
+      b' <- co b
+      return (S a' b')
+  C a b ->
+      do
+      a' <- co a
+      b' <- co b
+      return (C a' b')
+  FV as -> 
+      do
+      as' <- mapM co as
+      return (FV as')
+  V x as -> 
+      do 
+      as' <- mapM co as
+      return (V x as')
+  _ -> return trm -- covers Arg, I, LI, K, E

src-2.9/GF/Canon/CanonToGFCC.hs

@@ -0,0 +1,45 @@
+module GF.Canon.CanonToGFCC where
+
+import GF.Devel.GrammarToGFCC
+import GF.Devel.PrintGFCC
+import GF.GFCC.CheckGFCC (checkGFCCmaybe)
+import GF.GFCC.OptimizeGFCC
+import GF.Canon.AbsGFC
+import GF.Canon.GFC
+import GF.Canon.CanonToGrammar
+import GF.Canon.Subexpressions
+import GF.Devel.PrintGFCC
+import GF.Grammar.PrGrammar
+
+import qualified GF.Infra.Modules as M
+import GF.Infra.Option
+
+import GF.Data.Operations
+import GF.Text.UTF8
+
+canon2gfccPr opts = printGFCC . canon2gfcc opts
+canon2gfcc opts = source2gfcc opts . canon2source ----
+canon2source = err error id . canon2sourceGrammar . unSubelimCanon
+
+source2gfcc opts gf = 
+  let 
+    (abs,gfcc) = mkCanon2gfcc opts (gfcabs gf) gf
+    gfcc1 = maybe undefined id $ checkGFCCmaybe gfcc
+  in addParsers $ if oElem (iOpt "noopt") opts then gfcc1 else optGFCC gfcc1
+
+gfcabs gfc = 
+  prt $ head $ M.allConcretes gfc $ maybe (error "no abstract") id $ 
+   M.greatestAbstract gfc
+
+{-
+-- this variant makes utf8 conversion; used in back ends
+mkCanon2gfcc :: CanonGrammar -> D.GFCC
+mkCanon2gfcc = 
+-- canon2gfcc . reorder abs . utf8Conv . canon2canon abs
+  optGFCC . canon2gfcc . reorder . utf8Conv . canon2canon . normalize
+
+-- this variant makes no utf8 conversion; used in ShellState
+mkCanon2gfccNoUTF8 :: CanonGrammar -> D.GFCC
+mkCanon2gfccNoUTF8 = optGFCC . canon2gfcc . reorder . canon2canon . normalize
+-}
+

src-2.9/GF/Canon/CanonToGrammar.hs

@@ -0,0 +1,203 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CanonToGrammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/17 14:15:17 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.15 $
+--
+-- a decompiler. AR 12/6/2003 -- 19/4/2004
+-----------------------------------------------------------------------------
+
+module GF.Canon.CanonToGrammar (canon2sourceGrammar, canon2sourceModule, redFlag) where
+
+import GF.Canon.AbsGFC
+import GF.Canon.GFC
+import GF.Canon.MkGFC
+---import CMacros
+import qualified GF.Infra.Modules as M
+import qualified GF.Infra.Option as O
+import qualified GF.Grammar.Grammar as G
+import qualified GF.Grammar.Macros as F
+
+import GF.Infra.Ident
+import GF.Data.Operations
+
+import Control.Monad
+
+canon2sourceGrammar :: CanonGrammar -> Err G.SourceGrammar
+canon2sourceGrammar gr = do
+  ms' <- mapM canon2sourceModule $ M.modules gr
+  return $ M.MGrammar ms'
+
+canon2sourceModule :: CanonModule -> Err G.SourceModule
+canon2sourceModule (i,mi) = do
+  i'    <- redIdent i 
+  info' <- case mi of
+    M.ModMod m -> do
+      (e,os) <- redExtOpen m
+      flags  <- mapM redFlag $ M.flags m 
+      (abstr,mt)  <- case M.mtype m of
+          M.MTConcrete a -> do
+            a' <- redIdent a
+            return (a', M.MTConcrete a') 
+          M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed
+          M.MTResource -> return (i',M.MTResource) --- c' not needed
+          M.MTTransfer x y -> return (i',M.MTTransfer x y) --- c' not needed
+      defs   <- mapMTree redInfo $ M.jments m
+      return $ M.ModMod $ M.Module mt (M.mstatus m) flags e os defs
+    _ -> Bad $ "cannot decompile module type"
+  return (i',info')
+ where
+   redExtOpen m = do
+     e'  <- return $ M.extend m
+     os' <- mapM (\ (M.OSimple q i) -> liftM (\i -> M.OQualif q i i) (redIdent i)) $ 
+                 M.opens m
+     return (e',os')
+
+redInfo :: (Ident,Info) -> Err (Ident,G.Info)
+redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
+  c' <- redIdent c 
+  info' <- case info of
+    AbsCat cont fs -> do
+      return $ G.AbsCat (Yes cont) (Yes (map (uncurry G.Q) fs))
+    AbsFun typ df -> do
+      return $ G.AbsFun (Yes typ) (Yes df)
+    AbsTrans t -> do
+      return $ G.AbsTrans t
+
+    ResPar par -> do
+      par' <- mapM redParam par
+      return $ G.ResParam (Yes (par',Nothing)) ---- list of values
+
+    ResOper pty ptr -> do
+      ty'  <- redCType pty
+      trm' <- redCTerm ptr
+      return $ G.ResOper (Yes ty') (Yes trm')
+
+    CncCat pty ptr ppr -> do
+      ty'  <- redCType pty
+      trm' <- redCTerm ptr
+      ppr' <- redCTerm ppr 
+      return $ G.CncCat (Yes ty') (Yes trm') (Yes ppr')      
+    CncFun (CIQ abstr cat) xx body ppr -> do
+      xx'   <- mapM redArgVar xx
+      body' <- redCTerm body
+      ppr'  <- redCTerm ppr
+      cat'  <- redIdent cat
+      return $ G.CncFun (Just (cat', ([],F.typeStr))) -- Nothing 
+        (Yes (F.mkAbs xx' body')) (Yes ppr')
+
+    AnyInd b c -> liftM (G.AnyInd b) $ redIdent c
+
+  return (c',info')
+
+redQIdent :: CIdent -> Err G.QIdent
+redQIdent (CIQ m c) = liftM2 (,) (redIdent m) (redIdent c)
+
+redIdent :: Ident -> Err Ident
+redIdent = return
+
+redFlag :: Flag -> Err O.Option
+redFlag (Flg f x) = return $ O.Opt (prIdent f,[prIdent x])
+
+redDecl :: Decl -> Err G.Decl
+redDecl (Decl x a) = liftM2 (,) (redIdent x) (redTerm a)
+
+redType :: Exp -> Err G.Type
+redType = redTerm
+
+redTerm :: Exp -> Err G.Term
+redTerm t = return $ trExp t
+
+-- resource
+
+redParam (ParD c cont) = do
+  c'    <- redIdent c
+  cont' <- mapM redCType cont
+  return $ (c', [(IW,t) | t <- cont'])
+
+-- concrete syntax
+
+redCType :: CType -> Err G.Type
+redCType t = case t of
+  RecType lbs -> do
+    let (ls,ts) = unzip [(l,t) | Lbg l t <- lbs]
+        ls' = map redLabel ls
+    ts' <- mapM redCType ts
+    return $ G.RecType $ zip ls' ts'
+  Table p v  -> liftM2 G.Table (redCType p) (redCType v)
+  Cn mc  -> liftM (uncurry G.QC) $ redQIdent mc
+  TStr -> return $ F.typeStr
+  TInts i -> return $ F.typeInts (fromInteger i)
+
+redCTerm :: Term -> Err G.Term
+redCTerm x = case x of
+  Arg argvar  -> liftM G.Vr $ redArgVar argvar
+  I cident  -> liftM (uncurry G.Q) $ redQIdent cident
+  Par cident terms  -> liftM2 F.mkApp 
+                         (liftM (uncurry G.QC) $ redQIdent cident) 
+                         (mapM redCTerm terms)
+  LI id  -> liftM G.Vr $ redIdent id
+  R assigns  -> do
+    let (ls,ts) = unzip [(l,t) | Ass l t <- assigns]
+    let ls' = map redLabel ls
+    ts' <- mapM redCTerm ts
+    return $ G.R [(l,(Nothing,t)) | (l,t) <- zip ls' ts']
+  P term label  -> liftM2 G.P (redCTerm term) (return $ redLabel label)
+  T ctype cases  -> do
+    ctype' <- redCType ctype
+    let (ps,ts) = unzip [(p,t) | Cas [p] t <- cases]
+    ps' <- mapM redPatt ps
+    ts' <- mapM redCTerm ts
+    let tinfo = case ps' of
+                  [G.PV _] -> G.TTyped ctype'
+                  _ -> G.TComp ctype'
+    return $ G.T tinfo $ zip ps' ts'
+  V ctype ts  -> do
+    ctype' <- redCType ctype
+    ts' <- mapM redCTerm ts
+    return $ G.V ctype' ts'
+  S term0 term  -> liftM2 G.S (redCTerm term0) (redCTerm term)
+  C term0 term  -> liftM2 G.C (redCTerm term0) (redCTerm term)
+  FV terms  -> liftM G.FV $ mapM redCTerm terms
+  K (KS str) -> return $ G.K str
+  EInt i     -> return $ G.EInt i
+  EFloat i   -> return $ G.EFloat i
+  E  -> return $ G.Empty
+  K (KP d vs)  -> return $ 
+                    G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs])
+ where
+   tList ss = case ss of --- this should be in Macros
+     [] -> G.Empty
+     _ -> foldr1 G.C $ map G.K ss
+
+failure x = Bad $ "not yet" +++ show x ----
+
+redArgVar :: ArgVar -> Err Ident
+redArgVar x = case x of
+  A x i -> return $ IA (prIdent x, fromInteger i)
+  AB x b i -> return $ IAV (prIdent x, fromInteger b, fromInteger i)
+
+redLabel :: Label -> G.Label
+redLabel (L x) = G.LIdent $ prIdent x
+redLabel (LV i) = G.LVar $ fromInteger i
+
+redPatt :: Patt -> Err G.Patt
+redPatt p = case p of
+  PV x -> liftM G.PV $ redIdent x
+  PC mc ps -> do
+    (m,c) <- redQIdent mc
+    liftM (G.PP m c) (mapM redPatt ps) 
+  PR rs -> do
+    let (ls,ts) = unzip [(l,t) | PAss l t <- rs]
+        ls' = map redLabel ls
+    ts <- mapM redPatt ts
+    return $ G.PR $ zip ls' ts
+  PI i -> return $ G.PInt i
+  PF i -> return $ G.PFloat i
+  _ -> Bad $ "cannot recompile pattern" +++ show p
+

src-2.9/GF/Canon/GFC.cf

@@ -0,0 +1,170 @@
+-- top-level grammar
+
+-- Canonical GF. AR 27/4/2003
+
+entrypoints Canon, Line ;
+
+-- old approach: read in a whole grammar
+
+MGr. Canon ::= "grammar" [Ident] "of" Ident ";" [Module] ;
+Gr.  Canon ::= [Module] ;
+
+-- new approach: read line by line
+
+LMulti.  Line ::= "grammar" [Ident] "of" Ident ";" ;
+LHeader. Line ::= ModType "=" Extend Open "{" ;
+LFlag.   Line ::= Flag ";" ;
+LDef.    Line ::= Def ";" ;
+LEnd.    Line ::= "}" ;    
+
+Mod. Module ::= ModType "=" Extend Open "{" [Flag] [Def] "}" ;
+
+MTAbs.   ModType ::= "abstract" Ident ; 
+MTCnc.   ModType ::= "concrete" Ident "of" Ident ;
+MTRes.   ModType ::= "resource" Ident ;
+MTTrans. ModType ::= "transfer" Ident ":" Ident "->" Ident ;
+
+separator Module "" ;
+
+Ext.   Extend ::= [Ident] "**" ;
+NoExt. Extend ::= ;
+
+Opens.   Open ::= "open" [Ident] "in" ;
+NoOpens. Open ::= ;
+
+
+-- judgements
+
+Flg.  Flag ::= "flags" Ident "=" Ident ;  --- to have the same res word as in GF
+
+AbsDCat.   Def ::= "cat" Ident "[" [Decl] "]" "=" [CIdent] ;
+AbsDFun.   Def ::= "fun" Ident ":" Exp "=" Exp ;
+AbsDTrans. Def ::= "transfer" Ident "=" Exp ;
+
+ResDPar.   Def ::= "param"  Ident "=" [ParDef] ;
+ResDOper.  Def ::= "oper"   Ident ":" CType "=" Term ;
+
+CncDCat.   Def ::= "lincat" Ident "=" CType "=" Term ";" Term  ; 
+CncDFun.   Def ::= "lin"    Ident ":" CIdent "=" "\\" [ArgVar] "->" Term ";" Term ;
+
+AnyDInd.   Def ::= Ident Status "in" Ident ;
+
+ParD. ParDef ::= Ident [CType] ;
+
+-- the canonicity of an indirected constant
+
+Canon.  Status ::= "data" ;
+NonCan. Status ::= ;
+
+-- names originating from resource modules: prefixed by the module name
+
+CIQ. CIdent ::= Ident "." Ident ;
+
+-- types and terms in abstract syntax; no longer type-annotated
+
+EApp.   Exp1 ::= Exp1 Exp2 ;
+EProd.  Exp  ::= "(" Ident ":" Exp ")" "->" Exp ;
+EAbs.   Exp  ::= "\\" Ident "->" Exp ;
+EAtom.  Exp2 ::= Atom ;
+EData.  Exp2 ::= "data" ;
+
+EEq.    Exp  ::= "{" [Equation] "}" ;  -- list of pattern eqs; primitive notion: []
+
+coercions Exp 2 ;
+
+SType.  Sort ::= "Type" ;
+
+Equ. Equation ::= [APatt] "->" Exp ;
+
+APC. APatt ::= "(" CIdent [APatt] ")" ;
+APV. APatt ::= Ident ;
+APS. APatt ::= String ;
+API. APatt ::= Integer ;
+APF. APatt ::= Double ;
+APW. APatt ::= "_" ;
+
+separator Decl ";" ;
+terminator APatt "" ;
+terminator Equation ";" ;
+
+AC. Atom ::= CIdent ;
+AD. Atom ::= "<" CIdent ">" ;
+AV. Atom ::= "$" Ident ;
+AM. Atom ::= "?" Integer ;
+AS. Atom ::= String ;
+AI. Atom ::= Integer ;
+AT. Atom ::= Sort ;
+
+Decl. Decl ::= Ident ":" Exp ;
+
+
+-- types, terms, and patterns in concrete syntax
+
+RecType. CType ::= "{" [Labelling] "}" ;
+Table.   CType ::= "(" CType "=>" CType ")" ;
+Cn.      CType ::= CIdent ;
+TStr.    CType ::= "Str" ;
+TInts.   CType ::= "Ints" Integer ;
+
+Lbg.  Labelling ::= Label ":" CType ;
+
+Arg.  Term2 ::= ArgVar ;
+I.    Term2 ::= CIdent ; -- from resources
+Par.  Term2 ::= "<" CIdent [Term2] ">" ;
+LI.   Term2 ::= "$" Ident ;  -- from pattern variables
+
+R.    Term2 ::= "{" [Assign] "}" ;
+P.    Term1 ::= Term2 "." Label ;
+T.    Term1 ::= "table" CType "{" [Case] "}" ;
+V.    Term1 ::= "table" CType "[" [Term2] "]" ;
+S.    Term1 ::= Term1 "!" Term2 ;
+C.    Term  ::= Term "++" Term1 ;
+FV.   Term1 ::= "variants" "{" [Term2] "}" ;  --- no separator!
+
+EInt.   Term2 ::= Integer ;
+EFloat. Term2 ::= Double ;
+K.    Term2 ::= Tokn ;
+E.    Term2 ::= "[" "]" ;
+
+KS.   Tokn  ::= String ;
+KP.   Tokn  ::= "[" "pre" [String] "{" [Variant] "}" "]" ;
+internal KM.   Tokn  ::= String ; -- mark-up
+
+Ass.  Assign  ::= Label "=" Term ;
+Cas.  Case    ::= [Patt] "=>" Term ;
+Var.  Variant ::= [String] "/" [String] ;
+
+coercions Term 2 ;
+
+L.    Label  ::= Ident ;
+LV.   Label  ::= "$" Integer ;
+A.    ArgVar ::= Ident "@" Integer ;             -- no bindings
+AB.   ArgVar ::= Ident "+" Integer "@" Integer ; -- with a number of bindings
+
+PC.   Patt ::= "(" CIdent [Patt] ")" ;
+PV.   Patt ::= Ident ;
+PW.   Patt ::= "_" ;
+PR.   Patt ::= "{" [PattAssign] "}" ;
+PI.   Patt ::= Integer ;
+PF.   Patt ::= Double ;
+
+PAss. PattAssign ::= Label "=" Patt ;
+
+--- here we use the new pragmas to generate list rules
+
+terminator Flag ";" ;
+terminator Def ";" ;
+separator ParDef "|" ;
+separator CType "" ;
+separator CIdent "" ;
+separator Assign ";" ;
+separator ArgVar "," ;
+separator Labelling ";" ;
+separator Case ";" ;
+separator Term2 "" ;
+separator String "" ;
+separator Variant ";" ;
+separator PattAssign ";" ;
+separator Patt "" ;
+separator Ident "," ;
+

src-2.9/GF/Canon/GFC.hs

@@ -0,0 +1,103 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GFC
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:22 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.12 $
+--
+-- canonical GF. AR 10\/9\/2002 -- 9\/5\/2003 -- 21\/9
+-----------------------------------------------------------------------------
+
+module GF.Canon.GFC (Context,
+	    CanonGrammar,
+	    CanonModInfo,
+	    CanonModule,
+	    CanonAbs,
+	    Info(..),
+	    Printname,
+            prPrintnamesGrammar,
+	    mapInfoTerms,
+	    setFlag,
+            flagIncomplete,
+            isIncompleteCanon,
+            hasFlagCanon,
+            flagCanon
+	   ) where
+
+import GF.Canon.AbsGFC
+import GF.Canon.PrintGFC
+import qualified GF.Grammar.Abstract as A
+
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Data.Zipper
+import GF.Data.Operations
+import qualified GF.Infra.Modules as M
+
+import Data.Char
+import Control.Arrow (first)
+
+type Context = [(Ident,Exp)]
+
+type CanonGrammar = M.MGrammar Ident Flag Info
+
+type CanonModInfo = M.ModInfo Ident Flag Info
+
+type CanonModule = (Ident, CanonModInfo)
+
+type CanonAbs = M.Module Ident Option Info
+
+data Info =  
+   AbsCat  A.Context [A.Fun]
+ | AbsFun  A.Type A.Term
+ | AbsTrans A.Term
+
+ | ResPar  [ParDef]
+ | ResOper CType Term     -- ^ global constant
+ | CncCat  CType Term Printname
+ | CncFun  CIdent [ArgVar] Term Printname
+ | AnyInd Bool Ident
+  deriving (Show)
+
+type Printname = Term
+	      
+mapInfoTerms :: (Term -> Term) -> Info -> Info
+mapInfoTerms f i = case i of 
+         ResOper x a -> ResOper x (f a)
+	 CncCat  x a y -> CncCat x (f a) y
+	 CncFun  x y a z -> CncFun x y (f a) z
+	 _ -> i
+
+setFlag :: String -> String -> [Flag] -> [Flag]
+setFlag n v fs = flagCanon n v : [f | f@(Flg (IC n') _) <- fs, n' /= n]
+
+flagIncomplete :: Flag
+flagIncomplete = flagCanon "incomplete" "true"
+
+isIncompleteCanon :: CanonModule -> Bool
+isIncompleteCanon = hasFlagCanon flagIncomplete
+
+hasFlagCanon :: Flag -> CanonModule -> Bool
+hasFlagCanon f (_,M.ModMod mo) = elem f $ M.flags mo
+hasFlagCanon f _ = True ---- safe, useless 
+
+flagCanon :: String -> String -> Flag
+flagCanon f v = Flg (identC f) (identC v)
+
+-- for Ha-Jo 20/2/2005
+
+prPrintnamesGrammar :: CanonGrammar -> String
+prPrintnamesGrammar gr = unlines $ filter (not . null) [prPrint j | 
+  (_,M.ModMod m) <- M.modules gr,  
+  M.isModCnc m,
+  j <- tree2list $ M.jments m
+  ]
+  where
+    prPrint j = case j of
+      (c,CncCat _   _ p) -> "printname cat" +++ A.prt_ c +++ "=" +++ A.prt_ p
+      (c,CncFun _ _ _ p) -> "printname fun" +++ A.prt_ c +++ "=" +++ A.prt_ p
+      _ -> []

src-2.9/GF/Canon/GetGFC.hs

@@ -0,0 +1,78 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GetGFC
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 18:39:43 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.9 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Canon.GetGFC (getCanonModule, getCanonGrammar) where
+
+import GF.Data.Operations
+import GF.Canon.ParGFC
+import GF.Canon.GFC
+import GF.Canon.MkGFC
+import GF.Infra.Modules
+import GF.Infra.UseIO
+
+import System.IO
+import System.Directory
+import Control.Monad
+
+getCanonModule :: FilePath -> IOE CanonModule
+getCanonModule file = do
+  gr <- getCanonGrammar file
+  case modules gr of
+    [m] -> return m
+    _ -> ioeErr $ Bad "expected exactly one module in a file"
+
+getCanonGrammar :: FilePath -> IOE CanonGrammar
+-- getCanonGrammar = getCanonGrammarByLine
+getCanonGrammar file = do
+  s <- ioeIO $ readFileIf file
+  c <- ioeErr $ pCanon $ myLexer s
+  return $ canon2grammar c
+
+{-
+-- the following surprisingly does not save memory so it is
+-- not in use
+
+getCanonGrammarByLine :: FilePath -> IOE CanonGrammar
+getCanonGrammarByLine file = do
+  b <- ioeIO $ doesFileExist file
+  if not b 
+    then ioeErr $ Bad $ "file" +++ file +++ "does not exist"
+    else do
+   ioeIO $ putStrLn ""
+   hand <- ioeIO $ openFile file ReadMode ---- err
+   size <- ioeIO $ hFileSize hand
+   gr <- addNextLine (size,0) 1 hand emptyMGrammar
+   ioeIO $ hClose hand
+   return $ MGrammar $ reverse $ modules gr
+
+ where
+   addNextLine (size,act) d hand gr = do
+     eof <- ioeIO $ hIsEOF hand 
+     if eof 
+       then return gr 
+       else do
+         s <- ioeIO  $ hGetLine hand
+         let act' = act + toInteger (length s)
+--         if isHash act act' then (ioeIO $ putChar '#') else return () 
+         updGrammar act' d gr $ pLine $ myLexer s
+    where     
+      updGrammar a d gr (Ok t) = case buildCanonGrammar d gr t of 
+        (gr',d') -> addNextLine (size,a) d' hand gr'
+      updGrammar _ _ gr (Bad s) = do
+        ioeIO $ putStrLn s
+        return emptyMGrammar
+
+      isHash a b = a `div` step < b `div` step
+      step = size `div` 50
+-}

src-2.9/GF/Canon/LexGFC.hs

@@ -0,0 +1,346 @@
+{-# OPTIONS -fglasgow-exts -cpp #-}
+{-# LINE 3 "LexGFC.x" #-}
+module GF.Canon.LexGFC where --H
+
+import GF.Data.ErrM --H
+import GF.Data.SharedString --H
+
+#if __GLASGOW_HASKELL__ >= 603
+#include "ghcconfig.h"
+#else
+#include "config.h"
+#endif
+#if __GLASGOW_HASKELL__ >= 503
+import Data.Array
+import Data.Char (ord)
+import Data.Array.Base (unsafeAt)
+#else
+import Array
+import Char (ord)
+#endif
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.Exts
+#else
+import GlaExts
+#endif
+alex_base :: AlexAddr
+alex_base = AlexA# "\x01\x00\x00\x00\x39\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x1d\x00\x00\x00\x0b\x00\x00\x00\x20\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x15\x01\x00\x00\xd3\x00\x00\x00\x35\x00\x00\x00\xe5\x00\x00\x00\x3f\x00\x00\x00\xf0\x00\x00\x00\x1b\x01\x00\x00\x6d\x01\x00\x00"#
+
+alex_table :: AlexAddr
+alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x03\x00\x0a\x00\xff\xff\x03\x00\xff\xff\xff\xff\xff\xff\x03\x00\x03\x00\x07\x00\x05\x00\x03\x00\x06\x00\x03\x00\x03\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x03\x00\x03\x00\x03\x00\x04\x00\x03\x00\x03\x00\x03\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x03\x00\x03\x00\x03\x00\x03\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\xff\xff\x03\x00\xff\xff\x02\x00\x0f\x00\x00\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0c\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0a\x00\x00\x00\x00\x00\xff\xff\x08\x00\x0a\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x11\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x0b\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\x10\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
+
+alex_check :: AlexAddr
+alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3e\x00\x2b\x00\x3e\x00\x2a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xff\xff\xff\xff\xf7\x00\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
+
+alex_deflt :: AlexAddr
+alex_deflt = AlexA# "\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
+
+alex_accept = listArray (0::Int,17) [[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[],[],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[],[],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[],[],[]]
+{-# LINE 32 "LexGFC.x" #-}
+
+tok f p s = f p s
+
+share :: String -> String
+share = shareString
+
+data Tok =
+   TS !String     -- reserved words
+ | TL !String     -- string literals
+ | TI !String     -- integer literals
+ | TV !String     -- identifiers
+ | TD !String     -- double precision float literals
+ | TC !String     -- character literals
+
+ deriving (Eq,Show,Ord)
+
+data Token = 
+   PT  Posn Tok
+ | Err Posn
+  deriving (Eq,Show,Ord)
+
+tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
+tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
+tokenPos _ = "end of file"
+
+posLineCol (Pn _ l c) = (l,c)
+mkPosToken t@(PT p _) = (posLineCol p, prToken t)
+
+prToken t = case t of
+  PT _ (TS s) -> s
+  PT _ (TI s) -> s
+  PT _ (TV s) -> s
+  PT _ (TD s) -> s
+  PT _ (TC s) -> s
+
+  _ -> show t
+
+data BTree = N | B String Tok BTree BTree deriving (Show)
+
+eitherResIdent :: (String -> Tok) -> String -> Tok
+eitherResIdent tv s = treeFind resWords
+  where
+  treeFind N = tv s
+  treeFind (B a t left right) | s < a  = treeFind left
+                              | s > a  = treeFind right
+                              | s == a = t
+
+resWords = b "lin" (b "concrete" (b "Type" (b "Str" (b "Ints" N N) N) (b "cat" (b "abstract" N N) N)) (b "fun" (b "flags" (b "data" N N) N) (b "in" (b "grammar" N N) N))) (b "pre" (b "open" (b "of" (b "lincat" N N) N) (b "param" (b "oper" N N) N)) (b "transfer" (b "table" (b "resource" N N) N) (b "variants" N N)))
+   where b s = B s (TS s)
+
+unescapeInitTail :: String -> String
+unescapeInitTail = unesc . tail where
+  unesc s = case s of
+    '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
+    '\\':'n':cs  -> '\n' : unesc cs
+    '\\':'t':cs  -> '\t' : unesc cs
+    '"':[]    -> []
+    c:cs      -> c : unesc cs
+    _         -> []
+
+-------------------------------------------------------------------
+-- Alex wrapper code.
+-- A modified "posn" wrapper.
+-------------------------------------------------------------------
+
+data Posn = Pn !Int !Int !Int
+      deriving (Eq, Show,Ord)
+
+alexStartPos :: Posn
+alexStartPos = Pn 0 1 1
+
+alexMove :: Posn -> Char -> Posn
+alexMove (Pn a l c) '\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)
+alexMove (Pn a l c) '\n' = Pn (a+1) (l+1)   1
+alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)
+
+type AlexInput = (Posn, -- current position,
+		  Char,	-- previous char
+		  String)	-- current input string
+
+tokens :: String -> [Token]
+tokens str = go (alexStartPos, '\n', str)
+    where
+      go :: (Posn, Char, String) -> [Token]
+      go inp@(pos, _, str) =
+    	  case alexScan inp 0 of
+    	    AlexEOF                -> []
+    	    AlexError (pos, _, _)  -> fail $ show pos ++ ": lexical error"
+    	    AlexSkip  inp' len     -> go inp'
+    	    AlexToken inp' len act -> act pos (take len str) : (go inp')
+
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar (p, c, [])    = Nothing
+alexGetChar (p, _, (c:s)) =
+    let p' = alexMove p c
+     in p' `seq` Just (c, (p', c, s))
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (p, c, s) = c
+
+alex_action_1 = tok (\p s -> PT p (TS $ share s)) 
+alex_action_2 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) 
+alex_action_3 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) 
+alex_action_4 = tok (\p s -> PT p (TI $ share s))    
+alex_action_5 = tok (\p s -> PT p (TD $ share s)) 
+{-# LINE 1 "GenericTemplate.hs" #-}
+{-# LINE 1 "<built-in>" #-}
+{-# LINE 1 "<command line>" #-}
+{-# LINE 1 "GenericTemplate.hs" #-}
+-- -----------------------------------------------------------------------------
+-- ALEX TEMPLATE
+--
+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use
+-- it for any purpose whatsoever.
+
+-- -----------------------------------------------------------------------------
+-- INTERNALS and main scanner engine
+
+
+{-# LINE 35 "GenericTemplate.hs" #-}
+
+
+
+
+
+
+
+
+
+
+
+
+data AlexAddr = AlexA# Addr#
+
+#if __GLASGOW_HASKELL__ < 503
+uncheckedShiftL# = shiftL#
+#endif
+
+{-# INLINE alexIndexInt16OffAddr #-}
+alexIndexInt16OffAddr (AlexA# arr) off =
+#ifdef WORDS_BIGENDIAN
+  narrow16Int# i
+  where
+	i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
+	high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
+	low  = int2Word# (ord# (indexCharOffAddr# arr off'))
+	off' = off *# 2#
+#else
+  indexInt16OffAddr# arr off
+#endif
+
+
+
+
+
+{-# INLINE alexIndexInt32OffAddr #-}
+alexIndexInt32OffAddr (AlexA# arr) off = 
+#ifdef WORDS_BIGENDIAN
+  narrow32Int# i
+  where
+   i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`
+		     (b2 `uncheckedShiftL#` 16#) `or#`
+		     (b1 `uncheckedShiftL#` 8#) `or#` b0)
+   b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))
+   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))
+   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
+   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))
+   off' = off *# 4#
+#else
+  indexInt32OffAddr# arr off
+#endif
+
+
+
+
+
+#if __GLASGOW_HASKELL__ < 503
+quickIndex arr i = arr ! i
+#else
+-- GHC >= 503, unsafeAt is available from Data.Array.Base.
+quickIndex = unsafeAt
+#endif
+
+
+
+
+-- -----------------------------------------------------------------------------
+-- Main lexing routines
+
+data AlexReturn a
+  = AlexEOF
+  | AlexError  !AlexInput
+  | AlexSkip   !AlexInput !Int
+  | AlexToken  !AlexInput !Int a
+
+-- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act)
+alexScan input (I# (sc))
+  = alexScanUser undefined input (I# (sc))
+
+alexScanUser user input (I# (sc))
+  = case alex_scan_tkn user input 0# input sc AlexNone of
+	(AlexNone, input') ->
+		case alexGetChar input of
+			Nothing -> 
+
+
+
+				   AlexEOF
+			Just _ ->
+
+
+
+				   AlexError input'
+
+	(AlexLastSkip input len, _) ->
+
+
+
+		AlexSkip input len
+
+	(AlexLastAcc k input len, _) ->
+
+
+
+		AlexToken input len k
+
+
+-- Push the input through the DFA, remembering the most recent accepting
+-- state it encountered.
+
+alex_scan_tkn user orig_input len input s last_acc =
+  input `seq` -- strict in the input
+  case s of 
+    -1# -> (last_acc, input)
+    _ -> alex_scan_tkn' user orig_input len input s last_acc
+
+alex_scan_tkn' user orig_input len input s last_acc =
+  let 
+	new_acc = check_accs (alex_accept `quickIndex` (I# (s)))
+  in
+  new_acc `seq`
+  case alexGetChar input of
+     Nothing -> (new_acc, input)
+     Just (c, new_input) -> 
+
+
+
+	let
+		base   = alexIndexInt32OffAddr alex_base s
+		(I# (ord_c)) = ord c
+		offset = (base +# ord_c)
+		check  = alexIndexInt16OffAddr alex_check offset
+		
+		new_s = if (offset >=# 0#) && (check ==# ord_c)
+			  then alexIndexInt16OffAddr alex_table offset
+			  else alexIndexInt16OffAddr alex_deflt s
+	in
+	alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc
+
+  where
+	check_accs [] = last_acc
+	check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))
+	check_accs (AlexAccSkip : _)  = AlexLastSkip  input (I# (len))
+	check_accs (AlexAccPred a pred : rest)
+	   | pred user orig_input (I# (len)) input
+	   = AlexLastAcc a input (I# (len))
+	check_accs (AlexAccSkipPred pred : rest)
+	   | pred user orig_input (I# (len)) input
+	   = AlexLastSkip input (I# (len))
+	check_accs (_ : rest) = check_accs rest
+
+data AlexLastAcc a
+  = AlexNone
+  | AlexLastAcc a !AlexInput !Int
+  | AlexLastSkip  !AlexInput !Int
+
+data AlexAcc a user
+  = AlexAcc a
+  | AlexAccSkip
+  | AlexAccPred a (AlexAccPred user)
+  | AlexAccSkipPred (AlexAccPred user)
+
+type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool
+
+-- -----------------------------------------------------------------------------
+-- Predicates on a rule
+
+alexAndPred p1 p2 user in1 len in2
+  = p1 user in1 len in2 && p2 user in1 len in2
+
+--alexPrevCharIsPred :: Char -> AlexAccPred _ 
+alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input
+
+--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ 
+alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input
+
+--alexRightContext :: Int -> AlexAccPred _
+alexRightContext (I# (sc)) user _ _ input = 
+     case alex_scan_tkn user input 0# input sc AlexNone of
+	  (AlexNone, _) -> False
+	  _ -> True
+	-- TODO: there's no need to find the longest
+	-- match when checking the right context, just
+	-- the first match will do.
+
+-- used by wrappers
+iUnbox (I# (i)) = i

src-2.9/GF/Canon/LexGFC.x

@@ -0,0 +1,132 @@
+-- -*- haskell -*-
+-- This Alex file was machine-generated by the BNF converter
+{
+module GF.Canon.LexGFC where
+
+import GF.Data.ErrM -- H
+import GF.Data.SharedString -- H
+}
+
+
+$l = [a-zA-Z\192 - \255] # [\215 \247]    -- isolatin1 letter FIXME
+$c = [A-Z\192-\221] # [\215]    -- capital isolatin1 letter FIXME
+$s = [a-z\222-\255] # [\247]    -- small isolatin1 letter FIXME
+$d = [0-9]                -- digit
+$i = [$l $d _ ']          -- identifier character
+$u = [\0-\255]          -- universal: any character
+
+@rsyms =    -- reserved words consisting of special symbols
+   \; | \= | \{ | \} | \: | \- \> | \* \* | \[ | \] | \\ | \. | \( | \) | \_ | \< | \> | \$ | \? | \= \> | \! | \+ \+ | \/ | \@ | \+ | \| | \,
+
+:-
+
+$white+ ;
+@rsyms { tok (\p s -> PT p (TS $ share s)) }
+
+$l $i*   { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
+\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
+
+$d+      { tok (\p s -> PT p (TI $ share s))    }
+
+
+{
+
+tok f p s = f p s
+
+share :: String -> String
+share = shareString
+
+data Tok =
+   TS !String     -- reserved words
+ | TL !String     -- string literals
+ | TI !String     -- integer literals
+ | TV !String     -- identifiers
+ | TD !String     -- double precision float literals
+ | TC !String     -- character literals
+
+ deriving (Eq,Show,Ord)
+
+data Token = 
+   PT  Posn Tok
+ | Err Posn
+  deriving (Eq,Show,Ord)
+
+tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
+tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
+tokenPos _ = "end of file"
+
+posLineCol (Pn _ l c) = (l,c)
+mkPosToken t@(PT p _) = (posLineCol p, prToken t)
+
+prToken t = case t of
+  PT _ (TS s) -> s
+  PT _ (TI s) -> s
+  PT _ (TV s) -> s
+  PT _ (TD s) -> s
+  PT _ (TC s) -> s
+
+  _ -> show t
+
+data BTree = N | B String Tok BTree BTree deriving (Show)
+
+eitherResIdent :: (String -> Tok) -> String -> Tok
+eitherResIdent tv s = treeFind resWords
+  where
+  treeFind N = tv s
+  treeFind (B a t left right) | s < a  = treeFind left
+                              | s > a  = treeFind right
+                              | s == a = t
+
+resWords = b "lin" (b "concrete" (b "Type" (b "Str" (b "Ints" N N) N) (b "cat" (b "abstract" N N) N)) (b "fun" (b "flags" (b "data" N N) N) (b "in" (b "grammar" N N) N))) (b "pre" (b "open" (b "of" (b "lincat" N N) N) (b "param" (b "oper" N N) N)) (b "transfer" (b "table" (b "resource" N N) N) (b "variants" N N)))
+   where b s = B s (TS s)
+
+unescapeInitTail :: String -> String
+unescapeInitTail = unesc . tail where
+  unesc s = case s of
+    '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
+    '\\':'n':cs  -> '\n' : unesc cs
+    '\\':'t':cs  -> '\t' : unesc cs
+    '"':[]    -> []
+    c:cs      -> c : unesc cs
+    _         -> []
+
+-------------------------------------------------------------------
+-- Alex wrapper code.
+-- A modified "posn" wrapper.
+-------------------------------------------------------------------
+
+data Posn = Pn !Int !Int !Int
+      deriving (Eq, Show,Ord)
+
+alexStartPos :: Posn
+alexStartPos = Pn 0 1 1
+
+alexMove :: Posn -> Char -> Posn
+alexMove (Pn a l c) '\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)
+alexMove (Pn a l c) '\n' = Pn (a+1) (l+1)   1
+alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)
+
+type AlexInput = (Posn, -- current position,
+		  Char,	-- previous char
+		  String)	-- current input string
+
+tokens :: String -> [Token]
+tokens str = go (alexStartPos, '\n', str)
+    where
+      go :: (Posn, Char, String) -> [Token]
+      go inp@(pos, _, str) =
+    	  case alexScan inp 0 of
+    	    AlexEOF                -> []
+    	    AlexError (pos, _, _)  -> fail $ show pos ++ ": lexical error"
+    	    AlexSkip  inp' len     -> go inp'
+    	    AlexToken inp' len act -> act pos (take len str) : (go inp')
+
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar (p, c, [])    = Nothing
+alexGetChar (p, _, (c:s)) =
+    let p' = alexMove p c
+     in p' `seq` Just (c, (p', c, s))
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (p, c, s) = c
+}

src-2.9/GF/Canon/Look.hs

@@ -0,0 +1,225 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Look
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/20 09:32:56 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.17 $
+--
+-- lookup in GFC. AR 2003
+-----------------------------------------------------------------------------
+
+module GF.Canon.Look (lookupCncInfo,
+	     lookupLin,
+	     lookupLincat,
+	     lookupPrintname,
+	     lookupResInfo,
+	     lookupGlobal,
+	     lookupOptionsCan,
+	     lookupParamValues,
+	     allParamValues,
+	     ccompute
+	    ) where
+
+import GF.Canon.AbsGFC
+import GF.Canon.GFC
+import GF.Grammar.PrGrammar
+import GF.Canon.CMacros
+----import Values
+import GF.Grammar.MMacros
+import GF.Grammar.Macros (zIdent)
+import qualified GF.Infra.Modules as M
+import qualified GF.Canon.CanonToGrammar as CG
+
+import GF.Data.Operations
+import GF.Infra.Option
+
+import Control.Monad
+import Data.List
+
+-- linearization lookup
+
+lookupCncInfo :: CanonGrammar -> CIdent -> Err Info
+lookupCncInfo gr f@(CIQ m c) = do
+  mt <- M.lookupModule gr m
+  case mt of
+    M.ModMod a -> errIn ("module" +++ prt m) $ 
+                  lookupIdent c $ M.jments a 
+    _ -> prtBad "not concrete module" m
+
+lookupLin :: CanonGrammar -> CIdent -> Err Term
+lookupLin gr f = errIn "looking up linearization rule" $ do
+  info <- lookupCncInfo gr f
+  case info of
+    CncFun _ _ t _ -> return t
+    CncCat _ t _ -> return t
+    AnyInd _ n -> lookupLin gr $ redirectIdent n f
+
+lookupLincat :: CanonGrammar -> CIdent -> Err CType
+lookupLincat gr (CIQ _ c) | elem c [zIdent "String", zIdent "Int", zIdent "Float"] =
+  return defLinType --- ad hoc; not needed? cf. Grammar.Lookup.lookupLincat
+lookupLincat gr f = errIn "looking up linearization type" $ do
+  info <- lookupCncInfo gr f
+  case info of
+    CncCat t _ _ -> return t
+    AnyInd _ n -> lookupLincat gr $ redirectIdent n f
+    _ -> prtBad "no lincat found for" f
+
+lookupPrintname :: CanonGrammar -> CIdent -> Err Term
+lookupPrintname gr f = errIn "looking up printname" $ do
+  info <- lookupCncInfo gr f
+  case info of
+    CncFun _ _ _ t -> return t
+    CncCat _ _ t -> return t
+    AnyInd _ n -> lookupPrintname gr $ redirectIdent n f
+
+lookupResInfo :: CanonGrammar -> CIdent -> Err Info
+lookupResInfo gr f@(CIQ m c) = do
+  mt <- M.lookupModule gr m
+  case mt of
+    M.ModMod a -> lookupIdent c $ M.jments a 
+    _ -> prtBad "not resource module" m
+
+lookupGlobal :: CanonGrammar -> CIdent -> Err Term
+lookupGlobal gr f = do
+  info <- lookupResInfo gr f
+  case info of
+    ResOper _ t -> return t
+    AnyInd _ n -> lookupGlobal gr $ redirectIdent n f
+    _ -> prtBad "cannot find global" f
+
+lookupOptionsCan :: CanonGrammar -> Err Options
+lookupOptionsCan gr = do
+  let fs = M.allFlags gr
+  os <- mapM CG.redFlag fs
+  return $ options os
+
+lookupParamValues :: CanonGrammar -> CIdent -> Err [Term]
+lookupParamValues gr pt@(CIQ m _) = do
+  info <- lookupResInfo gr pt
+  case info of
+    ResPar ps -> liftM concat $ mapM mkPar ps
+    AnyInd _ n -> lookupParamValues gr $ redirectIdent n pt
+    _ -> prtBad "cannot find parameter type" pt
+ where
+   mkPar (ParD f co) = do
+     vs <- liftM combinations $ mapM (allParamValues gr) co
+     return $ map (Par (CIQ m f)) vs
+
+-- this is needed since param type can also be a record type
+
+allParamValues :: CanonGrammar -> CType -> Err [Term]
+allParamValues cnc ptyp = case ptyp of
+  Cn pc -> lookupParamValues cnc pc
+  RecType r -> do
+    let (ls,tys) = unzip [(l,t) | Lbg l t <- r]
+    tss <- mapM allPV tys
+    return [R (map (uncurry Ass) (zip ls ts)) | ts <- combinations tss]
+  TInts n -> return [EInt i | i <- [0..n]]
+  _ -> prtBad "cannot possibly find parameter values for" ptyp
+ where
+   allPV = allParamValues cnc
+
+-- runtime computation on GFC objects
+
+ccompute :: CanonGrammar -> [Term] -> Term -> Err Term
+ccompute cnc = vcomp
+ where
+
+  vcomp xs t = do
+    let xss = variations xs
+    ts <- mapM (\xx -> comp [] xx t) xss
+    return $ variants ts
+
+  variations xs = combinations [getVariants t | t <- xs]
+  variants ts = case ts of
+    [t] -> t
+    _ -> FV ts
+  getVariants t = case t of
+    FV ts -> ts
+    _ -> [t]
+
+  comp g xs t = case t of
+    Arg (A _ i)    -> err (const (return t)) return $ xs !? fromInteger i
+    Arg (AB _ _ i) -> err (const (return t)) return $ xs !? fromInteger i
+    I c     -> look c 
+    LI c    -> lookVar c g
+
+    -- short-cut computation of selections: compute the table only if needed
+    S u v   -> do
+      u' <- compt u
+      case u' of
+        T _ [Cas [PW] b] -> compt b  
+        T _ [Cas [PV x] b] -> do
+          v' <- compt v
+          comp ((x,v') : g) xs b  
+        T _ cs -> do
+          v' <- compt v
+          if noVar v' 
+             then matchPatt cs v' >>= compt
+             else return $ S u' v'
+        FV ccs -> do
+          v' <- compt v
+          mapM (\c -> compt (S c v')) ccs >>= return . FV
+
+        _      -> liftM (S u') $ compt v
+
+    P u l  -> do
+      u' <- compt u
+      case u' of
+        R rs -> maybe (Bad ("unknown label" +++ prt l +++ "in" +++ prt u'))
+                      return $ 
+                        lookup l [ (x,y) | Ass x y <- rs]
+        FV rrs -> do
+          mapM (\r -> compt (P r l)) rrs >>= return . FV
+
+        _    -> return $ P u' l
+    FV ts    -> liftM FV (mapM compt ts)
+    C E b    -> compt b
+    C a E    -> compt a
+    C a b    -> do
+      a' <- compt a
+      b' <- compt b
+      return $ case (a',b') of
+        (E,_) -> b'
+        (_,E) -> a'
+        _     -> C a' b'
+    R rs     -> liftM (R . map (uncurry Ass)) $ 
+                  mapPairsM compt [(l,r) | Ass l r <- rs]
+
+    -- only expand the table when the table is really needed: use expandLin
+    T ty rs -> liftM (T ty . map (uncurry Cas)) $ 
+                  mapPairsM compt [(l,r) | Cas l r <- rs]
+
+    V ptyp ts -> do
+      ts' <- mapM compt ts
+      vs0 <- allParamValues cnc ptyp
+      vs  <- mapM term2patt vs0
+      let cc = [Cas [p] u | (p,u) <- zip vs ts']
+      return $ T ptyp cc
+
+    Par c xs -> liftM (Par c) $ mapM compt xs
+
+    K (KS []) -> return E --- should not be needed
+
+    _        -> return t  
+   where
+     compt = comp g xs
+     look c = lookupGlobal cnc c >>= compt
+
+     lookVar c co = case lookup c co of
+       Just t -> return t
+       _ -> return $ LI c --- Bad $ "unknown local variable" +++ prt c --- 
+
+     noVar v = case v of
+       LI _ -> False
+       Arg _ -> False
+       R rs -> all noVar [t | Ass _ t <- rs]
+       Par _ ts -> all noVar ts
+       FV ts -> all noVar ts
+       S x y -> noVar x && noVar y
+       P t _ -> noVar t
+       _    -> True --- other cases that can be values to pattern match?

src-2.9/GF/Canon/MkGFC.hs

@@ -0,0 +1,237 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MkGFC
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/04 11:45:38 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.16 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Canon.MkGFC (prCanonModInfo, prCanon, prCanonMGr,
+	      canon2grammar, grammar2canon, -- buildCanonGrammar,
+	      info2mod,info2def,
+	      trExp, rtExp, rtQIdent) where
+
+import GF.Canon.GFC
+import GF.Canon.AbsGFC
+import qualified GF.Grammar.Abstract as A
+import GF.Grammar.PrGrammar
+
+import GF.Infra.Ident
+import GF.Data.Operations
+import qualified GF.Infra.Modules as M
+
+prCanonModInfo :: CanonModule -> String
+prCanonModInfo = prt . info2mod
+
+prCanon :: CanonGrammar -> String
+prCanon = unlines . map prCanonModInfo . M.modules
+
+prCanonMGr :: CanonGrammar -> String
+prCanonMGr g = header ++++ prCanon g where
+  header = case M.greatestAbstract g of
+    Just a -> prt (MGr (M.allConcretes g a) a [])
+    _ -> []
+
+canon2grammar :: Canon -> CanonGrammar
+canon2grammar (MGr _ _ modules) = canon2grammar (Gr modules) ---- ignoring the header
+canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules
+
+mod2info m = case m of
+    Mod mt e os flags defs -> 
+      let defs' = buildTree $ map def2info defs
+          (a,mt') = case mt of
+            MTAbs a -> (a,M.MTAbstract)
+            MTRes a -> (a,M.MTResource)
+            MTCnc a x -> (a,M.MTConcrete x)
+            MTTrans a x y -> (a,M.MTTransfer (M.oSimple x) (M.oSimple y))
+      in (a,M.ModMod (M.Module mt' M.MSComplete flags (ee e) (oo os) defs'))
+ where
+  ee (Ext m) = map M.inheritAll m
+  ee _ = []
+  oo (Opens ms) = map M.oSimple ms
+  oo _ = []
+
+grammar2canon :: CanonGrammar -> Canon
+grammar2canon (M.MGrammar modules) = Gr $ map info2mod modules 
+
+info2mod :: (Ident, M.ModInfo Ident Flag Info) -> Module
+info2mod m = case m of
+    (a, M.ModMod (M.Module mt _ flags me os defs)) -> 
+      let defs' = map info2def $ tree2list defs 
+          mt'   = case mt of
+             M.MTAbstract -> MTAbs a
+             M.MTResource -> MTRes a
+             M.MTConcrete x -> MTCnc a x
+             M.MTTransfer (M.OSimple _ x) (M.OSimple _ y) -> MTTrans a x y
+      in
+        Mod mt' (gfcE me) (gfcO os) flags defs'
+ where
+  gfcE = ifNull NoExt Ext . map fst
+  gfcO os = if null os then NoOpens else Opens [m | M.OSimple _ m <- os]
+
+
+-- these translations are meant to be trivial
+
+defs2infos = sorted2tree . map def2info
+
+def2info d = case d of
+  AbsDCat c cont fs -> (c,AbsCat (trCont cont) (trFs fs))
+  AbsDFun c ty df   -> (c,AbsFun (trExp ty) (trExp df))
+  AbsDTrans c t     -> (c,AbsTrans (trExp t))
+  ResDPar c    df   -> (c,ResPar df)
+  ResDOper c ty df  -> (c,ResOper ty df)
+  CncDCat c ty df pr   -> (c, CncCat ty df pr)
+  CncDFun f c xs li pr -> (f, CncFun c xs li pr)
+  AnyDInd c b m        -> (c, AnyInd (b == Canon) m)
+
+-- from file to internal
+
+trCont cont = [(x,trExp t) | Decl x t <- cont]
+
+trFs = map trQIdent
+
+trExp :: Exp -> A.Term
+trExp t = case t of
+  EProd x a b -> A.Prod x (trExp a) (trExp b)
+  EAbs  x   b -> A.Abs  x (trExp b)
+  EApp  f a   -> A.App  (trExp f)  (trExp a)
+  EEq eqs     -> A.Eqs [(map trPt ps, trExp e) | Equ ps e <- eqs]
+  EData       -> A.EData
+  _    -> trAt t
+ where
+  trAt (EAtom t) = case t of
+    AC c   -> (uncurry A.Q)  $ trQIdent c
+    AD c   -> (uncurry A.QC) $ trQIdent c
+    AV v   -> A.Vr v
+    AM i   -> A.Meta $ A.MetaSymb $ fromInteger i
+    AT s   -> A.Sort $ prt s
+    AS s   -> A.K s
+    AI i   -> A.EInt $ i
+    AF i   -> A.EFloat $ i
+  trPt p = case p of
+    APC mc ps -> let (m,c) = trQIdent mc in A.PP m c (map trPt ps)
+    APV x -> A.PV x
+    APS s -> A.PString s
+    API i -> A.PInt $ i
+    APF i -> A.PFloat $ i
+    APW   -> A.PW
+
+trQIdent (CIQ m c) = (m,c)
+
+-- from internal to file
+
+infos2defs = map info2def . tree2list
+
+info2def d = case d of
+  (c,AbsCat cont fs)    -> AbsDCat c (rtCont cont) (rtFs fs)
+  (c,AbsFun ty df)      -> AbsDFun c (rtExp ty) (rtExp df)
+  (c,AbsTrans t)        -> AbsDTrans c (rtExp t)
+  (c,ResPar    df)      -> ResDPar c df
+  (c,ResOper ty df)     -> ResDOper c ty df
+  (c,CncCat ty df pr)   -> CncDCat c ty df pr
+  (f,CncFun c xs li pr) -> CncDFun f c xs li pr
+  (c,AnyInd b m)        -> AnyDInd c (if b then Canon else NonCan) m
+
+rtCont cont = [Decl (rtIdent x) (rtExp t) | (x,t) <- cont]
+
+rtFs = map rtQIdent
+
+rtExp :: A.Term -> Exp
+rtExp t = case t of
+  A.Prod x a b -> EProd (rtIdent x) (rtExp a) (rtExp b)
+  A.Abs  x   b -> EAbs  (rtIdent x) (rtExp b)
+  A.App  f a   -> EApp  (rtExp f) (rtExp a)
+  A.Eqs eqs    -> EEq   [Equ (map rtPt ps) (rtExp e) | (ps,e) <- eqs]
+  A.EData      -> EData
+  _ -> EAtom $ rtAt t
+ where
+  rtAt t = case t of
+    A.Q m c        -> AC $ rtQIdent (m,c)
+    A.QC m c       -> AD $ rtQIdent (m,c)
+    A.Vr v         -> AV v
+    A.Meta i       -> AM $ toInteger $ A.metaSymbInt i
+    A.Sort "Type"  -> AT SType
+    A.K s          -> AS s
+    A.EInt i       -> AI $ toInteger i
+    _ -> error $ "MkGFC.rt not defined for" +++ show t
+  rtPt p = case p of
+    A.PP m c ps -> APC (rtQIdent (m,c)) (map rtPt ps)
+    A.PV x      -> APV x
+    A.PString s -> APS s
+    A.PInt i    -> API $ toInteger i
+    A.PW        -> APW
+    _ -> error $ "MkGFC.rt not defined for" +++ show p
+
+
+rtQIdent :: (Ident, Ident) -> CIdent
+rtQIdent (m,c) = CIQ (rtIdent m) (rtIdent c)
+rtIdent x 
+  | isWildIdent x = identC "h_" --- needed in declarations
+  | otherwise = identC $ prt x ---
+
+{-
+-- the following is called in GetGFC to read gfc files line
+-- by line. It does not save memory, though, and is therefore
+-- not used.
+
+buildCanonGrammar :: Int -> CanonGrammar -> Line -> (CanonGrammar,Int)
+buildCanonGrammar n gr0 line = mgr $ case line of
+-- LMulti ids id
+  LHeader mt ext op -> newModule mt ext op
+  LFlag f@(Flg (IC "modulesize") (IC n)) -> initModule f $ read $ tail n
+  LFlag flag        -> newFlag flag
+  LDef def          -> newDef $ def2info def
+--  LEnd              -> cleanNames
+  _                 -> M.modules gr0
+ where
+   newModule mt ext op = mod2info (Mod mt ext op [] []) : mods
+   initModule f i = case actm of
+     (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
+       (name, M.ModMod (M.Module mt com (f:flags) ee oo (newtree i))) : tmods
+   newFlag f = case actm of
+     (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
+       (name, M.ModMod (M.Module mt com (f:flags) ee oo defs)) : tmods
+   newDef d = case actm of
+     (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
+       (name, M.ModMod (M.Module mt com flags ee oo 
+          (upd (padd 8 n) d defs))) : tmods
+
+--   cleanNames = case actm of
+--     (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
+--       (name, M.ModMod (M.Module mt com (reverse flags) ee oo 
+--          (mapTree (\ (IC f,t) -> (IC (drop 8 f),t)) defs))) : tmods
+
+   actm = head mods -- only used when a new mod has been created
+   mods = M.modules gr0
+   tmods = tail mods
+
+   mgr ms = (M.MGrammar ms, case line of
+     LDef _ -> n+1
+     LEnd   -> 1
+     _ -> n
+     )
+
+   -- create an initial tree with who-cares value
+   newtree (i :: Int) = emptyBinTree
+--   newtree (i :: Int) = sorted2tree [
+--     (padd 8 k, ResPar []) | 
+--     k <- [1..i]] --- padd (length (show i))
+
+   padd l k = 0
+--   padd l k = let sk = show k in identC (replicate (l - length sk) '0' ++ sk)
+
+   upd _ d defs = updateTree d defs
+--   upd n d@(f,t) defs = case defs of
+--     NT -> BT (merg n f,t) NT NT --- should not happen
+--     BT c@(a,_) left right 
+--       | n < a  -> let left'  = upd n d left  in BT c left' right 
+--       | n > a  -> let right' = upd n d right in BT c left right' 
+--       | otherwise -> BT (merg n f,t) left right
+--   merg (IC n) (IC f) = IC (n ++ f)
+-}

src-2.9/GF/Canon/ParGFC.y

@@ -0,0 +1,385 @@
+-- This Happy file was machine-generated by the BNF converter
+{
+module GF.Canon.ParGFC where
+import GF.Canon.AbsGFC
+import GF.Canon.LexGFC
+import GF.Data.ErrM -- H
+import GF.Infra.Ident -- H
+}
+
+%name pCanon Canon
+%name pLine Line
+
+-- no lexer declaration
+%monad { Err } { thenM } { returnM }
+%tokentype { Token }
+
+%token 
+ ';' { PT _ (TS ";") }
+ '=' { PT _ (TS "=") }
+ '{' { PT _ (TS "{") }
+ '}' { PT _ (TS "}") }
+ ':' { PT _ (TS ":") }
+ '->' { PT _ (TS "->") }
+ '**' { PT _ (TS "**") }
+ '[' { PT _ (TS "[") }
+ ']' { PT _ (TS "]") }
+ '\\' { PT _ (TS "\\") }
+ '.' { PT _ (TS ".") }
+ '(' { PT _ (TS "(") }
+ ')' { PT _ (TS ")") }
+ '_' { PT _ (TS "_") }
+ '<' { PT _ (TS "<") }
+ '>' { PT _ (TS ">") }
+ '$' { PT _ (TS "$") }
+ '?' { PT _ (TS "?") }
+ '=>' { PT _ (TS "=>") }
+ '!' { PT _ (TS "!") }
+ '++' { PT _ (TS "++") }
+ '/' { PT _ (TS "/") }
+ '@' { PT _ (TS "@") }
+ '+' { PT _ (TS "+") }
+ '|' { PT _ (TS "|") }
+ ',' { PT _ (TS ",") }
+ 'Ints' { PT _ (TS "Ints") }
+ 'Str' { PT _ (TS "Str") }
+ 'Type' { PT _ (TS "Type") }
+ 'abstract' { PT _ (TS "abstract") }
+ 'cat' { PT _ (TS "cat") }
+ 'concrete' { PT _ (TS "concrete") }
+ 'data' { PT _ (TS "data") }
+ 'flags' { PT _ (TS "flags") }
+ 'fun' { PT _ (TS "fun") }
+ 'grammar' { PT _ (TS "grammar") }
+ 'in' { PT _ (TS "in") }
+ 'lin' { PT _ (TS "lin") }
+ 'lincat' { PT _ (TS "lincat") }
+ 'of' { PT _ (TS "of") }
+ 'open' { PT _ (TS "open") }
+ 'oper' { PT _ (TS "oper") }
+ 'param' { PT _ (TS "param") }
+ 'pre' { PT _ (TS "pre") }
+ 'resource' { PT _ (TS "resource") }
+ 'table' { PT _ (TS "table") }
+ 'transfer' { PT _ (TS "transfer") }
+ 'variants' { PT _ (TS "variants") }
+
+L_ident  { PT _ (TV $$) }
+L_quoted { PT _ (TL $$) }
+L_integ  { PT _ (TI $$) }
+L_err    { _ }
+
+
+%%
+
+Ident   :: { Ident }   : L_ident  { identC $1 } -- H
+String  :: { String }  : L_quoted { $1 }
+Integer :: { Integer } : L_integ  { (read $1) :: Integer }
+
+Canon :: { Canon }
+Canon : 'grammar' ListIdent 'of' Ident ';' ListModule { MGr $2 $4 (reverse $6) } 
+  | ListModule { Gr (reverse $1) }
+
+
+Line :: { Line }
+Line : 'grammar' ListIdent 'of' Ident ';' { LMulti $2 $4 } 
+  | ModType '=' Extend Open '{' { LHeader $1 $3 $4 }
+  | Flag ';' { LFlag $1 }
+  | Def ';' { LDef $1 }
+  | '}' { LEnd }
+
+
+Module :: { Module }
+Module : ModType '=' Extend Open '{' ListFlag ListDef '}' { Mod $1 $3 $4 (reverse $6) (reverse $7) } 
+
+
+ModType :: { ModType }
+ModType : 'abstract' Ident { MTAbs $2 } 
+  | 'concrete' Ident 'of' Ident { MTCnc $2 $4 }
+  | 'resource' Ident { MTRes $2 }
+  | 'transfer' Ident ':' Ident '->' Ident { MTTrans $2 $4 $6 }
+
+
+ListModule :: { [Module] }
+ListModule : {- empty -} { [] } 
+  | ListModule Module { flip (:) $1 $2 }
+
+
+Extend :: { Extend }
+Extend : ListIdent '**' { Ext $1 } 
+  | {- empty -} { NoExt }
+
+
+Open :: { Open }
+Open : 'open' ListIdent 'in' { Opens $2 } 
+  | {- empty -} { NoOpens }
+
+
+Flag :: { Flag }
+Flag : 'flags' Ident '=' Ident { Flg $2 $4 } 
+
+
+Def :: { Def }
+Def : 'cat' Ident '[' ListDecl ']' '=' ListCIdent { AbsDCat $2 $4 (reverse $7) } 
+  | 'fun' Ident ':' Exp '=' Exp { AbsDFun $2 $4 $6 }
+  | 'transfer' Ident '=' Exp { AbsDTrans $2 $4 }
+  | 'param' Ident '=' ListParDef { ResDPar $2 $4 }
+  | 'oper' Ident ':' CType '=' Term { ResDOper $2 $4 $6 }
+  | 'lincat' Ident '=' CType '=' Term ';' Term { CncDCat $2 $4 $6 $8 }
+  | 'lin' Ident ':' CIdent '=' '\\' ListArgVar '->' Term ';' Term { CncDFun $2 $4 $7 $9 $11 }
+  | Ident Status 'in' Ident { AnyDInd $1 $2 $4 }
+
+
+ParDef :: { ParDef }
+ParDef : Ident ListCType { ParD $1 (reverse $2) } 
+
+
+Status :: { Status }
+Status : 'data' { Canon } 
+  | {- empty -} { NonCan }
+
+
+CIdent :: { CIdent }
+CIdent : Ident '.' Ident { CIQ $1 $3 } 
+
+
+Exp1 :: { Exp }
+Exp1 : Exp1 Exp2 { EApp $1 $2 } 
+  | Exp2 { $1 }
+
+
+Exp :: { Exp }
+Exp : '(' Ident ':' Exp ')' '->' Exp { EProd $2 $4 $7 } 
+  | '\\' Ident '->' Exp { EAbs $2 $4 }
+  | '{' ListEquation '}' { EEq (reverse $2) }
+  | Exp1 { $1 }
+
+
+Exp2 :: { Exp }
+Exp2 : Atom { EAtom $1 } 
+  | 'data' { EData }
+  | '(' Exp ')' { $2 }
+
+
+Sort :: { Sort }
+Sort : 'Type' { SType } 
+
+
+Equation :: { Equation }
+Equation : ListAPatt '->' Exp { Equ (reverse $1) $3 } 
+
+
+APatt :: { APatt }
+APatt : '(' CIdent ListAPatt ')' { APC $2 (reverse $3) } 
+  | Ident { APV $1 }
+  | String { APS $1 }
+  | Integer { API $1 }
+  | '_' { APW }
+
+
+ListDecl :: { [Decl] }
+ListDecl : {- empty -} { [] } 
+  | Decl { (:[]) $1 }
+  | Decl ';' ListDecl { (:) $1 $3 }
+
+
+ListAPatt :: { [APatt] }
+ListAPatt : {- empty -} { [] } 
+  | ListAPatt APatt { flip (:) $1 $2 }
+
+
+ListEquation :: { [Equation] }
+ListEquation : {- empty -} { [] } 
+  | ListEquation Equation ';' { flip (:) $1 $2 }
+
+
+Atom :: { Atom }
+Atom : CIdent { AC $1 } 
+  | '<' CIdent '>' { AD $2 }
+  | '$' Ident { AV $2 }
+  | '?' Integer { AM $2 }
+  | String { AS $1 }
+  | Integer { AI $1 }
+  | Sort { AT $1 }
+
+
+Decl :: { Decl }
+Decl : Ident ':' Exp { Decl $1 $3 } 
+
+
+CType :: { CType }
+CType : '{' ListLabelling '}' { RecType $2 } 
+  | '(' CType '=>' CType ')' { Table $2 $4 }
+  | CIdent { Cn $1 }
+  | 'Str' { TStr }
+  | 'Ints' Integer { TInts $2 }
+
+
+Labelling :: { Labelling }
+Labelling : Label ':' CType { Lbg $1 $3 } 
+
+
+Term2 :: { Term }
+Term2 : ArgVar { Arg $1 } 
+  | CIdent { I $1 }
+  | '<' CIdent ListTerm2 '>' { Par $2 (reverse $3) }
+  | '$' Ident { LI $2 }
+  | '{' ListAssign '}' { R $2 }
+  | Integer { EInt $1 }
+  | Tokn { K $1 }
+  | '[' ']' { E }
+  | '(' Term ')' { $2 }
+
+
+Term1 :: { Term }
+Term1 : Term2 '.' Label { P $1 $3 } 
+  | 'table' CType '{' ListCase '}' { T $2 $4 }
+  | 'table' CType '[' ListTerm2 ']' { V $2 (reverse $4) }
+  | Term1 '!' Term2 { S $1 $3 }
+  | 'variants' '{' ListTerm2 '}' { FV (reverse $3) }
+  | Term2 { $1 }
+
+
+Term :: { Term }
+Term : Term '++' Term1 { C $1 $3 } 
+  | Term1 { $1 }
+
+
+Tokn :: { Tokn }
+Tokn : String { KS $1 } 
+  | '[' 'pre' ListString '{' ListVariant '}' ']' { KP (reverse $3) $5 }
+
+
+Assign :: { Assign }
+Assign : Label '=' Term { Ass $1 $3 } 
+
+
+Case :: { Case }
+Case : ListPatt '=>' Term { Cas (reverse $1) $3 } 
+
+
+Variant :: { Variant }
+Variant : ListString '/' ListString { Var (reverse $1) (reverse $3) } 
+
+
+Label :: { Label }
+Label : Ident { L $1 } 
+  | '$' Integer { LV $2 }
+
+
+ArgVar :: { ArgVar }
+ArgVar : Ident '@' Integer { A $1 $3 } 
+  | Ident '+' Integer '@' Integer { AB $1 $3 $5 }
+
+
+Patt :: { Patt }
+Patt : '(' CIdent ListPatt ')' { PC $2 (reverse $3) } 
+  | Ident { PV $1 }
+  | '_' { PW }
+  | '{' ListPattAssign '}' { PR $2 }
+  | Integer { PI $1 }
+
+
+PattAssign :: { PattAssign }
+PattAssign : Label '=' Patt { PAss $1 $3 } 
+
+
+ListFlag :: { [Flag] }
+ListFlag : {- empty -} { [] } 
+  | ListFlag Flag ';' { flip (:) $1 $2 }
+
+
+ListDef :: { [Def] }
+ListDef : {- empty -} { [] } 
+  | ListDef Def ';' { flip (:) $1 $2 }
+
+
+ListParDef :: { [ParDef] }
+ListParDef : {- empty -} { [] } 
+  | ParDef { (:[]) $1 }
+  | ParDef '|' ListParDef { (:) $1 $3 }
+
+
+ListCType :: { [CType] }
+ListCType : {- empty -} { [] } 
+  | ListCType CType { flip (:) $1 $2 }
+
+
+ListCIdent :: { [CIdent] }
+ListCIdent : {- empty -} { [] } 
+  | ListCIdent CIdent { flip (:) $1 $2 }
+
+
+ListAssign :: { [Assign] }
+ListAssign : {- empty -} { [] } 
+  | Assign { (:[]) $1 }
+  | Assign ';' ListAssign { (:) $1 $3 }
+
+
+ListArgVar :: { [ArgVar] }
+ListArgVar : {- empty -} { [] } 
+  | ArgVar { (:[]) $1 }
+  | ArgVar ',' ListArgVar { (:) $1 $3 }
+
+
+ListLabelling :: { [Labelling] }
+ListLabelling : {- empty -} { [] } 
+  | Labelling { (:[]) $1 }
+  | Labelling ';' ListLabelling { (:) $1 $3 }
+
+
+ListCase :: { [Case] }
+ListCase : {- empty -} { [] } 
+  | Case { (:[]) $1 }
+  | Case ';' ListCase { (:) $1 $3 }
+
+
+ListTerm2 :: { [Term] }
+ListTerm2 : {- empty -} { [] } 
+  | ListTerm2 Term2 { flip (:) $1 $2 }
+
+
+ListString :: { [String] }
+ListString : {- empty -} { [] } 
+  | ListString String { flip (:) $1 $2 }
+
+
+ListVariant :: { [Variant] }
+ListVariant : {- empty -} { [] } 
+  | Variant { (:[]) $1 }
+  | Variant ';' ListVariant { (:) $1 $3 }
+
+
+ListPattAssign :: { [PattAssign] }
+ListPattAssign : {- empty -} { [] } 
+  | PattAssign { (:[]) $1 }
+  | PattAssign ';' ListPattAssign { (:) $1 $3 }
+
+
+ListPatt :: { [Patt] }
+ListPatt : {- empty -} { [] } 
+  | ListPatt Patt { flip (:) $1 $2 }
+
+
+ListIdent :: { [Ident] }
+ListIdent : {- empty -} { [] } 
+  | Ident { (:[]) $1 }
+  | Ident ',' ListIdent { (:) $1 $3 }
+
+
+
+{
+
+returnM :: a -> Err a
+returnM = return
+
+thenM :: Err a -> (a -> Err b) -> Err b
+thenM = (>>=)
+
+happyError :: [Token] -> Err a
+happyError ts =
+  Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts)))
+
+myLexer = tokens
+}
+

src-2.9/GF/Canon/PrExp.hs

@@ -0,0 +1,46 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PrExp
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:28 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.5 $
+--
+-- print trees without qualifications
+-----------------------------------------------------------------------------
+
+module GF.Canon.PrExp (prExp) where
+
+import GF.Canon.AbsGFC
+import GF.Canon.GFC
+
+import GF.Data.Operations
+
+prExp :: Exp -> String
+prExp e = case e of
+  EApp f a   -> pr1 f +++ pr2 a
+  EAbsR x b  -> "\\" ++ prtt x +++ "->" +++ prExp b
+  EAbs x _ b -> prExp $ EAbsR x b
+  EProd x a b -> "(\\" ++ prtt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b
+  EAtomR a   -> prAtom a
+  EAtom a _  -> prAtom a
+  _ -> prtt e
+ where
+   pr1 e = case e of
+     EAbsR _ _   -> prParenth $ prExp e
+     EAbs _ _ _  -> prParenth $ prExp e
+     EProd _ _ _ -> prParenth $ prExp e
+     _ -> prExp e
+   pr2 e = case e of
+     EApp _ _ -> prParenth $ prExp e
+     _ -> pr1 e
+
+prAtom a = case a of
+  AC c -> prCIdent c
+  AD c -> prCIdent c
+  _ -> prtt a
+
+prCIdent (CIQ _ c) = prtt c

src-2.9/GF/Canon/PrintGFC.hs

@@ -0,0 +1,376 @@
+module GF.Canon.PrintGFC where
+
+
+-- pretty-printer generated by the BNF converter, except handhacked spacing --H
+
+import GF.Infra.Ident --H
+import GF.Canon.AbsGFC
+import Data.Char
+
+-- the top-level printing method
+printTree :: Print a => a -> String
+printTree = render . prt 0
+
+type Doc = [ShowS] -> [ShowS]
+
+doc :: ShowS -> Doc
+doc = (:)
+
+docs :: ShowS -> Doc
+docs x y = concatD [spc, doc x, spc ] y
+
+spc = doc (showString "&")
+
+render :: Doc -> String
+render d = rend 0 (map ($ "") $ d []) "" where
+  rend i ss = case ss of
+    "*"    :ts -> realnew . rend i ts --H
+    "&":"&":ts -> showChar ' ' . rend i ts --H
+    "&"    :ts -> rend i ts --H
+    t      :ts -> showString t . rend i ts
+    _          -> id
+  realnew = showChar '\n' --H
+
+{-
+render :: Doc -> String
+render d = rend 0 (map ($ "") $ d []) "" where
+  rend i ss = case ss of
+    "*NEW"   :ts -> realnew . rend i ts --H
+    "<"      :ts -> showString "<" . rend i ts --H
+    "$"      :ts -> showString "$" . rend i ts --H
+    "?"      :ts -> showString "?" . rend i ts --H
+    "["      :ts -> showChar '[' . rend i ts
+    "("      :ts -> showChar '(' . rend i ts
+    "{"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts
+    "}" : ";":ts -> new (i-1) . showChar '}' . showChar ';' . new (i-1) . rend (i-1) ts
+    "}"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
+    ";"      :ts -> showChar ';' . new i . rend i ts
+    t  : "@" :ts -> showString t . showChar '@' . rend i ts
+    t  : "," :ts -> showString t . showChar ',' . rend i ts
+    t  : ")" :ts -> showString t . showChar ')' . rend i ts
+    t  : "]" :ts -> showString t . showChar ']' . rend i ts
+    t  : ">" :ts -> showString t . showChar '>' . rend i ts --H
+    t  : "." :ts -> showString t . showChar '.' . rend i ts --H
+    t@"=>"   :ts -> showString t . rend i ts --H
+    t@"->"   :ts -> showString t . rend i ts --H
+    t        :ts -> realspace t . rend i ts --H
+    _            -> id
+  space t = showString t . showChar ' ' -- H
+  realspace t = showString t . (\s -> if null s then "" else (' ':s)) -- H
+  new i s   = s  -- H
+  realnew = showChar '\n' --H
+-}
+
+parenth :: Doc -> Doc
+parenth ss = doc (showChar '(') . ss . doc (showChar ')')
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+concatD :: [Doc] -> Doc
+concatD = foldr (.) id
+
+replicateS :: Int -> ShowS -> ShowS
+replicateS n f = concatS (replicate n f)
+
+-- the printer class does the job
+class Print a where
+  prt :: Int -> a -> Doc
+  prtList :: [a] -> Doc
+  prtList = concatD . map (prt 0)
+
+instance Print a => Print [a] where
+  prt _ = prtList
+
+instance Print Char where
+  prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
+  prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
+
+mkEsc :: Char -> Char -> ShowS
+mkEsc q s = case s of
+  _ | s == q -> showChar '\\' . showChar s
+  '\\'-> showString "\\\\"
+  '\n' -> showString "\\n"
+  '\t' -> showString "\\t"
+  _ -> showChar s
+
+prPrec :: Int -> Int -> Doc -> Doc
+prPrec i j = if j<i then parenth else id
+
+
+instance Print Integer where
+  prt _ x = docs (shows x)
+
+
+instance Print Double where
+  prt _ x = docs (shows x)
+
+instance Print Ident where
+  prt _ i = docs (showString $ prIdent i) -- H
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Canon where
+  prt i e = case e of
+   MGr ids id modules -> prPrec i 0 (concatD [spc, doc (showString "grammar") , spc, prt 0 ids , spc , doc (showString "of") , spc, prt 0 id , doc (showString ";") , prt 0 modules])
+   Gr modules -> prPrec i 0 (concatD [prt 0 modules])
+
+
+instance Print Line where
+  prt i e = case e of
+   LMulti ids id -> prPrec i 0 (concatD [spc, doc (showString "grammar") , spc, prt 0 ids , spc, doc (showString "of") , spc, prt 0 id , doc (showString ";")])
+   LHeader modtype extend open -> prPrec i 0 (concatD [prt 0 modtype , doc (showString "=") , prt 0 extend , prt 0 open , doc (showString "{")])
+   LFlag flag -> prPrec i 0 (concatD [prt 0 flag , doc (showString ";")])
+   LDef def -> prPrec i 0 (concatD [prt 0 def , doc (showString ";")])
+   LEnd  -> prPrec i 0 (concatD [doc (showString "}")])
+
+
+instance Print Module where
+  prt i e = case e of
+   Mod modtype extend open flags defs -> prPrec i 0 (concatD [prt 0 modtype , doc (showString "=") , prt 0 extend , prt 0 open , doc (showString "{") , prt 0 flags , prt 0 defs , doc (showString "}")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print ModType where
+  prt i e = case e of
+   MTAbs id -> prPrec i 0 (concatD [spc, doc (showString "abstract") , spc , prt 0 id])
+   MTCnc id0 id -> prPrec i 0 (concatD [spc, doc (showString "concrete") , spc, prt 0 id0 , spc, doc (showString "of") , spc, prt 0 id])
+   MTRes id -> prPrec i 0 (concatD [spc, doc (showString "resource") , spc, prt 0 id])
+   MTTrans id0 id1 id -> prPrec i 0 (concatD [spc, doc (showString "transfer") , spc, prt 0 id0 , doc (showString ":") , prt 0 id1 , doc (showString "->") , prt 0 id])
+
+
+instance Print Extend where
+  prt i e = case e of
+   Ext ids -> prPrec i 0 (concatD [prt 0 ids , doc (showString "**")])
+   NoExt  -> prPrec i 0 (concatD [])
+
+
+instance Print Open where
+  prt i e = case e of
+   Opens ids -> prPrec i 0 (concatD [spc, doc (showString "open") , spc, prt 0 ids , docs (showString "in")])
+   NoOpens  -> prPrec i 0 (concatD [])
+
+
+instance Print Flag where
+  prt i e = case e of
+   Flg id0 id -> prPrec i 0 (concatD [spc, doc (showString "flags") , spc, prt 0 id0 , doc (showString "=") , prt 0 id])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Def where
+  prt i e = case e of
+   AbsDCat id decls cidents -> prPrec i 0 (concatD [docs (showString "cat") , prt 0 id , doc (showString "[") , prt 0 decls , doc (showString "]") , doc (showString "=") , prt 0 cidents])
+   AbsDFun id exp0 exp -> prPrec i 0 (concatD [docs (showString "fun") , prt 0 id , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp])
+   AbsDTrans id exp -> prPrec i 0 (concatD [docs (showString "transfer") , prt 0 id , doc (showString "=") , prt 0 exp])
+   ResDPar id pardefs -> prPrec i 0 (concatD [docs (showString "param") , prt 0 id , doc (showString "=") , prt 0 pardefs])
+   ResDOper id ctype term -> prPrec i 0 (concatD [docs (showString "oper") , prt 0 id , doc (showString ":") , prt 0 ctype , doc (showString "=") , prt 0 term])
+   CncDCat id ctype term0 term -> prPrec i 0 (concatD [docs (showString "lincat") , prt 0 id , doc (showString "=") , prt 0 ctype , doc (showString "=") , prt 0 term0 , doc (showString ";") , prt 0 term])
+   CncDFun id cident argvars term0 term -> prPrec i 0 (concatD [docs (showString "lin") , prt 0 id , doc (showString ":") , prt 0 cident , doc (showString "=") , doc (showString "\\") , prt 0 argvars , doc (showString "->") , prt 0 term0 , doc (showString ";") , prt 0 term])
+   AnyDInd id0 status id -> prPrec i 0 (concatD [prt 0 id0 , prt 0 status , docs (showString "in") , prt 0 id])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";"), doc (showString "*") , prt 0 xs]) -- H
+
+
+instance Print ParDef where
+  prt i e = case e of
+   ParD id ctypes -> prPrec i 0 (concatD [prt 0 id , prt 0 ctypes])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
+
+instance Print Status where
+  prt i e = case e of
+   Canon  -> prPrec i 0 (concatD [docs (showString "data")])
+   NonCan  -> prPrec i 0 (concatD [])
+
+
+instance Print CIdent where
+  prt i e = case e of
+   CIQ id0 id -> prPrec i 0 (concatD [prt 0 id0 , doc (showString ".") , prt 0 id])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print Exp where
+  prt i e = case e of
+   EApp exp0 exp -> prPrec i 1 (concatD [prt 1 exp0 , prt 2 exp])
+   EProd id exp0 exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 id , doc (showString ":") , prt 0 exp0 , doc (showString ")") , doc (showString "->") , prt 0 exp])
+   EAbs id exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 id , doc (showString "->") , prt 0 exp])
+   EAtom atom -> prPrec i 2 (concatD [prt 0 atom])
+   EData  -> prPrec i 2 (concatD [docs (showString "data")])
+   EEq equations -> prPrec i 0 (concatD [doc (showString "{") , prt 0 equations , doc (showString "}")])
+
+
+instance Print Sort where
+  prt i e = case e of
+   SType  -> prPrec i 0 (concatD [docs (showString "Type")])
+
+
+instance Print Equation where
+  prt i e = case e of
+   Equ apatts exp -> prPrec i 0 (concatD [prt 0 apatts , doc (showString "->") , prt 0 exp])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print APatt where
+  prt i e = case e of
+   APC cident apatts -> prPrec i 0 (concatD [doc (showString "(") , prt 0 cident , prt 0 apatts , doc (showString ")")])
+   APV id -> prPrec i 0 (concatD [prt 0 id])
+   APS str -> prPrec i 0 (concatD [prt 0 str])
+   API n -> prPrec i 0 (concatD [prt 0 n])
+   APF n -> prPrec i 0 (concatD [prt 0 n])
+   APW  -> prPrec i 0 (concatD [doc (showString "_")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print Atom where
+  prt i e = case e of
+   AC cident -> prPrec i 0 (concatD [prt 0 cident])
+   AD cident -> prPrec i 0 (concatD [doc (showString "<") , prt 0 cident , doc (showString ">")])
+   AV id -> prPrec i 0 (concatD [doc (showString "$") , prt 0 id])
+   AM n -> prPrec i 0 (concatD [doc (showString "?") , prt 0 n])
+   AS str -> prPrec i 0 (concatD [prt 0 str])
+   AI n -> prPrec i 0 (concatD [prt 0 n])
+   AT sort -> prPrec i 0 (concatD [prt 0 sort])
+
+
+instance Print Decl where
+  prt i e = case e of
+   Decl id exp -> prPrec i 0 (concatD [prt 0 id , doc (showString ":") , prt 0 exp])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print CType where
+  prt i e = case e of
+   RecType labellings -> prPrec i 0 (concatD [doc (showString "{") , prt 0 labellings , doc (showString "}")])
+   Table ctype0 ctype -> prPrec i 0 (concatD [doc (showString "(") , prt 0 ctype0 , doc (showString "=>") , prt 0 ctype , doc (showString ")")])
+   Cn cident -> prPrec i 0 (concatD [prt 0 cident])
+   TStr  -> prPrec i 0 (concatD [docs (showString "Str")])
+   TInts n -> prPrec i 0 (concatD [docs (showString "Ints") , prt 0 n])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print Labelling where
+  prt i e = case e of
+   Lbg label ctype -> prPrec i 0 (concatD [prt 0 label , doc (showString ":") , prt 0 ctype])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Term where
+  prt i e = case e of
+   Arg argvar -> prPrec i 2 (concatD [prt 0 argvar])
+   I cident -> prPrec i 2 (concatD [prt 0 cident])
+   Par cident terms -> prPrec i 2 (concatD [doc (showString "<") , prt 0 cident , prt 2 terms , doc (showString ">")])
+   LI id -> prPrec i 2 (concatD [doc (showString "$") , prt 0 id])
+   R assigns -> prPrec i 2 (concatD [doc (showString "{") , prt 0 assigns , doc (showString "}")])
+   P term label -> prPrec i 1 (concatD [prt 2 term , doc (showString ".") , prt 0 label])
+   T ctype cases -> prPrec i 1 (concatD [docs (showString "table") , prt 0 ctype , doc (showString "{") , prt 0 cases , doc (showString "}")])
+   V ctype terms -> prPrec i 1 (concatD [docs (showString "table") , prt 0 ctype , doc (showString "[") , prt 2 terms , doc (showString "]")])
+   S term0 term -> prPrec i 1 (concatD [prt 1 term0 , doc (showString "!") , prt 2 term])
+   C term0 term -> prPrec i 0 (concatD [prt 0 term0 , doc (showString "++") , prt 1 term])
+   FV terms -> prPrec i 1 (concatD [docs (showString "variants") , doc (showString "{") , prt 2 terms , doc (showString "}")])
+   EInt n -> prPrec i 2 (concatD [prt 0 n])
+   EFloat n -> prPrec i 2 (concatD [prt 0 n])
+   K tokn -> prPrec i 2 (concatD [prt 0 tokn])
+   E  -> prPrec i 2 (concatD [doc (showString "[") , doc (showString "]")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 2 x , prt 2 xs])
+
+instance Print Tokn where
+  prt i e = case e of
+   KS str -> prPrec i 0 (concatD [prt 0 str])
+   KP strs variants -> prPrec i 0 (concatD [doc (showString "[") , docs (showString "pre") , prt 0 strs , doc (showString "{") , prt 0 variants , doc (showString "}") , doc (showString "]")])
+   KM str -> prPrec i 0 (concatD [prt 0 str])
+
+
+instance Print Assign where
+  prt i e = case e of
+   Ass label term -> prPrec i 0 (concatD [prt 0 label , doc (showString "=") , prt 0 term])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Case where
+  prt i e = case e of
+   Cas patts term -> prPrec i 0 (concatD [prt 0 patts , doc (showString "=>") , prt 0 term])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Variant where
+  prt i e = case e of
+   Var strs0 strs -> prPrec i 0 (concatD [prt 0 strs0 , doc (showString "/") , prt 0 strs])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Label where
+  prt i e = case e of
+   L id -> prPrec i 0 (concatD [prt 0 id])
+   LV n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
+
+
+instance Print ArgVar where
+  prt i e = case e of
+   A id n -> prPrec i 0 (concatD [prt 0 id , doc (showString "@") , prt 0 n])
+   AB id n0 n -> prPrec i 0 (concatD [prt 0 id , doc (showString "+") , prt 0 n0 , doc (showString "@") , prt 0 n])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Patt where
+  prt i e = case e of
+   PC cident patts -> prPrec i 0 (concatD [doc (showString "(") , prt 0 cident , prt 0 patts , doc (showString ")")])
+   PV id -> prPrec i 0 (concatD [prt 0 id])
+   PW  -> prPrec i 0 (concatD [docs (showString "_")])
+   PR pattassigns -> prPrec i 0 (concatD [doc (showString "{") , prt 0 pattassigns , doc (showString "}")])
+   PI n -> prPrec i 0 (concatD [prt 0 n])
+   PF n -> prPrec i 0 (concatD [prt 0 n])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print PattAssign where
+  prt i e = case e of
+   PAss label patt -> prPrec i 0 (concatD [prt 0 label , doc (showString "=") , prt 0 patt])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+

src-2.9/GF/Canon/Share.hs

@@ -0,0 +1,147 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Share
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/17 14:15:18 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.12 $
+--
+-- Optimizations on GFC code: sharing, parametrization, value sets.
+--
+-- optimization: sharing branches in tables. AR 25\/4\/2003.
+-- following advice of Josef Svenningsson
+-----------------------------------------------------------------------------
+
+module GF.Canon.Share (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
+
+import GF.Canon.AbsGFC
+import GF.Infra.Ident
+import GF.Canon.GFC
+import qualified GF.Canon.CMacros as C
+import GF.Grammar.PrGrammar (prt)
+import GF.Data.Operations
+import Data.List
+import qualified GF.Infra.Modules as M
+
+type OptSpec = [Integer] ---
+
+doOptFactor opt = elem 2 opt
+doOptValues opt = elem 3 opt
+
+shareOpt :: OptSpec
+shareOpt = []
+
+paramOpt :: OptSpec
+paramOpt = [2]
+
+valOpt :: OptSpec
+valOpt = [3]
+
+allOpt :: OptSpec
+allOpt = [2,3]
+
+shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo)
+shareModule opt (i,m) = case m of
+  M.ModMod (M.Module mt st fs me ops js) -> 
+    (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
+  _ -> (i,m)
+
+shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOptim opt c t) m)
+shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOptim opt c t) m)
+shareInfo _ i = i
+
+-- | the function putting together optimizations
+shareOptim :: OptSpec -> Ident -> Term -> Term
+shareOptim opt c 
+  | doOptFactor opt && doOptValues opt = values . factor c 0
+  | doOptFactor opt = share . factor c 0
+  | doOptValues opt = values    
+  | otherwise = share
+
+-- | we need no counter to create new variable names, since variables are 
+-- local to tables
+share :: Term -> Term
+share t = case t of
+  T ty cs  -> shareT ty [(p, share v) | Cas ps v <- cs, p <- ps]  -- only substant.
+  R lts -> R [Ass l (share t) | Ass l t <- lts]
+  P t l -> P (share t) l
+  S t a -> S (share t) (share a)
+  C t a -> C (share t) (share a)
+  FV ts -> FV (map share ts)
+
+  _ -> t  -- including D, which is always born shared
+
+ where
+   shareT ty = finalize ty . groupC . sortC
+ 
+   sortC :: [(Patt,Term)] -> [(Patt,Term)]
+   sortC = sortBy $ \a b -> compare (snd a) (snd b)
+
+   groupC :: [(Patt,Term)] -> [[(Patt,Term)]]
+   groupC = groupBy $ \a b -> snd a == snd b
+
+   finalize :: CType -> [[(Patt,Term)]] -> Term
+   finalize ty css = T ty [Cas (map fst ps) t | ps@((_,t):_) <- css]
+
+
+-- | do even more: factor parametric branches
+factor :: Ident -> Int -> Term -> Term
+factor c i t = case t of
+  T _ [_] -> t
+  T _ []  -> t
+  T ty cs -> T ty $ factors i [Cas [p] (factor c (i+1) v) | Cas ps v <- cs, p <- ps]
+  R lts   -> R [Ass l (factor c i t) | Ass l t <- lts]
+  P t l   -> P (factor c i t) l
+  S t a   -> S (factor c i t) (factor c i a)
+  C t a   -> C (factor c i t) (factor c i a)
+  FV ts   -> FV (map (factor c i) ts)
+
+  _ -> t
+ where
+
+   factors i psvs =   -- we know psvs has at least 2 elements
+     let p   = pIdent c i
+         vs' = map (mkFun p) psvs
+     in if   allEqs vs'
+        then mkCase p vs' 
+        else psvs
+
+   mkFun p (Cas [patt] val) = replace (C.patt2term patt) (LI p) val
+
+   allEqs (v:vs) = all (==v) vs
+
+   mkCase p (v:_) = [Cas [PV p] v]
+
+pIdent c i = identC ("p_" ++ prt c ++ "__" ++ show i)
+
+
+-- | we need to replace subterms
+replace :: Term -> Term -> Term -> Term
+replace old new trm = case trm of
+  T ty cs -> T ty [Cas p (repl v) | Cas p v <- cs]
+  P t l   -> P (repl t) l
+  S t a   -> S (repl t) (repl a)
+  C t a   -> C (repl t) (repl a)
+  FV ts   -> FV (map repl ts)
+  
+  -- these are the important cases, since they can correspond to patterns  
+  Par c ts | trm == old -> new
+  Par c ts            -> Par c (map repl ts)
+  R _ | isRec && trm == old -> new
+  R lts   -> R [Ass l (repl t) | Ass l t <- lts]
+
+  _ -> trm
+ where
+   repl = replace old new
+   isRec = case trm of
+     R _ -> True
+     _ -> False
+
+values :: Term -> Term
+values t = case t of
+  T ty [c] -> T ty [Cas p (values t) | Cas p t <- [c]] -- preserve parametrization
+  T ty cs  -> V ty [values t | Cas _ t <- cs] -- assumes proper order
+  _ -> C.composSafeOp values t

src-2.9/GF/Canon/SkelGFC.hs

@@ -0,0 +1,217 @@
+module GF.Canon.SkelGFC where
+
+-- Haskell module generated by the BNF converter
+
+import GF.Canon.AbsGFC
+import GF.Data.ErrM
+import GF.Infra.Ident
+
+type Result = Err String
+
+failure :: Show a => a -> Result
+failure x = Bad $ "Undefined case: " ++ show x
+
+transIdent :: Ident -> Result
+transIdent x = case x of
+  Ident str  -> failure x
+
+
+transCanon :: Canon -> Result
+transCanon x = case x of
+  MGr ids id modules  -> failure x
+  Gr modules  -> failure x
+
+
+transLine :: Line -> Result
+transLine x = case x of
+  LMulti ids id  -> failure x
+  LHeader modtype extend open  -> failure x
+  LFlag flag  -> failure x
+  LDef def  -> failure x
+  LEnd  -> failure x
+
+
+transModule :: Module -> Result
+transModule x = case x of
+  Mod modtype extend open flags defs  -> failure x
+
+
+transModType :: ModType -> Result
+transModType x = case x of
+  MTAbs id  -> failure x
+  MTCnc id0 id  -> failure x
+  MTRes id  -> failure x
+  MTTrans id0 id1 id  -> failure x
+
+
+transExtend :: Extend -> Result
+transExtend x = case x of
+  Ext ids  -> failure x
+  NoExt  -> failure x
+
+
+transOpen :: Open -> Result
+transOpen x = case x of
+  Opens ids  -> failure x
+  NoOpens  -> failure x
+
+
+transFlag :: Flag -> Result
+transFlag x = case x of
+  Flg id0 id  -> failure x
+
+
+transDef :: Def -> Result
+transDef x = case x of
+  AbsDCat id decls cidents  -> failure x
+  AbsDFun id exp0 exp  -> failure x
+  AbsDTrans id exp  -> failure x
+  ResDPar id pardefs  -> failure x
+  ResDOper id ctype term  -> failure x
+  CncDCat id ctype term0 term  -> failure x
+  CncDFun id cident argvars term0 term  -> failure x
+  AnyDInd id0 status id  -> failure x
+
+
+transParDef :: ParDef -> Result
+transParDef x = case x of
+  ParD id ctypes  -> failure x
+
+
+transStatus :: Status -> Result
+transStatus x = case x of
+  Canon  -> failure x
+  NonCan  -> failure x
+
+
+transCIdent :: CIdent -> Result
+transCIdent x = case x of
+  CIQ id0 id  -> failure x
+
+
+transExp :: Exp -> Result
+transExp x = case x of
+  EApp exp0 exp  -> failure x
+  EProd id exp0 exp  -> failure x
+  EAbs id exp  -> failure x
+  EAtom atom  -> failure x
+  EData  -> failure x
+  EEq equations  -> failure x
+
+
+transSort :: Sort -> Result
+transSort x = case x of
+  SType  -> failure x
+
+
+transEquation :: Equation -> Result
+transEquation x = case x of
+  Equ apatts exp  -> failure x
+
+
+transAPatt :: APatt -> Result
+transAPatt x = case x of
+  APC cident apatts  -> failure x
+  APV id  -> failure x
+  APS str  -> failure x
+  API n  -> failure x
+  APW  -> failure x
+
+
+transAtom :: Atom -> Result
+transAtom x = case x of
+  AC cident  -> failure x
+  AD cident  -> failure x
+  AV id  -> failure x
+  AM n  -> failure x
+  AS str  -> failure x
+  AI n  -> failure x
+  AT sort  -> failure x
+
+
+transDecl :: Decl -> Result
+transDecl x = case x of
+  Decl id exp  -> failure x
+
+
+transCType :: CType -> Result
+transCType x = case x of
+  RecType labellings  -> failure x
+  Table ctype0 ctype  -> failure x
+  Cn cident  -> failure x
+  TStr  -> failure x
+  TInts n  -> failure x
+
+
+transLabelling :: Labelling -> Result
+transLabelling x = case x of
+  Lbg label ctype  -> failure x
+
+
+transTerm :: Term -> Result
+transTerm x = case x of
+  Arg argvar  -> failure x
+  I cident  -> failure x
+  Par cident terms  -> failure x
+  LI id  -> failure x
+  R assigns  -> failure x
+  P term label  -> failure x
+  T ctype cases  -> failure x
+  V ctype terms  -> failure x
+  S term0 term  -> failure x
+  C term0 term  -> failure x
+  FV terms  -> failure x
+  EInt n  -> failure x
+  K tokn  -> failure x
+  E  -> failure x
+
+
+transTokn :: Tokn -> Result
+transTokn x = case x of
+  KS str  -> failure x
+  KP strs variants  -> failure x
+  KM str  -> failure x
+
+
+transAssign :: Assign -> Result
+transAssign x = case x of
+  Ass label term  -> failure x
+
+
+transCase :: Case -> Result
+transCase x = case x of
+  Cas patts term  -> failure x
+
+
+transVariant :: Variant -> Result
+transVariant x = case x of
+  Var strs0 strs  -> failure x
+
+
+transLabel :: Label -> Result
+transLabel x = case x of
+  L id  -> failure x
+  LV n  -> failure x
+
+
+transArgVar :: ArgVar -> Result
+transArgVar x = case x of
+  A id n  -> failure x
+  AB id n0 n  -> failure x
+
+
+transPatt :: Patt -> Result
+transPatt x = case x of
+  PC cident patts  -> failure x
+  PV id  -> failure x
+  PW  -> failure x
+  PR pattassigns  -> failure x
+  PI n  -> failure x
+
+
+transPattAssign :: PattAssign -> Result
+transPattAssign x = case x of
+  PAss label patt  -> failure x
+
+
+

src-2.9/GF/Canon/Subexpressions.hs

@@ -0,0 +1,170 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Subexpressions
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/20 09:32:56 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.4 $
+--
+-- Common subexpression elimination.
+-- all tables. AR 18\/9\/2005.
+-----------------------------------------------------------------------------
+
+module GF.Canon.Subexpressions (
+  elimSubtermsMod, prSubtermStat, unSubelimCanon, unSubelimModule
+  ) where
+
+import GF.Canon.AbsGFC
+import GF.Infra.Ident
+import GF.Canon.GFC
+import GF.Canon.Look
+import GF.Grammar.PrGrammar
+import GF.Canon.CMacros as C
+import GF.Data.Operations
+import qualified GF.Infra.Modules as M
+
+import Control.Monad
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.List
+
+{-
+This module implements a simple common subexpression elimination
+ for gfc grammars, to factor out shared subterms in lin rules.
+It works in three phases: 
+
+  (1) collectSubterms collects recursively all subterms of forms table and (P x..y)
+      from lin definitions (experience shows that only these forms
+      tend to get shared) and counts how many times they occur
+  (2) addSubexpConsts takes those subterms t that occur more than once
+      and creates definitions of form "oper A''n = t" where n is a
+      fresh number; notice that we assume no ids of this form are in
+      scope otherwise
+  (3) elimSubtermsMod goes through lins and the created opers by replacing largest
+      possible subterms by the newly created identifiers
+
+The optimization is invoked in gf by the flag i -subs.
+
+If an application does not support GFC opers, the effect of this
+optimization can be undone by the function unSubelimCanon.
+
+The function unSubelimCanon can be used to diagnostisize how much
+cse is possible in the grammar. It is used by the flag pg -printer=subs.
+
+-}
+
+-- exported functions
+
+elimSubtermsMod :: (Ident,CanonModInfo) -> Err (Ident, CanonModInfo)
+elimSubtermsMod (mo,m) = case m of
+  M.ModMod (M.Module mt st fs me ops js) -> do
+    (tree,_) <- appSTM (getSubtermsMod mo (tree2list js)) (Map.empty,0)
+    js2 <- liftM buildTree $ addSubexpConsts mo tree $ tree2list js
+    return (mo,M.ModMod (M.Module mt st fs me ops js2))
+  _ -> return (mo,m)
+
+prSubtermStat :: CanonGrammar -> String
+prSubtermStat gr = unlines [prt mo ++++ expsIn mo js | (mo,js) <- mos] where
+  mos = [(i, tree2list (M.jments m)) | (i, M.ModMod m) <- M.modules gr, M.isModCnc m]
+  expsIn mo js = err id id $ do
+    (tree,_) <- appSTM (getSubtermsMod mo js) (Map.empty,0)
+    let list0 = Map.toList tree
+    let list1 = sortBy (\ (_,(m,_)) (_,(n,_)) -> compare n m) list0
+    return $ unlines [show n ++ "\t" ++ prt trm | (trm,(n,_)) <- list1]
+
+unSubelimCanon :: CanonGrammar -> CanonGrammar
+unSubelimCanon gr@(M.MGrammar modules) = 
+    M.MGrammar $ map unSubelimModule modules 
+ 
+unSubelimModule :: CanonModule -> CanonModule
+unSubelimModule mo@(i,m) = case m of
+    M.ModMod (M.Module mt@(M.MTConcrete _) st fs me ops js) | hasSub ljs ->
+      (i, M.ModMod (M.Module mt st fs me ops 
+                     (rebuild (map unparInfo ljs)))) 
+                        where ljs = tree2list js
+    _ -> (i,m)
+  where
+    -- perform this iff the module has opers
+    hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
+    unparInfo (c,info) = case info of
+      CncFun k xs t m -> [(c, CncFun k xs (unparTerm t) m)]
+      ResOper _ _ -> []
+      _ -> [(c,info)]
+    unparTerm t = case t of
+      I c -> errVal t $ liftM unparTerm $ lookupGlobal gr c 
+      _ -> C.composSafeOp unparTerm t
+    gr = M.MGrammar [mo] 
+    rebuild = buildTree . concat
+
+-- implementation
+
+type TermList = Map Term (Int,Int) -- number of occs, id
+type TermM a = STM (TermList,Int) a
+
+addSubexpConsts :: Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)]
+addSubexpConsts mo tree lins = do
+  let opers = [oper id trm | (trm,(_,id)) <- list]
+  mapM mkOne $ opers ++ lins
+ where
+
+   mkOne (f,def) = case def of
+     CncFun ci xs trm pn -> do
+       trm' <- recomp f trm
+       return (f,CncFun ci xs trm' pn)
+     ResOper ty trm -> do
+       trm' <- recomp f trm
+       return (f,ResOper ty trm')
+     _ -> return (f,def)
+   recomp f t = case Map.lookup t tree of
+     Just (_,id) | ident id /= f -> return $ I $ cident mo id
+     _ -> composOp (recomp f) t
+
+   list = Map.toList tree
+
+   oper id trm = (ident id, ResOper TStr trm) --- type TStr does not matter
+
+getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
+getSubtermsMod mo js = do
+  mapM (getInfo (collectSubterms mo)) js
+  (tree0,_) <- readSTM
+  return $ Map.filter (\ (nu,_) -> nu > 1) tree0
+ where
+   getInfo get fi@(f,i) = case i of
+     CncFun ci xs trm pn -> do
+       get trm
+       return $ fi
+     ResOper ty trm -> do
+       get trm
+       return $ fi
+     _ -> return fi
+
+collectSubterms :: Ident -> Term -> TermM Term
+collectSubterms mo t = case t of
+  Par _ (_:_) -> add t
+  T ty cs -> do
+    let (ps,ts) = unzip [(p,t) | Cas p t <- cs]
+    mapM (collectSubterms mo) ts
+    add t
+  V ty ts -> do
+    mapM (collectSubterms mo) ts
+    add t
+  K (KP _ _)  -> add t
+  _ -> composOp (collectSubterms mo) t
+ where
+   add t = do
+     (ts,i) <- readSTM
+     let 
+       ((count,id),next) = case Map.lookup t ts of
+         Just (nu,id) -> ((nu+1,id), i)
+         _ ->            ((1,   i ), i+1)
+     writeSTM (Map.insert t (count,id) ts, next)
+     return t --- only because of composOp
+
+ident :: Int -> Ident
+ident i = identC ("A''" ++ show i) ---
+
+cident :: Ident -> Int -> CIdent
+cident mo = CIQ mo . ident

src-2.9/GF/Canon/TestGFC.hs

@@ -0,0 +1,58 @@
+-- automatically generated by BNF Converter
+module Main where
+
+
+import IO ( stdin, hGetContents )
+import System ( getArgs, getProgName )
+
+import GF.Canon.LexGFC
+import GF.Canon.ParGFC
+import GF.Canon.SkelGFC
+import GF.Canon.PrintGFC
+import GF.Canon.AbsGFC
+import GF.Infra.Ident
+
+
+
+import GF.Data.ErrM
+
+type ParseFun a = [Token] -> Err a
+
+myLLexer = myLexer
+
+type Verbosity = Int
+
+putStrV :: Verbosity -> String -> IO ()
+putStrV v s = if v > 1 then putStrLn s else return ()
+
+runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
+runFile v p f = putStrLn f >> readFile f >>= run v p
+
+run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
+run v p s = let ts = myLLexer s in case p ts of
+           Bad s    -> do putStrLn "\nParse              Failed...\n"
+                          putStrV v "Tokens:"
+                          putStrV v $ show ts
+                          putStrLn s
+           Ok  tree -> do putStrLn "\nParse Successful!"
+                          showTree v tree
+
+
+
+showTree :: (Show a, Print a) => Int -> a -> IO ()
+showTree v tree
+ = do
+      putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
+      putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
+
+main :: IO ()
+main = do args <- getArgs
+          case args of
+            [] -> hGetContents stdin >>= run 2 pCanon
+            "-s":fs -> mapM_ (runFile 0 pCanon) fs
+            fs -> mapM_ (runFile 2 pCanon) fs
+
+
+
+
+

src-2.9/GF/Canon/Unlex.hs

@@ -0,0 +1,49 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Unlex
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:32 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- elementary text postprocessing. AR 21/11/2001
+-----------------------------------------------------------------------------
+
+module GF.Canon.Unlex (formatAsText, unlex, performBinds) where
+
+import GF.Data.Operations
+import GF.Data.Str
+
+import Data.Char
+import Data.List (isPrefixOf)
+
+formatAsText :: String -> String
+formatAsText = unwords . format . cap . words where
+  format ws = case ws of
+    w : c : ww | major c -> (w ++ c)      : format (cap ww)
+    w : c : ww | minor c -> (w ++ c)      : format ww
+    c     : ww | para  c -> "\n\n"        : format ww
+    w     : ww           -> w             : format ww
+    [] -> []
+  cap (p:(c:cs):ww) | para p = p : (toUpper c : cs) : ww
+  cap ((c:cs):ww) = (toUpper c : cs) : ww
+  cap [] = []
+  major = flip elem (map (:[]) ".!?") 
+  minor = flip elem (map (:[]) ",:;")
+  para  = (=="&-") 
+
+unlex :: [Str] -> String
+unlex = formatAsText . performBinds . concat . map sstr . take 1 ----
+
+-- | modified from GF/src/Text by adding hyphen
+performBinds :: String -> String
+performBinds = unwords . format . words where
+  format ws = case ws of
+    w : "-"  : u : ws -> format ((w ++ "-" ++ u) : ws)
+    w : "&+" : u : ws -> format ((w ++ u) : ws)
+    w : ws            -> w : format ws
+    []                -> []
+

src-2.9/GF/Canon/Unparametrize.hs

@@ -0,0 +1,63 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Unparametrize
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/14 16:26:21 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.1 $
+--
+-- Taking away parameters from a canonical grammar. All param
+-- types are replaced by {}, and only one branch is left in
+-- all tables. AR 14\/9\/2005.
+-----------------------------------------------------------------------------
+
+module GF.Canon.Unparametrize (unparametrizeCanon) where
+
+import GF.Canon.AbsGFC
+import GF.Infra.Ident
+import GF.Canon.GFC
+import qualified GF.Canon.CMacros as C
+import GF.Data.Operations
+import qualified GF.Infra.Modules as M
+
+unparametrizeCanon :: CanonGrammar -> CanonGrammar
+unparametrizeCanon (M.MGrammar modules) = 
+    M.MGrammar $ map unparModule modules where 
+
+  unparModule (i,m) = case m of
+    M.ModMod (M.Module mt@(M.MTConcrete _) st fs me ops js) ->
+      let me' = [(unparIdent j,incl) | (j,incl) <- me] in 
+      (unparIdent i, M.ModMod (M.Module mt st fs me' ops (mapTree unparInfo js)))
+    _ -> (i,m)
+
+  unparInfo (c,info) = case info of
+    CncCat ty t m   -> (c, CncCat   (unparCType ty) (unparTerm t) m)
+    CncFun k xs t m -> (c, CncFun k xs (unparTerm t) m)
+    AnyInd b i      -> (c, AnyInd b (unparIdent i))
+    _ -> (c,info)
+
+  unparCType ty = case ty of
+    RecType ls -> RecType [Lbg lab (unparCType t) | Lbg lab t <- ls]
+    Table _ v  -> unparCType v --- Table unitType (unparCType v)
+    Cn _       -> unitType
+    _ -> ty
+
+  unparTerm t = case t of
+    Par _ _ -> unitTerm
+    T _ cs  -> unparTerm (head [t | Cas _ t <- cs])
+    V _ ts  -> unparTerm (head ts)
+    S t _   -> unparTerm t
+{-
+    T _ cs  -> V unitType [unparTerm (head [t | Cas _ t <- cs])]
+    V _ ts  -> V unitType [unparTerm (head ts)]
+    S t _   -> S (unparTerm t) unitTerm
+-}
+    _ -> C.composSafeOp unparTerm t
+
+  unitType = RecType []
+  unitTerm = R []
+
+  unparIdent (IC s) = IC $ "UP_" ++ s

src-2.9/GF/Canon/log.txt

@@ -0,0 +1,20 @@
+GFCC, 6/9/2006
+
+66661   24  Par remaining to be sent to GFC
+66662    0  not covered by mkTerm
+66663   36  label not in numeric format in mkTerm
+66664    2  label not found in symbol table
+66665   36  projection from deeper than just arg var: NP.agr.n
+66667    0  parameter value not found in symbol table
+66668    1  variable in parameter argument
+
+
+
+66664    2
+66665  125  missing: (VP.s!vf).fin
+66668    1
+
+
+66661/3 24  same lines: 
+66664    2
+66668    1

src-2.9/GF/Command/AbsGFShell.hs

@@ -0,0 +1,42 @@
+module GF.Command.AbsGFShell where
+
+-- Haskell module generated by the BNF converter
+
+newtype Ident = Ident String deriving (Eq,Ord,Show)
+data CommandLine =
+   CLine [Pipe]
+ | CEmpty
+  deriving (Eq,Ord,Show)
+
+data Pipe =
+   PComm [Command]
+  deriving (Eq,Ord,Show)
+
+data Command =
+   Comm Ident [Option] Argument
+ | CNoarg Ident [Option]
+  deriving (Eq,Ord,Show)
+
+data Option =
+   OOpt Ident
+ | OFlag Ident Value
+  deriving (Eq,Ord,Show)
+
+data Value =
+   VId Ident
+ | VInt Integer
+  deriving (Eq,Ord,Show)
+
+data Argument =
+   ATree Tree
+  deriving (Eq,Ord,Show)
+
+data Tree =
+   TApp Ident [Tree]
+ | TAbs [Ident] Tree
+ | TId Ident
+ | TInt Integer
+ | TStr String
+ | TFloat Double
+  deriving (Eq,Ord,Show)
+

src-2.9/GF/Command/Commands.hs

@@ -0,0 +1,159 @@
+module GF.Command.Commands (
+  allCommands,
+  lookCommand,
+  exec,
+  isOpt,
+  options,
+  flags,
+  CommandInfo,
+  CommandOutput
+  ) where
+
+import GF.Command.AbsGFShell hiding (Tree)
+import GF.Command.PPrTree
+import GF.Command.ParGFShell
+import GF.GFCC.ShowLinearize
+import GF.GFCC.API
+import GF.GFCC.Macros
+import GF.Devel.PrintGFCC
+import GF.GFCC.DataGFCC ----
+
+import GF.Data.ErrM ----
+
+import qualified Data.Map as Map
+
+type CommandOutput = ([Tree],String) ---- errors, etc
+
+data CommandInfo = CommandInfo {
+  exec     :: [Option] -> [Tree] -> IO CommandOutput,
+  synopsis :: String,
+  explanation :: String,
+  longname :: String,
+  options  :: [String],
+  flags    :: [String]
+  }
+
+emptyCommandInfo :: CommandInfo
+emptyCommandInfo = CommandInfo {
+  exec = \_ ts -> return (ts,[]), ----
+  synopsis = "synopsis",
+  explanation = "explanation",
+  longname = "longname",
+  options = [],
+  flags = []
+  }
+
+lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo
+lookCommand = Map.lookup
+
+commandHelpAll :: MultiGrammar -> [Option] -> String
+commandHelpAll mgr opts = unlines
+  [commandHelp (isOpt "full" opts) (co,info)
+    | (co,info) <- Map.assocs (allCommands mgr)]
+
+commandHelp :: Bool -> (String,CommandInfo) -> String
+commandHelp full (co,info) = unlines $ [
+  co ++ ", " ++ longname info,
+  synopsis info] ++ if full then [
+  explanation info,
+  "options: " ++ unwords (options info),
+  "flags: " ++ unwords (flags info)
+  ] else []
+
+valIdOpts :: String -> String -> [Option] -> String
+valIdOpts flag def opts = case valOpts flag (VId (Ident def)) opts of
+  VId (Ident v) -> v
+  _ -> def
+
+valIntOpts :: String -> Integer -> [Option] -> Int
+valIntOpts flag def opts = fromInteger $ case valOpts flag (VInt def) opts of
+  VInt v -> v
+  _ -> def
+
+valOpts :: String -> Value -> [Option] -> Value
+valOpts flag def opts = case lookup flag flags of
+  Just v -> v
+  _ -> def
+ where
+   flags = [(f,v) | OFlag (Ident f) v <- opts]
+
+isOpt :: String -> [Option] -> Bool
+isOpt o opts = elem o [x | OOpt (Ident x) <- opts]
+
+-- this list must be kept sorted by the command name!
+allCommands :: MultiGrammar -> Map.Map String CommandInfo
+allCommands mgr = Map.fromAscList [
+  ("gr", emptyCommandInfo {
+     longname = "generate_random",
+     synopsis = "generates a list of random trees, by default one tree",
+     flags = ["cat","number"],
+     exec = \opts _ -> do
+       ts <- generateRandom mgr (optCat opts)
+       return $ fromTrees $ take (optNum opts) ts
+     }),
+  ("gt", emptyCommandInfo {
+     longname = "generate_trees",
+     synopsis = "generates a list of trees, by default exhaustive",
+     flags = ["cat","depth","number"],
+     exec = \opts _ -> do
+       let dp = return $ valIntOpts "depth" 4 opts
+       let ts = generateAllDepth mgr (optCat opts) dp
+       return $ fromTrees $ take (optNumInf opts) ts
+     }),
+  ("h", emptyCommandInfo {
+     longname = "help",
+     synopsis = "get description of a command, or a the full list of commands",
+     options = ["full"],
+     exec = \opts ts -> return ([], case ts of
+       [t] -> let co = (showTree t) in 
+              case lookCommand co (allCommands mgr) of   ---- new map ??!!
+                Just info -> commandHelp True (co,info)
+                _ -> "command not found"
+       _ -> commandHelpAll mgr opts)
+     }),
+  ("l", emptyCommandInfo {
+     exec = \opts -> return . fromStrings . map (optLin opts),
+     options = ["all","record","table","term"],
+     flags = ["lang"]
+     }),
+  ("p", emptyCommandInfo {
+     exec = \opts -> return . fromTrees . concatMap (par opts). toStrings,
+     flags = ["cat","lang"]
+     }),
+  ("pg", emptyCommandInfo {
+     exec  = \opts _ -> return $ fromString $ prGrammar opts,
+     flags = ["cat","lang","printer"]
+     })
+  ]
+ where
+   lin opts t = unlines [linearize mgr lang t    | lang <- optLangs opts]
+   par opts s = concat  [parse mgr lang (optCat opts) s | lang <- optLangs opts]
+ 
+   optLin opts t = unlines [linea lang t | lang <- optLangs opts] where
+     linea lang = case opts of
+       _ | isOpt "all"    opts -> allLinearize gr (cid lang)
+       _ | isOpt "table"  opts -> tableLinearize gr (cid lang)
+       _ | isOpt "term"   opts -> termLinearize gr (cid lang)
+       _ | isOpt "record" opts -> recordLinearize gr (cid lang)
+       _  -> linearize mgr lang
+
+
+   optLangs opts = case valIdOpts "lang" "" opts of
+     "" -> languages mgr
+     lang -> [lang] 
+   optCat opts = valIdOpts "cat" (lookStartCat gr) opts
+   optNum opts = valIntOpts "number" 1 opts
+   optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
+
+   gr       = gfcc mgr
+
+   fromTrees ts = (ts,unlines (map showTree ts))
+   fromStrings ss = (map tStr ss, unlines ss)
+   fromString  s  = ([tStr s], s)
+   toStrings ts = [s | DTr [] (AS s) [] <- ts] 
+   tStr s = DTr [] (AS s) []
+
+   prGrammar opts = case valIdOpts "printer" "" opts of
+     "cats" -> unwords $ categories mgr
+     v -> prGFCC v gr 
+

src-2.9/GF/Command/GFShell.cf

@@ -0,0 +1,27 @@
+--entrypoints CommandLine, Tree ;
+
+CLine.   CommandLine ::= [Pipe] ;
+CEmpty.  CommandLine ::= ;
+PComm.   Pipe        ::= [Command] ;
+Comm.    Command     ::= Ident [Option] Argument ;
+CNoarg.  Command     ::= Ident [Option] ;
+OOpt.    Option      ::= "-" Ident ;
+OFlag.   Option      ::= "-" Ident "=" Value ;
+VId.     Value       ::= Ident ;
+VInt.    Value       ::= Integer ;
+ATree.   Argument    ::= Tree ;
+
+TApp.    Tree1       ::= Ident [Tree2] ;
+TAbs.    Tree        ::= "\\" [Ident] "->" Tree ;
+TId.     Tree2       ::= Ident ;
+TInt.    Tree2       ::= Integer ; 
+TStr.    Tree2       ::= String ; 
+TFloat.  Tree2       ::= Double ; 
+
+coercions Tree 2 ;
+
+separator nonempty Pipe ";" ;
+separator nonempty Command "|" ;
+terminator Option "" ;
+terminator nonempty Tree2 "" ;
+terminator nonempty Ident "," ;

src-2.9/GF/Command/Importing.hs

@@ -0,0 +1,28 @@
+module GF.Command.Importing (importGrammar) where
+
+import GF.Compile.API
+import GF.GFCC.DataGFCC
+import GF.GFCC.API
+
+import GF.Devel.UseIO
+import GF.Infra.Option
+import GF.Data.ErrM
+
+import Data.List (nubBy)
+import System.FilePath
+
+-- import a grammar in an environment where it extends an existing grammar
+importGrammar :: MultiGrammar -> Options -> [FilePath] -> IO MultiGrammar
+importGrammar mgr0 opts files =
+  case takeExtensions (last files) of
+    s | elem s [".gf",".gfo"] -> do
+      res <- appIOE $ compileToGFCC opts files
+      case res of
+        Ok gfcc2 -> do let gfcc3 = unionGFCC (gfcc mgr0) gfcc2
+                       return $ MultiGrammar gfcc3
+        Bad msg  -> do putStrLn msg
+                       return mgr0
+    ".gfcc" -> do
+      gfcc2 <- mapM file2gfcc files >>= return . foldl1 unionGFCC
+      let gfcc3 = unionGFCC (gfcc mgr0) gfcc2
+      return $ MultiGrammar gfcc3

src-2.9/GF/Command/Interpreter.hs

@@ -0,0 +1,74 @@
+module GF.Command.Interpreter (
+  CommandEnv (..),
+  interpretCommandLine
+  ) where
+
+import GF.Command.Commands
+import GF.Command.AbsGFShell hiding (Tree)
+import GF.Command.PPrTree
+import GF.Command.ParGFShell
+import GF.GFCC.API
+import GF.GFCC.Macros
+import GF.GFCC.DataGFCC
+
+import GF.Data.ErrM ----
+
+import qualified Data.Map as Map
+
+data CommandEnv = CommandEnv {
+  multigrammar :: MultiGrammar,
+  commands     :: Map.Map String CommandInfo
+  }
+
+interpretCommandLine :: CommandEnv -> String -> IO ()
+interpretCommandLine env line = case (pCommandLine (myLexer line)) of
+  Ok CEmpty -> return ()
+  Ok (CLine pipes) -> mapM_ interPipe pipes
+  _ -> putStrLn "command not parsed"
+ where
+   interPipe (PComm cs) = do
+     (_,s) <- intercs ([],"") cs
+     putStrLn s
+   intercs treess [] = return treess
+   intercs (trees,_) (c:cs) = do
+     treess2 <- interc trees c
+     intercs treess2 cs
+   interc = interpret env
+
+-- return the trees to be sent in pipe, and the output possibly printed
+interpret :: CommandEnv -> [Tree] -> Command -> IO CommandOutput
+interpret env trees0 comm = case lookCommand co comms of
+  Just info -> do
+    checkOpts info
+    tss@(_,s) <- exec info opts trees
+    optTrace s
+    return tss
+  _ -> do
+    putStrLn $ "command " ++ co ++ " not interpreted"
+    return ([],[])
+ where
+   optTrace = if isOpt "tr" opts then putStrLn else const (return ()) 
+   (co,opts,trees) = getCommand comm trees0
+   comms = commands env
+   checkOpts info = 
+     case
+       [o | OOpt  (Ident o)   <- opts, notElem o (options info)] ++
+       [o | OFlag (Ident o) _ <- opts, notElem o (flags info)]
+      of
+        []  -> return () 
+        [o] -> putStrLn $ "option not interpreted: " ++ o
+        os  -> putStrLn $ "options not interpreted: " ++ unwords os
+
+-- analyse command parse tree to a uniform datastructure, normalizing comm name
+getCommand :: Command -> [Tree] -> (String,[Option],[Tree])
+getCommand co ts = case co of
+  Comm   (Ident c) opts (ATree t) -> (getOp c,opts,[tree2exp t]) -- ignore piped
+  CNoarg (Ident c) opts           -> (getOp c,opts,ts)           -- use piped
+ where
+   -- abbreviation convention from gf
+   getOp s = case break (=='_') s of
+     (a:_,_:b:_) -> [a,b]  -- axx_byy --> ab
+     _ -> case s of
+       [a,b] -> s          -- ab  --> ab
+       a:_ -> [a]          -- axx --> a
+

src-2.9/GF/Command/PPrTree.hs

@@ -0,0 +1,39 @@
+module GF.Command.PPrTree (pTree, prExp, tree2exp) where
+
+import GF.GFCC.DataGFCC
+import GF.GFCC.CId
+import GF.GFCC.Macros
+import qualified GF.Command.ParGFShell as P
+import GF.Command.PrintGFShell
+import GF.Command.AbsGFShell
+import GF.Data.ErrM
+
+pTree :: String -> Exp
+pTree s = case P.pTree (P.myLexer s) of
+  Ok t -> tree2exp t
+  Bad s -> error s
+
+tree2exp t = case t of
+  TApp f ts -> tree (AC (i2i f)) (map tree2exp ts)  
+  TAbs xs t -> DTr (map i2i xs ++ ys) f ts where DTr ys f ts = tree2exp t 
+  TId c     -> tree (AC (i2i c)) [] 
+  TInt i    -> tree (AI i) []
+  TStr s    -> tree (AS s) []
+  TFloat d  -> tree (AF d) [] 
+ where
+   i2i (Ident s) = CId s
+
+prExp :: Exp -> String
+prExp = printTree . exp2tree
+
+exp2tree (DTr xs at ts) = tabs (map i4i xs) (tapp at (map exp2tree ts)) 
+  where
+    tabs [] t = t
+    tabs ys t = TAbs ys t
+    tapp (AC f) [] = TId (i4i f)
+    tapp (AC f) vs = TApp (i4i f) vs
+    tapp (AI i) [] = TInt i
+    tapp (AS i) [] = TStr i
+    tapp (AF i) [] = TFloat i
+    tapp (AM i) [] = TId (Ident "?") ----
+    i4i (CId s) = Ident s

src-2.9/GF/Command/ParGFShell.hs

@@ -0,0 +1,809 @@
+{-# OPTIONS -fglasgow-exts -cpp #-}
+{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
+module GF.Command.ParGFShell where
+import GF.Command.AbsGFShell
+import GF.Command.LexGFShell
+import GF.Data.ErrM
+#if __GLASGOW_HASKELL__ >= 503
+import Data.Array
+#else
+import Array
+#endif
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.Exts
+#else
+import GlaExts
+#endif
+
+-- parser produced by Happy Version 1.16
+
+newtype HappyAbsSyn  = HappyAbsSyn (() -> ())
+happyIn17 :: (Ident) -> (HappyAbsSyn )
+happyIn17 x = unsafeCoerce# x
+{-# INLINE happyIn17 #-}
+happyOut17 :: (HappyAbsSyn ) -> (Ident)
+happyOut17 x = unsafeCoerce# x
+{-# INLINE happyOut17 #-}
+happyIn18 :: (Integer) -> (HappyAbsSyn )
+happyIn18 x = unsafeCoerce# x
+{-# INLINE happyIn18 #-}
+happyOut18 :: (HappyAbsSyn ) -> (Integer)
+happyOut18 x = unsafeCoerce# x
+{-# INLINE happyOut18 #-}
+happyIn19 :: (String) -> (HappyAbsSyn )
+happyIn19 x = unsafeCoerce# x
+{-# INLINE happyIn19 #-}
+happyOut19 :: (HappyAbsSyn ) -> (String)
+happyOut19 x = unsafeCoerce# x
+{-# INLINE happyOut19 #-}
+happyIn20 :: (Double) -> (HappyAbsSyn )
+happyIn20 x = unsafeCoerce# x
+{-# INLINE happyIn20 #-}
+happyOut20 :: (HappyAbsSyn ) -> (Double)
+happyOut20 x = unsafeCoerce# x
+{-# INLINE happyOut20 #-}
+happyIn21 :: (CommandLine) -> (HappyAbsSyn )
+happyIn21 x = unsafeCoerce# x
+{-# INLINE happyIn21 #-}
+happyOut21 :: (HappyAbsSyn ) -> (CommandLine)
+happyOut21 x = unsafeCoerce# x
+{-# INLINE happyOut21 #-}
+happyIn22 :: (Pipe) -> (HappyAbsSyn )
+happyIn22 x = unsafeCoerce# x
+{-# INLINE happyIn22 #-}
+happyOut22 :: (HappyAbsSyn ) -> (Pipe)
+happyOut22 x = unsafeCoerce# x
+{-# INLINE happyOut22 #-}
+happyIn23 :: (Command) -> (HappyAbsSyn )
+happyIn23 x = unsafeCoerce# x
+{-# INLINE happyIn23 #-}
+happyOut23 :: (HappyAbsSyn ) -> (Command)
+happyOut23 x = unsafeCoerce# x
+{-# INLINE happyOut23 #-}
+happyIn24 :: (Option) -> (HappyAbsSyn )
+happyIn24 x = unsafeCoerce# x
+{-# INLINE happyIn24 #-}
+happyOut24 :: (HappyAbsSyn ) -> (Option)
+happyOut24 x = unsafeCoerce# x
+{-# INLINE happyOut24 #-}
+happyIn25 :: (Value) -> (HappyAbsSyn )
+happyIn25 x = unsafeCoerce# x
+{-# INLINE happyIn25 #-}
+happyOut25 :: (HappyAbsSyn ) -> (Value)
+happyOut25 x = unsafeCoerce# x
+{-# INLINE happyOut25 #-}
+happyIn26 :: (Argument) -> (HappyAbsSyn )
+happyIn26 x = unsafeCoerce# x
+{-# INLINE happyIn26 #-}
+happyOut26 :: (HappyAbsSyn ) -> (Argument)
+happyOut26 x = unsafeCoerce# x
+{-# INLINE happyOut26 #-}
+happyIn27 :: (Tree) -> (HappyAbsSyn )
+happyIn27 x = unsafeCoerce# x
+{-# INLINE happyIn27 #-}
+happyOut27 :: (HappyAbsSyn ) -> (Tree)
+happyOut27 x = unsafeCoerce# x
+{-# INLINE happyOut27 #-}
+happyIn28 :: (Tree) -> (HappyAbsSyn )
+happyIn28 x = unsafeCoerce# x
+{-# INLINE happyIn28 #-}
+happyOut28 :: (HappyAbsSyn ) -> (Tree)
+happyOut28 x = unsafeCoerce# x
+{-# INLINE happyOut28 #-}
+happyIn29 :: (Tree) -> (HappyAbsSyn )
+happyIn29 x = unsafeCoerce# x
+{-# INLINE happyIn29 #-}
+happyOut29 :: (HappyAbsSyn ) -> (Tree)
+happyOut29 x = unsafeCoerce# x
+{-# INLINE happyOut29 #-}
+happyIn30 :: ([Pipe]) -> (HappyAbsSyn )
+happyIn30 x = unsafeCoerce# x
+{-# INLINE happyIn30 #-}
+happyOut30 :: (HappyAbsSyn ) -> ([Pipe])
+happyOut30 x = unsafeCoerce# x
+{-# INLINE happyOut30 #-}
+happyIn31 :: ([Command]) -> (HappyAbsSyn )
+happyIn31 x = unsafeCoerce# x
+{-# INLINE happyIn31 #-}
+happyOut31 :: (HappyAbsSyn ) -> ([Command])
+happyOut31 x = unsafeCoerce# x
+{-# INLINE happyOut31 #-}
+happyIn32 :: ([Option]) -> (HappyAbsSyn )
+happyIn32 x = unsafeCoerce# x
+{-# INLINE happyIn32 #-}
+happyOut32 :: (HappyAbsSyn ) -> ([Option])
+happyOut32 x = unsafeCoerce# x
+{-# INLINE happyOut32 #-}
+happyIn33 :: ([Tree]) -> (HappyAbsSyn )
+happyIn33 x = unsafeCoerce# x
+{-# INLINE happyIn33 #-}
+happyOut33 :: (HappyAbsSyn ) -> ([Tree])
+happyOut33 x = unsafeCoerce# x
+{-# INLINE happyOut33 #-}
+happyIn34 :: ([Ident]) -> (HappyAbsSyn )
+happyIn34 x = unsafeCoerce# x
+{-# INLINE happyIn34 #-}
+happyOut34 :: (HappyAbsSyn ) -> ([Ident])
+happyOut34 x = unsafeCoerce# x
+{-# INLINE happyOut34 #-}
+happyInTok :: Token -> (HappyAbsSyn )
+happyInTok x = unsafeCoerce# x
+{-# INLINE happyInTok #-}
+happyOutTok :: (HappyAbsSyn ) -> Token
+happyOutTok x = unsafeCoerce# x
+{-# INLINE happyOutTok #-}
+
+happyActOffsets :: HappyAddr
+happyActOffsets = HappyA# "\x8d\x00\x8d\x00\x8d\x00\x91\x00\x16\x00\x80\x00\x89\x00\x80\x00\x89\x00\x7c\x00\x7c\x00\x00\x00\x89\x00\x7c\x00\x7c\x00\x00\x00\x7b\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x73\x00\x80\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x79\x00\x6c\x00\x72\x00\x69\x00\x00\x00\x69\x00\x89\x00\x00\x00\x69\x00\x00\x00\x62\x00\x5f\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x5f\x00\x5d\x00\x54\x00\x54\x00\x54\x00\x00\x00\x60\x00\x52\x00\x00\x00\x3a\x00\x3a\x00\x6a\x00\x00\x00\x24\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x16\x00\x00\x00\x00\x00\x00\x00"#
+
+happyGotoOffsets :: HappyAddr
+happyGotoOffsets = HappyA# "\x1f\x00\x09\x00\x35\x00\x2a\x00\x90\x00\x49\x00\x70\x00\x5e\x00\x7d\x00\x33\x00\x34\x00\x42\x00\x1b\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x12\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x22\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x87\x00\x00\x00\x00\x00\x00\x00"#
+
+happyDefActions :: HappyAddr
+happyDefActions = HappyA# "\xec\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\xff\x00\x00\x00\x00\x00\x00\xf1\xff\x00\x00\x00\x00\xdf\xff\xde\xff\xdd\xff\xdc\xff\xd4\xff\x00\x00\x00\x00\xf0\xff\xef\xff\xee\xff\x00\x00\xd6\xff\xd8\xff\x00\x00\xda\xff\x00\x00\xeb\xff\x00\x00\xdf\xff\xe0\xff\x00\x00\xe2\xff\x00\x00\x00\x00\x00\x00\xe4\xff\xe6\xff\xe5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xff\xe8\xff\x00\x00\xe3\xff\x00\x00\x00\x00\xe9\xff\xd5\xff\x00\x00\xd3\xff\xd2\xff\xd1\xff\xdb\xff\xea\xff\xd7\xff\xd9\xff\x00\x00\x00\x00\xe7\xff\xe1\xff"#
+
+happyCheck :: HappyAddr
+happyCheck = HappyA# "\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x00\x00\x01\x00\x02\x00\x03\x00\x05\x00\x06\x00\x0a\x00\x0c\x00\x11\x00\x11\x00\x11\x00\x10\x00\x0c\x00\x0e\x00\x01\x00\x07\x00\x10\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x0a\x00\x0b\x00\x00\x00\x04\x00\x05\x00\x06\x00\x0f\x00\x0c\x00\x06\x00\x00\x00\x06\x00\x10\x00\x0d\x00\x0e\x00\x05\x00\x06\x00\x0e\x00\x07\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x0e\x00\x05\x00\x06\x00\x06\x00\x06\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0d\x00\x0e\x00\x0e\x00\x07\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0f\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x04\x00\x0a\x00\x0b\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x02\x00\x0f\x00\x0a\x00\x0b\x00\x0c\x00\x0a\x00\x0a\x00\x0b\x00\x0c\x00\x01\x00\x0a\x00\x03\x00\x0f\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0f\x00\x07\x00\x0a\x00\x0f\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x08\x00\x0f\x00\x03\x00\x09\x00\x05\x00\x0a\x00\x00\x00\x01\x00\x0c\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x08\x00\x00\x00\x01\x00\x01\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
+
+happyTable :: HappyAddr
+happyTable = HappyA# "\x00\x00\x10\x00\x10\x00\x10\x00\x35\x00\x12\x00\x13\x00\x14\x00\x15\x00\x1d\x00\x12\x00\x13\x00\x14\x00\x15\x00\x32\x00\x1e\x00\x10\x00\x16\x00\x3f\x00\x36\x00\x11\x00\x37\x00\x16\x00\x22\x00\x31\x00\x3b\x00\x3d\x00\x12\x00\x13\x00\x14\x00\x15\x00\x1d\x00\x10\x00\x1a\x00\x1d\x00\x33\x00\x20\x00\x1e\x00\xff\xff\x16\x00\x1e\x00\x1d\x00\x41\x00\x17\x00\x34\x00\x22\x00\x20\x00\x1e\x00\x42\x00\x2f\x00\x3a\x00\x1d\x00\x1d\x00\x1d\x00\x43\x00\x22\x00\x20\x00\x1e\x00\x1e\x00\x31\x00\x24\x00\x13\x00\x14\x00\x15\x00\x21\x00\x22\x00\x1f\x00\x3b\x00\x10\x00\x41\x00\x25\x00\x2b\x00\x27\x00\x24\x00\x13\x00\x14\x00\x15\x00\x24\x00\x13\x00\x14\x00\x15\x00\x1c\x00\x2a\x00\x25\x00\x2b\x00\x27\x00\x45\x00\x25\x00\x47\x00\x27\x00\x24\x00\x13\x00\x14\x00\x15\x00\x24\x00\x13\x00\x14\x00\x15\x00\x46\x00\xff\xff\x25\x00\x3c\x00\x27\x00\x10\x00\x25\x00\x26\x00\x27\x00\x31\x00\x10\x00\x29\x00\xff\xff\x19\x00\x24\x00\x13\x00\x14\x00\x15\x00\x10\x00\x1a\x00\x1b\x00\x1c\x00\xff\xff\x39\x00\x29\x00\xff\xff\x27\x00\x12\x00\x13\x00\x14\x00\x15\x00\x3a\x00\xff\xff\x29\x00\x3f\x00\x19\x00\x10\x00\x2c\x00\x2d\x00\x23\x00\x10\x00\x1a\x00\x1b\x00\x1c\x00\x19\x00\x46\x00\x2c\x00\x2d\x00\x31\x00\x10\x00\x1a\x00\x1b\x00\x1c\x00\x10\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
+
+happyReduceArr = array (14, 46) [
+	(14 , happyReduce_14),
+	(15 , happyReduce_15),
+	(16 , happyReduce_16),
+	(17 , happyReduce_17),
+	(18 , happyReduce_18),
+	(19 , happyReduce_19),
+	(20 , happyReduce_20),
+	(21 , happyReduce_21),
+	(22 , happyReduce_22),
+	(23 , happyReduce_23),
+	(24 , happyReduce_24),
+	(25 , happyReduce_25),
+	(26 , happyReduce_26),
+	(27 , happyReduce_27),
+	(28 , happyReduce_28),
+	(29 , happyReduce_29),
+	(30 , happyReduce_30),
+	(31 , happyReduce_31),
+	(32 , happyReduce_32),
+	(33 , happyReduce_33),
+	(34 , happyReduce_34),
+	(35 , happyReduce_35),
+	(36 , happyReduce_36),
+	(37 , happyReduce_37),
+	(38 , happyReduce_38),
+	(39 , happyReduce_39),
+	(40 , happyReduce_40),
+	(41 , happyReduce_41),
+	(42 , happyReduce_42),
+	(43 , happyReduce_43),
+	(44 , happyReduce_44),
+	(45 , happyReduce_45),
+	(46 , happyReduce_46)
+	]
+
+happy_n_terms = 16 :: Int
+happy_n_nonterms = 18 :: Int
+
+happyReduce_14 = happySpecReduce_1  0# happyReduction_14
+happyReduction_14 happy_x_1
+	 =  case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) -> 
+	happyIn17
+		 (Ident happy_var_1
+	)}
+
+happyReduce_15 = happySpecReduce_1  1# happyReduction_15
+happyReduction_15 happy_x_1
+	 =  case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> 
+	happyIn18
+		 ((read happy_var_1) :: Integer
+	)}
+
+happyReduce_16 = happySpecReduce_1  2# happyReduction_16
+happyReduction_16 happy_x_1
+	 =  case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> 
+	happyIn19
+		 (happy_var_1
+	)}
+
+happyReduce_17 = happySpecReduce_1  3# happyReduction_17
+happyReduction_17 happy_x_1
+	 =  case happyOutTok happy_x_1 of { (PT _ (TD happy_var_1)) -> 
+	happyIn20
+		 ((read happy_var_1) :: Double
+	)}
+
+happyReduce_18 = happySpecReduce_1  4# happyReduction_18
+happyReduction_18 happy_x_1
+	 =  case happyOut30 happy_x_1 of { happy_var_1 -> 
+	happyIn21
+		 (CLine happy_var_1
+	)}
+
+happyReduce_19 = happySpecReduce_0  4# happyReduction_19
+happyReduction_19  =  happyIn21
+		 (CEmpty
+	)
+
+happyReduce_20 = happySpecReduce_1  5# happyReduction_20
+happyReduction_20 happy_x_1
+	 =  case happyOut31 happy_x_1 of { happy_var_1 -> 
+	happyIn22
+		 (PComm happy_var_1
+	)}
+
+happyReduce_21 = happySpecReduce_3  6# happyReduction_21
+happyReduction_21 happy_x_3
+	happy_x_2
+	happy_x_1
+	 =  case happyOut17 happy_x_1 of { happy_var_1 -> 
+	case happyOut32 happy_x_2 of { happy_var_2 -> 
+	case happyOut26 happy_x_3 of { happy_var_3 -> 
+	happyIn23
+		 (Comm happy_var_1 (reverse happy_var_2) happy_var_3
+	)}}}
+
+happyReduce_22 = happySpecReduce_2  6# happyReduction_22
+happyReduction_22 happy_x_2
+	happy_x_1
+	 =  case happyOut17 happy_x_1 of { happy_var_1 -> 
+	case happyOut32 happy_x_2 of { happy_var_2 -> 
+	happyIn23
+		 (CNoarg happy_var_1 (reverse happy_var_2)
+	)}}
+
+happyReduce_23 = happySpecReduce_2  7# happyReduction_23
+happyReduction_23 happy_x_2
+	happy_x_1
+	 =  case happyOut17 happy_x_2 of { happy_var_2 -> 
+	happyIn24
+		 (OOpt happy_var_2
+	)}
+
+happyReduce_24 = happyReduce 4# 7# happyReduction_24
+happyReduction_24 (happy_x_4 `HappyStk`
+	happy_x_3 `HappyStk`
+	happy_x_2 `HappyStk`
+	happy_x_1 `HappyStk`
+	happyRest)
+	 = case happyOut17 happy_x_2 of { happy_var_2 -> 
+	case happyOut25 happy_x_4 of { happy_var_4 -> 
+	happyIn24
+		 (OFlag happy_var_2 happy_var_4
+	) `HappyStk` happyRest}}
+
+happyReduce_25 = happySpecReduce_1  8# happyReduction_25
+happyReduction_25 happy_x_1
+	 =  case happyOut17 happy_x_1 of { happy_var_1 -> 
+	happyIn25
+		 (VId happy_var_1
+	)}
+
+happyReduce_26 = happySpecReduce_1  8# happyReduction_26
+happyReduction_26 happy_x_1
+	 =  case happyOut18 happy_x_1 of { happy_var_1 -> 
+	happyIn25
+		 (VInt happy_var_1
+	)}
+
+happyReduce_27 = happySpecReduce_1  9# happyReduction_27
+happyReduction_27 happy_x_1
+	 =  case happyOut28 happy_x_1 of { happy_var_1 -> 
+	happyIn26
+		 (ATree happy_var_1
+	)}
+
+happyReduce_28 = happySpecReduce_2  10# happyReduction_28
+happyReduction_28 happy_x_2
+	happy_x_1
+	 =  case happyOut17 happy_x_1 of { happy_var_1 -> 
+	case happyOut33 happy_x_2 of { happy_var_2 -> 
+	happyIn27
+		 (TApp happy_var_1 happy_var_2
+	)}}
+
+happyReduce_29 = happySpecReduce_1  10# happyReduction_29
+happyReduction_29 happy_x_1
+	 =  case happyOut29 happy_x_1 of { happy_var_1 -> 
+	happyIn27
+		 (happy_var_1
+	)}
+
+happyReduce_30 = happyReduce 4# 11# happyReduction_30
+happyReduction_30 (happy_x_4 `HappyStk`
+	happy_x_3 `HappyStk`
+	happy_x_2 `HappyStk`
+	happy_x_1 `HappyStk`
+	happyRest)
+	 = case happyOut34 happy_x_2 of { happy_var_2 -> 
+	case happyOut28 happy_x_4 of { happy_var_4 -> 
+	happyIn28
+		 (TAbs happy_var_2 happy_var_4
+	) `HappyStk` happyRest}}
+
+happyReduce_31 = happySpecReduce_1  11# happyReduction_31
+happyReduction_31 happy_x_1
+	 =  case happyOut27 happy_x_1 of { happy_var_1 -> 
+	happyIn28
+		 (happy_var_1
+	)}
+
+happyReduce_32 = happySpecReduce_1  12# happyReduction_32
+happyReduction_32 happy_x_1
+	 =  case happyOut17 happy_x_1 of { happy_var_1 -> 
+	happyIn29
+		 (TId happy_var_1
+	)}
+
+happyReduce_33 = happySpecReduce_1  12# happyReduction_33
+happyReduction_33 happy_x_1
+	 =  case happyOut18 happy_x_1 of { happy_var_1 -> 
+	happyIn29
+		 (TInt happy_var_1
+	)}
+
+happyReduce_34 = happySpecReduce_1  12# happyReduction_34
+happyReduction_34 happy_x_1
+	 =  case happyOut19 happy_x_1 of { happy_var_1 -> 
+	happyIn29
+		 (TStr happy_var_1
+	)}
+
+happyReduce_35 = happySpecReduce_1  12# happyReduction_35
+happyReduction_35 happy_x_1
+	 =  case happyOut20 happy_x_1 of { happy_var_1 -> 
+	happyIn29
+		 (TFloat happy_var_1
+	)}
+
+happyReduce_36 = happySpecReduce_3  12# happyReduction_36
+happyReduction_36 happy_x_3
+	happy_x_2
+	happy_x_1
+	 =  case happyOut28 happy_x_2 of { happy_var_2 -> 
+	happyIn29
+		 (happy_var_2
+	)}
+
+happyReduce_37 = happySpecReduce_1  13# happyReduction_37
+happyReduction_37 happy_x_1
+	 =  case happyOut22 happy_x_1 of { happy_var_1 -> 
+	happyIn30
+		 ((:[]) happy_var_1
+	)}
+
+happyReduce_38 = happySpecReduce_3  13# happyReduction_38
+happyReduction_38 happy_x_3
+	happy_x_2
+	happy_x_1
+	 =  case happyOut22 happy_x_1 of { happy_var_1 -> 
+	case happyOut30 happy_x_3 of { happy_var_3 -> 
+	happyIn30
+		 ((:) happy_var_1 happy_var_3
+	)}}
+
+happyReduce_39 = happySpecReduce_1  14# happyReduction_39
+happyReduction_39 happy_x_1
+	 =  case happyOut23 happy_x_1 of { happy_var_1 -> 
+	happyIn31
+		 ((:[]) happy_var_1
+	)}
+
+happyReduce_40 = happySpecReduce_3  14# happyReduction_40
+happyReduction_40 happy_x_3
+	happy_x_2
+	happy_x_1
+	 =  case happyOut23 happy_x_1 of { happy_var_1 -> 
+	case happyOut31 happy_x_3 of { happy_var_3 -> 
+	happyIn31
+		 ((:) happy_var_1 happy_var_3
+	)}}
+
+happyReduce_41 = happySpecReduce_0  15# happyReduction_41
+happyReduction_41  =  happyIn32
+		 ([]
+	)
+
+happyReduce_42 = happySpecReduce_2  15# happyReduction_42
+happyReduction_42 happy_x_2
+	happy_x_1
+	 =  case happyOut32 happy_x_1 of { happy_var_1 -> 
+	case happyOut24 happy_x_2 of { happy_var_2 -> 
+	happyIn32
+		 (flip (:) happy_var_1 happy_var_2
+	)}}
+
+happyReduce_43 = happySpecReduce_1  16# happyReduction_43
+happyReduction_43 happy_x_1
+	 =  case happyOut29 happy_x_1 of { happy_var_1 -> 
+	happyIn33
+		 ((:[]) happy_var_1
+	)}
+
+happyReduce_44 = happySpecReduce_2  16# happyReduction_44
+happyReduction_44 happy_x_2
+	happy_x_1
+	 =  case happyOut29 happy_x_1 of { happy_var_1 -> 
+	case happyOut33 happy_x_2 of { happy_var_2 -> 
+	happyIn33
+		 ((:) happy_var_1 happy_var_2
+	)}}
+
+happyReduce_45 = happySpecReduce_2  17# happyReduction_45
+happyReduction_45 happy_x_2
+	happy_x_1
+	 =  case happyOut17 happy_x_1 of { happy_var_1 -> 
+	happyIn34
+		 ((:[]) happy_var_1
+	)}
+
+happyReduce_46 = happySpecReduce_3  17# happyReduction_46
+happyReduction_46 happy_x_3
+	happy_x_2
+	happy_x_1
+	 =  case happyOut17 happy_x_1 of { happy_var_1 -> 
+	case happyOut34 happy_x_3 of { happy_var_3 -> 
+	happyIn34
+		 ((:) happy_var_1 happy_var_3
+	)}}
+
+happyNewToken action sts stk [] =
+	happyDoAction 15# notHappyAtAll action sts stk []
+
+happyNewToken action sts stk (tk:tks) =
+	let cont i = happyDoAction i tk action sts stk tks in
+	case tk of {
+	PT _ (TS "-") -> cont 1#;
+	PT _ (TS "=") -> cont 2#;
+	PT _ (TS "\\") -> cont 3#;
+	PT _ (TS "->") -> cont 4#;
+	PT _ (TS "(") -> cont 5#;
+	PT _ (TS ")") -> cont 6#;
+	PT _ (TS ";") -> cont 7#;
+	PT _ (TS "|") -> cont 8#;
+	PT _ (TS ",") -> cont 9#;
+	PT _ (TV happy_dollar_dollar) -> cont 10#;
+	PT _ (TI happy_dollar_dollar) -> cont 11#;
+	PT _ (TL happy_dollar_dollar) -> cont 12#;
+	PT _ (TD happy_dollar_dollar) -> cont 13#;
+	_ -> cont 14#;
+	_ -> happyError' (tk:tks)
+	}
+
+happyError_ tk tks = happyError' (tk:tks)
+
+happyThen :: () => Err a -> (a -> Err b) -> Err b
+happyThen = (thenM)
+happyReturn :: () => a -> Err a
+happyReturn = (returnM)
+happyThen1 m k tks = (thenM) m (\a -> k a tks)
+happyReturn1 :: () => a -> b -> Err a
+happyReturn1 = \a tks -> (returnM) a
+happyError' :: () => [Token] -> Err a
+happyError' = happyError
+
+pCommandLine tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut21 x))
+
+pPipe tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut22 x))
+
+pCommand tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 2# tks) (\x -> happyReturn (happyOut23 x))
+
+pOption tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 3# tks) (\x -> happyReturn (happyOut24 x))
+
+pValue tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 4# tks) (\x -> happyReturn (happyOut25 x))
+
+pArgument tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 5# tks) (\x -> happyReturn (happyOut26 x))
+
+pTree1 tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 6# tks) (\x -> happyReturn (happyOut27 x))
+
+pTree tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 7# tks) (\x -> happyReturn (happyOut28 x))
+
+pTree2 tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 8# tks) (\x -> happyReturn (happyOut29 x))
+
+pListPipe tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 9# tks) (\x -> happyReturn (happyOut30 x))
+
+pListCommand tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 10# tks) (\x -> happyReturn (happyOut31 x))
+
+pListOption tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 11# tks) (\x -> happyReturn (happyOut32 x))
+
+pListTree2 tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 12# tks) (\x -> happyReturn (happyOut33 x))
+
+pListIdent tks = happySomeParser where
+  happySomeParser = happyThen (happyParse 13# tks) (\x -> happyReturn (happyOut34 x))
+
+happySeq = happyDontSeq
+
+
+returnM :: a -> Err a
+returnM = return
+
+thenM :: Err a -> (a -> Err b) -> Err b
+thenM = (>>=)
+
+happyError :: [Token] -> Err a
+happyError ts =
+  Bad $ "syntax error at " ++ tokenPos ts ++ 
+  case ts of
+    [] -> []
+    [Err _] -> " due to lexer error"
+    _ -> " before " ++ unwords (map prToken (take 4 ts))
+
+myLexer = tokens
+{-# LINE 1 "GenericTemplate.hs" #-}
+{-# LINE 1 "<built-in>" #-}
+{-# LINE 1 "<command line>" #-}
+{-# LINE 1 "GenericTemplate.hs" #-}
+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp 
+
+{-# LINE 28 "GenericTemplate.hs" #-}
+
+
+data Happy_IntList = HappyCons Int# Happy_IntList
+
+
+
+
+
+{-# LINE 49 "GenericTemplate.hs" #-}
+
+{-# LINE 59 "GenericTemplate.hs" #-}
+
+{-# LINE 68 "GenericTemplate.hs" #-}
+
+infixr 9 `HappyStk`
+data HappyStk a = HappyStk a (HappyStk a)
+
+-----------------------------------------------------------------------------
+-- starting the parse
+
+happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
+
+-----------------------------------------------------------------------------
+-- Accepting the parse
+
+-- If the current token is 0#, it means we've just accepted a partial
+-- parse (a %partial parser).  We must ignore the saved token on the top of
+-- the stack in this case.
+happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =
+	happyReturn1 ans
+happyAccept j tk st sts (HappyStk ans _) = 
+	(happyTcHack j (happyTcHack st)) (happyReturn1 ans)
+
+-----------------------------------------------------------------------------
+-- Arrays only: do the next action
+
+
+
+happyDoAction i tk st
+	= {- nothing -}
+
+
+	  case action of
+		0#		  -> {- nothing -}
+				     happyFail i tk st
+		-1# 	  -> {- nothing -}
+				     happyAccept i tk st
+		n | (n <# (0# :: Int#)) -> {- nothing -}
+
+				     (happyReduceArr ! rule) i tk st
+				     where rule = (I# ((negateInt# ((n +# (1# :: Int#))))))
+		n		  -> {- nothing -}
+
+
+				     happyShift new_state i tk st
+				     where new_state = (n -# (1# :: Int#))
+   where off    = indexShortOffAddr happyActOffsets st
+	 off_i  = (off +# i)
+	 check  = if (off_i >=# (0# :: Int#))
+			then (indexShortOffAddr happyCheck off_i ==#  i)
+			else False
+ 	 action | check     = indexShortOffAddr happyTable off_i
+		| otherwise = indexShortOffAddr happyDefActions st
+
+{-# LINE 127 "GenericTemplate.hs" #-}
+
+
+indexShortOffAddr (HappyA# arr) off =
+#if __GLASGOW_HASKELL__ > 500
+	narrow16Int# i
+#elif __GLASGOW_HASKELL__ == 500
+	intToInt16# i
+#else
+	(i `iShiftL#` 16#) `iShiftRA#` 16#
+#endif
+  where
+#if __GLASGOW_HASKELL__ >= 503
+	i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
+#else
+	i = word2Int# ((high `shiftL#` 8#) `or#` low)
+#endif
+	high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
+	low  = int2Word# (ord# (indexCharOffAddr# arr off'))
+	off' = off *# 2#
+
+
+
+
+
+data HappyAddr = HappyA# Addr#
+
+
+
+
+-----------------------------------------------------------------------------
+-- HappyState data type (not arrays)
+
+{-# LINE 170 "GenericTemplate.hs" #-}
+
+-----------------------------------------------------------------------------
+-- Shifting a token
+
+happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =
+     let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in
+--     trace "shifting the error token" $
+     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)
+
+happyShift new_state i tk st sts stk =
+     happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)
+
+-- happyReduce is specialised for the common cases.
+
+happySpecReduce_0 i fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happySpecReduce_0 nt fn j tk st@((action)) sts stk
+     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)
+
+happySpecReduce_1 i fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')
+     = let r = fn v1 in
+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
+
+happySpecReduce_2 i fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')
+     = let r = fn v1 v2 in
+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
+
+happySpecReduce_3 i fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
+     = let r = fn v1 v2 v3 in
+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
+
+happyReduce k i fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happyReduce k nt fn j tk st sts stk
+     = case happyDrop (k -# (1# :: Int#)) sts of
+	 sts1@((HappyCons (st1@(action)) (_))) ->
+        	let r = fn stk in  -- it doesn't hurt to always seq here...
+       		happyDoSeq r (happyGoto nt j tk st1 sts1 r)
+
+happyMonadReduce k nt fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happyMonadReduce k nt fn j tk st sts stk =
+        happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))
+       where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))
+             drop_stk = happyDropStk k stk
+
+happyMonad2Reduce k nt fn 0# tk st sts stk
+     = happyFail 0# tk st sts stk
+happyMonad2Reduce k nt fn j tk st sts stk =
+       happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))
+       where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))
+             drop_stk = happyDropStk k stk
+
+             off    = indexShortOffAddr happyGotoOffsets st1
+             off_i  = (off +# nt)
+             new_state = indexShortOffAddr happyTable off_i
+
+
+
+
+happyDrop 0# l = l
+happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t
+
+happyDropStk 0# l = l
+happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs
+
+-----------------------------------------------------------------------------
+-- Moving to a new state after a reduction
+
+
+happyGoto nt j tk st = 
+   {- nothing -}
+   happyDoAction j tk new_state
+   where off    = indexShortOffAddr happyGotoOffsets st
+	 off_i  = (off +# nt)
+ 	 new_state = indexShortOffAddr happyTable off_i
+
+
+
+
+-----------------------------------------------------------------------------
+-- Error recovery (0# is the error token)
+
+-- parse error if we are in recovery and we fail again
+happyFail  0# tk old_st _ stk =
+--	trace "failing" $ 
+    	happyError_ tk
+
+{-  We don't need state discarding for our restricted implementation of
+    "error".  In fact, it can cause some bogus parses, so I've disabled it
+    for now --SDM
+
+-- discard a state
+happyFail  0# tk old_st (HappyCons ((action)) (sts)) 
+						(saved_tok `HappyStk` _ `HappyStk` stk) =
+--	trace ("discarding state, depth " ++ show (length stk))  $
+	happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))
+-}
+
+-- Enter error recovery: generate an error token,
+--                       save the old token and carry on.
+happyFail  i tk (action) sts stk =
+--      trace "entering error recovery" $
+	happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk)
+
+-- Internal happy errors:
+
+notHappyAtAll = error "Internal Happy error\n"
+
+-----------------------------------------------------------------------------
+-- Hack to get the typechecker to accept our action functions
+
+
+happyTcHack :: Int# -> a -> a
+happyTcHack x y = y
+{-# INLINE happyTcHack #-}
+
+
+-----------------------------------------------------------------------------
+-- Seq-ing.  If the --strict flag is given, then Happy emits 
+--	happySeq = happyDoSeq
+-- otherwise it emits
+-- 	happySeq = happyDontSeq
+
+happyDoSeq, happyDontSeq :: a -> b -> b
+happyDoSeq   a b = a `seq` b
+happyDontSeq a b = b
+
+-----------------------------------------------------------------------------
+-- Don't inline any functions from the template.  GHC has a nasty habit
+-- of deciding to inline happyGoto everywhere, which increases the size of
+-- the generated parser quite a bit.
+
+
+{-# NOINLINE happyDoAction #-}
+{-# NOINLINE happyTable #-}
+{-# NOINLINE happyCheck #-}
+{-# NOINLINE happyActOffsets #-}
+{-# NOINLINE happyGotoOffsets #-}
+{-# NOINLINE happyDefActions #-}
+
+{-# NOINLINE happyShift #-}
+{-# NOINLINE happySpecReduce_0 #-}
+{-# NOINLINE happySpecReduce_1 #-}
+{-# NOINLINE happySpecReduce_2 #-}
+{-# NOINLINE happySpecReduce_3 #-}
+{-# NOINLINE happyReduce #-}
+{-# NOINLINE happyMonadReduce #-}
+{-# NOINLINE happyGoto #-}
+{-# NOINLINE happyFail #-}
+
+-- end of Happy Template.

src-2.9/GF/Command/PrintGFShell.hs

@@ -0,0 +1,144 @@
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+module GF.Command.PrintGFShell where
+
+-- pretty-printer generated by the BNF converter
+
+import GF.Command.AbsGFShell
+import Char
+
+-- the top-level printing method
+printTree :: Print a => a -> String
+printTree = render . prt 0
+
+type Doc = [ShowS] -> [ShowS]
+
+doc :: ShowS -> Doc
+doc = (:)
+
+render :: Doc -> String
+render d = rend 0 (map ($ "") $ d []) "" where
+  rend i ss = case ss of
+    "["      :ts -> showChar '[' . rend i ts
+    "("      :ts -> showChar '(' . rend i ts
+    "{"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts
+    "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
+    "}"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
+    ";"      :ts -> showChar ';' . new i . rend i ts
+    t  : "," :ts -> showString t . space "," . rend i ts
+    t  : ")" :ts -> showString t . showChar ')' . rend i ts
+    t  : "]" :ts -> showString t . showChar ']' . rend i ts
+    t        :ts -> space t . rend i ts
+    _            -> id
+  new i   = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
+  space t = showString t . (\s -> if null s then "" else (' ':s))
+
+parenth :: Doc -> Doc
+parenth ss = doc (showChar '(') . ss . doc (showChar ')')
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+concatD :: [Doc] -> Doc
+concatD = foldr (.) id
+
+replicateS :: Int -> ShowS -> ShowS
+replicateS n f = concatS (replicate n f)
+
+-- the printer class does the job
+class Print a where
+  prt :: Int -> a -> Doc
+  prtList :: [a] -> Doc
+  prtList = concatD . map (prt 0)
+
+instance Print a => Print [a] where
+  prt _ = prtList
+
+instance Print Char where
+  prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
+  prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
+
+mkEsc :: Char -> Char -> ShowS
+mkEsc q s = case s of
+  _ | s == q -> showChar '\\' . showChar s
+  '\\'-> showString "\\\\"
+  '\n' -> showString "\\n"
+  '\t' -> showString "\\t"
+  _ -> showChar s
+
+prPrec :: Int -> Int -> Doc -> Doc
+prPrec i j = if j<i then parenth else id
+
+
+instance Print Integer where
+  prt _ x = doc (shows x)
+
+
+instance Print Double where
+  prt _ x = doc (shows x)
+
+
+instance Print Ident where
+  prt _ (Ident i) = doc (showString i)
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x , doc (showString ",")])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+
+
+instance Print CommandLine where
+  prt i e = case e of
+   CLine pipes -> prPrec i 0 (concatD [prt 0 pipes])
+   CEmpty  -> prPrec i 0 (concatD [])
+
+
+instance Print Pipe where
+  prt i e = case e of
+   PComm commands -> prPrec i 0 (concatD [prt 0 commands])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Command where
+  prt i e = case e of
+   Comm id options argument -> prPrec i 0 (concatD [prt 0 id , prt 0 options , prt 0 argument])
+   CNoarg id options -> prPrec i 0 (concatD [prt 0 id , prt 0 options])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
+
+instance Print Option where
+  prt i e = case e of
+   OOpt id -> prPrec i 0 (concatD [doc (showString "-") , prt 0 id])
+   OFlag id value -> prPrec i 0 (concatD [doc (showString "-") , prt 0 id , doc (showString "=") , prt 0 value])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print Value where
+  prt i e = case e of
+   VId id -> prPrec i 0 (concatD [prt 0 id])
+   VInt n -> prPrec i 0 (concatD [prt 0 n])
+
+
+instance Print Argument where
+  prt i e = case e of
+   ATree tree -> prPrec i 0 (concatD [prt 0 tree])
+
+
+instance Print Tree where
+  prt i e = case e of
+   TApp id trees -> prPrec i 1 (concatD [prt 0 id , prt 2 trees])
+   TAbs ids tree -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 ids , doc (showString "->") , prt 0 tree])
+   TId id -> prPrec i 2 (concatD [prt 0 id])
+   TInt n -> prPrec i 2 (concatD [prt 0 n])
+   TStr str -> prPrec i 2 (concatD [prt 0 str])
+   TFloat d -> prPrec i 2 (concatD [prt 0 d])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 2 x])
+   x:xs -> (concatD [prt 2 x , prt 2 xs])
+
+

src-2.9/GF/Compile/API.hs

@@ -0,0 +1,21 @@
+module GF.Compile.API (batchCompile, compileToGFCC) where
+
+import GF.Devel.Compile
+import GF.Devel.GrammarToGFCC
+import GF.GFCC.OptimizeGFCC
+import GF.GFCC.CheckGFCC
+import GF.GFCC.DataGFCC
+import GF.Infra.Option
+import GF.Devel.UseIO
+
+-- | Compiles a number of source files and builds a 'GFCC' structure for them.
+compileToGFCC :: Options -> [FilePath] -> IOE GFCC
+compileToGFCC opts fs = 
+    do gr <- batchCompile opts fs
+       let name = justModuleName (last fs)
+       gc1 <- putPointE opts "linking ... " $
+                let (abs,gc0) = mkCanon2gfcc opts name gr
+                in ioeIO $ checkGFCCio gc0
+       let opt = if oElem (iOpt "noopt") opts then id else optGFCC
+           par = if oElem (iOpt "noparse") opts then id else addParsers
+       return (par (opt gc1))

src-2.9/GF/Compile/BackOpt.hs

@@ -0,0 +1,141 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : BackOpt
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:33 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- Optimizations on GF source code: sharing, parametrization, value sets.
+--
+-- optimization: sharing branches in tables. AR 25\/4\/2003.
+-- following advice of Josef Svenningsson
+-----------------------------------------------------------------------------
+
+module GF.Compile.BackOpt (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import qualified GF.Grammar.Macros as C
+import GF.Grammar.PrGrammar (prt)
+import GF.Data.Operations
+import Data.List
+import qualified GF.Infra.Modules as M
+
+type OptSpec = [Integer] ---
+
+doOptFactor :: OptSpec -> Bool
+doOptFactor opt = elem 2 opt
+
+doOptValues :: OptSpec -> Bool
+doOptValues opt = elem 3 opt
+
+shareOpt :: OptSpec
+shareOpt = []
+
+paramOpt :: OptSpec
+paramOpt = [2]
+
+valOpt :: OptSpec
+valOpt = [3]
+
+allOpt :: OptSpec
+allOpt = [2,3]
+
+shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
+shareModule opt (i,m) = case m of
+  M.ModMod (M.Module mt st fs me ops js) -> 
+    (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
+  _ -> (i,m)
+
+shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (shareOptim opt c t)) m)
+shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (shareOptim opt c t)) m)
+shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (shareOptim opt c t)))
+shareInfo _ i = i
+
+-- the function putting together optimizations
+shareOptim :: OptSpec -> Ident -> Term -> Term
+shareOptim opt c 
+  | doOptFactor opt && doOptValues opt = values . factor c 0
+  | doOptFactor opt = share . factor c 0
+  | doOptValues opt = values    
+  | otherwise = share
+
+-- we need no counter to create new variable names, since variables are 
+-- local to tables (only true in GFC) ---
+
+share :: Term -> Term
+share t = case t of
+  T ty@(TComp _) cs -> shareT ty [(p, share v) | (p, v) <- cs]
+  _ -> C.composSafeOp share t
+
+ where
+   shareT ty = finalize ty . groupC . sortC
+ 
+   sortC :: [(Patt,Term)] -> [(Patt,Term)]
+   sortC = sortBy $ \a b -> compare (snd a) (snd b)
+
+   groupC :: [(Patt,Term)] -> [[(Patt,Term)]]
+   groupC = groupBy $ \a b -> snd a == snd b
+
+   finalize :: TInfo -> [[(Patt,Term)]] -> Term
+   finalize ty css = TSh ty [(map fst ps, t) | ps@((_,t):_) <- css]
+
+-- do even more: factor parametric branches
+
+factor :: Ident -> Int -> Term -> Term
+factor c i t = case t of
+  T _ [_] -> t
+  T _ []  -> t
+  T (TComp ty) cs -> 
+    T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs]
+  _ -> C.composSafeOp (factor c i) t
+ where
+
+   factors i psvs =   -- we know psvs has at least 2 elements
+     let p   = qqIdent c i
+         vs' = map (mkFun p) psvs
+     in if   allEqs vs'
+        then mkCase p vs' 
+        else psvs
+
+   mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val
+
+   allEqs (v:vs) = all (==v) vs
+
+   mkCase p (v:_) = [(PV p, v)]
+
+--- we hope this will be fresh and don't check... in GFC would be safe
+
+qqIdent c i = identC ("q_" ++ prt c ++ "__" ++ show i)
+
+
+--  we need to replace subterms
+
+replace :: Term -> Term -> Term -> Term
+replace old new trm = case trm of
+  
+  -- these are the important cases, since they can correspond to patterns  
+  QC _ _   | trm == old -> new
+  App t ts | trm == old -> new
+  App t ts              -> App (repl t) (repl ts)
+  R _ | isRec && trm == old -> new
+  _ -> C.composSafeOp repl trm
+ where
+   repl = replace old new
+   isRec = case trm of
+     R _ -> True
+     _ -> False
+
+-- It is very important that this is performed only after case
+-- expansion since otherwise the order and number of values can
+-- be incorrect. Guaranteed by the TComp flag.
+
+values :: Term -> Term
+values t = case t of
+  T ty [(ps,t)]   -> T ty [(ps,values t)] -- don't destroy parametrization
+  T (TComp ty) cs -> V ty [values t | (_, t) <- cs]
+  _ -> C.composSafeOp values t

src-2.9/GF/Compile/Compile.hs

@@ -0,0 +1,401 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Compile
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/05 20:02:19 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.45 $
+--
+-- The top-level compilation chain from source file to gfc\/gfr.
+-----------------------------------------------------------------------------
+
+module GF.Compile.Compile (compileModule, compileEnvShSt, compileOne,
+		CompileEnv, TimedCompileEnv,gfGrammarPathVar,pathListOpts,
+	       getGFEFiles) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Infra.CompactPrint
+import GF.Grammar.PrGrammar
+import GF.Compile.Update
+import GF.Grammar.Lookup
+import GF.Infra.Modules
+import GF.Infra.ReadFiles
+import GF.Compile.ShellState
+import GF.Compile.MkResource
+---- import MkUnion
+
+-- the main compiler passes
+import GF.Compile.GetGrammar
+import GF.Compile.Extend
+import GF.Compile.Rebuild
+import GF.Compile.Rename
+import GF.Grammar.Refresh
+import GF.Compile.CheckGrammar
+import GF.Compile.Optimize
+import GF.Compile.Evaluate
+import GF.Compile.GrammarToCanon
+--import GF.Devel.GrammarToGFCC -----
+import GF.Devel.OptimizeGF (subexpModule,unsubexpModule)
+import GF.Canon.Share
+import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule)
+import GF.UseGrammar.Linear (unoptimizeCanonMod) ----
+
+import qualified GF.Canon.CanonToGrammar as CG
+
+import qualified GF.Canon.GFC as GFC
+import qualified GF.Canon.MkGFC as MkGFC
+import GF.Canon.GetGFC
+
+import GF.Data.Operations
+import GF.Infra.UseIO
+import GF.Text.UTF8 ----
+import GF.System.Arch
+
+import Control.Monad
+import System.Directory
+import System.FilePath
+
+-- | in batch mode: write code in a file
+batchCompile f = liftM fst $ compileModule defOpts emptyShellState f
+  where
+    defOpts = options [emitCode] 
+batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f
+  where
+    defOpts = options [emitCode, optimizeCanon] 
+
+batchCompileOld f = compileOld defOpts f
+  where
+    defOpts = options [emitCode] 
+
+-- | compile with one module as starting point
+-- command-line options override options (marked by --#) in the file
+-- As for path: if it is read from file, the file path is prepended to each name.
+-- If from command line, it is used as it is.
+compileModule :: Options -> ShellState -> FilePath -> IOE TimedCompileEnv
+----             IOE (GFC.CanonGrammar, (SourceGrammar,[(String,(FilePath,ModTime))]))
+
+compileModule opts st0 file | 
+     oElem showOld opts || 
+     elem suff [".cf",".ebnf",".gfm"] = do
+  let putp  = putPointE opts
+  let putpp = putPointEsil opts
+  let path = [] ----
+  grammar1 <- case suff of
+    ".cf"   -> putp ("- parsing" +++ suff +++ file) $ getCFGrammar opts file
+    ".ebnf" -> putp ("- parsing" +++ suff +++ file) $ getEBNFGrammar opts file
+    ".gfm"  -> putp ("- parsing" +++ suff +++ file) $ getSourceGrammar opts file
+    _       -> putp ("- parsing old gf" +++ file)   $ getOldGrammar opts file
+  let mods = modules grammar1
+  let env = compileEnvShSt st0 []
+  foldM (comp putpp path) env mods
+ where
+   suff = takeExtensions file
+   comp putpp path env sm0 = do
+     (k',sm,eenv')  <- makeSourceModule opts (fst env) sm0
+     cm  <- putpp "  generating code... " $ generateModuleCode opts path sm
+     ft <- getReadTimes file ---
+     extendCompileEnvInt env (k',sm,cm) eenv' ft
+
+compileModule opts1 st0 file = do
+  opts0 <- ioeIO $ getOptionsFromFile file
+  let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
+  let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList
+  let opts = addOptions opts1 opts0 
+  let fpath = dropFileName file
+  ps0 <- ioeIO $ pathListOpts opts fpath
+
+  let ps1 = if (useFileOpt && not useLineOpt) 
+              then (ps0 ++ map (combine fpath) ps0)
+              else ps0
+  ps <- ioeIO $ extendPathEnv ps1
+  let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ()))
+  ioeIOIf $ putStrLn $ "module search path:" +++ show ps ----
+  let st = st0 --- if useFileOpt then emptyShellState else st0
+  let rfs = [(m,t) | (m,(_,t)) <- readFiles st]
+  let file' = if useFileOpt then takeFileName file else file -- to find file itself
+  files <- getAllFiles opts ps rfs file'
+  ioeIOIf $ putStrLn $ "files to read:" +++ show files ----
+  let names = map justModuleName files
+  ioeIOIf $ putStrLn $ "modules to include:" +++ show names ----
+  let env0 = compileEnvShSt st names
+  (e,mm) <- foldIOE (compileOne opts) env0 files
+  maybe (return ()) putStrLnE mm
+  return e
+
+getReadTimes file = do
+  t <- ioeIO getNowTime
+  let m = justModuleName file
+  return $ (m,(file,t)) : [(resModName m,(file,t)) | not (isGFC file)]
+
+compileEnvShSt :: ShellState -> [ModName] -> TimedCompileEnv
+compileEnvShSt st fs = ((0,sgr,cgr,eenv),fts) where
+  cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i]
+  sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i]
+  notInc i = notElem (prt i) $ map dropExtension fs
+  notIns i = notElem (prt i) $ map dropExtension fs
+  fts = readFiles st
+  eenv = evalEnv st
+
+pathListOpts :: Options -> FileName -> IO [InitPath]
+pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList
+
+reverseModules (MGrammar ms) = MGrammar $ reverse ms
+
+keepResModules :: Options -> SourceGrammar -> SourceGrammar
+keepResModules opts gr = 
+  if oElem retainOpers opts 
+    then MGrammar $ reverse [(i,mi) | (i,mi@(ModMod m)) <- modules gr, isModRes m]
+    else emptyMGrammar
+
+
+-- | the environment
+type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar,EEnv)
+
+emptyCompileEnv :: TimedCompileEnv
+emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar,emptyEEnv),[])
+
+extendCompileEnvInt ((_,MGrammar ss, MGrammar cs,_),fts) (k,sm,cm) eenv ft = 
+  return ((k,MGrammar (sm:ss), MGrammar (cm:cs),eenv),ft++fts) --- reverse later
+
+extendCompileEnv e@((k,_,_,_),_) (sm,cm) = extendCompileEnvInt e (k,sm,cm)
+
+extendCompileEnvCanon ((k,s,c,e),fts) cgr eenv ft = 
+  return ((k,s, MGrammar (modules cgr ++ modules c),eenv),ft++fts)
+
+type TimedCompileEnv = (CompileEnv,[(String,(FilePath,ModTime))])
+
+compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv
+compileOne opts env@((_,srcgr,cancgr0,eenv),_) file = do
+
+  let putp = putPointE opts
+  let putpp = putPointEsil opts
+  let putpOpt v m act
+       | oElem beVerbose opts =  putp v act
+       | oElem beSilent opts  =  putpp v act
+       | otherwise = ioeIO (putStrFlush m) >> act
+
+  let gf   = takeExtensions file
+  let path = dropFileName file
+  let name = dropExtension file
+  let mos  = modules srcgr
+
+  case gf of
+    -- for multilingual canonical gf, just read the file and update environment
+    ".gfcm" -> do
+       cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file
+       ft <- getReadTimes file
+       extendCompileEnvCanon env cgr eenv ft
+
+    -- for canonical gf, read the file and update environment, also source env
+    ".gfc" -> do
+       cm <- putp ("+ reading" +++ file) $ getCanonModule file
+       let cancgr = updateMGrammar (MGrammar [cm]) cancgr0 
+       sm <- ioeErr $ CG.canon2sourceModule $ unoptimizeCanonMod cancgr $ unSubelimModule cm
+       ft <- getReadTimes file
+       extendCompileEnv env (sm, cm) eenv ft
+
+    -- for compiled resource, parse and organize, then update environment
+    ".gfr" -> do
+       sm0 <- putp ("| reading" +++ file) $ getSourceModule opts file
+       let sm1 = unsubexpModule sm0
+       sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm1
+---- experiment with not optimizing gfr 
+----      sm:_  <- putp "  optimizing " $ ioeErr $ evalModule mos sm1
+       let gfc = gfcFile name 
+       cm  <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
+       ft  <- getReadTimes file
+       extendCompileEnv env (sm,cm) eenv ft
+
+    -- for gf source, do full compilation
+
+    _ -> do
+
+      --- hack fix to a bug in ReadFiles with reused concrete
+
+      let modu = dropExtension file
+      b1 <- ioeIO $ doesFileExist file
+      b2 <- ioeIO $ doesFileExist $ gfrFile modu
+      if not b1
+        then if b2 
+          then compileOne opts env $ gfrFile $ modu 
+          else compileOne opts env $ gfcFile $ modu 
+        else do
+
+       sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ 
+                                           getSourceModule opts file
+       (k',sm,eenv')  <- makeSourceModule opts (fst env) sm0
+       cm  <- putpp "  generating code... " $ generateModuleCode opts path sm
+       ft <- getReadTimes file
+
+       sm':_ <- case snd sm of
+----         ModMod n | isModRes n -> putp "  optimizing " $ ioeErr $ evalModule mos sm
+         _ -> return [sm]
+
+       extendCompileEnvInt env (k',sm',cm) eenv' ft
+
+-- | dispatch reused resource at early stage
+makeSourceModule :: Options -> CompileEnv -> 
+                    SourceModule -> IOE (Int,SourceModule,EEnv)
+makeSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = case mi of
+
+  ModMod m -> case mtype m of
+    MTReuse c -> do
+      sm <- ioeErr $ makeReuse gr i (extend m) c
+      let mo2 = (i, ModMod sm)
+          mos = modules gr
+      --- putp "  type checking reused" $ ioeErr $ showCheckModule mos mo2
+      return $ (k,mo2,eenv)
+{- ---- obsolete
+    MTUnion ty imps -> do
+      mo' <- ioeErr $ makeUnion gr i ty imps
+      compileSourceModule opts env mo'
+-}
+
+    _ -> compileSourceModule opts env mo
+  _ -> compileSourceModule opts env mo
+ where
+   putp = putPointE opts
+
+compileSourceModule :: Options -> CompileEnv -> 
+                       SourceModule -> IOE (Int,SourceModule,EEnv)
+compileSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = do
+
+  let putp  = putPointE opts
+      putpp = putPointEsil opts
+      mos   = modules gr
+
+  if (oElem showOld opts && oElem emitCode opts) 
+    then do
+      let (file,out) = (gfFile (prt i), prGrammar (MGrammar [mo]))
+      putp ("  wrote file" +++ file) $ ioeIO $ writeFile file out
+    else return ()
+
+  mo1   <- ioeErr $ rebuildModule mos mo
+
+  mo1b  <- ioeErr $ extendModule mos mo1
+
+  case mo1b of
+    (_,ModMod n) | not (isCompleteModule n) -> do
+      return (k,mo1b,eenv)   -- refresh would fail, since not renamed
+    _ -> do
+      mo2:_ <- putpp "  renaming " $ ioeErr $ renameModule mos mo1b
+
+      (mo3:_,warnings) <- putpp "  type checking" $ ioeErr $ showCheckModule mos mo2
+      if null warnings then return () else putp warnings $ return ()
+
+      (k',mo3r:_) <- putpp "  refreshing " $ ioeErr $ refreshModule (k,mos) mo3
+
+      (mo4,eenv') <- 
+        ---- if oElem "check_only" opts 
+          putpp "  optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r
+      return (k',mo4,eenv')
+ where
+   ----   prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
+   prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo]
+
+generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule
+generateModuleCode opts path minfo@(name,info) = do
+
+--- DEPREC
+---  if oElem (iOpt "gfcc") opts
+---    then ioeIO $ putStrLn $ prGrammar2gfcc minfo
+---    else return ()
+
+  let pname = path </> prt name
+  minfo0     <- ioeErr $ redModInfo minfo
+  let oopts  = addOptions opts (iOpts (flagsModule minfo))
+      optims = maybe "all_subs" id $ getOptVal oopts useOptimizer
+      optim  = takeWhile (/='_') optims
+      subs   = drop 1 (dropWhile (/='_') optims) == "subs"
+  minfo1     <- return $ 
+    case optim of
+      "parametrize" -> shareModule paramOpt minfo0  -- parametrization and sharing
+      "values"      -> shareModule valOpt minfo0    -- tables as courses-of-values
+      "share"       -> shareModule shareOpt minfo0  -- sharing of branches
+      "all"         -> shareModule allOpt minfo0    -- first parametrize then values
+      "none"        -> minfo0                       -- no optimization
+      _             -> shareModule shareOpt minfo0  -- sharing; default
+
+  -- do common subexpression elimination if required by flag "subs"
+  minfo' <- 
+    if subs
+      then ioeErr $ elimSubtermsMod minfo1
+      else return minfo1
+
+  -- for resource, also emit gfr. 
+  --- Also for incomplete, to create timestamped gfc/gfr files
+  case info of
+    ModMod m | emitsGFR m && emit && nomulti -> do
+      let rminfo = if isCompilable info 
+                   then subexpModule minfo 
+                   else (name, ModMod emptyModule) 
+      let (file,out) = (gfrFile pname, prGrammar (MGrammar [rminfo]))
+      putp ("  wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out
+    _ -> return ()
+  let encode = case getOptVal opts uniCoding of
+        Just "utf8" -> encodeUTF8
+        _ -> id
+  (file,out) <- do
+      code <- return $ MkGFC.prCanonModInfo minfo'
+      return (gfcFile pname, encode code)
+  if emit && nomulti ---- && isCompilable info 
+     then putp  ("  wrote file" +++ file) $ ioeIO $ writeFile file out
+     else putpp ("no need to save module" +++ prt name) $ return ()
+  return minfo'
+ where 
+   putp  = putPointE opts
+   putpp = putPointEsil opts
+
+   emitsGFR m = isModRes m ---- && isCompilable info
+     ---- isModRes m || (isModCnc m && mstatus m == MSIncomplete)
+   isCompilable mi = case mi of
+     ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete 
+     _ -> True
+   nomulti = not $ oElem makeMulti opts
+   emit  = oElem emitCode opts && not (oElem notEmitCode opts)
+
+-- for old GF: sort into modules, write files, compile as usual
+
+compileOld :: Options -> FilePath -> IOE GFC.CanonGrammar
+compileOld opts file = do
+  let putp = putPointE opts
+  grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
+  files <- mapM writeNewGF $ modules grammar1
+  ((_,_,grammar,_),_) <- foldM (compileOne opts) emptyCompileEnv files
+  return grammar
+
+writeNewGF :: SourceModule -> IOE FilePath
+writeNewGF m@(i,_) = do
+  let file = gfFile $ prt i
+  ioeIO $ writeFile file $ prGrammar (MGrammar [m])
+  ioeIO $ putStrLn $ "wrote file" +++ file
+  return file
+
+--- this function duplicates a lot of code from compileModule.
+--- It does not really belong here either.
+-- It selects those .gfe files that a grammar depends on and that
+-- are younger than corresponding gf
+
+getGFEFiles :: Options -> FilePath -> IO [FilePath]
+getGFEFiles opts1 file = useIOE [] $ do
+  opts0 <- ioeIO $ getOptionsFromFile file
+  let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
+  let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList
+  let opts = addOptions opts1 opts0 
+  let fpath = dropFileName file
+  ps0 <- ioeIO $ pathListOpts opts fpath
+
+  let ps1 = if (useFileOpt && not useLineOpt) 
+              then (map (combine fpath) ps0)
+              else ps0
+  ps <- ioeIO $ extendPathEnv ps1
+  let file' = if useFileOpt then takeFileName file else file -- to find file itself
+  files <- getAllFiles opts ps [] file'
+  efiles <- ioeIO $ filterM doesFileExist [replaceExtension f "gfe" | f <- files]
+  es <- ioeIO $ mapM (uncurry selectLater) [(f, init f) | f <- efiles] -- init gfe == gf
+  return $ filter ((=='e') . last) es

src-2.9/GF/Compile/Evaluate.hs

@@ -0,0 +1,477 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Evaluate
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/01 15:39:12 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.19 $
+--
+-- Computation of source terms. Used in compilation and in @cc@ command.
+-----------------------------------------------------------------------------
+
+module GF.Compile.Evaluate (appEvalConcrete, EEnv, emptyEEnv) where
+
+import GF.Data.Operations
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Data.Str
+import GF.Grammar.PrGrammar
+import GF.Infra.Modules
+import GF.Infra.Option
+import GF.Grammar.Macros
+import GF.Grammar.Lookup
+import GF.Grammar.Refresh
+import GF.Grammar.PatternMatch
+import GF.Grammar.Lockfield (isLockLabel) ----
+
+import GF.Grammar.AppPredefined
+
+import qualified Data.Map as Map
+
+import Data.List (nub,intersperse)
+import Control.Monad (liftM2, liftM)
+import Debug.Trace
+
+
+data EEnv = EEnv {
+  computd :: Map.Map (Ident,Ident) FTerm,
+  temp :: Int
+  }
+
+emptyEEnv = EEnv Map.empty 0
+
+lookupComputed :: (Ident,Ident) -> STM EEnv (Maybe FTerm)
+lookupComputed mc = do
+  env <- readSTM
+  return $ Map.lookup mc $ computd env
+
+updateComputed :: (Ident,Ident) -> FTerm -> STM EEnv ()
+updateComputed mc t = 
+  updateSTM (\e -> e{computd = Map.insert mc t (computd e)})
+
+getTemp :: STM EEnv Ident
+getTemp = do
+  env <- readSTM
+  updateSTM (\e -> e{temp = temp e + 1})
+  return $ identC ("#" ++ show (temp env))
+
+data FTerm = 
+    FTC Term
+  | FTF (Term -> FTerm)
+
+prFTerm :: Integer -> FTerm -> String
+prFTerm i t = case t of
+  FTC t -> prt t
+  FTF f -> show i +++ "->" +++ prFTerm (i + 1) (f (EInt i))
+
+term2fterm t = case t of
+  Abs x b -> FTF (\t -> term2fterm (subst [(x,t)] b))
+  _ -> FTC t
+
+traceFTerm c ft = ft ----
+----trace ("\n" ++ prt c +++ "=" +++ take 60 (prFTerm 0 ft)) ft
+
+fterm2term :: FTerm -> STM EEnv Term
+fterm2term t = case t of
+  FTC t -> return t
+  FTF f -> do
+    x <- getTemp
+    b <- fterm2term $ f (Vr x)
+    return $ Abs x b
+
+subst g t = case t of
+  Vr x -> maybe t id $ lookup x g
+  _ -> composSafeOp (subst g) t
+
+
+appFTerm :: FTerm -> [Term] -> FTerm
+appFTerm ft ts = case (ft,ts) of
+  (FTF f, x:xs) -> appFTerm (f x) xs 
+  (FTC c, _:_) -> FTC $ foldl App c ts
+  _ -> ft
+
+apps :: Term -> (Term,[Term])
+apps t = case t of
+  App f a -> (f',xs ++ [a]) where (f',xs) = apps f
+  _ -> (t,[])
+
+appEvalConcrete gr bt env = appSTM (evalConcrete gr bt) env
+
+evalConcrete :: SourceGrammar -> BinTree Ident Info -> STM EEnv (BinTree Ident Info)
+evalConcrete gr mo = mapMTree evaldef mo where
+
+  evaldef (f,info) = case info of
+    CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> 
+       evalIn ("\nerror in linearization of function" +++ prt f +++ ":") $ 
+      do
+      pde' <- case pde of
+        Yes de -> do
+          liftM yes $ pEval ty de
+        _ -> return pde
+      --- ppr' <-  liftM yes $ evalPrintname gr c ppr pde'
+      return $ (f, CncFun mt pde' ppr) -- only cat in type actually needed
+
+    _ ->  return (f,info)
+
+  pEval (context,val) trm = do ---- errIn ("parteval" +++ prt_ trm) $ do
+    let 
+      vars  = map fst context
+      args  = map Vr vars
+      subst = [(v, Vr v) | v <- vars]
+      trm1  = mkApp trm args
+    trm3 <- recordExpand val trm1 >>= comp subst >>= recomp subst
+    return $ mkAbs vars trm3
+
+  ---- temporary hack to ascertain full evaluation, because of bug in comp
+  recomp g t = if notReady t then comp g t else return t
+  notReady = not . null . redexes
+  redexes t = case t of
+    Q _ _ -> return [()]
+    _ -> collectOp redexes t
+
+  recordExpand typ trm = case unComputed typ of
+    RecType tys -> case trm of
+      FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
+      _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
+    _ -> return trm
+
+  comp g t = case t of
+
+    Q (IC "Predef") _ -> return t ----trace ("\nPredef:\n" ++ prt t) $ return t
+
+    Q p c -> do
+      md <- lookupComputed (p,c) 
+      case md of
+        Nothing -> do
+          d  <- lookRes (p,c)
+          updateComputed (p,c) $ traceFTerm c $ term2fterm d
+          return d
+        Just d -> fterm2term d >>= comp g
+    App f a -> case apps t of
+{- ----
+      (h@(QC p c),xs) -> do
+        xs' <- mapM (comp g) xs
+        case lookupValueIndex gr ty t of 
+        Ok v -> return v
+        _ -> return t
+-}
+      (h@(Q p c),xs) | p == IC "Predef" -> do
+        xs' <- mapM (comp g) xs
+        (t',b) <- stmErr $ appPredefined (foldl App h xs')
+        if b then return t' else comp g t'
+      (h@(Q p c),xs) -> do
+        xs' <- mapM (comp g) xs
+        md <- lookupComputed (p,c) 
+        case md of
+          Just ft -> do
+            t <- fterm2term $ appFTerm ft xs'
+            comp g t
+          Nothing -> do
+            d  <- lookRes (p,c)
+            let ft = traceFTerm c $ term2fterm d
+            updateComputed (p,c) ft
+            t' <- fterm2term $ appFTerm ft xs'
+            comp g t'
+      _ -> do
+        f' <- comp g f
+        a' <- comp g a
+        case (f',a') of
+         (Abs x b,_) -> comp (ext x a' g) b
+         (QC _ _,_)  -> returnC $ App f' a'
+         (FV fs, _)  -> mapM (\c -> comp g (App c a')) fs >>= return . variants
+         (_, FV as)  -> mapM (\c -> comp g (App f' c)) as >>= return . variants
+
+         (Alias _ _ d, _) -> comp g (App d a')
+
+         (S (T i cs) e,_) -> prawitz g i (flip App a') cs e
+
+	 _ -> do
+           (t',b) <- stmErr $ appPredefined (App f' a')
+           if b then return t' else comp g t'
+
+
+    Vr x -> do
+       t' <- maybe (prtRaise (
+         "context" +++ show g +++ ": no value given to variable") x) return $ lookup x g
+       case t' of 
+         _ | t == t' -> return t
+         _ -> comp g t'
+
+    Abs x b -> do 
+       b' <- comp (ext x (Vr x) g) b
+       return $ Abs x b'
+
+    Let (x,(_,a)) b -> do
+       a' <- comp g a
+       comp (ext x a' g) b
+
+    Prod x a b -> do
+       a' <- comp g a
+       b' <- comp (ext x (Vr x) g) b
+       return $ Prod x a' b'
+
+    P t l | isLockLabel l -> return $ R [] 
+     ---- a workaround 18/2/2005: take this away and find the reason
+     ---- why earlier compilation destroys the lock field
+
+
+    P t l  -> do
+       t' <- comp g t
+       case t' of
+         FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants
+         R r   -> maybe 
+                   (prtRaise (prt t' ++ ": no value for label") l) (comp g . snd) $ 
+                    lookup l r 
+
+         ExtR a (R b) -> case lookup l b of  ----comp g (P (R b) l) of
+           Just (_,v) -> comp g v
+           _ -> comp g (P a l)
+         ExtR (R a) b -> case lookup l a of  ----comp g (P (R b) l) of
+           Just (_,v) -> comp g v
+           _ -> comp g (P b l)
+
+         S (T i cs) e -> prawitz g i (flip P l) cs e
+
+         _   -> returnC $ P t' l
+
+    S t@(T _ cc) v -> do
+       v'     <- comp g v
+       case v' of
+         FV vs -> do
+           ts' <- mapM (comp g . S t) vs
+           return $ variants ts' 
+         _ -> case matchPattern cc v' of
+           Ok (c,g') -> comp (g' ++ g) c
+           _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t 
+           _ -> do
+             t' <- comp g t
+             return $ S t' v' -- if v' is not canonical
+
+    S t v -> do
+       t'     <- comp g t
+       v'     <- comp g v
+       case t' of
+         T _ [(PV IW,c)] -> comp g c           --- an optimization
+         T _ [(PT _ (PV IW),c)] -> comp g c
+
+         T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization
+         T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
+
+         FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
+
+         V ptyp ts -> do
+           vs <- stmErr $ allParamValues gr ptyp
+           ps <- stmErr $ mapM term2patt vs
+           let cc = zip ps ts
+           case v' of
+             FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
+             _ -> case matchPattern cc v' of
+               Ok (c,g') -> comp (g' ++ g) c
+               _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t 
+               _ -> return $ S t' v' -- if v' is not canonical
+
+         T _ cc -> case v' of
+	   FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
+           _ -> case matchPattern cc v' of
+             Ok (c,g') -> comp (g' ++ g) c
+             _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t 
+             _ -> return $ S t' v' -- if v' is not canonical
+
+         Alias _ _ d -> comp g (S d v')
+
+         S (T i cs) e -> prawitz g i (flip S v') cs e
+
+	 _    -> returnC $ S t' v'
+
+     -- normalize away empty tokens
+    K "" -> return Empty
+
+    -- glue if you can
+    Glue x0 y0 -> do
+       x <- comp g x0
+       y <- comp g y0
+       case (x,y) of
+         (Alias _ _ d, y)  -> comp g $ Glue d y
+         (x, Alias _ _ d)  -> comp g $ Glue x d
+
+         (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e
+         (s, S (T i cs) e) -> prawitz g i (Glue s) cs e
+         (_,Empty)         -> return x
+         (Empty,_)         -> return y
+         (K a, K b)        -> return $ K (a ++ b)
+         (_, Alts (d,vs)) -> do
+----         (K a, Alts (d,vs)) -> do
+            let glx = Glue x
+            comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs])
+         (Alts _, ka) -> checks [do
+            y' <- stmErr $ strsFromTerm ka
+----         (Alts _, K a) -> checks [do
+            x' <- stmErr $ strsFromTerm x -- this may fail when compiling opers
+            return $ variants [
+              foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y']
+----              foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x']
+           ,return $ Glue x y
+           ]
+         (FV ks,_)         -> do
+           kys <- mapM (comp g . flip Glue y) ks
+           return $ variants kys
+         (_,FV ks)         -> do
+           xks <- mapM (comp g . Glue x) ks
+           return $ variants xks
+
+         _ -> do
+           mapM_ checkNoArgVars [x,y]
+           r <- composOp (comp g) t
+           returnC r
+
+    Alts _ -> do
+       r <- composOp (comp g) t
+       returnC r
+
+     -- remove empty
+    C a b    -> do
+       a' <- comp g a
+       b' <- comp g b
+       case (a',b') of
+         (Alts _, K a) -> checks [do
+            as <- stmErr $ strsFromTerm a' -- this may fail when compiling opers
+            return $ variants [
+              foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as]
+            ,
+            return $ C a' b'
+           ]
+         (Empty,_) -> returnC b'
+         (_,Empty) -> returnC a'
+         _     -> returnC $ C a' b'
+
+     -- reduce free variation as much as you can
+    FV ts -> mapM (comp g) ts >>= returnC . variants
+
+     -- merge record extensions if you can
+    ExtR r s -> do
+       r' <- comp g r
+       s' <- comp g s
+       case (r',s') of
+         (Alias _ _ d, _)  -> comp g $ ExtR d s'
+         (_, Alias _ _ d)  -> comp g $ Glue r' d
+
+         (R rs, R ss) -> stmErr $ plusRecord r' s'
+         (RecType rs, RecType ss) -> stmErr $ plusRecType r' s'
+
+         (_, FV ss) -> liftM FV $ mapM (comp g) [ExtR t u | u <- ss]
+
+         _ -> return $ ExtR r' s'
+
+     -- case-expand tables
+     -- if already expanded, don't expand again
+    T i@(TComp _) cs -> do
+       -- if there are no variables, don't even go inside
+       cs' <- {-if (null g) then return cs else-} mapPairsM (comp g) cs
+       return $ T i cs'
+
+     --- this means some extra work; should implement TSh directly
+    TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps]
+
+    T i cs -> do
+       pty0 <- stmErr $ getTableType i
+       ptyp <- comp g pty0
+       case allParamValues gr ptyp of
+         Ok vs -> do
+
+           cs'  <- mapM (compBranchOpt g) cs
+           sts  <- stmErr $ mapM (matchPattern cs') vs 
+           ts   <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
+           ps   <- stmErr $ mapM term2patt vs
+           let ps' = ps --- PT ptyp (head ps) : tail ps
+           return $ --- V ptyp ts -- to save space, just course of values
+                    T (TComp ptyp) (zip ps' ts)
+         _ -> do
+           cs' <- mapM (compBranch g) cs
+           return $ T i cs'  -- happens with variable types
+
+     -- otherwise go ahead
+    _ -> composOp (comp g) t >>= returnC
+
+  lookRes (p,c) = case lookupResDefKind gr p c of
+    Ok (t,_) | noExpand p -> return t
+    Ok (t,0) -> comp [] t
+    Ok (t,_) -> return t
+    Bad s -> raise s
+
+  noExpand p = errVal False $ do
+    mo <- lookupModMod gr p
+    return $ case getOptVal (iOpts (flags mo)) useOptimizer of
+      Just "noexpand" -> True
+      _ -> False
+
+  prtRaise s t = raise (s +++ prt t)
+
+  ext x a g = (x,a):g
+
+  returnC = return --- . computed
+
+  variants ts = case nub ts of
+       [t] -> t
+       ts  -> FV ts
+
+  isCan v = case v of
+       Con _    -> True
+       QC _ _   -> True
+       App f a  -> isCan f && isCan a
+       R rs     -> all (isCan . snd . snd) rs
+       _        -> False
+
+  compBranch g (p,v) = do
+       let g' = contP p ++ g
+       v' <- comp g' v
+       return (p,v')
+
+  compBranchOpt g c@(p,v) = case contP p of
+       [] -> return c
+       _ -> compBranch g c
+----       _ -> err (const (return c)) return $ compBranch g c
+
+  contP p = case p of
+       PV x -> [(x,Vr x)]
+       PC _ ps -> concatMap contP ps
+       PP _ _ ps -> concatMap contP ps
+       PT _ p -> contP p
+       PR rs -> concatMap (contP . snd) rs
+
+       PAs x p -> (x,Vr x) : contP p
+
+       PSeq p q -> concatMap contP [p,q]
+       PAlt p q -> concatMap contP [p,q]
+       PRep p   -> contP p
+       PNeg p   -> contP p
+
+       _ -> []
+
+  prawitz g i f cs e = do
+       cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
+       return $ S (T i cs') e
+
+-- | argument variables cannot be glued
+checkNoArgVars :: Term -> STM EEnv Term
+checkNoArgVars t = case t of
+  Vr (IA _)  -> raise $ glueErrorMsg $ prt t 
+  Vr (IAV _) -> raise $ glueErrorMsg $ prt t 
+  _ -> composOp checkNoArgVars t
+
+glueErrorMsg s = 
+  "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++
+  "Use Prelude.bind instead."
+
+stmErr :: Err a -> STM s a
+stmErr e = stm (\s -> do
+  v <- e
+  return (v,s)
+  )
+
+evalIn :: String -> STM s a -> STM s a
+evalIn msg st = stm $ \s -> case appSTM st s of
+  Bad e -> Bad $ msg ++++ e
+  Ok vs -> Ok vs

src-2.9/GF/Compile/Extend.hs

@@ -0,0 +1,136 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Extend
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.18 $
+--
+-- AR 14\/5\/2003 -- 11\/11
+--
+-- The top-level function 'extendModule'
+-- extends a module symbol table by indirections to the module it extends
+-----------------------------------------------------------------------------
+
+module GF.Compile.Extend (extendModule, extendMod
+	      ) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Grammar.PrGrammar
+import GF.Infra.Modules
+import GF.Compile.Update
+import GF.Grammar.Macros
+import GF.Data.Operations
+
+import Control.Monad
+
+extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
+extendModule ms (name,mod) = case mod of
+
+  ---- Just to allow inheritance in incomplete concrete (which are not
+  ---- compiled anyway), extensions are not built for them.
+  ---- Should be replaced by real control. AR 4/2/2005
+  ModMod m | mstatus m == MSIncomplete && isModCnc m -> return (name,mod)
+
+  ModMod m -> do
+    mod' <- foldM extOne m (extend m) 
+    return (name,ModMod mod') 
+ where
+   extOne mod@(Module mt st fs es ops js) (n,cond) = do
+        (m0,isCompl) <- do
+          m <- lookupModMod  (MGrammar ms) n
+
+          -- test that the module types match, and find out if the old is complete
+          testErr (sameMType (mtype m) mt) 
+                    ("illegal extension type to module" +++ prt name)
+          return (m, isCompleteModule m)
+----       return (m, if (isCompleteModule m) then True else not (isCompleteModule mod))
+
+        -- build extension in a way depending on whether the old module is complete
+        js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) js
+
+        -- if incomplete, throw away extension information
+        let me' = if isCompl then es else (filter ((/=n) . fst) es) 
+        return $ Module mt st fs me' ops js1
+
+-- | When extending a complete module: new information is inserted,
+-- and the process is interrupted if unification fails.
+-- If the extended module is incomplete, its judgements are just copied.
+extendMod :: Bool -> (Ident,Ident -> Bool) -> Ident -> 
+             BinTree Ident Info -> BinTree Ident Info -> 
+             Err (BinTree Ident Info)
+extendMod isCompl (name,cond) base old new = foldM try new $ tree2list old where
+  try t i@(c,_) | not (cond c) = return t
+  try t i@(c,_) = errIn ("constant" +++ prt c) $
+                  tryInsert (extendAnyInfo isCompl name base) indirIf t i
+  indirIf = if isCompl then indirInfo name else id
+
+indirInfo :: Ident -> Info -> Info
+indirInfo n info = AnyInd b n' where 
+  (b,n') = case info of
+    ResValue _ -> (True,n)
+    ResParam _ -> (True,n)
+    AbsFun _ (Yes EData) -> (True,n) 
+    AnyInd b k -> (b,k)
+    _ -> (False,n) ---- canonical in Abs
+
+perhIndir :: Ident -> Perh a -> Perh a
+perhIndir n p = case p of
+  Yes _ -> May n
+  _ -> p
+
+extendAnyInfo :: Bool -> Ident -> Ident -> Info -> Info -> Err Info
+extendAnyInfo isc n o i j = 
+ errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ case (i,j) of
+  (AbsCat mc1 mf1, AbsCat mc2 mf2) -> 
+    liftM2 AbsCat (updn isc n mc1 mc2) (updn isc n mf1 mf2) --- add cstrs
+  (AbsFun mt1 md1, AbsFun mt2 md2) -> 
+    liftM2 AbsFun (updn isc n mt1 mt2) (updn isc n md1 md2) --- add defs
+  (ResParam mt1, ResParam mt2) -> 
+    liftM ResParam $ updn isc n mt1 mt2
+  (ResValue mt1, ResValue mt2) -> 
+    liftM ResValue $ updn isc n mt1 mt2
+  (ResOper mt1 m1, ResOper mt2 m2) ->           ---- extendResOper n mt1 m1 mt2 m2 
+    liftM2 ResOper (updn isc n mt1 mt2) (updn isc n m1 m2)
+  (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> 
+    liftM3 CncCat (updn isc n mc1 mc2) (updn isc n mf1 mf2) (updn isc n mp1 mp2)
+  (CncFun m mt1 md1, CncFun _ mt2 md2) -> 
+    liftM2 (CncFun m) (updn isc n mt1 mt2) (updn isc n md1 md2)
+
+----  (AnyInd _ _, ResOper _ _) -> return j ----
+
+  (AnyInd b1 m1, AnyInd b2 m2) -> do
+    testErr (b1 == b2) "inconsistent indirection status"
+---- commented out as work-around for a spurious problem in
+---- TestResourceFre; should look at building of completion. 17/11/2004 
+    testErr (m1 == m2) $ 
+      "different sources of indirection: " +++ show m1 +++ show m2
+    return i
+
+  _ -> Bad $ "cannot unify information in" ++++ show i ++++ "and" ++++ show j
+
+--- where
+   
+updn isc n = if isc  then (updatePerhaps n) else (updatePerhapsHard n)
+updc isc n = if True then (updatePerhaps n) else (updatePerhapsHard n)
+
+
+
+{- ---- no more needed: this is done in Rebuild
+-- opers declared in an interface and defined in an instance are a special case
+
+extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of
+  (Nope,_) -> return $ ResOper (strip mt1) m2
+  _ -> liftM2 ResOper (updatePerhaps n mt1 mt2) (updatePerhaps n m1 m2)
+ where
+   strip (Yes t) = Yes $ strp t
+   strip m = m
+   strp t = case t of
+     Q _ c  -> Vr c
+     QC _ c -> Vr c
+     _ -> composSafeOp strp t
+-}

src-2.9/GF/Compile/Flatten.hs

@@ -0,0 +1,92 @@
+module Flatten where
+
+import Data.List
+-- import GF.Data.Operations
+
+-- (AR 15/3/2006)
+--
+-- A method for flattening grammars: create many flat rules instead of
+-- a few deep ones. This is generally better for parsins.
+-- The rules are obtained as follows:
+-- 1. write a config file tellinq which constants are variables: format 'c : C'
+-- 2. generate a list of trees with their types: format 't : T'
+-- 3. for each such tree, form a fun rule 'fun fui : X -> Y -> T' and a lin
+--    rule 'lin fui x y = t' where x:X,y:Y is the list of variables in t, as
+--    found in the config file.
+-- 4. You can go on and produce def or transfer rules similar to the lin rules
+--    except for the keyword.
+--
+-- So far this module is used outside gf. You can e.g. generate a list of
+-- trees by 'gt', write it in a file, and then in ghci call
+-- flattenGrammar <Config> <Trees> <OutFile>
+
+type Ident = String ---
+type Term  = String ---
+type Rule  = String ---
+
+type Config = [(Ident,Ident)]
+
+flattenGrammar :: FilePath -> FilePath -> FilePath -> IO ()
+flattenGrammar conff tf out = do
+  conf <- readFile conff >>= return . lines
+  ts   <- readFile tf    >>= return . lines
+  writeFile out $ mkFlatten conf ts
+
+mkFlatten :: [String] -> [String] -> String
+mkFlatten conff = unlines . concatMap getOne . zip [1..] where
+  getOne (k,t) = let (x,y) = mkRules conf ("fu" ++ show k) t in [x,y] 
+  conf = getConfig conff
+
+mkRules :: Config -> Ident -> Term -> (Rule,Rule)
+mkRules conf f t = (fun f ty, lin f (takeWhile (/=':') t)) where
+  args = mkArgs conf ts
+  ty   = concat [a ++ " -> " | a <- map snd args] ++ val
+  (ts,val) = let tt = lexTerm t in (init tt,last tt)
+---  f  = mkIdent t
+  fun c a = unwords   ["  fun", c, ":",a,";"] 
+  lin c a = unwords $ ["  lin", c] ++ map fst args ++ ["=",a,";"] 
+
+mkArgs :: Config -> [Ident] -> [(Ident,Ident)]
+mkArgs conf ids = [(x,ty) | x <- ids, Just ty <- [lookup x conf]]
+
+mkIdent :: Term -> Ident
+mkIdent = map mkChar where
+  mkChar c = case c of
+   '(' -> '6'
+   ')' -> '9'
+   ' ' -> '_'
+   _   -> c
+
+-- to get just the identifiers
+lexTerm :: String -> [String]
+lexTerm ss = case lex ss of
+  [([c],ws)] | isSpec c ->     lexTerm ws
+  [(w@(_:_),ws)]        -> w : lexTerm ws
+  _ -> []
+ where
+   isSpec = flip elem "();:"
+
+
+getConfig :: [String] -> Config
+getConfig = map getOne . filter (not . null) where
+  getOne line = case lexTerm line of
+    v:c:_ -> (v,c)
+
+ex = putStrLn fs where
+  fs = 
+    mkFlatten
+      ["man_N : N", 
+       "sleep_V : V"
+      ] 
+      ["PredVP (DefSg man_N) (UseV sleep_V) : Cl",
+       "PredVP (DefPl man_N) (UseV sleep_V) : Cl"
+      ]
+
+{-
+-- result of ex
+  
+  fun fu1 : N -> V -> Cl ;
+  lin fu1 man_N sleep_V = PredVP (DefSg man_N) (UseV sleep_V)  ;
+  fun fu2 : N -> V -> Cl ;
+  lin fu2 man_N sleep_V = PredVP (DefPl man_N) (UseV sleep_V)  ;
+-}

src-2.9/GF/Compile/GetGrammar.hs

@@ -0,0 +1,146 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GetGrammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/15 17:56:13 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.16 $
+--
+-- this module builds the internal GF grammar that is sent to the type checker
+-----------------------------------------------------------------------------
+
+module GF.Compile.GetGrammar (
+  getSourceModule, getSourceGrammar,
+  getOldGrammar, getCFGrammar, getEBNFGrammar
+		  ) where
+
+import GF.Data.Operations
+import qualified GF.Source.ErrM as E
+
+import GF.Infra.UseIO
+import GF.Grammar.Grammar
+import GF.Infra.Modules
+import GF.Grammar.PrGrammar
+import qualified GF.Source.AbsGF as A
+import GF.Source.SourceToGrammar
+---- import Macros
+---- import Rename
+import GF.Text.UTF8 ----
+import GF.Infra.Option
+--- import Custom
+import GF.Source.ParGF
+import qualified GF.Source.LexGF as L
+
+import GF.CF.CF (rules2CF)
+import GF.CF.PPrCF
+import GF.CF.CFtoGrammar
+import GF.CF.EBNF
+
+import GF.Infra.ReadFiles ----
+
+import Data.Char (toUpper)
+import Data.List (nub)
+import qualified Data.ByteString.Char8 as BS
+import Control.Monad (foldM)
+import System (system)
+import System.FilePath
+
+getSourceModule :: Options -> FilePath -> IOE SourceModule
+getSourceModule opts file0 = do
+  file <- case getOptVal opts usePreprocessor of
+    Just p -> do
+      let tmp = "_gf_preproc.tmp"
+          cmd = p +++ file0 ++ ">" ++ tmp
+      ioeIO $ system cmd
+      -- ioeIO $ putStrLn $ "preproc" +++ cmd
+      return tmp
+    _ -> return file0
+  string0    <- readFileIOE file
+  let string = case getOptVal opts uniCoding of
+        Just "utf8" -> decodeUTF8 string0
+        _ -> string0
+  let tokens = myLexer (BS.pack string)
+  mo1  <- ioeErr $ pModDef tokens
+  ioeErr $ transModDef mo1
+
+getSourceGrammar :: Options -> FilePath -> IOE SourceGrammar
+getSourceGrammar opts file = do
+  string    <- readFileIOE file
+  let tokens = myLexer (BS.pack string)
+  gr1  <- ioeErr $ pGrammar tokens
+  ioeErr $ transGrammar gr1
+
+
+-- for old GF format with includes
+
+getOldGrammar :: Options -> FilePath -> IOE SourceGrammar
+getOldGrammar opts file = do
+  defs <- parseOldGrammarFiles file
+  let g = A.OldGr A.NoIncl defs
+  let name = takeFileName file
+  ioeErr $ transOldGrammar opts name g
+
+parseOldGrammarFiles :: FilePath -> IOE [A.TopDef]
+parseOldGrammarFiles file = do
+   putStrLnE $ "reading grammar of old format" +++ file
+   (_, g) <- getImports "" ([],[]) file
+   return g  -- now we can throw away includes
+  where 
+   getImports oldInitPath (oldImps, oldG) f = do
+     (path,s) <- readFileLibraryIOE oldInitPath f
+     if not (elem path oldImps) 
+       then do
+         (imps,g) <- parseOldGrammar path
+         foldM (getImports (initFilePath path)) (path : oldImps, g ++ oldG) imps
+       else 
+         return (oldImps, oldG)
+
+parseOldGrammar :: FilePath -> IOE ([FilePath],[A.TopDef])
+parseOldGrammar file = do
+  putStrLnE $ "reading old file" +++ file
+  s <- ioeIO $ readFileIf file
+  A.OldGr incl topdefs <- ioeErr $ pOldGrammar $ oldLexer $ fixNewlines s
+  includes <- ioeErr $ transInclude incl
+  return (includes, topdefs)
+
+----
+
+-- | To resolve the new reserved words: 
+-- change them by turning the final letter to upper case.
+--- There is a risk of clash. 
+oldLexer :: String -> [L.Token]
+oldLexer = map change . L.tokens . BS.pack where
+  change t = case t of
+    (L.PT p (L.TS s)) | elem s newReservedWords -> 
+        (L.PT p (L.TV (init s ++ [toUpper (last s)])))
+    _ -> t
+
+getCFGrammar :: Options -> FilePath -> IOE SourceGrammar
+getCFGrammar opts file = do
+  let mo = takeWhile (/='.') file
+  s    <- ioeIO  $ readFileIf file
+  let files = case words (concat (take 1 (lines s))) of
+        "--":"include":fs -> fs
+        _ -> []
+  ss   <- ioeIO  $ mapM readFileIf files
+  cfs  <- ioeErr $ mapM (pCF mo) $ s:ss
+  defs <- return $ cf2grammar $ rules2CF $ concat cfs
+  let g = A.OldGr A.NoIncl defs
+---  let ma = justModuleName file
+---  let mc = 'C':ma ---
+---  let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts
+  ioeErr $ transOldGrammar opts file g
+
+getEBNFGrammar :: Options -> FilePath -> IOE SourceGrammar
+getEBNFGrammar opts file = do
+  let mo = takeWhile (/='.') file
+  s    <- ioeIO $ readFileIf file
+  defs <- ioeErr $ pEBNFasGrammar s
+  let g = A.OldGr A.NoIncl defs
+---  let ma = justModuleName file
+---  let mc = 'C':ma ---
+---  let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts
+  ioeErr $ transOldGrammar opts file g

src-2.9/GF/Compile/GrammarToCanon.hs

@@ -0,0 +1,293 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GrammarToCanon
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 23:24:33 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.23 $
+--
+-- Code generator from optimized GF source code to GFC.
+-----------------------------------------------------------------------------
+
+module GF.Compile.GrammarToCanon (showGFC,
+		       redModInfo, redQIdent
+		      ) where
+
+import GF.Data.Operations
+import GF.Data.Zipper
+import GF.Infra.Option
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Grammar.PrGrammar
+import GF.Infra.Modules
+import GF.Grammar.Macros
+import qualified GF.Canon.AbsGFC as G
+import qualified GF.Canon.GFC as C
+import GF.Canon.MkGFC
+---- import Alias
+import qualified GF.Canon.PrintGFC as P
+
+import Control.Monad
+import Data.List (nub,sortBy)
+
+-- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003
+
+-- | This is the top-level function printing a gfc file
+showGFC :: SourceGrammar -> String
+showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar
+
+-- | any grammar, first trying without dependent types
+-- abstract syntax without dependent types
+redGrammar :: SourceGrammar -> Err C.CanonGrammar
+redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo $ filter active gr where
+  active (_,m) = case typeOfModule m of
+    MTInterface -> False
+    _ -> True
+
+redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo)
+redModInfo (c,info) = do
+  c'    <- redIdent c
+  info' <- case info of
+    ModMod m -> do
+      let isIncompl = not $ isCompleteModule m
+      (e,os) <- if isIncompl then return ([],[]) else redExtOpen m ----
+      flags <- mapM redFlag $ flags m 
+      (a,mt0) <- case mtype m of
+         MTConcrete a -> do
+           a' <- redIdent a
+           return (a', MTConcrete a') 
+         MTAbstract -> return (c',MTAbstract) --- c' not needed
+         MTResource -> return (c',MTResource) --- c' not needed
+         MTInterface -> return (c',MTResource) ---- not needed
+         MTInstance _ -> return (c',MTResource) --- c' not needed
+         MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed
+
+      --- this generates empty GFC reosurce for interface and incomplete
+      let js = if isIncompl then emptyBinTree else jments m
+          mt = mt0 ---- if isIncompl then MTResource else mt0
+
+      defss <- mapM (redInfo a) $ tree2list $ js
+      let defs0 = concat defss
+      let lgh = length defs0
+      defs  <- return $ sorted2tree $ defs0  -- sorted, but reduced
+      let flags1 = if isIncompl then C.flagIncomplete : flags else flags
+      let flags' = G.Flg (identC "modulesize") (identC ("n"++show lgh)) : flags1
+      return $ ModMod $ Module mt MSComplete flags' e os defs
+  return (c',info')
+ where
+   redExtOpen m = do
+     e' <- case extends m of
+       es -> mapM (liftM inheritAll . redIdent) es
+     os' <- mapM (\o -> case o of 
+              OQualif q _ i -> liftM (OSimple q) (redIdent i)
+              _ -> prtBad "cannot translate unqualified open in" c) $ opens m
+     return (e',nub os')
+   om = oSimple . openedModule --- normalizing away qualif
+
+redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)]
+redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
+  c' <- redIdent c 
+  case info of
+    AbsCat (Yes cont) pfs -> do
+      let fs = case pfs of
+                 Yes ts -> [(m,c) | Q m c <- ts]
+                 _ -> []
+      returns c' $ C.AbsCat cont fs
+    AbsFun (Yes typ) pdf -> do
+      let df = case pdf of
+                 Yes t -> t  -- definition or "data"
+                 _ -> Eqs [] -- primitive notion
+      returns c' $ C.AbsFun typ df
+    AbsTrans t -> 
+      returns c' $ C.AbsTrans t
+
+    ResParam (Yes (ps,_)) -> do
+      ps' <- mapM redParam ps
+      returns c' $ C.ResPar ps'
+
+    CncCat pty ptr ppr -> case (pty,ptr,ppr) of
+      (Yes ty, Yes (Abs _ t), Yes pr) -> do
+        ty'  <- redCType ty
+        trm' <- redCTerm t
+        pr'  <- redCTerm pr 
+        return [(c', C.CncCat ty' trm' pr')]
+      _ -> prtBad ("cannot reduce rule for") c
+      
+    CncFun mt ptr ppr -> case (mt,ptr,ppr) of
+      (Just (cat,_), Yes trm, Yes pr) -> do
+        cat' <- redIdent cat
+        (xx,body,_) <- termForm trm
+        xx'   <- mapM redArgvar xx
+        body' <- errIn (prt body) $ redCTerm body ---- debug
+        pr'   <- redCTerm pr 
+        return [(c',C.CncFun (G.CIQ am cat') xx' body' pr')]
+      _ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug
+
+    AnyInd s b -> do
+      b' <- redIdent b
+      returns c' $ C.AnyInd s b'
+
+    _ -> return [] --- retain some operations
+ where
+   returns f i = return [(f,i)]
+
+redQIdent :: QIdent -> Err G.CIdent
+redQIdent (m,c) = return $ G.CIQ m c
+
+redIdent :: Ident -> Err Ident
+redIdent x 
+  | isWildIdent x = return $ identC "h_" --- needed in declarations
+  | otherwise = return $ identC $ prt x ---
+
+redFlag :: Option -> Err G.Flag
+redFlag (Opt (f,[x])) = return $ G.Flg (identC f) (identC x)
+redFlag o = Bad $ "cannot reduce option" +++ prOpt o
+
+redDecl :: Decl -> Err G.Decl
+redDecl (x,a) = liftM2 G.Decl (redIdent x) (redType a)
+
+redType :: Type -> Err G.Exp
+redType = redTerm
+
+redTerm :: Type -> Err G.Exp
+redTerm t = return $ rtExp t
+
+-- to normalize records and record types
+sortByFst :: Ord a => [(a,b)] -> [(a,b)]
+sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
+
+-- resource
+
+redParam :: Param -> Err G.ParDef
+redParam (c,cont) = do
+  c'    <- redIdent c
+  cont' <- mapM (redCType . snd) cont
+  return $ G.ParD c' cont'
+
+redArgvar :: Ident -> Err G.ArgVar
+redArgvar x = case x of
+  IA (x,i)     -> return $ G.A  (identC x) (toInteger i)
+  IAV (x,b,i) -> return $ G.AB (identC x) (toInteger b) (toInteger i)
+  _ -> Bad $ "cannot reduce" +++ show x +++ "as argument variable"
+
+redLindef :: Term -> Err G.Term
+redLindef t = case t of
+  Abs x b -> redCTerm b ---
+  _ -> redCTerm t
+
+redCType :: Type -> Err G.CType
+redCType t = case t of
+  RecType lbs -> do
+    let (ls,ts) = unzip lbs
+        ls' = map redLabel ls
+    ts' <- mapM redCType ts
+    return $ G.RecType $ map (uncurry G.Lbg) $ sortByFst $ zip ls' ts'
+  Table p v  -> liftM2 G.Table (redCType p) (redCType v)
+  Q m c    -> liftM G.Cn $ redQIdent (m,c)
+  QC m c   -> liftM G.Cn $ redQIdent (m,c)
+
+  App (Q (IC "Predef") (IC "Ints")) (EInt n) -> return $ G.TInts (toInteger n)
+
+  Sort "Str" -> return $ G.TStr
+  Sort "Tok" -> return $ G.TStr
+  _ -> prtBad "cannot reduce to canonical the type" t
+
+redCTerm :: Term -> Err G.Term
+redCTerm t = case t of
+  Vr x -> checkAgain 
+            (liftM G.Arg $ redArgvar x) 
+            (liftM G.LI  $ redIdent x) --- for parametrize optimization
+  App _ s -> do  -- only constructor applications can remain
+    (_,c,xx) <- termForm t
+    xx' <- mapM redCTerm xx
+    case c of
+      QC p c -> liftM2 G.Par (redQIdent (p,c)) (return xx')
+      Q (IC "Predef") (IC "error") -> fail $ "error: " ++ stringFromTerm s
+      _ -> prtBad "expected constructor head instead of" c
+  Q p c  -> liftM G.I (redQIdent (p,c))
+  QC p c -> liftM2 G.Par (redQIdent (p,c)) (return [])
+  R rs     -> do
+    let (ls,tts) = unzip rs
+        ls' = map redLabel ls
+    ts <- mapM (redCTerm . snd) tts
+    return $ G.R $ map (uncurry G.Ass) $ sortByFst $ zip ls' ts
+  RecType [] -> return $ G.R [] --- comes out in parsing
+  P tr l -> do
+    tr' <- redCTerm tr
+    return $ G.P tr' (redLabel l)
+  PI tr l _ -> redCTerm $ P tr l -----
+  T i cs     -> do
+    ty  <- getTableType i
+    ty' <- redCType ty
+    let (ps,ts) = unzip cs
+    ps' <- mapM redPatt ps
+    ts' <- mapM redCTerm ts
+    return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts'
+  TSh i cs -> do
+    ty  <- getTableType i
+    ty' <- redCType ty
+    let (pss,ts) = unzip cs
+    pss' <- mapM (mapM redPatt) pss
+    ts' <- mapM redCTerm ts
+    return $ G.T ty' $ map (uncurry G.Cas) $ zip pss' ts'
+  V ty ts     -> do
+    ty' <- redCType ty
+    ts' <- mapM redCTerm ts
+    return $ G.V ty' ts'
+  S u v -> liftM2 G.S (redCTerm u) (redCTerm v)
+  K s   -> return $ G.K (G.KS s)
+  EInt i -> return $ G.EInt i
+  EFloat i -> return $ G.EFloat i
+  C u v -> liftM2 G.C (redCTerm u) (redCTerm v)
+  FV ts -> liftM G.FV $ mapM redCTerm ts
+---  Ready ss -> return $ G.Ready [redStr ss] --- obsolete
+
+  Alts (d,vs) -> do ---
+    d'  <- redCTermTok d
+    vs' <- mapM redVariant vs
+    return $ G.K $ G.KP d' vs'
+
+  Empty -> return $ G.E
+
+---  Strs ss -> return $ G.Strs [s | K s <- ss] ---
+
+---- Glue obsolete in canon, should not occur here
+  Glue x y -> redCTerm (C x y)
+
+  _ -> Bad ("cannot reduce term" +++ prt t)
+
+redPatt :: Patt -> Err G.Patt
+redPatt p = case p of
+  PP m c ps -> liftM2 G.PC (redQIdent (m,c)) (mapM redPatt ps) 
+  PR rs -> do
+    let (ls,tts) = unzip rs
+        ls' = map redLabel ls
+    ts <- mapM redPatt tts
+    return $ G.PR $  map (uncurry G.PAss) $ sortByFst $ zip ls' ts
+  PT _ q -> redPatt q
+  PInt i -> return $ G.PI i
+  PFloat i -> return $ G.PF i
+  PV x -> liftM G.PV $ redIdent x --- for parametrize optimization
+  _ -> prtBad "cannot reduce pattern" p
+
+redLabel :: Label -> G.Label
+redLabel (LIdent s) = G.L $ identC s
+redLabel (LVar i)   = G.LV $ toInteger i
+
+redVariant :: (Term, Term) -> Err G.Variant
+redVariant (v,c) = do
+  v' <- redCTermTok v
+  c' <- redCTermTok c
+  return $ G.Var v' c'
+
+redCTermTok :: Term -> Err [String]
+redCTermTok t = case t of
+  K s   -> return [s]
+  Empty -> return []
+  C a b -> liftM2 (++) (redCTermTok a) (redCTermTok b)
+  Strs ss -> return [s | K s <- ss] ---
+  _ -> prtBad "cannot get strings from term" t
+

src-2.9/GF/Compile/MkConcrete.hs

@@ -0,0 +1,154 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MkConcrete
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 
+-- > CVS $Author: 
+-- > CVS $Revision: 
+--
+-- Compile a gfe file into a concrete syntax by using the parser on a resource grammar.
+-----------------------------------------------------------------------------
+
+module GF.Compile.MkConcrete (mkConcretes) where
+
+import GF.Grammar.Values (Tree,tree2exp)
+import GF.Grammar.PrGrammar (prt_,prModule)
+import GF.Grammar.Grammar --- (Term(..),SourceModule)
+import GF.Grammar.Macros (composSafeOp, composOp, record2subst, zIdent)
+import GF.Compile.ShellState --(firstStateGrammar,stateGrammarWords)
+import GF.Compile.PGrammar (pTerm,pTrm)
+import GF.Compile.Compile
+import GF.Compile.PrOld (stripTerm)
+import GF.Compile.GetGrammar
+import GF.API
+import GF.API.IOGrammar
+import qualified GF.Embed.EmbedAPI as EA
+
+import GF.Data.Operations
+import GF.Infra.UseIO
+import GF.Infra.Option
+import GF.Infra.Modules
+import GF.Infra.ReadFiles
+import GF.System.Arch
+import GF.UseGrammar.Treebank
+
+import System.Directory
+import System.FilePath
+import Data.Char
+import Control.Monad
+import Data.List
+
+-- translate strings into lin rules by parsing in a resource
+-- grammar. AR 2/6/2005
+
+-- Format of rule (on one line):
+--    lin F x y = in C "ssss" ;
+-- Format of resource path (on first line):
+--    --# -resource=PATH
+-- Other lines are copied verbatim.
+-- A sequence of files can be processed with the same resource without
+-- rebuilding the grammar and parser.
+
+-- notice: we use a hand-crafted lexer and parser in order to preserve
+-- the layout and comments in the rest of the file.
+
+mkConcretes :: Options -> [FilePath] -> IO ()
+mkConcretes opts files = do
+  ress <- mapM getResPath files
+  let grps = groupBy (\a b -> fst a == fst b) $ 
+               sortBy (\a b -> compare (fst a) (fst b)) $ zip ress files
+  mapM_ (mkCncGroups opts) [(rp,map snd gs) | gs@((rp,_):_) <- grps]
+
+mkCncGroups opts0 ((res,path),files) = do
+  putStrLnFlush $ "Going to preprocess examples in " ++ unwords files
+  putStrLn $ "Compiling resource " ++ res
+  let opts = addOptions (options [beSilent,pathList path]) opts0
+  let treebank = oElem (iOpt "treebank") opts
+  resf <- useIOE res $ do
+    (fp,_) <- readFileLibraryIOE "" res
+    return fp
+  egr <- appIOE $ shellStateFromFiles opts emptyShellState resf
+  (parser,morpho) <- if treebank then do
+      tb <- err (\_ -> error $ "no treebank of name" +++ path)
+                return
+                (egr >>= flip findTreebank (zIdent path))
+      return (\_ -> flip (,) "Not in treebank" . map pTrm . lookupTreebank tb,
+              isWordInTreebank tb)
+    else do
+      gr  <- err (\s -> putStrLn s >> error "resource grammar rejected") 
+                 (return . firstStateGrammar) egr
+      return 
+            (\cat s -> 
+                errVal ([],"No parse") $ 
+                optParseArgErrMsg (options [newFParser, firstCat cat, beVerbose]) gr s >>=
+                (\ (ts,e) -> return (map tree2exp ts, e)) , 
+            isKnownWord gr)
+  putStrLn "Building parser"
+  mapM_ (mkConcrete parser morpho) files
+
+type Parser = String -> String -> ([Term],String)
+type Morpho = String -> Bool 
+
+getResPath :: FilePath -> IO (String,String)
+getResPath file = do
+  s <- liftM lines $ readFileIf file
+  case filter (not . all isSpace) s of
+    res:path:_ | is "resource" res && is "path"     path -> return (val res, val path)
+    res:path:_ | is "resource" res && is "treebank" path -> return (val res, val path)
+    res:_ | is "resource" res -> return (val res, "")
+    _ -> error 
+           "expected --# -resource=FILE and optional --# -path=PATH or --# -treebank=IDENT"
+ where
+   val = dropWhile (isSpace) . tail . dropWhile (not . (=='='))
+   is tag s = case words s of
+     "--#":w:_ -> isPrefixOf ('-':tag) w
+     _ -> False 
+
+
+mkConcrete :: Parser -> Morpho -> FilePath -> IO ()
+mkConcrete parser morpho file = do
+  src <- appIOE (getSourceModule noOptions file) >>= err error return
+  let (src',msgs) = mkModule parser morpho src
+  let out = addExtension (justModuleName file) "gf"
+  writeFile out $ "-- File generated by GF from " ++ file
+  appendFile out "\n"
+  appendFile out (prModule src')
+  appendFile out "{-\n"
+  appendFile out $ unlines $ filter (not . null) msgs
+  appendFile out "-}\n"
+
+mkModule :: Parser -> Morpho -> SourceModule -> (SourceModule,[String])
+mkModule parser morpho (name,src) = case src of 
+  ModMod m@(Module mt st fs me ops js) ->
+
+    let js1 = jments m
+        (js2,msgs) = err error id $ appSTM (mapMTree mkInfo js1) []
+        mod2 = ModMod $ Module mt st fs me ops $ js2
+    in ((name,mod2), msgs)
+ where
+  mkInfo ni@(name,info) = case info of
+    CncFun mt (Yes trm) ppr -> do
+      trm' <- mkTrm trm
+      return (name, CncFun mt (Yes trm') ppr) 
+    _ -> return ni
+   where
+     mkTrm t = case t of
+       Example (P _ cat) s -> parse cat s t
+       Example (Vr  cat) s -> parse cat s t
+       _ -> composOp mkTrm t
+     parse cat s t = case parser (prt_ cat) s of
+       (tr:[], _) -> do
+         updateSTM ((("PARSED in" +++ prt_ name) : s : [prt_ tr]) ++)
+         return $ stripTerm tr
+       (tr:trs,_) -> do
+         updateSTM ((("AMBIGUOUS in" +++ prt_ name) : s : map prt_ trs) ++)
+         return $ stripTerm tr
+       ([],ms) -> do
+         updateSTM ((("NO PARSE in" +++ prt_ name) : s : ms : [morph s]) ++)
+         return t
+  morph s = case [w | w <- words s, not (morpho w)] of
+    [] -> ""
+    ws -> "unknown words: " ++ unwords ws

src-2.9/GF/Compile/MkResource.hs

@@ -0,0 +1,128 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MkResource
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.14 $
+--
+-- Compile a gfc module into a "reuse" gfr resource, interface, or instance.
+-----------------------------------------------------------------------------
+
+module GF.Compile.MkResource (makeReuse) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.Macros
+import GF.Grammar.Lockfield
+import GF.Grammar.PrGrammar
+
+import GF.Data.Operations
+
+import Control.Monad
+
+-- | extracting resource r from abstract + concrete syntax.
+-- AR 21\/8\/2002 -- 22\/6\/2003 for GF with modules
+makeReuse :: SourceGrammar -> Ident -> [(Ident,MInclude Ident)] -> 
+             MReuseType Ident -> Err SourceRes
+makeReuse gr r me mrc = do
+  flags <- return [] --- no flags are passed: they would not make sense
+  case mrc of
+    MRResource c -> do
+      (ops,jms) <- mkFull True c
+      return $ Module MTResource MSComplete flags me ops jms
+
+    MRInstance c a -> do
+      (ops,jms) <- mkFull False c
+      return $ Module (MTInstance a) MSComplete flags me ops jms
+
+    MRInterface c -> do
+      mc <- lookupModule gr c
+
+      (ops,jms) <- case mc of 
+        ModMod m -> case mtype m of
+          MTAbstract -> liftM ((,) (opens m)) $ 
+                          mkResDefs True False gr r c me 
+                            (extend m) (jments m) emptyBinTree
+          _ -> prtBad "expected abstract to be the type of" c
+        _ -> prtBad "expected abstract to be the type of" c
+
+      return $ Module MTInterface MSIncomplete flags me ops jms
+
+ where
+    mkFull hasT c = do
+      mc <- lookupModule gr c
+
+      case mc of 
+        ModMod m -> case mtype m of
+          MTConcrete a -> do
+            ma <- lookupModule gr a
+            jmsA <- case ma of 
+               ModMod m' -> return $ jments m'
+               _ -> prtBad "expected abstract to be the type of" a
+            liftM ((,) (opens m)) $ 
+               mkResDefs hasT True gr r a me (extend m) jmsA (jments m)
+          _ -> prtBad "expected concrete to be the type of" c
+        _ -> prtBad "expected concrete to be the type of" c
+
+
+-- | the first  Boolean indicates if the type needs be given
+-- the second Boolean indicates if the definition needs be given
+mkResDefs :: Bool -> Bool -> 
+             SourceGrammar -> Ident -> Ident -> 
+             [(Ident,MInclude Ident)] -> [(Ident,MInclude Ident)] -> 
+             BinTree Ident Info -> BinTree Ident Info -> 
+             Err (BinTree Ident Info)
+mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where
+
+  ifTyped  = yes --- if hasT then yes else const nope --- needed for TC
+  ifCompl  = if isC  then yes else const nope
+  doIf b t = if b then t else return typeType -- latter value not used
+
+  mkOne a mae (f,info) = case info of
+      AbsCat _ _ -> do
+        typ  <- doIf isC $ err (const (return defLinType)) return $ look cnc f
+        typ' <- doIf isC $ lockRecType f typ 
+        return (f, ResOper (ifTyped typeType) (ifCompl typ'))
+      AbsFun (Yes typ0) _ -> do
+        trm <- doIf isC $ look cnc f
+        testErr (not (isHardType typ0)) 
+                ("cannot build reuse for function" +++ prt f +++ ":" +++ prt typ0)
+        typ <- redirTyp True a mae typ0
+        cat <- valCat typ
+        trm' <- doIf isC $ unlockRecord (snd cat) trm 
+        return (f, ResOper (ifTyped typ) (ifCompl trm'))
+      AnyInd b n -> do
+        mo    <- lookupModMod gr n
+        info' <- lookupInfo mo f
+        mkOne n (extend mo) (f,info')
+
+  look cnc f = do
+     info <- lookupTree prt f cnc
+     case info of
+       CncCat (Yes ty) _ _ -> return ty
+       CncCat _ _ _        -> return defLinType
+       CncFun _ (Yes tr) _ -> return tr
+       AnyInd _ n -> do 
+         mo    <- lookupModMod gr n
+         t <- look (jments mo) f
+         redirTyp False n (extend mo) t
+       _ -> prtBad "not enough information to reuse" f
+
+  -- type constant qualifications changed from abstract to resource
+  redirTyp always a mae ty = case ty of
+    Q _ c | always -> return $ Q r c
+    Q n c | n == a || [n] == map fst mae -> return $ Q r c ---- FIX for non-singleton exts
+    _ -> composOp (redirTyp always a mae) ty
+
+-- | no reuse for functions of HO\/dep types
+isHardType t = case t of
+  Prod x a b -> not (isWild x) || isHardType a || isHardType b
+  App _ _    -> True
+  _          -> False  
+ where 
+   isWild x = isWildIdent x || prt x == "h_" --- produced by transl from canon

src-2.9/GF/Compile/MkUnion.hs

@@ -0,0 +1,83 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MkUnion
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:39 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.7 $
+--
+-- building union of modules.
+-- AR 1\/3\/2004 --- OBSOLETE 15\/9\/2004 with multiple inheritance
+-----------------------------------------------------------------------------
+
+module GF.Compile.MkUnion (makeUnion) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.Macros
+import GF.Grammar.PrGrammar
+
+import GF.Data.Operations
+import GF.Infra.Option
+
+import Data.List
+import Control.Monad
+
+makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] ->
+             Err SourceModule
+makeUnion gr m ty imps = do
+  ms    <- mapM (lookupModMod gr . fst) imps
+  typ   <- return ty ---- getTyp ms
+  ext   <- getExt [i | Just i <- map extends ms]
+  ops   <- return $ nub $ concatMap opens ms
+  flags <- return $ concatMap flags ms
+  js    <- liftM (buildTree . concat) $ mapM getJments imps
+  return $ (m, ModMod (Module typ MSComplete flags ext ops js))
+
+ where
+   getExt es = case es of
+     [] -> return Nothing
+     i:is -> if all (==i) is then return (Just i) 
+               else Bad "different extended modules in union forbidden"
+   getJments (i,fs) = do
+     m  <- lookupModMod gr i
+     let js = jments m
+     if null fs 
+       then 
+         return (map (unqual i) $ tree2list js) 
+       else do
+         ds <- mapM (flip justLookupTree js) fs
+         return $ map (unqual i) $ zip fs ds
+
+   unqual i (f,d) = curry id f $ case d of
+     AbsCat  pty pts -> AbsCat (qualCo pty) (qualPs pts)
+     AbsFun  pty pt -> AbsFun (qualP pty) (qualP pt)
+     AbsTrans t     -> AbsTrans $ qual t
+     ResOper pty pt -> ResOper (qualP pty) (qualP pt)
+     CncCat  pty pt pp -> CncCat (qualP pty) (qualP pt) (qualP pp)
+     CncFun  mp pt pp -> CncFun (qualLin mp) (qualP pt) (qualP pp) ---- mp
+     ResParam (Yes ps) -> ResParam (yes (map qualParam ps)) 
+     ResValue pty ->  ResValue (qualP pty)
+     _ -> d
+    where
+     qualP pt = case pt of
+       Yes t -> yes $ qual t
+       _ -> pt
+     qualPs pt = case pt of
+       Yes ts -> yes $ map qual ts
+       _ -> pt
+     qualCo pco = case pco of
+       Yes co -> yes $ [(x,qual t) | (x,t) <- co]
+       _ -> pco
+     qual t = case t of
+       Q m c  | m==i -> Cn c
+       QC m c | m==i -> Cn c
+       _ -> composSafeOp qual t
+     qualParam (p,co) = (p,[(x,qual t) | (x,t) <- co])
+     qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t)))
+     qualLin Nothing = Nothing
+     

src-2.9/GF/Compile/ModDeps.hs

@@ -0,0 +1,153 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ModDeps
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 23:24:34 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.14 $
+--
+-- Check correctness of module dependencies. Incomplete.
+--
+-- AR 13\/5\/2003
+-----------------------------------------------------------------------------
+
+module GF.Compile.ModDeps (mkSourceGrammar,
+		moduleDeps,
+		openInterfaces,
+		requiredCanModules
+	       ) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Grammar.PrGrammar
+import GF.Compile.Update
+import GF.Grammar.Lookup
+import GF.Infra.Modules
+
+import GF.Data.Operations
+
+import Control.Monad
+import Data.List
+
+-- | to check uniqueness of module names and import names, the
+-- appropriateness of import and extend types,
+-- to build a dependency graph of modules, and to sort them topologically
+mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar
+mkSourceGrammar ms = do
+  let ns = map fst ms
+  checkUniqueErr ns
+  mapM (checkUniqueImportNames ns . snd) ms
+  deps    <- moduleDeps ms
+  deplist <- either 
+               return 
+               (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ 
+               topoTest deps
+  return $ MGrammar [(m, maybe undefined id $ lookup m ms)  | IdentM m _ <- deplist]
+
+checkUniqueErr ::  (Show i, Eq i) => [i] -> Err ()
+checkUniqueErr ms = do
+  let msg = checkUnique ms
+  if null msg then return () else Bad $ unlines msg
+
+-- | check that import names don't clash with module names
+checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
+checkUniqueImportNames ns mo = case mo of
+  ModMod m -> test [n | OQualif _ n v <- opens m, n /= v]
+  _ -> return () --- Bad $ "bug: ModDeps does not treat" +++ show mo
+ where
+
+  test ms = testErr (all (`notElem` ns) ms)
+                    ("import names clashing with module names among" +++ 
+                       unwords (map prt ms))
+
+type Dependencies = [(IdentM Ident,[IdentM Ident])]
+
+-- | to decide what modules immediately depend on what, and check if the
+-- dependencies are appropriate
+moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies
+moduleDeps ms = mapM deps ms where
+  deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of
+    ModMod m -> case mtype m of
+      MTConcrete a -> do
+        aty <- lookupModuleType gr a
+        testErr (aty == MTAbstract) "the of-module is not an abstract syntax" 
+        chDep (IdentM c (MTConcrete a)) 
+              (extends m) (MTConcrete a) (opens m) MTResource
+      t -> chDep (IdentM c t) (extends m) t (opens m) t
+
+  chDep it es ety os oty = do
+    ests <- mapM (lookupModuleType gr) es
+    testErr (all (compatMType ety) ests) "inappropriate extension module type" 
+----    osts <- mapM (lookupModuleType gr . openedModule) os
+----    testErr (all (compatOType oty) osts) "inappropriate open module type"
+    let ab = case it of
+               IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
+               _ -> [] ---- 
+    return (it, ab ++
+                [IdentM e ety | e <- es] ++ 
+                [IdentM (openedModule o) oty | o <- os])
+
+  -- check for superficial compatibility, not submodule relation etc: what can be extended
+  compatMType mt0 mt = case (mt0,mt) of
+    (MTResource,   MTConcrete _) -> True
+    (MTInstance _, MTConcrete _) -> True
+    (MTInterface,  MTAbstract)   -> True
+    (MTConcrete _, MTConcrete _) -> True
+    (MTInstance _, MTInstance _) -> True
+    (MTReuse _, MTReuse _) -> True
+    (MTInstance _, MTResource) -> True
+    (MTResource, MTInstance _) -> True
+    ---- some more?
+    _ -> mt0 == mt
+  -- in the same way; this defines what can be opened
+  compatOType mt0 mt = case mt0 of
+    MTAbstract     -> mt == MTAbstract
+    MTTransfer _ _ -> mt == MTAbstract
+    _ -> case mt of
+      MTResource -> True
+      MTReuse _ -> True
+      MTInterface -> True
+      MTInstance _ -> True
+      _ -> False      
+
+  gr = MGrammar ms --- hack
+
+openInterfaces :: Dependencies -> Ident -> Err [Ident]
+openInterfaces ds m = do
+  let deps = [(i,ds) | (IdentM i _,ds) <- ds]
+  let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is]
+  let mods = iterFix (concatMap more) (more (m,undefined))
+  return $ [i | (i,MTInterface) <- mods]
+
+-- | this function finds out what modules are really needed in the canonical gr.
+-- its argument is typically a concrete module name
+requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i f a -> i -> [i]
+requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
+  exts = allExtends gr c
+  ops  = if isSingle 
+         then map fst (modules gr) 
+         else iterFix (concatMap more) $ exts
+  more i = errVal [] $ do
+    m <- lookupModMod gr i
+    return $ extends m ++ [o | o <- map openedModule (opens m)]
+  notReuse i = errVal True $ do
+    m <- lookupModMod gr i
+    return $ isModRes m -- to exclude reused Cnc and Abs from required
+
+
+{-
+-- to test
+exampleDeps = [
+  (ir "Nat",[ii "Gen", ir "Adj"]),
+  (ir "Adj",[ii "Num", ii "Gen", ir "Nou"]),
+  (ir "Nou",[ii "Cas"])
+  ]
+
+ii s = IdentM (IC s) MTInterface
+ir s = IdentM (IC s) MTResource
+-}
+

src-2.9/GF/Compile/NewRename.hs

@@ -0,0 +1,294 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:41 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- AR 14\/5\/2003
+--
+-- The top-level function 'renameGrammar' does several things:
+--
+--   - extends each module symbol table by indirections to extended module
+--
+--   - changes unqualified and as-qualified imports to absolutely qualified
+--
+--   - goes through the definitions and resolves names
+--
+-- Dependency analysis between modules has been performed before this pass.
+-- Hence we can proceed by @fold@ing "from left to right".
+-----------------------------------------------------------------------------
+
+module GF.Compile.NewRename (renameSourceTerm, renameModule) where
+
+import GF.Grammar.Grammar
+import GF.Grammar.Values
+import GF.Infra.Modules
+import GF.Infra.Ident
+import GF.Grammar.Macros
+import GF.Grammar.PrGrammar
+import GF.Grammar.AppPredefined
+import GF.Grammar.Lookup
+import GF.Compile.Extend
+import GF.Data.Operations
+
+import Control.Monad
+
+-- | this gives top-level access to renaming term input in the cc command
+renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
+renameSourceTerm g m t = do
+  mo     <- lookupErr m (modules g)
+  let status = (modules g,(m,mo)) --- <- buildStatus g m mo
+  renameTerm status [] t
+
+-- | this is used in the compiler, separately for each module
+renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
+renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
+  ModMod m@(Module mt st fs me ops js) -> do
+    let js1 = jments m
+    let status = (ms, (name, mod))
+    js2    <- mapMTree (renameInfo status) js1
+    let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2
+    return $ (name,mod2) : ms
+
+type Status = ([SourceModule],SourceModule)   --- (StatusTree, [(OpenSpec Ident, StatusTree)])
+
+--- type StatusTree = BinTree (Ident,StatusInfo)
+
+--- type StatusInfo = Ident -> Term
+
+lookupStatusInfo :: Ident -> SourceModule -> Err Term
+lookupStatusInfo c (q,ModMod m) = do
+  i <- lookupTree prt c $ jments m
+  return $ case i of
+    AbsFun _ (Yes EData) -> QC q c
+    ResValue _           -> QC q c
+    ResParam _           -> QC q c
+    AnyInd True n        -> QC n c --- should go further?
+    AnyInd False n       -> Q  n c
+    _                    -> Q  q c
+lookupStatusInfo c (q,_) = prtBad "ModMod expected for" q
+
+lookupStatusInfoMany :: [SourceModule] -> Ident -> Err Term
+lookupStatusInfoMany (m:ms) c = case lookupStatusInfo c m of
+  Ok v -> return v
+  _ -> lookupStatusInfoMany ms c
+lookupStatusInfoMany [] x = 
+  prtBad "renaming failed to find unqualified constant" x
+---- should also give error if stg is found in more than one module
+
+renameIdentTerm :: Status -> Term -> Err Term
+renameIdentTerm env@(imps,act@(_,ModMod this)) t = 
+ errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $
+   case t of
+  Vr c -> do
+    f <- err (predefAbs c) return $ lookupStatusInfoMany openeds c
+    return $ f
+  Cn c -> do
+    f <- lookupStatusInfoMany openeds c
+    return $ f
+  Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
+  Q m' c -> do
+    m <- lookupErr m' qualifs
+    f <- lookupStatusInfo c m
+    return $ f
+  QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
+  QC m' c -> do
+    m <- lookupErr m' qualifs
+    f <- lookupStatusInfo c m
+    return $ f
+  _ -> return t
+ where
+   openeds = act : [(m,st) | OSimple _ m <- opens this, Just st <- [lookup m imps]]
+   qualifs = 
+     [(m, (n,st)) | OQualif _ m n <- opens this, Just st <- [lookup n imps]] 
+     ++ 
+     [(m, (m,st)) | OSimple _ m   <- opens this, Just st <- [lookup m imps]] 
+                                -- qualif is always possible
+
+   -- this facility is mainly for BWC with GF1: you need not import PredefAbs
+   predefAbs c s = case c of
+     IC "Int"    -> return $ Q cPredefAbs cInt
+     IC "String" -> return $ Q cPredefAbs cString
+     _ -> Bad s
+
+-- | would it make sense to optimize this by inlining?
+renameIdentPatt :: Status -> Patt -> Err Patt
+renameIdentPatt env p = do
+  let t = patt2term p
+  t' <- renameIdentTerm env t
+  term2patt t'
+
+{- deprec !
+info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo)
+info2status mq (c,i) = (c, case i of
+  AbsFun _ (Yes EData) -> maybe Con QC mq
+  ResValue _  -> maybe Con QC mq
+  ResParam _  -> maybe Con QC mq
+  AnyInd True m -> maybe Con (const (QC m)) mq
+  AnyInd False m -> maybe Cn (const (Q m)) mq
+  _           -> maybe Cn  Q mq
+  )
+
+tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo)
+tree2status o = case o of
+  OSimple _ i   -> mapTree (info2status (Just i))
+  OQualif _ i j -> mapTree (info2status (Just j))
+
+buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
+buildStatus gr c mo = let mo' = self2status c mo in case mo of
+  ModMod m -> do
+    let gr1 = MGrammar $ (c,mo) : modules gr 
+        ops = [OSimple OQNormal e | e <- allExtendsPlus gr1 c] ++ allOpens m
+    mods <- mapM (lookupModule gr1 . openedModule) ops
+    let sts = map modInfo2status $ zip ops mods    
+    return $ if isModCnc m
+      then (NT, reverse sts) -- the module itself does not define any names
+      else (mo',reverse sts) -- so the empty ident is not needed
+
+modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree)
+modInfo2status (o,i) = (o,case i of
+  ModMod m -> tree2status o (jments m)
+  )
+
+self2status :: Ident -> SourceModInfo -> StatusTree
+self2status c i = mapTree (info2status (Just c)) js where   -- qualify internal
+  js = case i of
+    ModMod m 
+      | isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m 
+      | otherwise -> jments m
+  noTrans (_,d) = case d of  -- to enable other than transfer js in transfer module 
+    AbsTrans _ -> False
+    _ -> True
+-}
+
+forceQualif o = case o of
+  OSimple q i   -> OQualif q i i
+  OQualif q _ i -> OQualif q i i
+  
+renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info)
+renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ 
+                                liftM ((,) i) $ case info of
+  AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
+                                  (renPerh (mapM rent) pfs)
+  AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
+  AbsTrans f -> liftM AbsTrans (rent f)
+
+  ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
+  ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp)
+  ResValue t  -> liftM ResValue (ren t)
+  CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
+  CncFun mt  ptr ppr -> liftM2 (CncFun mt)      (ren ptr) (ren ppr)
+  _ -> return info
+ where 
+   ren = renPerh rent
+   rent = renameTerm status []
+
+renPerh ren pt = case pt of
+  Yes t -> liftM Yes $ ren t
+  _ -> return pt
+
+renameTerm :: Status -> [Ident] -> Term -> Err Term
+renameTerm env vars = ren vars where
+  ren vs trm = case trm of
+    Abs x b    -> liftM  (Abs x) (ren (x:vs) b)
+    Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b)
+    Typed a b  -> liftM2 Typed (ren vs a) (ren vs b)
+    Vr x      
+      | elem x vs -> return trm
+      | otherwise -> renid trm
+    Cn _   -> renid trm
+    Con _  -> renid trm
+    Q _ _  -> renid trm
+    QC _ _ -> renid trm
+    Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs
+    T i cs -> do
+      i' <- case i of
+        TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
+        _ -> return i
+      liftM (T i') $ mapM (renCase vs) cs  
+
+    Let (x,(m,a)) b -> do
+      m' <- case m of
+        Just ty -> liftM Just $ ren vs ty
+        _ -> return m
+      a' <- ren vs a
+      b' <- ren (x:vs) b
+      return $ Let (x,(m',a')) b'
+
+    P t@(Vr r) l                     -- for constant t we know it is projection
+      | elem r vs -> return trm                           -- var proj first
+      | otherwise -> case renid (Q r (label2ident l)) of  -- qualif   second
+          Ok t -> return t
+          _ -> liftM (flip P l) $ renid t                 -- const proj last
+
+    _ -> composOp (ren vs) trm
+
+  renid = renameIdentTerm env
+  renCase vs (p,t) = do
+    (p',vs') <- renpatt p
+    t' <- ren (vs' ++ vs) t
+    return (p',t')
+  renpatt = renamePattern env
+
+-- | vars not needed in env, since patterns always overshadow old vars
+renamePattern :: Status -> Patt -> Err (Patt,[Ident])
+renamePattern env patt = case patt of
+
+  PC c ps -> do
+    c' <- renameIdentTerm env $ Cn c
+    psvss <- mapM renp ps
+    let (ps',vs) = unzip psvss
+    case c' of
+      QC p d -> return (PP p d ps', concat vs)
+      Q  p d -> return (PP p d ps', concat vs) ---- should not happen
+      _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs)
+
+----  PP p c ps -> (PP p c ps',concat vs') where (ps',vs') = unzip $ map renp ps
+
+  PV x -> case renid patt of
+    Ok p -> return (p,[])
+    _    -> return (patt, [x])
+
+  PR r -> do
+    let (ls,ps) = unzip r
+    psvss <- mapM renp ps
+    let (ps',vs') = unzip psvss
+    return (PR (zip ls ps'), concat vs') 
+
+  _ -> return (patt,[])
+
+ where 
+   renp  = renamePattern env
+   renid = renameIdentPatt env
+
+renameParam :: Status -> (Ident, Context) -> Err (Ident, Context)
+renameParam env (c,co) = do
+  co' <- renameContext env co
+  return (c,co')
+
+renameContext :: Status -> Context -> Err Context
+renameContext b = renc [] where
+  renc vs cont = case cont of
+    (x,t) : xts 
+      | isWildIdent x -> do
+          t'   <- ren vs t
+          xts' <- renc vs xts
+          return $ (x,t') : xts'
+      | otherwise -> do
+          t'   <- ren vs t
+          let vs' = x:vs
+          xts' <- renc vs' xts
+          return $ (x,t') : xts'
+    _ -> return cont
+  ren = renameTerm b
+
+-- | vars not needed in env, since patterns always overshadow old vars
+renameEquation :: Status -> [Ident] -> Equation -> Err Equation
+renameEquation b vs (ps,t) = do
+  (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
+  t'        <- renameTerm b (concat vs' ++ vs) t
+  return (ps',t')

src-2.9/GF/Compile/NoParse.hs

@@ -0,0 +1,49 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : NoParse
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/14 16:03:41 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.1 $
+--
+-- Probabilistic abstract syntax. AR 30\/10\/2005
+--
+-- (c) Aarne Ranta 2005 under GNU GPL
+--
+-- Contents: decide what lin rules no parser is generated.
+-- Usually a list of noparse idents from 'i -boparse=file'.
+
+-----------------------------------------------------------------------------
+
+module GF.Compile.NoParse (
+  NoParse             -- =  Ident -> Bool
+ ,getNoparseFromFile  -- :: Opts -> IO NoParse
+ ,doParseAll          -- :: NoParse
+  ) where
+
+import GF.Infra.Ident
+import GF.Data.Operations
+import GF.Infra.Option
+
+
+type NoParse = (Ident -> Bool)
+
+doParseAll :: NoParse
+doParseAll = const False
+
+getNoparseFromFile :: Options -> FilePath -> IO NoParse
+getNoparseFromFile opts file = do 
+  let f = maybe file id $ getOptVal opts noparseFile
+  s <- readFile f
+  let tree = buildTree $ flip zip (repeat ()) $ concat $ map getIgnores $ lines s
+  tree `seq` return $ igns tree
+ where
+  igns tree i = isInBinTree i tree
+
+-- where
+getIgnores s = case dropWhile (/="--#") (words s) of
+     _:"noparse":fs -> map identC fs
+     _ -> []

src-2.9/GF/Compile/Optimize.hs

@@ -0,0 +1,300 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Optimize
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/16 13:56:13 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.18 $
+--
+-- Top-level partial evaluation for GF source modules.
+-----------------------------------------------------------------------------
+
+module GF.Compile.Optimize (optimizeModule) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.PrGrammar
+import GF.Grammar.Macros
+import GF.Grammar.Lookup
+import GF.Grammar.Refresh
+import GF.Grammar.Compute
+import GF.Compile.BackOpt
+import GF.Compile.CheckGrammar
+import GF.Compile.Update
+import GF.Compile.Evaluate
+
+import GF.Data.Operations
+import GF.Infra.CheckM
+import GF.Infra.Option
+
+import Control.Monad
+import Data.List
+
+import Debug.Trace
+
+
+-- conditional trace
+
+prtIf :: (Print a) => Bool -> a -> a
+prtIf b t = if b then trace (" " ++ prt t) t else t
+
+-- experimental evaluation, option to import
+oEval = iOpt "eval"
+
+-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
+-- only do this for resource: concrete is optimized in gfc form
+optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> 
+                  (Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv)
+optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of
+  ModMod m0@(Module mt st fs me ops js) | 
+    st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do
+      (mo1,_) <- evalModule oopts mse mo
+      let 
+       mo2 = case optim of
+        "parametrize" -> shareModule paramOpt mo1  -- parametrization and sharing
+        "values"      -> shareModule valOpt mo1    -- tables as courses-of-values
+        "share"       -> shareModule shareOpt mo1  -- sharing of branches
+        "all"         -> shareModule allOpt mo1    -- first parametrize then values
+        "none"        -> mo1                       -- no optimization
+        _             -> mo1                       -- none; default for src
+      return (mo2,eenv)
+  _ -> evalModule oopts mse mo
+ where
+   oopts = addOptions opts (iOpts (flagsModule mo))
+   optim = maybe "all" id $ getOptVal oopts useOptimizer
+
+evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) -> 
+               Err ((Ident,SourceModInfo),EEnv)
+evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
+
+  ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
+    _ | isModRes m0 && not (oElem oEval oopts) -> do
+      let deps = allOperDependencies name js
+      ids <- topoSortOpers deps
+      MGrammar (mod' : _) <- foldM evalOp gr ids
+      return $ (mod',eenv)
+
+    MTConcrete a | oElem oEval oopts -> do
+      (js0,eenv') <- appEvalConcrete gr js eenv
+      js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005 
+      return $ ((name, ModMod (Module mt st fs me ops js')),eenv')
+
+    MTConcrete a -> do
+      js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005
+      return $ ((name, ModMod (Module mt st fs me ops js')),eenv)
+
+    _ -> return $ ((name,mod),eenv)
+  _ -> return $ ((name,mod),eenv)
+ where
+   gr0 = MGrammar $ ms
+   gr  = MGrammar $ (name,mod) : ms
+
+   evalOp g@(MGrammar ((_, ModMod m) : _)) i = do
+     info  <- lookupTree prt i $ jments m
+     info' <- evalResInfo oopts gr (i,info)
+     return $ updateRes g name i info'
+
+-- | only operations need be compiled in a resource, and this is local to each
+-- definition since the module is traversed in topological order
+evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info
+evalResInfo oopts gr (c,info) = case info of
+
+  ResOper pty pde -> eIn "operation" $ do
+    pde' <- case pde of
+       Yes de | optres -> liftM yes $ comp de 
+       _ -> return pde
+    return $ ResOper pty pde'
+
+  _ ->  return info
+ where
+   comp = if optres then computeConcrete gr else computeConcreteRec gr
+   eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
+   optim = maybe "all" id $ getOptVal oopts useOptimizer
+   optres = case optim of
+     "noexpand" -> False
+     _ -> True
+
+
+evalCncInfo :: 
+  Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
+evalCncInfo opts gr cnc abs (c,info) = do
+
+ seq (prtIf (oElem beVerbose opts) c) $ return ()
+
+ errIn ("optimizing" +++ prt c) $ case info of
+
+  CncCat ptyp pde ppr -> do
+    pde' <- case (ptyp,pde) of
+      (Yes typ, Yes de) -> 
+        liftM yes $ pEval ([(strVar, typeStr)], typ) de
+      (Yes typ, Nope)   -> 
+        liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(strVar, typeStr)],typ)
+      (May b, Nope) ->
+        return $ May b
+      _ -> return pde   -- indirection
+
+    ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c)
+
+    return (c, CncCat ptyp pde' ppr')
+
+  CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> 
+       eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
+    pde' <- case pde of
+      Yes de | notNewEval -> do
+        liftM yes $ pEval ty de
+
+      _ -> return pde
+    ppr' <-  liftM yes $ evalPrintname gr c ppr pde'
+    return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed
+
+  _ ->  return (c,info)
+ where
+   pEval = partEval opts gr
+   eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
+   notNewEval = not (oElem oEval opts)
+
+-- | the main function for compiling linearizations
+partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
+partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do
+  let vars  = map fst context
+      args  = map Vr vars
+      subst = [(v, Vr v) | v <- vars]
+      trm1  = mkApp trm args
+  trm3 <- if globalTable 
+             then etaExpand subst trm1 >>= outCase subst
+             else etaExpand subst trm1
+  return $ mkAbs vars trm3
+
+ where 
+
+   globalTable = oElem showAll opts --- i -all
+
+   comp g t = {- refreshTerm t >>= -} computeTerm gr g t
+
+   etaExpand su t = do
+     t' <- comp su t 
+     case t' of
+       R _ | rightType t' -> comp su t' --- return t' wo noexpand...
+       _ -> recordExpand val t' >>= comp su
+   -- don't eta expand records of right length (correct by type checking)
+   rightType t = case (t,val) of
+     (R rs, RecType ts) -> length rs == length ts
+     _ -> False
+
+   outCase subst t = do
+     pts <- getParams context
+     let (args,ptyps) = unzip $ filter (flip occur t . fst) pts
+     if null args 
+       then return t 
+       else do 
+         let argtyp = RecType $ tuple2recordType ptyps
+         let pvars = map (Vr . zIdent . prt) args -- gets eliminated
+         patt <- term2patt $ R $ tuple2record $ pvars
+         let t' = replace (zip args pvars) t
+         t1 <- comp subst $ T (TTyped argtyp) [(patt, t')]
+         return $ S t1 $ R $ tuple2record args
+
+   --- notice: this assumes that all lin types follow the "old JFP style" 
+   getParams = liftM concat . mapM getParam 
+   getParam (argv,RecType rs) = return 
+     [(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs,  not (isLinLabel lab)] 
+   ---getParam (_,ty) | ty==typeStr = return [] --- in lindef 
+   getParam (av,ty) = 
+     Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av) 
+     --- all lin types are rec types
+
+   replace :: [(Term,Term)] -> Term -> Term
+   replace reps trm = case trm of  
+     -- this is the important case
+     P _ _ -> maybe trm id $ lookup trm reps
+     _ -> composSafeOp (replace reps) trm
+
+   occur t trm = case trm of
+
+     -- this is the important case
+     P _ _   -> t == trm
+     S x y   -> occur t y || occur t x
+     App f x -> occur t x || occur t f
+     Abs _ f -> occur t f
+     R rs    -> any (occur t) (map (snd . snd) rs)
+     T _ cs  -> any (occur t) (map snd cs)
+     C x y   -> occur t x || occur t y
+     Glue x y -> occur t x || occur t y
+     ExtR x y -> occur t x || occur t y
+     FV ts   -> any (occur t) ts
+     V _ ts   -> any (occur t) ts
+     Let (_,(_,x)) y -> occur t x || occur t y
+     _ -> False
+
+
+-- here we must be careful not to reduce
+--   variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
+--   {s  = variants {"Auto" ; "Wagen"} ; g  = variants {N ; M}} ;
+
+recordExpand :: Type -> Term -> Err Term
+recordExpand typ trm = case unComputed typ of
+  RecType tys -> case trm of
+    FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
+    _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
+  _ -> return trm
+
+
+-- | auxiliaries for compiling the resource
+
+mkLinDefault :: SourceGrammar -> Type -> Err Term
+mkLinDefault gr typ = do
+  case unComputed typ of
+    RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
+    _ -> prtBad "linearization type must be a record type, not" typ
+ where
+   mkDefField typ = case unComputed typ of
+     Table p t  -> do
+       t' <- mkDefField t
+       let T _ cs = mkWildCases t'
+       return $ T (TWild p) cs 
+     Sort "Str" -> return $ Vr strVar
+     QC q p     -> lookupFirstTag gr q p
+     RecType r  -> do
+       let (ls,ts) = unzip r
+       ts' <- mapM mkDefField ts
+       return $ R $ [assign l t | (l,t) <- zip ls ts']
+     _ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val
+     _ -> prtBad "linearization type field cannot be" typ
+
+-- | Form the printname: if given, compute. If not, use the computed
+-- lin for functions, cat name for cats (dispatch made in evalCncDef above).
+--- We cannot use linearization at this stage, since we do not know the
+--- defaults we would need for question marks - and we're not yet in canon.
+evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term
+evalPrintname gr c ppr lin =
+  case ppr of
+    Yes pr -> comp pr
+    _ -> case lin of
+      Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm
+      _ -> return $ K $ prt c ----
+ where
+   comp = computeConcrete gr
+
+   oneBranch t = case t of
+     Abs _ b   -> oneBranch b
+     R   (r:_) -> oneBranch $ snd $ snd r
+     T _ (c:_) -> oneBranch $ snd c
+     V _ (c:_) -> oneBranch c
+     FV  (t:_) -> oneBranch t
+     C x y     -> C (oneBranch x) (oneBranch y)
+     S x _     -> oneBranch x
+     P x _     -> oneBranch x
+     Alts (d,_) -> oneBranch d
+     _ -> t
+
+  --- very unclean cleaner
+   clean s = case s of
+     '+':'+':' ':cs -> clean cs
+     '"':cs -> clean cs
+     c:cs -> c: clean cs
+     _ -> s
+

src-2.9/GF/Compile/PGrammar.hs

@@ -0,0 +1,77 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PGrammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/25 10:27:12 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Compile.PGrammar (pTerm, pTrm, pTrms,
+		 pMeta, pzIdent, 
+		 string2ident
+		) where
+
+---import LexGF
+import GF.Source.ParGF
+import GF.Source.SourceToGrammar (transExp)
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import qualified GF.Canon.AbsGFC as A
+import qualified GF.Canon.GFC as G
+import GF.Compile.GetGrammar
+import GF.Grammar.Macros
+import GF.Grammar.MMacros
+
+import GF.Data.Operations
+import qualified Data.ByteString.Char8 as BS
+
+pTerm :: String -> Err Term
+pTerm s = do
+  e <- pExp $ myLexer (BS.pack s)
+  transExp e
+
+pTrm :: String -> Term
+pTrm = errVal (vr (zIdent "x")) . pTerm ---
+
+pTrms :: String -> [Term]
+pTrms = map pTrm . sep [] where
+  sep t cs = case cs of
+    ',' : cs2 -> reverse t : sep [] cs2
+    c   : cs2 -> sep (c:t) cs2
+    _         -> [reverse t]
+
+pTrm' :: String -> [Term]
+pTrm' = err (const []) singleton . pTerm
+
+pMeta :: String -> Integer
+pMeta _ = 0 ---
+
+pzIdent :: String -> Ident
+pzIdent = zIdent
+
+{-
+string2formsAndTerm :: String -> ([Term],Term)
+string2formsAndTerm s = case s of
+    '[':_:_ -> case span (/=']') s of  
+      (x,_:y) -> (pTrms (tail x), pTrm y)
+      _ -> ([],pTrm s)
+    _ -> ([], pTrm s)
+-}
+
+string2ident :: String -> Err Ident
+string2ident s = return $ string2var s
+
+{-
+-- reads the Haskell datatype
+readGrammar :: String -> Err GrammarST
+readGrammar s =  case [x | (x,t) <- reads s, ("","") <- lex t] of
+  [x] -> return x
+  []  -> Bad "no parse of Grammar"
+  _   -> Bad "ambiguous parse of Grammar"
+-}

src-2.9/GF/Compile/PrOld.hs

@@ -0,0 +1,84 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PrOld
+-- Maintainer  : GF
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:44 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- a hack to print gf2 into gf1 readable files
+-- Works only for canonical grammars, printed into GFC. Otherwise we would have
+-- problems with qualified names.
+-- --- printnames are not preserved, nor are lindefs
+-----------------------------------------------------------------------------
+
+module GF.Compile.PrOld (printGrammarOld, stripTerm) where
+
+import GF.Grammar.PrGrammar
+import GF.Canon.CanonToGrammar
+import qualified GF.Canon.GFC as GFC
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Grammar.Macros
+import GF.Infra.Modules
+import qualified GF.Source.PrintGF as P
+import GF.Source.GrammarToSource
+
+import Data.List
+import GF.Data.Operations
+import GF.Infra.UseIO
+
+printGrammarOld :: GFC.CanonGrammar -> String
+printGrammarOld gr = err id id $ do
+  as0 <- mapM canon2sourceModule [im | im@(_,ModMod m) <- modules gr, isModAbs m]
+  cs0 <- mapM canon2sourceModule 
+           [im | im@(_,ModMod m) <- modules gr, isModCnc m || isModRes m]
+  as1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) as0
+  cs1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) cs0
+  return $ unlines $ map prj $ srt as1 ++ srt cs1
+ where
+   js (ModMod m) = jments m
+   srt = sortBy (\ (i,_) (j,_) -> compare i j)
+   prj ii = P.printTree $ trAnyDef ii
+
+stripInfo :: (Ident,Info) -> [(Ident,Info)]
+stripInfo (c,i) = case i of
+  AbsCat   (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope
+  AbsFun   (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr))
+  AbsFun   (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope
+  ResParam (Yes (ps,m))       -> rc $ ResParam (Yes ([(c,stripContext co) | (c,co)<- ps],Nothing))
+  CncCat   (Yes ty) _ _ -> rc $
+    CncCat (Yes (stripTerm ty)) nope nope
+  CncFun   _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope
+  _ -> []
+ where
+   rc j = [(c,j)]
+
+stripContext co = [(x, stripTerm t) | (x,t) <- co]
+
+stripTerm :: Term -> Term
+stripTerm t = case t of
+  Q _ c -> Vr c
+  QC _ c -> Vr c
+  T ti cs -> T ti' [(stripPattern p, stripTerm c) | (p,c) <- cs] where
+               ti' = case ti of
+                  TTyped ty -> TTyped $ stripTerm ty
+                  TComp ty -> TComp $ stripTerm ty
+                  TWild ty -> TWild $ stripTerm ty
+                  _ -> ti
+----  R [] -> EInt 8      --- GF 1.2 parser doesn't accept empty records 
+----  RecType [] -> Cn (zIdent "Int") ---
+  _ -> composSafeOp stripTerm t
+
+stripPattern p = case p of
+  PC c [] -> PV c
+  PP _ c [] -> PV c
+  PC c ps -> PC c (map stripPattern ps)
+  PP _ c ps -> PC c (map stripPattern ps)
+  PR lps -> PR [(l, stripPattern p) | (l,p) <- lps]
+  PT t p -> PT (stripTerm t) (stripPattern p)
+  _ -> p
+

src-2.9/GF/Compile/Rebuild.hs

@@ -0,0 +1,99 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Rebuild
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.14 $
+--
+-- Rebuild a source module from incomplete and its with-instance.
+-----------------------------------------------------------------------------
+
+module GF.Compile.Rebuild (rebuildModule) where
+
+import GF.Grammar.Grammar
+import GF.Compile.ModDeps
+import GF.Grammar.PrGrammar
+import GF.Grammar.Lookup
+import GF.Compile.Extend
+import GF.Grammar.Macros
+
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Data.Operations
+
+import Data.List (nub)
+
+-- | rebuilding instance + interface, and "with" modules, prior to renaming. 
+-- AR 24/10/2003
+rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule
+rebuildModule ms mo@(i,mi) = do
+  let gr = MGrammar ms
+----  deps <- moduleDeps ms
+----  is   <- openInterfaces deps i
+  let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
+  mi'  <- case mi of
+
+    -- add the information given in interface into an instance module
+    ModMod m -> do
+      testErr (null is || mstatus m == MSIncomplete) 
+              ("module" +++ prt i +++ 
+               "has open interfaces and must therefore be declared incomplete") 
+      case mtype m of
+        MTInstance i0 -> do
+          m1 <- lookupModMod gr i0
+          testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
+          m' <- do
+            js' <- extendMod False (i0,const True) i (jments m1) (jments m)
+            --- to avoid double inclusions, in instance I of I0 = J0 ** ...
+            case extends m of
+              [] -> return $ replaceJudgements m js'
+              j0s -> do 
+                m0s <- mapM (lookupModMod gr) j0s
+                let notInM0 c _  = all (not . isInBinTree c . jments) m0s
+                let js2 = filterBinTree notInM0 js'
+                return $ replaceJudgements m js2
+          return $ ModMod m'
+        _ -> return mi
+
+    -- add the instance opens to an incomplete module "with" instances
+    --      ModWith mt stat ext me ops -> do
+    ModWith (Module mt stat fs_ me ops_ js_) (ext,incl) ops -> do
+      let insts = [(inf,inst) | OQualif _ inf inst <- ops]
+      let infs  = map fst insts
+      let stat' = ifNull MSComplete (const MSIncomplete)
+                    [i | i <- is, notElem i infs]
+      testErr (stat' == MSComplete || stat == MSIncomplete) 
+              ("module" +++ prt i +++ "remains incomplete")
+      Module mt0 _ fs me' ops0 js <- lookupModMod gr ext
+      let ops1 = nub $
+                   ops_ ++ -- N.B. js has been name-resolved already
+                   ops ++ [o | o <- ops0, notElem (openedModule o) infs]
+                       ++ [oQualif i i | i <- map snd insts] ----
+                       ++ [oSimple i   | i <- map snd insts] ----
+
+      --- check if me is incomplete
+      let fs1 = fs_ ++ fs                            -- new flags have priority
+      let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
+      let js1 = buildTree (tree2list js_ ++ js0)
+      return $ ModMod $ Module mt0 stat' fs1 me ops1 js1 
+                          ---- (mapTree (qualifInstanceInfo insts) js) -- not needed
+
+    _ -> return mi
+  return (i,mi')
+
+checkCompleteInstance :: SourceRes -> SourceRes -> Err ()
+checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $
+  checkComplete [f | (f, ResOper (Yes _) _) <- abs'] cnc'
+   where
+     abs' = tree2list $ jments abs
+     cnc' = jments cnc
+     checkComplete sought given = foldr ckOne [] sought
+       where
+         ckOne f = if isInBinTree f given 
+                      then id
+                      else (("Error: no definition given to" +++ prt f):)
+

src-2.9/GF/Compile/RemoveLiT.hs

@@ -0,0 +1,63 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : RemoveLiT
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:45 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- remove obsolete (Lin C) expressions before doing anything else. AR 21/6/2003
+--
+-- What the program does is replace the occurrences of Lin C with the actual
+-- definition T given in lincat C = T ; with {s : Str} if no lincat is found.
+-- The procedure is uncertain, if T contains another Lin.
+-----------------------------------------------------------------------------
+
+module GF.Compile.RemoveLiT (removeLiT) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.Macros
+import GF.Grammar.Lookup
+
+import GF.Data.Operations
+
+import Control.Monad
+
+removeLiT :: SourceGrammar -> Err SourceGrammar
+removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr)
+
+remlModule :: SourceGrammar -> (Ident,SourceModInfo) -> Err (Ident,SourceModInfo)
+remlModule gr mi@(name,mod) = case mod of
+  ModMod (Module mt st fs me ops js) -> do
+    js1 <- mapMTree (remlResInfo gr) js
+    let mod2 = ModMod $ Module mt st fs me ops js1
+    return $ (name,mod2)
+  _ -> return mi
+
+remlResInfo :: SourceGrammar -> (Ident,Info) -> Err (Ident,Info)
+remlResInfo gr mi@(i,info) = case info of
+  ResOper pty ptr    -> liftM ((,) i) $ liftM2 ResOper (ren pty) (ren ptr)
+  CncCat pty ptr ppr -> liftM ((,) i) $ liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
+  CncFun mt  ptr ppr -> liftM ((,) i) $ liftM2 (CncFun mt)      (ren ptr) (ren ppr)
+  _ -> return mi
+ where 
+   ren = remlPerh gr
+
+remlPerh gr pt = case pt of
+  Yes t -> liftM Yes $ remlTerm gr t
+  _ -> return pt
+
+remlTerm :: SourceGrammar -> Term -> Err Term
+remlTerm gr trm = case trm of
+  LiT c -> look c >>= remlTerm gr
+  _ -> composOp (remlTerm gr) trm
+ where
+   look c = err (const $ return defLinType) return $ lookupLincat gr m c
+   m = case [cnc | (cnc,ModMod m) <- modules gr, isModCnc m] of
+     cnc:_ -> cnc   -- actually there is always exactly one
+     _ -> zIdent "CNC" 

src-2.9/GF/Compile/Rename.hs

@@ -0,0 +1,338 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Rename
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.19 $
+--
+-- AR 14\/5\/2003
+-- The top-level function 'renameGrammar' does several things:
+--
+--   - extends each module symbol table by indirections to extended module
+--
+--   - changes unqualified and as-qualified imports to absolutely qualified
+--
+--   - goes through the definitions and resolves names
+--
+-- Dependency analysis between modules has been performed before this pass.
+-- Hence we can proceed by @fold@ing "from left to right".
+-----------------------------------------------------------------------------
+
+module GF.Compile.Rename (renameGrammar,
+	       renameSourceTerm,
+	       renameModule
+	      ) where
+
+import GF.Grammar.Grammar
+import GF.Grammar.Values
+import GF.Infra.Modules
+import GF.Infra.Ident
+import GF.Grammar.Macros
+import GF.Grammar.PrGrammar
+import GF.Grammar.AppPredefined
+import GF.Grammar.Lookup
+import GF.Compile.Extend
+import GF.Data.Operations
+
+import Control.Monad
+import Data.List (nub)
+import Debug.Trace (trace)
+
+renameGrammar :: SourceGrammar -> Err SourceGrammar
+renameGrammar g = liftM (MGrammar . reverse) $ foldM renameModule [] (modules g)
+
+-- | this gives top-level access to renaming term input in the cc command
+renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
+renameSourceTerm g m t = do
+  mo     <- lookupErr m (modules g)
+  status <- buildStatus g m mo
+  renameTerm status [] t
+
+renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
+renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
+  ModMod m@(Module mt st fs me ops js) -> do
+    let js1 = jments m
+    status <- buildStatus (MGrammar ms) name mod
+    js2    <- mapMTree (renameInfo status) js1
+    let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2
+    return $ (name,mod2) : ms
+
+type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
+
+type StatusTree = BinTree Ident StatusInfo
+
+type StatusInfo = Ident -> Term
+
+renameIdentTerm :: Status -> Term -> Err Term
+renameIdentTerm env@(act,imps) t = 
+ errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $
+   case t of
+  Vr c -> ident predefAbs c
+  Cn c -> ident (\_ s -> Bad s) c
+  Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
+  Q m' c -> do
+    m <- lookupErr m' qualifs
+    f <- lookupTree prt c m
+    return $ f c
+  QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
+  QC m' c -> do
+    m <- lookupErr m' qualifs
+    f <- lookupTree prt c m
+    return $ f c
+  _ -> return t
+ where
+   opens  = [st  | (OSimple _ _,st) <- imps]
+   qualifs = [(m, st) | (OQualif _ m _, st) <- imps] ++ 
+             [(m, st) | (OSimple _ m, st) <- imps] -- qualif is always possible
+
+   -- this facility is mainly for BWC with GF1: you need not import PredefAbs
+   predefAbs c s = case c of
+     IC "Int" -> return $ Q cPredefAbs cInt
+     IC "Float" -> return $ Q cPredefAbs cFloat
+     IC "String" -> return $ Q cPredefAbs cString
+     _ -> Bad s
+
+   ident alt c = case lookupTree prt c act of
+      Ok f -> return $ f c
+      _ -> case lookupTreeManyAll prt opens c of
+        [f] -> return $ f c
+        []  -> alt c ("constant not found:" +++ prt c) 
+        fs -> case nub [f c | f <- fs]  of
+          [tr] -> return tr
+          ts@(t:_) -> trace ("WARNING: conflict" +++ unwords (map prt ts)) (return t)
+----          ts -> return $ Strs $ (cnIC "#conflict") : reverse ts
+            -- a warning will be generated in CheckGrammar, and the head returned
+            -- in next V: 
+            -- Bad $ "conflicting imports:" +++ unwords (map prt ts) 
+
+
+--- | would it make sense to optimize this by inlining?
+renameIdentPatt :: Status -> Patt -> Err Patt
+renameIdentPatt env p = do
+  let t = patt2term p
+  t' <- renameIdentTerm env t
+  term2patt t'
+
+info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo)
+info2status mq (c,i) = (c, case i of
+  AbsFun _ (Yes EData) -> maybe Con QC mq
+  ResValue _  -> maybe Con QC mq
+  ResParam _  -> maybe Con QC mq
+  AnyInd True m -> maybe Con (const (QC m)) mq
+  AnyInd False m -> maybe Cn (const (Q m)) mq
+  _           -> maybe Cn  Q mq
+  )
+
+tree2status :: OpenSpec Ident -> BinTree Ident Info -> BinTree Ident StatusInfo
+tree2status o = case o of
+  OSimple _ i   -> mapTree (info2status (Just i))
+  OQualif _ i j -> mapTree (info2status (Just j))
+
+buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
+buildStatus gr c mo = let mo' = self2status c mo in case mo of
+  ModMod m -> do
+    let gr1 = MGrammar $ (c,mo) : modules gr 
+        ops = [OSimple OQNormal e | e <- allExtends gr1 c] ++ allOpens m
+    mods <- mapM (lookupModule gr1 . openedModule) ops
+    let sts = map modInfo2status $ zip ops mods    
+    return $ if isModCnc m
+      then (emptyBinTree, reverse sts) -- the module itself does not define any names
+      else (mo',reverse sts) -- so the empty ident is not needed
+
+modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree)
+modInfo2status (o,i) = (o,case i of
+  ModMod m -> tree2status o (jments m)
+  )
+
+self2status :: Ident -> SourceModInfo -> StatusTree
+self2status c i = mapTree (info2status (Just c)) js where   -- qualify internal
+  js = case i of
+    ModMod m 
+      | isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m 
+      | otherwise -> jments m
+  noTrans (_,d) = case d of  -- to enable other than transfer js in transfer module 
+    AbsTrans _ -> False
+    _ -> True
+
+forceQualif o = case o of
+  OSimple q i   -> OQualif q i i
+  OQualif q _ i -> OQualif q i i
+  
+renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info)
+renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ 
+                                liftM ((,) i) $ case info of
+  AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
+                                  (renPerh (mapM rent) pfs)
+  AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
+  AbsTrans f -> liftM AbsTrans (rent f)
+
+  ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
+  ResOverload tysts -> liftM ResOverload $ mapM (pairM rent) tysts
+
+  ResParam (Yes (pp,m)) -> do
+    pp' <- mapM (renameParam status) pp
+    return $ ResParam $ Yes (pp',m)
+  ResValue (Yes (t,m)) -> do
+    t' <- rent t
+    return $ ResValue $ Yes (t',m)
+  CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
+  CncFun mt  ptr ppr -> liftM2 (CncFun mt)      (ren ptr) (ren ppr)
+  _ -> return info
+ where 
+   ren = renPerh rent
+   rent = renameTerm status []
+
+renPerh ren pt = case pt of
+  Yes t -> liftM Yes $ ren t
+  _ -> return pt
+
+renameTerm :: Status -> [Ident] -> Term -> Err Term
+renameTerm env vars = ren vars where
+  ren vs trm = case trm of
+    Abs x b    -> liftM  (Abs x) (ren (x:vs) b)
+    Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b)
+    Typed a b  -> liftM2 Typed (ren vs a) (ren vs b)
+    Vr x      
+      | elem x vs -> return trm
+      | otherwise -> renid trm
+    Cn _   -> renid trm
+    Con _  -> renid trm
+    Q _ _  -> renid trm
+    QC _ _ -> renid trm
+    Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs
+    T i cs -> do
+      i' <- case i of
+        TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
+        _ -> return i
+      liftM (T i') $ mapM (renCase vs) cs  
+
+    Let (x,(m,a)) b -> do
+      m' <- case m of
+        Just ty -> liftM Just $ ren vs ty
+        _ -> return m
+      a' <- ren vs a
+      b' <- ren (x:vs) b
+      return $ Let (x,(m',a')) b'
+
+    P t@(Vr r) l                     -- for constant t we know it is projection
+      | elem r vs -> return trm                           -- var proj first
+      | otherwise -> case renid (Q r (label2ident l)) of  -- qualif   second
+          Ok t -> return t
+          _ -> case liftM (flip P l) $ renid t of
+            Ok t -> return t                              -- const proj last
+            _ -> prtBad "unknown qualified constant" trm
+
+    EPatt p -> do
+      (p',_) <- renpatt p
+      return $ EPatt p'
+
+    _ -> composOp (ren vs) trm
+
+  renid = renameIdentTerm env
+  renCase vs (p,t) = do
+    (p',vs') <- renpatt p
+    t' <- ren (vs' ++ vs) t
+    return (p',t')
+  renpatt = renamePattern env
+
+-- | vars not needed in env, since patterns always overshadow old vars
+renamePattern :: Status -> Patt -> Err (Patt,[Ident])
+renamePattern env patt = case patt of
+
+  PMacro c -> do
+    c' <- renid $ Vr c
+    case c' of
+      Q p d -> renp $ PM p d
+      _ -> prtBad "unresolved pattern" patt
+
+  PC c ps -> do
+    c' <- renameIdentTerm env $ Cn c
+    case c' of
+      QC p d -> renp $ PP p d ps
+--      Q  p d -> renp $ PP p d ps --- why this? AR 15/3/2008
+      _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs)
+
+  PP p c ps -> do
+
+    (p', c') <- case renameIdentTerm env (QC p c) of
+      Ok (QC p' c') -> return (p',c')
+      _ -> return (p,c) --- temporarily, for bw compat
+    psvss <- mapM renp ps
+    let (ps',vs) = unzip psvss
+    return (PP p' c' ps', concat vs)
+
+  PM p c -> do
+    (p', c') <- case renameIdentTerm env (Q p c) of
+      Ok (Q p' c') -> return (p',c')
+      _ -> prtBad "not a pattern macro" patt
+    return (PM p' c', [])
+
+  PV x -> case renid (Vr x) of
+    Ok (QC m c) -> return (PP m c [],[])
+    _    -> return (patt, [x])
+
+  PR r -> do
+    let (ls,ps) = unzip r
+    psvss <- mapM renp ps
+    let (ps',vs') = unzip psvss
+    return (PR (zip ls ps'), concat vs') 
+
+  PAlt p q -> do
+    (p',vs) <- renp p
+    (q',ws) <- renp q
+    return (PAlt p' q', vs ++ ws)
+
+  PSeq p q -> do
+    (p',vs) <- renp p
+    (q',ws) <- renp q
+    return (PSeq p' q', vs ++ ws)
+
+  PRep p -> do
+    (p',vs) <- renp p
+    return (PRep p', vs)
+
+  PNeg p -> do
+    (p',vs) <- renp p
+    return (PNeg p', vs)
+
+  PAs x p -> do
+    (p',vs) <- renp p
+    return (PAs x p', x:vs)
+
+  _ -> return (patt,[])
+
+ where 
+   renp  = renamePattern env
+   renid = renameIdentTerm env
+
+renameParam :: Status -> (Ident, Context) -> Err (Ident, Context)
+renameParam env (c,co) = do
+  co' <- renameContext env co
+  return (c,co')
+
+renameContext :: Status -> Context -> Err Context
+renameContext b = renc [] where
+  renc vs cont = case cont of
+    (x,t) : xts 
+      | isWildIdent x -> do
+          t'   <- ren vs t
+          xts' <- renc vs xts
+          return $ (x,t') : xts'
+      | otherwise -> do
+          t'   <- ren vs t
+          let vs' = x:vs
+          xts' <- renc vs' xts
+          return $ (x,t') : xts'
+    _ -> return cont
+  ren = renameTerm b
+
+-- | vars not needed in env, since patterns always overshadow old vars
+renameEquation :: Status -> [Ident] -> Equation -> Err Equation
+renameEquation b vs (ps,t) = do
+  (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
+  t'        <- renameTerm b (concat vs' ++ vs) t
+  return (ps',t')

src-2.9/GF/Compile/ShellState.hs

@@ -0,0 +1,568 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ShellState
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/14 16:03:41 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.53 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Compile.ShellState where
+
+import GF.Data.Operations
+import GF.Canon.GFC
+import GF.Canon.AbsGFC
+import GF.GFCC.CId
+--import GF.GFCC.DataGFCC(mkGFCC)
+import GF.GFCC.Macros (lookFCFG)
+import GF.Canon.CanonToGFCC
+import GF.Grammar.Macros
+import GF.Grammar.MMacros
+
+import GF.Canon.Look
+import GF.Canon.Subexpressions
+import GF.Grammar.LookAbs
+import GF.Compile.ModDeps
+import GF.Compile.Evaluate
+import qualified GF.Infra.Modules as M
+import qualified GF.Grammar.Grammar as G
+import qualified GF.Grammar.PrGrammar as P
+import GF.CF.CF
+import GF.CF.CFIdent
+import GF.CF.CanonToCF
+import GF.UseGrammar.Morphology
+import GF.Probabilistic.Probabilistic
+import GF.Compile.NoParse
+import GF.Infra.Option
+import GF.Infra.Ident
+import GF.Infra.UseIO (justModuleName)
+import GF.System.Arch (ModTime)
+
+import qualified Transfer.InterpreterAPI as T
+
+import GF.Formalism.FCFG
+import qualified GF.OldParsing.ConvertGrammar as CnvOld -- OBSOLETE
+import qualified GF.Conversion.GFC as Cnv
+import qualified GF.Conversion.SimpleToFCFG as FCnv
+import qualified GF.Parsing.GFC as Prs
+
+import Control.Monad (mplus)
+import Data.List (nub,nubBy)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
+
+
+-- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished
+
+-- | multilingual state with grammars and options
+data ShellState = ShSt {
+  abstract   :: Maybe Ident ,        -- ^ pointer to actual abstract, if not empty st
+  concrete   :: Maybe Ident ,        -- ^ pointer to primary concrete
+  concretes  :: [((Ident,Ident),Bool)], -- ^ list of all concretes, and whether active
+  canModules :: CanonGrammar ,       -- ^ compiled abstracts and concretes
+  srcModules :: G.SourceGrammar ,    -- ^ saved resource modules
+  cfs        :: [(Ident,CF)] ,       -- ^ context-free grammars (small, no parameters, very over-generating)
+  abstracts  :: [(Ident,[Ident])],   -- ^ abstracts and their associated concretes
+  mcfgs      :: [(Ident, Cnv.MGrammar)], -- ^ MCFG, converted according to Ljunglöf (2004, ch 3)
+  fcfgs      :: [(Ident, FGrammar)], -- ^ FCFG, optimized MCFG by Krasimir Angelov
+  cfgs       :: [(Ident, Cnv.CGrammar)], -- ^ CFG, converted from mcfg 
+                                         -- (large, with parameters, no-so overgenerating)
+  pInfos     :: [(Ident, Prs.PInfo)], -- ^ parsing information (compiled mcfg&cfg grammars)
+  morphos    :: [(Ident,Morpho)],    -- ^ morphologies
+  treebanks  :: [(Ident,Treebank)],  -- ^ treebanks
+  probss     :: [(Ident,Probs)],     -- ^ probability distributions
+  gloptions  :: Options,             -- ^ global options
+  readFiles  :: [(String,(FilePath,ModTime))],-- ^ files read
+  absCats    :: [(G.Cat,(G.Context,
+                  [(G.Fun,G.Type)],
+                  [((G.Fun,Int),G.Type)]))],   -- ^ cats, (their contexts, 
+                                               -- functions to them,
+                                               -- functions on them)
+  statistics :: [Statistics],         -- ^ statistics on grammars
+  transfers  :: [(Ident,T.Env)],      -- ^ transfer modules
+  evalEnv    :: EEnv                  -- ^ evaluation environment
+  }                             
+
+type Treebank = Map.Map String [String] -- string, trees
+
+actualConcretes :: ShellState -> [((Ident,Ident),Bool)]
+actualConcretes sh = nub [((c,c),b) | 
+  Just a <- [abstract sh],
+  ((c,_),_) <- concretes sh, ----concretesOfAbstract sh a,
+  let b = True -----
+  ]
+
+concretesOfAbstract :: ShellState -> Ident -> [Ident]
+concretesOfAbstract sh a = [c | (b,cs) <- abstracts sh, b == a, c <- cs]
+
+data Statistics = 
+    StDepTypes Bool        -- ^ whether there are dependent types      
+  | StBoundVars [G.Cat]    -- ^ which categories have bound variables
+  ---                      -- etc
+   deriving (Eq,Ord)
+
+emptyShellState :: ShellState
+emptyShellState = ShSt {
+  abstract   = Nothing,
+  concrete   = Nothing,
+  concretes  = [],
+  canModules = M.emptyMGrammar,
+  srcModules = M.emptyMGrammar,
+  cfs        = [],
+  abstracts  = [],
+  mcfgs      = [],
+  fcfgs      = [],
+  cfgs       = [],
+  pInfos     = [],
+  morphos    = [],
+  treebanks  = [],
+  probss     = [],
+  gloptions  = noOptions,
+  readFiles  = [],
+  absCats    = [],
+  statistics = [],
+  transfers  = [],
+  evalEnv    = emptyEEnv
+  }
+
+optInitShellState :: Options -> ShellState
+optInitShellState os = addGlobalOptions os emptyShellState
+
+type Language = Ident
+
+language :: String -> Language
+language = identC
+
+prLanguage :: Language -> String
+prLanguage = prIdent
+
+-- | grammar for one language in a state, comprising its abs and cnc
+data StateGrammar = StGr {
+  absId    :: Ident,
+  cncId    :: Ident,
+  grammar  :: CanonGrammar,
+  cf       :: CF,
+  mcfg     :: Cnv.MGrammar,
+  fcfg     :: FGrammar,
+  cfg      :: Cnv.CGrammar,
+  pInfo    :: Prs.PInfo,
+  morpho   :: Morpho,
+  probs    :: Probs,
+  loptions :: Options
+  }
+
+emptyStateGrammar :: StateGrammar
+emptyStateGrammar = StGr {
+  absId    = identC "#EMPTY", ---
+  cncId    = identC "#EMPTY", ---
+  grammar  = M.emptyMGrammar,
+  cf       = emptyCF,
+  mcfg     = [],
+  fcfg     = ([], Map.empty),
+  cfg      = [],
+  pInfo    = Prs.buildPInfo [] ([], Map.empty) [],
+  morpho   = emptyMorpho,
+  probs    = emptyProbs,
+  loptions = noOptions
+  }
+
+-- analysing shell grammar into parts
+
+stateGrammarST    :: StateGrammar -> CanonGrammar
+stateCF           :: StateGrammar -> CF
+stateMCFG         :: StateGrammar -> Cnv.MGrammar
+stateFCFG         :: StateGrammar -> FGrammar
+stateCFG          :: StateGrammar -> Cnv.CGrammar
+statePInfo        :: StateGrammar -> Prs.PInfo
+stateMorpho       :: StateGrammar -> Morpho
+stateProbs        :: StateGrammar -> Probs
+stateOptions      :: StateGrammar -> Options
+stateGrammarWords :: StateGrammar -> [String]
+stateGrammarLang  :: StateGrammar -> (CanonGrammar, Ident)
+
+stateGrammarST = grammar
+stateCF        = cf
+stateMCFG      = mcfg
+stateFCFG      = fcfg
+stateCFG       = cfg
+statePInfo     = pInfo
+stateMorpho    = morpho
+stateProbs     = probs
+stateOptions   = loptions
+stateGrammarWords = allMorphoWords . stateMorpho
+stateGrammarLang st = (grammar st, cncId st)
+
+---- this should be computed at compile time and stored
+stateHasHOAS :: StateGrammar -> Bool
+stateHasHOAS = hasHOAS . stateGrammarST
+
+cncModuleIdST :: StateGrammar -> CanonGrammar
+cncModuleIdST = stateGrammarST
+
+-- | form a shell state from a canonical grammar
+grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState 
+grammar2shellState opts (gr,sgr) = 
+  updateShellState opts doParseAll Nothing emptyShellState ((0,sgr,gr,emptyEEnv),[]) --- is 0 safe?
+
+-- | update a shell state from a canonical grammar
+updateShellState :: Options -> NoParse -> Maybe Ident -> ShellState -> 
+   ((Int,G.SourceGrammar,CanonGrammar,EEnv),[(String,(FilePath,ModTime))]) ->
+   Err ShellState 
+updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do 
+  let cgr0 = M.updateMGrammar (canModules sh) gr
+
+  -- a0 = abstract of old state
+  -- a1 = abstract of compiled grammar
+
+  let a0 = abstract sh
+  a1 <- return $ case mcnc of
+    Just cnc -> err (const Nothing) Just $ M.abstractOfConcrete cgr0 cnc
+    _ -> M.greatestAbstract cgr0
+
+  -- abstr0 = a1 if it exists
+
+  let (abstr0,isNew) = case (a0,a1) of
+        (Just a,  Just b) | a /= b -> (a1, True)
+        (Nothing, Just _)          -> (a1, True)
+        _                          -> (a0, False)
+
+  let concrs0 = maybe [] (M.allConcretes cgr0) abstr0
+
+  let abstrs = nubBy (\ (x,_) (y,_) -> x == y) $ 
+               maybe id (\a -> ((a,concrs0):)) abstr0 $ abstracts sh
+               
+  let needed = nub $ concatMap (requiredCanModules (length abstrs == 1) cgr0) (maybe [] singleton abstr0 ++ concrs0)
+      purge  = nubBy (\x y -> fst x == fst y) . filter (\(m,mo) -> elem m needed && not (isIncompleteCanon (m,mo)))
+      
+  let cgr = M.MGrammar $ purge $ M.modules cgr0
+
+  let oldConcrs = map (snd . fst) (concretes sh)
+      newConcrs = maybe [] (M.allConcretes gr) abstr0
+      toRetain (c,v) = notElem c newConcrs
+  let complete m = case M.lookupModule gr m of
+        Ok mo -> not $ isIncompleteCanon (m,mo)
+        _ -> False
+        
+  let concrs = filter (\i -> complete i && elem i needed) $ nub $ newConcrs ++ oldConcrs
+      concr0 = ifNull Nothing (return . head) concrs
+      notInrts f = notElem f $ map fst rts
+      subcgr = unSubelimCanon cgr
+  cf's0 <- if (not (oElem (iOpt "docf") opts) &&       -- cf only built with -docf
+               (oElem noCF opts || not (hasHOAS cgr))) -- or HOAS, if not -nocf
+            then return $ map snd $ cfs sh
+            else mapM (canon2cf opts ign subcgr) newConcrs 
+  let cf's = zip newConcrs cf's0 ++ filter toRetain (cfs sh)
+
+  let morphs = [(c,mkMorpho subcgr c) | c <- newConcrs] ++ filter toRetain (morphos sh)
+  let probss = [] -----
+
+
+  let fromGFC       = snd . snd . Cnv.convertGFC opts
+      (mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs
+      gfcc          = canon2gfcc opts cgr ---- UTF8
+      fcfgs         = [(c,g) | c@(IC cn) <- concrs, Just g <- [lookFCFG gfcc (CId cn)]]
+      pInfos        = zipWith3 Prs.buildPInfo mcfgs (map snd fcfgs) cfgs
+      
+  let funs = funRulesOf cgr
+  let cats = allCatsOf cgr
+  let csi  = [(c,(co,
+                  [(fun,typ) | (fun,typ) <- funs, compatType tc typ], 
+                  funsOnTypeFs compatType funs tc))
+                                      | (c,co) <- cats, let tc = cat2val co c]
+  let deps = True ---- not $ null $ allDepCats cgr
+  let binds = [] ---- allCatsWithBind cgr 
+  let src = M.updateMGrammar (srcModules sh) sgr
+
+  return $ ShSt {
+    abstract   = abstr0, 
+    concrete   = concr0, 
+    concretes  = zip (zip concrs concrs) (repeat True),
+    canModules = cgr,
+    srcModules = src,
+    cfs        = cf's,
+    abstracts  = maybe [] (\a -> [(a,concrs)]) abstr0,
+    mcfgs      = zip concrs mcfgs,
+    fcfgs      = fcfgs,
+    cfgs       = zip concrs cfgs,
+    pInfos     = zip concrs pInfos,
+    morphos    = morphs,
+    treebanks  = treebanks sh,
+    probss     = zip concrs probss,
+    gloptions  = gloptions sh, --- opts, -- this would be command-line options
+    readFiles  = [ft | ft@(f,(_,_)) <- readFiles sh, notInrts f] ++ rts,
+    absCats    = csi,
+    statistics = [StDepTypes deps,StBoundVars binds],
+    transfers  = transfers sh,
+    evalEnv    = eenv
+    }            
+
+prShellStateInfo :: ShellState -> String
+prShellStateInfo sh = unlines [
+  "main abstract :    " +++ abstractName sh,
+  "main concrete :    " +++ maybe "(none)" P.prt (concrete sh),
+  "actual concretes : " +++ unwords (map (P.prt . fst . fst) (actualConcretes sh)),
+  "all abstracts :    " +++ unwords (map (P.prt . fst) (abstracts sh)),
+  "all concretes :    " +++ unwords (map (P.prt . fst . fst) (concretes sh)),
+  "canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))),
+  "source modules :   " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))),
+  "global options :   " +++ prOpts (gloptions sh),
+  "transfer modules : " +++ unwords (map (P.prt . fst) (transfers sh)),
+  "treebanks :        " +++ unwords (map (P.prt . fst) (treebanks sh))
+  ]
+
+abstractName :: ShellState -> String
+abstractName sh = maybe "(none)" P.prt (abstract sh)
+
+-- | throw away those abstracts that are not needed --- could be more aggressive
+filterAbstracts :: [Ident] -> CanonGrammar -> CanonGrammar
+filterAbstracts absts cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <- ms, needed m]) where
+  ms = M.modules cgr
+  needed (i,_) = elem i needs
+  needs   = [i | (i,M.ModMod m) <- ms, not (M.isModAbs m) || any (dep i) absts]
+  dep i a = elem i (ext mse a)
+  mse = [(i,me) | (i,M.ModMod m) <- ms, M.isModAbs m, me <- [M.extends m]]
+  ext es a = case lookup a es of
+    Just e -> a : concatMap (ext es) e  ---- FIX multiple exts
+    _ -> []
+
+purgeShellState :: ShellState -> ShellState
+purgeShellState sh = ShSt {
+  abstract   = abstr,
+  concrete   = concrete sh,
+  concretes  = concrs,
+  canModules = M.MGrammar $ filter complete $ purge $ M.modules $ canModules sh,
+  srcModules = M.emptyMGrammar,
+  cfs        = cfs sh,
+  abstracts  = maybe [] (\a -> [(a,map (snd . fst) concrs)]) abstr,
+  mcfgs      = mcfgs sh,
+  fcfgs      = fcfgs sh,
+  cfgs       = cfgs sh,
+  pInfos     = pInfos sh,
+  morphos    = morphos sh,
+  treebanks  = treebanks sh,
+  probss     = probss sh,
+  gloptions  = gloptions sh,
+  readFiles  = [],
+  absCats    = absCats sh,
+  statistics = statistics sh,
+  transfers  = transfers sh,
+  evalEnv    = emptyEEnv
+  }
+ where
+   abstr = abstract sh
+   concrs = [((a,i),b) | ((a,i),b) <- concretes sh, elem i needed]
+   isSingle = length (abstracts sh) == 1
+   needed = nub $ concatMap (requiredCanModules isSingle (canModules sh)) acncs
+   purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
+   acncs = maybe [] singleton abstr ++ map (snd . fst) (actualConcretes sh)
+   complete = not . isIncompleteCanon
+
+changeMain :: Maybe Ident -> ShellState -> Err ShellState
+changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) = 
+  return (ShSt Nothing Nothing [] ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee)
+changeMain 
+  (Just c) st@(ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) = 
+   case lookup c (M.modules ms) of 
+    Just _ -> do
+      a   <- M.abstractOfConcrete ms c
+      let cas = M.allConcretes ms a
+      let cs' = [((c,c),True) | c <- cas]
+      return (ShSt (Just a) (Just c) cs' ms ss cfs old_pis mcfgs fcfgs cfgs
+        pinfos mos tbs pbs os rs acs s trs ee) 
+    _ -> P.prtBad "The state has no concrete syntax named" c
+
+-- | form just one state grammar, if unique, from a canonical grammar
+grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar 
+grammar2stateGrammar opts gr = do 
+  st    <- grammar2shellState opts (gr,M.emptyMGrammar)
+  concr <- maybeErr "no concrete syntax" $ concrete st 
+  return $ stateGrammarOfLang st concr
+
+resourceOfShellState :: ShellState -> Maybe Ident
+resourceOfShellState = M.greatestResource . srcModules
+
+qualifTop :: StateGrammar -> G.QIdent -> G.QIdent
+qualifTop gr (_,c) = (absId gr,c)
+
+stateGrammarOfLang :: ShellState -> Language -> StateGrammar
+stateGrammarOfLang = stateGrammarOfLangOpt True
+
+stateGrammarOfLangOpt :: Bool -> ShellState -> Language -> StateGrammar
+stateGrammarOfLangOpt purg st0 l = StGr {
+  absId    = err (const (identC "Abs")) id  $ M.abstractOfConcrete allCan l, ---
+  cncId    = l,
+  grammar  = allCan,
+  cf       = maybe emptyCF id (lookup l (cfs st)),
+  mcfg     = maybe [] id $ lookup l $ mcfgs st,
+  fcfg     = maybe ([],Map.empty) id $ lookup l $ fcfgs st,
+  cfg      = maybe [] id $ lookup l $ cfgs st,
+  pInfo    = maybe (Prs.buildPInfo [] ([],Map.empty) []) id $ lookup l $ pInfos st,
+  morpho   = maybe emptyMorpho id (lookup l (morphos st)),
+  probs    = maybe emptyProbs id (lookup l (probss st)),
+  loptions = errVal noOptions $ lookupOptionsCan allCan
+  }
+ where
+   st = (if purg then purgeShellState else id) $ errVal st0 $ changeMain (Just l) st0
+   allCan = canModules st
+
+grammarOfLang :: ShellState -> Language -> CanonGrammar
+cfOfLang      :: ShellState -> Language -> CF
+morphoOfLang  :: ShellState -> Language -> Morpho
+probsOfLang   :: ShellState -> Language -> Probs
+optionsOfLang :: ShellState -> Language -> Options
+
+grammarOfLang st = stateGrammarST . stateGrammarOfLang st
+cfOfLang st      = stateCF        . stateGrammarOfLang st
+morphoOfLang st  = stateMorpho    . stateGrammarOfLang st
+probsOfLang st   = stateProbs     . stateGrammarOfLang st
+optionsOfLang st = stateOptions   . stateGrammarOfLang st
+
+removeLang :: Language -> ShellState -> ShellState
+removeLang lang st = purgeShellState $ st{concretes = concs1} where
+  concs1 = filter ((/=lang) . snd . fst) $ concretes st
+
+-- | the last introduced grammar, stored in options, is the default for operations
+firstStateGrammar :: ShellState -> StateGrammar
+firstStateGrammar st = errVal (stateAbstractGrammar st) $ do
+  concr <- maybeErr "no concrete syntax" $ concrete st 
+  return $ stateGrammarOfLang st concr
+
+mkStateGrammar :: ShellState -> Language -> StateGrammar
+mkStateGrammar = stateGrammarOfLang
+
+stateAbstractGrammar :: ShellState -> StateGrammar
+stateAbstractGrammar st = StGr {
+  absId    = maybe (identC "Abs") id (abstract st), ---
+  cncId    = identC "#Cnc", ---
+  grammar  = canModules st, ---- only abstarct ones
+  cf       = emptyCF,
+  mcfg     = [],
+  fcfg     = ([],Map.empty),
+  cfg      = [],
+  pInfo    = Prs.buildPInfo [] ([],Map.empty) [],
+  morpho   = emptyMorpho,
+  probs    = emptyProbs,
+  loptions = gloptions st ----
+  }
+
+
+-- analysing shell state into parts
+
+globalOptions                   :: ShellState -> Options
+allLanguages                    :: ShellState -> [Language]
+allTransfers                    :: ShellState -> [Ident]
+allCategories                   :: ShellState -> [G.Cat]
+allStateGrammars                :: ShellState -> [StateGrammar]
+allStateGrammarsWithNames       :: ShellState -> [(Language, StateGrammar)]
+allGrammarFileNames             :: ShellState -> [String]
+allActiveStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)]
+allActiveGrammars               :: ShellState -> [StateGrammar]
+
+globalOptions = gloptions
+--allLanguages  = map (fst . fst) . concretes
+allLanguages  = map (snd . fst) . actualConcretes
+allTransfers  = map fst . transfers
+allCategories = map fst . allCatsOf . canModules
+
+allStateGrammars = map snd . allStateGrammarsWithNames
+
+allStateGrammarsWithNames st = 
+  [(c, mkStateGrammar st c) | ((c,_),_) <- actualConcretes st]
+
+allGrammarFileNames st = [prLanguage c ++ ".gf" | ((c,_),_) <- actualConcretes st]
+
+allActiveStateGrammarsWithNames st =   
+  [(c, mkStateGrammar st c) | ((c,_),True) <- concretes st] --- actual
+
+allActiveGrammars = map snd . allActiveStateGrammarsWithNames
+
+pathOfModule :: ShellState -> Ident -> FilePath
+pathOfModule sh m = maybe "module not found" fst $ lookup (P.prt m) $ readFiles sh
+
+-- command-line option -lang=foo overrides the actual grammar in state
+grammarOfOptState :: Options -> ShellState -> StateGrammar
+grammarOfOptState opts st = 
+  maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $ 
+                                               getOptVal opts useLanguage
+
+languageOfOptState :: Options -> ShellState -> Maybe Language
+languageOfOptState opts st = 
+  maybe (concrete st) (return . language) $ getOptVal opts useLanguage
+
+-- | command-line option -cat=foo overrides the possible start cat of a grammar
+firstCatOpts :: Options -> StateGrammar -> CFCat
+firstCatOpts opts sgr = 
+  maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $ 
+    getOptVal opts firstCat
+
+-- | the first cat for random generation
+firstAbsCat :: Options -> StateGrammar -> G.QIdent
+firstAbsCat opts = cfCat2Cat . firstCatOpts opts
+
+-- | Gets the start category for the grammar from the options.
+--   If the startcat is not set in the options, we look
+--   for a flag in the grammar. If there is no flag in the
+--   grammar, S is returned.
+startCatStateOpts :: Options -> StateGrammar -> CFCat
+startCatStateOpts opts sgr = 
+    string2CFCat a (fromMaybe "S" (optsStartCat `mplus` grStartCat))
+  where optsStartCat = getOptVal opts gStartCat
+        grStartCat = getOptVal (stateOptions sgr) gStartCat
+        a = P.prt (absId sgr)
+
+-- | a grammar can have start category as option startcat=foo ; default is S 
+stateFirstCat :: StateGrammar -> CFCat
+stateFirstCat = startCatStateOpts noOptions
+
+stateIsWord :: StateGrammar -> String -> Bool
+stateIsWord sg = isKnownWord (stateMorpho sg)
+
+addProbs :: (Ident,Probs) -> ShellState -> Err ShellState
+addProbs ip@(lang,probs) sh = do
+  let gr = grammarOfLang sh lang
+  probs' <- checkGrammarProbs gr probs
+  let pbs' = (lang,probs') : filter ((/= lang) . fst) (probss sh)
+  return $ sh{probss = pbs'}
+
+addTransfer :: (Ident,T.Env) -> ShellState -> ShellState
+addTransfer it@(i,_) sh = 
+  sh {transfers = it : filter ((/= i) . fst) (transfers sh)}
+
+addTreebanks :: [(Ident,Treebank)] -> ShellState -> ShellState
+addTreebanks its sh = sh {treebanks = its ++ treebanks sh}
+
+findTreebank :: ShellState -> Ident -> Err Treebank
+findTreebank sh i = maybeErr "no treebank found" $ lookup i $ treebanks sh
+
+-- modify state
+
+type ShellStateOper = ShellState -> ShellState
+type ShellStateOperErr = ShellState -> Err ShellState
+
+reinitShellState :: ShellStateOper
+reinitShellState = const emptyShellState
+
+languageOn, languageOff :: Language -> ShellStateOper
+languageOn  = languageOnOff True
+languageOff = languageOnOff False
+
+languageOnOff :: Bool -> Language -> ShellStateOper
+---                                         __________ this is OBSOLETE
+languageOnOff b lang sh = sh {concretes = cs'} where
+  cs' = [if lang==l then (lc,b) else i | i@(lc@(l,c),_) <- concretes sh]
+
+changeOptions :: (Options -> Options) -> ShellStateOper
+---                                      __________ this is OBSOLETE
+changeOptions f sh = sh {gloptions = f (gloptions sh)}
+
+addGlobalOptions :: Options -> ShellStateOper
+addGlobalOptions = changeOptions . addOptions
+
+removeGlobalOptions :: Options -> ShellStateOper
+removeGlobalOptions = changeOptions . removeOptions
+

src-2.9/GF/Compile/Update.hs

@@ -0,0 +1,135 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Update
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.8 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Compile.Update (updateRes, buildAnyTree, combineAnyInfos, unifyAnyInfo,
+	       -- * these auxiliaries should be somewhere else 
+	       -- since they don't use the info types
+	       groupInfos, sortInfos, combineInfos, unifyInfos,
+	       tryInsert, unifAbsDefs, unifConstrs
+	      ) where
+
+import GF.Infra.Ident
+import GF.Grammar.Grammar
+import GF.Grammar.PrGrammar
+import GF.Infra.Modules
+
+import GF.Data.Operations
+
+import Data.List
+import Control.Monad
+
+-- | update a resource module by adding a new or changing an old definition
+updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar
+updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
+  upd (n,mod) 
+    | n /= m = (n,mod)
+    | n == m = case mod of
+       ModMod r -> (m,ModMod $ updateModule r i info)
+       _ -> (n,mod) --- no error msg
+
+-- | combine a list of definitions into a balanced binary search tree
+buildAnyTree :: [(Ident,Info)] -> Err (BinTree Ident Info)
+buildAnyTree ias = do
+  ias' <- combineAnyInfos ias
+  return $ buildTree ias'
+
+
+-- | unifying information for abstract, resource, and concrete
+combineAnyInfos :: [(Ident,Info)] -> Err [(Ident,Info)]
+combineAnyInfos = combineInfos unifyAnyInfo
+
+unifyAnyInfo :: Ident -> Info -> Info -> Err Info
+unifyAnyInfo c i j = errIn ("combining information for" +++ prt c) $ case (i,j) of
+  (AbsCat mc1 mf1, AbsCat mc2 mf2) -> 
+    liftM2 AbsCat (unifPerhaps mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs
+  (AbsFun mt1 md1, AbsFun mt2 md2) -> 
+    liftM2 AbsFun (unifPerhaps mt1 mt2) (unifAbsDefs md1 md2) -- adding defs
+
+  (ResParam mt1, ResParam mt2) -> liftM ResParam $ unifPerhaps mt1 mt2
+  (ResOper mt1 m1, ResOper mt2 m2) -> 
+    liftM2 ResOper (unifPerhaps mt1 mt2) (unifPerhaps m1 m2)
+
+  (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> 
+    liftM3 CncCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) (unifPerhaps mp1 mp2)
+  (CncFun m mt1 md1, CncFun _ mt2 md2) -> 
+    liftM2 (CncFun m) (unifPerhaps mt1 mt2) (unifPerhaps md1 md2) ---- adding defs
+-- for bw compatibility with unspecified printnames in old GF
+  (CncFun Nothing Nope (Yes pr),_) -> 
+    unifyAnyInfo c (CncCat Nope Nope (Yes pr)) j 
+  (_,CncFun Nothing Nope (Yes pr)) -> 
+    unifyAnyInfo c i (CncCat Nope Nope (Yes pr)) 
+
+  _ -> Bad $ "cannot unify informations in" ++++ show i ++++ "and" ++++ show j
+
+--- these auxiliaries should be somewhere else since they don't use the info types
+
+groupInfos :: Eq a => [(a,b)] -> [[(a,b)]]
+groupInfos = groupBy (\i j -> fst i == fst j)
+
+sortInfos :: Ord a => [(a,b)] -> [(a,b)]
+sortInfos = sortBy (\i j -> compare (fst i) (fst j))
+
+combineInfos :: Ord a => (a -> b -> b -> Err b) -> [(a,b)] -> Err [(a,b)]
+combineInfos f ris = do
+  let riss = groupInfos $ sortInfos ris
+  mapM (unifyInfos f) riss
+
+unifyInfos :: (a -> b -> b -> Err b) -> [(a,b)] -> Err (a,b)
+unifyInfos _ [] = Bad "empty info list"
+unifyInfos unif ris = do
+  let c = fst $ head ris
+  let infos = map snd ris
+  let ([i],is) = splitAt 1 infos 
+  info <- foldM (unif c) i is
+  return (c,info)
+
+
+tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) ->
+             BinTree a b -> (a,b) -> Err (BinTree a b)
+tryInsert unif indir tree z@(x, info) = case justLookupTree x tree of
+  Ok info0 -> do
+    info1 <- unif info info0
+    return $ updateTree (x,info1) tree 
+  _ -> return $ updateTree (x,indir info) tree
+
+{- ----
+case tree of
+ NT -> return $ BT (x, indir info) NT NT
+ BT c@(a,info0) left right 
+   | x < a  -> do
+       left' <- tryInsert unif indir left z    
+       return $ BT c left' right 
+   | x > a  -> do
+       right' <- tryInsert unif indir right z    
+       return $ BT c left right' 
+   | x == a -> do
+       info' <- unif info info0
+       return $ BT (x,info') left right
+-}
+
+--- addToMaybeList m c = maybe (return c) (\old -> return (c ++ old)) m
+
+unifAbsDefs :: Perh Term -> Perh Term -> Err (Perh Term)
+unifAbsDefs p1 p2 = case (p1,p2) of
+  (Nope, _)  -> return p2
+  (_, Nope)  -> return p1
+  (Yes (Eqs bs), Yes (Eqs ds)) -> return $ yes $ Eqs $ bs ++ ds --- order!
+  _ -> Bad "update conflict for definitions"
+
+unifConstrs :: Perh [Term] -> Perh [Term] -> Err (Perh [Term])
+unifConstrs p1 p2 = case (p1,p2) of
+  (Nope, _)  -> return p2
+  (_, Nope)  -> return p1
+  (Yes bs, Yes ds) -> return $ yes $ bs ++ ds
+  _ -> Bad "update conflict for constructors"

src-2.9/GF/Compile/Wordlist.hs

@@ -0,0 +1,108 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Wordlist
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 
+-- > CVS $Author: 
+-- > CVS $Revision: 
+--
+-- Compile a gfwl file (multilingual word list) to an abstract + concretes
+-----------------------------------------------------------------------------
+
+module GF.Compile.Wordlist (mkWordlist) where
+
+import GF.Data.Operations
+import GF.Infra.UseIO
+import Data.List
+import Data.Char
+import System.FilePath
+
+-- read File.gfwl, write File.gf (abstract) and a set of concretes
+-- return the names of the concretes
+
+mkWordlist :: FilePath -> IO [FilePath]
+mkWordlist file = do
+  s <- readFileIf file
+  let abs = dropExtension file
+  let (cnchs,wlist) = pWordlist abs $ filter notComment $ lines s
+  let (gr,grs) = mkGrammars abs cnchs wlist
+  let cncfs = [cnc ++ ".gf" | (cnc,_) <- cnchs]
+  mapM_ (uncurry writeFile) $ (abs ++ ".gf",gr) : zip cncfs grs
+  putStrLn $ "wrote " ++ unwords ((abs ++ ".gf") : cncfs)
+  return cncfs
+
+{-
+-- syntax of files, e.g.
+
+  # Svenska - Franska - Finska  -- names of concretes
+ 
+  berg  - montagne - vuori      -- word entry
+
+-- this creates:
+
+  cat S ; 
+  fun berg_S : S ; 
+  lin berg_S = {s = ["berg"]} ;
+  lin berg_S = {s = ["montagne"]} ;
+  lin berg_S = {s = ["vuori"]} ;
+
+-- support for different categories to be elaborated. The syntax it
+
+  Verb . klättra - grimper / escalader - kiivetä / kiipeillä
+
+-- notice that a word can have several alternative (separator /)
+-- and that an alternative can consist of several words
+-}
+
+type CncHeader = (String,String) -- module name, module header
+
+type Wordlist = [(String, [[String]])] -- cat, variants for each cnc
+
+
+pWordlist :: String -> [String] -> ([CncHeader],Wordlist)
+pWordlist abs ls = (headers,rules) where
+  (hs,rs) = span ((=="#") . take 1) ls
+  headers = map mkHeader $ chunks "-" $ filter (/="#") $ words $ concat hs
+  rules   = map (mkRule   . words) rs
+
+  mkHeader ws = case ws of
+    w:ws2 -> (w, unwords ("concrete":w:"of":abs:"=":ws2))
+  mkRule ws = case ws of
+    cat:".":vs -> (cat, mkWords vs)
+    _          -> ("S", mkWords ws)
+  mkWords = map (map unwords . chunks "/") . chunks "-"
+
+
+mkGrammars :: String -> [CncHeader] -> Wordlist -> (String,[String])
+mkGrammars ab hs wl = (abs,cncs) where
+  abs = unlines $ map unwords $
+    ["abstract",ab,"=","{"]:
+    cats ++
+    funs ++
+    [["}"]]
+
+  cncs = [unlines $ (h ++ " {") : map lin rs ++ ["}"] | ((_,h),rs) <- zip hs rss]
+
+  cats = [["cat",c,";"] | c <- nub $ map fst wl]
+  funs = [["fun", f , ":", c,";"] | (f,c,_) <- wlf]
+
+  wlf = [(ident f c, c, ws) | (c,ws@(f:_)) <- wl]
+
+  rss = [[(f, wss !! i) | (f,_,wss) <- wlf] | i <- [0..length hs - 1]]
+
+  lin (f,ss) = unwords ["lin", f, "=", "{s", "=", val ss, "}", ";"]
+
+  val ss = case ss of
+    [w] -> quote w
+    _   -> "variants {" ++ unwords (intersperse ";" (map quote ss)) ++ "}"
+
+  quote w = "[" ++ prQuotedString w ++ "]" 
+
+  ident f c = concat $ intersperse "_" $ words (head f) ++ [c]
+
+
+notComment s = not (all isSpace s) && take 2 s /= "--"
+

src-2.9/GF/Conversion/GFC.hs

@@ -0,0 +1,157 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/01 09:53:18 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.14 $
+--
+-- All conversions from GFC 
+-----------------------------------------------------------------------------
+
+module GF.Conversion.GFC
+    (module GF.Conversion.GFC,
+     SGrammar, EGrammar, MGrammar, CGrammar) where
+
+import GF.Infra.Option
+import GF.Canon.GFC (CanonGrammar)
+import GF.Infra.Ident (Ident, identC)
+import qualified GF.Infra.Modules as M
+
+import GF.Formalism.GCFG (Rule(..), Abstract(..))
+import GF.Formalism.SimpleGFC (decl2cat)
+import GF.Formalism.CFG (CFRule(..))
+import GF.Formalism.Utilities (symbol, name2fun)
+import GF.Conversion.Types
+
+import qualified GF.Conversion.GFCtoSimple as G2S
+import qualified GF.Conversion.SimpleToFinite as S2Fin
+import qualified GF.Conversion.RemoveSingletons as RemSing
+import qualified GF.Conversion.RemoveErasing as RemEra
+import qualified GF.Conversion.RemoveEpsilon as RemEps
+import qualified GF.Conversion.SimpleToMCFG as S2M
+import qualified GF.Conversion.MCFGtoCFG as M2C
+
+import GF.Infra.Print
+
+import GF.System.Tracing
+
+----------------------------------------------------------------------
+-- * GFC -> MCFG & CFG, using options to decide which conversion is used
+
+convertGFC :: Options -> (CanonGrammar, Ident)
+           -> (SGrammar, (EGrammar, (MGrammar, CGrammar)))
+convertGFC opts = \g -> let s = g2s g
+                            e = s2e s 
+                            m = e2m e
+                        in trace2 "Options" (show opts) (s, (e, (m, e2c e)))
+    where e2c = M2C.convertGrammar
+	  e2m = case getOptVal opts firstCat of
+		  Just cat -> flip erasing [identC cat]
+		  Nothing  -> flip erasing []
+	  s2e = case getOptVal opts gfcConversion of
+		  Just "strict"            -> strict
+		  Just "finite-strict"     -> strict
+		  Just "epsilon"           -> epsilon . nondet
+		  _                        -> nondet
+	  g2s = case getOptVal opts gfcConversion of
+		  Just "finite"            -> finite . simple
+		  Just "finite2"           -> finite . finite . simple
+		  Just "finite3"           -> finite . finite . finite . simple
+		  Just "singletons"        -> single . simple
+		  Just "finite-singletons" -> single . finite . simple
+		  Just "finite-strict"     -> finite . simple
+		  _                        -> simple
+
+          simple  = G2S.convertGrammar
+          strict  = S2M.convertGrammarStrict
+          nondet  = S2M.convertGrammarNondet
+          epsilon = RemEps.convertGrammar
+          finite  = S2Fin.convertGrammar
+          single  = RemSing.convertGrammar
+          erasing = RemEra.convertGrammar
+
+gfc2simple :: Options -> (CanonGrammar, Ident) -> SGrammar
+gfc2simple opts = fst . convertGFC opts 
+
+gfc2mcfg :: Options -> (CanonGrammar, Ident) -> MGrammar
+gfc2mcfg opts g = mcfg
+  where
+    (mcfg, _) = snd (snd (convertGFC opts g))
+
+gfc2cfg :: Options -> (CanonGrammar, Ident) -> CGrammar
+gfc2cfg opts g = cfg
+  where
+    (_, cfg) = snd (snd (convertGFC opts g))
+
+
+----------------------------------------------------------------------
+-- * single step conversions
+
+{-
+gfc2simple :: (CanonGrammar, Ident) -> SGrammar
+gfc2simple = G2S.convertGrammar
+
+simple2finite :: SGrammar -> SGrammar
+simple2finite = S2Fin.convertGrammar
+
+removeSingletons :: SGrammar -> SGrammar
+removeSingletons = RemSing.convertGrammar
+
+simple2mcfg_nondet :: SGrammar -> EGrammar
+simple2mcfg_nondet = 
+
+simple2mcfg_strict :: SGrammar -> EGrammar
+simple2mcfg_strict = S2M.convertGrammarStrict
+
+mcfg2cfg :: EGrammar -> CGrammar
+mcfg2cfg = M2C.convertGrammar
+
+removeErasing :: EGrammar -> [SCat] -> MGrammar
+removeErasing = RemEra.convertGrammar 
+
+removeEpsilon :: EGrammar -> EGrammar
+removeEpsilon = RemEps.convertGrammar 
+-}
+
+----------------------------------------------------------------------
+-- * converting to some obscure formats
+
+gfc2abstract :: (CanonGrammar, Ident) -> [Abstract SCat Fun]
+gfc2abstract gr = [ Abs (decl2cat decl) (map decl2cat decls) (name2fun name) |
+		    Rule (Abs decl decls name) _ <- G2S.convertGrammar gr ]
+
+abstract2skvatt :: [Abstract SCat Fun] -> String
+abstract2skvatt gr = skvatt_hdr ++ concatMap abs2pl gr
+    where abs2pl (Abs cat [] fun) = prtQuoted cat ++ " ---> " ++ 
+				    "\"" ++ prt fun ++ "\".\n"
+	  abs2pl (Abs cat cats fun) =
+	      prtQuoted cat ++ " ---> " ++
+	      "\"(" ++ prt fun ++ "\"" ++
+	      prtBefore ", \" \", " (map prtQuoted cats) ++ ", \")\".\n"
+
+cfg2skvatt :: CGrammar -> String
+cfg2skvatt gr = skvatt_hdr ++ concatMap cfg2pl gr
+    where cfg2pl (CFRule cat syms _name) =
+	      prtQuoted cat ++ " ---> " ++
+	      if null syms then "\"\".\n" else
+	      prtSep ", " (map (symbol prtQuoted prTok) syms) ++ ".\n"
+	  prTok tok = "\"" ++ tok ++ " \""
+
+skvatt_hdr = ":- use_module(library(skvatt)).\n" ++ 
+	     ":- use_module(library(utils), [repeat/1]).\n" ++
+	     "corpus(File, StartCat, Depth, Size) :- \n" ++
+	     "        set_flag(gendepth, Depth),\n" ++ 
+	     "        tell(File), repeat(Size),\n" ++
+	     "        generate_words(StartCat, String), format('~s~n~n', [String]),\n" ++
+	     "        write(user_error, '.'),\n" ++ 
+	     "        fail ; told.\n\n"
+
+prtQuoted :: Print a => a -> String
+prtQuoted a = "'" ++ prt a ++ "'"
+
+
+
+

src-2.9/GF/Conversion/GFCtoSimple.hs

@@ -0,0 +1,175 @@
+---------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/07 11:24:51 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.15 $
+--
+-- Converting GFC to SimpleGFC
+--
+-- the conversion might fail if the GFC grammar has dependent or higher-order types,
+-- or if the grammar contains bound pattern variables
+-- (use -optimize=values/share/none when importing)
+--
+-- TODO: lift all functions to the 'Err' monad
+-----------------------------------------------------------------------------
+
+module GF.Conversion.GFCtoSimple
+    (convertGrammar) where
+
+import qualified GF.Canon.AbsGFC as A
+import qualified GF.Infra.Ident as I
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC 
+import GF.Formalism.Utilities
+import GF.Conversion.Types
+
+import GF.UseGrammar.Linear (expandLinTables)
+import GF.Canon.GFC (CanonGrammar)
+import GF.Canon.MkGFC (grammar2canon)
+import GF.Canon.Subexpressions (unSubelimCanon)
+import qualified GF.Canon.Look as Look (lookupLin, allParamValues, lookupLincat)
+import qualified GF.Canon.CMacros as CMacros (defLinType)
+import GF.Data.Operations (err, errVal)
+--import qualified Modules as M
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+----------------------------------------------------------------------
+
+type Env = (CanonGrammar, I.Ident)
+
+convertGrammar :: Env -> SGrammar
+convertGrammar (g,i) = trace2 "GFCtoSimple - concrete language" (prt (snd gram)) $
+		        tracePrt "GFCtoSimple - simpleGFC rules" (prt . length) $
+		         [ convertAbsFun gram fun typing |
+			  A.Mod (A.MTAbs modname) _ _ _ defs <- modules,
+			  A.AbsDFun fun typing _ <- defs ]
+    where A.Gr modules = grammar2canon (fst gram)
+          gram = (unSubelimCanon g,i)
+
+convertAbsFun :: Env -> I.Ident -> A.Exp -> SRule
+convertAbsFun gram fun typing = -- trace2 "GFCtoSimple - converting function" (prt fun) $
+                                Rule abs cnc
+    where abs = convertAbstract [] fun typing
+	  cnc = convertConcrete gram abs
+
+----------------------------------------------------------------------
+-- abstract definitions
+
+convertAbstract :: [SDecl] -> Fun -> A.Exp -> Abstract SDecl Name
+convertAbstract env fun (A.EProd x a b) 
+    = convertAbstract (convertAbsType x' [] a : env) fun b
+    where x' = if x==I.identC "h_" then anyVar else x
+convertAbstract env fun a 
+    = Abs (convertAbsType anyVar [] a) (reverse env) name
+    where name = Name fun [ Unify [n] | n <- [0 .. length env-1] ]
+
+convertAbsType :: Var -> [FOType SCat] -> A.Exp -> SDecl
+convertAbsType x args (A.EProd _ a b) = convertAbsType x (convertType [] a : args) b
+convertAbsType x args a = Decl x (reverse args ::--> convertType [] a)
+
+convertType :: [TTerm] -> A.Exp -> FOType SCat
+convertType args (A.EApp a b) = convertType (convertExp [] b : args) a
+convertType args (A.EAtom at) = convertCat at ::@ reverse args
+convertType args (A.EProd _ _ b) = convertType args b ---- AR 7/10 workaround
+convertType args exp          = error $ "GFCtoSimple.convertType: " ++ prt exp
+
+{- Exp from GF/Canon/GFC.cf:
+EApp.   Exp1 ::= Exp1 Exp2 ;
+EProd.  Exp  ::= "(" Ident ":" Exp ")" "->" Exp ;
+EAbs.   Exp  ::= "\\" Ident "->" Exp ;
+EAtom.  Exp2 ::= Atom ;
+EData.  Exp2 ::= "data" ;
+-}
+
+convertExp :: [TTerm] -> A.Exp -> TTerm
+convertExp args (A.EAtom at) = convertAtom args at
+convertExp args (A.EApp a b) = convertExp (convertExp [] b : args) a
+convertExp args exp          = error $ "GFCtoSimple.convertExp: " ++ prt exp
+
+convertAtom :: [TTerm] -> A.Atom -> TTerm
+convertAtom args (A.AC con) = con :@ reverse args
+-- A.AD: is this correct???
+convertAtom args (A.AD con) = con :@ args
+convertAtom []   (A.AV var) = TVar var
+convertAtom args atom       = error $ "GFCtoSimple.convertAtom: " ++ prt args ++ " " ++ show atom
+
+convertCat :: A.Atom -> SCat
+convertCat (A.AC (A.CIQ _ cat)) = cat
+convertCat atom                 = error $ "GFCtoSimple.convertCat: " ++ show atom
+
+----------------------------------------------------------------------
+-- concrete definitions
+
+convertConcrete :: Env -> Abstract SDecl Name -> Concrete SLinType (Maybe STerm)
+convertConcrete gram (Abs decl args name) = Cnc ltyp largs term
+    where term = fmap (convertTerm gram . expandTerm gram) $ lookupLin gram $ name2fun name
+	  ltyp : largs = map (convertCType gram . lookupCType gram) (decl : args)
+
+expandTerm :: Env -> A.Term -> A.Term
+expandTerm gram term = -- tracePrt "expanded term" prt $
+		       err error id $ expandLinTables (fst gram) $
+		       -- tracePrt "initial term" prt $ 
+		       term
+
+convertCType :: Env -> A.CType -> SLinType
+convertCType gram (A.RecType rec) = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ]
+convertCType gram (A.Table pt vt) = TblT (enumerateTerms Nothing (convertCType gram pt)) (convertCType gram vt)
+convertCType gram ct@(A.Cn con)   = ConT $ map (convertTerm gram) $ groundTerms gram ct
+convertCType gram (A.TStr)        = StrT
+convertCType gram (A.TInts n)     = error "GFCtoSimple.convertCType: cannot handle 'TInts' constructor"
+
+convertTerm :: Env -> A.Term -> STerm
+convertTerm gram (A.Arg arg)       = convertArgVar arg
+convertTerm gram (A.Par con terms) = con :^ map (convertTerm gram) terms
+-- convertTerm gram (A.LI var)        = Var var
+convertTerm gram (A.R rec)         = Rec [ (lbl, convertTerm gram term) | A.Ass lbl term <- rec ]
+convertTerm gram (A.P term lbl)    = convertTerm gram term +. lbl
+convertTerm gram (A.V ctype terms) = Tbl [ (convertTerm gram pat, convertTerm gram term) |
+					  (pat, term) <- zip (groundTerms gram ctype) terms ]
+convertTerm gram (A.T ctype tbl)   = Tbl [ (convertPatt pat, convertTerm gram term) |
+					   A.Cas pats term <- tbl, pat <- pats ]
+convertTerm gram (A.S term sel)    = convertTerm gram term :! convertTerm gram sel
+convertTerm gram (A.C term1 term2) = convertTerm gram term1 ?++ convertTerm gram term2
+convertTerm gram (A.FV terms)      = variants (map (convertTerm gram) terms)
+convertTerm gram (A.E)             = Empty
+convertTerm gram (A.K (A.KS tok))  = Token tok
+-- 'pre' tokens are converted to variants (over-generating):
+convertTerm gram (A.K (A.KP strs vars))
+                                   = variants $ map conc $ strs : [ vs | A.Var vs _ <- vars ]
+    where conc [] = Empty
+	  conc ts = foldr1 (?++) $ map Token ts
+convertTerm gram (A.I con)         = error "GFCtoSimple.convertTerm: cannot handle 'I' constructor"
+convertTerm gram (A.EInt int)      = error "GFCtoSimple.convertTerm: cannot handle 'EInt' constructor"
+
+convertArgVar :: A.ArgVar -> STerm
+convertArgVar (A.A cat nr)           = Arg (fromInteger nr) cat emptyPath
+convertArgVar (A.AB cat bindings nr) = Arg (fromInteger nr) cat emptyPath
+
+convertPatt (A.PC con pats) = con :^ map convertPatt pats
+-- convertPatt (A.PV x)        = Var x
+-- convertPatt (A.PW)          = Wildcard
+convertPatt (A.PR rec)      = Rec [ (lbl, convertPatt pat) | A.PAss lbl pat <- rec ]
+convertPatt (A.PI n)        = error "GFCtoSimple.convertPatt: cannot handle 'PI' constructor"
+convertPatt p               = error $ "GFCtoSimple.convertPatt: cannot handle " ++ show p
+
+----------------------------------------------------------------------
+
+lookupLin :: Env -> Fun -> Maybe A.Term
+lookupLin gram fun = err fail Just $
+		     Look.lookupLin (fst gram) (A.CIQ (snd gram) fun)
+
+lookupCType :: Env -> SDecl -> A.CType
+lookupCType env decl
+    = errVal CMacros.defLinType $ 
+      Look.lookupLincat (fst env) (A.CIQ (snd env) (decl2cat decl))
+
+groundTerms :: Env -> A.CType -> [A.Term]
+groundTerms gram ctype = err error id $
+			 Look.allParamValues (fst gram) ctype
+

src-2.9/GF/Conversion/Haskell.hs

@@ -0,0 +1,71 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/08/11 14:11:46 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Converting/Printing different grammar formalisms in Haskell-readable format
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.Haskell where
+
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC
+import GF.Formalism.MCFG
+import GF.Formalism.CFG
+import GF.Formalism.Utilities
+import GF.Conversion.Types
+import GF.Data.Operations ((++++), (+++++))
+import GF.Infra.Print
+
+import Data.List (intersperse)
+
+-- | SimpleGFC to Haskell
+prtSGrammar :: SGrammar -> String
+prtSGrammar rules = "-- Simple GFC grammar as a Haskell file" ++++
+                    "-- Autogenerated from the Grammatical Framework" +++++
+                    "import GF.Formalism.GCFG" ++++
+                    "import GF.Formalism.SimpleGFC" ++++
+                    "import GF.Formalism.Utilities" ++++
+                    "import GF.Canon.AbsGFC (CIdent(..), Label(..))" ++++
+                    "import GF.Infra.Ident (Ident(..))" +++++
+                    "grammar :: SimpleGrammar Ident (NameProfile Ident) String" ++++
+                    "grammar = \n\t[ " ++ 
+                    concat (intersperse "\n\t, " (map show rules)) ++ "\n\t]\n\n"
+
+-- | MCFG to Haskell
+prtMGrammar :: MGrammar -> String
+prtMGrammar rules = "-- Multiple context-free grammar as a Haskell file" ++++
+		    "-- Autogenerated from the Grammatical Framework" +++++
+		    "import GF.Formalism.GCFG" ++++
+		    "import GF.Formalism.MCFG" ++++
+                    "import GF.Formalism.Utilities" +++++
+                    "grammar :: MCFGrammar String (NameProfile String) String String" ++++
+		    "grammar = \n\t[ " ++ 
+		    concat (intersperse "\n\t, " (map prtMRule rules)) ++ "\n\t]\n\n" 
+    where prtMRule (Rule (Abs cat cats (Name fun profiles)) (Cnc lcat lcats lins)) 
+	      = show (Rule (Abs (prt cat) (map prt cats) (Name (prt fun) (map cnvProfile profiles)))
+		           (Cnc (map prt lcat) (map (map prt) lcats) (map cnvLin lins)))
+	  cnvLin (Lin lbl syms) = Lin (prt lbl) (map (mapSymbol prtMArg id) syms)
+	  prtMArg  (cat, lbl, nr) = (prt cat, prt lbl, nr)
+
+-- | CFG to Haskell
+prtCGrammar :: CGrammar -> String
+prtCGrammar rules = "-- Context-free grammar as a Haskell file" ++++
+		    "-- autogenerated from the Grammatical Framework" +++++
+		    "import GF.Formalism.CFG" ++++ 
+                    "import GF.Formalism.Utilities" ++++
+                    "\ngrammar :: CFGrammar String (NameProfile String) String" ++++
+		    "grammar = \n\t[ " ++ 
+		    concat (intersperse "\n\t, " (map prtCRule rules)) ++ "\n\t]\n\n" 
+    where prtCRule (CFRule cat syms (Name fun profiles)) 
+	      = show (CFRule (prt cat) (map (mapSymbol prt id) syms) 
+	                     (Name (prt fun) (map cnvProfile profiles)))
+
+cnvProfile (Unify args) = Unify args
+cnvProfile (Constant forest) = Constant (fmap prt forest)

src-2.9/GF/Conversion/MCFGtoCFG.hs

@@ -0,0 +1,53 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/09 09:28:43 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.6 $
+--
+-- Converting MCFG grammars to (possibly overgenerating) CFG
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.MCFGtoCFG
+    (convertGrammar) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import Control.Monad
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+import GF.Formalism.MCFG
+import GF.Formalism.CFG
+import GF.Conversion.Types
+
+----------------------------------------------------------------------
+-- * converting (possibly erasing) MCFG grammars
+
+convertGrammar :: EGrammar -> CGrammar
+convertGrammar gram = tracePrt "MCFGtoCFG - context-free rules" (prt.length) $
+		       concatMap convertRule gram
+
+convertRule :: ERule -> [CRule]
+convertRule (Rule (Abs cat args (Name fun mprofile)) (Cnc _ _ record)) 
+    = [ CFRule (CCat cat lbl) rhs (Name fun profile) |
+	Lin lbl lin <- record,
+	let rhs = map (mapSymbol convertArg id) lin,
+	let cprofile = map (Unify . argPlaces lin) [0 .. length args-1],
+	let profile = mprofile `composeProfiles` cprofile
+      ]
+
+convertArg :: (ECat, ELabel, Int) -> CCat
+convertArg (cat, lbl, _) = CCat cat lbl
+
+argPlaces :: [Symbol (cat, lbl, Int) tok] -> Int -> [Int]
+argPlaces lin nr  = [ place | (nr', place) <- zip linArgs [0..], nr == nr' ]
+    where linArgs = [ nr' | (_, _, nr') <- filterCats lin ]
+
+
+
+

src-2.9/GF/Conversion/MCFGtoFCFG.hs

@@ -0,0 +1,51 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/09 09:28:43 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.6 $
+--
+-- Converting MCFG grammars to equivalent optimized FCFG
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.MCFGtoFCFG
+    (convertGrammar) where
+
+import Control.Monad
+import List (elemIndex)
+import Array
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+import GF.Formalism.MCFG
+import GF.Formalism.FCFG
+import GF.Conversion.Types
+import GF.Data.SortedList (nubsort)
+
+import GF.Infra.Print
+
+----------------------------------------------------------------------
+-- * converting MCFG to optimized FCFG
+
+convertGrammar :: MGrammar -> FGrammar
+convertGrammar gram = [ FRule (Abs (fcat cat) (map fcat cats) name) (fcnc cnc) |
+                        Rule (Abs cat cats name) cnc <- gram ]
+    where mcats = nubsort [ mc | Rule (Abs mcat mcats _) _ <- gram, mc <- mcat:mcats ]
+
+          fcat mcat@(MCat (ECat scat ecns) mlbls) 
+              = case elemIndex mcat mcats of
+                  Just catid -> FCat catid scat mlbls ecns
+                  Nothing -> error ("MCFGtoFCFG.fcat " ++ prt mcat)
+
+          fcnc (Cnc  _ arglbls lins) = listArray (0, length lins-1) (map flin lins)
+              where flin (Lin _ syms) = listArray (0, length syms-1) (map fsym syms)
+                    fsym (Tok tok) = FSymTok tok
+                    fsym (Cat (cat,lbl,arg)) = FSymCat (fcat cat) (flbl arg lbl) arg
+                    flbl arg lbl = case elemIndex lbl (arglbls !! arg) of
+                                     Just lblid -> lblid
+                                     Nothing -> error ("MCFGtoFCFG.flbl " ++ prt arg ++ " " ++ prt lbl)
+ 

src-2.9/GF/Conversion/Prolog.hs

@@ -0,0 +1,205 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/14 09:51:18 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.4 $
+--
+-- Converting/Printing different grammar formalisms in Prolog-readable format
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.Prolog (prtSGrammar, prtSMulti, prtSHeader, prtSRule,
+                             prtMGrammar, prtMMulti, prtMHeader, prtMRule,
+                             prtCGrammar, prtCMulti, prtCHeader, prtCRule) where
+
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC
+import GF.Formalism.MCFG
+import GF.Formalism.CFG
+import GF.Formalism.Utilities
+import GF.Conversion.Types
+import qualified GF.Conversion.GFC as Cnv
+
+import GF.Data.Operations ((++++), (+++++))
+import GF.Infra.Print
+import qualified GF.Infra.Modules as Mod
+import qualified GF.Infra.Option as Option
+import GF.Data.Operations (okError)
+import GF.Canon.AbsGFC (Flag(..))
+import GF.Canon.GFC (CanonGrammar)
+import GF.Infra.Ident (Ident(..))
+
+import Data.Maybe (maybeToList, listToMaybe)
+import Data.Char (isLower, isAlphaNum)
+
+import GF.System.Tracing
+
+----------------------------------------------------------------------
+-- | printing multiple languages at the same time
+
+prtSMulti, prtMMulti, prtCMulti :: Option.Options -> CanonGrammar -> String
+prtSMulti = prtMulti prtSHeader prtSRule Cnv.gfc2simple "gfc_"
+prtMMulti = prtMulti prtMHeader prtMRule Cnv.gfc2mcfg "mcfg_"
+prtCMulti = prtMulti prtCHeader prtCRule Cnv.gfc2cfg "cfg_"
+
+-- code and ideas stolen from GF.CFGM.PrintCFGrammar
+
+prtMulti prtHeader prtRule conversion prefix opts gr
+    = prtHeader ++++ unlines
+      [ "\n\n" ++ prtLine ++++
+        "%% Language module: " ++ prtQ langmod +++++
+        unlines (map (prtRule langmod) rules) |
+        lang <- maybe [] (Mod.allConcretes gr) (Mod.greatestAbstract gr),
+        let Mod.ModMod (Mod.Module{Mod.flags=fs}) = okError (Mod.lookupModule gr lang),
+        let cnvopts = Option.Opts $ map Option.gfcConversion $ getFlag fs "conversion",
+        let rules = conversion cnvopts (gr, lang),
+        let langmod = (let IC lg = lang in prefix ++ lg) ]
+
+getFlag :: [Flag] -> String -> [String]
+getFlag fs x = [v | Flg (IC k) (IC v) <- fs, k == x]
+
+----------------------------------------------------------------------
+-- | SimpleGFC to Prolog
+--
+-- assumes that the profiles in the Simple GFC names are trivial
+prtSGrammar :: SGrammar -> String
+prtSGrammar rules = prtSHeader +++++ unlines (map (prtSRule "") rules)
+
+prtSHeader :: String
+prtSHeader = prtLine ++++
+             "%% Simple GFC grammar in Prolog-readable format" ++++
+             "%% Autogenerated from the Grammatical Framework" +++++
+             "%% The following predicate is defined:" ++++
+             "%% \t rule(Fun, Cat, c(Cat,...), LinTerm)"
+
+prtSRule :: String -> SRule -> String
+prtSRule lang (Rule (Abs cat cats (Name fun _prof)) (Cnc _ _ mterm)) 
+    = (if null lang then "" else prtQ lang ++ " : ") ++ 
+      prtFunctor "rule" [plfun, plcat, plcats, plcnc] ++ "."
+    where plfun  = prtQ fun
+          plcat  = prtSDecl cat
+          plcats = prtFunctor "c" (map prtSDecl cats) 
+	  plcnc  = "\n\t" ++ prtSTerm (maybe Empty id mterm)
+
+prtSTerm (Arg n c p)    = prtFunctor "arg" [prtQ c, prt (n+1), prtSPath p]
+-- prtSTerm (c :^ [])   = prtQ c
+prtSTerm (c :^ ts)      = prtOper "^" (prtQ c) (prtPList (map prtSTerm ts))
+prtSTerm (Rec rec)      = prtFunctor "rec" [prtPList [ prtOper "=" (prtQ l) (prtSTerm t) | (l, t) <- rec ]]
+prtSTerm (Tbl tbl)      = prtFunctor "tbl" [prtPList [ prtOper "=" (prtSTerm p) (prtSTerm t) | (p, t) <- tbl ]]
+prtSTerm (Variants ts)  = prtFunctor "variants" [prtPList (map prtSTerm ts)]
+prtSTerm (t1 :++ t2)    = prtOper "+" (prtSTerm t1) (prtSTerm t2)
+prtSTerm (Token t)      = prtFunctor "tok" [prtQ t]
+prtSTerm (Empty)        = "empty"
+prtSTerm (term :. lbl)  = prtOper "*" (prtSTerm term) (prtQ lbl)
+prtSTerm (term :! sel)  = prtOper "/" (prtSTerm term) (prtSTerm sel)
+-- prtSTerm (Wildcard)  = "wildcard"
+-- prtSTerm (Var var)   = prtFunctor "var" [prtQ var]
+
+prtSPath (Path path) = prtPList (map (either prtQ prtSTerm) path)
+
+prtSDecl (Decl var typ) | var == anyVar = prtSAbsType typ
+                        | otherwise     = "_" ++ prtVar var ++ ":" ++ prtSAbsType typ
+
+
+prtSAbsType ([]   ::--> typ) = prtSFOType typ
+prtSAbsType (args ::--> typ) = prtOper ":->" (prtPList (map prtSFOType args)) (prtSFOType typ)
+
+prtSFOType (cat ::@ args) = prtFunctor (prtQ cat) (map prtSTTerm args)
+
+prtSTTerm (con :@ args) = prtFunctor (prtQ con) (map prtSTTerm args)
+prtSTTerm (TVar var)    = "_" ++ prtVar var
+
+----------------------------------------------------------------------
+-- | MCFG to Prolog
+prtMGrammar :: MGrammar -> String
+prtMGrammar rules = prtMHeader +++++ unlines (map (prtMRule "") rules)
+
+prtMHeader :: String
+prtMHeader = prtLine ++++
+             "%% Multiple context-free grammar in Prolog-readable format" ++++
+             "%% Autogenerated from the Grammatical Framework" +++++
+             "%% The following predicate is defined:" ++++
+             "%% \t rule(Profile, Cat, c(Cat,...), [Lbl=Symbols,...])" 
+
+prtMRule :: String -> MRule -> String
+prtMRule lang (Rule (Abs cat cats name) (Cnc _lcat _lcats lins)) 
+    = (if null lang then "" else prtQ lang ++ " : ") ++ 
+      prtFunctor "rule" [plname, plcat, plcats, pllins] ++ "."
+    where plname = prtName name
+          plcat  = prtQ cat
+          plcats = prtFunctor "c" (map prtQ cats) 
+          pllins = "\n\t[ " ++ prtSep "\n\t, " (map prtMLin lins) ++ " ]"
+
+prtMLin (Lin lbl lin) = prtOper "=" (prtQ lbl) (prtPList (map prtMSymbol lin))
+
+prtMSymbol (Cat (cat, lbl, nr)) = prtFunctor "arg" [prtQ cat, show (nr+1), prtQ lbl]
+prtMSymbol (Tok tok) = prtFunctor "tok" [prtQ tok]
+
+----------------------------------------------------------------------
+-- | CFG to Prolog
+prtCGrammar :: CGrammar -> String
+prtCGrammar rules = prtCHeader +++++ unlines (map (prtCRule "") rules)
+
+prtCHeader :: String
+prtCHeader = prtLine ++++
+             "%% Context-free grammar in Prolog-readable format" ++++
+             "%% Autogenerated from the Grammatical Framework" +++++
+             "%% The following predicate is defined:" ++++
+             "%% \t rule(Profile, Cat, [Symbol,...])"
+
+prtCRule :: String -> CRule -> String
+prtCRule lang (CFRule cat syms name)
+    = (if null lang then "" else prtQ lang ++ " : ") ++ 
+      prtFunctor "cfgrule" [plname, plcat, plsyms] ++ "."
+    where plname = prtName name
+          plcat  = prtQ cat
+          plsyms = prtPList (map prtCSymbol syms) 
+
+prtCSymbol (Cat cat) = prtFunctor "cat" [prtQ cat]
+prtCSymbol (Tok tok) = prtFunctor "tok" [prtQ tok]
+
+----------------------------------------------------------------------
+-- profiles, quoted strings and more
+
+prtFunctor f xs = f ++ if null xs then "" else "(" ++ prtSep ", " xs ++ ")"
+prtPList     xs = "[" ++ prtSep ", " xs ++ "]"
+prtOper   f x y = "(" ++ x ++ " " ++ f ++ " " ++ y ++ ")"
+
+prtName name@(Name fun profiles)
+    | name == coercionName = "1"
+    | and (zipWith (==) profiles (map (Unify . return) [0..])) = prtQ fun
+    | otherwise = prtFunctor (prtQ fun) (map prtProfile profiles) 
+
+prtProfile (Unify []) = " ? "
+prtProfile (Unify args) = foldr1 (prtOper "=") (map (show . succ) args)
+prtProfile (Constant forest) = prtForest forest
+
+prtForest (FMeta) = " ? "
+prtForest (FNode fun [fs]) = prtFunctor (prtQ fun) (map prtForest fs)
+prtForest (FNode fun fss) = prtPList [ prtFunctor (prtQ fun) (map prtForest fs) |
+                                       fs <- fss ]
+
+prtQ atom = prtQStr (prt atom)
+
+prtQStr atom@(x:xs) 
+    | isLower x && all isAlphaNumUnder xs = atom
+    where isAlphaNumUnder '_' = True
+          isAlphaNumUnder x = isAlphaNum x
+prtQStr atom =  "'" ++ concatMap esc (prt atom) ++ "'"
+    where esc '\'' = "\\'"
+          esc '\n' = "\\n"
+          esc '\t' = "\\t"
+          esc c = [c]
+
+prtVar var = reprime (prt var)
+    where reprime "" = ""
+          reprime ('\'' : cs) = "_0" ++ reprime cs
+          reprime (c:cs) = c : reprime cs
+
+prtLine = replicate 70 '%'
+
+

src-2.9/GF/Conversion/RemoveEpsilon.hs

@@ -0,0 +1,46 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 08:11:32 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.3 $
+--
+-- Removing epsilon linearizations from MCF grammars
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.RemoveEpsilon where
+--    (convertGrammar) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import Control.Monad
+import Data.List (mapAccumL)
+import Data.Maybe (mapMaybe)
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+import GF.Formalism.MCFG
+import GF.Conversion.Types
+import GF.Data.Assoc
+import GF.Data.SortedList
+import GF.Data.GeneralDeduction
+
+convertGrammar :: EGrammar -> EGrammar
+convertGrammar grammar = trace2 "RemoveEpsilon: initialEmpties" (prt initialEmpties) $
+			 trace2 "RemoveEpsilon: emptyCats" (prt emptyCats) $
+			 grammar 
+    where initialEmpties  = nubsort [ (cat, lbl)  | 
+				      Rule (Abs cat _ _) (Cnc _ _ lins) <- grammar,
+				      Lin lbl [] <- lins ]
+	  emptyCats       = limitEmpties initialEmpties
+	  limitEmpties es = if es==es' then es else limitEmpties es'
+	      where es'   = nubsort [ (cat, lbl) | Rule (Abs cat _ _) (Cnc _ _ lins) <- grammar, 
+				      Lin lbl rhs <- lins,
+				      all (symbol (\(c,l,n) -> (c,l) `elem` es) (const False)) rhs ]
+
+
+

src-2.9/GF/Conversion/RemoveErasing.hs

@@ -0,0 +1,113 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/09 09:28:44 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.3 $
+--
+-- Removing erasingness from MCFG grammars (as in Ljunglöf 2004, sec 4.5.1)
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.RemoveErasing
+    (convertGrammar) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import Control.Monad 
+import Data.List (mapAccumL)
+import Data.Maybe (mapMaybe)
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+import GF.Formalism.MCFG
+import GF.Conversion.Types
+import GF.Data.Assoc
+import GF.Data.SortedList
+import GF.Data.GeneralDeduction
+
+convertGrammar :: EGrammar -> [SCat] -> MGrammar
+convertGrammar grammar starts = newGrammar
+    where newGrammar  = tracePrt "RemoveErasing - nonerasing rules" (prt . length) $
+			[ rule | NR rule <- chartLookup finalChart True ]
+	  finalChart  = tracePrt "RemoveErasing - nonerasing cats" 
+			(prt . length . flip chartLookup False) $
+			buildChart keyof [newRules rulesByCat] $
+			tracePrt "RemoveErasing - initial ne-cats" (prt . length) $
+			initialCats
+	  initialCats = trace2 "RemoveErasing - starting categories" (prt starts) $
+			if null starts 
+			  then trace2 "RemoveErasing" "initialCatsBU" $
+			       initialCatsBU rulesByCat
+			  else trace2 "RemoveErasing" ("initialCatsTD: " ++ prt starts) $
+			       initialCatsTD rulesByCat starts
+	  rulesByCat  = trace2 "RemoveErasing - erasing rules" (prt $ length grammar) $
+			accumAssoc id [ (cat, rule) | rule@(Rule (Abs cat _ _) _) <- grammar ]
+
+data Item r c = NR r | NC c deriving (Eq, Ord, Show)
+
+keyof (NR _) = True
+keyof (NC _) = False
+
+newRules grammar chart (NR (Rule (Abs _ cats _) _))
+    = [ NC cat | cat@(MCat _ lbls) <- cats, not (null lbls) ]
+newRules grammar chart (NC newCat@(MCat cat lbls))
+    = do Rule (Abs _ args (Name fun profile)) (Cnc _ _ lins0) <- grammar ? cat
+
+         lins <- selectLins lins0 lbls 
+	 -- let lins = [ lin | lin@(Lin lbl _) <- lins0, 
+	 -- 	      lbl `elem` lbls ]
+
+	 let argsInLin = listAssoc $
+			 map (\((n,c),l) -> (n, MCat c l)) $
+			 groupPairs $ nubsort $
+			 [ ((nr, cat), lbl) | 
+			   Lin _ lin <- lins, 
+			   Cat (cat, lbl, nr) <- lin ] 
+
+	     newArgs = mapMaybe (lookupAssoc argsInLin) [0 .. length args-1]
+	     argLbls = [ lbls | MCat _ lbls <- newArgs ]
+
+	     newLins = [ Lin lbl newLin | Lin lbl lin <- lins,
+			 let newLin = map (mapSymbol cnvCat id) lin ]
+	     cnvCat (cat, lbl, nr) = (mcat, lbl, nr')
+		 where Just mcat = lookupAssoc argsInLin nr
+		       Unify [nr'] = newProfile !! nr
+	     nonEmptyCat (Cat (MCat _ [], _, _)) = False
+	     nonEmptyCat _ = True
+
+	     newProfile = snd $ mapAccumL accumProf 0 $
+			  map (lookupAssoc argsInLin) [0 .. length args-1]
+	     accumProf nr = maybe (nr, Unify []) $ const (nr+1, Unify [nr])
+	     newName = -- tracePrt "newName" (prtNewName profile newProfile) $
+                       Name fun (profile `composeProfiles` newProfile)
+
+         guard $ all (not . null) argLbls
+	 return $ NR (Rule (Abs newCat newArgs newName) (Cnc lbls argLbls newLins))
+
+selectLins lins0 = mapM selectLbl
+    where selectLbl lbl = [ lin | lin@(Lin lbl' _) <- lins0, lbl == lbl' ] 
+
+
+prtNewName :: [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)] -> Name -> String
+prtNewName p p' n = prt p ++ " .o. " ++ prt p' ++ " : " ++ prt n
+
+
+initialCatsTD grammar starts =
+    [ cat | cat@(NC (MCat (ECat start _) _)) <- initialCatsBU grammar,
+      start `elem` starts ]
+
+initialCatsBU grammar 
+    = [ NC (MCat cat [lbl]) | (cat, rules) <- aAssocs grammar, 
+	let Rule _ (Cnc lbls _ _) = head rules,
+	lbl <- lbls ]
+
+
+
+
+
+
+

src-2.9/GF/Conversion/RemoveSingletons.hs

@@ -0,0 +1,82 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/11 10:28:16 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.5 $
+--
+-- Instantiating all types which only have one single element.
+--
+-- Should be merged into 'GF.Conversion.FiniteToSimple'
+-----------------------------------------------------------------------------
+
+module GF.Conversion.RemoveSingletons where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC
+import GF.Conversion.Types
+
+import GF.Data.SortedList
+import GF.Data.Assoc
+
+import Data.List (mapAccumL)
+
+convertGrammar :: SGrammar -> SGrammar
+convertGrammar grammar = if singles == emptyAssoc then grammar
+			 else tracePrt "RemoveSingletons - non-singleton rules" (prt . length) $
+			      map (convertRule singles) grammar
+    where singles = calcSingletons grammar
+
+convertRule :: Assoc SCat (SyntaxForest Fun, Maybe STerm) -> SRule -> SRule
+convertRule singles rule@(Rule (Abs _ decls _) _)
+    = if all (Nothing ==) singleArgs then rule
+      else instantiateSingles singleArgs rule
+    where singleArgs = map (lookupAssoc singles . decl2cat) decls
+
+instantiateSingles :: [Maybe (SyntaxForest Fun, Maybe STerm)] -> SRule -> SRule
+instantiateSingles singleArgs (Rule (Abs decl decls (Name fun profile)) (Cnc lcat lcats lterm))
+    = Rule (Abs decl decls' (Name fun profile')) (Cnc lcat lcats' lterm')
+    where (decls', lcats') = unzip [ (d, l) | (Nothing, d, l) <- zip3 singleArgs decls lcats ]
+	  profile'  = map (fmap fst) exProfile `composeProfiles` profile
+	  newArgs   = map (fmap snd) exProfile
+	  lterm'    = fmap (instantiateLin newArgs) lterm
+	  exProfile = snd $ mapAccumL mkProfile 0 singleArgs
+	  mkProfile nr (Just trm) = (nr, Constant trm)
+	  mkProfile nr (Nothing)  = (nr+1, Unify [nr])
+
+instantiateLin :: [Profile (Maybe STerm)] -> STerm -> STerm
+instantiateLin newArgs = inst
+    where inst (Arg nr cat path) 
+	      = case newArgs !! nr of
+		  Unify [nr']          -> Arg nr' cat path
+		  Constant (Just term) -> termFollowPath path term
+		  Constant Nothing     -> error "RemoveSingletons.instantiateLin: This should not happen (argument has no linearization)"
+	  inst (cn :^ terms) = cn :^ map inst terms
+	  inst (Rec rec)     = Rec [ (lbl, inst term) | (lbl, term) <- rec ]
+	  inst (term :. lbl) = inst term +. lbl
+	  inst (Tbl tbl)     = Tbl [ (pat, inst term) | (pat, term) <- tbl ]
+	  inst (term :! sel) = inst term +! inst sel
+	  inst (Variants ts) = variants (map inst ts)
+	  inst (t1 :++ t2)   = inst t1 ?++ inst t2
+	  inst term          = term
+
+----------------------------------------------------------------------
+
+calcSingletons :: SGrammar -> Assoc SCat (SyntaxForest Fun, Maybe STerm)
+calcSingletons rules = listAssoc singleCats
+    where singleCats = tracePrt "RemoveSingletons - singleton cats" (prtSep " ") $
+		       [ (cat, (constantNameToForest name, lin)) | 
+			 (cat, [([], name, lin)]) <- rulesByCat ]
+	  rulesByCat = groupPairs $ nubsort
+		       [ (decl2cat cat, (args, name, lin)) | 
+			 Rule (Abs cat args name) (Cnc _ _ lin) <- rules ]
+
+
+

src-2.9/GF/Conversion/SimpleToFCFG.hs

@@ -0,0 +1,536 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : Krasimir Angelov
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- Converting SimpleGFC grammars to fast nonerasing MCFG grammar.
+--
+-- the resulting grammars might be /very large/
+--
+-- the conversion is only equivalent if the GFC grammar has a context-free backbone.
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.SimpleToFCFG
+    (convertConcrete) where
+
+import GF.Infra.PrintClass
+
+import Control.Monad
+
+import GF.Formalism.Utilities
+import GF.Formalism.FCFG
+
+import GF.GFCC.Macros --hiding (prt)
+import GF.GFCC.DataGFCC
+import GF.GFCC.CId
+
+import GF.Data.BacktrackM
+import GF.Data.SortedList
+import GF.Data.Utilities (updateNthM, sortNub)
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.List as List
+import Data.Array
+import Data.Maybe
+
+----------------------------------------------------------------------
+-- main conversion function
+
+convertConcrete :: Abstr -> Concr -> FGrammar
+convertConcrete abs cnc = fixHoasFuns $ convert abs_defs' conc' cats'
+       where abs_defs = Map.assocs (funs abs)
+             conc = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient"
+             cats = lincats cnc
+             (abs_defs',conc',cats') = expandHOAS abs_defs conc cats
+
+expandHOAS :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> ([(CId,(Type,Exp))],TermMap,TermMap)
+expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns, 
+                                Map.unions [lins, hoLins, varLins], 
+                                Map.unions [lincats, hoLincats, varLincat])
+    where
+      -- replace higher-order fun argument types with new categories
+      funs' = [(f,(fixType ty,e)) | (f,(ty,e)) <- funs]
+          where
+            fixType :: Type -> Type
+            fixType ty = let (ats,rt) = typeSkeleton ty in cftype (map catName ats) rt
+
+      hoTypes :: [(Int,CId)]
+      hoTypes = sortNub [(n,c) | (_,(ty,_)) <- funs, (n,c) <- fst (typeSkeleton ty), n > 0]
+      hoCats = sortNub (map snd hoTypes)
+      -- for each Cat with N bindings, we add a new category _NCat
+      -- each new category contains a single function __NCat : Cat -> _Var -> ... -> _Var -> _NCat
+      hoFuns = [(funName ty,(cftype (c : replicate n varCat) (catName ty),EEq [])) | ty@(n,c) <- hoTypes]
+      -- lincats for the new categories
+      hoLincats = Map.fromList [(catName ty, modifyRec (++ replicate n (S [])) (lincatOf c)) | ty@(n,c) <- hoTypes]
+      -- linearizations of the new functions, lin __NCat v_0 ... v_n-1 x = { s1 = x.s1; ...; sk = x.sk; $0 = v_0.s ...
+      hoLins = Map.fromList [ (funName ty, mkLin c n) | ty@(n,c) <- hoTypes]
+          where mkLin c n = modifyRec (\fs -> [P (V 0) (C j) | j <- [0..length fs-1]] ++ [P (V i) (C 0) | i <- [1..n]]) (lincatOf c)
+      -- for each Cat, we a add a fun _Var_Cat : _Var -> Cat
+      varFuns = [(varFunName cat, (cftype [varCat] cat,EEq [])) | cat <- hoCats]
+      -- linearizations of the _Var_Cat functions
+      varLins = Map.fromList [(varFunName cat, R [P (V 0) (C 0)]) | cat <- hoCats]
+      -- lincat for the _Var category
+      varLincat = Map.singleton varCat (R [S []])
+
+      lincatOf c = fromMaybe (error $ "No lincat for " ++ prt c) $ Map.lookup c lincats
+
+      modifyRec :: ([Term] -> [Term]) -> Term -> Term
+      modifyRec f (R xs) = R (f xs)
+      modifyRec _ t = error $ "Not a record: " ++ show t
+
+      varCat = CId "_Var"
+
+      catName :: (Int,CId) -> CId
+      catName (0,c) = c
+      catName (n,CId c) = CId ("_" ++ show n ++ c)
+
+      funName :: (Int,CId) -> CId
+      funName (n,CId c) = CId ("__" ++ show n ++ c)
+
+      varFunName :: CId -> CId
+      varFunName (CId c) = CId ("_Var_" ++ c)
+
+-- replaces __NCat with _B and _Var_Cat with _.
+-- the temporary names are just there to avoid name collisions.
+fixHoasFuns :: FGrammar -> FGrammar
+fixHoasFuns (rs, cs) = ([FRule (fixName n) args cat lins | FRule n args cat lins <- rs], cs)
+  where fixName (Name (CId ('_':'_':_)) p) = Name (CId "_B") p
+        fixName (Name (CId n) p) | "_Var_" `List.isPrefixOf` n = Name wildCId p
+        fixName n = n
+
+convert :: [(CId,(Type,Exp))] -> TermMap -> TermMap -> FGrammar
+convert abs_defs cnc_defs cat_defs = getFGrammar (loop frulesEnv)
+      where
+        srules = [
+          (XRule id args res (map findLinType args) (findLinType res) term) | 
+            (id, (ty,_)) <- abs_defs, let (args,res) = catSkeleton ty, 
+            term <- Map.lookup id cnc_defs]
+        
+        findLinType id = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs)
+
+        (xrulesMap,frulesEnv) = List.foldl' helper (Map.empty,emptyFRulesEnv) srules
+           where
+	     helper (xrulesMap,frulesEnv) rule@(XRule id abs_args abs_res cnc_args cnc_res term) = 
+	       let xrulesMap' = Map.insertWith (++) abs_res [rule] xrulesMap
+	           frulesEnv' = List.foldl' (\env selector -> convertRule cnc_defs selector rule env)
+	                                    frulesEnv
+	                                    (mkSingletonSelectors cnc_defs cnc_res)
+               in xrulesMap' `seq` frulesEnv' `seq` (xrulesMap',frulesEnv')
+
+        loop frulesEnv =
+          let (todo, frulesEnv') = takeToDoRules xrulesMap frulesEnv
+          in case todo of
+               [] -> frulesEnv'
+               _  -> loop $! List.foldl' (\env (srules,selector) -> 
+                             List.foldl' (\env srule             -> convertRule cnc_defs selector srule env) env srules) frulesEnv' todo
+
+convertRule :: TermMap -> TermSelector -> XRule -> FRulesEnv -> FRulesEnv
+convertRule cnc_defs selector (XRule fun args cat ctypes ctype term) frulesEnv =
+  foldBM addRule
+         frulesEnv
+         (convertTerm cnc_defs selector term [([],[])])
+         (protoFCat cat, map (\scat -> (protoFCat scat,[])) args, ctype, ctypes)
+  where
+    addRule linRec (newCat', newArgs', _, _) env0 =
+      let (env1, newCat)          = genFCatHead env0 newCat'
+          (env2, newArgs,idxArgs) = foldr (\((xcat@(PFCat cat rcs tcs),xpaths),ctype,idx) (env,args,all_args) ->
+                                       let xargs          = xcat:[PFCat cat [path] tcs | path <- reverse xpaths]
+                                           (env1, xargs1) = List.mapAccumL (genFCatArg cnc_defs ctype) env xargs
+                                       in case xcat of
+                                            PFCat _ [] _ -> (env ,        args,                       all_args)
+                                            _            -> (env1,xargs1++args,(idx,zip xargs1 xargs):all_args)) (env1,[],[]) (zip3 newArgs' ctypes [0..])
+
+          newLinRec = listArray (0,length linRec-1) [translateLin idxArgs path linRec | path <- case newCat' of {PFCat _ rcs _ -> rcs}]
+
+          (_,newProfile) = List.mapAccumL accumProf 0 newArgs'
+            where
+              accumProf nr (PFCat _ [] _,_     ) = (nr,       Unify []          )
+              accumProf nr (_           ,xpaths) = (nr+cnt+1, Unify [nr..nr+cnt])
+                where cnt = length xpaths
+
+          rule = FRule (Name fun newProfile) newArgs newCat newLinRec
+      in addFRule env2 rule
+
+translateLin idxArgs lbl' []                    = array (0,-1) []
+translateLin idxArgs lbl' ((lbl,syms) : lins)
+  | lbl' == lbl = listArray (0,length syms-1) (map instSym syms)
+  | otherwise   = translateLin idxArgs lbl' lins
+  where
+    instSym = symbol (\(lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs) FSymTok
+    instCat lbl nr xnr nr' ((idx,xargs):idxArgs)
+      | nr == idx = let (fcat, PFCat _ rcs _) = xargs !! xnr
+                    in FSymCat fcat (index lbl rcs 0) (nr'+xnr)
+      | otherwise = instCat lbl nr xnr (nr'+length xargs) idxArgs
+
+    index lbl' (lbl:lbls) idx
+      | lbl' == lbl = idx
+      | otherwise   = index lbl' lbls $! (idx+1)
+
+
+----------------------------------------------------------------------
+-- term conversion
+
+type CnvMonad a = BacktrackM Env a
+
+type Env     = (ProtoFCat, [(ProtoFCat,[FPath])], Term, [Term])
+type LinRec  = [(FPath, [Symbol (FPath, FIndex, Int) FToken])]
+
+type TermMap = Map.Map CId Term
+
+convertTerm :: TermMap -> TermSelector -> Term -> LinRec -> CnvMonad LinRec
+convertTerm cnc_defs selector (V nr)       ((lbl_path,lin) : lins) = convertArg selector nr []    lbl_path lin lins
+convertTerm cnc_defs selector (C nr)       ((lbl_path,lin) : lins) = convertCon selector nr       lbl_path lin lins
+convertTerm cnc_defs selector (R record)   ((lbl_path,lin) : lins) = convertRec cnc_defs selector 0 record lbl_path lin lins
+
+convertTerm cnc_defs selector (P term sel)                   lins  = do nr <- evalTerm cnc_defs [] sel
+                                                                        convertTerm cnc_defs (TuplePrj nr selector) term lins
+convertTerm cnc_defs selector (FV vars)                      lins  = do term <- member vars
+                                                                        convertTerm cnc_defs selector term lins
+convertTerm cnc_defs selector (S ts)       ((lbl_path,lin) : lins) = do projectHead lbl_path
+                                                                        foldM (\lins t -> convertTerm cnc_defs selector t lins) ((lbl_path,lin) : lins) (reverse ts)
+convertTerm cnc_defs selector (K (KS str)) ((lbl_path,lin) : lins) = 
+  do projectHead lbl_path
+     return ((lbl_path,Tok str : lin) : lins)
+convertTerm cnc_defs selector (K (KP strs vars))((lbl_path,lin) : lins) = 
+  do projectHead lbl_path
+     toks <- member (strs:[strs' | Var strs' _ <- vars])
+     return ((lbl_path, map Tok toks ++ lin) : lins)
+convertTerm cnc_defs selector (RP _ term)                    lins  = convertTerm cnc_defs selector term lins
+convertTerm cnc_defs selector (F id)                         lins  = do term <- Map.lookup id cnc_defs
+                                                                        convertTerm cnc_defs selector term lins
+convertTerm cnc_defs selector (W s t)     ((lbl_path,lin) : lins) = do
+  ss <- case t of
+    R ss -> return ss
+    F f -> do
+      t <- Map.lookup f cnc_defs 
+      case t of
+        R ss -> return ss
+  convertRec cnc_defs selector 0 [K (KS (s ++ s1)) | K (KS s1) <- ss] lbl_path lin lins
+convertTerm cnc_defs selector x lins  = error ("convertTerm ("++show x++")")
+
+
+convertArg (TupleSel record)  nr path lbl_path lin lins =
+  foldM (\lins (lbl,  selector) -> convertArg selector nr (lbl:path)  (lbl:lbl_path) lin lins) lins record
+convertArg (TuplePrj lbl selector) nr path lbl_path lin lins = 
+  convertArg selector nr (lbl:path) lbl_path lin lins
+convertArg (ConSel indices) nr path lbl_path lin lins = do
+  index <- member indices
+  restrictHead lbl_path index
+  restrictArg nr path index
+  return lins
+convertArg StrSel nr path lbl_path lin lins = do
+  projectHead lbl_path
+  xnr <- projectArg nr path
+  return ((lbl_path, GF.Formalism.Utilities.Cat (path, nr, xnr) : lin) : lins)
+
+convertCon (ConSel indices) index lbl_path lin lins = do
+  guard (index `elem` indices)
+  restrictHead lbl_path index
+  return lins
+convertCon x _ _ _ _ = error $ "SimpleToFCFG,convertCon: " ++ show x
+
+convertRec cnc_defs selector                   index []           lbl_path lin lins = return lins
+convertRec cnc_defs selector@(TupleSel fields) index (val:record) lbl_path lin lins = select fields
+  where
+    select []                          = convertRec cnc_defs selector (index+1) record lbl_path lin lins
+    select ((index',sub_sel) : fields)
+      | index == index'                = do lins <- convertTerm cnc_defs sub_sel val ((index:lbl_path,lin) : lins)
+                                            convertRec cnc_defs selector (index+1) record lbl_path lin lins
+      | otherwise                      = select fields
+convertRec cnc_defs (TuplePrj index' sub_sel) index record lbl_path lin lins = do
+  convertTerm cnc_defs sub_sel (record !! (index'-index)) ((lbl_path,lin) : lins)
+
+
+------------------------------------------------------------
+-- eval a term to ground terms
+
+evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex
+evalTerm cnc_defs path (V nr)       = do term <- readArgCType nr
+                                         unifyPType nr (reverse path) (selectTerm path term)
+evalTerm cnc_defs path (C nr)       = return nr
+evalTerm cnc_defs path (R record)   = case path of
+                                        (index:path) -> evalTerm cnc_defs path (record !! index)
+evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel
+                                         evalTerm cnc_defs (index:path) term
+evalTerm cnc_defs path (FV terms)   = member terms >>= evalTerm cnc_defs path
+evalTerm cnc_defs path (RP alias _) = evalTerm cnc_defs path alias
+evalTerm cnc_defs path (F id)       = do term <- Map.lookup id cnc_defs
+                                         evalTerm cnc_defs path term
+evalTerm cnc_defs path x = error ("evalTerm ("++show x++")")
+
+unifyPType :: FIndex -> FPath -> Term -> CnvMonad FIndex
+unifyPType nr path (C max_index) =
+    do (_, args, _, _) <- readState
+       let (PFCat _ _ tcs,_) = args !! nr
+       case lookup path tcs of
+         Just index -> return index
+         Nothing    -> do index <- member [0..max_index]
+		          restrictArg nr path index
+		          return index
+unifyPType nr path (RP alias _) = unifyPType nr path alias
+
+unifyPType nr path t = error $ "unifyPType " ++ show t ---- AR 2/10/2007
+
+selectTerm :: FPath -> Term -> Term
+selectTerm []           term        = term
+selectTerm (index:path) (R  record) = selectTerm path (record !! index)
+selectTerm path         (RP _ term) = selectTerm path term
+
+
+----------------------------------------------------------------------
+-- FRulesEnv
+
+data FRulesEnv = FRulesEnv {-# UNPACK #-} !Int FCatSet [FRule]
+type FCatSet   = Map.Map CId (Map.Map [FPath] (Map.Map [(FPath,FIndex)] (Either FCat FCat)))
+
+data ProtoFCat = PFCat CId [FPath] [(FPath,FIndex)]
+
+protoFCat :: CId -> ProtoFCat
+protoFCat cat = PFCat cat [] []
+
+emptyFRulesEnv = FRulesEnv 0 (ins fcatString (CId "String") [[0]] [] $
+                              ins fcatInt    (CId "Int")    [[0]] [] $
+                              ins fcatFloat  (CId "Float")  [[0]] [] $
+                              ins fcatVar    (CId "_Var")   [[0]] [] $
+                              Map.empty) []
+  where
+    ins fcat cat rcs tcs fcatSet =
+      Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s fcatSet
+      where
+        right_fcat = Right fcat
+        tmap_s = Map.singleton tcs right_fcat
+        rmap_s = Map.singleton rcs tmap_s
+
+addFRule :: FRulesEnv -> FRule -> FRulesEnv
+addFRule (FRulesEnv last_id fcatSet rules) rule = FRulesEnv last_id fcatSet (rule:rules)
+
+getFGrammar :: FRulesEnv -> FGrammar
+getFGrammar (FRulesEnv last_id fcatSet rules) = (rules, Map.map getFCatList fcatSet)
+  where
+    getFCatList rcs = Map.fold (\tcs lst -> Map.fold (\x lst -> either id id x : lst) lst tcs) [] rcs
+
+genFCatHead :: FRulesEnv -> ProtoFCat -> (FRulesEnv, FCat)
+genFCatHead env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs tcs) =
+  case Map.lookup cat fcatSet >>= Map.lookup rcs >>= Map.lookup tcs of
+    Just (Left  fcat) -> (FRulesEnv last_id (ins fcat) rules, fcat)
+    Just (Right fcat) -> (env, fcat)
+    Nothing           -> let fcat = last_id+1
+                         in (FRulesEnv fcat (ins fcat) rules, fcat)
+  where
+    ins fcat = Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s fcatSet
+      where
+        right_fcat = Right fcat
+        tmap_s = Map.singleton tcs right_fcat
+        rmap_s = Map.singleton rcs tmap_s
+
+genFCatArg :: TermMap -> Term -> FRulesEnv -> ProtoFCat -> (FRulesEnv, FCat)
+genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs tcs) =
+  case Map.lookup cat fcatSet >>= Map.lookup rcs of
+    Just tmap -> case Map.lookup tcs tmap of
+                   Just (Left  fcat) -> (env,   fcat)
+                   Just (Right fcat) -> (env,   fcat)
+                   Nothing           -> ins tmap
+    Nothing   -> ins Map.empty
+  where
+    ins tmap =
+      let fcat = last_id+1
+          (either_fcat,last_id1,tmap1,rules1)
+                  = foldBM (\tcs st (either_fcat,last_id,tmap,rules) ->
+                                   let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap
+                                       rule = FRule (Name (CId "_") [Unify [0]]) [fcat_arg] fcat
+                                                    (listArray (0,length rcs-1) [listArray (0,0) [FSymCat fcat_arg lbl 0] | lbl <- [0..length rcs-1]])
+                                   in if st
+                                        then (Right fcat, last_id1,tmap1,rule:rules)
+                                        else (either_fcat,last_id, tmap,      rules))
+                           (Left fcat,fcat,Map.insert tcs either_fcat tmap,rules)
+                           (gen_tcs ctype [] [])
+                           False
+          rmap1 = Map.singleton rcs tmap1
+      in (FRulesEnv last_id1 (Map.insertWith (\_ -> Map.insert rcs tmap1) cat rmap1 fcatSet) rules1, fcat)
+      where
+        addArg tcs last_id tmap =
+	  case Map.lookup tcs tmap of
+	    Just (Left  fcat) -> (last_id, tmap, fcat)
+	    Just (Right fcat) -> (last_id, tmap, fcat)
+	    Nothing           -> let fcat = last_id+1
+                                 in (fcat, Map.insert tcs (Left fcat) tmap, fcat)
+
+    gen_tcs :: Term -> FPath -> [(FPath,FIndex)] -> BacktrackM Bool [(FPath,FIndex)]
+    gen_tcs (R record)    path acc = foldM (\acc (label,ctype) -> gen_tcs ctype (label:path) acc) acc (zip [0..] record)
+    gen_tcs (S _)         path acc = return acc
+    gen_tcs (RP _ term)   path acc = gen_tcs term path acc
+    gen_tcs (C max_index) path acc =
+      case List.lookup path tcs of
+        Just index -> return $! addConstraint path index acc
+        Nothing    -> do writeState True
+                         index <- member [0..max_index]
+                         return $! addConstraint path index acc
+      where
+        addConstraint path0 index0 (c@(path,index) : cs)
+	  | path0 > path = c:addConstraint path0 index0 cs
+        addConstraint path0 index0 cs  = (path0,index0) : cs
+    gen_tcs (F id)        path acc = case Map.lookup id cnc_defs of
+                                        Just term -> gen_tcs term path acc
+                                        Nothing   -> error ("unknown identifier: "++prt id)
+
+
+
+------------------------------------------------------------
+-- TODO queue organization
+
+type XRulesMap = Map.Map CId [XRule]
+data XRule     = XRule CId     {- function -}
+                       [CId]   {- argument types -}
+                       CId     {- result   type  -}
+                       [Term]  {- argument lin-types representation -}
+                       Term    {- result   lin-type  representation -}
+                       Term    {- body -}
+
+takeToDoRules :: XRulesMap -> FRulesEnv -> ([([XRule], TermSelector)], FRulesEnv)
+takeToDoRules xrulesMap (FRulesEnv last_id fcatSet rules) = (todo,FRulesEnv last_id fcatSet' rules)
+  where
+    (todo,fcatSet') =
+          Map.mapAccumWithKey (\todo cat rmap ->
+                let (todo1,rmap1) = Map.mapAccumWithKey (\todo rcs tmap -> 
+                                          let (tcss,tmap') = Map.mapAccumWithKey (\tcss tcs either_xcat ->
+                                                                   case either_xcat of
+                                                                     Left  xcat -> (tcs:tcss,Right xcat)
+                                                                     Right xcat -> (    tcss,either_xcat)) [] tmap
+                                          in case tcss of
+                                               [] -> (                               todo,tmap )
+                                               _  -> ((srules,mkSelector rcs tcss) : todo,tmap')) todo rmap
+                    mb_srules   = Map.lookup cat xrulesMap
+                    Just srules = mb_srules
+
+                in case mb_srules of
+                     Just srules -> (todo1,rmap1)
+                     Nothing     -> (todo ,rmap1)) [] fcatSet
+
+
+------------------------------------------------------------
+-- The TermSelector
+
+data TermSelector
+  = TupleSel [(FIndex, TermSelector)]
+  | TuplePrj   FIndex  TermSelector
+  | ConSel   [FIndex]
+  | StrSel
+  deriving Show
+
+mkSingletonSelectors :: TermMap 
+                     -> Term               -- ^ Type representation term
+                     -> [TermSelector]     -- ^ list of selectors containing just one string field
+mkSingletonSelectors cnc_defs term = sels0
+  where
+    (sels0,tcss0) = loop [] ([],[]) term
+
+    loop path st          (R record) = List.foldl' (\st (index,term) -> loop (index:path) st term) st (zip [0..] record)
+    loop path st          (RP _ t)   = loop path st t
+    loop path (sels,tcss) (C i)      = (                          sels,map ((,) path) [0..i] : tcss)
+    loop path (sels,tcss) (S _)      = (mkSelector [path] tcss0 : sels,                        tcss)
+    loop path (sels,tcss) (F id)     = case Map.lookup id cnc_defs of
+                                         Just term -> loop path (sels,tcss) term
+                                         Nothing   -> error ("unknown identifier: "++prt id)
+
+mkSelector :: [FPath] -> [[(FPath,FIndex)]] -> TermSelector
+mkSelector rcs tcss =
+  List.foldl' addRestriction (case xs of
+                                (path:xs) -> List.foldl' addProjection (path2selector StrSel path) xs) ys
+  where
+    xs = [ reverse path       |               path       <- rcs]
+    ys = [(reverse path,term) | tcs <- tcss, (path,term) <- tcs]
+    
+    addRestriction :: TermSelector -> (FPath,FIndex) -> TermSelector
+    addRestriction (ConSel indices)  ([]          ,n_index) = ConSel (add indices)
+      where
+        add []                      = [n_index]
+        add (index':indices)
+          | n_index == index'       = index':    indices
+          | otherwise               = index':add indices
+    addRestriction (TupleSel fields) (index : path,n_index) = TupleSel (add fields)
+      where
+        add []                      = [(index,path2selector (ConSel [n_index]) path)]
+        add (field@(index',sub_sel):fields)
+          | index == index'         = (index',addRestriction sub_sel (path,n_index)):fields
+          | otherwise               = field : add fields
+
+    addProjection :: TermSelector -> FPath -> TermSelector
+    addProjection StrSel            []             = StrSel
+    addProjection (TupleSel fields) (index : path) = TupleSel (add fields)
+      where
+        add []                      = [(index,path2selector StrSel path)]
+        add (field@(index',sub_sel):fields)
+          | index == index'         = (index',addProjection sub_sel path):fields
+          | otherwise               = field : add fields
+    
+    path2selector base []             = base
+    path2selector base (index : path) = TupleSel [(index,path2selector base path)]
+
+------------------------------------------------------------
+-- updating the MCF rule
+
+readArgCType :: FIndex -> CnvMonad Term
+readArgCType nr = do (_, _, _, ctypes) <- readState
+		     return (ctypes !! nr)
+
+restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad ()
+restrictArg nr path index = do
+  (head, args, ctype, ctypes) <- readState 
+  args' <- updateNthM (\(xcat,xs) -> do xcat <- restrictProtoFCat path index xcat
+                                        return (xcat,xs)                         ) nr args
+  writeState (head, args', ctype, ctypes)
+
+projectArg :: FIndex -> FPath -> CnvMonad Int
+projectArg nr path = do
+  (head, args, ctype, ctypes) <- readState
+  (xnr,args') <- updateArgs nr args
+  writeState (head, args', ctype, ctypes)
+  return xnr
+  where
+    updateArgs :: FIndex -> [(ProtoFCat,[FPath])] -> CnvMonad (Int,[(ProtoFCat,[FPath])])
+    updateArgs 0 ((a@(PFCat _ rcs _),xpaths) : as)
+      | path `elem` rcs = return (length xpaths+1,(a,path:xpaths):as)
+      | otherwise       = do a <- projectProtoFCat path a
+                             return (0,(a,xpaths):as)
+    updateArgs n (a : as) = do
+      (xnr,as) <- updateArgs (n-1) as
+      return (xnr,a:as)
+
+readHeadCType :: CnvMonad Term
+readHeadCType = do (_, _, ctype, _) <- readState
+		   return ctype
+
+restrictHead :: FPath -> FIndex -> CnvMonad ()
+restrictHead path term
+    = do (head, args, ctype, ctypes) <- readState
+	 head' <- restrictProtoFCat path term head
+	 writeState (head', args, ctype, ctypes)
+
+projectHead :: FPath -> CnvMonad ()
+projectHead path
+    = do (head, args, ctype, ctypes) <- readState
+	 head' <- projectProtoFCat path head
+	 writeState (head', args, ctype, ctypes)
+
+restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> CnvMonad ProtoFCat
+restrictProtoFCat path0 index0 (PFCat cat rcs tcs) = do
+  tcs <- addConstraint tcs
+  return (PFCat cat rcs tcs)
+  where
+    addConstraint (c@(path,index) : cs)
+        | path0 >  path = liftM (c:) (addConstraint cs)
+        | path0 == path = guard (index0 == index) >>
+                          return (c : cs)
+    addConstraint cs    = return ((path0,index0) : cs)
+
+projectProtoFCat :: FPath -> ProtoFCat -> CnvMonad ProtoFCat
+projectProtoFCat path0 (PFCat cat rcs tcs) = do
+  return (PFCat cat (addConstraint rcs) tcs)
+  where
+    addConstraint (path : rcs)
+        | path0 >  path = path  : addConstraint rcs
+        | path0 == path = path  : rcs
+    addConstraint rcs   = path0 : rcs

src-2.9/GF/Conversion/SimpleToFinite.hs

@@ -0,0 +1,178 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/01 09:53:19 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.7 $
+--
+-- Calculating the finiteness of each type in a grammar
+-----------------------------------------------------------------------------
+
+module GF.Conversion.SimpleToFinite
+    (convertGrammar) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC
+import GF.Formalism.Utilities 
+import GF.Conversion.Types
+
+import GF.Data.SortedList
+import GF.Data.Assoc
+import GF.Data.BacktrackM
+import GF.Data.Utilities (lookupList)
+
+import GF.Infra.Ident (Ident(..))
+
+type CnvMonad a = BacktrackM () a
+
+convertGrammar :: SGrammar -> SGrammar
+convertGrammar rules = tracePrt "SimpleToFinie - nr. 'finite' rules" (prt . length) $
+		       solutions cnvMonad ()
+    where split = calcSplitable rules
+	  cnvMonad = member rules >>= convertRule split
+
+convertRule :: Splitable -> SRule -> CnvMonad SRule
+convertRule split (Rule abs cnc) 
+    = do newAbs <- convertAbstract split abs
+	 return $ Rule newAbs cnc
+
+{-
+-- old code
+convertAbstract :: Splitable -> Abstract SDecl Name
+		-> CnvMonad (Abstract SDecl Name)
+convertAbstract split (Abs decl decls name)
+    = case splitableFun split (name2fun name) of
+        Just cat' -> return $ Abs (Decl anyVar (mergeFun (name2fun name) cat') []) decls name
+	Nothing -> expandTyping split name [] decl decls []
+
+
+expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SDecl -> [SDecl] -> [SDecl] 
+	     -> CnvMonad (Abstract SDecl Name)
+expandTyping split name env (Decl x cat args) [] decls 
+    = return $ Abs decl (reverse decls) name
+    where decl = substArgs split x env cat args []
+expandTyping split name env typ (Decl x xcat xargs : declsToDo) declsDone
+    = do (x', xcat', env') <- calcNewEnv
+         let decl = substArgs split x' env xcat' xargs []
+	 expandTyping split name env' typ declsToDo (decl : declsDone)
+    where calcNewEnv = case splitableCat split xcat of
+		         Just newFuns -> do newFun <- member newFuns
+                                            let newCat  = mergeFun newFun xcat
+		         -- Just newCats -> do newCat <- member newCats
+					    return (anyVar, newCat, (x,newCat) : env)
+			 Nothing -> return (x, xcat, env)
+-}
+
+-- new code
+convertAbstract :: Splitable -> Abstract SDecl Name
+		-> CnvMonad (Abstract SDecl Name)
+convertAbstract split (Abs decl decls name)
+    = case splitableFun split fun of
+        Just cat' -> return $ Abs (Decl anyVar ([] ::--> (mergeFun fun cat' ::@ []))) decls name
+	Nothing -> expandTyping split [] fun profiles [] decl decls []
+    where Name fun profiles = name
+
+expandTyping :: Splitable -> [(Var, SCat)]
+             -> Fun -> [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)] 
+             -> SDecl -> [SDecl] -> [SDecl] 
+	     -> CnvMonad (Abstract SDecl Name)
+expandTyping split env fun [] profiles (Decl x (typargs ::--> (cat ::@ args))) [] decls 
+    = return $ Abs decl (reverse decls) (Name fun (reverse profiles))
+    where decl = substArgs split x env typargs cat args []
+expandTyping split env fun (prof:profiles) profsDone typ 
+                 (Decl x (xtypargs ::--> (xcat ::@ xargs)) : declsToDo) declsDone
+    = do (x', xcat', env', prof') <- calcNewEnv
+         let decl = substArgs split x' env xtypargs xcat' xargs []
+	 expandTyping split env' fun profiles (prof' : profsDone) typ declsToDo (decl : declsDone)
+    where calcNewEnv = case splitableCat split xcat of
+			 Nothing      -> return (x, xcat, env, prof)
+		         Just newFuns -> do newFun <- member newFuns
+                                            let newCat  = mergeFun newFun xcat
+                                                newProf = Constant (FNode newFun [[]])
+                                            -- should really be using some kind of
+                                            -- "profile unification"
+					    return (anyVar, newCat, (x,newCat) : env, newProf)
+
+substArgs :: Splitable -> Var -> [(Var, SCat)] -> [FOType SCat]
+	  -> SCat -> [TTerm] -> [TTerm] -> SDecl
+substArgs split x env typargs cat [] args = Decl x (typargs ::--> (cat ::@ reverse args))
+substArgs split x env typargs cat (arg:argsToDo) argsDone
+    = case argLookup split env arg of
+        Just newCat -> substArgs split x env typargs (mergeArg cat newCat) argsToDo argsDone
+	Nothing     -> substArgs split x env typargs cat argsToDo (arg : argsDone)
+
+argLookup split env (TVar x)   = lookup x env 
+argLookup split env (con :@ _) = fmap (mergeFun fun) (splitableFun split fun)
+    where fun = constr2fun con
+      
+
+----------------------------------------------------------------------
+-- splitable categories (finite, no dependencies)
+-- they should also be used as some dependency
+
+type Splitable = (Assoc SCat [Fun], Assoc Fun SCat)
+
+splitableCat :: Splitable -> SCat -> Maybe [Fun]
+splitableCat = lookupAssoc . fst 
+
+splitableFun :: Splitable -> Fun -> Maybe SCat
+splitableFun = lookupAssoc . snd
+
+calcSplitable :: [SRule] -> Splitable
+calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat)
+    where splitableCat2Funs = groupPairs $ nubsort splitableCatFuns
+
+	  splitableFun2Cat = nubsort
+			     [ (fun, cat) | (cat, fun) <- splitableCatFuns ]
+
+          -- cat-fun pairs that are splitable
+	  splitableCatFuns = tracePrt "SimpleToFinite - splitable functions" prt $
+                             [ (cat, name2fun name) |
+			       Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] name) _ <- rules,
+			       splitableCats ?= cat ]
+
+          -- all cats that are splitable
+          splitableCats = listSet $
+			  tracePrt "SimpleToFinite - finite categories to split" prt $
+			  (nondepCats <**> depCats) <\\> resultCats
+
+          -- all result cats for some pure function
+	  resultCats = tracePrt "SimpleToFinite - result cats" prt $
+                       nubsort [ cat | Rule (Abs (Decl _ (_ ::--> (cat ::@ _))) decls _) _ <- rules,
+				 not (null decls) ]
+
+          -- all cats in constants without dependencies
+          nondepCats = tracePrt "SimpleToFinite - nondep cats" prt $
+                       nubsort [ cat | Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] _) _ <- rules ]
+
+          -- all cats occurring as some dependency of another cat
+	  depCats = tracePrt "SimpleToFinite - dep cats" prt $
+                    nubsort [ cat | Rule (Abs decl decls _) _ <- rules,
+			      cat <- varCats [] (decls ++ [decl]) ]
+
+	  varCats _ [] = []
+	  varCats env (Decl x (xargs ::--> xtyp@(xcat ::@ _)) : decls)
+	      = varCats ((x,xcat) : env) decls ++
+		[ cat | (_::@args) <- (xtyp:xargs), arg <- args, 
+                  y <- varsInTTerm arg, cat <- lookupList y env ]
+
+
+----------------------------------------------------------------------
+-- utilities
+-- mergeing categories
+
+mergeCats :: String -> String -> String -> SCat -> SCat -> SCat
+mergeCats before middle after (IC cat) (IC arg) 
+    = IC (before ++ cat ++ middle ++ arg ++ after)
+
+mergeFun, mergeArg :: SCat -> SCat -> SCat
+mergeFun = mergeCats "{" ":" "}"
+mergeArg = mergeCats "" "" ""
+
+

src-2.9/GF/Conversion/SimpleToMCFG.hs

@@ -0,0 +1,26 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/18 14:55:32 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.3 $
+--
+-- All different conversions from SimpleGFC to MCFG
+-----------------------------------------------------------------------------
+
+module GF.Conversion.SimpleToMCFG where
+
+import GF.Formalism.SimpleGFC 
+import GF.Conversion.Types
+
+import qualified GF.Conversion.SimpleToMCFG.Strict as Strict
+import qualified GF.Conversion.SimpleToMCFG.Nondet as Nondet
+import qualified GF.Conversion.SimpleToMCFG.Coercions as Coerce
+
+convertGrammarNondet, convertGrammarStrict :: SGrammar -> EGrammar
+convertGrammarNondet = Coerce.addCoercions . Nondet.convertGrammar
+convertGrammarStrict = Strict.convertGrammar
+

src-2.9/GF/Conversion/SimpleToMCFG/Coercions.hs

@@ -0,0 +1,63 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/09 09:28:44 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.5 $
+--
+-- Adding coercion functions to a MCFG if necessary.
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.SimpleToMCFG.Coercions
+    (addCoercions) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+import GF.Formalism.MCFG
+import GF.Conversion.Types 
+import GF.Data.SortedList
+import Data.List (groupBy)
+
+----------------------------------------------------------------------
+
+addCoercions :: EGrammar -> EGrammar
+addCoercions rules = coercions ++ rules
+    where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | 
+					Rule (Abs head args _) (Cnc lbls _ _) <- rules ]
+	  allHeadSet = nubsort allHeads
+	  allArgSet  = union   allArgs <\\> map fst allHeadSet
+	  coercions = tracePrt "SimpleToMCFG.Coercions - MCFG coercions" (prt . length) $
+		      concat $
+		      tracePrt "SimpleToMCFG.Coercions - MCFG coercions per category" 
+				   (prtList . map length) $
+		      combineCoercions 
+		        (groupBy sameECatFst allHeadSet) 
+			(groupBy sameECat    allArgSet)
+	  sameECatFst a b = sameECat (fst a) (fst b)
+
+
+combineCoercions [] _ = []
+combineCoercions _ [] = []
+combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) 
+    = case compare (ecat2scat $ fst $ head heads) (ecat2scat $ head args) of
+        LT -> combineCoercions allHeads  allArgs'
+	GT -> combineCoercions allHeads' allArgs
+	EQ -> makeCoercion heads args : combineCoercions allHeads allArgs
+
+
+makeCoercion heads args
+    = [ Rule (Abs arg [head] coercionName) (Cnc lbls [lbls] lins)  |
+	(head@(ECat _ headCns), lbls) <- heads, 
+	let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ],
+	arg@(ECat _ argCns) <- args,
+	argCns `subset` headCns ]
+
+
+

src-2.9/GF/Conversion/SimpleToMCFG/Nondet.hs

@@ -0,0 +1,256 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/08/17 08:27:29 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.7 $
+--
+-- Converting SimpleGFC grammars to MCFG grammars, nondeterministically.
+-- Afterwards, the grammar has to be extended with coercion functions,
+-- from the module 'GF.Conversion.SimpleToMCFG.Coercions'
+--
+-- the resulting grammars might be /very large/
+--
+-- the conversion is only equivalent if the GFC grammar has a context-free backbone.
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.SimpleToMCFG.Nondet
+    (convertGrammar) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import Control.Monad
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG 
+import GF.Formalism.MCFG 
+import GF.Formalism.SimpleGFC 
+import GF.Conversion.Types
+
+import GF.Data.BacktrackM
+import GF.Data.Utilities (notLongerThan, updateNthM)
+
+------------------------------------------------------------
+-- type declarations
+
+type CnvMonad a = BacktrackM Env a
+
+type Env    = (ECat, [ECat], LinRec, [SLinType]) -- variable bindings: [(Var, STerm)]
+type LinRec = [Lin SCat MLabel Token]
+
+
+----------------------------------------------------------------------
+-- main conversion function
+
+maxNrRules :: Int
+maxNrRules = 5000
+
+convertGrammar :: SGrammar -> EGrammar 
+convertGrammar rules = traceCalcFirst rules' $
+		       tracePrt "SimpleToMCFG.Nondet - MCFG rules" (prt . length) $
+		       rules'
+    where rules' = rules >>= convertRule
+--		       solutions conversion undefined
+--    where conversion = member rules >>= convertRule
+
+convertRule :: SRule -> [ERule] -- CnvMonad ERule
+convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) =
+--    | prt(name2fun fun) `elem` 
+--      words "UseCl PosTP TPast ASimul SPredV IndefOneNP DefOneNP UseN2 mother_N2 jump_V" =
+    if notLongerThan maxNrRules rules 
+       then tracePrt ("SimpeToMCFG.Nondet - MCFG rules for " ++ prt fun) (prt . length) $
+	    rules
+       else trace2 "SimpeToMCFG.Nondet - TOO MANY RULES, function not converted" 
+		("More than " ++ show maxNrRules ++ " MCFG rules for " ++ prt fun) $
+            []
+    where rules = flip solutions undefined $
+		  do let cat : args = map decl2cat (decl : decls)
+		     writeState (initialECat cat, map initialECat args, [], ctypes)
+		     rterm <- simplifyTerm term
+		     reduceTerm ctype emptyPath rterm
+		     (newCat, newArgs, linRec, _) <- readState
+		     let newLinRec = map (instantiateArgs newArgs) linRec
+			 catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes)
+		     -- checkLinRec argsPaths catPaths newLinRec
+		     return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec) 
+convertRule _ = [] -- failure
+
+
+----------------------------------------------------------------------
+-- "type-checking" the resulting linearization
+-- should not be necessary, if the algorithms (type-checking and conversion) are correct
+
+checkLinRec args lbls = mapM (checkLin args lbls) 
+
+checkLin args lbls (Lin lbl lin) 
+    | lbl `elem` lbls = mapM (symbol (checkArg args) (const (return ()))) lin
+    | otherwise = trace2 "SimpleToMCFG.Nondet - ERROR" "Label mismatch" $
+		  failure
+
+checkArg args (_cat, lbl, nr) 
+    | lbl `elem` (args !! nr) = return ()
+--    | otherwise = trace2 "SimpleToMCFG.Nondet - ERROR" ("Label mismatch in arg " ++ prt nr) $
+--		  failure
+    | otherwise = trace2 ("SimpleToMCFG.Nondet - ERROR: Label mismatch in arg " ++ prt nr) 
+		  (prt lbl ++ " `notElem` " ++ prt (args!!nr)) $
+		  failure
+
+
+----------------------------------------------------------------------
+-- term simplification
+
+simplifyTerm :: STerm -> CnvMonad STerm
+simplifyTerm (term :! sel)      
+    = do sterm <- simplifyTerm term
+	 ssel <- simplifyTerm sel
+	 case sterm of
+	   Tbl table  -> do (pat, val) <- member table
+			    pat =?= ssel
+			    return val
+	   _ -> do sel' <- expandTerm ssel
+		   return (sterm +! sel')
+-- simplifyTerm (Var x)           = readBinding x
+simplifyTerm (con :^ terms)    = liftM (con :^) $ mapM simplifyTerm terms
+simplifyTerm (Rec record)      = liftM Rec      $ mapM simplifyAssign record
+simplifyTerm (term :. lbl)     = liftM (+. lbl) $      simplifyTerm term
+simplifyTerm (Tbl table)       = liftM Tbl      $ mapM simplifyCase table
+simplifyTerm (Variants terms)  = liftM Variants $ mapM simplifyTerm terms
+simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2)
+simplifyTerm term              = return term
+
+simplifyAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
+simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term
+
+simplifyCase :: (STerm, STerm) -> CnvMonad (STerm, STerm)
+simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term)
+
+
+------------------------------------------------------------
+-- reducing simplified terms, collecting MCF rules
+
+reduceTerm :: SLinType -> SPath -> STerm -> CnvMonad ()
+--reduceTerm ctype path (Variants terms) 
+--    = member terms >>= reduceTerm ctype path
+reduceTerm (StrT)   path term = updateLin (path, term)
+reduceTerm (ConT _) path term = do pat <- expandTerm term
+				   updateHead (path, pat)
+reduceTerm (RecT rtype) path term
+    = sequence_ [ reduceTerm ctype (path ++. lbl) (term  +. lbl) | (lbl, ctype) <- rtype ]
+reduceTerm (TblT pats vtype) path table 
+    = sequence_ [ reduceTerm vtype (path ++! pat) (table +! pat) | pat <- pats ]
+
+
+------------------------------------------------------------
+-- expanding a term to ground terms
+
+expandTerm :: STerm -> CnvMonad STerm
+expandTerm arg@(Arg nr _ path) 
+    = do ctypes <- readArgCTypes
+	 unifyPType arg $ lintypeFollowPath path $ ctypes !! nr
+-- expandTerm arg@(Arg nr _ path) 
+--     = do ctypes <- readArgCTypes
+-- 	 pat <- member $ enumeratePatterns $ lintypeFollowPath path $ ctypes !! nr
+-- 	 pat =?= arg
+-- 	 return pat
+expandTerm (con :^ terms)   = liftM (con :^) $ mapM expandTerm terms
+expandTerm (Rec record)     = liftM  Rec     $ mapM expandAssign record
+--expandTerm (Variants terms) = liftM Variants $ mapM expandTerm terms  
+expandTerm (Variants terms) = member terms >>= expandTerm  
+expandTerm term = error $ "expandTerm: " ++ prt term
+
+expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
+expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term
+
+unifyPType :: STerm -> SLinType -> CnvMonad STerm
+unifyPType arg (RecT prec) = 
+    liftM Rec $
+    sequence [ liftM ((,) lbl) $
+	       unifyPType (arg +. lbl) ptype |
+	       (lbl, ptype) <- prec ]
+unifyPType (Arg nr _ path) (ConT terms) = 
+    do (_, args, _, _) <- readState
+       case lookup path (ecatConstraints (args !! nr)) of
+         Just term -> return term
+         Nothing -> do term <- member terms
+		       updateArg nr (path, term)
+		       return term
+
+------------------------------------------------------------
+-- unification of patterns and selection terms
+
+(=?=) :: STerm -> STerm -> CnvMonad ()
+-- Wildcard      =?= _               = return ()
+-- Var x         =?= term            = addBinding x term
+Rec precord   =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) |
+						(lbl, pat) <- precord ]
+pat           =?= Arg nr _ path   = updateArg nr (path, pat)
+(con :^ pats) =?= (con' :^ terms) = do guard (con==con' && length pats==length terms)
+				       sequence_ $ zipWith (=?=) pats terms
+Rec precord   =?= Rec record      = sequence_ [ maybe mzero (pat =?=) mterm |
+						(lbl, pat) <- precord,
+						let mterm = lookup lbl record ]
+-- variants are not allowed in patterns, but in selection terms:
+term =?= Variants terms = member terms >>= (term =?=)
+pat =?= term = error $ "(=?=): " ++ prt pat ++ " =?= " ++ prt term
+
+----------------------------------------------------------------------
+-- variable bindings (does not work correctly)
+{-
+addBinding x term = do (a, b, c, d, bindings) <- readState
+		       writeState (a, b, c, d, (x,term):bindings)
+
+readBinding x = do (_, _, _, _, bindings) <- readState
+		   return $ maybe (Var x) id $ lookup x bindings
+-}
+
+------------------------------------------------------------
+-- updating the MCF rule
+
+readArgCTypes :: CnvMonad [SLinType]
+readArgCTypes = do (_, _, _, env) <- readState
+		   return env
+
+updateArg :: Int -> Constraint -> CnvMonad ()
+updateArg arg cn
+    = do (head, args, lins, env) <- readState 
+	 args' <- updateNthM (addToECat cn) arg args
+	 writeState (head, args', lins, env)
+
+updateHead :: Constraint -> CnvMonad ()
+updateHead cn
+    = do (head, args, lins, env) <- readState
+	 head' <- addToECat cn head
+	 writeState (head', args, lins, env)
+
+updateLin :: Constraint -> CnvMonad ()
+updateLin (path, term) 
+    = do let newLins = term2lins term
+	 (head, args, lins, env) <- readState
+	 let lins' = lins ++ map (Lin path) newLins
+	 writeState (head, args, lins', env)
+
+term2lins :: STerm -> [[Symbol (SCat, SPath, Int) Token]]
+term2lins (Arg nr cat path) = return [Cat (cat, path, nr)]
+term2lins (Token str)       = return [Tok str]
+term2lins (t1 :++ t2)       = liftM2 (++) (term2lins t1) (term2lins t2)
+term2lins (Empty)           = return []
+term2lins (Variants terms)  = terms >>= term2lins
+term2lins term = error $ "term2lins: " ++ show term
+
+addToECat :: Constraint -> ECat -> CnvMonad ECat
+addToECat cn (ECat cat cns) = liftM (ECat cat) $ addConstraint cn cns
+
+addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint]
+addConstraint cn0 (cn : cns)
+    | fst cn0 >  fst cn = liftM (cn:) (addConstraint cn0 cns)
+    | fst cn0 == fst cn = guard (snd cn0 == snd cn) >>
+			  return (cn : cns)
+addConstraint cn0 cns   = return (cn0 : cns)
+
+
+

src-2.9/GF/Conversion/SimpleToMCFG/Strict.hs

@@ -0,0 +1,129 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/09 09:28:44 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.5 $
+--
+-- Converting SimpleGFC grammars to MCFG grammars, deterministic.
+--
+-- the resulting grammars might be /very large/
+--
+-- the conversion is only equivalent if the GFC grammar has a context-free backbone.
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.SimpleToMCFG.Strict
+    (convertGrammar) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import Control.Monad
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG 
+import GF.Formalism.MCFG 
+import GF.Formalism.SimpleGFC 
+import GF.Conversion.Types
+
+import GF.Data.BacktrackM
+import GF.Data.SortedList
+
+----------------------------------------------------------------------
+-- main conversion function
+
+type CnvMonad a = BacktrackM () a
+
+convertGrammar :: SGrammar -> EGrammar 
+convertGrammar rules = tracePrt "SimpleToMCFG.Strict - MCFG rules" (prt . length) $
+		       solutions conversion undefined
+    where conversion = member rules >>= convertRule
+
+convertRule :: SRule -> CnvMonad ERule
+convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term)))
+    = do let cat : args  = map decl2cat (decl : decls)
+	     args_ctypes = zip3 [0..] args ctypes
+	 instArgs <- mapM enumerateArg args_ctypes
+	 let instTerm = substitutePaths instArgs term
+	 newCat <- extractECat cat ctype instTerm
+	 newArgs <- mapM (extractArg instArgs) args_ctypes
+	 let linRec = strPaths ctype instTerm >>= extractLin newArgs
+	 let newLinRec = map (instantiateArgs newArgs) linRec
+	     catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes)
+	 return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec) 
+convertRule _ = failure
+
+----------------------------------------------------------------------
+-- category extraction
+
+extractArg :: [STerm] -> (Int, SCat, SLinType) -> CnvMonad ECat
+extractArg args (nr, cat, ctype) = extractECat cat ctype (args !! nr)
+
+extractECat :: SCat -> SLinType -> STerm -> CnvMonad ECat
+extractECat cat ctype term = member $ map (ECat cat) $ parPaths ctype term
+
+enumerateArg :: (Int, SCat, SLinType) -> CnvMonad STerm
+enumerateArg (nr, cat, ctype) = member $ enumerateTerms (Just (Arg nr cat emptyPath)) ctype
+
+----------------------------------------------------------------------
+-- Substitute each instantiated parameter path for its instantiation
+
+substitutePaths :: [STerm] -> STerm -> STerm
+substitutePaths arguments = subst 
+    where subst (Arg nr _ path)  = termFollowPath path (arguments !! nr)
+	  subst (con :^ terms)   = con :^ map subst terms
+	  subst (Rec record)     = Rec [ (lbl, subst term) | (lbl, term) <- record ]
+	  subst (term :. lbl)    = subst term +. lbl
+	  subst (Tbl table)      = Tbl [ (pat, subst term) | 
+				      (pat, term) <- table ]
+	  subst (term :! select) = subst term +! subst select
+	  subst (term :++ term') = subst term ?++ subst term'
+	  subst (Variants terms) = Variants $ map subst terms
+	  subst term = term
+
+----------------------------------------------------------------------
+-- term paths extaction
+
+termPaths :: SLinType -> STerm -> [(SPath, (SLinType, STerm))]
+termPaths ctype (Variants terms) = terms >>= termPaths ctype
+termPaths (RecT rtype) (Rec record) 
+    = [ (path ++. lbl, value) |
+	(lbl, term) <- record,
+	let Just ctype = lookup lbl rtype,
+	(path, value) <- termPaths ctype term ]
+termPaths (TblT _ ctype) (Tbl table)
+    = [ (path ++! pat, value) |
+	(pat, term) <- table,
+	(path, value) <- termPaths ctype term ]
+termPaths ctype term | isBaseType ctype = [ (emptyPath, (ctype, term)) ]
+
+{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt):
+{a=a1; b=b1}  | {a=a2; b=b2}   ==>  {a=a1|a2; b=b1|b2}
+[p=>p1;q=>q1] | [p=>p2;q=>q2]  ==>  [p=>p1|p2;q=>q1|q2]
+-}
+
+parPaths :: SLinType -> STerm -> [[(SPath, STerm)]]
+parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $
+		      nubsort [ (path, value) | 
+				(path, (ConT _, value)) <- termPaths ctype term ]
+
+strPaths :: SLinType -> STerm -> [(SPath, STerm)]
+strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ]
+    where paths = nubsort [ (path, value) | (path, (StrT, value)) <- termPaths ctype term ]
+
+----------------------------------------------------------------------
+-- linearization extraction
+
+extractLin :: [ECat] -> (SPath, STerm) -> [Lin ECat MLabel Token]
+extractLin args (path, term) = map (Lin path) (convertLin term)
+    where convertLin (t1 :++ t2) = liftM2 (++) (convertLin t1) (convertLin t2)
+	  convertLin (Empty) = [[]]
+	  convertLin (Token tok) = [[Tok tok]]
+	  convertLin (Variants terms) = concatMap convertLin terms
+	  convertLin (Arg nr _ path) = [[Cat (args !! nr, path, nr)]]
+	  convertLin t = error $ "convertLin: " ++ prt t ++ "  " ++ prt (args, path)
+

src-2.9/GF/Conversion/TypeGraph.hs

@@ -0,0 +1,58 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/16 10:21:21 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.2 $
+--
+-- Printing the type hierarchy of an abstract module in GraphViz format
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.TypeGraph (prtTypeGraph, prtFunctionGraph) where
+
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC
+import GF.Formalism.Utilities
+import GF.Conversion.Types
+
+import GF.Data.Operations ((++++), (+++++))
+import GF.Infra.Print
+
+----------------------------------------------------------------------
+-- | SimpleGFC to TypeGraph
+--
+-- assumes that the profiles in the Simple GFC names are trivial
+
+prtTypeGraph :: SGrammar -> String
+prtTypeGraph rules = "digraph TypeGraph {" ++++ 
+                     "concentrate=true;" ++++
+                     "node [shape=ellipse];" +++++
+                     unlines (map prtTypeGraphRule rules) +++++
+                     "}"
+
+prtTypeGraphRule :: SRule -> String
+prtTypeGraphRule (Rule abs@(Abs cat cats (Name fun _prof)) _)
+    = "// " ++ prt abs ++++
+      unlines [ prtSCat c ++ " -> " ++ prtSCat cat ++ ";" | c <- cats ]
+
+prtFunctionGraph :: SGrammar -> String
+prtFunctionGraph rules = "digraph FunctionGraph {" ++++ 
+                         "node [shape=ellipse];" +++++
+                         unlines (map prtFunctionGraphRule rules) +++++
+                         "}"
+
+prtFunctionGraphRule :: SRule -> String
+prtFunctionGraphRule (Rule abs@(Abs cat cats (Name fun _prof)) _)
+    = "// " ++ prt abs ++++
+      pfun ++ " [label=\"" ++ prt fun ++ "\", shape=box, style=dashed];" ++++
+      pfun ++ " -> " ++ prtSCat cat ++ ";" ++++
+      unlines [ prtSCat c ++ " -> " ++ pfun ++ ";" | c <- cats ]
+    where pfun = "GF_FUNCTION_" ++ prt fun
+
+prtSCat decl = prt (decl2cat decl)
+
+

src-2.9/GF/Conversion/Types.hs

@@ -0,0 +1,146 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/08/11 14:11:46 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.10 $
+--
+-- All possible instantiations of different grammar formats used in conversion from GFC
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.Types where
+
+---import GF.Conversion.FTypes
+
+import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent)
+import qualified GF.Canon.AbsGFC as AbsGFC (CIdent(..), Label(..))
+import qualified GF.GFCC.CId
+import qualified GF.Grammar.Grammar as Grammar (Term)
+
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC
+import GF.Formalism.MCFG
+import GF.Formalism.FCFG
+import GF.Formalism.CFG
+import GF.Formalism.Utilities
+import GF.Infra.Print
+import GF.Data.Assoc
+
+import Control.Monad (foldM)
+import Data.Array
+
+----------------------------------------------------------------------
+-- * basic (leaf) types
+
+-- ** input tokens
+
+type Token = String
+
+-- ** function names
+
+type Fun  = Ident.Ident
+type Name = NameProfile Fun
+
+
+----------------------------------------------------------------------
+-- * Simple GFC
+
+type SCat = Ident.Ident
+
+constr2fun :: Constr -> Fun
+constr2fun (AbsGFC.CIQ _ fun) = fun
+
+-- ** grammar types
+
+type SGrammar = SimpleGrammar SCat Name Token
+type SRule    = SimpleRule    SCat Name Token
+
+type SPath    = Path    SCat Token
+type STerm    = Term    SCat Token
+type SLinType = LinType SCat Token
+type SDecl    = Decl    SCat
+
+----------------------------------------------------------------------
+-- * erasing MCFG
+
+type EGrammar = MCFGrammar ECat Name ELabel Token
+type ERule    = MCFRule    ECat Name ELabel Token
+data ECat     = ECat SCat [Constraint]   deriving (Eq, Ord, Show)
+type ELabel   = SPath
+
+type Constraint = (SPath, STerm)
+
+-- ** type coercions etc
+
+initialECat :: SCat -> ECat
+initialECat cat = ECat cat []
+
+ecat2scat :: ECat -> SCat
+ecat2scat (ECat cat _) = cat
+
+ecatConstraints :: ECat -> [Constraint]
+ecatConstraints (ECat _ cns) = cns
+
+sameECat :: ECat -> ECat -> Bool
+sameECat ec1 ec2 = ecat2scat ec1 == ecat2scat ec2
+
+coercionName :: Name
+coercionName = Name Ident.wildIdent [Unify [0]]
+
+isCoercion :: Name -> Bool
+isCoercion (Name fun [Unify [0]]) = Ident.isWildIdent fun
+isCoercion _ = False
+
+----------------------------------------------------------------------
+-- * nonerasing MCFG
+
+type MGrammar = MCFGrammar MCat Name MLabel Token
+type MRule    = MCFRule    MCat Name MLabel Token
+data MCat     = MCat ECat [ELabel]   deriving (Eq, Ord, Show)
+type MLabel   = ELabel
+
+mcat2ecat :: MCat -> ECat
+mcat2ecat (MCat cat _) = cat
+
+mcat2scat :: MCat -> SCat
+mcat2scat = ecat2scat . mcat2ecat
+
+----------------------------------------------------------------------
+-- * fast nonerasing MCFG
+
+---- moved to FTypes by AR 20/9/2007
+
+
+----------------------------------------------------------------------
+-- * CFG
+
+type CGrammar = CFGrammar CCat Name Token
+type CRule    = CFRule    CCat Name Token
+data CCat     = CCat      ECat ELabel  deriving (Eq, Ord, Show)
+
+ccat2ecat :: CCat -> ECat
+ccat2ecat (CCat cat _) = cat
+
+ccat2scat :: CCat -> SCat
+ccat2scat = ecat2scat . ccat2ecat
+
+----------------------------------------------------------------------
+-- * pretty-printing
+
+instance Print ECat where
+    prt (ECat cat constrs) = prt cat ++ "{" ++ 
+			     concat [ prt path ++ "=" ++ prt term ++ ";" |
+				      (path, term) <- constrs ] ++ "}"
+
+instance Print MCat where
+    prt (MCat cat labels) = prt cat ++ prt labels
+
+instance Print CCat where
+    prt (CCat cat label) = prt cat ++ prt label
+
+---- instance Print FCat where ---- FCat
+

src-2.9/GF/Data/Assoc.hs

@@ -0,0 +1,143 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Assoc
+-- Maintainer  : Peter Ljunglöf
+-- Stability   : Stable
+-- Portability : Haskell 98
+--
+-- > CVS $Date: 2005/05/09 09:28:44 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.4 $
+--
+-- Association lists, or finite maps,
+-- including sets as maps with result type @()@.
+-- function names stolen from module @Array@.
+-- /O(log n)/ key lookup
+-----------------------------------------------------------------------------
+
+module GF.Data.Assoc ( Assoc,
+		       Set,
+		       emptyAssoc,
+		       emptySet,
+		       listAssoc,
+		       listSet,
+		       accumAssoc,
+		       aAssocs,
+		       aElems,
+		       assocMap,
+		       assocFilter,
+		       lookupAssoc,
+		       lookupWith,
+		       (?),
+		       (?=)
+		     ) where
+
+import GF.Data.SortedList 
+
+infixl 9 ?, ?=
+
+-- | a set is a finite map with empty values
+type Set a = Assoc a ()
+
+emptyAssoc :: Ord a => Assoc a b
+emptySet   :: Ord a => Set a
+
+-- | creating a finite map from a sorted key-value list 
+listAssoc   :: Ord a => SList (a, b) -> Assoc a b
+
+-- | creating a set from a sorted list
+listSet     :: Ord a => SList a -> Set a
+
+-- | building a finite map from a list of keys and 'b's, 
+-- and a function that combines a sorted list of 'b's into a value
+accumAssoc :: (Ord a, Ord c) => (SList c -> b) -> [(a, c)] -> Assoc a b
+
+-- | all key-value pairs from an association list
+aAssocs :: Ord a => Assoc a b -> SList (a, b)
+
+-- | all keys from an association list
+aElems  :: Ord a => Assoc a b -> SList a
+
+-- fmap :: Ord a => (b -> b') -> Assoc a b -> Assoc a b'
+
+-- | mapping values to other values.
+-- the mapping function can take the key as information
+assocMap :: Ord a => (a -> b -> b') -> Assoc a b -> Assoc a b'
+
+assocFilter :: Ord a => (b -> Bool) -> Assoc a b -> Assoc a b
+assocFilter pred = listAssoc . filter (pred . snd) . aAssocs
+
+-- | monadic lookup function,
+-- returning failure if the key does not exist
+lookupAssoc :: (Ord a, Monad m) => Assoc a b -> a -> m b
+
+-- | if the key does not exist, 
+-- the first argument is returned
+lookupWith :: Ord a => b -> Assoc a b -> a -> b
+
+-- | if the values are monadic, we can return the value type
+(?) :: (Ord a, Monad m) => Assoc a (m b) -> a -> m b
+
+-- | checking wheter the map contains a given key 
+(?=) :: Ord a => Assoc a b -> a -> Bool
+
+
+------------------------------------------------------------
+
+data Assoc a b = ANil | ANode (Assoc a b) a b (Assoc a b)
+		 deriving (Eq, Ord, Show)
+
+emptyAssoc = ANil
+emptySet   = emptyAssoc
+
+listAssoc as = assoc
+  where (assoc, [])     = sl2bst (length as) as
+	sl2bst 0 xs     = (ANil, xs)
+	sl2bst 1 (x:xs) = (ANode ANil (fst x) (snd x) ANil, xs)
+	sl2bst n xs     = (ANode left (fst x) (snd x) right, zs)
+          where llen    = (n-1) `div` 2
+                rlen    = n - 1 - llen
+                (left, x:ys) = sl2bst llen xs
+                (right, zs)  = sl2bst rlen ys
+
+listSet as = listAssoc (zip as (repeat ()))
+
+accumAssoc join = listAssoc . map (mapSnd join) . groupPairs . nubsort
+    where mapSnd f (a, b) = (a, f b)
+
+aAssocs as = prs as []
+    where prs ANil = id
+	  prs (ANode left a b right) = prs left . ((a,b) :) . prs right
+
+aElems = map fst . aAssocs
+
+
+instance Ord a => Functor (Assoc a) where
+    fmap f = assocMap (const f)
+
+assocMap f ANil = ANil
+assocMap f (ANode left a b right) = ANode (assocMap f left) a (f a b) (assocMap f right)
+
+
+lookupAssoc ANil _ = fail "key not found"
+lookupAssoc (ANode left a b right) a' = case compare a a' of
+					  GT -> lookupAssoc left  a'
+					  LT -> lookupAssoc right a'
+					  EQ -> return b
+
+lookupWith z ANil _ = z
+lookupWith z (ANode left a b right) a' = case compare a a' of
+					   GT -> lookupWith z left  a'
+					   LT -> lookupWith z right a'
+					   EQ -> b
+
+(?) = lookupWith (fail "key not found")
+
+(?=) = \assoc -> maybe False (const True) . lookupAssoc assoc 
+
+
+
+
+
+
+