GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

removed src for 2.9

Browse Source
This commit is contained in:
aarne
2008-06-25 16:43:48 +00:00
parent fe367412e0
commit b96b36f43d
536 changed files with 0 additions and 127076 deletions
Download Patch File Download Diff File Expand all files Collapse all files

260
src/FILES
View File

@@ -1,260 +0,0 @@
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

52
src/GF-embed.cabal
View File

@@ -1,52 +0,0 @@
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

153
src/GF.hs
View File

@@ -1,153 +0,0 @@
{-# 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"
]

472
src/GF/API.hs
View File

@@ -1,472 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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])

43
src/GF/API/BatchTranslate.hs
View File

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

271
src/GF/API/GrammarToHaskell.hs
View File

@@ -1,271 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

94
src/GF/API/GrammarToTransfer.hs
View File

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

96
src/GF/API/IOGrammar.hs
View File

@@ -1,96 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

25
src/GF/API/MyParser.hs
View File

@@ -1,25 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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?")

213
src/GF/CF/CF.hs
View File

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

253
src/GF/CF/CFIdent.hs
View File

@@ -1,253 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

62
src/GF/CF/CFtoGrammar.hs
View File

@@ -1,62 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

214
src/GF/CF/CanonToCF.hs
View File

@@ -1,214 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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]
_ -> []

206
src/GF/CF/ChartParser.hs
View File

@@ -1,206 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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)

191
src/GF/CF/EBNF.hs
View File

@@ -1,191 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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,[]))

102
src/GF/CF/PPrCF.hs
View File

@@ -1,102 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

150
src/GF/CF/PrLBNF.hs
View File

@@ -1,150 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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))

106
src/GF/CF/Profile.hs
View File

@@ -1,106 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

45
src/GF/CFGM/AbsCFG.hs
View File

@@ -1,45 +0,0 @@
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)

36
src/GF/CFGM/CFG.cf
View File

@@ -1,36 +0,0 @@
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 - ["'\\"]) | ('\\' ["'\\"]))* '\'' ;

312
src/GF/CFGM/LexCFG.hs
View File

File diff suppressed because one or more lines are too long

135
src/GF/CFGM/LexCFG.x
View File

@@ -1,135 +0,0 @@
-- -*- 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
}

779
src/GF/CFGM/ParCFG.hs
View File

@@ -1,779 +0,0 @@
{-# 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.

129
src/GF/CFGM/ParCFG.y
View File

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

157
src/GF/CFGM/PrintCFG.hs
View File

@@ -1,157 +0,0 @@
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])

113
src/GF/CFGM/PrintCFGrammar.hs
View File

@@ -1,113 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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])

182
src/GF/Canon/AbsGFC.hs
View File

@@ -1,182 +0,0 @@
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)

38
src/GF/Canon/AbsToBNF.hs
View File

@@ -1,38 +0,0 @@
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 ++ "_"

334
src/GF/Canon/CMacros.hs
View File

@@ -1,334 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

45
src/GF/Canon/CanonToGFCC.hs
View File

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

203
src/GF/Canon/CanonToGrammar.hs
View File

@@ -1,203 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

170
src/GF/Canon/GFC.cf
View File

@@ -1,170 +0,0 @@
-- 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 "," ;

103
src/GF/Canon/GFC.hs
View File

@@ -1,103 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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
_ -> []

78
src/GF/Canon/GetGFC.hs
View File

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

346
src/GF/Canon/LexGFC.hs
View File

@@ -1,346 +0,0 @@
{-# 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

132
src/GF/Canon/LexGFC.x
View File

@@ -1,132 +0,0 @@
-- -*- 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
}

225
src/GF/Canon/Look.hs
View File

@@ -1,225 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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?

237
src/GF/Canon/MkGFC.hs
View File

@@ -1,237 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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)
-}

2142
src/GF/Canon/ParGFC.hs
View File

File diff suppressed because one or more lines are too long

385
src/GF/Canon/ParGFC.y
View File

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

46
src/GF/Canon/PrExp.hs
View File

@@ -1,46 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

376
src/GF/Canon/PrintGFC.hs
View File

@@ -1,376 +0,0 @@
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])

147
src/GF/Canon/Share.hs
View File

@@ -1,147 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

217
src/GF/Canon/SkelGFC.hs
View File

@@ -1,217 +0,0 @@
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

170
src/GF/Canon/Subexpressions.hs
View File

@@ -1,170 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

58
src/GF/Canon/TestGFC.hs
View File

@@ -1,58 +0,0 @@
-- 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

49
src/GF/Canon/Unlex.hs
View File

@@ -1,49 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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
[] -> []

63
src/GF/Canon/Unparametrize.hs
View File

@@ -1,63 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

20
src/GF/Canon/log.txt
View File

@@ -1,20 +0,0 @@
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

42
src/GF/Command/AbsGFShell.hs
View File

@@ -1,42 +0,0 @@
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)

159
src/GF/Command/Commands.hs
View File

@@ -1,159 +0,0 @@
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

27
src/GF/Command/GFShell.cf
View File

@@ -1,27 +0,0 @@
--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 "," ;

28
src/GF/Command/Importing.hs
View File

@@ -1,28 +0,0 @@
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

74
src/GF/Command/Interpreter.hs
View File

@@ -1,74 +0,0 @@
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

337
src/GF/Command/LexGFShell.hs
View File

File diff suppressed because one or more lines are too long

39
src/GF/Command/PPrTree.hs
View File

@@ -1,39 +0,0 @@
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

809
src/GF/Command/ParGFShell.hs
View File

@@ -1,809 +0,0 @@
{-# 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.

144
src/GF/Command/PrintGFShell.hs
View File

@@ -1,144 +0,0 @@
{-# 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])

21
src/GF/Compile/API.hs
View File

@@ -1,21 +0,0 @@
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))

141
src/GF/Compile/BackOpt.hs
View File

@@ -1,141 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

1078
src/GF/Compile/CheckGrammar.hs
View File

File diff suppressed because it is too large Load Diff

401
src/GF/Compile/Compile.hs
View File

@@ -1,401 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

477
src/GF/Compile/Evaluate.hs
View File

@@ -1,477 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

136
src/GF/Compile/Extend.hs
View File

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

92
src/GF/Compile/Flatten.hs
View File

@@ -1,92 +0,0 @@
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) ;
-}

146
src/GF/Compile/GetGrammar.hs
View File

@@ -1,146 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

293
src/GF/Compile/GrammarToCanon.hs
View File

@@ -1,293 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

154
src/GF/Compile/MkConcrete.hs
View File

@@ -1,154 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

128
src/GF/Compile/MkResource.hs
View File

@@ -1,128 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

83
src/GF/Compile/MkUnion.hs
View File

@@ -1,83 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

153
src/GF/Compile/ModDeps.hs
View File

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

294
src/GF/Compile/NewRename.hs
View File

@@ -1,294 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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')

49
src/GF/Compile/NoParse.hs
View File

@@ -1,49 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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
_ -> []

300
src/GF/Compile/Optimize.hs
View File

@@ -1,300 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

77
src/GF/Compile/PGrammar.hs
View File

@@ -1,77 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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"
-}

84
src/GF/Compile/PrOld.hs
View File

@@ -1,84 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

99
src/GF/Compile/Rebuild.hs
View File

@@ -1,99 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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):)

63
src/GF/Compile/RemoveLiT.hs
View File

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

338
src/GF/Compile/Rename.hs
View File

@@ -1,338 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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')

568
src/GF/Compile/ShellState.hs
View File

@@ -1,568 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

135
src/GF/Compile/Update.hs
View File

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

108
src/GF/Compile/Wordlist.hs
View File

@@ -1,108 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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 /= "--"

157
src/GF/Conversion/GFC.hs
View File

@@ -1,157 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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 ++ "'"

175
src/GF/Conversion/GFCtoSimple.hs
View File

@@ -1,175 +0,0 @@
---------------------------------------------------------------------
-- |
-- 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

71
src/GF/Conversion/Haskell.hs
View File

@@ -1,71 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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)

53
src/GF/Conversion/MCFGtoCFG.hs
View File

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

51
src/GF/Conversion/MCFGtoFCFG.hs
View File

@@ -1,51 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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)

205
src/GF/Conversion/Prolog.hs
View File

@@ -1,205 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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 '%'

46
src/GF/Conversion/RemoveEpsilon.hs
View File

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

113
src/GF/Conversion/RemoveErasing.hs
View File

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

82
src/GF/Conversion/RemoveSingletons.hs
View File

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

536
src/GF/Conversion/SimpleToFCFG.hs
View File

@@ -1,536 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

178
src/GF/Conversion/SimpleToFinite.hs
View File

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

26
src/GF/Conversion/SimpleToMCFG.hs
View File

@@ -1,26 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

63
src/GF/Conversion/SimpleToMCFG/Coercions.hs
View File

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

256
src/GF/Conversion/SimpleToMCFG/Nondet.hs
View File

@@ -1,256 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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)

129
src/GF/Conversion/SimpleToMCFG/Strict.hs
View File

@@ -1,129 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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)

58
src/GF/Conversion/TypeGraph.hs
View File

@@ -1,58 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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)

146
src/GF/Conversion/Types.hs
View File

@@ -1,146 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

143
src/GF/Data/Assoc.hs
View File

@@ -1,143 +0,0 @@
----------------------------------------------------------------------
-- |
-- 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

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