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

changed names of resource-1.3; added a note on homepage on release

Browse Source
This commit is contained in:
aarne
2008-06-25 16:54:35 +00:00
parent b96b36f43d
commit e9e80fc389
903 changed files with 113 additions and 32 deletions
Download Patch File Download Diff File Expand all files Collapse all files

260
src/FILES Normal file
View File

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

41
src/GF.hs Normal file
View File

@@ -0,0 +1,41 @@
{-# OPTIONS -cpp #-}
module Main where
import GFC
import GFI
import GF.Data.ErrM
import GF.Infra.Option
import GF.Infra.UseIO
import Paths_gf
import Data.Version
import System.Environment (getArgs)
import System.Exit
import System.IO
#ifdef mingw32_HOST_OS
import System.Win32.Console
import System.Win32.NLS
#endif
main :: IO ()
main = do
#ifdef mingw32_HOST_OS
codepage <- getACP
setConsoleCP codepage
setConsoleOutputCP codepage
#endif
args <- getArgs
case parseOptions args of
Ok (opts,files) -> mainOpts opts files
Bad err -> do hPutStrLn stderr err
hPutStrLn stderr "You may want to try --help."
exitFailure
mainOpts :: Options -> [FilePath] -> IO ()
mainOpts opts files =
case flag optMode opts of
ModeVersion -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version
ModeHelp -> putStrLn helpMessage
ModeInteractive -> mainGFI opts files
ModeCompiler -> dieIOE (mainGFC opts files)

67
src/GF/Command/Abstract.hs Normal file
View File

@@ -0,0 +1,67 @@
module GF.Command.Abstract where
import PGF.Data
type Ident = String
type CommandLine = [Pipe]
type Pipe = [Command]
data Command
= Command Ident [Option] Argument
deriving (Eq,Ord,Show)
data Option
= OOpt Ident
| OFlag Ident Value
deriving (Eq,Ord,Show)
data Value
= VId Ident
| VInt Integer
| VStr String
deriving (Eq,Ord,Show)
data Argument
= ATree Tree
| ANoArg
| AMacro Ident
deriving (Eq,Ord,Show)
valIdOpts :: String -> String -> [Option] -> String
valIdOpts flag def opts = case valOpts flag (VId def) opts of
VId v -> v
_ -> def
valIntOpts :: String -> Integer -> [Option] -> Int
valIntOpts flag def opts = fromInteger $ case valOpts flag (VInt def) opts of
VInt v -> v
_ -> def
valStrOpts :: String -> String -> [Option] -> String
valStrOpts flag def opts = case valOpts flag (VStr def) opts of
VStr 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 f v <- opts]
isOpt :: String -> [Option] -> Bool
isOpt o opts = elem o [x | OOpt x <- opts]
isFlag :: String -> [Option] -> Bool
isFlag o opts = elem o [x | OFlag x _ <- opts]
prOpt :: Option -> String
prOpt o = case o of
OOpt i -> i
OFlag f x -> f ++ "=" ++ show x
mkOpt :: String -> Option
mkOpt = OOpt

603
src/GF/Command/Commands.hs Normal file
View File

@@ -0,0 +1,603 @@
module GF.Command.Commands (
allCommands,
lookCommand,
exec,
isOpt,
options,
flags,
CommandInfo,
CommandOutput
) where
import PGF
import PGF.CId
import PGF.ShowLinearize
import PGF.Macros
import PGF.Data ----
import PGF.Morphology
import PGF.Quiz
import PGF.VisualizeTree
import GF.Compile.Export
import GF.Infra.Option (noOptions)
import GF.Infra.UseIO
import GF.Data.ErrM ----
import PGF.Expr (readTree)
import GF.Command.Abstract
import GF.Text.Lexing
import GF.Text.Transliterations
import GF.Data.Operations
import Data.Maybe
import qualified Data.Map as Map
import System.Cmd
import Debug.Trace
type CommandOutput = ([Tree],String) ---- errors, etc
data CommandInfo = CommandInfo {
exec :: [Option] -> [Tree] -> IO CommandOutput,
synopsis :: String,
syntax :: String,
explanation :: String,
longname :: String,
options :: [(String,String)],
flags :: [(String,String)],
examples :: [String]
}
emptyCommandInfo :: CommandInfo
emptyCommandInfo = CommandInfo {
exec = \_ ts -> return (ts,[]), ----
synopsis = "",
syntax = "",
explanation = "",
longname = "",
options = [],
flags = [],
examples = []
}
lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo
lookCommand = Map.lookup
commandHelpAll :: PGF -> [Option] -> String
commandHelpAll pgf opts = unlines
[commandHelp (isOpt "full" opts) (co,info)
| (co,info) <- Map.assocs (allCommands pgf)]
commandHelp :: Bool -> (String,CommandInfo) -> String
commandHelp full (co,info) = unlines $ [
co ++ ", " ++ longname info,
synopsis info] ++ if full then [
"",
"syntax:" ++++ " " ++ syntax info,
"",
explanation info,
"options:" ++++ unlines [" -" ++ o ++ "\t" ++ e | (o,e) <- options info],
"flags:" ++++ unlines [" -" ++ o ++ "\t" ++ e | (o,e) <- flags info],
"examples:" ++++ unlines [" " ++ s | s <- examples info]
] else []
-- this list must no more be kept sorted by the command name
allCommands :: PGF -> Map.Map String CommandInfo
allCommands pgf = Map.fromList [
("cc", emptyCommandInfo {
longname = "compute_concrete",
syntax = "cc (-all | -table | -unqual)? TERM",
synopsis = "computes concrete syntax term using a source grammar",
explanation = unlines [
"Compute TERM by concrete syntax definitions. Uses the topmost",
"module (the last one imported) to resolve constant names.",
"N.B.1 You need the flag -retain when importing the grammar, if you want",
"the definitions to be retained after compilation.",
"N.B.2 The resulting term is not a tree in the sense of abstract syntax",
"and hence not a valid input to a Tree-expecting command.",
"This command must be a line of its own, and thus cannot be a part",
"of a pipe."
],
options = [
("all","pick all strings (forms and variants) from records and tables"),
("table","show all strings labelled by parameters"),
("unqual","hide qualifying module names")
]
}),
("dc", emptyCommandInfo {
longname = "define_command",
syntax = "dc IDENT COMMANDLINE",
synopsis = "define a command macro",
explanation = unlines [
"Defines IDENT as macro for COMMANDLINE, until IDENT gets redefined.",
"A call of the command has the form %IDENT. The command may take an",
"argument, which in COMMANDLINE is marked as ?0. Both strings and",
"trees can be arguments. Currently at most one argument is possible.",
"This command must be a line of its own, and thus cannot be a part",
"of a pipe."
]
}),
("dt", emptyCommandInfo {
longname = "define_tree",
syntax = "dt IDENT (TREE | STRING | \"<\" COMMANDLINE)",
synopsis = "define a tree or string macro",
explanation = unlines [
"Defines IDENT as macro for TREE or STRING, until IDENT gets redefined.",
"The defining value can also come from a command, preceded by \"<\".",
"If the command gives many values, the first one is selected.",
"A use of the macro has the form %IDENT. Currently this use cannot be",
"a subtree of another tree. This command must be a line of its own",
"and thus cannot be a part of a pipe."
],
examples = [
("dt ex \"hello world\" -- define ex as string"),
("dt ex UseN man_N -- define ex as string"),
("dt ex < p -cat=NP \"the man in the car\" -- define ex as parse result"),
("l -lang=LangSwe %ex | ps -to_utf8 -- linearize the tree ex")
]
}),
("e", emptyCommandInfo {
longname = "empty",
synopsis = "empty the environment"
}),
("gr", emptyCommandInfo {
longname = "generate_random",
synopsis = "generate random trees in the current abstract syntax",
syntax = "gr [-cat=CAT] [-number=INT]",
examples = [
"gr -- one tree in the startcat of the current grammar",
"gr -cat=NP -number=16 -- 16 trees in the category NP"
],
explanation = unlines [
"Generates a list of random trees, by default one tree."
---- "If a tree argument is given, the command completes the Tree with values to",
---- "the metavariables in the tree."
],
flags = [
("cat","generation category"),
("lang","excludes functions that have no linearization in this language"),
("number","number of trees generated")
],
exec = \opts _ -> do
let pgfr = optRestricted opts
ts <- generateRandom pgfr (optCat opts)
return $ fromTrees $ take (optNum opts) ts
}),
("gt", emptyCommandInfo {
longname = "generate_trees",
synopsis = "generates a list of trees, by default exhaustive",
explanation = unlines [
"Generates all trees of a given category, with increasing depth.",
"By default, the depth is 4, but this can be changed by a flag."
---- "If a Tree argument is given, the command completes the Tree with values",
---- "to the metavariables in the tree."
],
flags = [
("cat","the generation category"),
("depth","the maximum generation depth"),
("lang","excludes functions that have no linearization in this language"),
("number","the number of trees generated")
],
exec = \opts _ -> do
let pgfr = optRestricted opts
let dp = return $ valIntOpts "depth" 4 opts
let ts = generateAllDepth pgfr (optCat opts) dp
return $ fromTrees $ take (optNumInf opts) ts
}),
("h", emptyCommandInfo {
longname = "help",
syntax = "h (-full)? COMMAND?",
synopsis = "get description of a command, or a the full list of commands",
explanation = unlines [
"Displays information concerning the COMMAND.",
"Without argument, shows the synopsis of all commands."
],
options = [
("full","give full information of the commands")
],
exec = \opts ts -> return ([], case ts of
[t] -> let co = showTree t in
case lookCommand co (allCommands pgf) of ---- new map ??!!
Just info -> commandHelp True (co,info)
_ -> "command not found"
_ -> commandHelpAll pgf opts)
}),
("i", emptyCommandInfo {
longname = "import",
synopsis = "import a grammar from source code or compiled .pgf file",
explanation = unlines [
"Reads a grammar from File and compiles it into a GF runtime grammar.",
"If a grammar with the same concrete name is already in the state",
"it is overwritten - but only if compilation succeeds.",
"The grammar parser depends on the file name suffix:",
" .gf normal GF source",
" .gfo compiled GF source",
" .pgf precompiled grammar in Portable Grammar Format"
],
options = [
-- ["prob", "retain", "gfo", "src", "no-cpu", "cpu", "quiet", "verbose"]
("retain","retain operations (used for cc command)"),
("src", "force compilation from source"),
("v", "be verbose - show intermediate status information")
]
}),
("l", emptyCommandInfo {
longname = "linearize",
synopsis = "convert an abstract syntax expression to string",
explanation = unlines [
"Shows the linearization of a Tree by the grammars in scope.",
"The -lang flag can be used to restrict this to fewer languages.",
"A sequence of string operations (see command ps) can be given",
"as options, and works then like a pipe to the ps command, except",
"that it only affect the strings, not e.g. the table labels.",
"These can be given separately to each language with the unlexer flag",
"whose results are prepended to the other lexer flags. The value of the",
"unlexer flag is a space-separated list of comma-separated string operation",
"sequences; see example."
],
examples = [
"l -langs=LangSwe,LangNor no_Utt -- linearize tree to LangSwe and LangNor",
"gr -lang=LangHin -cat=Cl | l -table -to_devanagari -to_utf8 -- hindi table",
"l -unlexer=\"LangSwe=to_utf8 LangHin=to_devanagari,to_utf8\" -- different lexers"
],
exec = \opts -> return . fromStrings . map (optLin opts),
options = [
("all","show all forms and variants"),
("record","show source-code-like record"),
("table","show all forms labelled by parameters"),
("term", "show PGF term"),
("treebank","show the tree and tag linearizations with language names")
] ++ stringOpOptions,
flags = [
("lang","the languages of linearization (comma-separated, no spaces)"),
("unlexer","set unlexers separately to each language (space-separated)")
]
}),
("ma", emptyCommandInfo {
longname = "morpho_analyse",
synopsis = "print the morphological analyses of all words in the string",
explanation = unlines [
"Prints all the analyses of space-separated words in the input string,",
"using the morphological analyser of the actual grammar (see command pf)"
],
exec = \opts ->
return . fromString . unlines .
map prMorphoAnalysis . concatMap (morphos opts) .
concatMap words . toStrings
}),
("mq", emptyCommandInfo {
longname = "morpho_quiz",
synopsis = "start a morphology quiz",
exec = \opts _ -> do
let lang = optLang opts
let cat = optCat opts
morphologyQuiz pgf lang cat
return void,
flags = [
("lang","language of the quiz"),
("cat","category of the quiz"),
("number","maximum number of questions")
]
}),
("p", emptyCommandInfo {
longname = "parse",
synopsis = "parse a string to abstract syntax expression",
explanation = unlines [
"Shows all trees returned by parsing a string in the grammars in scope.",
"The -lang flag can be used to restrict this to fewer languages.",
"The default start category can be overridden by the -cat flag.",
"See also the ps command for lexing and character encoding."
],
exec = \opts -> return . fromTrees . concatMap (par opts) . toStrings,
flags = [
("cat","target category of parsing"),
("lang","the languages of parsing (comma-separated, no spaces)")
]
}),
("pg", emptyCommandInfo { -----
longname = "print_grammar",
synopsis = "print the actual grammar with the given printer",
explanation = unlines [
"Prints the actual grammar, with all involved languages.",
"In some printers, this can be restricted to a subset of languages",
"with the -lang=X,Y flag (comma-separated, no spaces).",
"The -printer=P flag sets the format in which the grammar is printed.",
"N.B.1 Since grammars are compiled when imported, this command",
"generally shows a grammar that looks rather different from the source.",
"N.B.2 This command is slightly obsolete: to produce different formats",
"the batch compiler gfc is recommended, and has many more options."
],
exec = \opts _ -> return $ fromString $ prGrammar opts,
flags = [
--"cat",
("lang", "select languages for the some options (default all languages)"),
("printer","select the printing format (see gfc --help)")
],
options = [
("cats", "show just the names of abstract syntax categories"),
("fullform", "print the fullform lexicon"),
("missing","show just the names of functions that have no linearization")
]
}),
("ph", emptyCommandInfo {
longname = "print_history",
synopsis = "print command history",
explanation = unlines [
"Prints the commands issued during the GF session.",
"The result is readable by the eh command.",
"The result can be used as a script when starting GF."
],
examples = [
"ph | wf -file=foo.gfs -- save the history into a file"
]
}),
("ps", emptyCommandInfo {
longname = "put_string",
syntax = "ps OPT? STRING",
synopsis = "return a string, possibly processed with a function",
explanation = unlines [
"Returns a string obtained from its argument string by applying",
"string processing functions in the order given in the command line",
"option list. Thus 'ps -f -g s' returns g (f s). Typical string processors",
"are lexers and unlexers, but also character encoding conversions are possible.",
"The unlexers preserve the division of their input to lines.",
"To see transliteration tables, use command ut."
],
examples = [
"l (EAdd 3 4) | ps -code -- linearize code-like output",
"ps -lexer=code | p -cat=Exp -- parse code-like input",
"gr -cat=QCl | l | ps -bind -to_utf8 -- linearization output from LangFin",
"ps -from_utf8 \"jag ?r h?r\" | p -- parser in LangSwe in UTF8 terminal",
"ps -to_devanagari -to_utf8 \"A-p\" -- show Devanagari in UTF8 terminal"
],
exec = \opts -> return . fromString . stringOps (map prOpt opts) . toString,
options = stringOpOptions
}),
("q", emptyCommandInfo {
longname = "quit",
synopsis = "exit GF interpreter"
}),
("rf", emptyCommandInfo {
longname = "read_file",
synopsis = "read string or tree input from a file",
explanation = unlines [
"Reads input from file. The filename must be in double quotes.",
"The input is interpreted as a string by default, and can hence be",
"piped e.g. to the parse command. The option -tree interprets the",
"input as a tree, which can be given e.g. to the linearize command.",
"The option -lines will result in a list of strings or trees, one by line."
],
options = [
("lines","return the list of lines, instead of the singleton of all contents"),
("tree","convert strings into trees")
],
exec = \opts arg -> do
let file = valIdOpts "file" "_gftmp" opts
s <- readFile file
return $ case opts of
_ | isOpt "lines" opts && isOpt "tree" opts ->
fromTrees [t | l <- lines s, Just t <- [readTree l]]
_ | isOpt "tree" opts ->
fromTrees [t | Just t <- [readTree s]]
_ | isOpt "lines" opts -> fromStrings $ lines s
_ -> fromString s,
flags = [("file","the input file name")]
}),
("tq", emptyCommandInfo {
longname = "translation_quiz",
synopsis = "start a translation quiz",
exec = \opts _ -> do
let from = valIdOpts "from" (optLang opts) opts
let to = valIdOpts "to" (optLang opts) opts
let cat = optCat opts
translationQuiz pgf from to cat
return void,
flags = [
("from","translate from this language"),
("to","translate to this language"),
("cat","translate in this category"),
("number","the maximum number of questions")
]
}),
("sp", emptyCommandInfo {
longname = "system_pipe",
synopsis = "send argument to a system command",
syntax = "sp -command=\"SYSTEMCOMMAND\" STRING",
exec = \opts arg -> do
let tmpi = "_tmpi" ---
let tmpo = "_tmpo"
writeFile tmpi $ toString arg
let syst = optComm opts ++ " " ++ tmpi
system $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
s <- readFile tmpo
return $ fromString s,
flags = [
("command","the system command applied to the argument")
],
examples = [
"ps -command=\"wc\" \"foo\"",
"gt | l | sp -command=\"grep \\\"who\\\"\" | sp -command=\"wc\""
]
}),
("ut", emptyCommandInfo {
longname = "unicode_table",
synopsis = "show a transliteration table for a unicode character set",
exec = \opts arg -> do
let t = concatMap prOpt (take 1 opts)
let out = maybe "no such transliteration" characterTable $ transliteration t
return $ fromString out,
options = [
("devanagari","Devanagari"),
("thai", "Thai")
]
}),
("vt", emptyCommandInfo {
longname = "visualize_tree",
synopsis = "show a set of trees graphically",
explanation = unlines [
"Prints a set of trees in the .dot format (the graphviz format).",
"The graph can be saved in a file by the wf command as usual.",
"If the -view flag is defined, the graph is saved in a temporary file",
"which is processed by graphviz and displayed by the program indicated",
"by the flag. The target format is postscript, unless overridden by the",
"flag -format."
],
exec = \opts ts -> do
let funs = not (isOpt "nofun" opts)
let cats = not (isOpt "nocat" opts)
let grph = visualizeTrees pgf (funs,cats) ts -- True=digraph
if isFlag "view" opts || isFlag "format" opts then do
let file s = "_grph." ++ s
let view = optViewGraph opts ++ " "
let format = optViewFormat opts
writeFile (file "dot") grph
system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format ++
" ; " ++ view ++ file format
return void
else return $ fromString grph,
examples = [
"p \"hello\" | vt -- parse a string and show trees as graph script",
"p \"hello\" | vt -view=\"open\" -- parse a string and display trees on a Mac"
],
options = [
("nofun","don't show functions but only categories"),
("nocat","don't show categories but only functions")
],
flags = [
("format","format of the visualization file (default \"ps\")"),
("view","program to open the resulting file (default \"gv\")")
]
}),
("wf", emptyCommandInfo {
longname = "write_file",
synopsis = "send string or tree to a file",
exec = \opts arg -> do
let file = valIdOpts "file" "_gftmp" opts
if isOpt "append" opts
then appendFile file (toString arg)
else writeFile file (toString arg)
return void,
options = [
("append","append to file, instead of overwriting it")
],
flags = [("file","the output filename")]
})
]
where
lin opts t = unlines [linearize pgf lang t | lang <- optLangs opts]
par opts s = concat [parse pgf lang (optCat opts) s | lang <- optLangs opts]
void = ([],[])
optLin opts t = case opts of
_ | isOpt "treebank" opts -> treebank opts t
_ -> unlines [linear opts lang t | lang <- optLangs opts]
linear opts lang = let unl = unlex opts lang in case opts of
_ | isOpt "all" opts -> allLinearize unl pgf (mkCId lang)
_ | isOpt "table" opts -> tableLinearize unl pgf (mkCId lang)
_ | isOpt "term" opts -> termLinearize pgf (mkCId lang)
_ | isOpt "record" opts -> recordLinearize pgf (mkCId lang)
_ -> unl . linearize pgf lang
treebank opts t = unlines $
(abstractName pgf ++ ": " ++ showTree t) :
[lang ++ ": " ++ linear opts lang t | lang <- optLangs opts]
unlex opts lang = stringOps (getUnlex opts lang ++ map prOpt opts)
getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of
lexs -> case lookup lang
[(la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of
Just le -> chunks ',' le
_ -> []
-- Proposed logic of coding in unlexing:
-- - If lang has no coding flag, or -to_utf8 is not in opts, just opts are used.
-- - If lang has flag coding=utf8, -to_utf8 is ignored.
-- - If lang has coding=other, and -to_utf8 is in opts, from_other is applied first.
-- THIS DOES NOT WORK UNFORTUNATELY - can't use the grammar flag properly
unlexx opts lang = {- trace (unwords optsC) $ -} stringOps optsC where
optsC = case lookFlag pgf lang "coding" of
Just "utf8" -> filter (/="to_utf8") $ map prOpt opts
Just other | isOpt "to_utf8" opts ->
let cod = ("from_" ++ other)
in cod : filter (/=cod) (map prOpt opts)
_ -> map prOpt opts
optRestricted opts = restrictPGF (hasLin pgf (mkCId (optLang opts))) pgf
optLangs opts = case valIdOpts "lang" "" opts of
"" -> languages pgf
lang -> chunks ',' lang
optLang opts = head $ optLangs opts ++ ["#NOLANG"]
optCat opts = valIdOpts "cat" (lookStartCat pgf) opts
optComm opts = valStrOpts "command" "" opts
optViewFormat opts = valStrOpts "format" "ps" opts
optViewGraph opts = valStrOpts "view" "gv" opts
optNum opts = valIntOpts "number" 1 opts
optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
fromTrees ts = (ts,unlines (map showTree ts))
fromStrings ss = (map (Lit . LStr) ss, unlines ss)
fromString s = ([Lit (LStr s)], s)
toStrings ts = [s | Lit (LStr s) <- ts]
toString ts = unwords [s | Lit (LStr s) <- ts]
prGrammar opts = case opts of
_ | isOpt "cats" opts -> unwords $ categories pgf
_ | isOpt "fullform" opts -> concatMap
(prFullFormLexicon . buildMorpho pgf . mkCId) $ optLangs opts
_ | isOpt "missing" opts ->
unlines $ [unwords (la:":": map prCId cs) |
la <- optLangs opts, let cs = missingLins pgf (mkCId la)]
_ -> case valIdOpts "printer" "pgf" opts of
v -> concatMap snd $ exportPGF noOptions (read v) pgf
morphos opts s =
[lookupMorpho (buildMorpho pgf (mkCId la)) s | la <- optLangs opts]
-- ps -f -g s returns g (f s)
stringOps opts s = foldr app s (reverse opts) where
app f = maybe id id (stringOp f)
stringOpOptions = [
("bind","bind tokens separated by Prelude.BIND, i.e. &+"),
("chars","lexer that makes every non-space character a token"),
("from_cp1251","decode from cp1251 (Cyrillic used in Bulgarian resource)"),
("from_devanagari","from unicode to GF Devanagari transliteration"),
("from_thai","from unicode to GF Thai transliteration"),
("from_utf8","decode from utf8"),
("lextext","text-like lexer"),
("lexcode","code-like lexer"),
("lexmixed","mixture of text and code (code between $...$)"),
("to_cp1251","encode to cp1251 (Cyrillic used in Bulgarian resource)"),
("to_devanagari","from GF Devanagari transliteration to unicode"),
("to_html","wrap in a html file with linebreaks"),
("to_thai","from GF Thai transliteration to unicode"),
("to_utf8","encode to utf8"),
("unlextext","text-like unlexer"),
("unlexcode","code-like unlexer"),
("unlexmixed","mixture of text and code (code between $...$)"),
("unchars","unlexer that puts no spaces between tokens"),
("unwords","unlexer that puts a single space between tokens (default)"),
("words","lexer that assumes tokens separated by spaces (default)")
]
translationQuiz :: PGF -> Language -> Language -> Category -> IO ()
translationQuiz pgf ig og cat = do
tts <- translationList pgf ig og cat infinity
mkQuiz "Welcome to GF Translation Quiz." tts
morphologyQuiz :: PGF -> Language -> Category -> IO ()
morphologyQuiz pgf ig cat = do
tts <- morphologyList pgf ig cat infinity
mkQuiz "Welcome to GF Morphology Quiz." tts
-- | the maximal number of precompiled quiz problems
infinity :: Int
infinity = 256
lookFlag :: PGF -> String -> String -> Maybe String
lookFlag pgf lang flag = lookConcrFlag pgf (mkCId lang) (mkCId flag)

37
src/GF/Command/Importing.hs Normal file
View File

@@ -0,0 +1,37 @@
module GF.Command.Importing (importGrammar, importSource) where
import PGF
import PGF.Data
import GF.Compile
import GF.Grammar.Grammar (SourceGrammar) -- for cc command
import GF.Infra.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 :: PGF -> Options -> [FilePath] -> IO PGF
importGrammar pgf0 _ [] = return pgf0
importGrammar pgf0 opts files =
case takeExtensions (last files) of
s | elem s [".gf",".gfo"] -> do
res <- appIOE $ compileToPGF opts files
case res of
Ok pgf2 -> do return $ unionPGF pgf0 pgf2
Bad msg -> do putStrLn msg
return pgf0
".pgf" -> do
pgf2 <- mapM readPGF files >>= return . foldl1 unionPGF
return $ unionPGF pgf0 pgf2
importSource :: SourceGrammar -> Options -> [FilePath] -> IO SourceGrammar
importSource src0 opts files = do
src <- appIOE $ batchCompile opts files
case src of
Ok gr -> return gr
Bad msg -> do
putStrLn msg
return src0

121
src/GF/Command/Interpreter.hs Normal file
View File

@@ -0,0 +1,121 @@
module GF.Command.Interpreter (
CommandEnv (..),
mkCommandEnv,
emptyCommandEnv,
interpretCommandLine,
interpretPipe,
getCommandOp
) where
import GF.Command.Commands
import GF.Command.Abstract
import GF.Command.Parse
import PGF
import PGF.Data
import PGF.Macros
import GF.System.Signal
import GF.Infra.UseIO
import GF.Data.ErrM ----
import qualified Data.Map as Map
data CommandEnv = CommandEnv {
multigrammar :: PGF,
commands :: Map.Map String CommandInfo,
commandmacros :: Map.Map String CommandLine,
expmacros :: Map.Map String Tree
}
mkCommandEnv :: PGF -> CommandEnv
mkCommandEnv pgf = CommandEnv pgf (allCommands pgf) Map.empty Map.empty
emptyCommandEnv :: CommandEnv
emptyCommandEnv = mkCommandEnv emptyPGF
interpretCommandLine :: CommandEnv -> String -> IO ()
interpretCommandLine env line =
case readCommandLine line of
Just [] -> return ()
Just pipes -> do res <- runInterruptibly (mapM_ (interpretPipe env) pipes)
case res of
Left ex -> putStrLnFlush (show ex)
Right x -> return x
Nothing -> putStrLnFlush "command not parsed"
interpretPipe env cs = do
v@(_,s) <- intercs ([],"") cs
putStrLnFlush s
return v
where
intercs treess [] = return treess
intercs (trees,_) (c:cs) = do
treess2 <- interc trees c
intercs treess2 cs
interc es comm@(Command co _ arg) = case co of
'%':f -> case Map.lookup f (commandmacros env) of
Just css -> do
mapM_ (interpretPipe env) (appLine (getCommandArg env arg es) css)
return ([],[]) ---- return ?
_ -> do
putStrLn $ "command macro " ++ co ++ " not interpreted"
return ([],[])
_ -> interpret env es comm
appLine es = map (map (appCommand es))
-- macro definition applications: replace ?i by (exps !! i)
appCommand :: [Tree] -> Command -> Command
appCommand xs c@(Command i os arg) = case arg of
ATree e -> Command i os (ATree (app e))
_ -> c
where
app e = case e of
Meta i -> xs !! i
Fun f as -> Fun f (map app as)
Abs x b -> Abs x (app b)
-- 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 env comm trees0
comms = commands env
checkOpts info =
case
[o | OOpt o <- opts, notElem o ("tr" : map fst (options info))] ++
[o | OFlag o _ <- opts, notElem o (map fst (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
--- the env is needed for macro lookup
getCommand :: CommandEnv -> Command -> [Tree] -> (String,[Option],[Tree])
getCommand env co@(Command c opts arg) ts =
(getCommandOp c,opts,getCommandArg env arg ts)
getCommandArg :: CommandEnv -> Argument -> [Tree] -> [Tree]
getCommandArg env a ts = case a of
AMacro m -> case Map.lookup m (expmacros env) of
Just t -> [t]
_ -> []
ATree t -> [t] -- ignore piped
ANoArg -> ts -- use piped
-- abbreviation convention from gf commands
getCommandOp s = case break (=='_') s of
(a:_,_:b:_) -> [a,b] -- axx_byy --> ab
_ -> case s of
[a,b] -> s -- ab --> ab
a:_ -> [a] -- axx --> a

48
src/GF/Command/Parse.hs Normal file
View File

@@ -0,0 +1,48 @@
module GF.Command.Parse(readCommandLine, pCommand) where
import PGF.Expr
import PGF.Data(Tree)
import GF.Command.Abstract
import Data.Char
import Control.Monad
import qualified Text.ParserCombinators.ReadP as RP
readCommandLine :: String -> Maybe CommandLine
readCommandLine s = case [x | (x,cs) <- RP.readP_to_S pCommandLine s, all isSpace cs] of
[x] -> Just x
_ -> Nothing
test s = RP.readP_to_S pCommandLine s
pCommandLine = RP.sepBy (RP.skipSpaces >> pPipe) (RP.skipSpaces >> RP.char ';')
pPipe = RP.sepBy1 (RP.skipSpaces >> pCommand) (RP.skipSpaces >> RP.char '|')
pCommand = do
cmd <- pIdent RP.<++ (RP.char '%' >> pIdent >>= return . ('%':))
RP.skipSpaces
opts <- RP.sepBy pOption RP.skipSpaces
arg <- pArgument
return (Command cmd opts arg)
pOption = do
RP.char '-'
flg <- pIdent
RP.option (OOpt flg) (fmap (OFlag flg) (RP.char '=' >> pValue))
pValue = do
fmap (VInt . read) (RP.munch1 isDigit)
RP.<++
fmap VStr pStr
RP.<++
fmap VId pFilename
pFilename = liftM2 (:) (RP.satisfy isFileFirst) (RP.munch (not . isSpace)) where
isFileFirst c = not (isSpace c) && not (isDigit c)
pArgument =
RP.option ANoArg
(fmap ATree (pTree False)
RP.<++
(RP.munch isSpace >> RP.char '%' >> fmap AMacro pIdent))

226
src/GF/Compile.hs Normal file
View File

@@ -0,0 +1,226 @@
module GF.Compile (batchCompile, link, compileToPGF, compileSourceGrammar) where
-- the main compiler passes
import GF.Compile.GetGrammar
import GF.Compile.Extend
import GF.Compile.Rebuild
import GF.Compile.Rename
import GF.Compile.CheckGrammar
import GF.Compile.Optimize
import GF.Compile.OptimizeGF
import GF.Compile.OptimizeGFCC
import GF.Compile.GrammarToGFCC
import GF.Compile.ReadFiles
import GF.Compile.Update
import GF.Compile.Refresh
import GF.Grammar.Grammar
import GF.Grammar.Lookup
import GF.Grammar.PrGrammar
import GF.Infra.Ident
import GF.Infra.Option
import GF.Infra.Modules
import GF.Infra.UseIO
import GF.Source.GrammarToSource
import qualified GF.Source.AbsGF as A
import qualified GF.Source.PrintGF as P
import GF.Data.Operations
import Control.Monad
import System.Directory
import System.FilePath
import System.Time
import qualified Data.Map as Map
import qualified Data.Set as Set
import PGF.Check
import PGF.Data
-- | Compiles a number of source files and builds a 'PGF' structure for them.
compileToPGF :: Options -> [FilePath] -> IOE PGF
compileToPGF opts fs =
do gr <- batchCompile opts fs
let name = justModuleName (last fs)
link opts name gr
link :: Options -> String -> SourceGrammar -> IOE PGF
link opts cnc gr =
do gc1 <- putPointE Normal opts "linking ... " $
let (abs,gc0) = mkCanon2gfcc opts cnc gr
in case checkPGF gc0 of
Ok (gc,b) -> do
ioeIO $ putStrLn $ if b then "OK" else "Corrupted PGF"
return gc
Bad s -> fail s
return $ buildParser opts $ optimize opts gc1
optimize :: Options -> PGF -> PGF
optimize opts = cse . suf
where os = moduleFlag optOptimizations opts
cse = if OptCSE `Set.member` os then cseOptimize else id
suf = if OptStem `Set.member` os then suffixOptimize else id
buildParser :: Options -> PGF -> PGF
buildParser opts =
if moduleFlag optBuildParser opts then addParsers else id
batchCompile :: Options -> [FilePath] -> IOE SourceGrammar
batchCompile opts files = do
(_,gr,_) <- foldM (compileModule opts) emptyCompileEnv files
return gr
-- to compile a set of modules, e.g. an old GF or a .cf file
compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
compileSourceGrammar opts gr@(MGrammar ms) = do
(_,gr',_) <- foldM compOne (0,emptySourceGrammar,Map.empty) ms
return gr'
where
compOne env mo = do
(k,mo') <- compileSourceModule opts env mo
extendCompileEnvInt env k Nothing mo' --- file for the same of modif time...
-- to output an intermediate stage
intermOut :: Options -> Dump -> String -> IOE ()
intermOut opts d s = if dump opts d then
ioeIO (putStrLn ("\n\n--#" +++ show d) >> putStrLn s)
else return ()
-- | the environment
type CompileEnv = (Int,SourceGrammar,ModEnv)
-- | 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 -- ^ Options from program command line and shell command.
-> CompileEnv -> FilePath -> IOE CompileEnv
compileModule opts1 env file = do
opts0 <- getOptionsFromFile file
let opts = addOptions opts0 opts1
let fdir = dropFileName file
let ps0 = moduleFlag optLibraryPath opts
ps2 <- ioeIO $ extendPathEnv $ fdir : ps0
let ps = ps2 ++ map (fdir </>) ps0
ioeIO $ putIfVerb opts $ "module search path:" +++ show ps ----
let (_,sgr,rfs) = env
files <- getAllFiles opts ps rfs file
ioeIO $ putIfVerb opts $ "files to read:" +++ show files ----
let names = map justModuleName files
ioeIO $ putIfVerb opts $ "modules to include:" +++ show names ----
foldM (compileOne opts) (0,sgr,rfs) files
compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
compileOne opts env@(_,srcgr,_) file = do
let putpOpt v m act
| verbAtLeast opts Verbose = putPointE Normal opts v act
| verbAtLeast opts Normal = ioeIO (putStrFlush m) >> act
| otherwise = putPointE Verbose opts v act
let gf = takeExtensions file
let path = dropFileName file
let name = dropExtension file
let mos = modules srcgr
case gf of
-- for compiled gf, read the file and update environment
-- also undo common subexp optimization, to enable normal computations
".gfo" -> do
sm0 <- putPointE Normal opts ("+ reading" +++ file) $ getSourceModule opts file
let sm1 = unsubexpModule sm0
sm <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ extendModule mos sm1
extendCompileEnv env file sm
-- for gf source, do full compilation and generate code
_ -> do
let gfo = gfoFile (dropExtension file)
b1 <- ioeIO $ doesFileExist file
if not b1
then compileOne opts env $ gfo
else do
sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $
getSourceModule opts file
(k',sm) <- compileSourceModule opts env sm0
let sm1 = if isConcr sm then shareModule sm else sm -- cannot expand Str
cm <- putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo sm1
-- sm is optimized before generation, but not in the env
extendCompileEnvInt env k' (Just gfo) sm1
where
isConcr (_,mi) = case mi of
ModMod m -> isModCnc m && mstatus m /= MSIncomplete
_ -> False
compileSourceModule :: Options -> CompileEnv ->
SourceModule -> IOE (Int,SourceModule)
compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
let putp = putPointE Normal opts
putpp = putPointE Verbose opts
mos = modules gr
mo1 <- ioeErr $ rebuildModule mos mo
intermOut opts DumpRebuild (prModule mo1)
mo1b <- ioeErr $ extendModule mos mo1
intermOut opts DumpExtend (prModule mo1b)
case mo1b of
(_,ModMod n) | not (isCompleteModule n) -> do
return (k,mo1b) -- refresh would fail, since not renamed
_ -> do
mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b
intermOut opts DumpRename (prModule mo2)
(mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2
if null warnings then return () else putp warnings $ return ()
intermOut opts DumpTypeCheck (prModule mo3)
(k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3
intermOut opts DumpRefresh (prModule mo3r)
let eenv = () --- emptyEEnv
(mo4,eenv') <-
---- if oElem "check_only" opts
putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r
return (k',mo4)
where
---- prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo]
generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule
generateModuleCode opts file minfo = do
let minfo1 = subexpModule minfo
out = prGrammar (MGrammar [minfo1])
putPointE Normal opts (" wrote file" +++ file) $ ioeIO $ writeFile file $ out
return minfo1
-- auxiliaries
reverseModules (MGrammar ms) = MGrammar $ reverse ms
emptyCompileEnv :: CompileEnv
emptyCompileEnv = (0,emptyMGrammar,Map.empty)
extendCompileEnvInt (_,MGrammar ss,menv) k mfile sm = do
let (mod,imps) = importsOfModule (trModule sm)
menv2 <- case mfile of
Just file -> do
t <- ioeIO $ getModificationTime file
return $ Map.insert mod (t,imps) menv
_ -> return menv
return (k,MGrammar (sm:ss),menv2) --- reverse later
extendCompileEnv e@(k,_,_) file sm = extendCompileEnvInt e k (Just file) sm

105
src/GF/Compile/BackOpt.hs Normal file
View File

@@ -0,0 +1,105 @@
----------------------------------------------------------------------
-- |
-- 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) where
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Option
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
import qualified Data.ByteString.Char8 as BS
import Data.Set (Set)
import qualified Data.Set as Set
type OptSpec = Set Optimization
shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
shareModule opt (i,m) = case m of
M.ModMod mo ->
(i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo))))
_ -> (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 = (if OptValues `Set.member` opt then values else id)
. (if OptParametrize `Set.member` opt then factor c 0 else id)
-- 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 (BS.pack ("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

1105
src/GF/Compile/CheckGrammar.hs Normal file
View File

File diff suppressed because it is too large Load Diff

429
src/GF/Compile/Compute.hs Normal file
View File

@@ -0,0 +1,429 @@
----------------------------------------------------------------------
-- |
-- Module : Compute
-- 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.Compute (computeConcrete, computeTerm,computeConcreteRec) where
import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Option
import GF.Data.Str
import GF.Grammar.PrGrammar
import GF.Infra.Modules
import GF.Grammar.Predef
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Compile.Refresh
import GF.Grammar.PatternMatch
import GF.Grammar.Lockfield (isLockLabel) ----
import GF.Grammar.AppPredefined
import Data.List (nub,intersperse)
import Control.Monad (liftM2, liftM)
-- | computation of concrete syntax terms into normal form
-- used mainly for partial evaluation
computeConcrete :: SourceGrammar -> Term -> Err Term
computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t
computeConcreteRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t
computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term
computeTerm = computeTermOpt False
-- rec=True is used if it cannot be assumed that looked-up constants
-- have already been computed (mainly with -optimize=noexpand in .gfr)
computeTermOpt :: Bool -> SourceGrammar -> Substitution -> Term -> Err Term
computeTermOpt rec gr = comput True where
comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging
case t of
Q p c | p == cPredef -> return t
| otherwise -> look p c
-- if computed do nothing
Computed t' -> return $ unComputed t'
Vr x -> do
t' <- maybe (prtBad ("no value given to variable") x) return $ lookup x g
case t' of
_ | t == t' -> return t
_ -> comp g t'
-- Abs x@(IA _) b -> do
Abs x b | full -> do
let (xs,b1) = termFormCnc t
b' <- comp ([(x,Vr x) | x <- xs] ++ g) b1
return $ mkAbs xs b'
-- b' <- comp (ext x (Vr x) g) b
-- return $ Abs x b'
Abs _ _ -> return t -- hnf
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'
-- beta-convert
App f a -> case appForm t of
(h,as) | length as > 1 -> do
h' <- hnf g h
as' <- mapM (comp g) as
case h' of
_ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as')
c@(QC _ _) -> do
return $ mkApp c as'
Q mod f | mod == cPredef -> do
(t',b) <- appPredefined (mkApp h' as')
if b then return t' else comp g t'
Abs _ _ -> do
let (xs,b) = termFormCnc h'
let g' = (zip xs as') ++ g
let as2 = drop (length xs) as'
let xs2 = drop (length as') xs
b' <- comp g' (mkAbs xs2 b)
if null as2 then return b' else comp g (mkApp b' as2)
_ -> compApp g (mkApp h' as')
_ -> compApp g t
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 (prtBad "no value for label" l) (comp g . snd) $
lookup l $ reverse r
ExtR a (R b) ->
case comp g (P (R b) l) of
Ok v -> return v
_ -> comp g (P a l)
--- { - --- this is incorrect, since b can contain the proper value
ExtR (R a) b -> -- NOT POSSIBLE both a and b records!
case comp g (P (R a) l) of
Ok v -> return v
_ -> comp g (P b l)
--- - } ---
S (T i cs) e -> prawitz g i (flip P l) cs e
S (V i cs) e -> prawitzV g i (flip P l) cs e
_ -> returnC $ P t' l
PI t l i -> comp g $ P t l -----
S t v -> do
t' <- compTable g t
v' <- comp g v
t1 <- case t' of
---- V (RecType fs) _ -> uncurrySelect g fs t' v'
---- T (TComp (RecType fs)) _ -> uncurrySelect g fs t' v'
_ -> return $ S t' v'
compSelect g t1
-- 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
(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
(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
(S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e
(s, S (V i cs) e) -> prawitzV 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' <- strsFromTerm ka
---- (Alts _, K a) -> checks [do
x' <- 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
]
(C u v,_) -> comp g $ C u (Glue v y)
_ -> 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 <- 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
(R rs, R ss) -> plusRecord r' s'
(RecType rs, RecType ss) -> plusRecType r' s'
_ -> return $ ExtR r' s'
T _ _ -> compTable g t
V _ _ -> compTable g t
-- otherwise go ahead
_ -> composOp (comp g) t >>= returnC
where
compApp g (App f a) = do
f' <- hnf g f
a' <- comp g a
case (f',a') of
(Abs x b, FV as) ->
mapM (\c -> comp (ext x c g) b) as >>= return . variants
(_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants
(FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants
(Abs x b,_) -> comp (ext x a' g) b
(QC _ _,_) -> returnC $ App f' a'
(S (T i cs) e,_) -> prawitz g i (flip App a') cs e
(S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
_ -> do
(t',b) <- appPredefined (App f' a')
if b then return t' else comp g t'
hnf = comput False
comp = comput True
look p c
| rec = lookupResDef gr p c >>= comp []
| otherwise = lookupResDef gr p c
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
compPatternMacro p = case p of
PM m c -> case look m c of
Ok (EPatt p') -> compPatternMacro p'
_ -> prtBad "pattern expected as value of" p ---- should be in CheckGr
PAs x p -> do
p' <- compPatternMacro p
return $ PAs x p'
PAlt p q -> do
p' <- compPatternMacro p
q' <- compPatternMacro q
return $ PAlt p' q'
PSeq p q -> do
p' <- compPatternMacro p
q' <- compPatternMacro q
return $ PSeq p' q'
PRep p -> do
p' <- compPatternMacro p
return $ PRep p'
PNeg p -> do
p' <- compPatternMacro p
return $ PNeg p'
PR rs -> do
rs' <- mapPairsM compPatternMacro rs
return $ PR rs'
_ -> return p
compSelect g (S t' v') = case v' of
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
_ -> case t' of
FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
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
-- course-of-values table: look up by index, no pattern matching needed
V ptyp ts -> do
vs <- allParamValues gr ptyp
case lookup v' (zip vs [0 .. length vs - 1]) of
Just i -> comp g $ ts !! i
_ -> return $ S t' v' -- if v' is not canonical
T _ cc -> case matchPattern cc v' of
Ok (c,g') -> comp (g' ++ g) c
_ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t
_ -> return $ S t' v' -- if v' is not canonical
S (T i cs) e -> prawitz g i (flip S v') cs e
S (V i cs) e -> prawitzV g i (flip S v') cs e
_ -> returnC $ S t' v'
-- case-expand tables
-- if already expanded, don't expand again
compTable g t = case t of
T i@(TComp ty) 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 $ V ty (map snd cs')
return $ T i cs'
V ty cs -> do
ty' <- comp g ty
-- if there are no variables, don't even go inside
cs' <- if (null g) then return cs else mapM (comp g) cs
return $ V ty' cs'
T i cs -> do
pty0 <- getTableType i
ptyp <- comp g pty0
case allParamValues gr ptyp of
Ok vs -> do
ps0 <- mapM (compPatternMacro . fst) cs
cs' <- mapM (compBranchOpt g) (zip ps0 (map snd cs))
sts <- mapM (matchPattern cs') vs
ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
ps <- mapM term2patt vs
let ps' = ps --- PT ptyp (head ps) : tail ps
---- return $ V ptyp ts -- to save space, just course of values
return $ T (TComp ptyp) (zip ps' ts)
_ -> do
cs' <- mapM (compBranch g) cs
return $ T i cs' -- happens with variable types
_ -> comp g t
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
_ -> 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
prawitzV g i f cs e = do
cs' <- mapM (comp g) [(f v) | v <- cs]
return $ S (V i cs') e
{- ----
uncurrySelect g fs t v = do
ts <- mapM (allParamValues gr . snd) fs
vs <- mapM (comp g) [P v r | r <- map fst fs]
return $ reorderSelect t fs ts vs
reorderSelect t fs pss vs = case (t,fs,pss,vs) of
(V _ ts, f:fs1, ps:pss1, v:vs1) ->
S (V (snd f)
[reorderSelect (V (RecType fs1) t) fs1 pss1 vs1 |
t <- segments (length ts `div` length ps) ts]) v
(T (TComp _) cs, f:fs1, ps:pss1, v:vs1) ->
S (T (TComp (snd f))
[(p,reorderSelect (T (TComp (RecType fs1)) c) fs1 pss1 vs1) |
(ep,c) <- zip ps (segments (length cs `div` length ps) cs),
let Ok p = term2patt ep]) v
_ -> t
segments i xs =
let (x0,xs1) = splitAt i xs in x0 : takeWhile (not . null) (segments i xs1)
-}
-- | argument variables cannot be glued
checkNoArgVars :: Term -> Err Term
checkNoArgVars t = case t of
Vr (IA _ _) -> Bad $ glueErrorMsg $ prt t
Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ prt t
_ -> composOp checkNoArgVars t
glueErrorMsg s =
"Cannot glue (+) term with run-time variable" +++ s ++ "." ++++
"Use Prelude.bind instead."
getArgType t = case t of
V ty _ -> return ty
T (TComp ty) _ -> return ty
_ -> prtBad "cannot get argument type of table" t

61
src/GF/Compile/Export.hs Normal file
View File

@@ -0,0 +1,61 @@
module GF.Compile.Export where
import PGF.CId
import PGF.Data (PGF(..))
import PGF.Raw.Print (printTree)
import PGF.Raw.Convert (fromPGF)
import GF.Compile.GFCCtoHaskell
import GF.Compile.GFCCtoJS
import GF.Infra.Option
import GF.Speech.CFG
import GF.Speech.PGFToCFG
import GF.Speech.SRGS_XML
import GF.Speech.JSGF
import GF.Speech.GSL
import GF.Speech.VoiceXML
import GF.Speech.SLF
import GF.Speech.PrRegExp
import GF.Text.UTF8
import Data.Maybe
import System.FilePath
-- top-level access to code generation
exportPGF :: Options
-> OutputFormat
-> PGF
-> [(FilePath,String)] -- ^ List of recommended file names and contents.
exportPGF opts fmt pgf =
case fmt of
FmtPGF -> multi "pgf" printPGF
FmtJavaScript -> multi "js" pgf2js
FmtHaskell -> multi "hs" (grammar2haskell name)
FmtHaskell_GADT -> multi "hs" (grammar2haskellGADT name)
FmtBNF -> single "bnf" bnfPrinter
FmtSRGS_XML -> single "grxml" (srgsXmlPrinter sisr)
FmtJSGF -> single "jsgf" (jsgfPrinter sisr)
FmtGSL -> single "gsl" gslPrinter
FmtVoiceXML -> single "vxml" grammar2vxml
FmtSLF -> single ".slf" slfPrinter
FmtRegExp -> single ".rexp" regexpPrinter
FmtFA -> single ".dot" slfGraphvizPrinter
where
name = fromMaybe (prCId (absname pgf)) (moduleFlag optName opts)
sisr = flag optSISR opts
multi :: String -> (PGF -> String) -> [(FilePath,String)]
multi ext pr = [(name <.> ext, pr pgf)]
single :: String -> (PGF -> CId -> String) -> [(FilePath,String)]
single ext pr = [(prCId cnc <.> ext, pr pgf cnc) | cnc <- cncnames pgf]
-- | Get the name of the concrete syntax to generate output from.
-- FIXME: there should be an option to change this.
outputConcr :: PGF -> CId
outputConcr pgf = case cncnames pgf of
[] -> error "No concrete syntax."
cnc:_ -> cnc
printPGF :: PGF -> String
printPGF = encodeUTF8 . printTree . fromPGF

138
src/GF/Compile/Extend.hs Normal file
View File

@@ -0,0 +1,138 @@
----------------------------------------------------------------------
-- |
-- 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 mo (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) (mtype mo))
("illegal extension type to module" +++ prt name)
return (m, isCompleteModule m)
-- build extension in a way depending on whether the old module is complete
js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo)
-- if incomplete, throw away extension information
let es = extend mo
let es' = if isCompl then es else (filter ((/=n) . fst) es)
return $ mo {extend = es', jments = 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
(_, ResOverload ms t) | elem n ms ->
return $ ResOverload ms t
(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
-}

213
src/GF/Compile/GFCCtoHaskell.hs Normal file
View File

@@ -0,0 +1,213 @@
----------------------------------------------------------------------
-- |
-- Module : GFCCtoHaskell
-- 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.Compile.GFCCtoHaskell (grammar2haskell, grammar2haskellGADT) where
import PGF.CId
import PGF.Data
import PGF.Macros
import GF.Data.Operations
import GF.Text.UTF8
import Data.List --(isPrefixOf, find, intersperse)
import qualified Data.Map as Map
-- | the main function
grammar2haskell :: String -- ^ Module name.
-> PGF
-> String
grammar2haskell name gr = encodeUTF8 $ foldr (++++) [] $
haskPreamble name ++ [datatypes gr', gfinstances gr']
where gr' = hSkeleton gr
grammar2haskellGADT :: String -> PGF -> String
grammar2haskellGADT name gr = encodeUTF8 $ foldr (++++) [] $
["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++
haskPreamble name ++ [datatypesGADT gr', gfinstances 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 name =
[
"module " ++ name ++ " where",
"",
"import PGF",
"----------------------------------------------------",
"-- automatic translation from GF to Haskell",
"----------------------------------------------------",
"",
"class Gf a where",
" gf :: a -> Tree",
" fg :: Tree -> a",
"",
predefInst "GString" "String" "Lit (LStr s)",
"",
predefInst "GInt" "Integer" "Lit (LInt s)",
"",
predefInst "GFloat" "Double" "Lit (LFlt s)",
"",
"----------------------------------------------------",
"-- below this line machine-generated",
"----------------------------------------------------",
""
]
predefInst gtyp typ patt =
"newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++
"instance Gf" +++ gtyp +++ "where" ++++
" gf (" ++ gtyp +++ "s) =" +++ patt ++++
" fg t =" ++++
" case t of" ++++
" " +++ patt +++ " ->" +++ gtyp +++ "s" ++++
" _ -> error (\"no" +++ gtyp +++ "\" ++ show t)"
type OIdent = String
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
datatypes, gfinstances :: (String,HSkeleton) -> String
datatypes = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd
gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance m)) g
hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String
gfInstance :: 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 ++ "_"
gfInstance m crs = hInstance m crs ++++ fInstance m crs
----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\n" ++
unlines [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 = "Fun (mkCId \"" ++ f ++ "\")" +++
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
----fInstance m ("Cn",_) = "" ---
fInstance m (cat,[]) = ""
fInstance m (cat,rules) =
" fg t =" ++++
" case t of" ++++
unlines [mkInst f xx | (f,xx) <- rules] ++++
" _ -> error (\"no" +++ cat ++ " \" ++ show t)"
where
mkInst f xx =
" Fun i " ++
"[" ++ prTList "," xx' ++ "]" +++
"| i == mkCId \"" ++ f ++ "\" ->" +++ 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]
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: PGF -> (String,HSkeleton)
hSkeleton gr =
(prCId (absname gr),
[(prCId c, [(prCId f, map prCId cs) | (f, (cs,_)) <- fs]) |
fs@((_, (_,c)):_) <- fns]
)
where
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = x == y
jty (f,(ty,_)) = (f,catSkeleton ty)
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
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

117
src/GF/Compile/GFCCtoJS.hs Normal file
View File

@@ -0,0 +1,117 @@
module GF.Compile.GFCCtoJS (pgf2js) where
import PGF.CId
import PGF.Data
import qualified PGF.Macros as M
import qualified GF.JavaScript.AbsJS as JS
import qualified GF.JavaScript.PrintJS as JS
import GF.Text.UTF8
import GF.Data.ErrM
import GF.Infra.Option
import Control.Monad (mplus)
import Data.Array (Array)
import qualified Data.Array as Array
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
pgf2js :: PGF -> String
pgf2js pgf =
encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
where
n = prCId $ absname pgf
as = abstract pgf
cs = Map.assocs (concretes pgf)
start = M.lookStartCat pgf
grammar = new "GFGrammar" [js_abstract, js_concrete]
js_abstract = abstract2js start as
js_concrete = JS.EObj $ map (concrete2js start n) cs
abstract2js :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
absdef2js :: (CId,(Type,Expr)) -> JS.Property
absdef2js (f,(typ,_)) =
let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)])
concrete2js :: String -> String -> (CId,Concr) -> JS.Property
concrete2js start n (c, cnc) =
JS.Prop l (new "GFConcrete" ([(JS.EObj $ ((map (cncdef2js n (prCId c)) ds) ++ litslins))] ++
maybe [] (parser2js start) (parser cnc)))
where
l = JS.IdentPropName (JS.Ident (prCId c))
ds = concatMap Map.assocs [lins cnc, opers cnc, lindefs cnc]
litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
cncdef2js :: String -> String -> (CId,Term) -> JS.Property
cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)])
term2js :: String -> String -> Term -> JS.Expr
term2js n l t = f t
where
f t =
case t of
R xs -> new "Arr" (map f xs)
P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y]
S xs -> mkSeq (map f xs)
K t -> tokn2js t
V i -> JS.EIndex (JS.EVar children) (JS.EInt i)
C i -> new "Int" [JS.EInt i]
F f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (prCId f), JS.EVar children]
FV xs -> new "Variants" (map f xs)
W str x -> new "Suffix" [JS.EStr str, f x]
TM _ -> new "Meta" []
tokn2js :: Tokn -> JS.Expr
tokn2js (KS s) = mkStr s
tokn2js (KP ss vs) = mkSeq (map mkStr ss) -- FIXME
mkStr :: String -> JS.Expr
mkStr s = new "Str" [JS.EStr s]
mkSeq :: [JS.Expr] -> JS.Expr
mkSeq [x] = x
mkSeq xs = new "Seq" xs
argIdent :: Integer -> JS.Ident
argIdent n = JS.Ident ("x" ++ show n)
children :: JS.Ident
children = JS.Ident "cs"
-- Parser
parser2js :: String -> ParserInfo -> [JS.Expr]
parser2js start p = [new "Parser" [JS.EStr start,
JS.EArray $ map frule2js (Array.elems (allRules p)),
JS.EObj $ map cats (Map.assocs (startupCats p))]]
where
cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (prCId c))) (JS.EArray (map JS.EInt is))
frule2js :: FRule -> JS.Expr
frule2js (FRule f ps args res lins) = new "Rule" [JS.EInt res, name2js (f,ps), JS.EArray (map JS.EInt args), lins2js lins]
name2js :: (CId,[Profile]) -> JS.Expr
name2js (f,ps) | f == wildCId = fromProfile (head ps)
| otherwise = new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)]
where
fromProfile :: Profile -> JS.Expr
fromProfile [] = new "MetaVar" []
fromProfile [x] = daughter x
fromProfile args = new "Unify" [JS.EArray (map daughter args)]
daughter i = new "Arg" [JS.EInt i]
lins2js :: Array FIndex (Array FPointPos FSymbol) -> JS.Expr
lins2js ls = JS.EArray [ JS.EArray [ sym2js s | s <- Array.elems l] | l <- Array.elems ls]
sym2js :: FSymbol -> JS.Expr
sym2js (FSymCat l n) = new "ArgProj" [JS.EInt n, JS.EInt l]
sym2js (FSymTok t) = new "Terminal" [JS.EStr t]
new :: String -> [JS.Expr] -> JS.Expr
new f xs = JS.ENew (JS.Ident f) xs

526
src/GF/Compile/GenerateFCFG.hs Normal file
View File

@@ -0,0 +1,526 @@
----------------------------------------------------------------------
-- |
-- 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.Compile.GenerateFCFG
(convertConcrete) where
import PGF.CId
import PGF.Data
import PGF.Macros --hiding (prt)
import PGF.Parsing.FCFG.Utilities
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 qualified Data.ByteString.Char8 as BS
import Data.Array
import Data.Maybe
import Control.Monad
----------------------------------------------------------------------
-- 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,Expr))] -> TermMap -> TermMap -> ([(CId,(Type,Expr))],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 " ++ prCId 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 = mkCId "_Var"
catName :: (Int,CId) -> CId
catName (0,c) = c
catName (n,c) = mkCId ("_" ++ show n ++ prCId c)
funName :: (Int,CId) -> CId
funName (n,c) = mkCId ("__" ++ show n ++ prCId c)
varFunName :: CId -> CId
varFunName c = mkCId ("_Var_" ++ prCId 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) ps args cat lins | FRule n ps args cat lins <- rs], cs)
where fixName (CId n) | BS.pack "__" `BS.isPrefixOf` n = (mkCId "_B")
| BS.pack "_Var_" `BS.isPrefixOf` n = wildCId
fixName n = n
convert :: [(CId,(Type,Expr))] -> 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, [] )
accumProf nr (_ ,xpaths) = (nr+cnt+1, [nr..nr+cnt])
where cnt = length xpaths
rule = FRule 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 = either (\(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 (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 FPath = [FIndex]
type Env = (ProtoFCat, [(ProtoFCat,[FPath])], Term, [Term])
type LinRec = [(FPath, [Either (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,Right str : lin) : lins)
convertTerm cnc_defs selector (K (KP strs vars))((lbl_path,lin) : lins) =
do projectHead lbl_path
toks <- member (strs:[strs' | Alt strs' _ <- vars])
return ((lbl_path, map Right toks ++ lin) : 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, Left (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 (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 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)
----------------------------------------------------------------------
-- 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 (mkCId "String") [[0]] [] $
ins fcatInt (mkCId "Int") [[0]] [] $
ins fcatFloat (mkCId "Float") [[0]] [] $
ins fcatVar (mkCId "_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 wildCId [[0]] [fcat_arg] fcat
(listArray (0,length rcs-1) [listArray (0,0) [FSymCat 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 (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: "++prCId 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 (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: "++prCId 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

356
src/GF/Compile/GeneratePMCFG.hs Normal file
View File

@@ -0,0 +1,356 @@
{-# OPTIONS -fbang-patterns #-}
----------------------------------------------------------------------
-- |
-- 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.Compile.GeneratePMCFG
(convertConcrete) where
import PGF.CId
import PGF.Data
import PGF.Macros --hiding (prt)
import PGF.Parsing.FCFG.Utilities
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 qualified Data.ByteString.Char8 as BS
import Data.Array
import Data.Maybe
import Control.Monad
import Debug.Trace
----------------------------------------------------------------------
-- 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,Expr))] -> TermMap -> TermMap -> ([(CId,(Type,Expr))],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 " ++ prCId 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 = mkCId "_Var"
catName :: (Int,CId) -> CId
catName (0,c) = c
catName (n,c) = mkCId ("_" ++ show n ++ prCId c)
funName :: (Int,CId) -> CId
funName (n,c) = mkCId ("__" ++ show n ++ prCId c)
varFunName :: CId -> CId
varFunName c = mkCId ("_Var_" ++ prCId 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) ps args cat lins | FRule n ps args cat lins <- rs], cs)
where fixName (CId n) | BS.pack "__" `BS.isPrefixOf` n = (mkCId "_B")
| BS.pack "_Var_" `BS.isPrefixOf` n = wildCId
fixName n = n
convert :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> FGrammar
convert abs_defs cnc_defs cat_defs = getFGrammar (List.foldl' (convertRule cnc_defs) emptyFRulesEnv srules)
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)
convertRule :: TermMap -> FRulesEnv -> XRule -> FRulesEnv
convertRule cnc_defs frulesEnv (XRule fun args cat ctypes ctype term) =
foldBM addRule
frulesEnv
(convertTerm cnc_defs [] ctype term [([],[])])
(protoFCat cnc_defs cat ctype, zipWith (protoFCat cnc_defs) args ctypes)
where
addRule linRec (newCat', newArgs') env0 =
let (env1, newCat) = genFCatHead env0 newCat'
(env2, newArgs) = List.mapAccumL (genFCatArg cnc_defs) env1 newArgs'
newLinRec = mkArray (map (mkArray . snd) linRec)
mkArray lst = listArray (0,length lst-1) lst
rule = FRule fun [] newArgs newCat newLinRec
in addFRule env2 rule
----------------------------------------------------------------------
-- term conversion
type CnvMonad a = BacktrackM Env a
type FPath = [FIndex]
data ProtoFCat = PFCat CId [FPath] [(FPath,FIndex)] Term
type Env = (ProtoFCat, [ProtoFCat])
type LinRec = [(FPath, [FSymbol])]
data XRule = XRule CId {- function -}
[CId] {- argument types -}
CId {- result type -}
[Term] {- argument lin-types representation -}
Term {- result lin-type representation -}
Term {- body -}
protoFCat :: TermMap -> CId -> Term -> ProtoFCat
protoFCat cnc_defs cat ctype = PFCat cat (getRCS cnc_defs ctype) [] ctype
type TermMap = Map.Map CId Term
convertTerm :: TermMap -> FPath -> Term -> Term -> LinRec -> CnvMonad LinRec
convertTerm cnc_defs sel ctype (V nr) ((lbl_path,lin) : lins) = convertArg ctype nr (reverse sel) lbl_path lin lins
convertTerm cnc_defs sel ctype (C nr) ((lbl_path,lin) : lins) = convertCon ctype nr (reverse sel) lbl_path lin lins
convertTerm cnc_defs sel ctype (R record) ((lbl_path,lin) : lins) = convertRec cnc_defs sel ctype record lbl_path lin lins
convertTerm cnc_defs sel ctype (P term p) lins = do nr <- evalTerm cnc_defs [] p
convertTerm cnc_defs (nr:sel) ctype term lins
convertTerm cnc_defs sel ctype (FV vars) lins = do term <- member vars
convertTerm cnc_defs sel ctype term lins
convertTerm cnc_defs sel ctype (S ts) ((lbl_path,lin) : lins) = foldM (\lins t -> convertTerm cnc_defs sel ctype t lins) ((lbl_path,lin) : lins) (reverse ts)
convertTerm cnc_defs sel ctype (K (KS str)) ((lbl_path,lin) : lins) = return ((lbl_path,FSymTok str : lin) : lins)
convertTerm cnc_defs sel ctype (K (KP strs vars))((lbl_path,lin) : lins) =
do toks <- member (strs:[strs' | Alt strs' _ <- vars])
return ((lbl_path, map FSymTok toks ++ lin) : lins)
convertTerm cnc_defs sel ctype (F id) lins = do term <- Map.lookup id cnc_defs
convertTerm cnc_defs sel ctype term lins
convertTerm cnc_defs sel ctype (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 sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss] lbl_path lin lins
convertTerm cnc_defs sel ctype x lins = error ("convertTerm ("++show x++")")
convertArg (R record) nr path lbl_path lin lins =
foldM (\lins (lbl, ctype) -> convertArg ctype nr (lbl:path) (lbl:lbl_path) lin lins) lins (zip [0..] record)
convertArg (C max) nr path lbl_path lin lins = do
index <- member [0..max]
restrictHead lbl_path index
restrictArg nr path index
return lins
convertArg (S _) nr path lbl_path lin lins = do
(_, args) <- readState
let PFCat cat rcs tcs _ = args !! nr
return ((lbl_path, FSymCat (index path rcs 0) nr : lin) : lins)
where
index lbl' (lbl:lbls) idx
| lbl' == lbl = idx
| otherwise = index lbl' lbls $! (idx+1)
convertCon (C max) index [] lbl_path lin lins = do
guard (index <= max)
restrictHead lbl_path index
return lins
convertCon x _ _ _ _ _ = error $ "SimpleToFCFG,convertCon: " ++ show x
convertRec cnc_defs [] (R ctypes) record lbl_path lin lins =
foldM (\lins (index,ctype,val) -> convertTerm cnc_defs [] ctype val ((index:lbl_path,lin) : lins))
lins
(zip3 [0..] ctypes record)
convertRec cnc_defs (index:sub_sel) ctype record lbl_path lin lins = do
convertTerm cnc_defs sub_sel ctype (record !! index) ((lbl_path,lin) : lins)
------------------------------------------------------------
-- eval a term to ground terms
evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex
evalTerm cnc_defs path (V nr) = do (_, args) <- readState
let PFCat _ _ _ ctype = args !! nr
unifyPType nr (reverse path) (selectTerm path ctype)
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 (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 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)
----------------------------------------------------------------------
-- FRulesEnv
data FRulesEnv = FRulesEnv {-# UNPACK #-} !Int FCatSet [FRule]
type FCatSet = Map.Map CId (Map.Map [(FPath,FIndex)] FCat)
emptyFRulesEnv = FRulesEnv 0 (ins fcatString (mkCId "String") [] $
ins fcatInt (mkCId "Int") [] $
ins fcatFloat (mkCId "Float") [] $
ins fcatVar (mkCId "_Var") [] $
Map.empty) []
where
ins fcat cat tcs fcatSet =
Map.insertWith (\_ -> Map.insert tcs fcat) cat tmap_s fcatSet
where
tmap_s = Map.singleton tcs fcat
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 Map.elems fcatSet)
genFCatHead :: FRulesEnv -> ProtoFCat -> (FRulesEnv, FCat)
genFCatHead env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs tcs _) =
case Map.lookup cat fcatSet >>= Map.lookup tcs of
Just fcat -> (env, fcat)
Nothing -> let fcat = last_id+1
in (FRulesEnv fcat (ins fcat) rules, fcat)
where
ins fcat = Map.insertWith (\_ -> Map.insert tcs fcat) cat tmap_s fcatSet
where
tmap_s = Map.singleton tcs fcat
genFCatArg :: TermMap -> FRulesEnv -> ProtoFCat -> (FRulesEnv, FCat)
genFCatArg cnc_defs env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs tcs ctype) =
case Map.lookup cat fcatSet of
Just tmap -> case Map.lookup tcs tmap of
Just fcat -> (env, fcat)
Nothing -> ins tmap
Nothing -> ins Map.empty
where
ins tmap =
let fcat = last_id+1
(last_id1,tmap1,rules1)
= foldBM (\tcs st (last_id,tmap,rules) ->
let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap
rule = FRule wildCId [[0]] [fcat_arg] fcat
(listArray (0,length rcs-1) [listArray (0,0) [FSymCat lbl 0] | lbl <- [0..length rcs-1]])
in if st
then (last_id1,tmap1,rule:rules)
else (last_id, tmap, rules))
(fcat,Map.insert tcs fcat tmap,rules)
(gen_tcs ctype [] [])
False
in (FRulesEnv last_id1 (Map.insert cat tmap1 fcatSet) rules1, fcat)
where
addArg tcs last_id tmap =
case Map.lookup tcs tmap of
Just fcat -> (last_id, tmap, fcat)
Nothing -> let fcat = last_id+1
in (fcat, Map.insert tcs 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 (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: "++prCId id)
getRCS :: TermMap -> Term -> [FPath]
getRCS cnc_defs = loop [] []
where
loop path rcs (R record) = List.foldl' (\rcs (index,term) -> loop (index:path) rcs term) rcs (zip [0..] record)
loop path rcs (C i) = rcs
loop path rcs (S _) = path:rcs
loop path rcs (F id) = case Map.lookup id cnc_defs of
Just term -> loop path rcs term
Nothing -> error ("unknown identifier: "++show id)
------------------------------------------------------------
-- updating the MCF rule
restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad ()
restrictArg nr path index = do
(head, args) <- readState
args' <- updateNthM (restrictProtoFCat path index) nr args
writeState (head, args')
restrictHead :: FPath -> FIndex -> CnvMonad ()
restrictHead path term
= do (head, args) <- readState
head' <- restrictProtoFCat path term head
writeState (head', args)
restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> CnvMonad ProtoFCat
restrictProtoFCat path0 index0 (PFCat cat rcs tcs ctype) = do
tcs <- addConstraint tcs
return (PFCat cat rcs tcs ctype)
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)

55
src/GF/Compile/GetGrammar.hs Normal file
View File

@@ -0,0 +1,55 @@
----------------------------------------------------------------------
-- |
-- 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 where
import GF.Data.Operations
import qualified GF.Source.ErrM as E
import GF.Infra.UseIO
import GF.Infra.Modules
import GF.Grammar.Grammar
import qualified GF.Source.AbsGF as A
import GF.Source.SourceToGrammar
---- import Macros
---- import Rename
import GF.Infra.Option
--- import Custom
import GF.Source.ParGF
import qualified GF.Source.LexGF as L
import GF.Compile.ReadFiles
import Data.Char (toUpper)
import Data.List (nub)
import qualified Data.ByteString.Char8 as BS
import Control.Monad (foldM)
import System.Cmd (system)
getSourceModule :: Options -> FilePath -> IOE SourceModule
getSourceModule opts file0 = do
file <- foldM runPreprocessor file0 (moduleFlag optPreprocessors opts)
string <- readFileIOE file
let tokens = myLexer string
mo1 <- ioeErr $ pModDef tokens
ioeErr $ transModDef mo1
-- FIXME: should use System.IO.openTempFile
runPreprocessor :: FilePath -> String -> IOE FilePath
runPreprocessor file0 p =
do let tmp = "_gf_preproc.tmp"
cmd = p +++ file0 ++ ">" ++ tmp
ioeIO $ system cmd
-- ioeIO $ putStrLn $ "preproc" +++ cmd
return tmp

561
src/GF/Compile/GrammarToGFCC.hs Normal file
View File

@@ -0,0 +1,561 @@
{-# LANGUAGE PatternGuards #-}
module GF.Compile.GrammarToGFCC (prGrammar2gfcc,mkCanon2gfcc,addParsers) where
import GF.Compile.Export
import GF.Compile.OptimizeGF (unshareModule)
import qualified GF.Compile.GenerateFCFG as FCFG
import qualified GF.Compile.GeneratePMCFG as PMCFG
import PGF.CId
import PGF.BuildParser (buildParserInfo)
import qualified PGF.Macros as CM
import qualified PGF.Data as C
import qualified PGF.Data as D
import GF.Grammar.Predef
import GF.Grammar.PrGrammar
import GF.Grammar.Grammar
import qualified GF.Grammar.Lookup as Look
import qualified GF.Grammar.Abstract as A
import qualified GF.Grammar.Macros as GM
import qualified GF.Compile.Compute as Compute ----
import qualified GF.Infra.Modules as M
import qualified GF.Infra.Option as O
import GF.Infra.Ident
import GF.Infra.Option
import GF.Data.Operations
import GF.Text.UTF8
import Data.List
import Data.Char (isDigit,isSpace)
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS
import Debug.Trace ----
-- when developing, swap commenting
--traceD s t = trace s t
traceD s t = t
-- the main function: generate PGF from GF.
prGrammar2gfcc :: Options -> String -> SourceGrammar -> (String,String)
prGrammar2gfcc opts cnc gr = (abs,printPGF gc) where
(abs,gc) = mkCanon2gfcc opts cnc gr
mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.PGF)
mkCanon2gfcc opts cnc gr =
(prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr)
where
abs = err error id $ M.abstractOfConcrete gr (identC (BS.pack cnc))
pars = mkParamLincat gr
-- Adds parsers for all concretes
addParsers :: D.PGF -> D.PGF
addParsers pgf = pgf { D.concretes = Map.map conv (D.concretes pgf) }
where
conv cnc = cnc { D.parser = Just (buildParserInfo fcfg) }
where
fcfg
| Map.lookup (mkCId "erasing") (D.cflags cnc) == Just "on" = PMCFG.convertConcrete (D.abstract pgf) cnc
| otherwise = FCFG.convertConcrete (D.abstract pgf) cnc
-- Generate PGF from GFCM.
-- this assumes a grammar translated by canon2canon
canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF
canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
(if dump opts DumpCanon then trace (prGrammar cgr) else id) $
D.PGF an cns gflags abs cncs
where
-- abstract
an = (i2i a)
cns = map (i2i . fst) cms
abs = D.Abstr aflags funs cats catfuns
gflags = Map.empty
aflags = Map.fromList [(mkCId f,x) | (f,x) <- moduleOptionsGFO (M.flags abm)]
mkDef pty = case pty of
Yes t -> mkExp t
_ -> CM.primNotion
-- concretes
lfuns = [(f', (mkType ty, mkDef pty)) |
(f,AbsFun (Yes ty) pty) <- tree2list (M.jments abm), let f' = i2i f]
funs = Map.fromAscList lfuns
lcats = [(i2i c, mkContext cont) |
(c,AbsCat (Yes cont) _) <- tree2list (M.jments abm)]
cats = Map.fromAscList lcats
catfuns = Map.fromList
[(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,M.ModMod mo) <- cms]
mkConcr lang0 lang mo =
(lang,D.Concr flags lins opers lincats lindefs printnames params fcfg)
where
js = tree2list (M.jments mo)
flags = Map.fromList [(mkCId f,x) | (f,x) <- moduleOptionsGFO (M.flags mo)]
opers = Map.fromAscList [] -- opers will be created as optimization
utf = if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8
then D.convertStringsInTerm decodeUTF8 else id
lins = Map.fromAscList
[(i2i f, utf (mkTerm tr)) | (f,CncFun _ (Yes tr) _) <- js]
lincats = Map.fromAscList
[(i2i c, mkCType ty) | (c,CncCat (Yes ty) _ _) <- js]
lindefs = Map.fromAscList
[(i2i c, mkTerm tr) | (c,CncCat _ (Yes tr) _) <- js]
printnames = Map.union
(Map.fromAscList [(i2i f, mkTerm tr) | (f,CncFun _ _ (Yes tr)) <- js])
(Map.fromAscList [(i2i f, mkTerm tr) | (f,CncCat _ _ (Yes tr)) <- js])
params = Map.fromAscList
[(i2i c, pars lang0 c) | (c,CncCat (Yes ty) _ _) <- js]
fcfg = Nothing
i2i :: Ident -> CId
i2i = CId . ident2bs
mkType :: A.Type -> C.Type
mkType t = case GM.typeForm t of
Ok (hyps,(_,cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args)
mkExp :: A.Term -> C.Expr
mkExp t = case t of
A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs]
_ -> case GM.termForm t of
Ok (xs,c,args) -> mkAbs xs (mkApp c (map mkExp args))
where
mkAbs xs t = foldr (C.EAbs . i2i) t xs
mkApp c args = case c of
Q _ c -> foldl C.EApp (C.EVar (i2i c)) args
QC _ c -> foldl C.EApp (C.EVar (i2i c)) args
Vr x -> C.EVar (i2i x)
EInt i -> C.ELit (C.LInt i)
EFloat f -> C.ELit (C.LFlt f)
K s -> C.ELit (C.LStr s)
Meta (MetaSymb i) -> C.EMeta i
_ -> C.EMeta 0
mkPatt p = case p of
A.PP _ c ps -> foldl C.EApp (C.EVar (i2i c)) (map mkPatt ps)
A.PV x -> C.EVar (i2i x)
A.PW -> C.EVar wildCId
A.PInt i -> C.ELit (C.LInt i)
mkContext :: A.Context -> [C.Hypo]
mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps]
mkTerm :: Term -> C.Term
mkTerm tr = case tr of
Vr (IA _ i) -> C.V i
Vr (IAV _ _ i) -> C.V i
Vr (IC s) | isDigit (BS.last s) ->
C.V ((read . BS.unpack . snd . BS.spanEnd isDigit) s)
---- from gf parser of gfc
EInt i -> C.C $ fromInteger i
R rs -> C.R [mkTerm t | (_, (_,t)) <- rs]
P t l -> C.P (mkTerm t) (C.C (mkLab l))
TSh _ _ -> error $ show tr
T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------
V _ cs -> C.R [mkTerm t | t <- cs]
S t p -> C.P (mkTerm t) (mkTerm p)
C s t -> C.S $ concatMap flats [mkTerm x | x <- [s,t]]
FV ts -> C.FV [mkTerm t | t <- ts]
K s -> C.K (C.KS s)
----- K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants
Empty -> C.S []
App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging
Abs _ t -> mkTerm t ---- only on toplevel
Alts (td,tvs) ->
C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- tvs])
_ -> prtTrace tr $ C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging
where
mkLab (LIdent l) = case BS.unpack l of
'_':ds -> (read ds) :: Int
_ -> prtTrace tr $ 66663
strings t = case t of
K s -> [s]
C u v -> strings u ++ strings v
Strs ss -> concatMap strings ss
_ -> prtTrace tr $ ["66660"]
flats t = case t of
C.S ts -> concatMap flats ts
_ -> [t]
-- encoding PGF-internal lincats as terms
mkCType :: Type -> C.Term
mkCType t = case t of
EInt i -> C.C $ fromInteger i
RecType rs -> C.R [mkCType t | (_, t) <- rs]
Table pt vt -> case pt of
EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt
RecType rs -> mkCType $ foldr Table vt (map snd rs)
Sort s | s == cStr -> C.S [] --- Str only
_ | Just i <- GM.isTypeInts t -> C.C $ fromInteger i
_ -> error $ "mkCType " ++ show t
-- encoding showable lincats (as in source gf) as terms
mkParamLincat :: SourceGrammar -> Ident -> Ident -> C.Term
mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
typ <- Look.lookupLincat sgr lang cat
mkPType typ
where
mkPType typ = case typ of
RecType lts -> do
ts <- mapM (mkPType . snd) lts
return $ C.R [ C.P (kks $ prt_ l) t | ((l,_),t) <- zip lts ts]
Table (RecType lts) v -> do
ps <- mapM (mkPType . snd) lts
v' <- mkPType v
return $ foldr (\p v -> C.S [p,v]) v' ps
Table p v -> do
p' <- mkPType p
v' <- mkPType v
return $ C.S [p',v']
Sort s | s == cStr -> return $ C.S []
_ -> return $
C.FV $ map (kks . filter showable . prt_) $
errVal [] $ Look.allParamValues sgr typ
showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records
kks = C.K . C.KS
-- return just one module per language
reorder :: Ident -> SourceGrammar -> SourceGrammar
reorder abs cg = M.MGrammar $
(abs, M.ModMod $
M.Module M.MTAbstract M.MSComplete aflags [] [] adefs poss):
[(c, M.ModMod $
M.Module (M.MTConcrete abs) M.MSComplete fs [] [] (sorted2tree js) poss)
| (c,(fs,js)) <- cncs]
where
poss = emptyBinTree -- positions no longer needed
mos = M.allModMod cg
adefs = sorted2tree $ sortIds $
predefADefs ++ Look.allOrigInfos cg abs
predefADefs =
[(c, AbsCat (Yes []) Nope) | c <- [cFloat,cInt,cString]]
aflags =
concatModuleOptions [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo]
cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs]
concr la = (flags,
sortIds (predefCDefs ++ jments)) where
jments = Look.allOrigInfos cg la
flags = concatModuleOptions
[M.flags mo |
(i,mo) <- mos, M.isModCnc mo,
Just r <- [lookup i (M.allExtendSpecs cg la)]]
predefCDefs =
[(c, CncCat (Yes GM.defLinType) Nope Nope) | c <- [cInt,cFloat,cString]]
sortIds = sortBy (\ (f,_) (g,_) -> compare f g)
-- one grammar per language - needed for symtab generation
repartition :: Ident -> SourceGrammar -> [SourceGrammar]
repartition abs cg = [M.partOfGrammar cg (lang,mo) |
let mos = M.allModMod cg,
lang <- M.allConcretes cg abs,
let mo = errVal
(error ("no module found for " ++ A.prt lang)) $ M.lookupModule cg lang
]
-- translate tables and records to arrays, parameters and labels to indices
canon2canon :: Ident -> SourceGrammar -> SourceGrammar
canon2canon abs =
recollect . map cl2cl . repartition abs . purgeGrammar abs
where
recollect = M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules
cl2cl = M.MGrammar . js2js . map (c2c p2p) . M.modules
js2js ms = map (c2c (j2j (M.MGrammar ms))) ms
c2c f2 (c,m) = case m of
M.ModMod mo ->
(c, M.ModMod $ M.replaceJudgements mo $ mapTree f2 (M.jments mo))
_ -> (c,m)
j2j cg (f,j) = case j of
CncFun x (Yes tr) z -> (f,CncFun x (Yes ({-trace ("+ " ++ prt f)-} (t2t tr))) z)
CncCat (Yes ty) (Yes x) y -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y)
_ -> (f,j)
where
t2t = term2term cg pv
ty2ty = type2type cg pv
pv@(labels,untyps,typs) = trs $ paramValues cg
-- flatten record arguments of param constructors
p2p (f,j) = case j of
ResParam (Yes (ps,v)) ->
(f,ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing)))
_ -> (f,j)
unRec (x,ty) = case ty of
RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (identW,typ)]
_ -> [(x,ty)]
----
trs v = traceD (tr v) v
tr (labels,untyps,typs) =
("LABELS:" ++++
unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i |
((c,l),i) <- Map.toList labels]) ++++
("UNTYPS:" ++++ unlines [A.prt t +++ "=" +++ show i |
(t,i) <- Map.toList untyps]) ++++
("TYPS:" ++++ unlines [A.prt t +++ "=" +++ show (Map.assocs i) |
(t,i) <- Map.toList typs])
----
purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar
purgeGrammar abstr gr =
(M.MGrammar . list . map unopt . filter complete . purge . M.modules) gr
where
list ms = traceD ("MODULES" +++ unwords (map (prt . fst) ms)) ms
purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
needed = nub $ concatMap (requiredCanModules isSingle gr) acncs
acncs = abstr : M.allConcretes gr abstr
isSingle = True
complete (i,M.ModMod m) = M.isCompleteModule m --- not . isIncompleteCanon
unopt = unshareModule gr -- subexp elim undone when compiled
type ParamEnv =
(Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels
Map.Map Term Integer, -- untyped terms to values
Map.Map Type (Map.Map Term Integer)) -- types to their terms to values
--- gathers those param types that are actually used in lincats and lin terms
paramValues :: SourceGrammar -> ParamEnv
paramValues cgr = (labels,untyps,typs) where
partyps = nub $
--- [App (Q (IC "Predef") (IC "Ints")) (EInt i) | i <- [1,9]] ---linTypeInt
[ty |
(_,(_,CncCat (Yes ty0) _ _)) <- jments,
ty <- typsFrom ty0
] ++ [
Q m ty |
(m,(ty,ResParam _)) <- jments
] ++ [ty |
(_,(_,CncFun _ (Yes tr) _)) <- jments,
ty <- err (const []) snd $ appSTM (typsFromTrm tr) []
]
params = [(ty, errVal (traceD ("UNKNOWN PARAM TYPE" +++ show ty) []) $
Look.allParamValues cgr ty) | ty <- partyps]
typsFrom ty = unlockTy ty : case ty of
Table p t -> typsFrom p ++ typsFrom t
RecType ls -> concat [typsFrom t | (_, t) <- ls]
_ -> []
typsFromTrm :: Term -> STM [Type] Term
typsFromTrm tr = case tr of
R fs -> mapM_ (typsFromField . snd) fs >> return tr
where
typsFromField (mty, t) = case mty of
Just x -> updateSTM (x:) >> typsFromTrm t
_ -> typsFromTrm t
V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
T (TTyped ty) cs ->
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
T (TComp ty) cs ->
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
_ -> GM.composOp typsFromTrm tr
jments =
[(m,j) | (m,mo) <- M.allModMod cgr, j <- tree2list $ M.jments mo]
typs =
Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params]
untyps =
Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
lincats =
[(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++
reverse ---- TODO: really those lincats that are reached
---- reverse is enough to expel overshadowed ones...
[(cat,ls) | (_,(cat,CncCat (Yes ty) _ _)) <- jments,
RecType ls <- [unlockTy ty]]
labels = Map.fromList $ concat
[((cat,[lab]),(typ,i)):
[((cat,[LVar v]),(typ,toInteger (mx + v))) | v <- [0,1]] ++ ---- 1 or 2 vars
[((cat,[lab,lab2]),(ty,j)) |
rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]]
|
(cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..], let mx = length ls]
-- go to tables recursively
---- TODO: even go to deeper records
where
getRec typ = case typ of
RecType rs -> [rs] ---- [unlockTyp rs] -- (sort (unlockTyp ls))
Table _ t -> getRec t
_ -> []
type2type :: SourceGrammar -> ParamEnv -> Type -> Type
type2type cgr env@(labels,untyps,typs) ty = case ty of
RecType rs ->
RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)]
Table pt vt -> Table (t2t pt) (t2t vt)
QC _ _ -> look ty
_ -> ty
where
t2t = type2type cgr env
look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of
Just vs -> length $ Map.assocs vs
_ -> trace ("unknown partype " ++ show ty) 66669
term2term :: SourceGrammar -> ParamEnv -> Term -> Term
term2term cgr env@(labels,untyps,typs) tr = case tr of
App _ _ -> mkValCase (unrec tr)
QC _ _ -> mkValCase tr
R rs -> R [(mkLab i, (Nothing, t2t t)) |
(i,(l,(_,t))) <- zip [0..] (GM.sortRec (unlock rs))]
P t l -> r2r tr
PI t l i -> EInt $ toInteger i
T (TWild _) _ -> error $ "wild" +++ prt tr
T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
V ty ts -> mkCurry $ V ty [t2t t | t <- ts]
S t p -> mkCurrySel (t2t t) (t2t p)
_ -> GM.composSafeOp t2t tr
where
t2t = term2term cgr env
unrec t = case t of
App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs]
_ -> GM.composSafeOp unrec t
mkValCase tr = case appSTM (doVar tr) [] of
Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st
_ -> valNum $ comp tr
--- this is mainly needed for parameter record projections
---- was:
comp t = errVal t $ Compute.computeConcreteRec cgr t
compt t = case t of
T (TComp typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should...
T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should
V typ ts -> V typ (map comp ts)
S tb (FV ts) -> FV $ map (comp . S tb) ts
S tb@(V typ ts) v0 -> err error id $ do
let v = comp v0
let mv1 = Map.lookup v untyps
case mv1 of
Just v1 -> return $ (comp . (ts !!) . fromInteger) v1
_ -> return (S (comp tb) v)
R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r]
P (R r) l -> maybe t (comp . snd) $ lookup l r
_ -> GM.composSafeOp comp t
doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term
doVar tr = case getLab tr of
Ok (cat, lab) -> do
k <- readSTM >>= return . length
let tr' = Vr $ identC $ (BS.pack (show k)) -----
let tyvs = case Map.lookup (cat,lab) labels of
Just (ty,_) -> case Map.lookup ty typs of
Just vs -> (ty,[t |
(t,_) <- sortBy (\x y -> compare (snd x) (snd y))
(Map.assocs vs)])
_ -> error $ "doVar1" +++ A.prt ty
_ -> error $ "doVar2" +++ A.prt tr +++ show (cat,lab) ---- debug
updateSTM ((tyvs, (tr', tr)):)
return tr'
_ -> GM.composOp doVar tr
r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v
r2r tr@(P p _) = case getLab tr of
Ok (cat,labs) -> P (t2t p) . mkLab $
maybe (prtTrace tr $ 66664) snd $
Map.lookup (cat,labs) labels
_ -> K ((A.prt tr +++ prtTrace tr "66665"))
-- this goes recursively into tables (ignored) and records (accumulated)
getLab tr = case tr of
Vr (IA cat _) -> return (identC cat,[])
Vr (IAV cat _ _) -> return (identC cat,[])
Vr (IC s) -> return (identC cat,[]) where
cat = BS.takeWhile (/='_') s ---- also to match IAVs; no _ in a cat tolerated
---- init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser
---- Vr _ -> error $ "getLab " ++ show tr
P p lab2 -> do
(cat,labs) <- getLab p
return (cat,labs++[lab2])
S p _ -> getLab p
_ -> Bad "getLab"
mkCase ((ty,vs),(x,p)) tr =
S (V ty [mkBranch x v tr | v <- vs]) p
mkBranch x t tr = case tr of
_ | tr == x -> t
_ -> GM.composSafeOp (mkBranch x t) tr
valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps
where
tryFV tr = case GM.appForm tr of
(c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)]
(FV ts,_) -> ts
_ -> [tr]
valNumFV ts = case ts of
[tr] -> error ("valNum" +++ prt tr) ----- prtTrace tr $ K "66667"
_ -> FV $ map valNum ts
mkCurry trm = case trm of
V (RecType [(_,ty)]) ts -> V ty ts
V (RecType ((_,ty):ltys)) ts ->
V ty [mkCurry (V (RecType ltys) cs) |
cs <- chop (product (map (lengthtyp . snd) ltys)) ts]
_ -> trm
lengthtyp ty = case Map.lookup ty typs of
Just m -> length (Map.assocs m)
_ -> error $ "length of type " ++ show ty
chop i xs = case splitAt i xs of
(xs1,[]) -> [xs1]
(xs1,xs2) -> xs1:chop i xs2
mkCurrySel t p = S t p -- done properly in CheckGFCC
mkLab k = LIdent (BS.pack ("_" ++ show k))
-- remove lock fields; in fact, any empty records and record types
unlock = filter notlock where
notlock (l,(_, t)) = case t of --- need not look at l
R [] -> False
RecType [] -> False
_ -> True
unlockTyp = filter notlock
notlock (l, t) = case t of --- need not look at l
RecType [] -> False
_ -> True
unlockTy ty = case ty of
RecType ls -> RecType $ GM.sortRec [(l, unlockTy t) | (l,t) <- ls, notlock (l,t)]
_ -> GM.composSafeOp unlockTy ty
prtTrace tr n =
trace ("-- INTERNAL COMPILER ERROR" +++ A.prt tr ++++ show n) n
prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
-- | 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 -> M.MGrammar i a -> i -> [i]
requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
exts = M.allExtends gr c
ops = if isSingle
then map fst (M.modules gr)
else iterFix (concatMap more) $ exts
more i = errVal [] $ do
m <- M.lookupModMod gr i
return $ M.extends m ++ [o | o <- map M.openedModule (M.opens m)]
notReuse i = errVal True $ do
m <- M.lookupModMod gr i
return $ M.isModRes m -- to exclude reused Cnc and Abs from required

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

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

235
src/GF/Compile/Optimize.hs Normal file
View File

@@ -0,0 +1,235 @@
{-# LANGUAGE PatternGuards #-}
----------------------------------------------------------------------
-- |
-- 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.Predef
import GF.Compile.Refresh
import GF.Compile.Compute
import GF.Compile.BackOpt
import GF.Compile.CheckGrammar
import GF.Compile.Update
import GF.Data.Operations
import GF.Infra.CheckM
import GF.Infra.Option
import Control.Monad
import Data.List
import qualified Data.Set as Set
import Debug.Trace
-- conditional trace
prtIf :: (Print a) => Bool -> a -> a
prtIf b t = if b then trace (" " ++ prt t) t else t
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
type EEnv = () --- not used
-- 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 | mstatus m0 == MSComplete && isModRes m0 -> do
(mo1,_) <- evalModule oopts mse mo
let mo2 = shareModule optim mo1
return (mo2,eenv)
_ -> evalModule oopts mse mo
where
oopts = addOptions opts (moduleOptions (flagsModule mo))
optim = moduleFlag optOptimizations oopts
evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) ->
Err ((Ident,SourceModInfo),EEnv)
evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
ModMod m0 | mstatus m0 == MSComplete -> case mtype m0 of
_ | isModRes m0 -> do
let deps = allOperDependencies name (jments m0)
ids <- topoSortOpers deps
MGrammar (mod' : _) <- foldM evalOp gr ids
return $ (mod',eenv)
MTConcrete a -> do
js' <- mapMTree (evalCncInfo oopts gr name a) (jments m0)
return $ ((name, ModMod (replaceJudgements m0 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 = moduleFlag optOptimizations oopts
optres = OptExpand `Set.member` optim
evalCncInfo ::
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
evalCncInfo opts gr cnc abs (c,info) = do
seq (prtIf (verbAtLeast opts Verbose) 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 ([(varStr, typeStr)], typ) de
(Yes typ, Nope) ->
liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, 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 -> --trace (prt c) $
eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
pde' <- case pde of
Yes de -> 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 +++ ":")
-- | 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
trm2 <- computeTerm gr subst trm1
trm3 <- if rightType trm2
then computeTerm gr subst trm2
else recordExpand val trm2 >>= computeTerm gr subst
return $ mkAbs vars trm3
where
-- don't eta expand records of right length (correct by type checking)
rightType (R rs) = case val of
RecType ts -> length rs == length ts
_ -> False
rightType _ = 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 varStr . R . mkAssign)
_ -> liftM (Abs varStr) $ mkDefField typ
---- _ -> 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 s | s == cStr -> return $ Vr varStr
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']
_ | Just _ <- 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

277
src/GF/Compile/OptimizeGF.hs Normal file
View File

@@ -0,0 +1,277 @@
----------------------------------------------------------------------
-- |
-- Module : OptimizeGF
-- 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.OptimizeGF (
optModule,unshareModule,unsubexpModule,unoptModule,subexpModule,shareModule
) where
import GF.Grammar.Grammar
import GF.Grammar.Lookup
import GF.Infra.Ident
import qualified GF.Grammar.Macros as C
import GF.Grammar.PrGrammar (prt)
import qualified GF.Infra.Modules as M
import GF.Data.Operations
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS
import Data.List
optModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo)
optModule = subexpModule . shareModule
shareModule = processModule optim
unoptModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
unoptModule gr = unshareModule gr . unsubexpModule
unshareModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
unshareModule gr = processModule (const (unoptim gr))
processModule ::
(Ident -> Term -> Term) -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
processModule opt (i,m) = case m of
M.ModMod mo ->
(i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo))))
_ -> (i,m)
shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (opt c t)) m)
shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (opt c t)) m)
shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (opt c t)))
shareInfo _ i = i
-- the function putting together optimizations
optim :: Ident -> Term -> Term
optim c = values . factor c 0
-- we need no counter to create new variable names, since variables are
-- local to tables (only true in GFC) ---
-- 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 (BS.pack ("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]
T (TTyped ty) cs -> V ty [values t | (_, t) <- cs]
---- why are these left?
---- printing with GrammarToSource does not preserve the distinction
_ -> C.composSafeOp values t
-- to undo the effect of factorization
unoptim :: SourceGrammar -> Term -> Term
unoptim gr = unfactor gr
unfactor :: SourceGrammar -> Term -> Term
unfactor gr t = case t of
T (TTyped ty) [(PV x,u)] -> V ty [restore x v (unfac u) | v <- vals ty]
_ -> C.composSafeOp unfac t
where
unfac = unfactor gr
vals = err error id . allParamValues gr
restore x u t = case t of
Vr y | y == x -> u
_ -> C.composSafeOp (restore x u) t
----------------------------------------------------------------------
{-
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.
-}
subexpModule :: SourceModule -> SourceModule
subexpModule (n,m) = errVal (n,m) $ case m of
M.ModMod mo -> do
let ljs = tree2list (M.jments mo)
(tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0)
js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs
return (n,M.ModMod (M.replaceJudgements mo js2))
_ -> return (n,m)
unsubexpModule :: SourceModule -> SourceModule
unsubexpModule sm@(i,m) = case m of
M.ModMod mo | hasSub ljs ->
(i, M.ModMod (M.replaceJudgements mo
(rebuild (map unparInfo ljs))))
where ljs = tree2list (M.jments mo)
_ -> (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 xs (Yes t) m -> [(c, CncFun xs (Yes (unparTerm t)) m)]
ResOper (Yes (EInt 8)) _ -> [] -- subexp-generated opers
ResOper pty (Yes t) -> [(c, ResOper pty (Yes (unparTerm t)))]
_ -> [(c,info)]
unparTerm t = case t of
Q m c | isOperIdent c -> --- name convention of subexp opers
errVal t $ liftM unparTerm $ lookupResDef gr m c
_ -> C.composSafeOp unparTerm t
gr = M.MGrammar [sm]
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 xs (Yes trm) pn -> do
trm' <- recomp f trm
return (f,CncFun xs (Yes trm') pn)
ResOper ty (Yes trm) -> do
trm' <- recomp f trm
return (f,ResOper ty (Yes trm'))
_ -> return (f,def)
recomp f t = case Map.lookup t tree of
Just (_,id) | operIdent id /= f -> return $ Q mo (operIdent id)
_ -> C.composOp (recomp f) t
list = Map.toList tree
oper id trm = (operIdent id, ResOper (Yes (EInt 8)) (Yes trm))
--- impossible type encoding generated opers
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 xs (Yes trm) pn -> do
get trm
return $ fi
ResOper ty (Yes trm) -> do
get trm
return $ fi
_ -> return fi
collectSubterms :: Ident -> Term -> TermM Term
collectSubterms mo t = case t of
App f a -> do
collect f
collect a
add t
T ty cs -> do
let (_,ts) = unzip cs
mapM collect ts
add t
V ty ts -> do
mapM collect ts
add t
---- K (KP _ _) -> add t
_ -> C.composOp (collectSubterms mo) t
where
collect = collectSubterms mo
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
operIdent :: Int -> Ident
operIdent i = identC (operPrefix `BS.append` (BS.pack (show i))) ---
isOperIdent :: Ident -> Bool
isOperIdent id = BS.isPrefixOf operPrefix (ident2bs id)
operPrefix = BS.pack ("A''")

124
src/GF/Compile/OptimizeGFCC.hs Normal file
View File

@@ -0,0 +1,124 @@
module GF.Compile.OptimizeGFCC where
import PGF.CId
import PGF.Data
import GF.Data.Operations
import Data.List
import qualified Data.Map as Map
-- back-end optimization:
-- suffix analysis followed by common subexpression elimination
optPGF :: PGF -> PGF
optPGF = cseOptimize . suffixOptimize
suffixOptimize :: PGF -> PGF
suffixOptimize pgf = pgf {
concretes = Map.map opt (concretes pgf)
}
where
opt cnc = cnc {
lins = Map.map optTerm (lins cnc),
lindefs = Map.map optTerm (lindefs cnc),
printnames = Map.map optTerm (printnames cnc)
}
cseOptimize :: PGF -> PGF
cseOptimize pgf = pgf {
concretes = Map.map subex (concretes pgf)
}
-- analyse word form lists into prefix + suffixes
-- suffix sets can later be shared by subex elim
optTerm :: Term -> Term
optTerm tr = case tr of
R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | K (KS s) <- ts]
R ts -> R $ map optTerm ts
P t v -> P (optTerm t) v
_ -> tr
where
optToks ss = prf : suffs where
prf = pref (head ss) (tail ss)
suffs = map (drop (length prf)) ss
pref cand ss = case ss of
s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss
_ -> cand
isK t = case t of
K (KS _) -> True
_ -> False
mkSuff ("":ws) = R (map (K . KS) ws)
mkSuff (p:ws) = W p (R (map (K . KS) ws))
-- common subexpression elimination
---subex :: [(CId,Term)] -> [(CId,Term)]
subex :: Concr -> Concr
subex cnc = err error id $ do
(tree,_) <- appSTM (getSubtermsMod cnc) (Map.empty,0)
return $ addSubexpConsts tree cnc
type TermList = Map.Map Term (Int,Int) -- number of occs, id
type TermM a = STM (TermList,Int) a
addSubexpConsts :: TermList -> Concr -> Concr
addSubexpConsts tree cnc = cnc {
opers = Map.fromList [(f,recomp f trm) | (f,trm) <- ops],
lins = rec lins,
lindefs = rec lindefs,
printnames = rec printnames
}
where
ops = [(fid id, trm) | (trm,(_,id)) <- Map.assocs tree]
mkOne (f,trm) = (f, recomp f trm)
recomp f t = case Map.lookup t tree of
Just (_,id) | fid id /= f -> F $ fid id -- not to replace oper itself
_ -> case t of
R ts -> R $ map (recomp f) ts
S ts -> S $ map (recomp f) ts
W s t -> W s (recomp f t)
P t p -> P (recomp f t) (recomp f p)
_ -> t
fid n = mkCId $ "_" ++ show n
rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)]
getSubtermsMod :: Concr -> TermM TermList
getSubtermsMod cnc = do
mapM getSubterms (Map.assocs (lins cnc))
mapM getSubterms (Map.assocs (lindefs cnc))
mapM getSubterms (Map.assocs (printnames cnc))
(tree0,_) <- readSTM
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
where
getSubterms (f,trm) = collectSubterms trm >> return ()
collectSubterms :: Term -> TermM ()
collectSubterms t = case t of
R ts -> do
mapM collectSubterms ts
add t
S ts -> do
mapM collectSubterms ts
add t
W s u -> do
collectSubterms u
add t
P p u -> do
collectSubterms p
collectSubterms u
add t
_ -> return ()
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)

195
src/GF/Compile/ReadFiles.hs Normal file
View File

@@ -0,0 +1,195 @@
----------------------------------------------------------------------
-- |
-- Module : ReadFiles
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 23:24:34 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.26 $
--
-- Decide what files to read as function of dependencies and time stamps.
--
-- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004
--
-- to find all files that have to be read, put them in dependency order, and
-- decide which files need recompilation. Name @file.gf@ is returned for them,
-- and @file.gfo@ otherwise.
-----------------------------------------------------------------------------
module GF.Compile.ReadFiles
( getAllFiles,ModName,ModEnv,importsOfModule,
gfoFile,gfFile,isGFO,
getOptionsFromFile) where
import GF.Infra.UseIO
import GF.Infra.Option
import GF.Data.Operations
import GF.Source.AbsGF hiding (FileName)
import GF.Source.LexGF
import GF.Source.ParGF
import Control.Monad
import Data.Char
import Data.List
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map
import System.Time
import System.Directory
import System.FilePath
type ModName = String
type ModEnv = Map.Map ModName (ClockTime,[ModName])
-- | Returns a list of all files to be compiled in topological order i.e.
-- the low level (leaf) modules are first.
getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath]
getAllFiles opts ps env file = do
-- read module headers from all files recursively
ds <- liftM reverse $ get [] [] (justModuleName file)
ioeIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds]
return $ paths ds
where
-- construct list of paths to read
paths cs = [mk (p </> f) | (f,st,_,_,p) <- cs, mk <- mkFile st]
where
mkFile CSComp = [gfFile ]
mkFile CSRead = [gfoFile]
mkFile _ = []
-- | traverses the dependency graph and returns a topologicaly sorted
-- list of ModuleInfo. An error is raised if there is circular dependency
get :: [ModName] -- ^ keeps the current path in the dependency graph to avoid cycles
-> [ModuleInfo] -- ^ a list of already traversed modules
-> ModName -- ^ the current module
-> IOE [ModuleInfo] -- ^ the final
get trc ds name
| name `elem` trc = ioeErr $ Bad $ "circular modules" +++ unwords trc
| (not . null) [n | (n,_,_,_,_) <- ds, name == n] --- file already read
= return ds
| otherwise = do
(name,st0,t0,imps,p) <- findModule name
ds <- foldM (get (name:trc)) ds imps
let (st,t) | (not . null) [f | (f,CSComp,_,_,_) <- ds, elem f imps]
= (CSComp,Nothing)
| otherwise = (st0,t0)
return ((name,st,t,imps,p):ds)
-- searches for module in the search path and if it is found
-- returns 'ModuleInfo'. It fails if there is no such module
findModule :: ModName -> IOE ModuleInfo
findModule name = do
(file,gfTime,gfoTime) <- do
mb_gfFile <- ioeIO $ getFilePathMsg "" ps (gfFile name)
case mb_gfFile of
Just gfFile -> do gfTime <- ioeIO $ getModificationTime gfFile
mb_gfoTime <- ioeIO $ catch (liftM Just $ getModificationTime (replaceExtension gfFile "gfo"))
(\_->return Nothing)
return (gfFile, Just gfTime, mb_gfoTime)
Nothing -> do mb_gfoFile <- ioeIO $ getFilePathMsg "" ps (gfoFile name)
case mb_gfoFile of
Just gfoFile -> do gfoTime <- ioeIO $ getModificationTime gfoFile
return (gfoFile, Nothing, Just gfoTime)
Nothing -> ioeErr $ Bad ("File " ++ gfFile name ++ " does not exist.")
let mb_envmod = Map.lookup name env
(st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime
imps <- if st == CSEnv
then return (maybe [] snd mb_envmod)
else do s <- ioeIO $ BS.readFile file
(mname,imps) <- ioeErr ((liftM importsOfModule . pModHeader . myLexer) s)
ioeErr $ testErr (mname == name)
("module name" +++ mname +++ "differs from file name" +++ name)
return imps
return (name,st,t,imps,dropFileName file)
isGFO :: FilePath -> Bool
isGFO = (== ".gfo") . takeExtensions
gfoFile :: FilePath -> FilePath
gfoFile f = addExtension f "gfo"
gfFile :: FilePath -> FilePath
gfFile f = addExtension f "gf"
-- From the given Options and the time stamps computes
-- whether the module have to be computed, read from .gfo or
-- the environment version have to be used
selectFormat :: Options -> Maybe ClockTime -> Maybe ClockTime -> Maybe ClockTime -> (CompStatus,Maybe ClockTime)
selectFormat opts mtenv mtgf mtgfo =
case (mtenv,mtgfo,mtgf) of
(_,_,Just tgf) | fromSrc -> (CSComp,Nothing)
(Just tenv,_,_) | fromComp -> (CSEnv, Just tenv)
(_,Just tgfo,_) | fromComp -> (CSRead,Just tgfo)
(Just tenv,_,Just tgf) | tenv > tgf -> (CSEnv, Just tenv)
(_,Just tgfo,Just tgf) | tgfo > tgf -> (CSRead,Just tgfo)
(Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist
(_,_, Nothing) -> (CSRead,Nothing) -- source does not exist
_ -> (CSComp,Nothing)
where
fromComp = flag optRecomp opts == NeverRecomp
fromSrc = flag optRecomp opts == AlwaysRecomp
-- internal module dep information
data CompStatus =
CSComp -- compile: read gf
| CSRead -- read gfo
| CSEnv -- gfo is in env
deriving Eq
type ModuleInfo = (ModName,CompStatus,Maybe ClockTime,[ModName],InitPath)
importsOfModule :: ModDef -> (ModName,[ModName])
importsOfModule (MModule _ typ body) = modType typ (modBody body [])
where
modType (MTAbstract m) xs = (modName m,xs)
modType (MTResource m) xs = (modName m,xs)
modType (MTInterface m) xs = (modName m,xs)
modType (MTConcrete m m2) xs = (modName m,modName m2:xs)
modType (MTInstance m m2) xs = (modName m,modName m2:xs)
modType (MTTransfer m o1 o2) xs = (modName m,open o1 (open o2 xs))
modBody (MBody e o _) xs = extend e (opens o xs)
modBody (MNoBody is) xs = foldr include xs is
modBody (MWith i os) xs = include i (foldr open xs os)
modBody (MWithBody i os o _) xs = include i (foldr open (opens o xs) os)
modBody (MWithE is i os) xs = foldr include (include i (foldr open xs os)) is
modBody (MWithEBody is i os o _) xs = foldr include (include i (foldr open (opens o xs) os)) is
modBody (MReuse m) xs = modName m:xs
modBody (MUnion is) xs = foldr include xs is
include (IAll m) xs = modName m:xs
include (ISome m _) xs = modName m:xs
include (IMinus m _) xs = modName m:xs
open (OName n) xs = modName n:xs
open (OQualQO _ n) xs = modName n:xs
open (OQual _ _ n) xs = modName n:xs
extend NoExt xs = xs
extend (Ext is) xs = foldr include xs is
opens NoOpens xs = xs
opens (OpenIn os) xs = foldr open xs os
modName (PIdent (_,s)) = BS.unpack s
-- | options can be passed to the compiler by comments in @--#@, in the main file
getOptionsFromFile :: FilePath -> IOE Options
getOptionsFromFile file = do
s <- ioeIO $ readFileIfStrict file
let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls
ioeErr $ liftM moduleOptions $ parseModuleOptions fs

104
src/GF/Compile/Rebuild.hs Normal file
View File

@@ -0,0 +1,104 @@
----------------------------------------------------------------------
-- |
-- 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.Infra.Option
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)
{positions =
buildTree (tree2list (positions m1) ++
tree2list (positions m))}
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_ ps_) (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 ps0 <- 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 = addModuleOptions fs fs_ -- new flags have priority
let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0)
let ps1 = buildTree (tree2list ps_ ++ tree2list ps0)
return $ ModMod $ Module mt0 stat' fs1 me ops1 js1 ps1
---- (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):)

133
src/GF/Compile/Refresh.hs Normal file
View File

@@ -0,0 +1,133 @@
----------------------------------------------------------------------
-- |
-- Module : Refresh
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:27 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Compile.Refresh (refreshTerm, refreshTermN,
refreshModule
) where
import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Grammar.Macros
import Control.Monad
refreshTerm :: Term -> Err Term
refreshTerm = refreshTermN 0
refreshTermN :: Int -> Term -> Err Term
refreshTermN i e = liftM snd $ refreshTermKN i e
refreshTermKN :: Int -> Term -> Err (Int,Term)
refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $
appSTM (refresh e) (initIdStateN i)
refresh :: Term -> STM IdState Term
refresh e = case e of
Vr x -> liftM Vr (lookVar x)
Abs x b -> liftM2 Abs (refVarPlus x) (refresh b)
Prod x a b -> do
a' <- refresh a
x' <- refVar x
b' <- refresh b
return $ Prod x' a' b'
Let (x,(mt,a)) b -> do
a' <- refresh a
mt' <- case mt of
Just t -> refresh t >>= (return . Just)
_ -> return mt
x' <- refVar x
b' <- refresh b
return (Let (x',(mt',a')) b')
R r -> liftM R $ refreshRecord r
ExtR r s -> liftM2 ExtR (refresh r) (refresh s)
T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc)
_ -> composOp refresh e
refreshCase :: (Patt,Term) -> STM IdState (Patt,Term)
refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t)
refreshPatt p = case p of
PV x -> liftM PV (refVar x)
PC c ps -> liftM (PC c) (mapM refreshPatt ps)
PP q c ps -> liftM (PP q c) (mapM refreshPatt ps)
PR r -> liftM PR (mapPairsM refreshPatt r)
PT t p' -> liftM2 PT (refresh t) (refreshPatt p')
PAs x p' -> liftM2 PAs (refVar x) (refreshPatt p')
PSeq p' q' -> liftM2 PSeq (refreshPatt p') (refreshPatt q')
PAlt p' q' -> liftM2 PAlt (refreshPatt p') (refreshPatt q')
PRep p' -> liftM PRep (refreshPatt p')
PNeg p' -> liftM PNeg (refreshPatt p')
_ -> return p
refreshRecord r = case r of
[] -> return r
(x,(mt,a)):b -> do
a' <- refresh a
mt' <- case mt of
Just t -> refresh t >>= (return . Just)
_ -> return mt
b' <- refreshRecord b
return $ (x,(mt',a')) : b'
refreshTInfo i = case i of
TTyped t -> liftM TTyped $ refresh t
TComp t -> liftM TComp $ refresh t
TWild t -> liftM TWild $ refresh t
_ -> return i
-- for abstract syntax
refreshEquation :: Equation -> Err ([Patt],Term)
refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where
refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t)
-- for concrete and resource in grammar, before optimizing
refreshGrammar :: SourceGrammar -> Err SourceGrammar
refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules
refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule])
refreshModule (k,ms) mi@(i,m) = case m of
ModMod mo | (isModCnc mo || isModRes mo) -> do
(k',js') <- foldM refreshRes (k,[]) $ tree2list $ jments mo
return (k', (i, ModMod(replaceJudgements mo (buildTree js'))) : ms)
_ -> return (k, mi:ms)
where
refreshRes (k,cs) ci@(c,info) = case info of
ResOper ptyp (Yes trm) -> do ---- refresh ptyp
(k',trm') <- refreshTermKN k trm
return $ (k', (c, ResOper ptyp (Yes trm')):cs)
ResOverload os tyts -> do
(k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $
appSTM (mapPairsM refresh tyts) (initIdStateN k)
return $ (k', (c, ResOverload os tyts'):cs)
CncCat mt (Yes trm) pn -> do ---- refresh mt, pn
(k',trm') <- refreshTermKN k trm
return $ (k', (c, CncCat mt (Yes trm') pn):cs)
CncFun mt (Yes trm) pn -> do ---- refresh pn
(k',trm') <- refreshTermKN k trm
return $ (k', (c, CncFun mt (Yes trm') pn):cs)
_ -> return (k, ci:cs)

64
src/GF/Compile/RemoveLiT.hs Normal file
View File

@@ -0,0 +1,64 @@
----------------------------------------------------------------------
-- |
-- 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.Grammar.Predef
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 mo -> do
js1 <- mapMTree (remlResInfo gr) (jments mo)
let mod2 = ModMod $ mo {jments = 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
_ -> cCNC

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

@@ -0,0 +1,338 @@
----------------------------------------------------------------------
-- |
-- Module : Rename
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.19 $
--
-- AR 14\/5\/2003
-- The top-level function 'renameGrammar' does several things:
--
-- - extends each module symbol table by indirections to extended module
--
-- - changes unqualified and as-qualified imports to absolutely qualified
--
-- - goes through the definitions and resolves names
--
-- Dependency analysis between modules has been performed before this pass.
-- Hence we can proceed by @fold@ing "from left to right".
-----------------------------------------------------------------------------
module GF.Compile.Rename (renameGrammar,
renameSourceTerm,
renameModule
) where
import GF.Grammar.Grammar
import GF.Grammar.Values
import GF.Grammar.Predef
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 mo -> do
let js1 = jments mo
status <- buildStatus (MGrammar ms) name mod
js2 <- mapsErrTree (renameInfo mo status) js1
let mod2 = ModMod $ mo {opens = map forceQualif (opens mo), jments = 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
| isPredefCat c = return $ Q cPredefAbs c
| otherwise = 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)
-- 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 :: Module Ident Info -> Status -> (Ident,Info) -> Err (Ident,Info)
renameInfo mo status (i,info) = errIn
("renaming definition of" +++ prt i +++ showPosition mo 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 os tysts ->
liftM (ResOverload os) (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')

292
src/GF/Compile/TC.hs Normal file
View File

@@ -0,0 +1,292 @@
----------------------------------------------------------------------
-- |
-- Module : TC
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/02 20:50:19 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.11 $
--
-- Thierry Coquand's type checking algorithm that creates a trace
-----------------------------------------------------------------------------
module GF.Compile.TC (AExp(..),
Theory,
checkExp,
inferExp,
checkEqs,
eqVal,
whnf
) where
import GF.Data.Operations
import GF.Grammar.Predef
import GF.Grammar.Abstract
import Control.Monad
import Data.List (sortBy)
data AExp =
AVr Ident Val
| ACn QIdent Val
| AType
| AInt Integer
| AFloat Double
| AStr String
| AMeta MetaSymb Val
| AApp AExp AExp Val
| AAbs Ident Val AExp
| AProd Ident AExp AExp
| AEqs [([Exp],AExp)] --- not used
| AData Val
deriving (Eq,Show)
type Theory = QIdent -> Err Val
lookupConst :: Theory -> QIdent -> Err Val
lookupConst th f = th f
lookupVar :: Env -> Ident -> Err Val
lookupVar g x = maybe (prtBad "unknown variable" x) return $ lookup x ((IW,uVal):g)
-- wild card IW: no error produced, ?0 instead.
type TCEnv = (Int,Env,Env)
emptyTCEnv :: TCEnv
emptyTCEnv = (0,[],[])
whnf :: Val -> Err Val
whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
case v of
VApp u w -> do
u' <- whnf u
w' <- whnf w
app u' w'
VClos env e -> eval env e
_ -> return v
app :: Val -> Val -> Err Val
app u v = case u of
VClos env (Abs x e) -> eval ((x,v):env) e
_ -> return $ VApp u v
eval :: Env -> Exp -> Err Val
eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
case e of
Vr x -> lookupVar env x
Q m c -> return $ VCn (m,c)
QC m c -> return $ VCn (m,c) ---- == Q ?
Sort c -> return $ VType --- the only sort is Type
App f a -> join $ liftM2 app (eval env f) (eval env a)
_ -> return $ VClos env e
eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
do
w1 <- whnf u1
w2 <- whnf u2
let v = VGen k
case (w1,w2) of
(VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
(VClos env1 (Abs x1 e1), VClos env2 (Abs x2 e2)) ->
eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
(VClos env1 (Prod x1 a1 e1), VClos env2 (Prod x2 a2 e2)) ->
liftM2 (++)
(eqVal k (VClos env1 a1) (VClos env2 a2))
(eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
(VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
(VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
--- thus ignore qualifications; valid because inheritance cannot
--- be qualified. Simplifies annotation. AR 17/3/2005
_ -> return [(w1,w2) | w1 /= w2]
-- invariant: constraints are in whnf
checkType :: Theory -> TCEnv -> Exp -> Err (AExp,[(Val,Val)])
checkType th tenv e = checkExp th tenv e vType
checkExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)])
checkExp th tenv@(k,rho,gamma) e ty = do
typ <- whnf ty
let v = VGen k
case e of
Meta m -> return $ (AMeta m typ,[])
EData -> return $ (AData typ,[])
Abs x t -> case typ of
VClos env (Prod y a b) -> do
a' <- whnf $ VClos env a ---
(t',cs) <- checkExp th
(k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
return (AAbs x a' t', cs)
_ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ
-- {- --- to get deprec when checkEqs works (15/9/2005)
Eqs es -> do
bcs <- mapM (\b -> checkBranch th tenv b typ) es
let (bs,css) = unzip bcs
return (AEqs bs, concat css)
-- - }
Prod x a b -> do
testErr (typ == vType) "expected Type"
(a',csa) <- checkType th tenv a
(b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
return (AProd x a' b', csa ++ csb)
_ -> checkInferExp th tenv e typ
checkInferExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)])
checkInferExp th tenv@(k,_,_) e typ = do
(e',w,cs1) <- inferExp th tenv e
cs2 <- eqVal k w typ
return (e',cs1 ++ cs2)
inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)])
inferExp th tenv@(k,rho,gamma) e = case e of
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
Q m c | m == cPredefAbs && isPredefCat c
-> return (ACn (m,c) vType, vType, [])
| otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
QC m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) ----
EInt i -> return (AInt i, valAbsInt, [])
EFloat i -> return (AFloat i, valAbsFloat, [])
K i -> return (AStr i, valAbsString, [])
Sort _ -> return (AType, vType, [])
App f t -> do
(f',w,csf) <- inferExp th tenv f
typ <- whnf w
case typ of
VClos env (Prod x a b) -> do
(a',csa) <- checkExp th tenv t (VClos env a)
b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa)
_ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ
_ -> prtBad "cannot infer type of expression" e
checkEqs :: Theory -> TCEnv -> (Fun,Trm) -> Val -> Err [(Val,Val)]
checkEqs th tenv@(k,rho,gamma) (fun@(m,f),def) val = case def of
Eqs es -> liftM concat $ mapM checkBranch es
_ -> liftM snd $ checkExp th tenv def val
where
checkBranch (ps,df) =
let
(ps',_,vars) = foldr p2t ([],0,[]) ps
fps = mkApp (Q m f) ps'
in errIn ("branch" +++ prt fps) $ do
(aexp, typ, cs1) <- inferExp th tenv fps
let
bds = binds vars aexp
tenv' = (k, rho, bds ++ gamma)
(_,cs2) <- errIn (show bds) $ checkExp th tenv' df typ
return $ (cs1 ++ cs2)
p2t p (ps,i,g) = case p of
PW -> (Meta (MetaSymb i) : ps, i+1, g)
PV IW -> (Meta (MetaSymb i) : ps, i+1, g)
PV x -> (Meta (MetaSymb i) : ps, i+1,upd x i g)
PString s -> ( K s : ps, i, g)
PInt n -> (EInt n : ps, i, g)
PFloat n -> (EFloat n : ps, i, g)
PP m c xs -> (mkApp (qq (m,c)) xss : ps, i', g')
where (xss,i',g') = foldr p2t ([],i,g) xs
_ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch"
upd x i g = (x,i) : g --- to annotate pattern variables: treat as metas
-- notice: in vars, the sequence 0.. is sorted. In subst aexp, all
-- this occurs and nothing else.
binds vars aexp = [(x,v) | ((x,_),v) <- zip vars metas] where
metas = map snd $ sortBy (\ (x,_) (y,_) -> compare x y) $ subst aexp
subst aexp = case aexp of
AMeta (MetaSymb i) v -> [(i,v)]
AApp c a _ -> subst c ++ subst a
_ -> [] -- never matter in patterns
checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Exp],AExp),[(Val,Val)])
checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
chB tenv' ps' ty
where
(ps',_,rho2,k') = ps2ts k ps
tenv' = (k, rho2++rho, gamma) ---- k' ?
(k,rho,gamma) = tenv
chB tenv@(k,rho,gamma) ps ty = case ps of
p:ps2 -> do
typ <- whnf ty
case typ of
VClos env (Prod y a b) -> do
a' <- whnf $ VClos env a
(p', sigma, binds, cs1) <- checkP tenv p y a'
let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
_ -> prtBad ("Product expected for definiens" +++prt t +++ "instead of") typ
[] -> do
(e,cs) <- checkExp th tenv t ty
return (([],e),cs)
checkP env@(k,rho,gamma) t x a = do
(delta,cs) <- checkPatt th env t a
let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
return (VClos sigma t, sigma, delta, cs)
ps2ts k = foldr p2t ([],0,[],k)
p2t p (ps,i,g,k) = case p of
PW -> (Meta (MetaSymb i) : ps, i+1,g,k)
PV IW -> (Meta (MetaSymb i) : ps, i+1,g,k)
PV x -> (Vr x : ps, i, upd x k g,k+1)
PString s -> (K s : ps, i, g, k)
PInt n -> (EInt n : ps, i, g, k)
PFloat n -> (EFloat n : ps, i, g, k)
PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k')
where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
_ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch"
upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
checkPatt :: Theory -> TCEnv -> Exp -> Val -> Err (Binds,[(Val,Val)])
checkPatt th tenv exp val = do
(aexp,_,cs) <- checkExpP tenv exp val
let binds = extrBinds aexp
return (binds,cs)
where
extrBinds aexp = case aexp of
AVr i v -> [(i,v)]
AApp f a _ -> extrBinds f ++ extrBinds a
_ -> [] -- no other cases are possible
--- ad hoc, to find types of variables
checkExpP tenv@(k,rho,gamma) exp val = case exp of
Meta m -> return $ (AMeta m val, val, [])
Vr x -> return $ (AVr x val, val, [])
EInt i -> return (AInt i, valAbsInt, [])
EFloat i -> return (AFloat i, valAbsFloat, [])
K s -> return (AStr s, valAbsString, [])
Q m c -> do
typ <- lookupConst th (m,c)
return $ (ACn (m,c) typ, typ, [])
QC m c -> do
typ <- lookupConst th (m,c)
return $ (ACn (m,c) typ, typ, []) ----
App f t -> do
(f',w,csf) <- checkExpP tenv f val
typ <- whnf w
case typ of
VClos env (Prod x a b) -> do
(a',_,csa) <- checkExpP tenv t (VClos env a)
b' <- whnf $ VClos ((x,VClos rho t):env) b
return $ (AApp f' a' b', b', csf ++ csa)
_ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ
_ -> prtBad "cannot typecheck pattern" exp
-- auxiliaries
noConstr :: Err Val -> Err (Val,[(Val,Val)])
noConstr er = er >>= (\v -> return (v,[]))
mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
mkAnnot a ti = do
(v,cs) <- ti
return (a v, v, cs)

118
src/GF/Compile/TypeCheck.hs Normal file
View File

@@ -0,0 +1,118 @@
----------------------------------------------------------------------
-- |
-- Module : TypeCheck
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/15 16:22:02 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Compile.TypeCheck (-- * top-level type checking functions; TC should not be called directly.
checkContext,
checkTyp,
checkEquation,
checkConstrs,
) where
import GF.Data.Operations
import GF.Data.Zipper
import GF.Grammar.Abstract
import GF.Compile.Refresh
import GF.Grammar.LookAbs
import qualified GF.Grammar.Lookup as Lookup ---
import GF.Grammar.Unify ---
import GF.Compile.TC
import Control.Monad (foldM, liftM, liftM2)
import Data.List (nub) ---
-- | invariant way of creating TCEnv from context
initTCEnv gamma =
(length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
-- interface to TC type checker
type2val :: Type -> Val
type2val = VClos []
aexp2tree :: (AExp,[(Val,Val)]) -> Err Tree
aexp2tree (aexp,cs) = do
(bi,at,vt,ts) <- treeForm aexp
ts' <- mapM aexp2tree [(t,[]) | t <- ts]
return $ Tr (N (bi,at,vt,(cs,[]),False),ts')
where
treeForm a = case a of
AAbs x v b -> do
(bi, at, vt, args) <- treeForm b
v' <- whnf v ---- should not be needed...
return ((x,v') : bi, at, vt, args)
AApp c a v -> do
(_,at,_,args) <- treeForm c
v' <- whnf v ----
return ([],at,v',args ++ [a])
AVr x v -> do
v' <- whnf v ----
return ([],AtV x,v',[])
ACn c v -> do
v' <- whnf v ----
return ([],AtC c,v',[])
AInt i -> do
return ([],AtI i,valAbsInt,[])
AFloat i -> do
return ([],AtF i,valAbsFloat,[])
AStr s -> do
return ([],AtL s,valAbsString,[])
AMeta m v -> do
v' <- whnf v ----
return ([],AtM m,v',[])
_ -> Bad "illegal tree" -- AProd
cont2exp :: Context -> Exp
cont2exp c = mkProd (c, eType, []) -- to check a context
cont2val :: Context -> Val
cont2val = type2val . cont2exp
-- some top-level batch-mode checkers for the compiler
justTypeCheck :: Grammar -> Exp -> Val -> Err Constraints
justTypeCheck gr e v = do
(_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v
return $ filter notJustMeta constrs0
---- return $ fst $ splitConstraintsSrc gr constrs0
---- this change was to force proper tc of abstract modules.
---- May not be quite right. AR 13/9/2005
notJustMeta (c,k) = case (c,k) of
(VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False
_ -> True
grammar2theory :: Grammar -> Theory
grammar2theory gr (m,f) = case lookupFunType gr m f of
Ok t -> return $ type2val t
Bad s -> case lookupCatContext gr m f of
Ok cont -> return $ cont2val cont
_ -> Bad s
checkContext :: Grammar -> Context -> [String]
checkContext st = checkTyp st . cont2exp
checkTyp :: Grammar -> Type -> [String]
checkTyp gr typ = err singleton prConstrs $ justTypeCheck gr typ vType
checkEquation :: Grammar -> Fun -> Trm -> [String]
checkEquation gr (m,fun) def = err singleton id $ do
typ <- lookupFunType gr m fun
cs <- justTypeCheck gr def (vClos typ)
let cs1 = filter notJustMeta cs
return $ ifNull [] (singleton . prConstraints) cs1
checkConstrs :: Grammar -> Cat -> [Ident] -> [String]
checkConstrs gr cat _ = [] ---- check constructors!

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

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

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

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

93
src/GF/Data/BacktrackM.hs Normal file
View File

@@ -0,0 +1,93 @@
----------------------------------------------------------------------
-- |
-- Module : BacktrackM
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:00 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.4 $
--
-- Backtracking state monad, with r\/o environment
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fglasgow-exts #-}
module GF.Data.BacktrackM ( -- * the backtracking state monad
BacktrackM,
-- * controlling the monad
failure,
(|||),
-- * handling the state & environment
readState,
writeState,
-- * monad specific utilities
member,
-- * running the monad
foldBM, runBM,
foldSolutions, solutions,
foldFinalStates, finalStates
) where
import Data.List
import Control.Monad
----------------------------------------------------------------------
-- Combining endomorphisms and continuations
-- a la Ralf Hinze
-- BacktrackM = state monad transformer over the backtracking monad
newtype BacktrackM s a = BM (forall b . (a -> s -> b -> b) -> s -> b -> b)
-- * running the monad
runBM :: BacktrackM s a -> s -> [(s,a)]
runBM (BM m) s = m (\x s xs -> (s,x) : xs) s []
foldBM :: (a -> s -> b -> b) -> b -> BacktrackM s a -> s -> b
foldBM f b (BM m) s = m f s b
foldSolutions :: (a -> b -> b) -> b -> BacktrackM s a -> s -> b
foldSolutions f b (BM m) s = m (\x s b -> f x b) s b
solutions :: BacktrackM s a -> s -> [a]
solutions = foldSolutions (:) []
foldFinalStates :: (s -> b -> b) -> b -> BacktrackM s () -> s -> b
foldFinalStates f b (BM m) s = m (\x s b -> f s b) s b
finalStates :: BacktrackM s () -> s -> [s]
finalStates bm = map fst . runBM bm
-- * handling the state & environment
readState :: BacktrackM s s
readState = BM (\c s b -> c s s b)
writeState :: s -> BacktrackM s ()
writeState s = BM (\c _ b -> c () s b)
instance Monad (BacktrackM s) where
return a = BM (\c s b -> c a s b)
BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b)
where unBM (BM m) = m
fail _ = failure
-- * controlling the monad
failure :: BacktrackM s a
failure = BM (\c s b -> b)
(|||) :: BacktrackM s a -> BacktrackM s a -> BacktrackM s a
(BM f) ||| (BM g) = BM (\c s b -> g c s $! f c s b)
instance MonadPlus (BacktrackM s) where
mzero = failure
mplus = (|||)
-- * specific functions on the backtracking monad
member :: [a] -> BacktrackM s a
member xs = BM (\c s b -> foldl' (\b x -> c x s b) b xs)

38
src/GF/Data/ErrM.hs Normal file
View File

@@ -0,0 +1,38 @@
----------------------------------------------------------------------
-- |
-- Module : ErrM
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:00 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.5 $
--
-- hack for BNFC generated files. AR 21/9/2003
-----------------------------------------------------------------------------
module GF.Data.ErrM (Err(..)) where
import Control.Monad (MonadPlus(..))
-- | like @Maybe@ type with error msgs
data Err a = Ok a | Bad String
deriving (Read, Show, Eq)
instance Monad Err where
return = Ok
fail = Bad
Ok a >>= f = f a
Bad s >>= f = Bad s
-- | added 2\/10\/2003 by PEB
instance Functor Err where
fmap f (Ok a) = Ok (f a)
fmap f (Bad s) = Bad s
-- | added by KJ
instance MonadPlus Err where
mzero = Bad "error (no reason given)"
mplus (Ok a) _ = Ok a
mplus (Bad s) b = b

47
src/GF/Data/MultiMap.hs Normal file
View File

@@ -0,0 +1,47 @@
module GF.Data.MultiMap where
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Prelude hiding (map)
import qualified Prelude
type MultiMap k a = Map k (Set a)
empty :: MultiMap k a
empty = Map.empty
keys :: MultiMap k a -> [k]
keys = Map.keys
elems :: MultiMap k a -> [a]
elems = concatMap Set.toList . Map.elems
(!) :: Ord k => MultiMap k a -> k -> [a]
m ! k = Set.toList $ Map.findWithDefault Set.empty k m
member :: (Ord k, Ord a) => k -> a -> MultiMap k a -> Bool
member k x m = x `Set.member` Map.findWithDefault Set.empty k m
insert :: (Ord k, Ord a) => k -> a -> MultiMap k a -> MultiMap k a
insert k x m = Map.insertWith Set.union k (Set.singleton x) m
insert' :: (Ord k, Ord a) => k -> a -> MultiMap k a -> Maybe (MultiMap k a)
insert' k x m | member k x m = Nothing -- FIXME: inefficient
| otherwise = Just (insert k x m)
union :: (Ord k, Ord a) => MultiMap k a -> MultiMap k a -> MultiMap k a
union = Map.unionWith Set.union
size :: MultiMap k a -> Int
size = sum . Prelude.map Set.size . Map.elems
map :: (Ord a, Ord b) => (a -> b) -> MultiMap k a -> MultiMap k b
map f = Map.map (Set.map f)
fromList :: (Ord k, Ord a) => [(k,a)] -> MultiMap k a
fromList xs = Map.fromListWith Set.union [(k, Set.singleton x) | (k,x) <- xs]
toList :: MultiMap k a -> [(k,a)]
toList m = [(k,x) | (k,s) <- Map.toList m, x <- Set.toList s]

676
src/GF/Data/Operations.hs Normal file
View File

@@ -0,0 +1,676 @@
----------------------------------------------------------------------
-- |
-- Module : Operations
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 16:12:41 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.22 $
--
-- some auxiliary GF operations. AR 19\/6\/1998 -- 6\/2\/2001
--
-- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL)
-----------------------------------------------------------------------------
module GF.Data.Operations (-- * misc functions
ifNull, onSnd,
-- * the Error monad
Err(..), err, maybeErr, testErr, errVal, errIn, derrIn,
performOps, repeatUntilErr, repeatUntil, okError, isNotError,
showBad, lookupErr, lookupErrMsg, lookupDefault, updateLookupList,
mapPairListM, mapPairsM, pairM, mapErr, mapErrN, foldErr,
(!?), errList, singleton, mapsErr, mapsErrTree,
-- ** checking
checkUnique, titleIfNeeded, errMsg, errAndMsg,
-- * a three-valued maybe type to express indirections
Perhaps(..), yes, may, nope,
mapP,
unifPerhaps, updatePerhaps, updatePerhapsHard,
-- * binary search trees; now with FiniteMap
BinTree, emptyBinTree, isInBinTree, justLookupTree,
lookupTree, lookupTreeMany, lookupTreeManyAll, updateTree,
buildTree, filterBinTree,
sorted2tree, mapTree, mapMTree, tree2list,
-- * parsing
WParser, wParseResults, paragraphs,
-- * printing
indent, (+++), (++-), (++++), (+++++),
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
-- ** LaTeX code producing functions
dollar, mbox, ital, boldf, verbat, mkLatexFile,
begindocument, enddocument,
-- * extra
sortByLongest, combinations, mkTextFile, initFilePath,
-- * topological sorting with test of cyclicity
topoTest, topoSort, cyclesIn,
-- * the generic fix point iterator
iterFix,
-- * association lists
updateAssoc, removeAssoc,
-- * chop into separator-separated parts
chunks, readIntArg, subSequences,
-- * state monad with error; from Agda 6\/11\/2001
STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM, done,
-- * error monad class
ErrorMonad(..), checkAgain, checks, allChecks, doUntil
) where
import Data.Char (isSpace, toUpper, isSpace, isDigit)
import Data.List (nub, sortBy, sort, deleteBy, nubBy)
--import Data.FiniteMap
import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus)
import GF.Data.ErrM
infixr 5 +++
infixr 5 ++-
infixr 5 ++++
infixr 5 +++++
infixl 9 !?
ifNull :: b -> ([a] -> b) -> [a] -> b
ifNull b f xs = if null xs then b else f xs
onSnd :: (a -> b) -> (c,a) -> (c,b)
onSnd f (x, y) = (x, f y)
-- the Error monad
-- | analogue of @maybe@
err :: (String -> b) -> (a -> b) -> Err a -> b
err d f e = case e of
Ok a -> f a
Bad s -> d s
-- | add msg s to @Maybe@ failures
maybeErr :: String -> Maybe a -> Err a
maybeErr s = maybe (Bad s) Ok
testErr :: Bool -> String -> Err ()
testErr cond msg = if cond then return () else Bad msg
errVal :: a -> Err a -> a
errVal a = err (const a) id
errIn :: String -> Err a -> Err a
errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return
-- | used for extra error reports when developing GF
derrIn :: String -> Err a -> Err a
derrIn m = errIn m -- id
performOps :: [a -> Err a] -> a -> Err a
performOps ops a = case ops of
f:fs -> f a >>= performOps fs
[] -> return a
repeatUntilErr :: (a -> Bool) -> (a -> Err a) -> a -> Err a
repeatUntilErr cond f a = if cond a then return a else f a >>= repeatUntilErr cond f
repeatUntil :: (a -> Bool) -> (a -> a) -> a -> a
repeatUntil cond f a = if cond a then a else repeatUntil cond f (f a)
okError :: Err a -> a
-- okError = err (error "no result Ok") id
okError = err (error . ("Bad result occurred" ++++)) id
isNotError :: Err a -> Bool
isNotError = err (const False) (const True)
showBad :: Show a => String -> a -> Err b
showBad s a = Bad (s +++ show a)
lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b
lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs)
lookupErrMsg :: (Eq a,Show a) => String -> a -> [(a,b)] -> Err b
lookupErrMsg m a abs = maybeErr (m +++ "gave unknown" +++ show a) (lookup a abs)
lookupDefault :: Eq a => b -> a -> [(a,b)] -> b
lookupDefault d x l = maybe d id $ lookup x l
updateLookupList :: Eq a => (a,b) -> [(a,b)] -> [(a,b)]
updateLookupList ab abs = insert ab [] abs where
insert c cc [] = cc ++ [c]
insert (a,b) cc ((a',b'):cc') = if a == a'
then cc ++ [(a,b)] ++ cc'
else insert (a,b) (cc ++ [(a',b')]) cc'
mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)]
mapPairListM f xys = mapM (\ p@(x,_) -> liftM ((,) x) (f p)) xys
mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
mapPairsM f xys = mapM (\ (x,y) -> liftM ((,) x) (f y)) xys
pairM :: Monad a => (b -> a c) -> (b,b) -> a (c,c)
pairM op (t1,t2) = liftM2 (,) (op t1) (op t2)
-- | like @mapM@, but continue instead of halting with 'Err'
mapErr :: (a -> Err b) -> [a] -> Err ([b], String)
mapErr f xs = Ok (ys, unlines ss)
where
(ys,ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs])
fxs = map f xs
-- | alternative variant, peb 9\/6-04
mapErrN :: Int -> (a -> Err b) -> [a] -> Err ([b], String)
mapErrN maxN f xs = Ok (ys, unlines (errHdr : ss2))
where
(ys, ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs])
errHdr = show nss ++ " errors occured" ++
if nss > maxN then ", showing the first " ++ show maxN else ""
ss2 = map ("* "++) $ take maxN ss
nss = length ss
fxs = map f xs
-- | like @foldM@, but also return the latest value if fails
foldErr :: (a -> b -> Err a) -> a -> [b] -> Err (a, Maybe String)
foldErr f s xs = case xs of
[] -> return (s,Nothing)
x:xx -> case f s x of
Ok v -> foldErr f v xx
Bad m -> return $ (s, Just m)
-- @!!@ with the error monad
(!?) :: [a] -> Int -> Err a
xs !? i = foldr (const . return) (Bad "too few elements in list") $ drop i xs
errList :: Err [a] -> [a]
errList = errVal []
singleton :: a -> [a]
singleton = (:[])
-- checking
checkUnique :: (Show a, Eq a) => [a] -> [String]
checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where
overloads = filter overloaded ss
overloaded s = length (filter (==s) ss) > 1
titleIfNeeded :: a -> [a] -> [a]
titleIfNeeded a [] = []
titleIfNeeded a as = a:as
errMsg :: Err a -> [String]
errMsg (Bad m) = [m]
errMsg _ = []
errAndMsg :: Err a -> Err (a,[String])
errAndMsg (Bad m) = Bad m
errAndMsg (Ok a) = return (a,[])
-- | a three-valued maybe type to express indirections
data Perhaps a b = Yes a | May b | Nope deriving (Show,Read,Eq,Ord)
yes :: a -> Perhaps a b
yes = Yes
may :: b -> Perhaps a b
may = May
nope :: Perhaps a b
nope = Nope
mapP :: (a -> c) -> Perhaps a b -> Perhaps c b
mapP f p = case p of
Yes a -> Yes (f a)
May b -> May b
Nope -> Nope
-- | this is what happens when matching two values in the same module
unifPerhaps :: (Eq a, Eq b, Show a, Show b) =>
Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
unifPerhaps p1 p2 = case (p1,p2) of
(Nope, _) -> return p2
(_, Nope) -> return p1
_ -> if p1==p2 then return p1
else Bad ("update conflict between" ++++ show p1 ++++ show p2)
-- | this is what happens when updating a module extension
updatePerhaps :: (Eq a,Eq b, Show a, Show b) =>
b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
updatePerhaps old p1 p2 = case (p1,p2) of
(Yes a, Nope) -> return $ may old
(May older,Nope) -> return $ may older
(_, May a) -> Bad "strange indirection"
_ -> unifPerhaps p1 p2
-- | here the value is copied instead of referred to; used for oper types
updatePerhapsHard :: (Eq a, Eq b, Show a, Show b) => b ->
Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
updatePerhapsHard old p1 p2 = case (p1,p2) of
(Yes a, Nope) -> return $ yes a
(May older,Nope) -> return $ may older
(_, May a) -> Bad "strange indirection"
_ -> unifPerhaps p1 p2
-- binary search trees
--- FiniteMap implementation is slower in crucial tests
data BinTree a b = NT | BT (a,b) !(BinTree a b) !(BinTree a b) deriving (Show)
-- type BinTree a b = FiniteMap a b
emptyBinTree :: BinTree a b
emptyBinTree = NT
-- emptyBinTree = emptyFM
isInBinTree :: (Ord a) => a -> BinTree a b -> Bool
isInBinTree x = err (const False) (const True) . justLookupTree x
-- isInBinTree = elemFM
justLookupTree :: (Monad m,Ord a) => a -> BinTree a b -> m b
justLookupTree = lookupTree (const [])
lookupTree :: (Monad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b
lookupTree pr x tree = case tree of
NT -> fail ("no occurrence of element" +++ pr x)
BT (a,b) left right
| x < a -> lookupTree pr x left
| x > a -> lookupTree pr x right
| x == a -> return b
--lookupTree pr x tree = case lookupFM tree x of
-- Just y -> return y
-- _ -> fail ("no occurrence of element" +++ pr x)
lookupTreeMany :: Ord a => (a -> String) -> [BinTree a b] -> a -> Err b
lookupTreeMany pr (t:ts) x = case lookupTree pr x t of
Ok v -> return v
_ -> lookupTreeMany pr ts x
lookupTreeMany pr [] x = Bad $ "failed to find" +++ pr x
lookupTreeManyAll :: Ord a => (a -> String) -> [BinTree a b] -> a -> [b]
lookupTreeManyAll pr (t:ts) x = case lookupTree pr x t of
Ok v -> v : lookupTreeManyAll pr ts x
_ -> lookupTreeManyAll pr ts x
lookupTreeManyAll pr [] x = []
-- | destructive update
updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b
-- updateTree (a,b) tr = addToFM tr a b
updateTree = updateTreeGen True
-- | destructive or not
updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree a b -> BinTree a b
updateTreeGen destr z@(x,y) tree = case tree of
NT -> BT z NT NT
BT c@(a,b) left right
| x < a -> let left' = updateTree z left in BT c left' right
| x > a -> let right' = updateTree z right in BT c left right'
| otherwise -> if destr
then BT z left right -- removing the old value of a
else tree -- retaining the old value if one exists
buildTree :: (Ord a) => [(a,b)] -> BinTree a b
buildTree = sorted2tree . sortBy fs where
fs (x,_) (y,_)
| x < y = LT
| x > y = GT
| True = EQ
-- buildTree = listToFM
sorted2tree :: Ord a => [(a,b)] -> BinTree a b
sorted2tree [] = NT
sorted2tree xs = BT x (sorted2tree t1) (sorted2tree t2) where
(t1,(x:t2)) = splitAt (length xs `div` 2) xs
--sorted2tree = listToFM
--- dm less general than orig
mapTree :: ((a,b) -> (a,c)) -> BinTree a b -> BinTree a c
mapTree f NT = NT
mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right)
--mapTree f = mapFM (\k v -> snd (f (k,v)))
--- fm less efficient than orig?
mapMTree :: (Ord a,Monad m) => ((a,b) -> m (a,c)) -> BinTree a b -> m (BinTree a c)
mapMTree f NT = return NT
mapMTree f (BT a left right) = do
a' <- f a
left' <- mapMTree f left
right' <- mapMTree f right
return $ BT a' left' right'
--mapMTree f t = liftM listToFM $ mapM f $ fmToList t
filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b
-- filterFM f t
filterBinTree f = sorted2tree . filter (uncurry f) . tree2list
tree2list :: BinTree a b -> [(a,b)] -- inorder
tree2list NT = []
tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right
--tree2list = fmToList
-- parsing
type WParser a b = [a] -> [(b,[a])] -- old Wadler style parser
wParseResults :: WParser a b -> [a] -> [b]
wParseResults p aa = [b | (b,[]) <- p aa]
paragraphs :: String -> [String]
paragraphs = map unlines . chop . lines where
chop [] = []
chop ss = let (ps,rest) = break empty ss in ps : chop (dropWhile empty rest)
empty = all isSpace
-- printing
indent :: Int -> String -> String
indent i s = replicate i ' ' ++ s
(+++), (++-), (++++), (+++++) :: String -> String -> String
a +++ b = a ++ " " ++ b
a ++- "" = a
a ++- b = a +++ b
a ++++ b = a ++ "\n" ++ b
a +++++ b = a ++ "\n\n" ++ b
prUpper :: String -> String
prUpper s = s1 ++ s2' where
(s1,s2) = span isSpace s
s2' = case s2 of
c:t -> toUpper c : t
_ -> s2
prReplicate :: Int -> String -> String
prReplicate n s = concat (replicate n s)
prTList :: String -> [String] -> String
prTList t ss = case ss of
[] -> ""
[s] -> s
s:ss -> s ++ t ++ prTList t ss
prQuotedString :: String -> String
prQuotedString x = "\"" ++ restoreEscapes x ++ "\""
prParenth :: String -> String
prParenth s = if s == "" then "" else "(" ++ s ++ ")"
prCurly, prBracket :: String -> String
prCurly s = "{" ++ s ++ "}"
prBracket s = "[" ++ s ++ "]"
prArgList, prSemicList, prCurlyList :: [String] -> String
prArgList = prParenth . prTList ","
prSemicList = prTList " ; "
prCurlyList = prCurly . prSemicList
restoreEscapes :: String -> String
restoreEscapes s =
case s of
[] -> []
'"' : t -> '\\' : '"' : restoreEscapes t
'\\': t -> '\\' : '\\' : restoreEscapes t
c : t -> c : restoreEscapes t
numberedParagraphs :: [[String]] -> [String]
numberedParagraphs t = case t of
[] -> []
p:[] -> p
_ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
prConjList :: String -> [String] -> String
prConjList c [] = ""
prConjList c [s] = s
prConjList c [s,t] = s +++ c +++ t
prConjList c (s:tt) = s ++ "," +++ prConjList c tt
prIfEmpty :: String -> String -> String -> String -> String
prIfEmpty em _ _ [] = em
prIfEmpty em nem1 nem2 s = nem1 ++ s ++ nem2
-- | Thomas Hallgren's wrap lines
wrapLines :: Int -> String -> String
wrapLines n "" = ""
wrapLines n s@(c:cs) =
if isSpace c
then c:wrapLines (n+1) cs
else case lex s of
[(w,rest)] -> if n'>=76
then '\n':w++wrapLines l rest
else w++wrapLines n' rest
where n' = n+l
l = length w
_ -> s -- give up!!
--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
-- LaTeX code producing functions
dollar, mbox, ital, boldf, verbat :: String -> String
dollar s = '$' : s ++ "$"
mbox s = "\\mbox{" ++ s ++ "}"
ital s = "{\\em" +++ s ++ "}"
boldf s = "{\\bf" +++ s ++ "}"
verbat s = "\\verbat!" ++ s ++ "!"
mkLatexFile :: String -> String
mkLatexFile s = begindocument +++++ s +++++ enddocument
begindocument, enddocument :: String
begindocument =
"\\documentclass[a4paper,11pt]{article}" ++++ -- M.F. 25/01-02
"\\setlength{\\parskip}{2mm}" ++++
"\\setlength{\\parindent}{0mm}" ++++
"\\setlength{\\oddsidemargin}{0mm}" ++++
("\\setlength{\\evensidemargin}{"++"-2mm}") ++++ -- peb 27/5-04: to prevent hugs-mode
("\\setlength{\\topmargin}{"++"-8mm}") ++++ -- from treating the rest as comments
"\\setlength{\\textheight}{240mm}" ++++
"\\setlength{\\textwidth}{158mm}" ++++
"\\begin{document}\n"
enddocument =
"\n\\end{document}\n"
sortByLongest :: [[a]] -> [[a]]
sortByLongest = sortBy longer where
longer x y
| x' > y' = LT
| x' < y' = GT
| True = EQ
where
x' = length x
y' = length y
-- | 'combinations' is the same as @sequence@!!!
-- peb 30\/5-04
combinations :: [[a]] -> [[a]]
combinations t = case t of
[] -> [[]]
aa:uu -> [a:u | a <- aa, u <- combinations uu]
mkTextFile :: String -> IO ()
mkTextFile name = do
s <- readFile name
let s' = prelude name ++ "\n\n" ++ heading name ++ "\n" ++ object s
writeFile (name ++ ".hs") s'
where
prelude name = "module " ++ name ++ " where"
heading name = "txt" ++ name ++ " ="
object s = mk s ++ " \"\""
mk s = unlines [" \"" ++ escs line ++ "\" ++ \"\\n\" ++" | line <- lines s]
escs s = case s of
c:cs | elem c "\"\\" -> '\\' : c : escs cs
c:cs -> c : escs cs
_ -> s
initFilePath :: FilePath -> FilePath
initFilePath f = reverse (dropWhile (/='/') (reverse f))
-- | topological sorting with test of cyclicity
topoTest :: Eq a => [(a,[a])] -> Either [a] [[a]]
topoTest g = if length g' == length g then Left g' else Right (cyclesIn g ++[[]])
where
g' = topoSort g
cyclesIn :: Eq a => [(a,[a])] -> [[a]]
cyclesIn deps = nubb $ clean $ filt $ iterFix findDep immediate where
immediate = [[y,x] | (x,xs) <- deps, y <- xs]
findDep chains = [y:x:chain |
x:chain <- chains, (x',xs) <- deps, x' == x, y <- xs,
notElem y (init chain)]
clean = map remdup
nubb = nubBy (\x y -> y == reverse x)
filt = filter (\xs -> last xs == head xs)
remdup (x:xs) = x : remdup xs' where xs' = dropWhile (==x) xs
remdup [] = []
-- | topological sorting
topoSort :: Eq a => [(a,[a])] -> [a]
topoSort g = reverse $ tsort 0 [ffs | ffs@(f,_) <- g, inDeg f == 0] [] where
tsort _ [] r = r
tsort k (ffs@(f,fs) : cs) r
| elem f r = tsort k cs r
| k > lx = r
| otherwise = tsort (k+1) cs (f : tsort (k+1) (info fs) r)
info hs = [(f,fs) | (f,fs) <- g, elem f hs]
inDeg f = length [t | (h,hs) <- g, t <- hs, t == f]
lx = length g
-- | the generic fix point iterator
iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
iterFix more start = iter start start
where
iter old new = if (null new')
then old
else iter (new' ++ old) new'
where
new' = filter (`notElem` old) (more new)
-- association lists
updateAssoc :: Eq a => (a,b) -> [(a,b)] -> [(a,b)]
updateAssoc ab@(a,b) as = case as of
(x,y): xs | x == a -> (a,b):xs
xy : xs -> xy : updateAssoc ab xs
[] -> [ab]
removeAssoc :: Eq a => a -> [(a,b)] -> [(a,b)]
removeAssoc a = filter ((/=a) . fst)
-- | chop into separator-separated parts
chunks :: Eq a => a -> [a] -> [[a]]
chunks sep ws = case span (/= sep) ws of
(a,_:b) -> a : bs where bs = chunks sep b
(a, []) -> if null a then [] else [a]
readIntArg :: String -> Int
readIntArg n = if (not (null n) && all isDigit n) then read n else 0
-- state monad with error; from Agda 6/11/2001
newtype STM s a = STM (s -> Err (a,s))
appSTM :: STM s a -> s -> Err (a,s)
appSTM (STM f) s = f s
stm :: (s -> Err (a,s)) -> STM s a
stm = STM
stmr :: (s -> (a,s)) -> STM s a
stmr f = stm (\s -> return (f s))
instance Monad (STM s) where
return a = STM (\s -> return (a,s))
STM c >>= f = STM (\s -> do
(x,s') <- c s
let STM f' = f x
f' s')
readSTM :: STM s s
readSTM = stmr (\s -> (s,s))
updateSTM :: (s -> s) -> STM s ()
updateSTM f = stmr (\s -> ((),f s))
writeSTM :: s -> STM s ()
writeSTM s = stmr (const ((),s))
done :: Monad m => m ()
done = return ()
class Monad m => ErrorMonad m where
raise :: String -> m a
handle :: m a -> (String -> m a) -> m a
handle_ :: m a -> m a -> m a
handle_ a b = a `handle` (\_ -> b)
instance ErrorMonad Err where
raise = Bad
handle a@(Ok _) _ = a
handle (Bad i) f = f i
instance ErrorMonad (STM s) where
raise msg = STM (\s -> raise msg)
handle (STM f) g = STM (\s -> (f s)
`handle` (\e -> let STM g' = (g e) in
g' s))
-- error recovery with multiple reporting AR 30/5/2008
mapsErr :: (a -> Err b) -> [a] -> Err [b]
mapsErr f = seqs . map f where
seqs es = case es of
Ok v : ms -> case seqs ms of
Ok vs -> return (v : vs)
b -> b
Bad s : ms -> case seqs ms of
Ok vs -> Bad s
Bad ss -> Bad (s +++++ ss)
[] -> return []
mapsErrTree :: (Ord a) => ((a,b) -> Err (a,c)) -> BinTree a b -> Err (BinTree a c)
mapsErrTree f t = mapsErr f (tree2list t) >>= return . sorted2tree
-- | if the first check fails try another one
checkAgain :: ErrorMonad m => m a -> m a -> m a
checkAgain c1 c2 = handle_ c1 c2
checks :: ErrorMonad m => [m a] -> m a
checks [] = raise "no chance to pass"
checks cs = foldr1 checkAgain cs
allChecks :: ErrorMonad m => [m a] -> m [a]
allChecks ms = case ms of
(m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs
_ -> return []
doUntil :: ErrorMonad m => (a -> Bool) -> [m a] -> m a
doUntil cond ms = case ms of
a:as -> do
v <- a
if cond v then return v else doUntil cond as
_ -> raise "no result"
-- subsequences sorted from longest to shortest ; their number is 2^n
subSequences :: [a] -> [[a]]
subSequences = sortBy (\x y -> compare (length y) (length x)) . subs where
subs xs = case xs of
[] -> [[]]
x:xs -> let xss = subs xs in [x:y | y <- xss] ++ xss

127
src/GF/Data/SortedList.hs Normal file
View File

@@ -0,0 +1,127 @@
----------------------------------------------------------------------
-- |
-- Maintainer : Peter Ljunglöf
-- Stability : stable
-- Portability : portable
--
-- > CVS $Date: 2005/04/21 16:22:08 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.3 $
--
-- Sets as sorted lists
--
-- * /O(n)/ union, difference and intersection
--
-- * /O(n log n)/ creating a set from a list (=sorting)
--
-- * /O(n^2)/ fixed point iteration
-----------------------------------------------------------------------------
module GF.Data.SortedList
( -- * type declarations
SList, SMap,
-- * set operations
nubsort, union,
(<++>), (<\\>), (<**>),
limit,
hasCommonElements, subset,
-- * map operations
groupPairs, groupUnion,
unionMap, mergeMap
) where
import Data.List (groupBy)
import GF.Data.Utilities (split, foldMerge)
-- | The list must be sorted and contain no duplicates.
type SList a = [a]
-- | A sorted map also has unique keys,
-- i.e. 'map fst m :: SList a', if 'm :: SMap a b'
type SMap a b = SList (a, b)
-- | Group a set of key-value pairs into a sorted map
groupPairs :: Ord a => SList (a, b) -> SMap a (SList b)
groupPairs = map mapFst . groupBy eqFst
where mapFst as = (fst (head as), map snd as)
eqFst a b = fst a == fst b
-- | Group a set of key-(sets-of-values) pairs into a sorted map
groupUnion :: (Ord a, Ord b) => SList (a, SList b) -> SMap a (SList b)
groupUnion = map unionSnd . groupPairs
where unionSnd (a, bs) = (a, union bs)
-- | True is the two sets has common elements
hasCommonElements :: Ord a => SList a -> SList a -> Bool
hasCommonElements as bs = not (null (as <**> bs))
-- | True if the first argument is a subset of the second argument
subset :: Ord a => SList a -> SList a -> Bool
xs `subset` ys = null (xs <\\> ys)
-- | Create a set from any list.
-- This function can also be used as an alternative to @nub@ in @List.hs@
nubsort :: Ord a => [a] -> SList a
nubsort = union . map return
-- | the union of a list of sorted maps
unionMap :: Ord a => (b -> b -> b)
-> [SMap a b] -> SMap a b
unionMap plus = foldMerge (mergeMap plus) []
-- | merging two sorted maps
mergeMap :: Ord a => (b -> b -> b)
-> SMap a b -> SMap a b -> SMap a b
mergeMap plus [] abs = abs
mergeMap plus abs [] = abs
mergeMap plus abs@(ab@(a,bs):abs') cds@(cd@(c,ds):cds')
= case compare a c of
EQ -> (a, plus bs ds) : mergeMap plus abs' cds'
LT -> ab : mergeMap plus abs' cds
GT -> cd : mergeMap plus abs cds'
-- | The union of a list of sets
union :: Ord a => [SList a] -> SList a
union = foldMerge (<++>) []
-- | The union of two sets
(<++>) :: Ord a => SList a -> SList a -> SList a
[] <++> bs = bs
as <++> [] = as
as@(a:as') <++> bs@(b:bs') = case compare a b of
LT -> a : (as' <++> bs)
GT -> b : (as <++> bs')
EQ -> a : (as' <++> bs')
-- | The difference of two sets
(<\\>) :: Ord a => SList a -> SList a -> SList a
[] <\\> bs = []
as <\\> [] = as
as@(a:as') <\\> bs@(b:bs') = case compare a b of
LT -> a : (as' <\\> bs)
GT -> (as <\\> bs')
EQ -> (as' <\\> bs')
-- | The intersection of two sets
(<**>) :: Ord a => SList a -> SList a -> SList a
[] <**> bs = []
as <**> [] = []
as@(a:as') <**> bs@(b:bs') = case compare a b of
LT -> (as' <**> bs)
GT -> (as <**> bs')
EQ -> a : (as' <**> bs')
-- | A fixed point iteration
limit :: Ord a => (a -> SList a) -- ^ The iterator function
-> SList a -- ^ The initial set
-> SList a -- ^ The result of the iteration
limit more start = limit' start start
where limit' chart agenda | null new' = chart
| otherwise = limit' (chart <++> new') new'
where new = union (map more agenda)
new'= new <\\> chart

134
src/GF/Data/Str.hs Normal file
View File

@@ -0,0 +1,134 @@
----------------------------------------------------------------------
-- |
-- Module : Str
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:09 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Data.Str (
Str (..), Tok (..), --- constructors needed in PrGrammar
str2strings, str2allStrings, str, sstr, sstrV,
isZeroTok, prStr, plusStr, glueStr,
strTok,
allItems
) where
import GF.Data.Operations
import Data.List (isPrefixOf, isSuffixOf, intersperse)
-- | abstract token list type. AR 2001, revised and simplified 20\/4\/2003
newtype Str = Str [Tok] deriving (Read, Show, Eq, Ord)
-- | notice that having both pre and post would leave to inconsistent situations:
--
-- > pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"}
--
-- always violates a condition expressed by the one or the other
data Tok =
TK String
| TN Ss [(Ss, [String])] -- ^ variants depending on next string
--- | TP Ss [(Ss, [String])] -- variants depending on previous string
deriving (Eq, Ord, Show, Read)
-- | a variant can itself be a token list, but for simplicity only a list of strings
-- i.e. not itself containing variants
type Ss = [String]
-- matching functions in both ways
matchPrefix :: Ss -> [(Ss,[String])] -> [String] -> Ss
matchPrefix s vs t =
head $ [u |
(u,as) <- vs,
any (\c -> isPrefixOf c (concat (unmarkup t))) as
] ++ [s]
matchSuffix :: String -> Ss -> [(Ss,[String])] -> Ss
matchSuffix t s vs =
head ([u | (u,as) <- vs, any (\c -> isSuffixOf c t) as] ++ [s])
unmarkup :: [String] -> [String]
unmarkup = filter (not . isXMLtag) where
isXMLtag s = case s of
'<':cs@(_:_) -> last cs == '>'
_ -> False
str2strings :: Str -> Ss
str2strings (Str st) = alls st where
alls st = case st of
TK s : ts -> s : alls ts
TN ds vs : ts -> matchPrefix ds vs t ++ t where t = alls ts
---- u :TP ds vs: ts -> [u] ++ matchSuffix u ds vs ++ alls ts
[] -> []
str2allStrings :: Str -> [Ss]
str2allStrings (Str st) = alls st where
alls st = case st of
TK s : ts -> [s : t | t <- alls ts]
TN ds vs : [] -> [ds ++ v | v <- map fst vs]
TN ds vs : ts -> [matchPrefix ds vs t ++ t | t <- alls ts]
[] -> [[]]
sstr :: Str -> String
sstr = unwords . str2strings
-- | to handle a list of variants
sstrV :: [Str] -> String
sstrV ss = case ss of
[] -> "*"
_ -> unwords $ intersperse "/" $ map (unwords . str2strings) ss
str :: String -> Str
str s = if null s then Str [] else Str [itS s]
itS :: String -> Tok
itS s = TK s
isZeroTok :: Str -> Bool
isZeroTok t = case t of
Str [] -> True
Str [TK []] -> True
_ -> False
strTok :: Ss -> [(Ss,[String])] -> Str
strTok ds vs = Str [TN ds vs]
prStr :: Str -> String
prStr = prQuotedString . sstr
plusStr :: Str -> Str -> Str
plusStr (Str ss) (Str tt) = Str (ss ++ tt)
glueStr :: Str -> Str -> Str
glueStr (Str ss) (Str tt) = Str $ case (ss,tt) of
([],_) -> tt
(_,[]) -> ss
_ -> init ss ++ glueIt (last ss) (head tt) ++ tail tt
where
glueIt t u = case (t,u) of
(TK s, TK s') -> return $ TK $ s ++ s'
(TN ds vs, TN es ws) -> return $ TN (glues (matchPrefix ds vs es) es)
[(glues (matchPrefix ds vs w) w,cs) | (w,cs) <- ws]
(TN ds vs, TK s) -> map TK $ glues (matchPrefix ds vs [s]) [s]
(TK s, TN es ws) -> return $ TN (glues [s] es) [(glues [s] w, c) | (w,c) <- ws]
glues :: [[a]] -> [[a]] -> [[a]]
glues ss tt = case (ss,tt) of
([],_) -> tt
(_,[]) -> ss
_ -> init ss ++ [last ss ++ head tt] ++ tail tt
-- | to create the list of all lexical items
allItems :: Str -> [String]
allItems (Str s) = concatMap allOne s where
allOne t = case t of
TK s -> [s]
TN ds vs -> ds ++ concatMap fst vs

190
src/GF/Data/Utilities.hs Normal file
View File

@@ -0,0 +1,190 @@
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/26 18:47:16 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- Basic functions not in the standard libraries
-----------------------------------------------------------------------------
module GF.Data.Utilities where
import Data.Maybe
import Data.List
import Control.Monad (MonadPlus(..),liftM)
-- * functions on lists
sameLength :: [a] -> [a] -> Bool
sameLength [] [] = True
sameLength (_:xs) (_:ys) = sameLength xs ys
sameLength _ _ = False
notLongerThan, longerThan :: Int -> [a] -> Bool
notLongerThan n = null . snd . splitAt n
longerThan n = not . notLongerThan n
lookupList :: Eq a => a -> [(a, b)] -> [b]
lookupList a [] = []
lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
| otherwise = lookupList a ps
split :: [a] -> ([a], [a])
split (x : y : as) = (x:xs, y:ys)
where (xs, ys) = split as
split as = (as, [])
splitBy :: (a -> Bool) -> [a] -> ([a], [a])
splitBy p [] = ([], [])
splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
where (xs, ys) = splitBy p as
foldMerge :: (a -> a -> a) -> a -> [a] -> a
foldMerge merge zero = fm
where fm [] = zero
fm [a] = a
fm abs = let (as, bs) = split abs in fm as `merge` fm bs
select :: [a] -> [(a, [a])]
select [] = []
select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ]
updateNth :: (a -> a) -> Int -> [a] -> [a]
updateNth update 0 (a : as) = update a : as
updateNth update n (a : as) = a : updateNth update (n-1) as
updateNthM :: Monad m => (a -> m a) -> Int -> [a] -> m [a]
updateNthM update 0 (a : as) = liftM (:as) (update a)
updateNthM update n (a : as) = liftM (a:) (updateNthM update (n-1) as)
-- | Like 'init', but returns the empty list when the input is empty.
safeInit :: [a] -> [a]
safeInit [] = []
safeInit xs = init xs
-- | Like 'nub', but more efficient as it uses sorting internally.
sortNub :: Ord a => [a] -> [a]
sortNub = map head . group . sort
-- | Like 'nubBy', but more efficient as it uses sorting internally.
sortNubBy :: (a -> a -> Ordering) -> [a] -> [a]
sortNubBy f = map head . sortGroupBy f
-- | Sorts and then groups elements given and ordering of the
-- elements.
sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]]
sortGroupBy f = groupBy (compareEq f) . sortBy f
-- | Take the union of a list of lists.
unionAll :: Eq a => [[a]] -> [a]
unionAll = nub . concat
-- | Like 'lookup', but fails if the argument is not found,
-- instead of returning Nothing.
lookup' :: (Show a, Eq a) => a -> [(a,b)] -> b
lookup' x = fromMaybe (error $ "Not found: " ++ show x) . lookup x
-- | Like 'find', but fails if nothing is found.
find' :: (a -> Bool) -> [a] -> a
find' p = fromJust . find p
-- | Set a value in a lookup table.
tableSet :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
tableSet x y [] = [(x,y)]
tableSet x y (p@(x',_):xs) | x' == x = (x,y):xs
| otherwise = p:tableSet x y xs
-- | Group tuples by their first elements.
buildMultiMap :: Ord a => [(a,b)] -> [(a,[b])]
buildMultiMap = map (\g -> (fst (head g), map snd g) )
. sortGroupBy (compareBy fst)
-- | Replace all occurences of an element by another element.
replace :: Eq a => a -> a -> [a] -> [a]
replace x y = map (\z -> if z == x then y else z)
-- * equality functions
-- | Use an ordering function as an equality predicate.
compareEq :: (a -> a -> Ordering) -> a -> a -> Bool
compareEq f x y = case f x y of
EQ -> True
_ -> False
-- * ordering functions
compareBy :: Ord b => (a -> b) -> a -> a -> Ordering
compareBy f = both f compare
both :: (a -> b) -> (b -> b -> c) -> a -> a -> c
both f g x y = g (f x) (f y)
-- * functions on pairs
mapFst :: (a -> a') -> (a, b) -> (a', b)
mapFst f (a, b) = (f a, b)
mapSnd :: (b -> b') -> (a, b) -> (a, b')
mapSnd f (a, b) = (a, f b)
-- * functions on monads
-- | Return the given value if the boolean is true, els return 'mzero'.
whenMP :: MonadPlus m => Bool -> a -> m a
whenMP b x = if b then return x else mzero
-- * functions on Maybes
-- | Returns true if the argument is Nothing or Just []
nothingOrNull :: Maybe [a] -> Bool
nothingOrNull = maybe True null
-- * functions on functions
-- | Apply all the functions in the list to the argument.
foldFuns :: [a -> a] -> a -> a
foldFuns fs x = foldl (flip ($)) x fs
-- | Fixpoint iteration.
fix :: Eq a => (a -> a) -> a -> a
fix f x = let x' = f x in if x' == x then x else fix f x'
-- * functions on strings
-- | Join a number of lists by using the given glue
-- between the lists.
join :: [a] -- ^ glue
-> [[a]] -- ^ lists to join
-> [a]
join g = concat . intersperse g
-- * ShowS-functions
nl :: ShowS
nl = showChar '\n'
sp :: ShowS
sp = showChar ' '
wrap :: String -> ShowS -> String -> ShowS
wrap o s c = showString o . s . showString c
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id
unwordsS :: [ShowS] -> ShowS
unwordsS = joinS " "
unlinesS :: [ShowS] -> ShowS
unlinesS = joinS "\n"
joinS :: String -> [ShowS] -> ShowS
joinS glue = concatS . intersperse (showString glue)

53
src/GF/Data/XML.hs Normal file
View File

@@ -0,0 +1,53 @@
----------------------------------------------------------------------
-- |
-- Module : XML
--
-- Utilities for creating XML documents.
----------------------------------------------------------------------
module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where
import GF.Data.Utilities
data XML = Data String | CData String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty
deriving (Ord,Eq,Show)
type Attr = (String,String)
comments :: [String] -> [XML]
comments = map Comment
showXMLDoc :: XML -> String
showXMLDoc xml = showsXMLDoc xml ""
showsXMLDoc :: XML -> ShowS
showsXMLDoc xml = showString header . showsXML xml
where header = "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
showsXML :: XML -> ShowS
showsXML (Data s) = showString s
showsXML (CData s) = showString "<![CDATA[" . showString s .showString "]]>"
showsXML (ETag t as) = showChar '<' . showString t . showsAttrs as . showString "/>"
showsXML (Tag t as cs) =
showChar '<' . showString t . showsAttrs as . showChar '>'
. concatS (map showsXML cs) . showString "</" . showString t . showChar '>'
showsXML (Comment c) = showString "<!-- " . showString c . showString " -->"
showsXML (Empty) = id
showsAttrs :: [Attr] -> ShowS
showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
showsAttr :: Attr -> ShowS
showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\""
escape :: String -> String
escape = concatMap escChar
where
escChar '<' = "&lt;"
escChar '>' = "&gt;"
escChar '&' = "&amp;"
escChar '"' = "&quot;"
escChar c = [c]
bottomUpXML :: (XML -> XML) -> XML -> XML
bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs))
bottomUpXML f x = f x

257
src/GF/Data/Zipper.hs Normal file
View File

@@ -0,0 +1,257 @@
----------------------------------------------------------------------
-- |
-- Module : Zipper
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/06/11 20:27:05 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.9 $
--
-- Gérard Huet's zipper (JFP 7 (1997)). AR 10\/8\/2001
-----------------------------------------------------------------------------
module GF.Data.Zipper (-- * types
Tr(..),
Path(..),
Loc(..),
-- * basic (original) functions
leaf,
goLeft, goRight, goUp, goDown,
changeLoc,
changeNode,
forgetNode,
-- * added sequential representation
goAhead,
goBack,
-- ** n-ary versions
goAheadN,
goBackN,
-- * added mappings between locations and trees
loc2tree,
loc2treeMarked,
tree2loc,
goRoot,
goLast,
goPosition,
getPosition,
keepPosition,
-- * added some utilities
traverseCollect,
scanTree,
mapTr,
mapTrM,
mapPath,
mapPathM,
mapLoc,
mapLocM,
foldTr,
foldTrM,
mapSubtrees,
mapSubtreesM,
changeRoot,
nthSubtree,
arityTree
) where
import GF.Data.Operations
newtype Tr a = Tr (a,[Tr a]) deriving (Show,Eq)
data Path a =
Top
| Node ([Tr a], (Path a, a), [Tr a])
deriving Show
leaf :: a -> Tr a
leaf a = Tr (a,[])
newtype Loc a = Loc (Tr a, Path a) deriving Show
goLeft, goRight, goUp, goDown :: Loc a -> Err (Loc a)
goLeft (Loc (t,p)) = case p of
Top -> Bad "left of top"
Node (l:left, upv, right) -> return $ Loc (l, Node (left,upv,t:right))
Node _ -> Bad "left of first"
goRight (Loc (t,p)) = case p of
Top -> Bad "right of top"
Node (left, upv, r:right) -> return $ Loc (r, Node (t:left,upv,right))
Node _ -> Bad "right of first"
goUp (Loc (t,p)) = case p of
Top -> Bad "up of top"
Node (left, (up,v), right) ->
return $ Loc (Tr (v, reverse left ++ (t:right)), up)
goDown (Loc (t,p)) = case t of
Tr (v,(t1:trees)) -> return $ Loc (t1,Node ([],(p,v),trees))
_ -> Bad "down of empty"
changeLoc :: Loc a -> Tr a -> Err (Loc a)
changeLoc (Loc (_,p)) t = return $ Loc (t,p)
changeNode :: (a -> a) -> Loc a -> Loc a
changeNode f (Loc (Tr (n,ts),p)) = Loc (Tr (f n, ts),p)
forgetNode :: Loc a -> Err (Loc a)
forgetNode (Loc (Tr (n,[t]),p)) = return $ Loc (t,p)
forgetNode _ = Bad $ "not a one-branch tree"
-- added sequential representation
-- | a successor function
goAhead :: Loc a -> Err (Loc a)
goAhead s@(Loc (t,p)) = case (t,p) of
(Tr (_,_:_),Node (_,_,_:_)) -> goDown s
(Tr (_,[]), _) -> upsRight s
(_, _) -> goDown s
where
upsRight t = case goRight t of
Ok t' -> return t'
Bad _ -> goUp t >>= upsRight
-- | a predecessor function
goBack :: Loc a -> Err (Loc a)
goBack s@(Loc (t,p)) = case goLeft s of
Ok s' -> downRight s'
_ -> goUp s
where
downRight s = case goDown s of
Ok s' -> case goRight s' of
Ok s'' -> downRight s''
_ -> downRight s'
_ -> return s
-- n-ary versions
goAheadN :: Int -> Loc a -> Err (Loc a)
goAheadN i st
| i < 1 = return st
| otherwise = goAhead st >>= goAheadN (i-1)
goBackN :: Int -> Loc a -> Err (Loc a)
goBackN i st
| i < 1 = return st
| otherwise = goBack st >>= goBackN (i-1)
-- added mappings between locations and trees
loc2tree :: Loc a -> Tr a
loc2tree (Loc (t,p)) = case p of
Top -> t
Node (left,(p',v),right) ->
loc2tree (Loc (Tr (v, reverse left ++ (t : right)),p'))
loc2treeMarked :: Loc a -> Tr (a, Bool)
loc2treeMarked (Loc (Tr (a,ts),p)) =
loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p))
where
(mark, nomark) = (\a -> (a,True), \a -> (a, False))
tree2loc :: Tr a -> Loc a
tree2loc t = Loc (t,Top)
goRoot :: Loc a -> Loc a
goRoot = tree2loc . loc2tree
goLast :: Loc a -> Err (Loc a)
goLast = rep goAhead where
rep f s = err (const (return s)) (rep f) (f s)
goPosition :: [Int] -> Loc a -> Err (Loc a)
goPosition p = go p . goRoot where
go [] s = return s
go (p:ps) s = goDown s >>= apply p goRight >>= go ps
getPosition :: Loc a -> [Int]
getPosition = reverse . getp where
getp (Loc (t,p)) = case p of
Top -> []
Node (left,(p',v),_) -> length left : getp (Loc (Tr (v, []),p'))
keepPosition :: (Loc a -> Err (Loc a)) -> (Loc a -> Err (Loc a))
keepPosition f s = do
let p = getPosition s
s' <- f s
goPosition p s'
apply :: Monad m => Int -> (a -> m a) -> a -> m a
apply n f a = case n of
0 -> return a
_ -> f a >>= apply (n-1) f
-- added some utilities
traverseCollect :: Path a -> [a]
traverseCollect p = reverse $ case p of
Top -> []
Node (_, (p',v), _) -> v : traverseCollect p'
scanTree :: Tr a -> [a]
scanTree (Tr (a,ts)) = a : concatMap scanTree ts
mapTr :: (a -> b) -> Tr a -> Tr b
mapTr f (Tr (x,ts)) = Tr (f x, map (mapTr f) ts)
mapTrM :: Monad m => (a -> m b) -> Tr a -> m (Tr b)
mapTrM f (Tr (x,ts)) = do
fx <- f x
fts <- mapM (mapTrM f) ts
return $ Tr (fx,fts)
mapPath :: (a -> b) -> Path a -> Path b
mapPath f p = case p of
Node (ts1, (p,v), ts2) ->
Node (map (mapTr f) ts1, (mapPath f p, f v), map (mapTr f) ts2)
Top -> Top
mapPathM :: Monad m => (a -> m b) -> Path a -> m (Path b)
mapPathM f p = case p of
Node (ts1, (p,v), ts2) -> do
ts1' <- mapM (mapTrM f) ts1
p' <- mapPathM f p
v' <- f v
ts2' <- mapM (mapTrM f) ts2
return $ Node (ts1', (p',v'), ts2')
Top -> return Top
mapLoc :: (a -> b) -> Loc a -> Loc b
mapLoc f (Loc (t,p)) = Loc (mapTr f t, mapPath f p)
mapLocM :: Monad m => (a -> m b) -> Loc a -> m (Loc b)
mapLocM f (Loc (t,p)) = do
t' <- mapTrM f t
p' <- mapPathM f p
return $ (Loc (t',p'))
foldTr :: (a -> [b] -> b) -> Tr a -> b
foldTr f (Tr (x,ts)) = f x (map (foldTr f) ts)
foldTrM :: Monad m => (a -> [b] -> m b) -> Tr a -> m b
foldTrM f (Tr (x,ts)) = do
fts <- mapM (foldTrM f) ts
f x fts
mapSubtrees :: (Tr a -> Tr a) -> Tr a -> Tr a
mapSubtrees f t = let Tr (x,ts) = f t in Tr (x, map (mapSubtrees f) ts)
mapSubtreesM :: Monad m => (Tr a -> m (Tr a)) -> Tr a -> m (Tr a)
mapSubtreesM f t = do
Tr (x,ts) <- f t
ts' <- mapM (mapSubtreesM f) ts
return $ Tr (x, ts')
-- | change the root without moving the pointer
changeRoot :: (a -> a) -> Loc a -> Loc a
changeRoot f loc = case loc of
Loc (Tr (a,ts),Top) -> Loc (Tr (f a,ts),Top)
Loc (t, Node (left,pv,right)) -> Loc (t, Node (left,chPath pv,right))
where
chPath pv = case pv of
(Top,a) -> (Top, f a)
(Node (left,pv,right),v) -> (Node (left, chPath pv,right),v)
nthSubtree :: Int -> Tr a -> Err (Tr a)
nthSubtree n (Tr (a,ts)) = ts !? n
arityTree :: Tr a -> Int
arityTree (Tr (_,ts)) = length ts

49
src/GF/Devel/README-testgf3 Normal file
View File

@@ -0,0 +1,49 @@
GF3, the next version of GF
Aarne Ranta
Version 1: 20/2/2008
To compile:
make testgf3
To run:
testgf3 <options>
Options:
-src -- read from source
-doemit -- emit gfn files
More options (debugging flags):
-show_gf -- show compiled source module after parsing
-show_extend -- ... after extension
-show_rename -- ... after renaming
-show_typecheck -- ... after type checking
-show_refreshing -- ... after refreshing variables
-show_optimize -- ... after partial evaluation
-show_factorize -- ... after factoring optimization
-show_all -- show all phases
-1 -- stop after parsing
-2 -- ... extending
-3 -- ... renaming
-4 -- ... type checking
-5 -- ... refreshing
==Compiler Phases==
LexGF
ParGF
SourceToGF
Extend
Rename
CheckGrammar
Refresh
Optimize
Factorize
GFtoGFCC

66
src/GF/Devel/gf-code.txt Normal file
View File

@@ -0,0 +1,66 @@
Guide to GF Implementation Code
Aarne Ranta
This document describes the code in GF grammar compiler and interactive
environment. It is aimed to cover well the implementation of the forthcoming
GF3. In comparison to GF 2.8, this implementation uses
- the same source language, GF (only slightly modified)
- a different run-time target language, GFCC (instead of GFCM)
- a different separate compilation target language (a fragment GF itself,
instead of GFC)
- a different internal representation of source code
Apart from GFCC, the goal of GF3 is simplification and consolidation, rather
than innovation. This is shown in particular in the abolition of GFC, and in
the streamlined internal source code format. The insight needed to achieve
these simplifications would not have been possible (at least for us) without
years of experimenting with the more messy formats; those formats moreover
grew organically when features were added to the GF language, and the old
implementation was thus a result of evolution rather than careful planning.
GF3 is planned to be released in an Alpha version in the end of 2007, its
sources forming a part of GF release 2.9.
There are currently two versions of GF3, as regards executables and ``make``
items:
- ``gf3``, using the old internal representation of source language, and
integrating a compiler from GF to GFCC and an interpreter of GFCC
- ``testgf3``, using the new formats everywhere but implementing the compiler
only; this program does not yet yield reasonable output
The descriptions below will target the newest ideas, that is, ``textgf3``
whenever it differs from ``gf3``.
==The structure of the code==
Code that is not shared with GF 2.8 is located in subdirectories of
``GF/Devel/``. Those subdirectories will, however, be moved one level
up. Currently they include
- ``GF/Devel/Grammar``: the datatypes and basic operations of source code
- ``GF/Devel/Compile``: the phases of compiling GF to GFCC
The other directories involved are
- ``GF/GFCC``: data types and functionalities of GFCC
- ``GF/Infra``: infrastructure utilities for the implementation
- ``GF/Data``: datastructures belonging to infrastructure
==The source code implementation==
==The compiler==
==The GFCC interpreter==
==The GF command interpreter==

84
src/GF/Devel/gf3.txt Normal file
View File

@@ -0,0 +1,84 @@
GF Version 3.0
Aarne Ranta
7 November 2007
This document summarizes the goals and status of the forthcoming
GF version 3.0.
==Overview==
GF 3 results from the following needs:
- refactor GF to make it more maintainable
- provide a simple command-line batch compiler
- replace gfc by the much simpler gfcc format for embedded grammars
The current implementation of GF 3 has three binaries:
- gfc, batch compiler, for building grammar applications
- gfi, interpreter for gfcc grammars, for using grammars
- gf, interactive compiler with interpreter, for developing grammars
Thus, roughly, gf = gfc + gfi.
Question: should we have, like current GF, just one binary, gf, and
implement the others by shell scripts calling gf with suitable options?
- +: one binary is less code altogether
- +: one binary is easier to distribute and update
- -: each of the components is less code by itself
- -: many users might only need either the compiler or the interpreter
- -: those users could avoid installation problems such as readline
There are some analogies in other languages:
|| GF | Haskell | Java ||
| gfc | ghc | javac |
| gfi | ghci* | java |
| gf | ghci* | - |
In Haskell, ghci makes more than gfi since it reads source files, but
less than gf since it does not compile them to externally usable target
code.
==Status of code and functionalities==
GF executable v. 2.8
- gf: 263 modules, executable 7+ MB (on MacOS i386)
Current status of GF 3.0 alpha:
- gf3: 94 modules, executable 4+ MB
- gfc: 71 modules, executable 3+ MB
- gfi: 35 modules, executable 1+ MB
Missing functionalities
- in gfc:
- input formats: cf, ebnf, gfe, old gf
- output formats: speech grammars, bnfc
- integrating options for input, output, and debugging information
(as described in Devel/GFC/Options.hs)
- in gfi:
- command cc (computing with resource)
- morphological analysis, linearization with tables
- quizzes, treebanks
- syntax editor
- readline
==Additional feature options==
Native Haskell readline
Binary formats for gfo and gfcc
Parallel compilation on multicore machines

75
src/GF/Grammar/API.hs Normal file
View File

@@ -0,0 +1,75 @@
module GF.Grammar.API (
Grammar,
emptyGrammar,
pTerm,
prTerm,
checkTerm,
computeTerm,
showTerm,
TermPrintStyle(..),
pTermPrintStyle
) where
import GF.Source.ParGF
import GF.Source.SourceToGrammar (transExp)
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Modules (greatestResource)
import GF.Compile.GetGrammar
import GF.Grammar.Macros
import GF.Grammar.PrGrammar
import GF.Compile.Rename (renameSourceTerm)
import GF.Compile.CheckGrammar (justCheckLTerm)
import GF.Compile.Compute (computeConcrete)
import GF.Data.Operations
import GF.Infra.Option
import qualified Data.ByteString.Char8 as BS
type Grammar = SourceGrammar
emptyGrammar :: Grammar
emptyGrammar = emptySourceGrammar
pTerm :: String -> Err Term
pTerm s = do
e <- pExp $ myLexer (BS.pack s)
transExp e
prTerm :: Term -> String
prTerm = prt
checkTerm :: Grammar -> Term -> Err Term
checkTerm gr t = do
mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr
checkTermAny gr mo t
checkTermAny :: Grammar -> Ident -> Term -> Err Term
checkTermAny gr m t = do
t1 <- renameSourceTerm gr m t
justCheckLTerm gr t1
computeTerm :: Grammar -> Term -> Err Term
computeTerm = computeConcrete
showTerm :: TermPrintStyle -> Term -> String
showTerm style t =
case style of
TermPrintTable -> unlines [p +++ s | (p,s) <- prTermTabular t]
TermPrintAll -> unlines [ s | (p,s) <- prTermTabular t]
TermPrintUnqual -> prt_ t
TermPrintDefault -> prt t
data TermPrintStyle = TermPrintTable | TermPrintAll | TermPrintUnqual | TermPrintDefault
deriving (Show,Eq)
pTermPrintStyle s = case s of
"table" -> TermPrintTable
"all" -> TermPrintAll
"unqual" -> TermPrintUnqual
_ -> TermPrintDefault

38
src/GF/Grammar/Abstract.hs Normal file
View File

@@ -0,0 +1,38 @@
----------------------------------------------------------------------
-- |
-- Module : Abstract
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:18 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.4 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Grammar.Abstract (
module GF.Grammar.Grammar,
module GF.Grammar.Values,
module GF.Grammar.Macros,
module GF.Infra.Ident,
module GF.Grammar.MMacros,
module GF.Grammar.PrGrammar,
Grammar
) where
import GF.Grammar.Grammar
import GF.Grammar.Values
import GF.Grammar.Macros
import GF.Infra.Ident
import GF.Grammar.MMacros
import GF.Grammar.PrGrammar
type Grammar = SourceGrammar ---

158
src/GF/Grammar/AppPredefined.hs Normal file
View File

@@ -0,0 +1,158 @@
----------------------------------------------------------------------
-- |
-- Module : AppPredefined
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/06 14:21:34 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.13 $
--
-- Predefined function type signatures and definitions.
-----------------------------------------------------------------------------
module GF.Grammar.AppPredefined (isInPredefined, typPredefined, appPredefined
) where
import GF.Infra.Ident
import GF.Data.Operations
import GF.Grammar.Predef
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Grammar.PrGrammar (prt,prt_,prtBad)
import qualified Data.ByteString.Char8 as BS
-- predefined function type signatures and definitions. AR 12/3/2003.
isInPredefined :: Ident -> Bool
isInPredefined = err (const True) (const False) . typPredefined
typPredefined :: Ident -> Err Type
typPredefined f
| f == cInt = return typePType
| f == cFloat = return typePType
| f == cErrorType = return typeType
| f == cInts = return $ mkFunType [typeInt] typePType
| f == cPBool = return typePType
| f == cError = return $ mkFunType [typeStr] typeError -- non-can. of empty set
| f == cPFalse = return $ typePBool
| f == cPTrue = return $ typePBool
| f == cDp = return $ mkFunType [typeInt,typeTok] typeTok
| f == cDrop = return $ mkFunType [typeInt,typeTok] typeTok
| f == cEqInt = return $ mkFunType [typeInt,typeInt] typePBool
| f == cLessInt = return $ mkFunType [typeInt,typeInt] typePBool
| f == cEqStr = return $ mkFunType [typeTok,typeTok] typePBool
| f == cLength = return $ mkFunType [typeTok] typeInt
| f == cOccur = return $ mkFunType [typeTok,typeTok] typePBool
| f == cOccurs = return $ mkFunType [typeTok,typeTok] typePBool
| f == cPlus = return $ mkFunType [typeInt,typeInt] (typeInt)
---- "read" -> (P : Type) -> Tok -> P
| f == cShow = return $ mkProd -- (P : PType) -> P -> Tok
([(varP,typePType),(identW,Vr varP)],typeStr,[])
| f == cToStr = return $ mkProd -- (L : Type) -> L -> Str
([(varL,typeType),(identW,Vr varL)],typeStr,[])
| f == cMapStr = return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L
([(varL,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr varL)],Vr varL,[])
| f == cTake = return $ mkFunType [typeInt,typeTok] typeTok
| f == cTk = return $ mkFunType [typeInt,typeTok] typeTok
| otherwise = prtBad "unknown in Predef:" f
varL :: Ident
varL = identC (BS.pack "L")
varP :: Ident
varP = identC (BS.pack "P")
appPredefined :: Term -> Err (Term,Bool)
appPredefined t = case t of
App f x0 -> do
(x,_) <- appPredefined x0
case f of
-- one-place functions
Q mod f | mod == cPredef ->
case x of
(K s) | f == cLength -> retb $ EInt $ toInteger $ length s
_ -> retb t
-- two-place functions
App (Q mod f) z0 | mod == cPredef -> do
(z,_) <- appPredefined z0
case (norm z, norm x) of
(EInt i, K s) | f == cDrop -> retb $ K (drop (fi i) s)
(EInt i, K s) | f == cTake -> retb $ K (take (fi i) s)
(EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - fi i)) s)
(EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - fi i)) s)
(K s, K t) | f == cEqStr -> retb $ if s == t then predefTrue else predefFalse
(K s, K t) | f == cOccur -> retb $ if substring s t then predefTrue else predefFalse
(K s, K t) | f == cOccurs -> retb $ if any (flip elem t) s then predefTrue else predefFalse
(EInt i, EInt j) | f == cEqInt -> retb $ if i==j then predefTrue else predefFalse
(EInt i, EInt j) | f == cLessInt -> retb $ if i<j then predefTrue else predefFalse
(EInt i, EInt j) | f == cPlus -> retb $ EInt $ i+j
(_, t) | f == cShow -> retb $ foldr C Empty $ map K $ words $ prt t
(_, K s) | f == cRead -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags
(_, t) | f == cToStr -> trm2str t >>= retb
_ -> retb t ---- prtBad "cannot compute predefined" t
-- three-place functions
App (App (Q mod f) z0) y0 | mod == cPredef -> do
(y,_) <- appPredefined y0
(z,_) <- appPredefined z0
case (z, y, x) of
(ty,op,t) | f == cMapStr -> retf $ mapStr ty op t
_ -> retb t ---- prtBad "cannot compute predefined" t
_ -> retb t ---- prtBad "cannot compute predefined" t
_ -> retb t
---- should really check the absence of arg variables
where
retb t = return (retc t,True) -- no further computing needed
retf t = return (retc t,False) -- must be computed further
retc t = case t of
K [] -> t
K s -> foldr1 C (map K (words s))
_ -> t
norm t = case t of
Empty -> K []
C u v -> case (norm u,norm v) of
(K x,K y) -> K (x +++ y)
_ -> t
_ -> t
fi = fromInteger
-- read makes variables into constants
predefTrue = Q cPredef cPTrue
predefFalse = Q cPredef cPFalse
substring :: String -> String -> Bool
substring s t = case (s,t) of
(c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds
([],_) -> True
_ -> False
trm2str :: Term -> Err Term
trm2str t = case t of
R ((_,(_,s)):_) -> trm2str s
T _ ((_,s):_) -> trm2str s
TSh _ ((_,s):_) -> trm2str s
V _ (s:_) -> trm2str s
C _ _ -> return $ t
K _ -> return $ t
S c _ -> trm2str c
Empty -> return $ t
_ -> prtBad "cannot get Str from term" t
-- simultaneous recursion on type and term: type arg is essential!
-- But simplify the task by assuming records are type-annotated
-- (this has been done in type checking)
mapStr :: Type -> Term -> Term -> Term
mapStr ty f t = case (ty,t) of
_ | elem ty [typeStr,typeTok] -> App f t
(_, R ts) -> R [(l,mapField v) | (l,v) <- ts]
(Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs]
_ -> t
where
mapField (mty,te) = case mty of
Just ty -> (mty,mapStr ty f te)
_ -> (mty,te)

264
src/GF/Grammar/Grammar.hs Normal file
View File

@@ -0,0 +1,264 @@
----------------------------------------------------------------------
-- |
-- Module : Grammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:20 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
-- GF source abstract syntax used internally in compilation.
--
-- AR 23\/1\/2000 -- 30\/5\/2001 -- 4\/5\/2003
-----------------------------------------------------------------------------
module GF.Grammar.Grammar (SourceGrammar,
emptySourceGrammar,
SourceModInfo,
SourceModule,
SourceAbs,
SourceRes,
SourceCnc,
Info(..),
PValues,
Perh,
MPr,
Type,
Cat,
Fun,
QIdent,
Term(..),
Patt(..),
TInfo(..),
Label(..),
MetaSymb(..),
Decl,
Context,
Equation,
Labelling,
Assign,
Case,
Cases,
LocalDef,
Param,
Altern,
Substitution,
Branch(..),
Con,
Trm,
wildPatt,
varLabel, tupleLabel, linLabel, theLinLabel,
ident2label, label2ident
) where
import GF.Data.Str
import GF.Infra.Ident
import GF.Infra.Option ---
import GF.Infra.Modules
import GF.Data.Operations
import qualified Data.ByteString.Char8 as BS
-- | grammar as presented to the compiler
type SourceGrammar = MGrammar Ident Info
emptySourceGrammar = MGrammar []
type SourceModInfo = ModInfo Ident Info
type SourceModule = (Ident, SourceModInfo)
type SourceAbs = Module Ident Info
type SourceRes = Module Ident Info
type SourceCnc = Module Ident Info
-- this is created in CheckGrammar, and so are Val and PVal
type PValues = [Term]
-- | the constructors are judgements in
--
-- - abstract syntax (/ABS/)
--
-- - resource (/RES/)
--
-- - concrete syntax (/CNC/)
--
-- and indirection to module (/INDIR/)
data Info =
-- judgements in abstract syntax
AbsCat (Perh Context) (Perh [Term]) -- ^ (/ABS/) constructors; must be 'Id' or 'QId'
| AbsFun (Perh Type) (Perh Term) -- ^ (/ABS/) 'Yes f' = canonical
| AbsTrans Term -- ^ (/ABS/)
-- judgements in resource
| ResParam (Perh ([Param],Maybe PValues)) -- ^ (/RES/)
| ResValue (Perh (Type,Maybe Int)) -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Perh Type) (Perh Term) -- ^ (/RES/)
| ResOverload [Ident] [(Type,Term)] -- ^ (/RES/) idents: modules inherited
-- judgements in concrete syntax
| CncCat (Perh Type) (Perh Term) MPr -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe (Ident,(Context,Type))) (Perh Term) MPr -- (/CNC/) type info added at 'TC'
-- indirection to module Ident
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
deriving (Read, Show)
-- | to express indirection to other module
type Perh a = Perhaps a Ident
-- | printname
type MPr = Perhaps Term Ident
type Type = Term
type Cat = QIdent
type Fun = QIdent
type QIdent = (Ident,Ident)
data Term =
Vr Ident -- ^ variable
| Cn Ident -- ^ constant
| Con Ident -- ^ constructor
| EData -- ^ to mark in definition that a fun is a constructor
| Sort Ident -- ^ basic type
| EInt Integer -- ^ integer literal
| EFloat Double -- ^ floating point literal
| K String -- ^ string literal or token: @\"foo\"@
| Empty -- ^ the empty string @[]@
| App Term Term -- ^ application: @f a@
| Abs Ident Term -- ^ abstraction: @\x -> b@
| Meta MetaSymb -- ^ metavariable: @?i@ (only parsable: ? = ?0)
| Prod Ident Term Term -- ^ function type: @(x : A) -> B@
| Eqs [Equation] -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@
-- only used in internal representation
| Typed Term Term -- ^ type-annotated term
--
-- /below this, the constructors are only for concrete syntax/
| Example Term String -- ^ example-based term: @in M.C "foo"
| RecType [Labelling] -- ^ record type: @{ p : A ; ...}@
| R [Assign] -- ^ record: @{ p = a ; ...}@
| P Term Label -- ^ projection: @r.p@
| PI Term Label Int -- ^ index-annotated projection
| ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms)
| Table Term Term -- ^ table type: @P => A@
| T TInfo [Case] -- ^ table: @table {p => c ; ...}@
| TSh TInfo [Cases] -- ^ table with disjunctive patters (only back end opt)
| V Type [Term] -- ^ table given as course of values: @table T [c1 ; ... ; cn]@
| S Term Term -- ^ selection: @t ! p@
| Val Type Int -- ^ parameter value number: @T # i#
| Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@
| Alias Ident Type Term -- ^ constant and its definition, used in inlining
| Q Ident Ident -- ^ qualified constant from a package
| QC Ident Ident -- ^ qualified constructor from a package
| C Term Term -- ^ concatenation: @s ++ t@
| Glue Term Term -- ^ agglutination: @s + t@
| EPatt Patt -- ^ pattern (in macro definition): # p
| EPattType Term -- ^ pattern type: pattern T
| FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@
| Alts (Term, [(Term, Term)]) -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
| Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@
--
-- /below this, the last three constructors are obsolete/
| LiT Ident -- ^ linearization type
| Ready Str -- ^ result of compiling; not to be parsed ...
| Computed Term -- ^ result of computing: not to be reopened nor parsed
deriving (Read, Show, Eq, Ord)
data Patt =
PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@
| PP Ident Ident [Patt] -- ^ package constructor pattern: @P.C p1 ... pn@ @P.C@
| PV Ident -- ^ variable pattern: @x@
| PW -- ^ wild card pattern: @_@
| PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete
| PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract
| PInt Integer -- ^ integer literal pattern: @12@ -- only abstract
| PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract
| PT Type Patt -- ^ type-annotated pattern
| PVal Type Int -- ^ parameter value number: @T # i#
| PAs Ident Patt -- ^ as-pattern: x@p
-- regular expression patterns
| PNeg Patt -- ^ negated pattern: -p
| PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2
| PSeq Patt Patt -- ^ sequence of token parts: p + q
| PRep Patt -- ^ repetition of token part: p*
| PChar -- ^ string of length one: ?
| PChars [Char] -- ^ character list: ["aeiou"]
| PMacro Ident -- #p
| PM Ident Ident -- #m.p
deriving (Read, Show, Eq, Ord)
-- | to guide computation and type checking of tables
data TInfo =
TRaw -- ^ received from parser; can be anything
| TTyped Type -- ^ type annontated, but can be anything
| TComp Type -- ^ expanded
| TWild Type -- ^ just one wild card pattern, no need to expand
deriving (Read, Show, Eq, Ord)
-- | record label
data Label =
LIdent BS.ByteString
| LVar Int
deriving (Read, Show, Eq, Ord)
newtype MetaSymb = MetaSymb Int deriving (Read, Show, Eq, Ord)
type Decl = (Ident,Term) -- (x:A) (_:A) A
type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A)
type Equation = ([Patt],Term)
type Labelling = (Label, Term)
type Assign = (Label, (Maybe Type, Term))
type Case = (Patt, Term)
type Cases = ([Patt], Term)
type LocalDef = (Ident, (Maybe Type, Term))
type Param = (Ident, Context)
type Altern = (Term, [(Term, Term)])
type Substitution = [(Ident, Term)]
-- | branches à la Alfa
newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read)
type Con = Ident ---
varLabel :: Int -> Label
varLabel = LVar
tupleLabel, linLabel :: Int -> Label
tupleLabel i = LIdent $! BS.pack ('p':show i)
linLabel i = LIdent $! BS.pack ('s':show i)
theLinLabel :: Label
theLinLabel = LIdent (BS.singleton 's')
ident2label :: Ident -> Label
ident2label c = LIdent (ident2bs c)
label2ident :: Label -> Ident
label2ident (LIdent s) = identC s
label2ident (LVar i) = identC (BS.pack ('$':show i))
wildPatt :: Patt
wildPatt = PV identW
type Trm = Term

51
src/GF/Grammar/Lockfield.hs Normal file
View File

@@ -0,0 +1,51 @@
----------------------------------------------------------------------
-- |
-- Module : Lockfield
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 23:24:34 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.7 $
--
-- Creating and using lock fields in reused resource grammars.
--
-- AR 8\/2\/2005 detached from 'compile/MkResource'
-----------------------------------------------------------------------------
module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
import qualified Data.ByteString.Char8 as BS
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Grammar.PrGrammar
import GF.Data.Operations
lockRecType :: Ident -> Type -> Err Type
lockRecType c t@(RecType rs) =
let lab = lockLabel c in
return $ if elem lab (map fst rs) || elem (prt c) ["String","Int"]
then t --- don't add an extra copy of lock field, nor predef cats
else RecType (rs ++ [(lockLabel c, RecType [])])
lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])]
unlockRecord :: Ident -> Term -> Err Term
unlockRecord c ft = do
let (xs,t) = termFormCnc ft
t' <- plusRecord t $ R [(lockLabel c, (Just (RecType []),R []))]
return $ mkAbs xs t'
lockLabel :: Ident -> Label
lockLabel c = LIdent $! BS.append lockPrefix (ident2bs c)
isLockLabel :: Label -> Bool
isLockLabel l = case l of
LIdent c -> BS.isPrefixOf lockPrefix c
_ -> False
lockPrefix = BS.pack "lock_"

53
src/GF/Grammar/LookAbs.hs Normal file
View File

@@ -0,0 +1,53 @@
----------------------------------------------------------------------
-- |
-- Module : LookAbs
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/28 16:42:48 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.14 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Grammar.LookAbs (
lookupFunType,
lookupCatContext
) where
import GF.Data.Operations
import GF.Grammar.Abstract
import GF.Infra.Ident
import GF.Infra.Modules
import Data.List (nub)
import Control.Monad
-- | this is needed at compile time
lookupFunType :: Grammar -> Ident -> Ident -> Err Type
lookupFunType gr m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
AbsFun (Yes t) _ -> return t
AnyInd _ n -> lookupFunType gr n c
_ -> prtBad "cannot find type of" c
_ -> Bad $ prt m +++ "is not an abstract module"
-- | this is needed at compile time
lookupCatContext :: Grammar -> Ident -> Ident -> Err Context
lookupCatContext gr m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
AbsCat (Yes co) _ -> return co
AnyInd _ n -> lookupCatContext gr n c
_ -> prtBad "unknown category" c
_ -> Bad $ prt m +++ "is not an abstract module"

269
src/GF/Grammar/Lookup.hs Normal file
View File

@@ -0,0 +1,269 @@
{-# LANGUAGE PatternGuards #-}
----------------------------------------------------------------------
-- |
-- Module : Lookup
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/27 13:21:53 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.15 $
--
-- Lookup in source (concrete and resource) when compiling.
--
-- lookup in resource and concrete in compiling; for abstract, use 'Look'
-----------------------------------------------------------------------------
module GF.Grammar.Lookup (
lookupResDef,
lookupResDefKind,
lookupResType,
lookupOverload,
lookupParams,
lookupParamValues,
lookupFirstTag,
lookupValueIndex,
lookupIndexValue,
allOrigInfos,
allParamValues,
lookupAbsDef,
lookupLincat,
opersForType
) where
import GF.Data.Operations
import GF.Grammar.Abstract
import GF.Infra.Modules
import GF.Grammar.Predef
import GF.Grammar.Lockfield
import Data.List (nub,sortBy)
import Control.Monad
-- whether lock fields are added in reuse
lock c = lockRecType c -- return
unlock c = unlockRecord c -- return
lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term
lookupResDef gr m c = liftM fst $ lookupResDefKind gr m c
-- 0 = oper, 1 = lin, 2 = canonical. v > 0 means: no need to be recomputed
lookupResDefKind :: SourceGrammar -> Ident -> Ident -> Err (Term,Int)
lookupResDefKind gr m c
| isPredefCat c = return (Q cPredefAbs c,2) --- need this in gf3 12/6/2008
| otherwise = look True m c where
look isTop m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfoIn mo m c
case info of
ResOper _ (Yes t) -> return (qualifAnnot m t, 0)
ResOper _ Nope -> return (Q m c, 0) ---- if isTop then lookExt m c
---- else prtBad "cannot find in exts" c
CncCat (Yes ty) _ _ -> liftM (flip (,) 1) $ lock c ty
CncCat _ _ _ -> liftM (flip (,) 1) $ lock c defLinType
CncFun (Just (cat,_)) (Yes tr) _ -> liftM (flip (,) 1) $ unlock cat tr
CncFun _ (Yes tr) _ -> liftM (flip (,) 1) (return tr) ---- $ unlock c tr
AnyInd _ n -> look False n c
ResParam _ -> return (QC m c,2)
ResValue _ -> return (QC m c,2)
_ -> Bad $ prt c +++ "is not defined in resource" +++ prt m
_ -> Bad $ prt m +++ "is not a resource"
lookExt m c =
checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c,3)])
lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type
lookupResType gr m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
ResOper (Yes t) _ -> return $ qualifAnnot m t
ResOper (May n) _ -> lookupResType gr n c
-- used in reused concrete
CncCat _ _ _ -> return typeType
CncFun (Just (cat,(cont@(_:_),val))) _ _ -> do
val' <- lock cat val
return $ mkProd (cont, val', [])
CncFun _ _ _ -> lookFunType m m c
AnyInd _ n -> lookupResType gr n c
ResParam _ -> return $ typePType
ResValue (Yes (t,_)) -> return $ qualifAnnotPar m t
_ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m
_ -> Bad $ prt m +++ "is not a resource"
where
lookFunType e m c = do
a <- abstractOfConcrete gr m
lookFun e m c a
lookFun e m c a = do
mu <- lookupModMod gr a
info <- lookupIdentInfo mu c
case info of
AbsFun (Yes ty) _ -> return $ redirectTerm e ty
AbsCat _ _ -> return typeType
AnyInd _ n -> lookFun e m c n
_ -> prtBad "cannot find type of reused function" c
lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))]
lookupOverload gr m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
ResOverload os tysts -> do
tss <- mapM (\x -> lookupOverload gr x c) os
return $ [(map snd args,(val,tr)) |
(ty,tr) <- tysts, Ok (args,val) <- [typeFormCnc ty]] ++
concat tss
AnyInd _ n -> lookupOverload gr n c
_ -> Bad $ prt c +++ "is not an overloaded operation"
_ -> Bad $ prt m +++ "is not a resource"
lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err Info
lookupOrigInfo gr m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
AnyInd _ n -> lookupOrigInfo gr n c
i -> return i
_ -> Bad $ prt m +++ "is not run-time module"
lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe PValues)
lookupParams gr = look True where
look isTop m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
ResParam (Yes psm) -> return psm
AnyInd _ n -> look False n c
_ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
_ -> Bad $ prt m +++ "is not a resource"
lookExt m c =
checks [look False n c | n <- allExtensions gr m]
lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term]
lookupParamValues gr m c = do
(ps,mpv) <- lookupParams gr m c
case mpv of
Just ts -> return ts
_ -> liftM concat $ mapM mkPar ps
where
mkPar (f,co) = do
vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gr ty) co
return $ map (mkApp (QC m f)) vs
lookupFirstTag :: SourceGrammar -> Ident -> Ident -> Err Term
lookupFirstTag gr m c = do
vs <- lookupParamValues gr m c
case vs of
v:_ -> return v
_ -> prtBad "no parameter values given to type" c
lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term
lookupValueIndex gr ty tr = do
ts <- allParamValues gr ty
case lookup tr $ zip ts [0..] of
Just i -> return $ Val ty i
_ -> Bad $ "no index for" +++ prt tr +++ "in" +++ prt ty
lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term
lookupIndexValue gr ty i = do
ts <- allParamValues gr ty
if i < length ts
then return $ ts !! i
else Bad $ "no value for index" +++ show i +++ "in" +++ prt ty
allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
allOrigInfos gr m = errVal [] $ do
mi <- lookupModule gr m
case mi of
ModMod mo -> return [(c,i) | (c,_) <- tree2list (jments mo), Ok i <- [look c]]
where
look = lookupOrigInfo gr m
allParamValues :: SourceGrammar -> Type -> Err [Term]
allParamValues cnc ptyp = case ptyp of
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
QC p c -> lookupParamValues cnc p c
Q p c -> lookupResDef cnc p c >>= allParamValues cnc
RecType r -> do
let (ls,tys) = unzip $ sortByFst r
tss <- mapM allPV tys
return [R (zipAssign ls ts) | ts <- combinations tss]
_ -> prtBad "cannot find parameter values for" ptyp
where
allPV = allParamValues cnc
-- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
qualifAnnot :: Ident -> Term -> Term
qualifAnnot _ = id
-- Using this we wouldn't have to annotate constants defined in a module itself.
-- But things are simpler if we do (cf. Zinc).
-- Change Rename.self2status to change this behaviour.
-- we need this for lookup in ResVal
qualifAnnotPar m t = case t of
Cn c -> Q m c
Con c -> QC m c
_ -> composSafeOp (qualifAnnotPar m) t
lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Term)
lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
AbsFun _ (Yes t) -> return $ return t
AnyInd _ n -> lookupAbsDef gr n c
_ -> return Nothing
_ -> Bad $ prt m +++ "is not an abstract module"
lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
lookupLincat gr m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
CncCat (Yes t) _ _ -> return t
AnyInd _ n -> lookupLincat gr n c
_ -> Bad $ prt c +++ "has no linearization type in" +++ prt m
_ -> Bad $ prt m +++ "is not concrete"
-- The first type argument is uncomputed, usually a category symbol.
-- This is a hack to find implicit (= reused) opers.
opersForType :: SourceGrammar -> Type -> Type -> [(QIdent,Term)]
opersForType gr orig val =
[((i,f),ty) | (i,m) <- allModMod gr, (f,ty) <- opers i m val] where
opers i m val =
[(f,ty) |
(f,ResOper (Yes ty) _) <- tree2list $ jments m,
Ok valt <- [valTypeCnc ty],
elem valt [val,orig]
] ++
let cat = err error snd (valCat orig) in --- ignore module
[(f,ty) |
Ok a <- [abstractOfConcrete gr i >>= lookupModMod gr],
(f, AbsFun (Yes ty0) _) <- tree2list $ jments a,
let ty = redirectTerm i ty0,
Ok valt <- [valCat ty],
cat == snd valt ---
]

339
src/GF/Grammar/MMacros.hs Normal file
View File

@@ -0,0 +1,339 @@
----------------------------------------------------------------------
-- |
-- Module : MMacros
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/10 12:49:13 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.9 $
--
-- some more abstractions on grammars, esp. for Edit
-----------------------------------------------------------------------------
module GF.Grammar.MMacros where
import GF.Data.Operations
import GF.Data.Zipper
import GF.Grammar.Grammar
import GF.Grammar.PrGrammar
import GF.Infra.Ident
import GF.Compile.Refresh
import GF.Grammar.Values
----import GrammarST
import GF.Grammar.Macros
import Control.Monad
import qualified Data.ByteString.Char8 as BS
nodeTree :: Tree -> TrNode
argsTree :: Tree -> [Tree]
nodeTree (Tr (n,_)) = n
argsTree (Tr (_,ts)) = ts
isFocusNode :: TrNode -> Bool
bindsNode :: TrNode -> Binds
atomNode :: TrNode -> Atom
valNode :: TrNode -> Val
constrsNode :: TrNode -> Constraints
metaSubstsNode :: TrNode -> MetaSubst
isFocusNode (N (_,_,_,_,b)) = b
bindsNode (N (b,_,_,_,_)) = b
atomNode (N (_,a,_,_,_)) = a
valNode (N (_,_,v,_,_)) = v
constrsNode (N (_,_,_,(c,_),_)) = c
metaSubstsNode (N (_,_,_,(_,m),_)) = m
atomTree :: Tree -> Atom
valTree :: Tree -> Val
atomTree = atomNode . nodeTree
valTree = valNode . nodeTree
mkNode :: Binds -> Atom -> Val -> (Constraints, MetaSubst) -> TrNode
mkNode binds atom vtyp cs = N (binds,atom,vtyp,cs,False)
type Var = Ident
type Meta = MetaSymb
metasTree :: Tree -> [Meta]
metasTree = concatMap metasNode . scanTree where
metasNode n = [m | AtM m <- [atomNode n]] ++ map fst (metaSubstsNode n)
varsTree :: Tree -> [(Var,Val)]
varsTree t = [(x,v) | N (_,AtV x,v,_,_) <- scanTree t]
constrsTree :: Tree -> Constraints
constrsTree = constrsNode . nodeTree
allConstrsTree :: Tree -> Constraints
allConstrsTree = concatMap constrsNode . scanTree
changeConstrs :: (Constraints -> Constraints) -> TrNode -> TrNode
changeConstrs f (N (b,a,v,(c,m),x)) = N (b,a,v,(f c, m),x)
changeMetaSubst :: (MetaSubst -> MetaSubst) -> TrNode -> TrNode
changeMetaSubst f (N (b,a,v,(c,m),x)) = N (b,a,v,(c, f m),x)
changeAtom :: (Atom -> Atom) -> TrNode -> TrNode
changeAtom f (N (b,a,v,(c,m),x)) = N (b,f a,v,(c, m),x)
-- * on the way to Edit
uTree :: Tree
uTree = Tr (uNode, []) -- unknown tree
uNode :: TrNode
uNode = mkNode [] uAtom uVal ([],[])
uAtom :: Atom
uAtom = AtM meta0
mAtom :: Atom
mAtom = AtM meta0
uVal :: Val
uVal = vClos uExp
vClos :: Exp -> Val
vClos = VClos []
uExp :: Exp
uExp = Meta meta0
mExp, mExp0 :: Exp
mExp = Meta meta0
mExp0 = mExp
meta2exp :: MetaSymb -> Exp
meta2exp = Meta
atomC :: Fun -> Atom
atomC = AtC
funAtom :: Atom -> Err Fun
funAtom a = case a of
AtC f -> return f
_ -> prtBad "not function head" a
atomIsMeta :: Atom -> Bool
atomIsMeta atom = case atom of
AtM _ -> True
_ -> False
getMetaAtom :: Atom -> Err Meta
getMetaAtom a = case a of
AtM m -> return m
_ -> Bad "the active node is not meta"
cat2val :: Context -> Cat -> Val
cat2val cont cat = vClos $ mkApp (qq cat) [mkMeta i | i <- [1..length cont]]
val2cat :: Val -> Err Cat
val2cat v = val2exp v >>= valCat
substTerm :: [Ident] -> Substitution -> Term -> Term
substTerm ss g c = case c of
Vr x -> maybe c id $ lookup x g
App f a -> App (substTerm ss g f) (substTerm ss g a)
Abs x b -> let y = mkFreshVarX ss x in
Abs y (substTerm (y:ss) ((x, Vr y):g) b)
Prod x a b -> let y = mkFreshVarX ss x in
Prod y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) b)
_ -> c
metaSubstExp :: MetaSubst -> [(Meta,Exp)]
metaSubstExp msubst = [(m, errVal (meta2exp m) (val2expSafe v)) | (m,v) <- msubst]
-- * belong here rather than to computation
substitute :: [Var] -> Substitution -> Exp -> Err Exp
substitute v s = return . substTerm v s
alphaConv :: [Var] -> (Var,Var) -> Exp -> Err Exp ---
alphaConv oldvars (x,x') = substitute (x:x':oldvars) [(x,Vr x')]
alphaFresh :: [Var] -> Exp -> Err Exp
alphaFresh vs = refreshTermN $ maxVarIndex vs
-- | done in a state monad
alphaFreshAll :: [Var] -> [Exp] -> Err [Exp]
alphaFreshAll vs = mapM $ alphaFresh vs
-- | for display
val2exp :: Val -> Err Exp
val2exp = val2expP False
-- | for type checking
val2expSafe :: Val -> Err Exp
val2expSafe = val2expP True
val2expP :: Bool -> Val -> Err Exp
val2expP safe v = case v of
VClos g@(_:_) e@(Meta _) -> if safe
then prtBad "unsafe value substitution" v
else substVal g e
VClos g e -> substVal g e
VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c)
VCn c -> return $ qq c
VGen i x -> if safe
then prtBad "unsafe val2exp" v
else return $ Vr $ x --- in editing, no alpha conversions presentv
where
substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e)
isConstVal :: Val -> Bool
isConstVal v = case v of
VApp f c -> isConstVal f && isConstVal c
VCn _ -> True
VClos [] e -> null $ freeVarsExp e
_ -> False --- could be more liberal
mkProdVal :: Binds -> Val -> Err Val ---
mkProdVal bs v = do
bs' <- mapPairsM val2exp bs
v' <- val2exp v
return $ vClos $ foldr (uncurry Prod) v' bs'
freeVarsExp :: Exp -> [Ident]
freeVarsExp e = case e of
Vr x -> [x]
App f c -> freeVarsExp f ++ freeVarsExp c
Abs x b -> filter (/=x) (freeVarsExp b)
Prod x a b -> freeVarsExp a ++ filter (/=x) (freeVarsExp b)
_ -> [] --- thus applies to abstract syntax only
ident2string :: Ident -> String
ident2string = prIdent
tree :: (TrNode,[Tree]) -> Tree
tree = Tr
eqCat :: Cat -> Cat -> Bool
eqCat = (==)
addBinds :: Binds -> Tree -> Tree
addBinds b (Tr (N (b0,at,t,c,x),ts)) = Tr (N (b ++ b0,at,t,c,x),ts)
bodyTree :: Tree -> Tree
bodyTree (Tr (N (_,a,t,c,x),ts)) = Tr (N ([],a,t,c,x),ts)
refreshMetas :: [Meta] -> Exp -> Exp
refreshMetas metas = fst . rms minMeta where
rms meta trm = case trm of
Meta m -> (Meta meta, nextMeta meta)
App f a -> let (f',msf) = rms meta f
(a',msa) = rms msf a
in (App f' a', msa)
Prod x a b ->
let (a',msa) = rms meta a
(b',msb) = rms msa b
in (Prod x a' b', msb)
Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb)
_ -> (trm,meta)
minMeta = int2meta $
if null metas then 0 else (maximum (map metaSymbInt metas) + 1)
ref2exp :: [Var] -> Type -> Ref -> Err Exp
ref2exp bounds typ ref = do
cont <- contextOfType typ
xx0 <- mapM (typeSkeleton . snd) cont
let (xxs,cs) = unzip [(length hs, c) | (hs,c) <- xx0]
args = [mkAbs xs mExp | i <- xxs, let xs = mkFreshVars i bounds]
return $ mkApp ref args
-- no refreshment of metas
-- | invariant: only 'Con' or 'Var'
type Ref = Exp
fun2wrap :: [Var] -> ((Fun,Int),Type) -> Exp -> Err Exp
fun2wrap oldvars ((fun,i),typ) exp = do
cont <- contextOfType typ
args <- mapM mkArg (zip [0..] (map snd cont))
return $ mkApp (qq fun) args
where
mkArg (n,c) = do
cont <- contextOfType c
let vars = mkFreshVars (length cont) oldvars
return $ mkAbs vars $ if n==i then exp else mExp
-- | weak heuristics: sameness of value category
compatType :: Val -> Type -> Bool
compatType v t = errVal True $ do
cat1 <- val2cat v
cat2 <- valCat t
return $ cat1 == cat2
---
mkJustProd :: Context -> Term -> Term
mkJustProd cont typ = mkProd (cont,typ,[])
int2var :: Int -> Ident
int2var = identC . BS.pack . ('$':) . show
meta0 :: Meta
meta0 = int2meta 0
termMeta0 :: Term
termMeta0 = Meta meta0
identVar :: Term -> Err Ident
identVar (Vr x) = return x
identVar _ = Bad "not a variable"
-- | light-weight rename for user interaction; also change names of internal vars
qualifTerm :: Ident -> Term -> Term
qualifTerm m = qualif [] where
qualif xs t = case t of
Abs x b -> let x' = chV x in Abs x' $ qualif (x':xs) b
Prod x a b -> Prod x (qualif xs a) $ qualif (x:xs) b
Vr x -> let x' = chV x in if (elem x' xs) then (Vr x') else (Q m x)
Cn c -> Q m c
Con c -> QC m c
_ -> composSafeOp (qualif xs) t
chV x = string2var $ ident2bs x
string2var :: BS.ByteString -> Ident
string2var s = case BS.unpack s of
c:'_':i -> identV (BS.singleton c) (readIntArg i) ---
_ -> identC s
-- | reindex variables so that they tell nesting depth level
reindexTerm :: Term -> Term
reindexTerm = qualif (0,[]) where
qualif dg@(d,g) t = case t of
Abs x b -> let x' = ind x d in Abs x' $ qualif (d+1, (x,x'):g) b
Prod x a b -> let x' = ind x d in Prod x' (qualif dg a) $ qualif (d+1, (x,x'):g) b
Vr x -> Vr $ look x g
_ -> composSafeOp (qualif dg) t
look x = maybe x id . lookup x --- if x is not in scope it is unchanged
ind x d = identC $ ident2bs x `BS.append` BS.singleton '_' `BS.append` BS.pack (show d)
-- this method works for context-free abstract syntax
-- and is meant to be used in simple embedded GF applications
exp2tree :: Exp -> Err Tree
exp2tree e = do
(bs,f,xs) <- termForm e
cont <- case bs of
[] -> return []
_ -> prtBad "cannot convert bindings in" e
at <- case f of
Q m c -> return $ AtC (m,c)
QC m c -> return $ AtC (m,c)
Meta m -> return $ AtM m
K s -> return $ AtL s
EInt n -> return $ AtI n
EFloat n -> return $ AtF n
_ -> prtBad "cannot convert to atom" f
ts <- mapM exp2tree xs
return $ Tr (N (cont,at,uVal,([],[]),True),ts)

733
src/GF/Grammar/Macros.hs Normal file
View File

@@ -0,0 +1,733 @@
----------------------------------------------------------------------
-- |
-- Module : Macros
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 16:38:00 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.24 $
--
-- Macros for constructing and analysing source code terms.
--
-- operations on terms and types not involving lookup in or reference to grammars
--
-- AR 7\/12\/1999 - 9\/5\/2000 -- 4\/6\/2001
-----------------------------------------------------------------------------
module GF.Grammar.Macros where
import GF.Data.Operations
import GF.Data.Str
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Values
import GF.Grammar.Predef
import GF.Grammar.PrGrammar
import Control.Monad (liftM, liftM2)
import Data.Char (isDigit)
import Data.List (sortBy)
firstTypeForm :: Type -> Err (Context, Type)
firstTypeForm t = case t of
Prod x a b -> do
(x', val) <- firstTypeForm b
return ((x,a):x',val)
_ -> return ([],t)
qTypeForm :: Type -> Err (Context, Cat, [Term])
qTypeForm t = case t of
Prod x a b -> do
(x', cat, args) <- qTypeForm b
return ((x,a):x', cat, args)
App c a -> do
(_,cat, args) <- qTypeForm c
return ([],cat,args ++ [a])
Q m c ->
return ([],(m,c),[])
QC m c ->
return ([],(m,c),[])
_ ->
prtBad "no normal form of type" t
qq :: QIdent -> Term
qq (m,c) = Q m c
typeForm :: Type -> Err (Context, Cat, [Term])
typeForm = qTypeForm ---- no need to distinguish any more
typeFormCnc :: Type -> Err (Context, Type)
typeFormCnc t = case t of
Prod x a b -> do
(x', v) <- typeFormCnc b
return ((x,a):x',v)
_ -> return ([],t)
valCat :: Type -> Err Cat
valCat typ =
do (_,cat,_) <- typeForm typ
return cat
valType :: Type -> Err Type
valType typ =
do (_,cat,xx) <- typeForm typ --- not optimal to do in this way
return $ mkApp (qq cat) xx
valTypeCnc :: Type -> Err Type
valTypeCnc typ =
do (_,ty) <- typeFormCnc typ
return ty
typeRawSkeleton :: Type -> Err ([(Int,Type)],Type)
typeRawSkeleton typ =
do (cont,typ) <- typeFormCnc typ
args <- mapM (typeRawSkeleton . snd) cont
return ([(length c, v) | (c,v) <- args], typ)
type MCat = (Ident,Ident)
getMCat :: Term -> Err MCat
getMCat t = case t of
Q m c -> return (m,c)
QC m c -> return (m,c)
Sort c -> return (identW, c)
App f _ -> getMCat f
_ -> prtBad "no qualified constant" t
typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
typeSkeleton typ = do
(cont,val) <- typeRawSkeleton typ
cont' <- mapPairsM getMCat cont
val' <- getMCat val
return (cont',val')
catSkeleton :: Type -> Err ([MCat],MCat)
catSkeleton typ =
do (args,val) <- typeSkeleton typ
return (map snd args, val)
funsToAndFrom :: Type -> (MCat, [(MCat,[Int])])
funsToAndFrom t = errVal undefined $ do ---
(cs,v) <- catSkeleton t
let cis = zip cs [0..]
return $ (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs])
typeFormConcrete :: Type -> Err (Context, Type)
typeFormConcrete t = case t of
Prod x a b -> do
(x', typ) <- typeFormConcrete b
return ((x,a):x', typ)
_ -> return ([],t)
isRecursiveType :: Type -> Bool
isRecursiveType t = errVal False $ do
(cc,c) <- catSkeleton t -- thus recursivity on Cat level
return $ any (== c) cc
isHigherOrderType :: Type -> Bool
isHigherOrderType t = errVal True $ do -- pessimistic choice
co <- contextOfType t
return $ not $ null [x | (x,Prod _ _ _) <- co]
contextOfType :: Type -> Err Context
contextOfType typ = case typ of
Prod x a b -> liftM ((x,a):) $ contextOfType b
_ -> return []
unComputed :: Term -> Term
unComputed t = case t of
Computed v -> unComputed v
_ -> t --- composSafeOp unComputed t
{-
--- defined (better) in compile/PrOld
stripTerm :: Term -> Term
stripTerm t = case t of
Q _ c -> Cn c
QC _ c -> Cn c
T ti psts -> T ti [(stripPatt p, stripTerm v) | (p,v) <- psts]
_ -> composSafeOp stripTerm t
where
stripPatt p = errVal p $ term2patt $ stripTerm $ patt2term p
-}
computed :: Term -> Term
computed = Computed
termForm :: Term -> Err ([(Ident)], Term, [Term])
termForm t = case t of
Abs x b ->
do (x', fun, args) <- termForm b
return (x:x', fun, args)
App c a ->
do (_,fun, args) <- termForm c
return ([],fun,args ++ [a])
_ ->
return ([],t,[])
termFormCnc :: Term -> ([(Ident)], Term)
termFormCnc t = case t of
Abs x b -> (x:xs, t') where (xs,t') = termFormCnc b
_ -> ([],t)
appForm :: Term -> (Term, [Term])
appForm t = case t of
App c a -> (fun, args ++ [a]) where (fun, args) = appForm c
_ -> (t,[])
varsOfType :: Type -> [Ident]
varsOfType t = case t of
Prod x _ b -> x : varsOfType b
_ -> []
mkProdSimple :: Context -> Term -> Term
mkProdSimple c t = mkProd (c,t,[])
mkProd :: (Context, Term, [Term]) -> Term
mkProd ([],typ,args) = mkApp typ args
mkProd ((x,a):dd, typ, args) = Prod x a (mkProd (dd, typ, args))
mkTerm :: ([(Ident)], Term, [Term]) -> Term
mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa)
mkApp :: Term -> [Term] -> Term
mkApp = foldl App
mkAbs :: [Ident] -> Term -> Term
mkAbs xx t = foldr Abs t xx
appCons :: Ident -> [Term] -> Term
appCons = mkApp . Cn
mkLet :: [LocalDef] -> Term -> Term
mkLet defs t = foldr Let t defs
mkLetUntyped :: Context -> Term -> Term
mkLetUntyped defs = mkLet [(x,(Nothing,t)) | (x,t) <- defs]
isVariable :: Term -> Bool
isVariable (Vr _ ) = True
isVariable _ = False
eqIdent :: Ident -> Ident -> Bool
eqIdent = (==)
uType :: Type
uType = Cn cUndefinedType
assign :: Label -> Term -> Assign
assign l t = (l,(Nothing,t))
assignT :: Label -> Type -> Term -> Assign
assignT l a t = (l,(Just a,t))
unzipR :: [Assign] -> ([Label],[Term])
unzipR r = (ls, map snd ts) where (ls,ts) = unzip r
mkAssign :: [(Label,Term)] -> [Assign]
mkAssign lts = [assign l t | (l,t) <- lts]
zipAssign :: [Label] -> [Term] -> [Assign]
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
mkRecordN :: Int -> (Int -> Label) -> [Term] -> Term
mkRecordN int lab typs = R [ assign (lab i) t | (i,t) <- zip [int..] typs]
mkRecord :: (Int -> Label) -> [Term] -> Term
mkRecord = mkRecordN 0
mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type
mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
mkRecType :: (Int -> Label) -> [Type] -> Type
mkRecType = mkRecTypeN 0
record2subst :: Term -> Err Substitution
record2subst t = case t of
R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
_ -> prtBad "record expected, found" t
typeType, typePType, typeStr, typeTok, typeStrs :: Term
typeType = Sort cType
typePType = Sort cPType
typeStr = Sort cStr
typeTok = Sort cTok
typeStrs = Sort cStrs
typeString, typeFloat, typeInt :: Term
typeInts :: Integer -> Term
typePBool :: Term
typeError :: Term
typeString = cnPredef cString
typeInt = cnPredef cInt
typeFloat = cnPredef cFloat
typeInts i = App (cnPredef cInts) (EInt i)
typePBool = cnPredef cPBool
typeError = cnPredef cErrorType
isTypeInts :: Term -> Maybe Integer
isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
isTypeInts _ = Nothing
isPredefConstant :: Term -> Bool
isPredefConstant t = case t of
Q mod _ | mod == cPredef || mod == cPredefAbs -> True
_ -> False
cnPredef :: Ident -> Term
cnPredef f = Q cPredef f
mkSelects :: Term -> [Term] -> Term
mkSelects t tt = foldl S t tt
mkTable :: [Term] -> Term -> Term
mkTable tt t = foldr Table t tt
mkCTable :: [Ident] -> Term -> Term
mkCTable ids v = foldr ccase v ids where
ccase x t = T TRaw [(PV x,t)]
mkDecl :: Term -> Decl
mkDecl typ = (identW, typ)
eqStrIdent :: Ident -> Ident -> Bool
eqStrIdent = (==)
tuple2record :: [Term] -> [Assign]
tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
tuple2recordType :: [Term] -> [Labelling]
tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
tuple2recordPatt :: [Patt] -> [(Label,Patt)]
tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
mkCases :: Ident -> Term -> Term
mkCases x t = T TRaw [(PV x, t)]
mkWildCases :: Term -> Term
mkWildCases = mkCases identW
mkFunType :: [Type] -> Type -> Type
mkFunType tt t = mkProd ([(identW, ty) | ty <- tt], t, []) -- nondep prod
plusRecType :: Type -> Type -> Err Type
plusRecType t1 t2 = case (unComputed t1, unComputed t2) of
(RecType r1, RecType r2) -> case
filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2))
ls -> Bad $ "clashing labels" +++ unwords (map prt ls)
_ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt t2)
plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 =
case (t1,t2) of
(R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
(_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV
(FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
_ -> Bad ("cannot add records" +++ prt t1 +++ "and" +++ prt t2)
-- | default linearization type
defLinType :: Type
defLinType = RecType [(theLinLabel, typeStr)]
-- | refreshing variables
mkFreshVar :: [Ident] -> Ident
mkFreshVar olds = varX (maxVarIndex olds + 1)
-- | trying to preserve a given symbol
mkFreshVarX :: [Ident] -> Ident -> Ident
mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x
maxVarIndex :: [Ident] -> Int
maxVarIndex = maximum . ((-1):) . map varIndex
mkFreshVars :: Int -> [Ident] -> [Ident]
mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]
-- | quick hack for refining with var in editor
freshAsTerm :: String -> Term
freshAsTerm s = Vr (varX (readIntArg s))
-- | create a terminal for concrete syntax
string2term :: String -> Term
string2term = K
int2term :: Integer -> Term
int2term = EInt
float2term :: Double -> Term
float2term = EFloat
-- | create a terminal from identifier
ident2terminal :: Ident -> Term
ident2terminal = K . prIdent
symbolOfIdent :: Ident -> String
symbolOfIdent = prIdent
symid :: Ident -> String
symid = symbolOfIdent
justIdentOf :: Term -> Maybe Ident
justIdentOf (Vr x) = Just x
justIdentOf (Cn x) = Just x
justIdentOf _ = Nothing
isMeta :: Term -> Bool
isMeta (Meta _) = True
isMeta _ = False
mkMeta :: Int -> Term
mkMeta = Meta . MetaSymb
nextMeta :: MetaSymb -> MetaSymb
nextMeta = int2meta . succ . metaSymbInt
int2meta :: Int -> MetaSymb
int2meta = MetaSymb
metaSymbInt :: MetaSymb -> Int
metaSymbInt (MetaSymb k) = k
freshMeta :: [MetaSymb] -> MetaSymb
freshMeta ms = MetaSymb (minimum [n | n <- [0..length ms],
notElem n (map metaSymbInt ms)])
mkFreshMetasInTrm :: [MetaSymb] -> Trm -> Trm
mkFreshMetasInTrm metas = fst . rms minMeta where
rms meta trm = case trm of
Meta m -> (Meta (MetaSymb meta), meta + 1)
App f a -> let (f',msf) = rms meta f
(a',msa) = rms msf a
in (App f' a', msa)
Prod x a b ->
let (a',msa) = rms meta a
(b',msb) = rms msa b
in (Prod x a' b', msb)
Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb)
_ -> (trm,meta)
minMeta = if null metas then 0 else (maximum (map metaSymbInt metas) + 1)
-- | decides that a term has no metavariables
isCompleteTerm :: Term -> Bool
isCompleteTerm t = case t of
Meta _ -> False
Abs _ b -> isCompleteTerm b
App f a -> isCompleteTerm f && isCompleteTerm a
_ -> True
linTypeStr :: Type
linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str}
linAsStr :: String -> Term
linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}
term2patt :: Term -> Err Patt
term2patt trm = case termForm trm of
Ok ([], Vr x, []) -> return (PV x)
Ok ([], Val ty x, []) -> return (PVal ty x)
Ok ([], Con c, aa) -> do
aa' <- mapM term2patt aa
return (PC c aa')
Ok ([], QC p c, aa) -> do
aa' <- mapM term2patt aa
return (PP p c aa')
Ok ([], Q p c, []) -> do
return (PM p c)
Ok ([], R r, []) -> do
let (ll,aa) = unzipR r
aa' <- mapM term2patt aa
return (PR (zip ll aa'))
Ok ([],EInt i,[]) -> return $ PInt i
Ok ([],EFloat i,[]) -> return $ PFloat i
Ok ([],K s, []) -> return $ PString s
--- encodings due to excessive use of term-patt convs. AR 7/1/2005
Ok ([], Cn id, [Vr a,b]) | id == cAs -> do
b' <- term2patt b
return (PAs a b')
Ok ([], Cn id, [a]) | id == cNeg -> do
a' <- term2patt a
return (PNeg a')
Ok ([], Cn id, [a]) | id == cRep -> do
a' <- term2patt a
return (PRep a')
Ok ([], Cn id, []) | id == cRep -> do
return PChar
Ok ([], Cn id,[K s]) | id == cChars -> do
return $ PChars s
Ok ([], Cn id, [a,b]) | id == cSeq -> do
a' <- term2patt a
b' <- term2patt b
return (PSeq a' b')
Ok ([], Cn id, [a,b]) | id == cAlt -> do
a' <- term2patt a
b' <- term2patt b
return (PAlt a' b')
Ok ([], Cn c, []) -> do
return (PMacro c)
_ -> prtBad "no pattern corresponds to term" trm
patt2term :: Patt -> Term
patt2term pt = case pt of
PV x -> Vr x
PW -> Vr identW --- not parsable, should not occur
PVal t i -> Val t i
PMacro c -> Cn c
PM p c -> Q p c
PC c pp -> mkApp (Con c) (map patt2term pp)
PP p c pp -> mkApp (QC p c) (map patt2term pp)
PR r -> R [assign l (patt2term p) | (l,p) <- r]
PT _ p -> patt2term p
PInt i -> EInt i
PFloat i -> EFloat i
PString s -> K s
PAs x p -> appCons cAs [Vr x, patt2term p] --- an encoding
PChar -> appCons cChar [] --- an encoding
PChars s -> appCons cChars [K s] --- an encoding
PSeq a b -> appCons cSeq [(patt2term a), (patt2term b)] --- an encoding
PAlt a b -> appCons cAlt [(patt2term a), (patt2term b)] --- an encoding
PRep a -> appCons cRep [(patt2term a)] --- an encoding
PNeg a -> appCons cNeg [(patt2term a)] --- an encoding
redirectTerm :: Ident -> Term -> Term
redirectTerm n t = case t of
QC _ f -> QC n f
Q _ f -> Q n f
_ -> composSafeOp (redirectTerm n) t
-- | to gather ultimate cases in a table; preserves pattern list
allCaseValues :: Term -> [([Patt],Term)]
allCaseValues trm = case unComputed trm of
T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0]
_ -> [([],trm)]
-- | to get a string from a term that represents a sequence of terminals
strsFromTerm :: Term -> Err [Str]
strsFromTerm t = case unComputed t of
K s -> return [str s]
Empty -> return [str []]
C s t -> do
s' <- strsFromTerm s
t' <- strsFromTerm t
return [plusStr x y | x <- s', y <- t']
Glue s t -> do
s' <- strsFromTerm s
t' <- strsFromTerm t
return [glueStr x y | x <- s', y <- t']
Alts (d,vs) -> do
d0 <- strsFromTerm d
v0 <- mapM (strsFromTerm . fst) vs
c0 <- mapM (strsFromTerm . snd) vs
let vs' = zip v0 c0
return [strTok (str2strings def) vars |
def <- d0,
vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
vv <- combinations v0]
]
FV ts -> mapM strsFromTerm ts >>= return . concat
Strs ts -> mapM strsFromTerm ts >>= return . concat
Ready ss -> return [ss]
Alias _ _ d -> strsFromTerm d --- should not be needed...
_ -> prtBad "cannot get Str from term" t
-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
stringFromTerm :: Term -> String
stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm
-- | 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
App c a ->
do c' <- co c
a' <- co a
return (App c' a')
Abs x b ->
do b' <- co b
return (Abs x b')
Prod x a b ->
do a' <- co a
b' <- co b
return (Prod x a' b')
S c a ->
do c' <- co c
a' <- co a
return (S c' a')
Table a c ->
do a' <- co a
c' <- co c
return (Table a' c')
R r ->
do r' <- mapAssignM co r
return (R r')
RecType r ->
do r' <- mapPairListM (co . snd) r
return (RecType r')
P t i ->
do t' <- co t
return (P t' i)
PI t i j ->
do t' <- co t
return (PI t' i j)
ExtR a c ->
do a' <- co a
c' <- co c
return (ExtR a' c')
T i cc ->
do cc' <- mapPairListM (co . snd) cc
i' <- changeTableType co i
return (T i' cc')
TSh i cc ->
do cc' <- mapPairListM (co . snd) cc
i' <- changeTableType co i
return (TSh i' cc')
Eqs cc ->
do cc' <- mapPairListM (co . snd) cc
return (Eqs cc')
V ty vs ->
do ty' <- co ty
vs' <- mapM co vs
return (V ty' vs')
Val ty i ->
do ty' <- co ty
return (Val ty' i)
Let (x,(mt,a)) b ->
do a' <- co a
mt' <- case mt of
Just t -> co t >>= (return . Just)
_ -> return mt
b' <- co b
return (Let (x,(mt',a')) b')
Alias c ty d ->
do v <- co d
ty' <- co ty
return $ Alias c ty' v
C s1 s2 ->
do v1 <- co s1
v2 <- co s2
return (C v1 v2)
Glue s1 s2 ->
do v1 <- co s1
v2 <- co s2
return (Glue v1 v2)
Alts (t,aa) ->
do t' <- co t
aa' <- mapM (pairM co) aa
return (Alts (t',aa'))
FV ts -> mapM co ts >>= return . FV
Strs tt -> mapM co tt >>= return . Strs
EPattType ty ->
do ty' <- co ty
return (EPattType ty')
_ -> return trm -- covers K, Vr, Cn, Sort, EPatt
getTableType :: TInfo -> Err Type
getTableType i = case i of
TTyped ty -> return ty
TComp ty -> return ty
TWild ty -> return ty
_ -> Bad "the table is untyped"
changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo
changeTableType co i = case i of
TTyped ty -> co ty >>= return . TTyped
TComp ty -> co ty >>= return . TComp
TWild ty -> co ty >>= return . TWild
_ -> return i
collectOp :: (Term -> [a]) -> Term -> [a]
collectOp co trm = case trm of
App c a -> co c ++ co a
Abs _ b -> co b
Prod _ a b -> co a ++ co b
S c a -> co c ++ co a
Table a c -> co a ++ co c
ExtR a c -> co a ++ co c
R r -> concatMap (\ (_,(mt,a)) -> maybe [] co mt ++ co a) r
RecType r -> concatMap (co . snd) r
P t i -> co t
T _ cc -> concatMap (co . snd) cc -- not from patterns --- nor from type annot
TSh _ cc -> concatMap (co . snd) cc -- not from patterns --- nor from type annot
V _ cc -> concatMap co cc --- nor from type annot
Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b
C s1 s2 -> co s1 ++ co s2
Glue s1 s2 -> co s1 ++ co s2
Alts (t,aa) -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y)
FV ts -> concatMap co ts
Strs tt -> concatMap co tt
_ -> [] -- covers K, Vr, Cn, Sort, Ready
-- | to find the word items in a term
wordsInTerm :: Term -> [String]
wordsInTerm trm = filter (not . null) $ case trm of
K s -> [s]
S c _ -> wo c
Alts (t,aa) -> wo t ++ concatMap (wo . fst) aa
Ready s -> allItems s
_ -> collectOp wo trm
where wo = wordsInTerm
noExist :: Term
noExist = FV []
defaultLinType :: Type
defaultLinType = mkRecType linLabel [typeStr]
metaTerms :: [Term]
metaTerms = map (Meta . MetaSymb) [0..]
-- | from GF1, 20\/9\/2003
isInOneType :: Type -> Bool
isInOneType t = case t of
Prod _ a b -> a == b
_ -> False
-- normalize records and record types; put s first
sortRec :: [(Label,a)] -> [(Label,a)]
sortRec = sortBy ordLabel where
ordLabel (r1,_) (r2,_) = case (prt r1, prt r2) of
("s",_) -> LT
(_,"s") -> GT
(s1,s2) -> compare s1 s2

155
src/GF/Grammar/PatternMatch.hs Normal file
View File

@@ -0,0 +1,155 @@
----------------------------------------------------------------------
-- |
-- Module : PatternMatch
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/12 12:38:29 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.7 $
--
-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
-----------------------------------------------------------------------------
module GF.Grammar.PatternMatch (matchPattern,
testOvershadow,
findMatch
) where
import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Grammar.Macros
import GF.Grammar.PrGrammar
import Data.List
import Control.Monad
matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
matchPattern pts term =
if not (isInConstantForm term)
then prtBad "variables occur in" term
else
errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
findMatch [([p],t) | (p,t) <- pts] [term]
testOvershadow :: [Patt] -> [Term] -> Err [Patt]
testOvershadow pts vs = do
let numpts = zip pts [0..]
let cases = [(p,EInt i) | (p,i) <- numpts]
ts <- mapM (liftM fst . matchPattern cases) vs
return $ [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
findMatch cases terms = case cases of
[] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
(patts,_):_ | length patts /= length terms ->
Bad ("wrong number of args for patterns :" +++
unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (val, concat substs)
_ -> findMatch cc terms
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
tryMatch (p,t) = do
t' <- termForm t
trym p t'
where
isInConstantFormt = True -- tested already
trym p t' =
case (p,t') of
(PVal _ i, (_,Val _ j,_))
| i == j -> return []
| otherwise -> Bad $ "no match of values"
(_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = []
(PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard
(PV x, _) | isInConstantFormt -> return [(x,t)]
(PString s, ([],K i,[])) | s==i -> return []
(PInt s, ([],EInt i,[])) | s==i -> return []
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
(PC p pp, ([], Con f, tt)) |
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PP q p pp, ([], QC r f, tt)) |
-- q `eqStrIdent` r && --- not for inherited AR 10/10/2005
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
---- hack for AppPredef bug
(PP q p pp, ([], Q r f, tt)) |
-- q `eqStrIdent` r && ---
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PR r, ([],R r',[])) |
all (`elem` map fst r') (map fst r) ->
do matches <- mapM tryMatch
[(p,snd a) | (l,p) <- r, let Just a = lookup l r']
return (concat matches)
(PT _ p',_) -> trym p' t'
(_, ([],Alias _ _ d,[])) -> tryMatch (p,d)
-- (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do
(PAs x p',_) -> do
subst <- trym p' t'
return $ (x,t) : subst
(PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
(PNeg p',_) -> case tryMatch (p',t) of
Bad _ -> return []
_ -> prtBad "no match with negative pattern" p
(PSeq p1 p2, ([],K s, [])) -> do
let cuts = [splitAt n s | n <- [0 .. length s]]
matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
return (concat matches)
(PRep p1, ([],K s, [])) -> checks [
trym (foldr (const (PSeq p1)) (PString "")
[1..n]) t' | n <- [0 .. length s]
] >>
return []
(PChar, ([],K [_], [])) -> return []
(PChars cs, ([],K [c], [])) | elem c cs -> return []
_ -> prtBad "no match in case expr for" t
isInConstantForm :: Term -> Bool
isInConstantForm trm = case trm of
Cn _ -> True
Con _ -> True
Q _ _ -> True
QC _ _ -> True
Abs _ _ -> True
App c a -> isInConstantForm c && isInConstantForm a
R r -> all (isInConstantForm . snd . snd) r
K _ -> True
Empty -> True
Alias _ _ t -> isInConstantForm t
EInt _ -> True
_ -> False ---- isInArgVarForm trm
varsOfPatt :: Patt -> [Ident]
varsOfPatt p = case p of
PV x -> [x | not (isWildIdent x)]
PC _ ps -> concat $ map varsOfPatt ps
PP _ _ ps -> concat $ map varsOfPatt ps
PR r -> concat $ map (varsOfPatt . snd) r
PT _ q -> varsOfPatt q
_ -> []
-- | to search matching parameter combinations in tables
isMatchingForms :: [Patt] -> [Term] -> Bool
isMatchingForms ps ts = all match (zip ps ts') where
match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds
match _ = True
ts' = map appForm ts

279
src/GF/Grammar/PrGrammar.hs Normal file
View File

@@ -0,0 +1,279 @@
----------------------------------------------------------------------
-- |
-- Module : PrGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/04 11:45:38 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $
--
-- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003
--
-- printing and prettyprinting class
--
-- 8\/1\/2004:
-- Usually followed principle: 'prt_' for displaying in the editor, 'prt'
-- in writing grammars to a file. For some constructs, e.g. 'prMarkedTree',
-- only the former is ever needed.
-----------------------------------------------------------------------------
module GF.Grammar.PrGrammar (Print(..),
prtBad,
prGrammar, prModule,
prContext, prParam,
prQIdent, prQIdent_,
prRefinement, prTermOpt,
prt_Tree, prMarkedTree, prTree,
tree2string, prprTree,
prConstrs, prConstraints,
prMetaSubst, prEnv, prMSubst,
prExp, prOperSignature,
lookupIdent, lookupIdentInfo, lookupIdentInfoIn,
prTermTabular
) where
import GF.Data.Operations
import GF.Data.Zipper
import GF.Grammar.Grammar
import GF.Infra.Modules
import qualified GF.Source.PrintGF as P
import GF.Grammar.Values
import GF.Source.GrammarToSource
--- import GFC (CanonGrammar) --- cycle of modules
import GF.Infra.Option
import GF.Infra.Ident
import GF.Data.Str
import GF.Infra.CompactPrint
import Data.List (intersperse)
class Print a where
prt :: a -> String
-- | printing with parentheses, if needed
prt2 :: a -> String
-- | pretty printing
prpr :: a -> [String]
-- | printing without ident qualifications
prt_ :: a -> String
prt2 = prt
prt_ = prt
prpr = return . prt
-- 8/1/2004
--- Usually followed principle: prt_ for displaying in the editor, prt
--- in writing grammars to a file. For some constructs, e.g. prMarkedTree,
--- only the former is ever needed.
-- | to show terms etc in error messages
prtBad :: Print a => String -> a -> Err b
prtBad s a = Bad (s +++ prt a)
pprintTree :: P.Print a => a -> String
pprintTree = compactPrint . P.printTree
prGrammar :: SourceGrammar -> String
prGrammar = pprintTree . trGrammar
prModule :: (Ident, SourceModInfo) -> String
prModule = pprintTree . trModule
instance Print Term where
prt = pprintTree . trt
prt_ = prExp
instance Print Ident where
prt = pprintTree . tri
instance Print Patt where
prt = pprintTree . trp
prt_ = prt . unqual where
unqual p = case p of
PP _ c [] -> PV c --- to remove curlies
PP _ c ps -> PC c (map unqual ps)
PC c ps -> PC c (map unqual ps)
_ -> p ---- records
instance Print Label where
prt = pprintTree . trLabel
instance Print MetaSymb where
prt (MetaSymb i) = "?" ++ show i
prParam :: Param -> String
prParam (c,co) = prt c +++ prContext co
prContext :: Context -> String
prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co]
-- some GFC notions
instance Print a => Print (Tr a) where
prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees)
prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t)
-- | we cannot define the method prt_ in this way
prt_Tree :: Tree -> String
prt_Tree = prt_ . tree2exp
instance Print TrNode where
prt (N (bi,at,vt,(cs,ms),_)) =
prBinds bi ++
prt at +++ ":" +++ prt vt
+++ prConstraints cs +++ prMetaSubst ms
prt_ (N (bi,at,vt,(cs,ms),_)) =
prBinds bi ++
prt_ at +++ ":" +++ prt_ vt
+++ prConstraints cs +++ prMetaSubst ms
prMarkedTree :: Tr (TrNode,Bool) -> [String]
prMarkedTree = prf 1 where
prf ind t@(Tr (node, trees)) =
prNode ind node : concatMap (prf (ind + 2)) trees
prNode ind node = case node of
(n, False) -> indent ind (prt_ n)
(n, _) -> '*' : indent (ind - 1) (prt_ n)
prTree :: Tree -> [String]
prTree = prMarkedTree . mapTr (\n -> (n,False))
-- | a pretty-printer for parsable output
tree2string :: Tree -> String
tree2string = unlines . prprTree
prprTree :: Tree -> [String]
prprTree = prf False where
prf par t@(Tr (node, trees)) =
parIf par (prn node : concat [prf (ifPar t) t | t <- trees])
prn (N (bi,at,_,_,_)) = prb bi ++ prt_ at
prb [] = ""
prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> "
parIf par (s:ss) = map (indent 2) $
if par
then ('(':s) : ss ++ [")"]
else s:ss
ifPar (Tr (N ([],_,_,_,_), [])) = False
ifPar _ = True
-- auxiliaries
prConstraints :: Constraints -> String
prConstraints = concat . prConstrs
prMetaSubst :: MetaSubst -> String
prMetaSubst = concat . prMSubst
prEnv :: Env -> String
---- prEnv [] = prCurly "" ---- for debugging
prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e
prConstrs :: Constraints -> [String]
prConstrs = map (\ (v,w) -> prCurly (prt v ++ "<>" ++ prt w))
prMSubst :: MetaSubst -> [String]
prMSubst = map (\ (m,e) -> prCurly ("?" ++ show m ++ "=" ++ prt e))
prBinds bi = if null bi
then []
else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> "
where
prValDecl (x,t) = prParenth (prt_ x +++ ":" +++ prt_ t)
instance Print Val where
prt (VGen i x) = prt x ++ "{-" ++ show i ++ "-}" ---- latter part for debugging
prt (VApp u v) = prt u +++ prv1 v
prt (VCn mc) = prQIdent_ mc
prt (VClos env e) = case e of
Meta _ -> prt_ e ++ prEnv env
_ -> prt_ e ---- ++ prEnv env ---- for debugging
prt VType = "Type"
prv1 v = case v of
VApp _ _ -> prParenth $ prt v
VClos _ _ -> prParenth $ prt v
_ -> prt v
instance Print Atom where
prt (AtC f) = prQIdent f
prt (AtM i) = prt i
prt (AtV i) = prt i
prt (AtL s) = prQuotedString s
prt (AtI i) = show i
prt (AtF i) = show i
prt_ (AtC (_,f)) = prt f
prt_ a = prt a
prQIdent :: QIdent -> String
prQIdent (m,f) = prt m ++ "." ++ prt f
prQIdent_ :: QIdent -> String
prQIdent_ (_,f) = prt f
-- | print terms without qualifications
prExp :: Term -> String
prExp e = case e of
App f a -> pr1 f +++ pr2 a
Abs x b -> "\\" ++ prt x +++ "->" +++ prExp b
Prod x a b -> "(\\" ++ prt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b
Q _ c -> prt c
QC _ c -> prt c
_ -> prt e
where
pr1 e = case e of
Abs _ _ -> prParenth $ prExp e
Prod _ _ _ -> prParenth $ prExp e
_ -> prExp e
pr2 e = case e of
App _ _ -> prParenth $ prExp e
_ -> pr1 e
-- | option @-strip@ strips qualifications
prTermOpt :: Options -> Term -> String
prTermOpt opts = if PrinterStrip `elem` flag optPrinter opts then prt else prExp
-- | to get rid of brackets in the editor
prRefinement :: Term -> String
prRefinement t = case t of
Q m c -> prQIdent (m,c)
QC m c -> prQIdent (m,c)
_ -> prt t
prOperSignature :: (QIdent,Type) -> String
prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t
-- to look up a constant etc in a search tree --- why here? AR 29/5/2008
lookupIdent :: Ident -> BinTree Ident b -> Err b
lookupIdent c t = case lookupTree prt c t of
Ok v -> return v
_ -> prtBad "unknown identifier" c
lookupIdentInfo :: Module Ident a -> Ident -> Err a
lookupIdentInfo mo i = lookupIdent i (jments mo)
lookupIdentInfoIn :: Module Ident a -> Ident -> Ident -> Err a
lookupIdentInfoIn mo m i =
err (\s -> Bad (s +++ "in module" +++ prt m)) return $ lookupIdentInfo mo i
--- printing cc command output AR 26/5/2008
prTermTabular :: Term -> [(String,String)]
prTermTabular = pr where
pr t = case t of
R rs ->
[(prt_ lab +++ "." +++ path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val]
T _ cs ->
[(prt_ lab +++"=>" +++ path, str) | (lab, val) <- cs, (path,str) <- pr val]
V _ cs ->
[("#" ++ show i +++"=>" +++ path, str) | (i,val) <- zip [0..] cs, (path,str) <- pr val]
_ -> [([],ps t)]
ps t = case t of
K s -> s
C s u -> ps s +++ ps u
FV ts -> unwords (intersperse "/" (map ps ts))
_ -> prt_ t

177
src/GF/Grammar/Predef.hs Normal file
View File

@@ -0,0 +1,177 @@
----------------------------------------------------------------------
-- |
-- Module : GF.Grammar.Predef
-- Maintainer : kr.angelov
-- Stability : (stable)
-- Portability : (portable)
--
-- Predefined identifiers and labels which the compiler knows
----------------------------------------------------------------------
module GF.Grammar.Predef
( cType
, cPType
, cTok
, cStr
, cStrs
, cPredefAbs, cPredef
, cInt
, cFloat
, cString
, cInts
, cPBool
, cErrorType
, cOverload
, cUndefinedType
, isPredefCat
, cPTrue, cPFalse
, cLength, cDrop, cTake, cTk, cDp, cEqStr, cOccur
, cOccurs, cEqInt, cLessInt, cPlus, cShow, cRead
, cToStr, cMapStr, cError
-- hacks
, cMeta, cAs, cChar, cChars, cSeq, cAlt, cRep
, cNeg, cCNC, cConflict
) where
import GF.Infra.Ident
import qualified Data.ByteString.Char8 as BS
cType :: Ident
cType = identC (BS.pack "Type")
cPType :: Ident
cPType = identC (BS.pack "PType")
cTok :: Ident
cTok = identC (BS.pack "Tok")
cStr :: Ident
cStr = identC (BS.pack "Str")
cStrs :: Ident
cStrs = identC (BS.pack "Strs")
cPredefAbs :: Ident
cPredefAbs = identC (BS.pack "PredefAbs")
cPredef :: Ident
cPredef = identC (BS.pack "Predef")
cInt :: Ident
cInt = identC (BS.pack "Int")
cFloat :: Ident
cFloat = identC (BS.pack "Float")
cString :: Ident
cString = identC (BS.pack "String")
cInts :: Ident
cInts = identC (BS.pack "Ints")
cPBool :: Ident
cPBool = identC (BS.pack "PBool")
cErrorType :: Ident
cErrorType = identC (BS.pack "Error")
cOverload :: Ident
cOverload = identC (BS.pack "overload")
cUndefinedType :: Ident
cUndefinedType = identC (BS.pack "UndefinedType")
isPredefCat :: Ident -> Bool
isPredefCat c = elem c [cInt,cString,cFloat]
cPTrue :: Ident
cPTrue = identC (BS.pack "PTrue")
cPFalse :: Ident
cPFalse = identC (BS.pack "PFalse")
cLength :: Ident
cLength = identC (BS.pack "length")
cDrop :: Ident
cDrop = identC (BS.pack "drop")
cTake :: Ident
cTake = identC (BS.pack "take")
cTk :: Ident
cTk = identC (BS.pack "tk")
cDp :: Ident
cDp = identC (BS.pack "dp")
cEqStr :: Ident
cEqStr = identC (BS.pack "eqStr")
cOccur :: Ident
cOccur = identC (BS.pack "occur")
cOccurs :: Ident
cOccurs = identC (BS.pack "occurs")
cEqInt :: Ident
cEqInt = identC (BS.pack "eqInt")
cLessInt :: Ident
cLessInt = identC (BS.pack "lessInt")
cPlus :: Ident
cPlus = identC (BS.pack "plus")
cShow :: Ident
cShow = identC (BS.pack "show")
cRead :: Ident
cRead = identC (BS.pack "read")
cToStr :: Ident
cToStr = identC (BS.pack "toStr")
cMapStr :: Ident
cMapStr = identC (BS.pack "mapStr")
cError :: Ident
cError = identC (BS.pack "error")
--- hacks: dummy identifiers used in various places
--- Not very nice!
cMeta :: Ident
cMeta = identC (BS.singleton '?')
cAs :: Ident
cAs = identC (BS.singleton '@')
cChar :: Ident
cChar = identC (BS.singleton '?')
cChars :: Ident
cChars = identC (BS.pack "[]")
cSeq :: Ident
cSeq = identC (BS.pack "+")
cAlt :: Ident
cAlt = identC (BS.pack "|")
cRep :: Ident
cRep = identC (BS.pack "*")
cNeg :: Ident
cNeg = identC (BS.pack "-")
cCNC :: Ident
cCNC = identC (BS.pack "CNC")
cConflict :: Ident
cConflict = IC (BS.pack "#conflict")

44
src/GF/Grammar/ReservedWords.hs Normal file
View File

@@ -0,0 +1,44 @@
----------------------------------------------------------------------
-- |
-- Module : ReservedWords
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:28 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.5 $
--
-- reserved words of GF. (c) Aarne Ranta 19\/3\/2002 under Gnu GPL.
-- modified by Markus Forsberg 9\/4.
-- modified by AR 12\/6\/2003 for GF2 and GFC
-----------------------------------------------------------------------------
module GF.Grammar.ReservedWords (isResWord, isResWordGFC) where
import Data.List
isResWord :: String -> Bool
isResWord s = isInTree s resWordTree
resWordTree :: BTree
resWordTree =
-- mapTree fst $ sorted2tree $ flip zip (repeat ()) $ sort allReservedWords
-- nowadays obtained from LexGF.hs
B "let" (B "data" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "concrete" N N))) (B "in" (B "fn" (B "flags" (B "def" N N) N) (B "grammar" (B "fun" N N) N)) (B "instance" (B "incomplete" (B "include" N N) N) (B "interface" N N)))) (B "pre" (B "open" (B "lindef" (B "lincat" (B "lin" N N) N) (B "of" (B "lintype" N N) N)) (B "param" (B "out" (B "oper" N N) N) (B "pattern" N N))) (B "transfer" (B "reuse" (B "resource" (B "printname" N N) N) (B "table" (B "strs" N N) N)) (B "where" (B "variants" (B "union" N N) N) (B "with" N N))))
isResWordGFC :: String -> Bool
isResWordGFC s = isInTree s $
B "of" (B "fun" (B "concrete" (B "cat" (B "abstract" N N) N) (B "flags" N N)) (B "lin" (B "in" N N) (B "lincat" N N))) (B "resource" (B "param" (B "oper" (B "open" N N) N) (B "pre" N N)) (B "table" (B "strs" N N) (B "variants" N N)))
data BTree = N | B String BTree BTree deriving (Show)
isInTree :: String -> BTree -> Bool
isInTree x tree = case tree of
N -> False
B a left right
| x < a -> isInTree x left
| x > a -> isInTree x right
| x == a -> True

96
src/GF/Grammar/Unify.hs Normal file
View File

@@ -0,0 +1,96 @@
----------------------------------------------------------------------
-- |
-- Module : Unify
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:31 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.4 $
--
-- (c) Petri Mäenpää & Aarne Ranta, 1998--2001
--
-- brute-force adaptation of the old-GF program AR 21\/12\/2001 ---
-- the only use is in 'TypeCheck.splitConstraints'
-----------------------------------------------------------------------------
module GF.Grammar.Unify (unifyVal) where
import GF.Grammar.Abstract
import GF.Data.Operations
import Data.List (partition)
unifyVal :: Constraints -> Err (Constraints,MetaSubst)
unifyVal cs0 = do
let (cs1,cs2) = partition notSolvable cs0
let (us,vs) = unzip cs1
us' <- mapM val2exp us
vs' <- mapM val2exp vs
let (ms,cs) = unifyAll (zip us' vs') []
return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs],
[(m, VClos [] t) | (m,t) <- ms])
where
notSolvable (v,w) = case (v,w) of -- don't consider nonempty closures
(VClos (_:_) _,_) -> True
(_,VClos (_:_) _) -> True
_ -> False
type Unifier = [(MetaSymb, Trm)]
type Constrs = [(Trm, Trm)]
unifyAll :: Constrs -> Unifier -> (Unifier,Constrs)
unifyAll [] g = (g, [])
unifyAll ((a@(s, t)) : l) g =
let (g1, c) = unifyAll l g
in case unify s t g1 of
Ok g2 -> (g2, c)
_ -> (g1, a : c)
unify :: Trm -> Trm -> Unifier -> Err Unifier
unify e1 e2 g =
case (e1, e2) of
(Meta s, t) -> do
tg <- subst_all g t
let sg = maybe e1 id (lookup s g)
if (sg == Meta s) then extend g s tg else unify sg tg g
(t, Meta s) -> unify e2 e1 g
(Q _ a, Q _ b) | (a == b) -> return g ---- qualif?
(QC _ a, QC _ b) | (a == b) -> return g ----
(Vr x, Vr y) | (x == y) -> return g
(Abs x b, Abs y c) -> do let c' = substTerm [x] [(y,Vr x)] c
unify b c' g
(App c a, App d b) -> case unify c d g of
Ok g1 -> unify a b g1
_ -> prtBad "fail unify" e1
_ -> prtBad "fail unify" e1
extend :: Unifier -> MetaSymb -> Trm -> Err Unifier
extend g s t | (t == Meta s) = return g
| occCheck s t = prtBad "occurs check" t
| True = return ((s, t) : g)
subst_all :: Unifier -> Trm -> Err Trm
subst_all s u =
case (s,u) of
([], t) -> return t
(a : l, t) -> do
t' <- (subst_all l t) --- successive substs - why ?
return $ substMetas [a] t'
substMetas :: [(MetaSymb,Trm)] -> Trm -> Trm
substMetas subst trm = case trm of
Meta x -> case lookup x subst of
Just t -> t
_ -> trm
_ -> composSafeOp (substMetas subst) trm
occCheck :: MetaSymb -> Trm -> Bool
occCheck s u = case u of
Meta v -> s == v
App c a -> occCheck s c || occCheck s a
Abs x b -> occCheck s b
_ -> False

91
src/GF/Grammar/Values.hs Normal file
View File

@@ -0,0 +1,91 @@
----------------------------------------------------------------------
-- |
-- Module : Values
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:32 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.7 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Grammar.Values (-- * values used in TC type checking
Exp, Val(..), Env,
-- * annotated tree used in editing
Tree, TrNode(..), Atom(..), Binds, Constraints, MetaSubst,
-- * for TC
valAbsInt, valAbsFloat, valAbsString, vType,
isPredefCat,
eType, tree2exp, loc2treeFocus
) where
import GF.Data.Operations
import GF.Data.Zipper
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Predef
-- values used in TC type checking
type Exp = Term
data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VType | VClos Env Exp
deriving (Eq,Show)
type Env = [(Ident,Val)]
-- annotated tree used in editing
type Tree = Tr TrNode
newtype TrNode = N (Binds,Atom,Val,(Constraints,MetaSubst),Bool)
deriving (Eq,Show)
data Atom =
AtC Fun | AtM MetaSymb | AtV Ident | AtL String | AtI Integer | AtF Double
deriving (Eq,Show)
type Binds = [(Ident,Val)]
type Constraints = [(Val,Val)]
type MetaSubst = [(MetaSymb,Val)]
-- for TC
valAbsInt :: Val
valAbsInt = VCn (cPredefAbs, cInt)
valAbsFloat :: Val
valAbsFloat = VCn (cPredefAbs, cFloat)
valAbsString :: Val
valAbsString = VCn (cPredefAbs, cString)
vType :: Val
vType = VType
eType :: Exp
eType = Sort cType
tree2exp :: Tree -> Exp
tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where
at' = case at of
AtC (m,c) -> Q m c
AtV i -> Vr i
AtM m -> Meta m
AtL s -> K s
AtI s -> EInt s
AtF s -> EFloat s
bi' = map fst bi
ts' = map tree2exp ts
loc2treeFocus :: Loc TrNode -> Tree
loc2treeFocus (Loc (Tr (a,ts),p)) =
loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p))
where
(mark, nomark) = (\(N (a,b,c,d,_)) -> N(a,b,c,d,True),
\(N (a,b,c,d,_)) -> N(a,b,c,d,False))

89
src/GF/Infra/CheckM.hs Normal file
View File

@@ -0,0 +1,89 @@
----------------------------------------------------------------------
-- |
-- Module : CheckM
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:33 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Infra.CheckM (Check,
checkError, checkCond, checkWarn, checkUpdate, checkInContext,
checkUpdates, checkReset, checkResets, checkGetContext,
checkLookup, checkStart, checkErr, checkVal, checkIn,
prtFail
) where
import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Grammar.PrGrammar
-- | the strings are non-fatal warnings
type Check a = STM (Context,[String]) a
checkError :: String -> Check a
checkError = raise
checkCond :: String -> Bool -> Check ()
checkCond s b = if b then return () else checkError s
-- | warnings should be reversed in the end
checkWarn :: String -> Check ()
checkWarn s = updateSTM (\ (cont,msg) -> (cont, s:msg))
checkUpdate :: Decl -> Check ()
checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg))
checkInContext :: [Decl] -> Check r -> Check r
checkInContext g ch = do
i <- checkUpdates g
r <- ch
checkResets i
return r
checkUpdates :: [Decl] -> Check Int
checkUpdates ds = mapM checkUpdate ds >> return (length ds)
checkReset :: Check ()
checkReset = checkResets 1
checkResets :: Int -> Check ()
checkResets i = updateSTM (\ (cont,msg) -> (drop i cont, msg))
checkGetContext :: Check Context
checkGetContext = do
(co,_) <- readSTM
return co
checkLookup :: Ident -> Check Type
checkLookup x = do
co <- checkGetContext
checkErr $ maybe (prtBad "unknown variable" x) return $ lookup x co
checkStart :: Check a -> Err (a,(Context,[String]))
checkStart c = appSTM c ([],[])
checkErr :: Err a -> Check a
checkErr e = stm (\s -> do
v <- e
return (v,s)
)
checkVal :: a -> Check a
checkVal v = return v
prtFail :: Print a => String -> a -> Check b
prtFail s t = checkErr $ prtBad s t
checkIn :: String -> Check a -> Check a
checkIn msg c = stm $ \s@(g,ws) -> case appSTM c s of
Bad e -> Bad $ msg ++++ e
Ok (v,(g',ws')) -> Ok (v,(g',ws2)) where
new = take (length ws' - length ws) ws'
ws2 = [msg ++++ w | w <- new] ++ ws

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

@@ -0,0 +1,22 @@
module GF.Infra.CompactPrint where
import Data.Char
compactPrint = compactPrintCustom keywordGF (const False)
compactPrintGFCC = compactPrintCustom (const False) keywordGFCC
compactPrintCustom pre post = dps . concat . map (spaceIf pre post) . words
dps = dropWhile isSpace
spaceIf pre post w = case w of
_ | pre w -> "\n" ++ w
_ | post w -> w ++ "\n"
c:_ | isAlpha c || isDigit c -> " " ++ w
'_':_ -> " " ++ w
_ -> w
keywordGF w = elem w ["cat","fun","lin","lincat","lindef","oper","param"]
keywordGFCC w =
last w == ';' ||
elem w ["flags","fun","cat","lin","oper","lincat","lindef","printname","param"]

381
src/GF/Infra/GetOpt.hs Normal file
View File

@@ -0,0 +1,381 @@
-- This is a version of System.Console.GetOpt which has been hacked to
-- support long options with a single dash. Since we don't want the annoying
-- clash with short options that start with the same character as a long
-- one, we don't allow short options to be given together (e.g. -zxf),
-- nor do we allow options to be given as any unique prefix.
-----------------------------------------------------------------------------
-- |
-- Module : System.Console.GetOpt
-- Copyright : (c) Sven Panne 2002-2005
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : portable
--
-- This library provides facilities for parsing the command-line options
-- in a standalone program. It is essentially a Haskell port of the GNU
-- @getopt@ library.
--
-----------------------------------------------------------------------------
{-
Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
changes Dec. 1997)
Two rather obscure features are missing: The Bash 2.0 non-option hack
(if you don't already know it, you probably don't want to hear about
it...) and the recognition of long options with a single dash
(e.g. '-help' is recognised as '--help', as long as there is no short
option 'h').
Other differences between GNU's getopt and this implementation:
* To enforce a coherent description of options and arguments, there
are explanation fields in the option/argument descriptor.
* Error messages are now more informative, but no longer POSIX
compliant... :-(
And a final Haskell advertisement: The GNU C implementation uses well
over 1100 lines, we need only 195 here, including a 46 line example!
:-)
-}
--module System.Console.GetOpt (
module GF.Infra.GetOpt (
-- * GetOpt
getOpt, getOpt',
usageInfo,
ArgOrder(..),
OptDescr(..),
ArgDescr(..),
-- * Examples
-- |To hopefully illuminate the role of the different data structures,
-- here are the command-line options for a (very simple) compiler,
-- done in two different ways.
-- The difference arises because the type of 'getOpt' is
-- parameterized by the type of values derived from flags.
-- ** Interpreting flags as concrete values
-- $example1
-- ** Interpreting flags as transformations of an options record
-- $example2
) where
import Prelude -- necessary to get dependencies right
import Data.List ( isPrefixOf, find )
-- |What to do with options following non-options
data ArgOrder a
= RequireOrder -- ^ no option processing after first non-option
| Permute -- ^ freely intersperse options and non-options
| ReturnInOrder (String -> a) -- ^ wrap non-options into options
{-|
Each 'OptDescr' describes a single option.
The arguments to 'Option' are:
* list of short option characters
* list of long option strings (without \"--\")
* argument descriptor
* explanation of option for user
-}
data OptDescr a = -- description of a single options:
Option [Char] -- list of short option characters
[String] -- list of long option strings (without "--")
(ArgDescr a) -- argument descriptor
String -- explanation of option for user
-- |Describes whether an option takes an argument or not, and if so
-- how the argument is injected into a value of type @a@.
data ArgDescr a
= NoArg a -- ^ no argument expected
| ReqArg (String -> a) String -- ^ option requires argument
| OptArg (Maybe String -> a) String -- ^ optional argument
data OptKind a -- kind of cmd line arg (internal use only):
= Opt a -- an option
| UnreqOpt String -- an un-recognized option
| NonOpt String -- a non-option
| EndOfOpts -- end-of-options marker (i.e. "--")
| OptErr String -- something went wrong...
-- | Return a string describing the usage of a command, derived from
-- the header (first argument) and the options described by the
-- second argument.
usageInfo :: String -- header
-> [OptDescr a] -- option descriptors
-> String -- nicely formatted decription of options
usageInfo header optDescr = unlines (header:table)
where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr
table = zipWith3 paste (sameLen ss) (sameLen ls) ds
paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z
sameLen xs = flushLeft ((maximum . map length) xs) xs
flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]
fmtOpt :: OptDescr a -> [(String,String,String)]
fmtOpt (Option sos los ad descr) =
case lines descr of
[] -> [(sosFmt,losFmt,"")]
(d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ]
where sepBy _ [] = ""
sepBy _ [x] = x
sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs
sosFmt = sepBy ',' (map (fmtShort ad) sos)
losFmt = sepBy ',' (map (fmtLong ad) los)
fmtShort :: ArgDescr a -> Char -> String
fmtShort (NoArg _ ) so = "-" ++ [so]
fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad
fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"
fmtLong :: ArgDescr a -> String -> String
fmtLong (NoArg _ ) lo = "--" ++ lo
fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
{-|
Process the command-line, and return the list of values that matched
(and those that didn\'t). The arguments are:
* The order requirements (see 'ArgOrder')
* The option descriptions (see 'OptDescr')
* The actual command line arguments (presumably got from
'System.Environment.getArgs').
'getOpt' returns a triple consisting of the option arguments, a list
of non-options, and a list of error messages.
-}
getOpt :: ArgOrder a -- non-option handling
-> [OptDescr a] -- option descriptors
-> [String] -- the command-line arguments
-> ([a],[String],[String]) -- (options,non-options,error messages)
getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)
where (os,xs,us,es) = getOpt' ordering optDescr args
{-|
This is almost the same as 'getOpt', but returns a quadruple
consisting of the option arguments, a list of non-options, a list of
unrecognized options, and a list of error messages.
-}
getOpt' :: ArgOrder a -- non-option handling
-> [OptDescr a] -- option descriptors
-> [String] -- the command-line arguments
-> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)
getOpt' _ _ [] = ([],[],[],[])
getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
where procNextOpt (Opt o) _ = (o:os,xs,us,es)
procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es)
procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[])
procNextOpt (NonOpt x) Permute = (os,x:xs,us,es)
procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es)
procNextOpt EndOfOpts RequireOrder = ([],rest,[],[])
procNextOpt EndOfOpts Permute = ([],rest,[],[])
procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[])
procNextOpt (OptErr e) _ = (os,xs,us,e:es)
(opt,rest) = getNext arg args optDescr
(os,xs,us,es) = getOpt' ordering optDescr rest
-- take a look at the next cmd line arg and decide what to do with it
getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)
getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
getNext ('-' :xs) rest optDescr = longOpt xs rest optDescr
getNext a rest _ = (NonOpt a,rest)
-- handle long option
longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
longOpt ls rs optDescr = long ads arg rs
where (opt,arg) = break (=='=') ls
options = [ o | o@(Option ss xs _ _) <- optDescr
, opt `elem` map (:[]) ss || opt `elem` xs ]
ads = [ ad | Option _ _ ad _ <- options ]
optStr = ("--"++opt)
long (_:_:_) _ rest = (errAmbig options optStr,rest)
long [NoArg a ] [] rest = (Opt a,rest)
long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)
long [ReqArg _ d] [] [] = (errReq d optStr,[])
long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)
long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)
long [OptArg f _] [] rest = (Opt (f Nothing),rest)
long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)
long _ _ rest = (UnreqOpt ("--"++ls),rest)
-- miscellaneous error formatting
errAmbig :: [OptDescr a] -> String -> OptKind a
errAmbig ods optStr = OptErr (usageInfo header ods)
where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
errReq :: String -> String -> OptKind a
errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
errUnrec :: String -> String
errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
errNoArg :: String -> OptKind a
errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
{-
-----------------------------------------------------------------------------------------
-- and here a small and hopefully enlightening example:
data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show
options :: [OptDescr Flag]
options =
[Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files",
Option ['V','?'] ["version","release"] (NoArg Version) "show version info",
Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump",
Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"]
out :: Maybe String -> Flag
out Nothing = Output "stdout"
out (Just o) = Output o
test :: ArgOrder Flag -> [String] -> String
test order cmdline = case getOpt order options cmdline of
(o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n"
(_,_,errs) -> concat errs ++ usageInfo header options
where header = "Usage: foobar [OPTION...] files..."
-- example runs:
-- putStr (test RequireOrder ["foo","-v"])
-- ==> options=[] args=["foo", "-v"]
-- putStr (test Permute ["foo","-v"])
-- ==> options=[Verbose] args=["foo"]
-- putStr (test (ReturnInOrder Arg) ["foo","-v"])
-- ==> options=[Arg "foo", Verbose] args=[]
-- putStr (test Permute ["foo","--","-v"])
-- ==> options=[] args=["foo", "-v"]
-- putStr (test Permute ["-?o","--name","bar","--na=baz"])
-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[]
-- putStr (test Permute ["--ver","foo"])
-- ==> option `--ver' is ambiguous; could be one of:
-- -v --verbose verbosely list files
-- -V, -? --version, --release show version info
-- Usage: foobar [OPTION...] files...
-- -v --verbose verbosely list files
-- -V, -? --version, --release show version info
-- -o[FILE] --output[=FILE] use FILE for dump
-- -n USER --name=USER only dump USER's files
-----------------------------------------------------------------------------------------
-}
{- $example1
A simple choice for the type associated with flags is to define a type
@Flag@ as an algebraic type representing the possible flags and their
arguments:
> module Opts1 where
>
> import System.Console.GetOpt
> import Data.Maybe ( fromMaybe )
>
> data Flag
> = Verbose | Version
> | Input String | Output String | LibDir String
> deriving Show
>
> options :: [OptDescr Flag]
> options =
> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr"
> , Option ['V','?'] ["version"] (NoArg Version) "show version number"
> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE"
> , Option ['c'] [] (OptArg inp "FILE") "input FILE"
> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory"
> ]
>
> inp,outp :: Maybe String -> Flag
> outp = Output . fromMaybe "stdout"
> inp = Input . fromMaybe "stdin"
>
> compilerOpts :: [String] -> IO ([Flag], [String])
> compilerOpts argv =
> case getOpt Permute options argv of
> (o,n,[] ) -> return (o,n)
> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
> where header = "Usage: ic [OPTION...] files..."
Then the rest of the program will use the constructed list of flags
to determine it\'s behaviour.
-}
{- $example2
A different approach is to group the option values in a record of type
@Options@, and have each flag yield a function of type
@Options -> Options@ transforming this record.
> module Opts2 where
>
> import System.Console.GetOpt
> import Data.Maybe ( fromMaybe )
>
> data Options = Options
> { optVerbose :: Bool
> , optShowVersion :: Bool
> , optOutput :: Maybe FilePath
> , optInput :: Maybe FilePath
> , optLibDirs :: [FilePath]
> } deriving Show
>
> defaultOptions = Options
> { optVerbose = False
> , optShowVersion = False
> , optOutput = Nothing
> , optInput = Nothing
> , optLibDirs = []
> }
>
> options :: [OptDescr (Options -> Options)]
> options =
> [ Option ['v'] ["verbose"]
> (NoArg (\ opts -> opts { optVerbose = True }))
> "chatty output on stderr"
> , Option ['V','?'] ["version"]
> (NoArg (\ opts -> opts { optShowVersion = True }))
> "show version number"
> , Option ['o'] ["output"]
> (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output")
> "FILE")
> "output FILE"
> , Option ['c'] []
> (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input")
> "FILE")
> "input FILE"
> , Option ['L'] ["libdir"]
> (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR")
> "library directory"
> ]
>
> compilerOpts :: [String] -> IO (Options, [String])
> compilerOpts argv =
> case getOpt Permute options argv of
> (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)
> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
> where header = "Usage: ic [OPTION...] files..."
Similarly, each flag could yield a monadic function transforming a record,
of type @Options -> IO Options@ (or any other monad), allowing option
processing to perform actions of the chosen monad, e.g. printing help or
version messages, checking that file arguments exist, etc.
-}

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

@@ -0,0 +1,152 @@
----------------------------------------------------------------------
-- |
-- Module : Ident
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/15 11:43:33 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.8 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Infra.Ident (-- * Identifiers
Ident(..), ident2bs, prIdent,
identC, identV, identA, identAV, identW,
argIdent, varStr, varX, isWildIdent, varIndex,
-- * refreshing identifiers
IdState, initIdStateN, initIdState,
lookVar, refVar, refVarPlus
) where
import GF.Data.Operations
import qualified Data.ByteString.Char8 as BS
-- import Monad
-- | the constructors labelled /INTERNAL/ are
-- internal representation never returned by the parser
data Ident =
IC {-# UNPACK #-} !BS.ByteString -- ^ raw identifier after parsing, resolved in Rename
| IW -- ^ wildcard
--
-- below this constructor: internal representation never returned by the parser
| IV {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int -- ^ /INTERNAL/ variable
| IA {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat at position
| IAV {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat with bindings at position
--
deriving (Eq, Ord, Show, Read)
ident2bs :: Ident -> BS.ByteString
ident2bs i = case i of
IC s -> s
IV s n -> BS.append s (BS.pack ('_':show n))
IA s j -> BS.append s (BS.pack ('_':show j))
IAV s b j -> BS.append s (BS.pack ('_':show b ++ '_':show j))
IW -> BS.pack "_"
prIdent :: Ident -> String
prIdent i = BS.unpack $! ident2bs i
identC :: BS.ByteString -> Ident
identV :: BS.ByteString -> Int -> Ident
identA :: BS.ByteString -> Int -> Ident
identAV:: BS.ByteString -> Int -> Int -> Ident
identW :: Ident
(identC, identV, identA, identAV, identW) =
(IC, IV, IA, IAV, IW)
-- normal identifier
-- ident s = IC s
-- | to mark argument variables
argIdent :: Int -> Ident -> Int -> Ident
argIdent 0 (IC c) i = identA c i
argIdent b (IC c) i = identAV c b i
-- | used in lin defaults
varStr :: Ident
varStr = identA (BS.pack "str") 0
-- | refreshing variables
varX :: Int -> Ident
varX = identV (BS.pack "x")
isWildIdent :: Ident -> Bool
isWildIdent x = case x of
IW -> True
IC s | s == BS.pack "_" -> True
_ -> False
varIndex :: Ident -> Int
varIndex (IV _ n) = n
varIndex _ = -1 --- other than IV should not count
-- refreshing identifiers
type IdState = ([(Ident,Ident)],Int)
initIdStateN :: Int -> IdState
initIdStateN i = ([],i)
initIdState :: IdState
initIdState = initIdStateN 0
lookVar :: Ident -> STM IdState Ident
lookVar a@(IA _ _) = return a
lookVar x = do
(sys,_) <- readSTM
stm (\s -> maybe (Bad ("cannot find" +++ show x +++ prParenth (show sys)))
return $
lookup x sys >>= (\y -> return (y,s)))
refVar :: Ident -> STM IdState Ident
----refVar IW = return IW --- no update of wildcard
refVar x = do
(_,m) <- readSTM
let x' = IV (ident2bs x) m
updateSTM (\(sys,mx) -> ((x, x'):sys, mx + 1))
return x'
refVarPlus :: Ident -> STM IdState Ident
----refVarPlus IW = refVar (identC "h")
refVarPlus x = refVar x
{-
------------------------------
-- to test
refreshExp :: Exp -> Err Exp
refreshExp e = err Bad (return . fst) (appSTM (refresh e) initState)
refresh :: Exp -> STM State Exp
refresh e = case e of
Atom x -> lookVar x >>= return . Atom
App f a -> liftM2 App (refresh f) (refresh a)
Abs x b -> liftM2 Abs (refVar x) (refresh b)
Fun xs a b -> do
a' <- refresh a
xs' <- mapM refVar xs
b' <- refresh b
return $ Fun xs' a' b'
data Exp =
Atom Ident
| App Exp Exp
| Abs Ident Exp
| Fun [Ident] Exp Exp
deriving Show
exp1 = Abs (IC "y") (Atom (IC "y"))
exp2 = Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y")))
exp3 = Abs (IC "y") (Abs (IC "z") (App (Atom (IC "y")) (Atom (IC "z"))))
exp4 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "z"))))
exp5 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y"))))
exp6 = Abs (IC "y") (Fun [IC "x", IC "y"] (Atom (IC "y")) (Atom (IC "y")))
exp7 = Abs (IL "8") (Atom (IC "y"))
-}

429
src/GF/Infra/Modules.hs Normal file
View File

@@ -0,0 +1,429 @@
----------------------------------------------------------------------
-- |
-- Module : Modules
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/09 15:14:30 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.26 $
--
-- Datastructures and functions for modules, common to GF and GFC.
--
-- AR 29\/4\/2003
--
-- The same structure will be used in both source code and canonical.
-- The parameters tell what kind of data is involved.
-- Invariant: modules are stored in dependency order
-----------------------------------------------------------------------------
module GF.Infra.Modules (
MGrammar(..), ModInfo(..), Module(..), ModuleType(..),
MReuseType(..), MInclude (..),
extends, isInherited,inheritAll,
updateMGrammar, updateModule, replaceJudgements, addFlag,
addOpenQualif, flagsModule, allFlags, mapModules,
MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..),
oSimple, oQualif,
ModuleStatus(..),
openedModule, allOpens, depPathModule, allDepsModule, partOfGrammar,
allExtends, allExtendSpecs, allExtendsPlus, allExtensions,
searchPathModule, addModule,
emptyMGrammar, emptyModInfo, emptyModule,
IdentM(..),
typeOfModule, abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupModMod, lookupInfo,
lookupPosition, showPosition,
allModMod, isModAbs, isModRes, isModCnc, isModTrans,
sameMType, isCompilableModule, isCompleteModule,
allAbstracts, greatestAbstract, allResources,
greatestResource, allConcretes, allConcreteModules
) where
import GF.Infra.Ident
import GF.Infra.Option
import GF.Data.Operations
import Data.List
-- AR 29/4/2003
-- The same structure will be used in both source code and canonical.
-- The parameters tell what kind of data is involved.
-- Invariant: modules are stored in dependency order
data MGrammar i a = MGrammar {modules :: [(i,ModInfo i a)]}
deriving Show
data ModInfo i a =
ModMainGrammar (MainGrammar i)
| ModMod (Module i a)
| ModWith (Module i a) (i,MInclude i) [OpenSpec i]
deriving Show
data Module i a = Module {
mtype :: ModuleType i ,
mstatus :: ModuleStatus ,
flags :: ModuleOptions,
extend :: [(i,MInclude i)],
opens :: [OpenSpec i] ,
jments :: BinTree i a ,
positions :: BinTree i (String,(Int,Int)) -- file, first line, last line
}
--- deriving Show
instance Show (Module i a) where
show _ = "cannot show Module with FiniteMap"
-- | encoding the type of the module
data ModuleType i =
MTAbstract
| MTTransfer (OpenSpec i) (OpenSpec i)
| MTResource
| MTConcrete i
-- ^ up to this, also used in GFC. Below, source only.
| MTInterface
| MTInstance i
| MTReuse (MReuseType i)
| MTUnion (ModuleType i) [(i,[i])] -- ^ not meant to be recursive
deriving (Eq,Show)
data MReuseType i = MRInterface i | MRInstance i i | MRResource i
deriving (Show,Eq)
data MInclude i = MIAll | MIOnly [i] | MIExcept [i]
deriving (Show,Eq)
extends :: Module i a -> [i]
extends = map fst . extend
isInherited :: Eq i => MInclude i -> i -> Bool
isInherited c i = case c of
MIAll -> True
MIOnly is -> elem i is
MIExcept is -> notElem i is
inheritAll :: i -> (i,MInclude i)
inheritAll i = (i,MIAll)
-- destructive update
-- | dep order preserved since old cannot depend on new
updateMGrammar :: Ord i => MGrammar i a -> MGrammar i a -> MGrammar i a
updateMGrammar old new = MGrammar $
[(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns
where
os = modules old
ns = modules new
updateModule :: Ord i => Module i t -> i -> t -> Module i t
updateModule (Module mt ms fs me ops js ps) i t =
Module mt ms fs me ops (updateTree (i,t) js) ps
replaceJudgements :: Module i t -> BinTree i t -> Module i t
replaceJudgements (Module mt ms fs me ops _ ps) js = Module mt ms fs me ops js ps
addOpenQualif :: i -> i -> Module i t -> Module i t
addOpenQualif i j (Module mt ms fs me ops js ps) =
Module mt ms fs me (oQualif i j : ops) js ps
addFlag :: ModuleOptions -> Module i t -> Module i t
addFlag f mo = mo {flags = addModuleOptions (flags mo) f}
flagsModule :: (i,ModInfo i a) -> ModuleOptions
flagsModule (_,mi) = case mi of
ModMod m -> flags m
_ -> noModuleOptions
allFlags :: MGrammar i a -> ModuleOptions
allFlags gr = concatModuleOptions $ map flags $ [m | (_, ModMod m) <- modules gr]
mapModules :: (Module i a -> Module i a)
-> MGrammar i a -> MGrammar i a
mapModules f = MGrammar . map (onSnd mapModules') . modules
where mapModules' (ModMod m) = ModMod (f m)
mapModules' m = m
data MainGrammar i = MainGrammar {
mainAbstract :: i ,
mainConcretes :: [MainConcreteSpec i]
}
deriving Show
data MainConcreteSpec i = MainConcreteSpec {
concretePrintname :: i ,
concreteName :: i ,
transferIn :: Maybe (OpenSpec i) , -- ^ if there is an in-transfer
transferOut :: Maybe (OpenSpec i) -- ^ if there is an out-transfer
}
deriving Show
data OpenSpec i =
OSimple OpenQualif i
| OQualif OpenQualif i i
deriving (Eq,Show)
data OpenQualif =
OQNormal
| OQInterface
| OQIncomplete
deriving (Eq,Show)
oSimple :: i -> OpenSpec i
oSimple = OSimple OQNormal
oQualif :: i -> i -> OpenSpec i
oQualif = OQualif OQNormal
data ModuleStatus =
MSComplete
| MSIncomplete
deriving (Eq,Show)
openedModule :: OpenSpec i -> i
openedModule o = case o of
OSimple _ m -> m
OQualif _ _ m -> m
allOpens :: Module i a -> [OpenSpec i]
allOpens m = case mtype m of
MTTransfer a b -> a : b : opens m
_ -> opens m
-- | initial dependency list
depPathModule :: Ord i => Module i a -> [OpenSpec i]
depPathModule m = fors m ++ exts m ++ opens m where
fors m = case mtype m of
MTTransfer i j -> [i,j]
MTConcrete i -> [oSimple i]
MTInstance i -> [oSimple i]
_ -> []
exts m = map oSimple $ extends m
-- | all dependencies
allDepsModule :: Ord i => MGrammar i a -> Module i a -> [OpenSpec i]
allDepsModule gr m = iterFix add os0 where
os0 = depPathModule m
add os = [m | o <- os, Just (ModMod n) <- [lookup (openedModule o) mods],
m <- depPathModule n]
mods = modules gr
-- | select just those modules that a given one depends on, including itself
partOfGrammar :: Ord i => MGrammar i a -> (i,ModInfo i a) -> MGrammar i a
partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
where
mods = modules gr
modsFor = case m of
ModMod n -> (i:) $ map openedModule $ allDepsModule gr n
---- ModWith n i os -> i : map openedModule os ++ partOfGrammar (ModMod n) ----
_ -> [i]
-- | all modules that a module extends, directly or indirectly, without restricts
allExtends :: (Show i,Ord i) => MGrammar i a -> i -> [i]
allExtends gr i = case lookupModule gr i of
Ok (ModMod m) -> case extends m of
[] -> [i]
is -> i : concatMap (allExtends gr) is
_ -> []
-- | all modules that a module extends, directly or indirectly, with restricts
allExtendSpecs :: (Show i,Ord i) => MGrammar i a -> i -> [(i,MInclude i)]
allExtendSpecs gr i = case lookupModule gr i of
Ok (ModMod m) -> case extend m of
[] -> [(i,MIAll)]
is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is
_ -> []
-- | this plus that an instance extends its interface
allExtendsPlus :: (Show i,Ord i) => MGrammar i a -> i -> [i]
allExtendsPlus gr i = case lookupModule gr i of
Ok (ModMod m) -> i : concatMap (allExtendsPlus gr) (exts m)
_ -> []
where
exts m = extends m ++ [j | MTInstance j <- [mtype m]]
-- | conversely: all modules that extend a given module, incl. instances of interface
allExtensions :: (Show i,Ord i) => MGrammar i a -> i -> [i]
allExtensions gr i = case lookupModule gr i of
Ok (ModMod m) -> let es = exts i in es ++ concatMap (allExtensions gr) es
_ -> []
where
exts i = [j | (j,m) <- mods, elem i (extends m)
|| elem (MTInstance i) [mtype m]]
mods = [(j,m) | (j,ModMod m) <- modules gr]
-- | initial search path: the nonqualified dependencies
searchPathModule :: Ord i => Module i a -> [i]
searchPathModule m = [i | OSimple _ i <- depPathModule m]
-- | a new module can safely be added to the end, since nothing old can depend on it
addModule :: Ord i =>
MGrammar i a -> i -> ModInfo i a -> MGrammar i a
addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)])
emptyMGrammar :: MGrammar i a
emptyMGrammar = MGrammar []
emptyModInfo :: ModInfo i a
emptyModInfo = ModMod emptyModule
emptyModule :: Module i a
emptyModule = Module
MTResource MSComplete noModuleOptions [] [] emptyBinTree emptyBinTree
-- | we store the module type with the identifier
data IdentM i = IdentM {
identM :: i ,
typeM :: ModuleType i
}
deriving (Eq,Show)
typeOfModule :: ModInfo i a -> ModuleType i
typeOfModule mi = case mi of
ModMod m -> mtype m
abstractOfConcrete :: (Show i, Eq i) => MGrammar i a -> i -> Err i
abstractOfConcrete gr c = do
m <- lookupModule gr c
case m of
ModMod n -> case mtype n of
MTConcrete a -> return a
_ -> Bad $ "expected concrete" +++ show c
_ -> Bad $ "expected concrete" +++ show c
abstractModOfConcrete :: (Show i, Eq i) =>
MGrammar i a -> i -> Err (Module i a)
abstractModOfConcrete gr c = do
a <- abstractOfConcrete gr c
m <- lookupModule gr a
case m of
ModMod n -> return n
_ -> Bad $ "expected abstract" +++ show c
-- the canonical file name
--- canonFileName s = prt s ++ ".gfc"
lookupModule :: (Show i,Eq i) => MGrammar i a -> i -> Err (ModInfo i a)
lookupModule gr m = case lookup m (modules gr) of
Just i -> return i
_ -> Bad $ "unknown module" +++ show m
+++ "among" +++ unwords (map (show . fst) (modules gr)) ---- debug
lookupModuleType :: (Show i,Eq i) => MGrammar i a -> i -> Err (ModuleType i)
lookupModuleType gr m = do
mi <- lookupModule gr m
return $ typeOfModule mi
lookupModMod :: (Show i,Eq i) => MGrammar i a -> i -> Err (Module i a)
lookupModMod gr i = do
mo <- lookupModule gr i
case mo of
ModMod m -> return m
_ -> Bad $ "expected proper module, not" +++ show i
lookupInfo :: (Show i, Ord i) => Module i a -> i -> Err a
lookupInfo mo i = lookupTree show i (jments mo)
lookupPosition :: (Show i, Ord i) => Module i a -> i -> Err (String,(Int,Int))
lookupPosition mo i = lookupTree show i (positions mo)
showPosition :: (Show i, Ord i) => Module i a -> i -> String
showPosition mo i = case lookupPosition mo i of
Ok (f,(b,e)) | b == e -> "in" +++ f ++ ", line" +++ show b
Ok (f,(b,e)) -> "in" +++ f ++ ", lines" +++ show b ++ "-" ++ show e
_ -> ""
allModMod :: (Show i,Eq i) => MGrammar i a -> [(i,Module i a)]
allModMod gr = [(i,m) | (i, ModMod m) <- modules gr]
isModAbs :: Module i a -> Bool
isModAbs m = case mtype m of
MTAbstract -> True
---- MTUnion t -> isModAbs t
_ -> False
isModRes :: Module i a -> Bool
isModRes m = case mtype m of
MTResource -> True
MTReuse _ -> True
---- MTUnion t -> isModRes t --- maybe not needed, since eliminated early
MTInterface -> True ---
MTInstance _ -> True
_ -> False
isModCnc :: Module i a -> Bool
isModCnc m = case mtype m of
MTConcrete _ -> True
---- MTUnion t -> isModCnc t
_ -> False
isModTrans :: Module i a -> Bool
isModTrans m = case mtype m of
MTTransfer _ _ -> True
---- MTUnion t -> isModTrans t
_ -> False
sameMType :: Eq i => ModuleType i -> ModuleType i -> Bool
sameMType m n = case (n,m) of
(MTConcrete _, MTConcrete _) -> True
(MTInstance _, MTInstance _) -> True
(MTInstance _, MTResource) -> True
(MTInstance _, MTConcrete _) -> True
(MTInterface, MTInstance _) -> True
(MTInterface, MTResource) -> True -- for reuse
(MTInterface, MTAbstract) -> True -- for reuse
(MTResource, MTInstance _) -> True
(MTResource, MTConcrete _) -> True -- for reuse
_ -> m == n
-- | don't generate code for interfaces and for incomplete modules
isCompilableModule :: ModInfo i a -> Bool
isCompilableModule m = case m of
ModMod m -> case mtype m of
MTInterface -> False
_ -> mstatus m == MSComplete
_ -> False ---
-- | interface and "incomplete M" are not complete
isCompleteModule :: (Eq i) => Module i a -> Bool
isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
-- | all abstract modules sorted from least to most dependent
allAbstracts :: Eq i => MGrammar i a -> [i]
allAbstracts gr = topoSort
[(i,extends m) | (i,ModMod m) <- modules gr, mtype m == MTAbstract]
-- | the last abstract in dependency order (head of list)
greatestAbstract :: Eq i => MGrammar i a -> Maybe i
greatestAbstract gr = case allAbstracts gr of
[] -> Nothing
as -> return $ last as
-- | all resource modules
allResources :: MGrammar i a -> [i]
allResources gr = [i | (i,ModMod m) <- modules gr, isModRes m || isModCnc m]
-- | the greatest resource in dependency order
greatestResource :: MGrammar i a -> Maybe i
greatestResource gr = case allResources gr of
[] -> Nothing
a -> return $ head a ---- why not last as in Abstract? works though AR 24/5/2008
-- | all concretes for a given abstract
allConcretes :: Eq i => MGrammar i a -> i -> [i]
allConcretes gr a =
[i | (i, ModMod m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
-- | all concrete modules for any abstract
allConcreteModules :: Eq i => MGrammar i a -> [i]
allConcreteModules gr =
[i | (i, ModMod m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]

549
src/GF/Infra/Option.hs Normal file
View File

@@ -0,0 +1,549 @@
module GF.Infra.Option
(
-- * Option types
Options, ModuleOptions,
Flags(..), ModuleFlags(..),
Mode(..), Phase(..), Verbosity(..), Encoding(..), OutputFormat(..),
SISRFormat(..), Optimization(..),
Dump(..), Printer(..), Recomp(..),
-- * Option parsing
parseOptions, parseModuleOptions,
-- * Option pretty-printing
moduleOptionsGFO,
-- * Option manipulation
addOptions, concatOptions, noOptions,
moduleOptions,
addModuleOptions, concatModuleOptions, noModuleOptions,
helpMessage,
-- * Checking specific options
flag, moduleFlag,
-- * Setting specific options
setOptimization,
-- * Convenience methods for checking options
verbAtLeast, dump
) where
import Control.Monad
import Data.Char (toLower)
import Data.List
import Data.Maybe
import GF.Infra.GetOpt
--import System.Console.GetOpt
import System.FilePath
import GF.Data.ErrM
import Data.Set (Set)
import qualified Data.Set as Set
usageHeader :: String
usageHeader = unlines
["Usage: gfc [OPTIONS] [FILE [...]]",
"",
"How each FILE is handled depends on the file name suffix:",
"",
".gf Normal or old GF source, will be compiled.",
".gfo Compiled GF source, will be loaded as is.",
".gfe Example-based GF source, will be converted to .gf and compiled.",
".ebnf Extended BNF format, will be converted to .gf and compiled.",
".cf Context-free (BNF) format, will be converted to .gf and compiled.",
"",
"If multiple FILES are given, they must be normal GF source, .gfo or .gfe files.",
"For the other input formats, only one file can be given.",
"",
"Command-line options:"]
helpMessage :: String
helpMessage = usageInfo usageHeader optDescr
-- FIXME: do we really want multi-line errors?
errors :: [String] -> Err a
errors = fail . unlines
-- Types
data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeCompiler
deriving (Show,Eq,Ord)
data Verbosity = Quiet | Normal | Verbose | Debug
deriving (Show,Eq,Ord,Enum,Bounded)
data Phase = Preproc | Convert | Compile | Link
deriving (Show,Eq,Ord)
data Encoding = UTF_8 | ISO_8859_1 | CP_1251
deriving (Show,Eq,Ord)
data OutputFormat = FmtPGF
| FmtJavaScript
| FmtHaskell
| FmtHaskell_GADT
| FmtBNF
| FmtSRGS_XML
| FmtSRGS_ABNF
| FmtJSGF
| FmtGSL
| FmtVoiceXML
| FmtSLF
| FmtRegExp
| FmtFA
deriving (Eq,Ord)
data SISRFormat =
-- | SISR Working draft 1 April 2003
-- <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/>
SISR_WD20030401
| SISR_1_0
deriving (Show,Eq,Ord)
data Optimization = OptStem | OptCSE | OptExpand | OptParametrize | OptValues
deriving (Show,Eq,Ord)
data Warning = WarnMissingLincat
deriving (Show,Eq,Ord)
data Dump = DumpRebuild | DumpExtend | DumpRename | DumpTypeCheck | DumpRefresh | DumpOptimize | DumpCanon
deriving (Show,Eq,Ord)
-- | Pretty-printing options
data Printer = PrinterStrip -- ^ Remove name qualifiers.
deriving (Show,Eq,Ord)
data Recomp = AlwaysRecomp | RecompIfNewer | NeverRecomp
deriving (Show,Eq,Ord)
data ModuleFlags = ModuleFlags {
optName :: Maybe String,
optAbsName :: Maybe String,
optCncName :: Maybe String,
optResName :: Maybe String,
optPreprocessors :: [String],
optEncoding :: Encoding,
optOptimizations :: Set Optimization,
optLibraryPath :: [FilePath],
optStartCat :: Maybe String,
optSpeechLanguage :: Maybe String,
optLexer :: Maybe String,
optUnlexer :: Maybe String,
optErasing :: Bool,
optBuildParser :: Bool,
optWarnings :: [Warning],
optDump :: [Dump]
}
deriving (Show)
data Flags = Flags {
optMode :: Mode,
optStopAfterPhase :: Phase,
optVerbosity :: Verbosity,
optShowCPUTime :: Bool,
optEmitGFO :: Bool,
optGFODir :: FilePath,
optOutputFormats :: [OutputFormat],
optSISR :: Maybe SISRFormat,
optOutputFile :: Maybe FilePath,
optOutputDir :: Maybe FilePath,
optRecomp :: Recomp,
optPrinter :: [Printer],
optProb :: Bool,
optRetainResource :: Bool,
optModuleFlags :: ModuleFlags
}
deriving (Show)
newtype Options = Options (Flags -> Flags)
instance Show Options where
show (Options o) = show (o defaultFlags)
newtype ModuleOptions = ModuleOptions (ModuleFlags -> ModuleFlags)
-- Option parsing
parseOptions :: [String] -> Err (Options, [FilePath])
parseOptions args
| not (null errs) = errors errs
| otherwise = do opts <- liftM concatOptions $ sequence optss
return (opts, files)
where (optss, files, errs) = getOpt RequireOrder optDescr args
parseModuleOptions :: [String] -> Err ModuleOptions
parseModuleOptions args
| not (null errs) = errors errs
| not (null files) = errors $ map ("Non-option among module options: " ++) files
| otherwise = liftM concatModuleOptions $ sequence flags
where (flags, files, errs) = getOpt RequireOrder moduleOptDescr args
-- Showing options
-- | Pretty-print the module options that are preserved in .gfo files.
moduleOptionsGFO :: ModuleOptions -> [(String,String)]
moduleOptionsGFO (ModuleOptions o) =
maybe [] (\x -> [("language",x)]) (optSpeechLanguage mfs)
++ maybe [] (\x -> [("startcat",x)]) (optStartCat mfs)
-- ++ maybe [] (\x -> [("coding", e2s x)]) (Just (optEncoding mfs))
++ (if optErasing mfs then [("erasing","on")] else [])
where
mfs = o defaultModuleFlags
e2s e = maybe [] id $ lookup e [(s,e) | (e,s) <- encodings]
-- Option manipulation
noOptions :: Options
noOptions = Options id
addOptions :: Options -- ^ Existing options.
-> Options -- ^ Options to add (these take preference).
-> Options
addOptions (Options o1) (Options o2) = Options (o2 . o1)
concatOptions :: [Options] -> Options
concatOptions = foldr addOptions noOptions
moduleOptions :: ModuleOptions -> Options
moduleOptions (ModuleOptions f) = Options (\o -> o { optModuleFlags = f (optModuleFlags o) })
addModuleOptions :: ModuleOptions -- ^ Existing options.
-> ModuleOptions -- ^ Options to add (these take preference).
-> ModuleOptions
addModuleOptions (ModuleOptions o1) (ModuleOptions o2) = ModuleOptions (o2 . o1)
concatModuleOptions :: [ModuleOptions] -> ModuleOptions
concatModuleOptions = foldr addModuleOptions noModuleOptions
noModuleOptions :: ModuleOptions
noModuleOptions = ModuleOptions id
flag :: (Flags -> a) -> Options -> a
flag f (Options o) = f (o defaultFlags)
moduleFlag :: (ModuleFlags -> a) -> Options -> a
moduleFlag f = flag (f . optModuleFlags)
modifyFlags :: (Flags -> Flags) -> Options
modifyFlags = Options
modifyModuleFlags :: (ModuleFlags -> ModuleFlags) -> Options
modifyModuleFlags = moduleOptions . ModuleOptions
{-
parseModuleFlags :: Options -> [(String,Maybe String)] -> Err ModuleOptions
parseModuleFlags opts flags =
mapM (uncurry (findFlag moduleOptDescr)) flags >>= foldM (flip ($)) (optModuleOptions opts)
findFlag :: Monad m => [OptDescr a] -> String -> Maybe String -> m a
findFlag opts n mv =
case filter (`flagMatches` n) opts of
[] -> fail $ "Unknown option: " ++ n
[opt] -> flagValue opt n mv
_ -> fail $ n ++ " matches multiple options."
flagMatches :: OptDescr a -> String -> Bool
flagMatches (Option cs ss _ _) n = n `elem` (map (:[]) cs ++ ss)
flagValue :: Monad m => OptDescr a -> String -> Maybe String -> m a
flagValue (Option _ _ arg _) n mv =
case (arg, mv) of
(NoArg x, Nothing) -> return x
(NoArg _, Just _ ) -> fail $ "Option " ++ n ++ " does not take a value."
(ReqArg _ _, Nothing) -> fail $ "Option " ++ n ++ " requires a value."
(ReqArg f _, Just x ) -> return (f x)
(OptArg f _, mx ) -> return (f mx)
-}
-- Default options
defaultModuleFlags :: ModuleFlags
defaultModuleFlags = ModuleFlags {
optName = Nothing,
optAbsName = Nothing,
optCncName = Nothing,
optResName = Nothing,
optPreprocessors = [],
optEncoding = ISO_8859_1,
optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues],
optLibraryPath = [],
optStartCat = Nothing,
optSpeechLanguage = Nothing,
optLexer = Nothing,
optUnlexer = Nothing,
optErasing = False,
optBuildParser = True,
optWarnings = [],
optDump = []
}
defaultFlags :: Flags
defaultFlags = Flags {
optMode = ModeInteractive,
optStopAfterPhase = Compile,
optVerbosity = Normal,
optShowCPUTime = False,
optEmitGFO = True,
optGFODir = ".",
optOutputFormats = [FmtPGF],
optSISR = Nothing,
optOutputFile = Nothing,
optOutputDir = Nothing,
optRecomp = RecompIfNewer,
optPrinter = [],
optProb = False,
optRetainResource = False,
optModuleFlags = defaultModuleFlags
}
-- Option descriptions
moduleOptDescr :: [OptDescr (Err ModuleOptions)]
moduleOptDescr =
[
Option ['n'] ["name"] (ReqArg name "NAME")
(unlines ["Use NAME as the name of the output. This is used in the output file names, ",
"with suffixes depending on the formats, and, when relevant, ",
"internally in the output."]),
Option [] ["abs"] (ReqArg absName "NAME")
("Use NAME as the name of the abstract syntax module generated from "
++ "a grammar in GF 1 format."),
Option [] ["cnc"] (ReqArg cncName "NAME")
("Use NAME as the name of the concrete syntax module generated from "
++ "a grammar in GF 1 format."),
Option [] ["res"] (ReqArg resName "NAME")
("Use NAME as the name of the resource module generated from "
++ "a grammar in GF 1 format."),
Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
Option [] ["preproc"] (ReqArg preproc "CMD")
(unlines ["Use CMD to preprocess input files.",
"Multiple preprocessors can be used by giving this option multiple times."]),
Option [] ["coding"] (ReqArg coding "ENCODING")
("Character encoding of the source grammar, ENCODING = "
++ concat (intersperse " | " (map fst encodings)) ++ "."),
Option [] ["erasing"] (onOff erasing False) "Generate erasing grammar (default off).",
Option [] ["parser"] (onOff parser True) "Build parser (default on).",
Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.",
Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
Option [] ["optimize"] (ReqArg optimize "OPT")
"Select an optimization package. OPT = all | values | parametrize | none",
Option [] ["stem"] (onOff (toggleOptimize OptStem) True) "Perform stem-suffix analysis (default on).",
Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).",
dumpOption "rebuild" DumpRebuild,
dumpOption "extend" DumpExtend,
dumpOption "rename" DumpRename,
dumpOption "tc" DumpTypeCheck,
dumpOption "refresh" DumpRefresh,
dumpOption "opt" DumpOptimize,
dumpOption "canon" DumpCanon
]
where
name x = set $ \o -> o { optName = Just x }
absName x = set $ \o -> o { optAbsName = Just x }
cncName x = set $ \o -> o { optCncName = Just x }
resName x = set $ \o -> o { optResName = Just x }
addLibDir x = set $ \o -> o { optLibraryPath = x:optLibraryPath o }
setLibPath x = set $ \o -> o { optLibraryPath = splitInModuleSearchPath x }
preproc x = set $ \o -> o { optPreprocessors = optPreprocessors o ++ [x] }
coding x = case lookup x encodings of
Just c -> set $ \o -> o { optEncoding = c }
Nothing -> fail $ "Unknown character encoding: " ++ x
erasing x = set $ \o -> o { optErasing = x }
parser x = set $ \o -> o { optBuildParser = x }
startcat x = set $ \o -> o { optStartCat = Just x }
language x = set $ \o -> o { optSpeechLanguage = Just x }
lexer x = set $ \o -> o { optLexer = Just x }
unlexer x = set $ \o -> o { optUnlexer = Just x }
optimize x = case lookup x optimizationPackages of
Just p -> set $ \o -> o { optOptimizations = p }
Nothing -> fail $ "Unknown optimization package: " ++ x
toggleOptimize x b = set $ setOptimization' x b
dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.")
set = return . ModuleOptions
optDescr :: [OptDescr (Err Options)]
optDescr =
[
Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 2.",
Option ['q','s'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.",
Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.",
Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).",
Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",
Option [] ["make"] (NoArg (phase Link)) "Build .pgf file and other output files.",
Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
Option [] ["emit-gfo"] (NoArg (emitGFO True)) "Create .gfo files (default).",
Option [] ["no-emit-gfo"] (NoArg (emitGFO False)) "Do not create .gfo files.",
Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
(unlines ["Output format. FMT can be one of:",
"Multiple concrete: pgf (default), gar, js, ...",
"Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...",
"Abstract only: haskell, ..."]),
Option [] ["sisr"] (ReqArg sisrFmt "FMT")
(unlines ["Include SISR tags in generated speech recognition grammars.",
"FMT can be one of: old, 1.0"]),
Option ['o'] ["output-file"] (ReqArg outFile "FILE")
"Save output in FILE (default is out.X, where X depends on output format.",
Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
"Save output files (other than .gfc files) in DIR.",
Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
"Always recompile from source.",
Option [] ["gfo","recomp-if-newer"] (NoArg (recomp RecompIfNewer))
"(default) Recompile from source if the source is newer than the .gfo file.",
Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
"Never recompile from source, if there is already .gfo file.",
Option [] ["strip"] (NoArg (printer PrinterStrip))
"Remove name qualifiers when pretty-printing.",
Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas."
] ++ map (fmap (liftM moduleOptions)) moduleOptDescr
where phase x = set $ \o -> o { optStopAfterPhase = x }
mode x = set $ \o -> o { optMode = x }
verbosity mv = case mv of
Nothing -> set $ \o -> o { optVerbosity = Verbose }
Just v -> case readMaybe v >>= toEnumBounded of
Just i -> set $ \o -> o { optVerbosity = i }
Nothing -> fail $ "Bad verbosity: " ++ show v
cpu x = set $ \o -> o { optShowCPUTime = x }
emitGFO x = set $ \o -> o { optEmitGFO = x }
gfoDir x = set $ \o -> o { optGFODir = x }
outFmt x = readOutputFormat x >>= \f ->
set $ \o -> o { optOutputFormats = optOutputFormats o ++ [f] }
sisrFmt x = case x of
"old" -> set $ \o -> o { optSISR = Just SISR_WD20030401 }
"1.0" -> set $ \o -> o { optSISR = Just SISR_1_0 }
_ -> fail $ "Unknown SISR format: " ++ show x
outFile x = set $ \o -> o { optOutputFile = Just x }
outDir x = set $ \o -> o { optOutputDir = Just x }
recomp x = set $ \o -> o { optRecomp = x }
printer x = set $ \o -> o { optPrinter = x : optPrinter o }
prob x = set $ \o -> o { optProb = x }
set = return . Options
outputFormats :: [(String,OutputFormat)]
outputFormats =
[("pgf", FmtPGF),
("js", FmtJavaScript),
("haskell", FmtHaskell),
("haskell_gadt", FmtHaskell_GADT),
("bnf", FmtBNF),
("srgs_xml", FmtSRGS_XML),
("srgs_abnf", FmtSRGS_ABNF),
("jsgf", FmtJSGF),
("gsl", FmtGSL),
("vxml", FmtVoiceXML),
("slf", FmtSLF),
("regexp", FmtRegExp),
("fa", FmtFA)]
instance Show OutputFormat where
show = lookupShow outputFormats
instance Read OutputFormat where
readsPrec = lookupReadsPrec outputFormats
optimizationPackages :: [(String, Set Optimization)]
optimizationPackages =
[("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]), -- deprecated
("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]),
("values", Set.fromList [OptStem,OptCSE,OptExpand,OptValues]),
("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("none", Set.fromList [OptStem,OptCSE,OptExpand]),
("noexpand", Set.fromList [OptStem,OptCSE])]
encodings :: [(String,Encoding)]
encodings =
[("utf8", UTF_8),
("cp1251", CP_1251),
("latin1", ISO_8859_1)
]
lookupShow :: Eq a => [(String,a)] -> a -> String
lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs]
lookupReadsPrec :: [(String,a)] -> Int -> ReadS a
lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x]
onOff :: Monad m => (Bool -> m a) -> Bool -> ArgDescr (m a)
onOff f def = OptArg g "[on,off]"
where g ma = maybe (return def) readOnOff ma >>= f
readOnOff x = case map toLower x of
"on" -> return True
"off" -> return False
_ -> fail $ "Expected [on,off], got: " ++ show x
readOutputFormat :: Monad m => String -> m OutputFormat
readOutputFormat s =
maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
-- FIXME: this is a copy of the function in GF.Devel.UseIO.
splitInModuleSearchPath :: String -> [FilePath]
splitInModuleSearchPath s = case break isPathSep s of
(f,_:cs) -> f : splitInModuleSearchPath cs
(f,_) -> [f]
where
isPathSep :: Char -> Bool
isPathSep c = c == ':' || c == ';'
--
-- * Convenience functions for checking options
--
verbAtLeast :: Options -> Verbosity -> Bool
verbAtLeast opts v = flag optVerbosity opts >= v
dump :: Options -> Dump -> Bool
dump opts d = moduleFlag ((d `elem`) . optDump) opts
--
-- * Convenience functions for setting options
--
setOptimization :: Optimization -> Bool -> Options
setOptimization o b = modifyModuleFlags (setOptimization' o b)
setOptimization' :: Optimization -> Bool -> ModuleFlags -> ModuleFlags
setOptimization' o b f = f { optOptimizations = g (optOptimizations f)}
where g = if b then Set.insert o else Set.delete o
--
-- * General utilities
--
readMaybe :: Read a => String -> Maybe a
readMaybe s = case reads s of
[(x,"")] -> Just x
_ -> Nothing
toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a
toEnumBounded i = let mi = minBound
ma = maxBound `asTypeOf` mi
in if i >= fromEnum mi && i <= fromEnum ma
then Just (toEnum i `asTypeOf` mi)
else Nothing
instance Functor OptDescr where
fmap f (Option cs ss d s) = Option cs ss (fmap f d) s
instance Functor ArgDescr where
fmap f (NoArg x) = NoArg (f x)
fmap f (ReqArg g s) = ReqArg (f . g) s
fmap f (OptArg g s) = OptArg (f . g) s

51
src/GF/Infra/PrintClass.hs Normal file
View File

@@ -0,0 +1,51 @@
module GF.Infra.PrintClass where
import Data.List (intersperse)
class Print a where
prt :: a -> String
prtList :: [a] -> String
prtList as = "[" ++ prtSep "," as ++ "]"
prtSep :: Print a => String -> [a] -> String
prtSep sep = concat . intersperse sep . map prt
prtBefore :: Print a => String -> [a] -> String
prtBefore before = prtBeforeAfter before ""
prtAfter :: Print a => String -> [a] -> String
prtAfter after = prtBeforeAfter "" after
prtBeforeAfter :: Print a => String -> String -> [a] -> String
prtBeforeAfter before after as = concat [ before ++ prt a ++ after | a <- as ]
prtPairList :: (Print a, Print b) => String -> String -> [(a,b)] -> String
prtPairList comma sep xys = prtSep sep [ prt x ++ comma ++ prt y | (x,y) <- xys ]
prIO :: Print a => a -> IO ()
prIO = putStr . prt
instance Print a => Print [a] where
prt = prtList
instance (Print a, Print b) => Print (a, b) where
prt (a, b) = "(" ++ prt a ++ "," ++ prt b ++ ")"
instance (Print a, Print b, Print c) => Print (a, b, c) where
prt (a, b, c) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ ")"
instance (Print a, Print b, Print c, Print d) => Print (a, b, c, d) where
prt (a, b, c, d) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ "," ++ prt d ++ ")"
instance Print Char where
prt = return
prtList = id
instance Print Int where
prt = show
instance Print Integer where
prt = show
instance Print a => Print (Maybe a) where
prt (Just a) = prt a
prt Nothing = "Nothing"

277
src/GF/Infra/UseIO.hs Normal file
View File

@@ -0,0 +1,277 @@
{-# OPTIONS -cpp #-}
----------------------------------------------------------------------
-- |
-- Module : UseIO
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/08/08 09:01:25 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.17 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Infra.UseIO where
import GF.Data.Operations
import GF.Infra.Option
import Paths_gf(getDataDir)
import System.Directory
import System.FilePath
import System.IO
import System.IO.Error
import System.Environment
import System.Exit
import System.CPUTime
import Control.Monad
import Control.Exception(evaluate)
import qualified Data.ByteString.Char8 as BS
putShow' :: Show a => (c -> a) -> c -> IO ()
putShow' f = putStrLn . show . length . show . f
putIfVerb :: Options -> String -> IO ()
putIfVerb opts msg =
when (verbAtLeast opts Verbose) $ putStrLn msg
putIfVerbW :: Options -> String -> IO ()
putIfVerbW opts msg =
when (verbAtLeast opts Verbose) $ putStr (' ' : msg)
errOptIO :: Options -> a -> Err a -> IO a
errOptIO os e m = case m of
Ok x -> return x
Bad k -> do
putIfVerb os k
return e
readFileIf f = catch (readFile f) (\_ -> reportOn f) where
reportOn f = do
putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string")
return ""
readFileIfStrict f = catch (BS.readFile f) (\_ -> reportOn f) where
reportOn f = do
putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string")
return BS.empty
type FileName = String
type InitPath = String
type FullPath = String
getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
getFilePath ps file = getFilePathMsg ("file" +++ file +++ "not found\n") ps file
getFilePathMsg :: String -> [FilePath] -> String -> IO (Maybe FilePath)
getFilePathMsg msg paths file = get paths where
get [] = putStrFlush msg >> return Nothing
get (p:ps) = do
let pfile = p </> file
exist <- doesFileExist pfile
if not exist
then get ps
else do pfile <- canonicalizePath pfile
return (Just pfile)
readFileIfPath :: [FilePath] -> String -> IOE (FilePath,BS.ByteString)
readFileIfPath paths file = do
mpfile <- ioeIO $ getFilePath paths file
case mpfile of
Just pfile -> do
s <- ioeIO $ BS.readFile pfile
return (dropFileName pfile,s)
_ -> ioeErr $ Bad ("File " ++ file ++ " does not exist.")
doesFileExistPath :: [FilePath] -> String -> IOE Bool
doesFileExistPath paths file = do
mpfile <- ioeIO $ getFilePathMsg "" paths file
return $ maybe False (const True) mpfile
gfLibraryPath = "GF_LIB_PATH"
gfGrammarPathVar = "GF_GRAMMAR_PATH"
getLibraryPath :: IO FilePath
getLibraryPath =
catch
(getEnv gfLibraryPath)
(\ex -> getDataDir >>= \path -> return (path </> "lib"))
-- | extends the search path with the
-- 'gfLibraryPath' and 'gfGrammarPathVar'
-- environment variables. Returns only existing paths.
extendPathEnv :: [FilePath] -> IO [FilePath]
extendPathEnv ps = do
b <- getLibraryPath -- e.g. GF_LIB_PATH
s <- catch (getEnv gfGrammarPathVar) (const (return "")) -- e.g. GF_GRAMMAR_PATH
let ss = ps ++ splitSearchPath s
liftM concat $ mapM allSubdirs $ ss ++ [b </> s | s <- ss ++ ["prelude"]]
where
allSubdirs :: FilePath -> IO [FilePath]
allSubdirs [] = return [[]]
allSubdirs p = case last p of
'*' -> do let path = init p
fs <- getSubdirs path
return [path </> f | f <- fs]
_ -> do exists <- doesDirectoryExist p
if exists
then return [p]
else return []
getSubdirs :: FilePath -> IO [FilePath]
getSubdirs dir = do
fs <- catch (getDirectoryContents dir) (const $ return [])
foldM (\fs f -> do let fpath = dir </> f
p <- getPermissions fpath
if searchable p && not (take 1 f==".")
then return (fpath:fs)
else return fs ) [] fs
justModuleName :: FilePath -> String
justModuleName = dropExtension . takeFileName
splitInModuleSearchPath :: String -> [FilePath]
splitInModuleSearchPath s = case break isPathSep s of
(f,_:cs) -> f : splitInModuleSearchPath cs
(f,_) -> [f]
where
isPathSep :: Char -> Bool
isPathSep c = c == ':' || c == ';'
--
getLineWell :: IO String -> IO String
getLineWell ios =
catch getLine (\e -> if (isEOFError e) then ios else ioError e)
putStrFlush :: String -> IO ()
putStrFlush s = putStr s >> hFlush stdout
putStrLnFlush :: String -> IO ()
putStrLnFlush s = putStrLn s >> hFlush stdout
-- * a generic quiz session
type QuestionsAndAnswers = [(String, String -> (Integer,String))]
teachDialogue :: QuestionsAndAnswers -> String -> IO ()
teachDialogue qas welc = do
putStrLn $ welc ++++ genericTeachWelcome
teach (0,0) qas
where
teach _ [] = do putStrLn "Sorry, ran out of problems"
teach (score,total) ((question,grade):quas) = do
putStr ("\n" ++ question ++ "\n> ")
answer <- getLine
if (answer == ".") then return () else do
let (result, feedback) = grade answer
score' = score + result
total' = total + 1
putStr (feedback ++++ "Score" +++ show score' ++ "/" ++ show total')
if (total' > 9 && fromInteger score' / fromInteger total' >= 0.75)
then do putStrLn "\nCongratulations - you passed!"
else teach (score',total') quas
genericTeachWelcome =
"The quiz is over when you have done at least 10 examples" ++++
"with at least 75 % success." +++++
"You can interrupt the quiz by entering a line consisting of a dot ('.').\n"
-- * IO monad with error; adapted from state monad
newtype IOE a = IOE (IO (Err a))
appIOE :: IOE a -> IO (Err a)
appIOE (IOE iea) = iea
ioe :: IO (Err a) -> IOE a
ioe = IOE
ioeIO :: IO a -> IOE a
ioeIO io = ioe (io >>= return . return)
ioeErr :: Err a -> IOE a
ioeErr = ioe . return
instance Monad IOE where
return a = ioe (return (return a))
IOE c >>= f = IOE $ do
x <- c -- Err a
appIOE $ err ioeBad f x -- f :: a -> IOE a
ioeBad :: String -> IOE a
ioeBad = ioe . return . Bad
useIOE :: a -> IOE a -> IO a
useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return
foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String)
foldIOE f s xs = case xs of
[] -> return (s,Nothing)
x:xx -> do
ev <- ioeIO $ appIOE (f s x)
case ev of
Ok v -> foldIOE f v xx
Bad m -> return $ (s, Just m)
dieIOE :: IOE a -> IO a
dieIOE x = appIOE x >>= err die return
die :: String -> IO a
die s = do hPutStrLn stderr s
exitFailure
putStrLnE :: String -> IOE ()
putStrLnE = ioeIO . putStrLnFlush
putStrE :: String -> IOE ()
putStrE = ioeIO . putStrFlush
putPointE :: Verbosity -> Options -> String -> IOE a -> IOE a
putPointE v opts msg act = do
when (verbAtLeast opts v) $ ioeIO $ putStrFlush msg
t1 <- ioeIO $ getCPUTime
a <- act >>= ioeIO . evaluate
t2 <- ioeIO $ getCPUTime
if flag optShowCPUTime opts
then putStrLnE (" " ++ show ((t2 - t1) `div` 1000000000) ++ " msec")
else when (verbAtLeast opts v) $ putStrLnE ""
return a
-- ((do {s <- readFile f; return (return s)}) )
readFileIOE :: FilePath -> IOE BS.ByteString
readFileIOE f = ioe $ catch (BS.readFile f >>= return . return)
(\e -> return (Bad (show e)))
-- | like readFileIOE but look also in the GF library if file not found
--
-- intended semantics: if file is not found, try @\$GF_LIB_PATH\/file@
-- (even if file is an absolute path, but this should always fail)
-- it returns not only contents of the file, but also the path used
readFileLibraryIOE :: String -> FilePath -> IOE (FilePath, BS.ByteString)
readFileLibraryIOE ini f = ioe $ do
lp <- getLibraryPath
tryRead ini $ \_ ->
tryRead lp $ \e ->
return (Bad (show e))
where
tryRead path onError =
catch (BS.readFile fpath >>= \s -> return (return (fpath,s)))
onError
where
fpath = path </> f
-- | example
koeIOE :: IO ()
koeIOE = useIOE () $ do
s <- ioeIO $ getLine
s2 <- ioeErr $ mapM (!? 2) $ words s
ioeIO $ putStrLn s2

60
src/GF/JavaScript/AbsJS.hs Normal file
View File

@@ -0,0 +1,60 @@
module GF.JavaScript.AbsJS where
-- Haskell module generated by the BNF converter
newtype Ident = Ident String deriving (Eq,Ord,Show)
data Program =
Program [Element]
deriving (Eq,Ord,Show)
data Element =
FunDef Ident [Ident] [Stmt]
| ElStmt Stmt
deriving (Eq,Ord,Show)
data Stmt =
SCompound [Stmt]
| SReturnVoid
| SReturn Expr
| SDeclOrExpr DeclOrExpr
deriving (Eq,Ord,Show)
data DeclOrExpr =
Decl [DeclVar]
| DExpr Expr
deriving (Eq,Ord,Show)
data DeclVar =
DVar Ident
| DInit Ident Expr
deriving (Eq,Ord,Show)
data Expr =
EAssign Expr Expr
| ENew Ident [Expr]
| EMember Expr Ident
| EIndex Expr Expr
| ECall Expr [Expr]
| EVar Ident
| EInt Int
| EDbl Double
| EStr String
| ETrue
| EFalse
| ENull
| EThis
| EFun [Ident] [Stmt]
| EArray [Expr]
| EObj [Property]
| ESeq [Expr]
deriving (Eq,Ord,Show)
data Property =
Prop PropertyName Expr
deriving (Eq,Ord,Show)
data PropertyName =
IdentPropName Ident
| StringPropName String
deriving (Eq,Ord,Show)

55
src/GF/JavaScript/JS.cf Normal file
View File

@@ -0,0 +1,55 @@
entrypoints Program;
Program. Program ::= [Element];
FunDef. Element ::= "function" Ident "(" [Ident] ")" "{" [Stmt] "}" ;
ElStmt. Element ::= Stmt;
separator Element "" ;
separator Ident "," ;
SCompound. Stmt ::= "{" [Stmt] "}" ;
SReturnVoid. Stmt ::= "return" ";" ;
SReturn. Stmt ::= "return" Expr ";" ;
SDeclOrExpr. Stmt ::= DeclOrExpr ";" ;
separator Stmt "" ;
Decl. DeclOrExpr ::= "var" [DeclVar];
DExpr. DeclOrExpr ::= Expr1 ;
DVar. DeclVar ::= Ident ;
DInit. DeclVar ::= Ident "=" Expr ;
separator DeclVar "," ;
EAssign. Expr13 ::= Expr14 "=" Expr13 ;
ENew. Expr14 ::= "new" Ident "(" [Expr] ")" ;
EMember. Expr15 ::= Expr15 "." Ident ;
EIndex. Expr15 ::= Expr15 "[" Expr "]" ;
ECall. Expr15 ::= Expr15 "(" [Expr] ")" ;
EVar. Expr16 ::= Ident ;
EInt. Expr16 ::= Integer ;
EDbl. Expr16 ::= Double ;
EStr. Expr16 ::= String ;
ETrue. Expr16 ::= "true" ;
EFalse. Expr16 ::= "false" ;
ENull. Expr16 ::= "null" ;
EThis. Expr16 ::= "this" ;
EFun. Expr16 ::= "function" "(" [Ident] ")" "{" [Stmt] "}" ;
EArray. Expr16 ::= "[" [Expr] "]" ;
EObj. Expr16 ::= "{" [Property] "}" ;
eseq1. Expr16 ::= "(" Expr "," [Expr] ")";
internal ESeq. Expr16 ::= "(" [Expr] ")" ;
define eseq1 x xs = ESeq (x:xs);
separator Expr "," ;
coercions Expr 16 ;
Prop. Property ::= PropertyName ":" Expr ;
separator Property "," ;
IdentPropName. PropertyName ::= Ident ;
StringPropName. PropertyName ::= String ;

132
src/GF/JavaScript/LexJS.x Normal file
View File

@@ -0,0 +1,132 @@
-- -*- haskell -*-
-- This Alex file was machine-generated by the BNF converter
{
{-# OPTIONS -fno-warn-incomplete-patterns #-}
module GF.JavaScript.LexJS where
}
$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 = -- symbols and non-identifier-like reserved words
\( | \) | \{ | \} | \, | \; | \= | \. | \[ | \] | \:
:-
$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)) }
$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
{
tok f p s = f p s
share :: String -> String
share = id
data Tok =
TS !String -- reserved words and symbols
| 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 "return" (b "new" (b "function" (b "false" N N) N) (b "null" N N)) (b "true" (b "this" N N) (b "var" 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, _, _) -> [Err pos]
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
}

14
src/GF/JavaScript/Makefile Normal file
View File

@@ -0,0 +1,14 @@
all:
happy -gca ParJS.y
alex -g LexJS.x
bnfc:
(cd ../.. && bnfc -p GF.JavaScript GF/JavaScript/JS.cf)
-rm -f *.bak
clean:
-rm -f *.log *.aux *.hi *.o *.dvi
-rm -f DocJS.ps
distclean: clean
-rm -f DocJS.* LexJS.* ParJS.* LayoutJS.* SkelJS.* PrintJS.* TestJS.* AbsJS.* TestJS ErrM.* SharedString.* JS.dtd XMLJS.* Makefile*

225
src/GF/JavaScript/ParJS.y Normal file
View File

@@ -0,0 +1,225 @@
-- This Happy file was machine-generated by the BNF converter
{
{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
module GF.JavaScript.ParJS where
import GF.JavaScript.AbsJS
import GF.JavaScript.LexJS
import GF.Data.ErrM
}
%name pProgram Program
-- 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 ":") }
'false' { PT _ (TS "false") }
'function' { PT _ (TS "function") }
'new' { PT _ (TS "new") }
'null' { PT _ (TS "null") }
'return' { PT _ (TS "return") }
'this' { PT _ (TS "this") }
'true' { PT _ (TS "true") }
'var' { PT _ (TS "var") }
L_ident { PT _ (TV $$) }
L_integ { PT _ (TI $$) }
L_doubl { PT _ (TD $$) }
L_quoted { PT _ (TL $$) }
L_err { _ }
%%
Ident :: { Ident } : L_ident { Ident $1 }
Integer :: { Integer } : L_integ { (read $1) :: Integer }
Double :: { Double } : L_doubl { (read $1) :: Double }
String :: { String } : L_quoted { $1 }
Program :: { Program }
Program : ListElement { Program (reverse $1) }
Element :: { Element }
Element : 'function' Ident '(' ListIdent ')' '{' ListStmt '}' { FunDef $2 $4 (reverse $7) }
| Stmt { ElStmt $1 }
ListElement :: { [Element] }
ListElement : {- empty -} { [] }
| ListElement Element { flip (:) $1 $2 }
ListIdent :: { [Ident] }
ListIdent : {- empty -} { [] }
| Ident { (:[]) $1 }
| Ident ',' ListIdent { (:) $1 $3 }
Stmt :: { Stmt }
Stmt : '{' ListStmt '}' { SCompound (reverse $2) }
| 'return' ';' { SReturnVoid }
| 'return' Expr ';' { SReturn $2 }
| DeclOrExpr ';' { SDeclOrExpr $1 }
ListStmt :: { [Stmt] }
ListStmt : {- empty -} { [] }
| ListStmt Stmt { flip (:) $1 $2 }
DeclOrExpr :: { DeclOrExpr }
DeclOrExpr : 'var' ListDeclVar { Decl $2 }
| Expr1 { DExpr $1 }
DeclVar :: { DeclVar }
DeclVar : Ident { DVar $1 }
| Ident '=' Expr { DInit $1 $3 }
ListDeclVar :: { [DeclVar] }
ListDeclVar : {- empty -} { [] }
| DeclVar { (:[]) $1 }
| DeclVar ',' ListDeclVar { (:) $1 $3 }
Expr13 :: { Expr }
Expr13 : Expr14 '=' Expr13 { EAssign $1 $3 }
| Expr14 { $1 }
Expr14 :: { Expr }
Expr14 : 'new' Ident '(' ListExpr ')' { ENew $2 $4 }
| Expr15 { $1 }
Expr15 :: { Expr }
Expr15 : Expr15 '.' Ident { EMember $1 $3 }
| Expr15 '[' Expr ']' { EIndex $1 $3 }
| Expr15 '(' ListExpr ')' { ECall $1 $3 }
| Expr16 { $1 }
Expr16 :: { Expr }
Expr16 : Ident { EVar $1 }
| Integer { EInt $1 }
| Double { EDbl $1 }
| String { EStr $1 }
| 'true' { ETrue }
| 'false' { EFalse }
| 'null' { ENull }
| 'this' { EThis }
| 'function' '(' ListIdent ')' '{' ListStmt '}' { EFun $3 (reverse $6) }
| '[' ListExpr ']' { EArray $2 }
| '{' ListProperty '}' { EObj $2 }
| '(' Expr ',' ListExpr ')' { eseq1_ $2 $4 }
| '(' Expr ')' { $2 }
ListExpr :: { [Expr] }
ListExpr : {- empty -} { [] }
| Expr { (:[]) $1 }
| Expr ',' ListExpr { (:) $1 $3 }
Expr :: { Expr }
Expr : Expr1 { $1 }
Expr1 :: { Expr }
Expr1 : Expr2 { $1 }
Expr2 :: { Expr }
Expr2 : Expr3 { $1 }
Expr3 :: { Expr }
Expr3 : Expr4 { $1 }
Expr4 :: { Expr }
Expr4 : Expr5 { $1 }
Expr5 :: { Expr }
Expr5 : Expr6 { $1 }
Expr6 :: { Expr }
Expr6 : Expr7 { $1 }
Expr7 :: { Expr }
Expr7 : Expr8 { $1 }
Expr8 :: { Expr }
Expr8 : Expr9 { $1 }
Expr9 :: { Expr }
Expr9 : Expr10 { $1 }
Expr10 :: { Expr }
Expr10 : Expr11 { $1 }
Expr11 :: { Expr }
Expr11 : Expr12 { $1 }
Expr12 :: { Expr }
Expr12 : Expr13 { $1 }
Property :: { Property }
Property : PropertyName ':' Expr { Prop $1 $3 }
ListProperty :: { [Property] }
ListProperty : {- empty -} { [] }
| Property { (:[]) $1 }
| Property ',' ListProperty { (:) $1 $3 }
PropertyName :: { PropertyName }
PropertyName : Ident { IdentPropName $1 }
| String { StringPropName $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 ++
case ts of
[] -> []
[Err _] -> " due to lexer error"
_ -> " before " ++ unwords (map prToken (take 4 ts))
myLexer = tokens
eseq1_ x_ xs_ = ESeq (x_ : xs_)
}

169
src/GF/JavaScript/PrintJS.hs Normal file
View File

@@ -0,0 +1,169 @@
{-# OPTIONS -fno-warn-incomplete-patterns #-}
module GF.JavaScript.PrintJS (printTree, Doc, Print(..)) where
-- pretty-printer generated by the BNF converter
import GF.JavaScript.AbsJS
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 = (:)
render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
rend i ss = case ss of
t:ts | not (spaceAfter t) -> showString t . rend i ts
t:ts@(t':_) | not (spaceBefore t') -> showString t . 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))
spaceAfter :: String -> Bool
spaceAfter = (`notElem` [".","(","[","{","\n"])
spaceBefore :: String -> Bool
spaceBefore = (`notElem` [",",".",":",";","(",")","[","]","{","}","\n"])
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 Int 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
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Program where
prt i e = case e of
Program elements -> prPrec i 0 (concatD [prt 0 elements])
instance Print Element where
prt i e = case e of
FunDef id ids stmts -> prPrec i 0 (concatD [doc (showString "function") , prt 0 id , doc (showString "(") , prt 0 ids , doc (showString ")") , doc (showString "{") , prt 0 stmts , doc (showString "}")])
ElStmt stmt -> prPrec i 0 (concatD [prt 0 stmt])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString "\n"), prt 0 xs]) -- HACKED!
instance Print Stmt where
prt i e = case e of
SCompound stmts -> prPrec i 0 (concatD [doc (showString "{") , prt 0 stmts , doc (showString "}")])
SReturnVoid -> prPrec i 0 (concatD [doc (showString "return") , doc (showString ";")])
SReturn expr -> prPrec i 0 (concatD [doc (showString "return") , prt 0 expr , doc (showString ";")])
SDeclOrExpr declorexpr -> prPrec i 0 (concatD [prt 0 declorexpr , doc (showString ";")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print DeclOrExpr where
prt i e = case e of
Decl declvars -> prPrec i 0 (concatD [doc (showString "var") , prt 0 declvars])
DExpr expr -> prPrec i 0 (concatD [prt 1 expr])
instance Print DeclVar where
prt i e = case e of
DVar id -> prPrec i 0 (concatD [prt 0 id])
DInit id expr -> prPrec i 0 (concatD [prt 0 id , doc (showString "=") , prt 0 expr])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Expr where
prt i e = case e of
EAssign expr0 expr -> prPrec i 13 (concatD [prt 14 expr0 , doc (showString "=") , prt 13 expr])
ENew id exprs -> prPrec i 14 (concatD [doc (showString "new") , prt 0 id , doc (showString "(") , prt 0 exprs , doc (showString ")")])
EMember expr id -> prPrec i 15 (concatD [prt 15 expr , doc (showString ".") , prt 0 id])
EIndex expr0 expr -> prPrec i 15 (concatD [prt 15 expr0 , doc (showString "[") , prt 0 expr , doc (showString "]")])
ECall expr exprs -> prPrec i 15 (concatD [prt 15 expr , doc (showString "(") , prt 0 exprs , doc (showString ")")])
EVar id -> prPrec i 16 (concatD [prt 0 id])
EInt n -> prPrec i 16 (concatD [prt 0 n])
EDbl d -> prPrec i 16 (concatD [prt 0 d])
EStr str -> prPrec i 16 (concatD [prt 0 str])
ETrue -> prPrec i 16 (concatD [doc (showString "true")])
EFalse -> prPrec i 16 (concatD [doc (showString "false")])
ENull -> prPrec i 16 (concatD [doc (showString "null")])
EThis -> prPrec i 16 (concatD [doc (showString "this")])
EFun ids stmts -> prPrec i 16 (concatD [doc (showString "function") , doc (showString "(") , prt 0 ids , doc (showString ")") , doc (showString "{") , prt 0 stmts , doc (showString "}")])
EArray exprs -> prPrec i 16 (concatD [doc (showString "[") , prt 0 exprs , doc (showString "]")])
EObj propertys -> prPrec i 16 (concatD [doc (showString "{") , prt 0 propertys , doc (showString "}")])
ESeq exprs -> prPrec i 16 (concatD [doc (showString "(") , prt 0 exprs , doc (showString ")")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Property where
prt i e = case e of
Prop propertyname expr -> prPrec i 0 (concatD [prt 0 propertyname , doc (showString ":") , prt 0 expr])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print PropertyName where
prt i e = case e of
IdentPropName id -> prPrec i 0 (concatD [prt 0 id])
StringPropName str -> prPrec i 0 (concatD [prt 0 str])

307
src/GF/Source/AbsGF.hs Normal file
View File

@@ -0,0 +1,307 @@
module GF.Source.AbsGF where
-- Haskell module generated by the BNF converter
import qualified Data.ByteString.Char8 as BS
newtype LString = LString BS.ByteString deriving (Eq,Ord,Show)
newtype PIdent = PIdent ((Int,Int),BS.ByteString) deriving (Eq,Ord,Show)
data Grammar =
Gr [ModDef]
deriving (Eq,Ord,Show)
data ModDef =
MMain PIdent PIdent [ConcSpec]
| MModule ComplMod ModType ModBody
deriving (Eq,Ord,Show)
data ConcSpec =
ConcSpec PIdent ConcExp
deriving (Eq,Ord,Show)
data ConcExp =
ConcExp PIdent [Transfer]
deriving (Eq,Ord,Show)
data Transfer =
TransferIn Open
| TransferOut Open
deriving (Eq,Ord,Show)
data ModType =
MTAbstract PIdent
| MTResource PIdent
| MTInterface PIdent
| MTConcrete PIdent PIdent
| MTInstance PIdent PIdent
| MTTransfer PIdent Open Open
deriving (Eq,Ord,Show)
data ModBody =
MBody Extend Opens [TopDef]
| MNoBody [Included]
| MWith Included [Open]
| MWithBody Included [Open] Opens [TopDef]
| MWithE [Included] Included [Open]
| MWithEBody [Included] Included [Open] Opens [TopDef]
| MReuse PIdent
| MUnion [Included]
deriving (Eq,Ord,Show)
data Extend =
Ext [Included]
| NoExt
deriving (Eq,Ord,Show)
data Opens =
NoOpens
| OpenIn [Open]
deriving (Eq,Ord,Show)
data Open =
OName PIdent
| OQualQO QualOpen PIdent
| OQual QualOpen PIdent PIdent
deriving (Eq,Ord,Show)
data ComplMod =
CMCompl
| CMIncompl
deriving (Eq,Ord,Show)
data QualOpen =
QOCompl
| QOIncompl
| QOInterface
deriving (Eq,Ord,Show)
data Included =
IAll PIdent
| ISome PIdent [PIdent]
| IMinus PIdent [PIdent]
deriving (Eq,Ord,Show)
data Def =
DDecl [Name] Exp
| DDef [Name] Exp
| DPatt Name [Patt] Exp
| DFull [Name] Exp Exp
deriving (Eq,Ord,Show)
data TopDef =
DefCat [CatDef]
| DefFun [FunDef]
| DefFunData [FunDef]
| DefDef [Def]
| DefData [DataDef]
| DefTrans [Def]
| DefPar [ParDef]
| DefOper [Def]
| DefLincat [PrintDef]
| DefLindef [Def]
| DefLin [Def]
| DefPrintCat [PrintDef]
| DefPrintFun [PrintDef]
| DefFlag [FlagDef]
| DefPrintOld [PrintDef]
| DefLintype [Def]
| DefPattern [Def]
| DefPackage PIdent [TopDef]
| DefVars [Def]
| DefTokenizer PIdent
deriving (Eq,Ord,Show)
data CatDef =
SimpleCatDef PIdent [DDecl]
| ListCatDef PIdent [DDecl]
| ListSizeCatDef PIdent [DDecl] Integer
deriving (Eq,Ord,Show)
data FunDef =
FunDef [PIdent] Exp
deriving (Eq,Ord,Show)
data DataDef =
DataDef PIdent [DataConstr]
deriving (Eq,Ord,Show)
data DataConstr =
DataId PIdent
| DataQId PIdent PIdent
deriving (Eq,Ord,Show)
data ParDef =
ParDefDir PIdent [ParConstr]
| ParDefIndir PIdent PIdent
| ParDefAbs PIdent
deriving (Eq,Ord,Show)
data ParConstr =
ParConstr PIdent [DDecl]
deriving (Eq,Ord,Show)
data PrintDef =
PrintDef [Name] Exp
deriving (Eq,Ord,Show)
data FlagDef =
FlagDef PIdent PIdent
deriving (Eq,Ord,Show)
data Name =
IdentName PIdent
| ListName PIdent
deriving (Eq,Ord,Show)
data LocDef =
LDDecl [PIdent] Exp
| LDDef [PIdent] Exp
| LDFull [PIdent] Exp Exp
deriving (Eq,Ord,Show)
data Exp =
EIdent PIdent
| EConstr PIdent
| ECons PIdent
| ESort Sort
| EString String
| EInt Integer
| EFloat Double
| EMeta
| EEmpty
| EData
| EList PIdent Exps
| EStrings String
| ERecord [LocDef]
| ETuple [TupleComp]
| EIndir PIdent
| ETyped Exp Exp
| EProj Exp Label
| EQConstr PIdent PIdent
| EQCons PIdent PIdent
| EApp Exp Exp
| ETable [Case]
| ETTable Exp [Case]
| EVTable Exp [Exp]
| ECase Exp [Case]
| EVariants [Exp]
| EPre Exp [Altern]
| EStrs [Exp]
| EConAt PIdent Exp
| EPatt Patt
| EPattType Exp
| ESelect Exp Exp
| ETupTyp Exp Exp
| EExtend Exp Exp
| EGlue Exp Exp
| EConcat Exp Exp
| EAbstr [Bind] Exp
| ECTable [Bind] Exp
| EProd Decl Exp
| ETType Exp Exp
| ELet [LocDef] Exp
| ELetb [LocDef] Exp
| EWhere Exp [LocDef]
| EEqs [Equation]
| EExample Exp String
| ELString LString
| ELin PIdent
deriving (Eq,Ord,Show)
data Exps =
NilExp
| ConsExp Exp Exps
deriving (Eq,Ord,Show)
data Patt =
PChar
| PChars String
| PMacro PIdent
| PM PIdent PIdent
| PW
| PV PIdent
| PCon PIdent
| PQ PIdent PIdent
| PInt Integer
| PFloat Double
| PStr String
| PR [PattAss]
| PTup [PattTupleComp]
| PC PIdent [Patt]
| PQC PIdent PIdent [Patt]
| PDisj Patt Patt
| PSeq Patt Patt
| PRep Patt
| PAs PIdent Patt
| PNeg Patt
deriving (Eq,Ord,Show)
data PattAss =
PA [PIdent] Patt
deriving (Eq,Ord,Show)
data Label =
LIdent PIdent
| LVar Integer
deriving (Eq,Ord,Show)
data Sort =
Sort_Type
| Sort_PType
| Sort_Tok
| Sort_Str
| Sort_Strs
deriving (Eq,Ord,Show)
data Bind =
BIdent PIdent
| BWild
deriving (Eq,Ord,Show)
data Decl =
DDec [Bind] Exp
| DExp Exp
deriving (Eq,Ord,Show)
data TupleComp =
TComp Exp
deriving (Eq,Ord,Show)
data PattTupleComp =
PTComp Patt
deriving (Eq,Ord,Show)
data Case =
Case Patt Exp
deriving (Eq,Ord,Show)
data Equation =
Equ [Patt] Exp
deriving (Eq,Ord,Show)
data Altern =
Alt Exp Exp
deriving (Eq,Ord,Show)
data DDecl =
DDDec [Bind] Exp
| DDExp Exp
deriving (Eq,Ord,Show)
data OldGrammar =
OldGr Include [TopDef]
deriving (Eq,Ord,Show)
data Include =
NoIncl
| Incl [FileName]
deriving (Eq,Ord,Show)
data FileName =
FString String
| FIdent PIdent
| FSlash FileName
| FDot FileName
| FMinus FileName
| FAddId PIdent FileName
deriving (Eq,Ord,Show)

26
src/GF/Source/ErrM.hs Normal file
View File

@@ -0,0 +1,26 @@
-- BNF Converter: Error Monad
-- Copyright (C) 2004 Author: Aarne Ranta
-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
module GF.Source.ErrM where
-- the Error monad: like Maybe type with error msgs
import Control.Monad (MonadPlus(..), liftM)
data Err a = Ok a | Bad String
deriving (Read, Show, Eq, Ord)
instance Monad Err where
return = Ok
fail = Bad
Ok a >>= f = f a
Bad s >>= f = Bad s
instance Functor Err where
fmap = liftM
instance MonadPlus Err where
mzero = Bad "Err.mzero"
mplus (Bad _) y = y
mplus x _ = x

371
src/GF/Source/GF.cf Normal file
View File

@@ -0,0 +1,371 @@
-- AR 2/5/2003, 14-16 o'clock, Torino
-- 17/6/2007: marked with suffix --% those lines that are obsolete and
-- should not be included in documentation
entrypoints Grammar, ModDef,
OldGrammar, --%
ModHeader,
Exp ; -- let's see if more are needed
comment "--" ;
comment "{-" "-}" ;
-- the top-level grammar
Gr. Grammar ::= [ModDef] ;
-- semicolon after module is permitted but not obligatory
terminator ModDef "" ;
_. ModDef ::= ModDef ";" ;
-- The $main$ multilingual grammar structure --%
MMain. ModDef ::= "grammar" PIdent "=" "{" "abstract" "=" PIdent ";" [ConcSpec] "}" ;--%
ConcSpec. ConcSpec ::= PIdent "=" ConcExp ;--%
separator ConcSpec ";" ;--%
ConcExp. ConcExp ::= PIdent [Transfer] ;--%
separator Transfer "" ;--%
TransferIn. Transfer ::= "(" "transfer" "in" Open ")" ; --%
TransferOut. Transfer ::= "(" "transfer" "out" Open ")" ; --%
-- the module header
MModule2. ModHeader ::= ComplMod ModType "=" ModHeaderBody ;
MBody2. ModHeaderBody ::= Extend Opens ;
MNoBody2. ModHeaderBody ::= [Included] ;
MWith2. ModHeaderBody ::= Included "with" [Open] ;
MWithBody2. ModHeaderBody ::= Included "with" [Open] "**" Opens ;
MWithE2. ModHeaderBody ::= [Included] "**" Included "with" [Open] ;
MWithEBody2. ModHeaderBody ::= [Included] "**" Included "with" [Open] "**" Opens ;
MReuse2. ModHeaderBody ::= "reuse" PIdent ; --%
MUnion2. ModHeaderBody ::= "union" [Included] ;--%
-- the individual modules
MModule. ModDef ::= ComplMod ModType "=" ModBody ;
MTAbstract. ModType ::= "abstract" PIdent ;
MTResource. ModType ::= "resource" PIdent ;
MTInterface. ModType ::= "interface" PIdent ;
MTConcrete. ModType ::= "concrete" PIdent "of" PIdent ;
MTInstance. ModType ::= "instance" PIdent "of" PIdent ;
MTTransfer. ModType ::= "transfer" PIdent ":" Open "->" Open ;
MBody. ModBody ::= Extend Opens "{" [TopDef] "}" ;
MNoBody. ModBody ::= [Included] ;
MWith. ModBody ::= Included "with" [Open] ;
MWithBody. ModBody ::= Included "with" [Open] "**" Opens "{" [TopDef] "}" ;
MWithE. ModBody ::= [Included] "**" Included "with" [Open] ;
MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ;
MReuse. ModBody ::= "reuse" PIdent ; --%
MUnion. ModBody ::= "union" [Included] ;--%
separator TopDef "" ;
Ext. Extend ::= [Included] "**" ;
NoExt. Extend ::= ;
separator Open "," ;
NoOpens. Opens ::= ;
OpenIn. Opens ::= "open" [Open] "in" ;
OName. Open ::= PIdent ;
OQualQO. Open ::= "(" QualOpen PIdent ")" ;
OQual. Open ::= "(" QualOpen PIdent "=" PIdent ")" ;
CMCompl. ComplMod ::= ;
CMIncompl. ComplMod ::= "incomplete" ;
QOCompl. QualOpen ::= ;
QOIncompl. QualOpen ::= "incomplete" ;--%
QOInterface. QualOpen ::= "interface" ;--%
separator Included "," ;
IAll. Included ::= PIdent ;
ISome. Included ::= PIdent "[" [PIdent] "]" ;
IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ;
-- definitions after the $oper$ keywords
DDecl. Def ::= [Name] ":" Exp ;
DDef. Def ::= [Name] "=" Exp ;
DPatt. Def ::= Name [Patt] "=" Exp ; -- non-empty pattern list
DFull. Def ::= [Name] ":" Exp "=" Exp ;
-- top-level definitions
DefCat. TopDef ::= "cat" [CatDef] ;
DefFun. TopDef ::= "fun" [FunDef] ;
DefFunData.TopDef ::= "data" [FunDef] ;
DefDef. TopDef ::= "def" [Def] ;
DefData. TopDef ::= "data" [DataDef] ;
DefTrans. TopDef ::= "transfer" [Def] ;--%
DefPar. TopDef ::= "param" [ParDef] ;
DefOper. TopDef ::= "oper" [Def] ;
DefLincat. TopDef ::= "lincat" [PrintDef] ;
DefLindef. TopDef ::= "lindef" [Def] ;
DefLin. TopDef ::= "lin" [Def] ;
DefPrintCat. TopDef ::= "printname" "cat" [PrintDef] ;
DefPrintFun. TopDef ::= "printname" "fun" [PrintDef] ;
DefFlag. TopDef ::= "flags" [FlagDef] ;
SimpleCatDef. CatDef ::= PIdent [DDecl] ;
ListCatDef. CatDef ::= "[" PIdent [DDecl] "]" ;
ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ;
FunDef. FunDef ::= [PIdent] ":" Exp ;
DataDef. DataDef ::= PIdent "=" [DataConstr] ;
DataId. DataConstr ::= PIdent ;
DataQId. DataConstr ::= PIdent "." PIdent ;
separator DataConstr "|" ;
ParDefDir. ParDef ::= PIdent "=" [ParConstr] ;
ParDefIndir. ParDef ::= PIdent "=" "(" "in" PIdent ")" ;
ParDefAbs. ParDef ::= PIdent ;
ParConstr. ParConstr ::= PIdent [DDecl] ;
PrintDef. PrintDef ::= [Name] "=" Exp ;
FlagDef. FlagDef ::= PIdent "=" PIdent ;
terminator nonempty Def ";" ;
terminator nonempty CatDef ";" ;
terminator nonempty FunDef ";" ;
terminator nonempty DataDef ";" ;
terminator nonempty ParDef ";" ;
terminator nonempty PrintDef ";" ;
terminator nonempty FlagDef ";" ;
separator ParConstr "|" ;
separator nonempty PIdent "," ;
-- names of categories and functions in definition LHS
IdentName. Name ::= PIdent ;
ListName. Name ::= "[" PIdent "]" ;
separator nonempty Name "," ;
-- definitions in records and $let$ expressions
LDDecl. LocDef ::= [PIdent] ":" Exp ;
LDDef. LocDef ::= [PIdent] "=" Exp ;
LDFull. LocDef ::= [PIdent] ":" Exp "=" Exp ;
separator LocDef ";" ;
-- terms and types
EIdent. Exp6 ::= PIdent ;
EConstr. Exp6 ::= "{" PIdent "}" ;--%
ECons. Exp6 ::= "%" PIdent "%" ;--%
ESort. Exp6 ::= Sort ;
EString. Exp6 ::= String ;
EInt. Exp6 ::= Integer ;
EFloat. Exp6 ::= Double ;
EMeta. Exp6 ::= "?" ;
EEmpty. Exp6 ::= "[" "]" ;
EData. Exp6 ::= "data" ;
EList. Exp6 ::= "[" PIdent Exps "]" ;
EStrings. Exp6 ::= "[" String "]" ;
ERecord. Exp6 ::= "{" [LocDef] "}" ; -- !
ETuple. Exp6 ::= "<" [TupleComp] ">" ; --- needed for separator ","
EIndir. Exp6 ::= "(" "in" PIdent ")" ; -- indirection, used in judgements --%
ETyped. Exp6 ::= "<" Exp ":" Exp ">" ; -- typing, used for annotations
EProj. Exp5 ::= Exp5 "." Label ;
EQConstr. Exp5 ::= "{" PIdent "." PIdent "}" ; -- qualified constructor --%
EQCons. Exp5 ::= "%" PIdent "." PIdent ; -- qualified constant --%
EApp. Exp4 ::= Exp4 Exp5 ;
ETable. Exp4 ::= "table" "{" [Case] "}" ;
ETTable. Exp4 ::= "table" Exp6 "{" [Case] "}" ;
EVTable. Exp4 ::= "table" Exp6 "[" [Exp] "]" ;
ECase. Exp4 ::= "case" Exp "of" "{" [Case] "}" ;
EVariants. Exp4 ::= "variants" "{" [Exp] "}" ;
--- EPreCase. Exp4 ::= "pre" "{" [Case] "}" ;
EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ;
EStrs. Exp4 ::= "strs" "{" [Exp] "}" ;
EConAt. Exp4 ::= PIdent "@" Exp6 ; --%
EPatt. Exp4 ::= "#" Patt2 ;
EPattType. Exp4 ::= "pattern" Exp5 ;
ESelect. Exp3 ::= Exp3 "!" Exp4 ;
ETupTyp. Exp3 ::= Exp3 "*" Exp4 ;
EExtend. Exp3 ::= Exp3 "**" Exp4 ;
EGlue. Exp1 ::= Exp2 "+" Exp1 ;
EConcat. Exp ::= Exp1 "++" Exp ;
EAbstr. Exp ::= "\\" [Bind] "->" Exp ;
ECTable. Exp ::= "\\""\\" [Bind] "=>" Exp ;
EProd. Exp ::= Decl "->" Exp ;
ETType. Exp ::= Exp3 "=>" Exp ; -- these are thus right associative
ELet. Exp ::= "let" "{" [LocDef] "}" "in" Exp ;
ELetb. Exp ::= "let" [LocDef] "in" Exp ;
EWhere. Exp ::= Exp3 "where" "{" [LocDef] "}" ;
EEqs. Exp ::= "fn" "{" [Equation] "}" ; --%
EExample. Exp ::= "in" Exp5 String ;
coercions Exp 6 ;
separator Exp ";" ; -- in variants
-- list of arguments to category
NilExp. Exps ::= ;
ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses
-- patterns
PChar. Patt2 ::= "?" ;
PChars. Patt2 ::= "[" String "]" ;
PMacro. Patt2 ::= "#" PIdent ;
PM. Patt2 ::= "#" PIdent "." PIdent ;
PW. Patt2 ::= "_" ;
PV. Patt2 ::= PIdent ;
PCon. Patt2 ::= "{" PIdent "}" ; --%
PQ. Patt2 ::= PIdent "." PIdent ;
PInt. Patt2 ::= Integer ;
PFloat. Patt2 ::= Double ;
PStr. Patt2 ::= String ;
PR. Patt2 ::= "{" [PattAss] "}" ;
PTup. Patt2 ::= "<" [PattTupleComp] ">" ;
PC. Patt1 ::= PIdent [Patt] ;
PQC. Patt1 ::= PIdent "." PIdent [Patt] ;
PDisj. Patt ::= Patt "|" Patt1 ;
PSeq. Patt ::= Patt "+" Patt1 ;
PRep. Patt1 ::= Patt2 "*" ;
PAs. Patt1 ::= PIdent "@" Patt2 ;
PNeg. Patt1 ::= "-" Patt2 ;
coercions Patt 2 ;
PA. PattAss ::= [PIdent] "=" Patt ;
-- labels
LIdent. Label ::= PIdent ;
LVar. Label ::= "$" Integer ;
-- basic types
rules Sort ::=
"Type"
| "PType"
| "Tok" --%
| "Str"
| "Strs" ;
separator PattAss ";" ;
-- this is explicit to force higher precedence level on rhs
(:[]). [Patt] ::= Patt2 ;
(:). [Patt] ::= Patt2 [Patt] ;
-- binds in lambdas and lin rules
BIdent. Bind ::= PIdent ;
BWild. Bind ::= "_" ;
separator Bind "," ;
-- declarations in function types
DDec. Decl ::= "(" [Bind] ":" Exp ")" ;
DExp. Decl ::= Exp4 ; -- can thus be an application
-- tuple component (term or pattern)
TComp. TupleComp ::= Exp ;
PTComp. PattTupleComp ::= Patt ;
separator TupleComp "," ;
separator PattTupleComp "," ;
-- case branches
Case. Case ::= Patt "=>" Exp ;
separator nonempty Case ";" ;
-- cases in abstract syntax --%
Equ. Equation ::= [Patt] "->" Exp ; --%
separator Equation ";" ; --%
-- prefix alternatives
Alt. Altern ::= Exp "/" Exp ;
separator Altern ";" ;
-- in a context, higher precedence is required than in function types
DDDec. DDecl ::= "(" [Bind] ":" Exp ")" ;
DDExp. DDecl ::= Exp6 ; -- can thus *not* be an application
separator DDecl "" ;
-------------------------------------- --%
-- for backward compatibility --%
OldGr. OldGrammar ::= Include [TopDef] ; --%
NoIncl. Include ::= ; --%
Incl. Include ::= "include" [FileName] ; --%
FString. FileName ::= String ; --%
terminator nonempty FileName ";" ; --%
FIdent. FileName ::= PIdent ; --%
FSlash. FileName ::= "/" FileName ; --%
FDot. FileName ::= "." FileName ; --%
FMinus. FileName ::= "-" FileName ; --%
FAddId. FileName ::= PIdent FileName ; --%
token LString '\'' (char - '\'')* '\'' ; --%
ELString. Exp6 ::= LString ; --%
ELin. Exp4 ::= "Lin" PIdent ; --%
DefPrintOld. TopDef ::= "printname" [PrintDef] ; --%
DefLintype. TopDef ::= "lintype" [Def] ; --%
DefPattern. TopDef ::= "pattern" [Def] ; --%
-- deprecated packages are attempted to be interpreted --%
DefPackage. TopDef ::= "package" PIdent "=" "{" [TopDef] "}" ";" ; --%
-- these two are just ignored after parsing --%
DefVars. TopDef ::= "var" [Def] ; --%
DefTokenizer. TopDef ::= "tokenizer" PIdent ";" ; --%
-- identifiers
position token PIdent ('_' | letter) (letter | digit | '_' | '\'')* ;

257
src/GF/Source/GrammarToSource.hs Normal file
View File

@@ -0,0 +1,257 @@
----------------------------------------------------------------------
-- |
-- Module : GrammarToSource
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/04 11:05:07 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.23 $
--
-- From internal source syntax to BNFC-generated (used for printing).
-----------------------------------------------------------------------------
module GF.Source.GrammarToSource ( trGrammar,
trModule,
trAnyDef,
trLabel,
trt, tri, trp
) where
import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Grammar.Predef
import GF.Infra.Modules
import GF.Infra.Option
import qualified GF.Source.AbsGF as P
import GF.Infra.Ident
import qualified Data.ByteString.Char8 as BS
-- | AR 13\/5\/2003
--
-- translate internal to parsable and printable source
trGrammar :: SourceGrammar -> P.Grammar
trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes
trModule :: (Ident,SourceModInfo) -> P.ModDef
trModule (i,mo) = case mo of
ModMod m -> P.MModule compl typ body where
compl = case mstatus m of
MSIncomplete -> P.CMIncompl
_ -> P.CMCompl
i' = tri i
typ = case typeOfModule mo of
MTResource -> P.MTResource i'
MTAbstract -> P.MTAbstract i'
MTConcrete a -> P.MTConcrete i' (tri a)
MTTransfer a b -> P.MTTransfer i' (trOpen a) (trOpen b)
MTInstance a -> P.MTInstance i' (tri a)
MTInterface -> P.MTInterface i'
body = P.MBody
(trExtends (extend m))
(mkOpens (map trOpen (opens m)))
(mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ trFlags (flags m)))
trExtends :: [(Ident,MInclude Ident)] -> P.Extend
trExtends [] = P.NoExt
trExtends es = (P.Ext $ map tre es) where
tre (i,c) = case c of
MIAll -> P.IAll (tri i)
MIOnly is -> P.ISome (tri i) (map tri is)
MIExcept is -> P.IMinus (tri i) (map tri is)
---- this has to be completed with other mtys
forName (MTConcrete a) = tri a
trOpen :: OpenSpec Ident -> P.Open
trOpen o = case o of
OSimple OQNormal i -> P.OName (tri i)
OSimple q i -> P.OQualQO (trQualOpen q) (tri i)
OQualif q i j -> P.OQual (trQualOpen q) (tri i) (tri j)
trQualOpen q = case q of
OQNormal -> P.QOCompl
OQIncomplete -> P.QOIncompl
OQInterface -> P.QOInterface
mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds
mkTopDefs ds = ds
trAnyDef :: (Ident,Info) -> [P.TopDef]
trAnyDef (i,info) = let i' = tri i in case info of
AbsCat (Yes co) pd -> [P.DefCat [P.SimpleCatDef i' (map trDecl co)]]
AbsFun (Yes ty) (Yes EData) -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
AbsFun (Yes ty) pt -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ case pt of
Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
_ -> []
AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]]
---- don't destroy definitions!
AbsTrans f -> [P.DefTrans [P.DDef [mkName i'] (trt f)]]
ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
ResParam pp -> [P.DefPar [case pp of
Yes (ps,_) -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps]
May b -> P.ParDefIndir i' $ tri b
_ -> P.ParDefAbs i']]
ResOverload os tysts ->
[P.DefOper [P.DDef [mkName i'] (
foldl P.EApp
(P.EIdent $ tri $ cOverload)
(map (P.EIdent . tri) os ++
[P.ERecord [P.LDFull [i'] (trt ty) (trt fu) | (ty,fu) <- tysts]]))]]
CncCat (Yes ty) Nope _ ->
[P.DefLincat [P.PrintDef [mkName i'] (trt ty)]]
CncCat pty ptr ppr ->
[P.DefLindef [trDef i' pty ptr]] ++
[P.DefPrintCat [P.PrintDef [mkName i'] (trt pr)] | Yes pr <- [ppr]]
CncFun _ ptr ppr ->
[P.DefLin [trDef i' nope ptr]] ++
[P.DefPrintFun [P.PrintDef [mkName i'] (trt pr)] | Yes pr <- [ppr]]
{-
---- encoding of AnyInd without changing syntax. AR 20/9/2007
AnyInd s b ->
[P.DefOper [P.DDef [mkName i]
(P.EApp (P.EInt (if s then 1 else 0)) (P.EIdent (tri b)))]]
-}
_ -> []
trDef :: P.PIdent -> Perh Type -> Perh Term -> P.Def
trDef i pty ptr = case (pty,ptr) of
(Nope, Nope) -> P.DDef [mkName i] (P.EMeta) ---
(_, Nope) -> P.DDecl [mkName i] (trPerh pty)
(Nope, _ ) -> P.DDef [mkName i] (trPerh ptr)
(_, _ ) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr)
trPerh p = case p of
Yes t -> trt t
May b -> P.EIndir $ tri b
_ -> P.EMeta ---
trFlags :: ModuleOptions -> [P.TopDef]
trFlags = map trFlag . moduleOptionsGFO
trFlag :: (String,String) -> P.TopDef
trFlag (f,x) = P.DefFlag [P.FlagDef (tri $ identC (BS.pack f)) (tri $ identC (BS.pack x))]
trt :: Term -> P.Exp
trt trm = case trm of
Vr s -> P.EIdent $ tri s
Cn s -> P.ECons $ tri s
Con s -> P.EConstr $ tri s
Sort s -> P.ESort $! if s == cType then P.Sort_Type else
if s == cPType then P.Sort_PType else
if s == cTok then P.Sort_Tok else
if s == cStr then P.Sort_Str else
if s == cStrs then P.Sort_Strs else
error $ "not yet sort " +++ show trm
App c a -> P.EApp (trt c) (trt a)
Abs x b -> P.EAbstr [trb x] (trt b)
Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts]
Meta m -> P.EMeta
Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
Example t s -> P.EExample (trt t) s
R [] -> P.ETuple [] --- to get correct parsing when read back
R r -> P.ERecord $ map trAssign r
RecType r -> P.ERecord $ map trLabelling r
ExtR x y -> P.EExtend (trt x) (trt y)
P t l -> P.EProj (trt t) (trLabel l)
PI t l _ -> P.EProj (trt t) (trLabel l)
Q t l -> P.EQCons (tri t) (tri l)
QC t l -> P.EQConstr (tri t) (tri l)
TSh (TComp ty) cc -> P.ETTable (trt ty) (map trCases cc)
TSh (TTyped ty) cc -> P.ETTable (trt ty) (map trCases cc)
TSh (TWild ty) cc -> P.ETTable (trt ty) (map trCases cc)
T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc)
T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
T _ cc -> P.ETable (map trCase cc)
V ty cc -> P.EVTable (trt ty) (map trt cc)
Table x v -> P.ETType (trt x) (trt v)
S f x -> P.ESelect (trt f) (trt x)
---- Alias c a t -> "{-" +++ prt c +++ "=" +++ "-}" +++ prt t
-- Alias c a t -> prt (Let (c,(Just a,t)) (Vr c)) -- thus Alias is only internal
Let (x,(ma,b)) t ->
P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b') ma] (trt t)
where
b' = trt b
x' = [tri x]
Empty -> P.EEmpty
K [] -> P.EEmpty
K a -> P.EString a
C a b -> P.EConcat (trt a) (trt b)
EInt i -> P.EInt i
EFloat i -> P.EFloat i
EPatt p -> P.EPatt (trp p)
EPattType t -> P.EPattType (trt t)
Glue a b -> P.EGlue (trt a) (trt b)
Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
FV ts -> P.EVariants $ map trt ts
Strs tt -> P.EStrs $ map trt tt
EData -> P.EData
_ -> error $ "not yet" +++ show trm ----
trp :: Patt -> P.Patt
trp p = case p of
PW -> P.PW
PV s | isWildIdent s -> P.PW
PV s -> P.PV $ tri s
PC c [] -> P.PCon $ tri c
PC c a -> P.PC (tri c) (map trp a)
PP p c [] -> P.PQ (tri p) (tri c)
PP p c a -> P.PQC (tri p) (tri c) (map trp a)
PR r -> P.PR [P.PA [tri $ label2ident l] (trp p) | (l,p) <- r]
PString s -> P.PStr s
PInt i -> P.PInt i
PFloat i -> P.PFloat i
PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t)
PAs x p -> P.PAs (tri x) (trp p)
PAlt p q -> P.PDisj (trp p) (trp q)
PSeq p q -> P.PSeq (trp p) (trp q)
PRep p -> P.PRep (trp p)
PNeg p -> P.PNeg (trp p)
PChar -> P.PChar
PChars s -> P.PChars s
PM m c -> P.PM (tri m) (tri c)
trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
where
t' = trt t
x = [tri $ label2ident lab]
trLabelling (lab,ty) = P.LDDecl [tri $ label2ident lab] (trt ty)
trCase (patt, trm) = P.Case (trp patt) (trt trm)
trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm)
trDecl (x,ty) = P.DDDec [trb x] (trt ty)
tri :: Ident -> P.PIdent
tri = ppIdent . ident2bs
ppIdent i = P.PIdent ((0,0),i)
trb i = if isWildIdent i then P.BWild else P.BIdent (tri i)
trLabel :: Label -> P.Label
trLabel i = case i of
LIdent s -> P.LIdent $ ppIdent s
LVar i -> P.LVar $ toInteger i
mkName :: P.PIdent -> P.Name
mkName = P.IdentName

350
src/GF/Source/LexGF.hs Normal file
View File

File diff suppressed because one or more lines are too long

144
src/GF/Source/LexGF.x Normal file
View File

@@ -0,0 +1,144 @@
-- -*- haskell -*-
-- This Alex file was machine-generated by the BNF converter
{
{-# OPTIONS -fno-warn-incomplete-patterns #-}
module GF.Source.LexGF where
import GF.Source.SharedString
import qualified Data.ByteString.Char8 as BS
}
$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 = -- symbols and non-identifier-like reserved words
\; | \= | \{ | \} | \( | \) | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \= \> | \_ | \$ | \/
:-
"--" [.]* ; -- Toss single line comments
"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
$white+ ;
@rsyms { tok (\p s -> PT p (eitherResIdent (T_PIdent . share) s)) }
\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) }
(\_ | $l)($l | $d | \_ | \')* { tok (\p s -> PT p (eitherResIdent (T_PIdent . 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)) }
$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
{
tok f p s = f p s
share :: BS.ByteString -> BS.ByteString
share = shareString
data Tok =
TS !BS.ByteString !Int -- reserved words and symbols
| TL !BS.ByteString -- string literals
| TI !BS.ByteString -- integer literals
| TV !BS.ByteString -- identifiers
| TD !BS.ByteString -- double precision float literals
| TC !BS.ByteString -- character literals
| T_LString !BS.ByteString
| T_PIdent !BS.ByteString
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 _ (TL s) -> s
PT _ (TI s) -> s
PT _ (TV s) -> s
PT _ (TD s) -> s
PT _ (TC s) -> s
PT _ (T_LString s) -> s
PT _ (T_PIdent s) -> s
data BTree = N | B BS.ByteString Tok BTree BTree deriving (Show)
eitherResIdent :: (BS.ByteString -> Tok) -> BS.ByteString -> 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 "def" 39 (b "=>" 20 (b "++" 10 (b "(" 5 (b "$" 3 (b "#" 2 (b "!" 1 N N) N) (b "%" 4 N N)) (b "**" 8 (b "*" 7 (b ")" 6 N N) N) (b "+" 9 N N))) (b "/" 15 (b "->" 13 (b "-" 12 (b "," 11 N N) N) (b "." 14 N N)) (b "<" 18 (b ";" 17 (b ":" 16 N N) N) (b "=" 19 N N)))) (b "[" 30 (b "PType" 25 (b "@" 23 (b "?" 22 (b ">" 21 N N) N) (b "Lin" 24 N N)) (b "Tok" 28 (b "Strs" 27 (b "Str" 26 N N) N) (b "Type" 29 N N))) (b "case" 35 (b "_" 33 (b "]" 32 (b "\\" 31 N N) N) (b "abstract" 34 N N)) (b "concrete" 37 (b "cat" 36 N N) (b "data" 38 N N))))) (b "package" 58 (b "let" 49 (b "in" 44 (b "fun" 42 (b "fn" 41 (b "flags" 40 N N) N) (b "grammar" 43 N N)) (b "instance" 47 (b "incomplete" 46 (b "include" 45 N N) N) (b "interface" 48 N N))) (b "of" 54 (b "lindef" 52 (b "lincat" 51 (b "lin" 50 N N) N) (b "lintype" 53 N N)) (b "oper" 56 (b "open" 55 N N) (b "out" 57 N N)))) (b "transfer" 68 (b "resource" 63 (b "pre" 61 (b "pattern" 60 (b "param" 59 N N) N) (b "printname" 62 N N)) (b "table" 66 (b "strs" 65 (b "reuse" 64 N N) N) (b "tokenizer" 67 N N))) (b "with" 73 (b "variants" 71 (b "var" 70 (b "union" 69 N N) N) (b "where" 72 N N)) (b "|" 75 (b "{" 74 N N) (b "}" 76 N N)))))
where b s n = let bs = BS.pack s
in B bs (TS bs n)
unescapeInitTail :: BS.ByteString -> BS.ByteString
unescapeInitTail = BS.pack . unesc . tail . BS.unpack 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
BS.ByteString) -- current input string
tokens :: BS.ByteString -> [Token]
tokens str = go (alexStartPos, '\n', str)
where
go :: AlexInput -> [Token]
go inp@(pos, _, str) =
case alexScan inp 0 of
AlexEOF -> []
AlexError (pos, _, _) -> [Err pos]
AlexSkip inp' len -> go inp'
AlexToken inp' len act -> act pos (BS.take len str) : (go inp')
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (p, _, s) =
case BS.uncons s of
Nothing -> Nothing
Just (c,s) ->
let p' = alexMove p c
in p' `seq` Just (c, (p', c, s))
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (p, c, s) = c
}

7843
src/GF/Source/ParGF.hs Normal file
View File

File diff suppressed because it is too large Load Diff

642
src/GF/Source/ParGF.y Normal file
View File

@@ -0,0 +1,642 @@
-- This Happy file was machine-generated by the BNF converter
{
{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
module GF.Source.ParGF where
import GF.Source.AbsGF
import GF.Source.LexGF
import GF.Data.ErrM
import qualified Data.ByteString.Char8 as BS
}
%name pGrammar Grammar
%name pModDef ModDef
%name pOldGrammar OldGrammar
%partial pModHeader ModHeader
%name pExp Exp
-- no lexer declaration
%monad { Err } { thenM } { returnM }
%tokentype { Token }
%token
'!' { PT _ (TS _ 1) }
'#' { PT _ (TS _ 2) }
'$' { PT _ (TS _ 3) }
'%' { PT _ (TS _ 4) }
'(' { PT _ (TS _ 5) }
')' { PT _ (TS _ 6) }
'*' { PT _ (TS _ 7) }
'**' { PT _ (TS _ 8) }
'+' { PT _ (TS _ 9) }
'++' { PT _ (TS _ 10) }
',' { PT _ (TS _ 11) }
'-' { PT _ (TS _ 12) }
'->' { PT _ (TS _ 13) }
'.' { PT _ (TS _ 14) }
'/' { PT _ (TS _ 15) }
':' { PT _ (TS _ 16) }
';' { PT _ (TS _ 17) }
'<' { PT _ (TS _ 18) }
'=' { PT _ (TS _ 19) }
'=>' { PT _ (TS _ 20) }
'>' { PT _ (TS _ 21) }
'?' { PT _ (TS _ 22) }
'@' { PT _ (TS _ 23) }
'Lin' { PT _ (TS _ 24) }
'PType' { PT _ (TS _ 25) }
'Str' { PT _ (TS _ 26) }
'Strs' { PT _ (TS _ 27) }
'Tok' { PT _ (TS _ 28) }
'Type' { PT _ (TS _ 29) }
'[' { PT _ (TS _ 30) }
'\\' { PT _ (TS _ 31) }
']' { PT _ (TS _ 32) }
'_' { PT _ (TS _ 33) }
'abstract' { PT _ (TS _ 34) }
'case' { PT _ (TS _ 35) }
'cat' { PT _ (TS _ 36) }
'concrete' { PT _ (TS _ 37) }
'data' { PT _ (TS _ 38) }
'def' { PT _ (TS _ 39) }
'flags' { PT _ (TS _ 40) }
'fn' { PT _ (TS _ 41) }
'fun' { PT _ (TS _ 42) }
'grammar' { PT _ (TS _ 43) }
'in' { PT _ (TS _ 44) }
'include' { PT _ (TS _ 45) }
'incomplete' { PT _ (TS _ 46) }
'instance' { PT _ (TS _ 47) }
'interface' { PT _ (TS _ 48) }
'let' { PT _ (TS _ 49) }
'lin' { PT _ (TS _ 50) }
'lincat' { PT _ (TS _ 51) }
'lindef' { PT _ (TS _ 52) }
'lintype' { PT _ (TS _ 53) }
'of' { PT _ (TS _ 54) }
'open' { PT _ (TS _ 55) }
'oper' { PT _ (TS _ 56) }
'out' { PT _ (TS _ 57) }
'package' { PT _ (TS _ 58) }
'param' { PT _ (TS _ 59) }
'pattern' { PT _ (TS _ 60) }
'pre' { PT _ (TS _ 61) }
'printname' { PT _ (TS _ 62) }
'resource' { PT _ (TS _ 63) }
'reuse' { PT _ (TS _ 64) }
'strs' { PT _ (TS _ 65) }
'table' { PT _ (TS _ 66) }
'tokenizer' { PT _ (TS _ 67) }
'transfer' { PT _ (TS _ 68) }
'union' { PT _ (TS _ 69) }
'var' { PT _ (TS _ 70) }
'variants' { PT _ (TS _ 71) }
'where' { PT _ (TS _ 72) }
'with' { PT _ (TS _ 73) }
'{' { PT _ (TS _ 74) }
'|' { PT _ (TS _ 75) }
'}' { PT _ (TS _ 76) }
L_integ { PT _ (TI $$) }
L_quoted { PT _ (TL $$) }
L_doubl { PT _ (TD $$) }
L_LString { PT _ (T_LString $$) }
L_PIdent { PT _ (T_PIdent _) }
L_err { _ }
%%
Integer :: { Integer } : L_integ { (read (BS.unpack $1)) :: Integer }
String :: { String } : L_quoted { BS.unpack $1 }
Double :: { Double } : L_doubl { (read (BS.unpack $1)) :: Double }
LString :: { LString} : L_LString { LString ($1)}
PIdent :: { PIdent} : L_PIdent { PIdent (mkPosToken $1)}
Grammar :: { Grammar }
Grammar : ListModDef { Gr (reverse $1) }
ListModDef :: { [ModDef] }
ListModDef : {- empty -} { [] }
| ListModDef ModDef { flip (:) $1 $2 }
ModDef :: { ModDef }
ModDef : ModDef ';' { $1 }
| 'grammar' PIdent '=' '{' 'abstract' '=' PIdent ';' ListConcSpec '}' { MMain $2 $7 $9 }
| ComplMod ModType '=' ModBody { MModule $1 $2 $4 }
ConcSpec :: { ConcSpec }
ConcSpec : PIdent '=' ConcExp { ConcSpec $1 $3 }
ListConcSpec :: { [ConcSpec] }
ListConcSpec : {- empty -} { [] }
| ConcSpec { (:[]) $1 }
| ConcSpec ';' ListConcSpec { (:) $1 $3 }
ConcExp :: { ConcExp }
ConcExp : PIdent ListTransfer { ConcExp $1 (reverse $2) }
ListTransfer :: { [Transfer] }
ListTransfer : {- empty -} { [] }
| ListTransfer Transfer { flip (:) $1 $2 }
Transfer :: { Transfer }
Transfer : '(' 'transfer' 'in' Open ')' { TransferIn $4 }
| '(' 'transfer' 'out' Open ')' { TransferOut $4 }
ModHeader :: { ModDef }
ModHeader : ComplMod ModType '=' ModHeaderBody { MModule $1 $2 $4 }
ModHeaderBody :: { ModBody }
ModHeaderBody : Extend Opens { MBody $1 $2 [] }
| ListIncluded { MNoBody $1 }
| Included 'with' ListOpen { MWith $1 $3 }
| Included 'with' ListOpen '**' Opens { MWithBody $1 $3 $5 [] }
| ListIncluded '**' Included 'with' ListOpen { MWithE $1 $3 $5 }
| ListIncluded '**' Included 'with' ListOpen '**' Opens { MWithEBody $1 $3 $5 $7 [] }
| 'reuse' PIdent { MReuse $2 }
| 'union' ListIncluded { MUnion $2 }
ModType :: { ModType }
ModType : 'abstract' PIdent { MTAbstract $2 }
| 'resource' PIdent { MTResource $2 }
| 'interface' PIdent { MTInterface $2 }
| 'concrete' PIdent 'of' PIdent { MTConcrete $2 $4 }
| 'instance' PIdent 'of' PIdent { MTInstance $2 $4 }
| 'transfer' PIdent ':' Open '->' Open { MTTransfer $2 $4 $6 }
ModBody :: { ModBody }
ModBody : Extend Opens '{' ListTopDef '}' { MBody $1 $2 (reverse $4) }
| ListIncluded { MNoBody $1 }
| Included 'with' ListOpen { MWith $1 $3 }
| Included 'with' ListOpen '**' Opens '{' ListTopDef '}' { MWithBody $1 $3 $5 (reverse $7) }
| ListIncluded '**' Included 'with' ListOpen { MWithE $1 $3 $5 }
| ListIncluded '**' Included 'with' ListOpen '**' Opens '{' ListTopDef '}' { MWithEBody $1 $3 $5 $7 (reverse $9) }
| 'reuse' PIdent { MReuse $2 }
| 'union' ListIncluded { MUnion $2 }
ListTopDef :: { [TopDef] }
ListTopDef : {- empty -} { [] }
| ListTopDef TopDef { flip (:) $1 $2 }
Extend :: { Extend }
Extend : ListIncluded '**' { Ext $1 }
| {- empty -} { NoExt }
ListOpen :: { [Open] }
ListOpen : {- empty -} { [] }
| Open { (:[]) $1 }
| Open ',' ListOpen { (:) $1 $3 }
Opens :: { Opens }
Opens : {- empty -} { NoOpens }
| 'open' ListOpen 'in' { OpenIn $2 }
Open :: { Open }
Open : PIdent { OName $1 }
| '(' QualOpen PIdent ')' { OQualQO $2 $3 }
| '(' QualOpen PIdent '=' PIdent ')' { OQual $2 $3 $5 }
ComplMod :: { ComplMod }
ComplMod : {- empty -} { CMCompl }
| 'incomplete' { CMIncompl }
QualOpen :: { QualOpen }
QualOpen : {- empty -} { QOCompl }
| 'incomplete' { QOIncompl }
| 'interface' { QOInterface }
ListIncluded :: { [Included] }
ListIncluded : {- empty -} { [] }
| Included { (:[]) $1 }
| Included ',' ListIncluded { (:) $1 $3 }
Included :: { Included }
Included : PIdent { IAll $1 }
| PIdent '[' ListPIdent ']' { ISome $1 $3 }
| PIdent '-' '[' ListPIdent ']' { IMinus $1 $4 }
Def :: { Def }
Def : ListName ':' Exp { DDecl $1 $3 }
| ListName '=' Exp { DDef $1 $3 }
| Name ListPatt '=' Exp { DPatt $1 $2 $4 }
| ListName ':' Exp '=' Exp { DFull $1 $3 $5 }
TopDef :: { TopDef }
TopDef : 'cat' ListCatDef { DefCat $2 }
| 'fun' ListFunDef { DefFun $2 }
| 'data' ListFunDef { DefFunData $2 }
| 'def' ListDef { DefDef $2 }
| 'data' ListDataDef { DefData $2 }
| 'transfer' ListDef { DefTrans $2 }
| 'param' ListParDef { DefPar $2 }
| 'oper' ListDef { DefOper $2 }
| 'lincat' ListPrintDef { DefLincat $2 }
| 'lindef' ListDef { DefLindef $2 }
| 'lin' ListDef { DefLin $2 }
| 'printname' 'cat' ListPrintDef { DefPrintCat $3 }
| 'printname' 'fun' ListPrintDef { DefPrintFun $3 }
| 'flags' ListFlagDef { DefFlag $2 }
| 'printname' ListPrintDef { DefPrintOld $2 }
| 'lintype' ListDef { DefLintype $2 }
| 'pattern' ListDef { DefPattern $2 }
| 'package' PIdent '=' '{' ListTopDef '}' ';' { DefPackage $2 (reverse $5) }
| 'var' ListDef { DefVars $2 }
| 'tokenizer' PIdent ';' { DefTokenizer $2 }
CatDef :: { CatDef }
CatDef : PIdent ListDDecl { SimpleCatDef $1 (reverse $2) }
| '[' PIdent ListDDecl ']' { ListCatDef $2 (reverse $3) }
| '[' PIdent ListDDecl ']' '{' Integer '}' { ListSizeCatDef $2 (reverse $3) $6 }
FunDef :: { FunDef }
FunDef : ListPIdent ':' Exp { FunDef $1 $3 }
DataDef :: { DataDef }
DataDef : PIdent '=' ListDataConstr { DataDef $1 $3 }
DataConstr :: { DataConstr }
DataConstr : PIdent { DataId $1 }
| PIdent '.' PIdent { DataQId $1 $3 }
ListDataConstr :: { [DataConstr] }
ListDataConstr : {- empty -} { [] }
| DataConstr { (:[]) $1 }
| DataConstr '|' ListDataConstr { (:) $1 $3 }
ParDef :: { ParDef }
ParDef : PIdent '=' ListParConstr { ParDefDir $1 $3 }
| PIdent '=' '(' 'in' PIdent ')' { ParDefIndir $1 $5 }
| PIdent { ParDefAbs $1 }
ParConstr :: { ParConstr }
ParConstr : PIdent ListDDecl { ParConstr $1 (reverse $2) }
PrintDef :: { PrintDef }
PrintDef : ListName '=' Exp { PrintDef $1 $3 }
FlagDef :: { FlagDef }
FlagDef : PIdent '=' PIdent { FlagDef $1 $3 }
ListDef :: { [Def] }
ListDef : Def ';' { (:[]) $1 }
| Def ';' ListDef { (:) $1 $3 }
ListCatDef :: { [CatDef] }
ListCatDef : CatDef ';' { (:[]) $1 }
| CatDef ';' ListCatDef { (:) $1 $3 }
ListFunDef :: { [FunDef] }
ListFunDef : FunDef ';' { (:[]) $1 }
| FunDef ';' ListFunDef { (:) $1 $3 }
ListDataDef :: { [DataDef] }
ListDataDef : DataDef ';' { (:[]) $1 }
| DataDef ';' ListDataDef { (:) $1 $3 }
ListParDef :: { [ParDef] }
ListParDef : ParDef ';' { (:[]) $1 }
| ParDef ';' ListParDef { (:) $1 $3 }
ListPrintDef :: { [PrintDef] }
ListPrintDef : PrintDef ';' { (:[]) $1 }
| PrintDef ';' ListPrintDef { (:) $1 $3 }
ListFlagDef :: { [FlagDef] }
ListFlagDef : FlagDef ';' { (:[]) $1 }
| FlagDef ';' ListFlagDef { (:) $1 $3 }
ListParConstr :: { [ParConstr] }
ListParConstr : {- empty -} { [] }
| ParConstr { (:[]) $1 }
| ParConstr '|' ListParConstr { (:) $1 $3 }
ListPIdent :: { [PIdent] }
ListPIdent : PIdent { (:[]) $1 }
| PIdent ',' ListPIdent { (:) $1 $3 }
Name :: { Name }
Name : PIdent { IdentName $1 }
| '[' PIdent ']' { ListName $2 }
ListName :: { [Name] }
ListName : Name { (:[]) $1 }
| Name ',' ListName { (:) $1 $3 }
LocDef :: { LocDef }
LocDef : ListPIdent ':' Exp { LDDecl $1 $3 }
| ListPIdent '=' Exp { LDDef $1 $3 }
| ListPIdent ':' Exp '=' Exp { LDFull $1 $3 $5 }
ListLocDef :: { [LocDef] }
ListLocDef : {- empty -} { [] }
| LocDef { (:[]) $1 }
| LocDef ';' ListLocDef { (:) $1 $3 }
Exp6 :: { Exp }
Exp6 : PIdent { EIdent $1 }
| '{' PIdent '}' { EConstr $2 }
| '%' PIdent '%' { ECons $2 }
| Sort { ESort $1 }
| String { EString $1 }
| Integer { EInt $1 }
| Double { EFloat $1 }
| '?' { EMeta }
| '[' ']' { EEmpty }
| 'data' { EData }
| '[' PIdent Exps ']' { EList $2 $3 }
| '[' String ']' { EStrings $2 }
| '{' ListLocDef '}' { ERecord $2 }
| '<' ListTupleComp '>' { ETuple $2 }
| '(' 'in' PIdent ')' { EIndir $3 }
| '<' Exp ':' Exp '>' { ETyped $2 $4 }
| '(' Exp ')' { $2 }
| LString { ELString $1 }
Exp5 :: { Exp }
Exp5 : Exp5 '.' Label { EProj $1 $3 }
| '{' PIdent '.' PIdent '}' { EQConstr $2 $4 }
| '%' PIdent '.' PIdent { EQCons $2 $4 }
| Exp6 { $1 }
Exp4 :: { Exp }
Exp4 : Exp4 Exp5 { EApp $1 $2 }
| 'table' '{' ListCase '}' { ETable $3 }
| 'table' Exp6 '{' ListCase '}' { ETTable $2 $4 }
| 'table' Exp6 '[' ListExp ']' { EVTable $2 $4 }
| 'case' Exp 'of' '{' ListCase '}' { ECase $2 $5 }
| 'variants' '{' ListExp '}' { EVariants $3 }
| 'pre' '{' Exp ';' ListAltern '}' { EPre $3 $5 }
| 'strs' '{' ListExp '}' { EStrs $3 }
| PIdent '@' Exp6 { EConAt $1 $3 }
| '#' Patt2 { EPatt $2 }
| 'pattern' Exp5 { EPattType $2 }
| Exp5 { $1 }
| 'Lin' PIdent { ELin $2 }
Exp3 :: { Exp }
Exp3 : Exp3 '!' Exp4 { ESelect $1 $3 }
| Exp3 '*' Exp4 { ETupTyp $1 $3 }
| Exp3 '**' Exp4 { EExtend $1 $3 }
| Exp4 { $1 }
Exp1 :: { Exp }
Exp1 : Exp2 '+' Exp1 { EGlue $1 $3 }
| Exp2 { $1 }
Exp :: { Exp }
Exp : Exp1 '++' Exp { EConcat $1 $3 }
| '\\' ListBind '->' Exp { EAbstr $2 $4 }
| '\\' '\\' ListBind '=>' Exp { ECTable $3 $5 }
| Decl '->' Exp { EProd $1 $3 }
| Exp3 '=>' Exp { ETType $1 $3 }
| 'let' '{' ListLocDef '}' 'in' Exp { ELet $3 $6 }
| 'let' ListLocDef 'in' Exp { ELetb $2 $4 }
| Exp3 'where' '{' ListLocDef '}' { EWhere $1 $4 }
| 'fn' '{' ListEquation '}' { EEqs $3 }
| 'in' Exp5 String { EExample $2 $3 }
| Exp1 { $1 }
Exp2 :: { Exp }
Exp2 : Exp3 { $1 }
ListExp :: { [Exp] }
ListExp : {- empty -} { [] }
| Exp { (:[]) $1 }
| Exp ';' ListExp { (:) $1 $3 }
Exps :: { Exps }
Exps : {- empty -} { NilExp }
| Exp6 Exps { ConsExp $1 $2 }
Patt2 :: { Patt }
Patt2 : '?' { PChar }
| '[' String ']' { PChars $2 }
| '#' PIdent { PMacro $2 }
| '#' PIdent '.' PIdent { PM $2 $4 }
| '_' { PW }
| PIdent { PV $1 }
| '{' PIdent '}' { PCon $2 }
| PIdent '.' PIdent { PQ $1 $3 }
| Integer { PInt $1 }
| Double { PFloat $1 }
| String { PStr $1 }
| '{' ListPattAss '}' { PR $2 }
| '<' ListPattTupleComp '>' { PTup $2 }
| '(' Patt ')' { $2 }
Patt1 :: { Patt }
Patt1 : PIdent ListPatt { PC $1 $2 }
| PIdent '.' PIdent ListPatt { PQC $1 $3 $4 }
| Patt2 '*' { PRep $1 }
| PIdent '@' Patt2 { PAs $1 $3 }
| '-' Patt2 { PNeg $2 }
| Patt2 { $1 }
Patt :: { Patt }
Patt : Patt '|' Patt1 { PDisj $1 $3 }
| Patt '+' Patt1 { PSeq $1 $3 }
| Patt1 { $1 }
PattAss :: { PattAss }
PattAss : ListPIdent '=' Patt { PA $1 $3 }
Label :: { Label }
Label : PIdent { LIdent $1 }
| '$' Integer { LVar $2 }
Sort :: { Sort }
Sort : 'Type' { Sort_Type }
| 'PType' { Sort_PType }
| 'Tok' { Sort_Tok }
| 'Str' { Sort_Str }
| 'Strs' { Sort_Strs }
ListPattAss :: { [PattAss] }
ListPattAss : {- empty -} { [] }
| PattAss { (:[]) $1 }
| PattAss ';' ListPattAss { (:) $1 $3 }
ListPatt :: { [Patt] }
ListPatt : Patt2 { (:[]) $1 }
| Patt2 ListPatt { (:) $1 $2 }
Bind :: { Bind }
Bind : PIdent { BIdent $1 }
| '_' { BWild }
ListBind :: { [Bind] }
ListBind : {- empty -} { [] }
| Bind { (:[]) $1 }
| Bind ',' ListBind { (:) $1 $3 }
Decl :: { Decl }
Decl : '(' ListBind ':' Exp ')' { DDec $2 $4 }
| Exp4 { DExp $1 }
TupleComp :: { TupleComp }
TupleComp : Exp { TComp $1 }
PattTupleComp :: { PattTupleComp }
PattTupleComp : Patt { PTComp $1 }
ListTupleComp :: { [TupleComp] }
ListTupleComp : {- empty -} { [] }
| TupleComp { (:[]) $1 }
| TupleComp ',' ListTupleComp { (:) $1 $3 }
ListPattTupleComp :: { [PattTupleComp] }
ListPattTupleComp : {- empty -} { [] }
| PattTupleComp { (:[]) $1 }
| PattTupleComp ',' ListPattTupleComp { (:) $1 $3 }
Case :: { Case }
Case : Patt '=>' Exp { Case $1 $3 }
ListCase :: { [Case] }
ListCase : Case { (:[]) $1 }
| Case ';' ListCase { (:) $1 $3 }
Equation :: { Equation }
Equation : ListPatt '->' Exp { Equ $1 $3 }
ListEquation :: { [Equation] }
ListEquation : {- empty -} { [] }
| Equation { (:[]) $1 }
| Equation ';' ListEquation { (:) $1 $3 }
Altern :: { Altern }
Altern : Exp '/' Exp { Alt $1 $3 }
ListAltern :: { [Altern] }
ListAltern : {- empty -} { [] }
| Altern { (:[]) $1 }
| Altern ';' ListAltern { (:) $1 $3 }
DDecl :: { DDecl }
DDecl : '(' ListBind ':' Exp ')' { DDDec $2 $4 }
| Exp6 { DDExp $1 }
ListDDecl :: { [DDecl] }
ListDDecl : {- empty -} { [] }
| ListDDecl DDecl { flip (:) $1 $2 }
OldGrammar :: { OldGrammar }
OldGrammar : Include ListTopDef { OldGr $1 (reverse $2) }
Include :: { Include }
Include : {- empty -} { NoIncl }
| 'include' ListFileName { Incl $2 }
FileName :: { FileName }
FileName : String { FString $1 }
| PIdent { FIdent $1 }
| '/' FileName { FSlash $2 }
| '.' FileName { FDot $2 }
| '-' FileName { FMinus $2 }
| PIdent FileName { FAddId $1 $2 }
ListFileName :: { [FileName] }
ListFileName : FileName ';' { (:[]) $1 }
| FileName ';' ListFileName { (:) $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 ++
case ts of
[] -> []
[Err _] -> " due to lexer error"
_ -> " before " ++ unwords (map (BS.unpack . prToken) (take 4 ts))
myLexer = tokens
}

534
src/GF/Source/PrintGF.hs Normal file
View File

@@ -0,0 +1,534 @@
{-# OPTIONS -fno-warn-incomplete-patterns #-}
module GF.Source.PrintGF where
-- pretty-printer generated by the BNF converter
import GF.Source.AbsGF
import Data.Char
import qualified Data.ByteString.Char8 as BS
-- 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 LString where
prt _ (LString i) = doc (showString (BS.unpack i))
instance Print PIdent where
prt _ (PIdent (_,i)) = doc (showString (BS.unpack i))
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Grammar where
prt i e = case e of
Gr moddefs -> prPrec i 0 (concatD [prt 0 moddefs])
instance Print ModDef where
prt i e = case e of
MMain pident0 pident concspecs -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 pident0 , doc (showString "=") , doc (showString "{") , doc (showString "abstract") , doc (showString "=") , prt 0 pident , doc (showString ";") , prt 0 concspecs , doc (showString "}")])
MModule complmod modtype modbody -> prPrec i 0 (concatD [prt 0 complmod , prt 0 modtype , doc (showString "=") , prt 0 modbody])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print ConcSpec where
prt i e = case e of
ConcSpec pident concexp -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 concexp])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print ConcExp where
prt i e = case e of
ConcExp pident transfers -> prPrec i 0 (concatD [prt 0 pident , prt 0 transfers])
instance Print Transfer where
prt i e = case e of
TransferIn open -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "transfer") , doc (showString "in") , prt 0 open , doc (showString ")")])
TransferOut open -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "transfer") , doc (showString "out") , prt 0 open , 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
MTAbstract pident -> prPrec i 0 (concatD [doc (showString "abstract") , prt 0 pident])
MTResource pident -> prPrec i 0 (concatD [doc (showString "resource") , prt 0 pident])
MTInterface pident -> prPrec i 0 (concatD [doc (showString "interface") , prt 0 pident])
MTConcrete pident0 pident -> prPrec i 0 (concatD [doc (showString "concrete") , prt 0 pident0 , doc (showString "of") , prt 0 pident])
MTInstance pident0 pident -> prPrec i 0 (concatD [doc (showString "instance") , prt 0 pident0 , doc (showString "of") , prt 0 pident])
MTTransfer pident open0 open -> prPrec i 0 (concatD [doc (showString "transfer") , prt 0 pident , doc (showString ":") , prt 0 open0 , doc (showString "->") , prt 0 open])
instance Print ModBody where
prt i e = case e of
MBody extend opens topdefs -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
MNoBody includeds -> prPrec i 0 (concatD [prt 0 includeds])
MWith included opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens])
MWithBody included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
MWithE includeds included opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens])
MWithEBody includeds included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
MReuse pident -> prPrec i 0 (concatD [doc (showString "reuse") , prt 0 pident])
MUnion includeds -> prPrec i 0 (concatD [doc (showString "union") , prt 0 includeds])
instance Print Extend where
prt i e = case e of
Ext includeds -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**")])
NoExt -> prPrec i 0 (concatD [])
instance Print Opens where
prt i e = case e of
NoOpens -> prPrec i 0 (concatD [])
OpenIn opens -> prPrec i 0 (concatD [doc (showString "open") , prt 0 opens , doc (showString "in")])
instance Print Open where
prt i e = case e of
OName pident -> prPrec i 0 (concatD [prt 0 pident])
OQualQO qualopen pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 qualopen , prt 0 pident , doc (showString ")")])
OQual qualopen pident0 pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 qualopen , prt 0 pident0 , doc (showString "=") , prt 0 pident , doc (showString ")")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print ComplMod where
prt i e = case e of
CMCompl -> prPrec i 0 (concatD [])
CMIncompl -> prPrec i 0 (concatD [doc (showString "incomplete")])
instance Print QualOpen where
prt i e = case e of
QOCompl -> prPrec i 0 (concatD [])
QOIncompl -> prPrec i 0 (concatD [doc (showString "incomplete")])
QOInterface -> prPrec i 0 (concatD [doc (showString "interface")])
instance Print Included where
prt i e = case e of
IAll pident -> prPrec i 0 (concatD [prt 0 pident])
ISome pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "[") , prt 0 pidents , doc (showString "]")])
IMinus pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "-") , doc (showString "[") , prt 0 pidents , doc (showString "]")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Def where
prt i e = case e of
DDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp])
DDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp])
DPatt name patts exp -> prPrec i 0 (concatD [prt 0 name , prt 0 patts , doc (showString "=") , prt 0 exp])
DFull names exp0 exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp])
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 TopDef where
prt i e = case e of
DefCat catdefs -> prPrec i 0 (concatD [doc (showString "cat") , prt 0 catdefs])
DefFun fundefs -> prPrec i 0 (concatD [doc (showString "fun") , prt 0 fundefs])
DefFunData fundefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 fundefs])
DefDef defs -> prPrec i 0 (concatD [doc (showString "def") , prt 0 defs])
DefData datadefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 datadefs])
DefTrans defs -> prPrec i 0 (concatD [doc (showString "transfer") , prt 0 defs])
DefPar pardefs -> prPrec i 0 (concatD [doc (showString "param") , prt 0 pardefs])
DefOper defs -> prPrec i 0 (concatD [doc (showString "oper") , prt 0 defs])
DefLincat printdefs -> prPrec i 0 (concatD [doc (showString "lincat") , prt 0 printdefs])
DefLindef defs -> prPrec i 0 (concatD [doc (showString "lindef") , prt 0 defs])
DefLin defs -> prPrec i 0 (concatD [doc (showString "lin") , prt 0 defs])
DefPrintCat printdefs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "cat") , prt 0 printdefs])
DefPrintFun printdefs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "fun") , prt 0 printdefs])
DefFlag flagdefs -> prPrec i 0 (concatD [doc (showString "flags") , prt 0 flagdefs])
DefPrintOld printdefs -> prPrec i 0 (concatD [doc (showString "printname") , prt 0 printdefs])
DefLintype defs -> prPrec i 0 (concatD [doc (showString "lintype") , prt 0 defs])
DefPattern defs -> prPrec i 0 (concatD [doc (showString "pattern") , prt 0 defs])
DefPackage pident topdefs -> prPrec i 0 (concatD [doc (showString "package") , prt 0 pident , doc (showString "=") , doc (showString "{") , prt 0 topdefs , doc (showString "}") , doc (showString ";")])
DefVars defs -> prPrec i 0 (concatD [doc (showString "var") , prt 0 defs])
DefTokenizer pident -> prPrec i 0 (concatD [doc (showString "tokenizer") , prt 0 pident , doc (showString ";")])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print CatDef where
prt i e = case e of
SimpleCatDef pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls])
ListCatDef pident ddecls -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]")])
ListSizeCatDef pident ddecls n -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]") , doc (showString "{") , prt 0 n , doc (showString "}")])
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 FunDef where
prt i e = case e of
FunDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp])
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 DataDef where
prt i e = case e of
DataDef pident dataconstrs -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 dataconstrs])
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 DataConstr where
prt i e = case e of
DataId pident -> prPrec i 0 (concatD [prt 0 pident])
DataQId pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
instance Print ParDef where
prt i e = case e of
ParDefDir pident parconstrs -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 parconstrs])
ParDefIndir pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString "=") , doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")])
ParDefAbs pident -> prPrec i 0 (concatD [prt 0 pident])
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 ParConstr where
prt i e = case e of
ParConstr pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
instance Print PrintDef where
prt i e = case e of
PrintDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp])
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 FlagDef where
prt i e = case e of
FlagDef pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString "=") , prt 0 pident])
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 Name where
prt i e = case e of
IdentName pident -> prPrec i 0 (concatD [prt 0 pident])
ListName pident -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , doc (showString "]")])
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print LocDef where
prt i e = case e of
LDDecl pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp])
LDDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 exp])
LDFull pidents exp0 exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp0 , 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 Exp where
prt i e = case e of
EIdent pident -> prPrec i 6 (concatD [prt 0 pident])
EConstr pident -> prPrec i 6 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")])
ECons pident -> prPrec i 6 (concatD [doc (showString "%") , prt 0 pident , doc (showString "%")])
ESort sort -> prPrec i 6 (concatD [prt 0 sort])
EString str -> prPrec i 6 (concatD [prt 0 str])
EInt n -> prPrec i 6 (concatD [prt 0 n])
EFloat d -> prPrec i 6 (concatD [prt 0 d])
EMeta -> prPrec i 6 (concatD [doc (showString "?")])
EEmpty -> prPrec i 6 (concatD [doc (showString "[") , doc (showString "]")])
EData -> prPrec i 6 (concatD [doc (showString "data")])
EList pident exps -> prPrec i 6 (concatD [doc (showString "[") , prt 0 pident , prt 0 exps , doc (showString "]")])
EStrings str -> prPrec i 6 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
ERecord locdefs -> prPrec i 6 (concatD [doc (showString "{") , prt 0 locdefs , doc (showString "}")])
ETuple tuplecomps -> prPrec i 6 (concatD [doc (showString "<") , prt 0 tuplecomps , doc (showString ">")])
EIndir pident -> prPrec i 6 (concatD [doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")])
ETyped exp0 exp -> prPrec i 6 (concatD [doc (showString "<") , prt 0 exp0 , doc (showString ":") , prt 0 exp , doc (showString ">")])
EProj exp label -> prPrec i 5 (concatD [prt 5 exp , doc (showString ".") , prt 0 label])
EQConstr pident0 pident -> prPrec i 5 (concatD [doc (showString "{") , prt 0 pident0 , doc (showString ".") , prt 0 pident , doc (showString "}")])
EQCons pident0 pident -> prPrec i 5 (concatD [doc (showString "%") , prt 0 pident0 , doc (showString ".") , prt 0 pident])
EApp exp0 exp -> prPrec i 4 (concatD [prt 4 exp0 , prt 5 exp])
ETable cases -> prPrec i 4 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")])
ETTable exp cases -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "{") , prt 0 cases , doc (showString "}")])
EVTable exp exps -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "[") , prt 0 exps , doc (showString "]")])
ECase exp cases -> prPrec i 4 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
EVariants exps -> prPrec i 4 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")])
EPre exp alterns -> prPrec i 4 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")])
EStrs exps -> prPrec i 4 (concatD [doc (showString "strs") , doc (showString "{") , prt 0 exps , doc (showString "}")])
EConAt pident exp -> prPrec i 4 (concatD [prt 0 pident , doc (showString "@") , prt 6 exp])
EPatt patt -> prPrec i 4 (concatD [doc (showString "#") , prt 2 patt])
EPattType exp -> prPrec i 4 (concatD [doc (showString "pattern") , prt 5 exp])
ESelect exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "!") , prt 4 exp])
ETupTyp exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "*") , prt 4 exp])
EExtend exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "**") , prt 4 exp])
EGlue exp0 exp -> prPrec i 1 (concatD [prt 2 exp0 , doc (showString "+") , prt 1 exp])
EConcat exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString "++") , prt 0 exp])
EAbstr binds exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 binds , doc (showString "->") , prt 0 exp])
ECTable binds exp -> prPrec i 0 (concatD [doc (showString "\\") , doc (showString "\\") , prt 0 binds , doc (showString "=>") , prt 0 exp])
EProd decl exp -> prPrec i 0 (concatD [prt 0 decl , doc (showString "->") , prt 0 exp])
ETType exp0 exp -> prPrec i 0 (concatD [prt 3 exp0 , doc (showString "=>") , prt 0 exp])
ELet locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 locdefs , doc (showString "}") , doc (showString "in") , prt 0 exp])
ELetb locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , prt 0 locdefs , doc (showString "in") , prt 0 exp])
EWhere exp locdefs -> prPrec i 0 (concatD [prt 3 exp , doc (showString "where") , doc (showString "{") , prt 0 locdefs , doc (showString "}")])
EEqs equations -> prPrec i 0 (concatD [doc (showString "fn") , doc (showString "{") , prt 0 equations , doc (showString "}")])
EExample exp str -> prPrec i 0 (concatD [doc (showString "in") , prt 5 exp , prt 0 str])
ELString lstring -> prPrec i 6 (concatD [prt 0 lstring])
ELin pident -> prPrec i 4 (concatD [doc (showString "Lin") , prt 0 pident])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Exps where
prt i e = case e of
NilExp -> prPrec i 0 (concatD [])
ConsExp exp exps -> prPrec i 0 (concatD [prt 6 exp , prt 0 exps])
instance Print Patt where
prt i e = case e of
PChar -> prPrec i 2 (concatD [doc (showString "?")])
PChars str -> prPrec i 2 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
PMacro pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident])
PM pident0 pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident0 , doc (showString ".") , prt 0 pident])
PW -> prPrec i 2 (concatD [doc (showString "_")])
PV pident -> prPrec i 2 (concatD [prt 0 pident])
PCon pident -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")])
PQ pident0 pident -> prPrec i 2 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident])
PInt n -> prPrec i 2 (concatD [prt 0 n])
PFloat d -> prPrec i 2 (concatD [prt 0 d])
PStr str -> prPrec i 2 (concatD [prt 0 str])
PR pattasss -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pattasss , doc (showString "}")])
PTup patttuplecomps -> prPrec i 2 (concatD [doc (showString "<") , prt 0 patttuplecomps , doc (showString ">")])
PC pident patts -> prPrec i 1 (concatD [prt 0 pident , prt 0 patts])
PQC pident0 pident patts -> prPrec i 1 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident , prt 0 patts])
PDisj patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "|") , prt 1 patt])
PSeq patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "+") , prt 1 patt])
PRep patt -> prPrec i 1 (concatD [prt 2 patt , doc (showString "*")])
PAs pident patt -> prPrec i 1 (concatD [prt 0 pident , doc (showString "@") , prt 2 patt])
PNeg patt -> prPrec i 1 (concatD [doc (showString "-") , prt 2 patt])
prtList es = case es of
[x] -> (concatD [prt 2 x])
x:xs -> (concatD [prt 2 x , prt 0 xs])
instance Print PattAss where
prt i e = case e of
PA pidents patt -> prPrec i 0 (concatD [prt 0 pidents , 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])
instance Print Label where
prt i e = case e of
LIdent pident -> prPrec i 0 (concatD [prt 0 pident])
LVar n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
instance Print Sort where
prt i e = case e of
Sort_Type -> prPrec i 0 (concatD [doc (showString "Type")])
Sort_PType -> prPrec i 0 (concatD [doc (showString "PType")])
Sort_Tok -> prPrec i 0 (concatD [doc (showString "Tok")])
Sort_Str -> prPrec i 0 (concatD [doc (showString "Str")])
Sort_Strs -> prPrec i 0 (concatD [doc (showString "Strs")])
instance Print Bind where
prt i e = case e of
BIdent pident -> prPrec i 0 (concatD [prt 0 pident])
BWild -> prPrec i 0 (concatD [doc (showString "_")])
prtList es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Decl where
prt i e = case e of
DDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")])
DExp exp -> prPrec i 0 (concatD [prt 4 exp])
instance Print TupleComp where
prt i e = case e of
TComp exp -> prPrec i 0 (concatD [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 PattTupleComp where
prt i e = case e of
PTComp patt -> prPrec i 0 (concatD [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])
instance Print Case where
prt i e = case e of
Case patt exp -> prPrec i 0 (concatD [prt 0 patt , doc (showString "=>") , prt 0 exp])
prtList es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print Equation where
prt i e = case e of
Equ patts exp -> prPrec i 0 (concatD [prt 0 patts , 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 Altern where
prt i e = case e of
Alt exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , 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 DDecl where
prt i e = case e of
DDDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")])
DDExp exp -> prPrec i 0 (concatD [prt 6 exp])
prtList es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , prt 0 xs])
instance Print OldGrammar where
prt i e = case e of
OldGr include topdefs -> prPrec i 0 (concatD [prt 0 include , prt 0 topdefs])
instance Print Include where
prt i e = case e of
NoIncl -> prPrec i 0 (concatD [])
Incl filenames -> prPrec i 0 (concatD [doc (showString "include") , prt 0 filenames])
instance Print FileName where
prt i e = case e of
FString str -> prPrec i 0 (concatD [prt 0 str])
FIdent pident -> prPrec i 0 (concatD [prt 0 pident])
FSlash filename -> prPrec i 0 (concatD [doc (showString "/") , prt 0 filename])
FDot filename -> prPrec i 0 (concatD [doc (showString ".") , prt 0 filename])
FMinus filename -> prPrec i 0 (concatD [doc (showString "-") , prt 0 filename])
FAddId pident filename -> prPrec i 0 (concatD [prt 0 pident , prt 0 filename])
prtList es = case es of
[x] -> (concatD [prt 0 x , doc (showString ";")])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])

20
src/GF/Source/SharedString.hs Normal file
View File

@@ -0,0 +1,20 @@
module GF.Source.SharedString (shareString) where
import Data.Map as M
import Data.IORef
import qualified Data.ByteString.Char8 as BS
import System.IO.Unsafe (unsafePerformIO)
{-# NOINLINE stringPoolRef #-}
stringPoolRef :: IORef (M.Map BS.ByteString BS.ByteString)
stringPoolRef = unsafePerformIO $ newIORef M.empty
{-# NOINLINE shareString #-}
shareString :: BS.ByteString -> BS.ByteString
shareString s = unsafePerformIO $ do
stringPool <- readIORef stringPoolRef
case M.lookup s stringPool of
Just s' -> return s'
Nothing -> do let s' = BS.copy s
writeIORef stringPoolRef $! M.insert s' s' stringPool
return s'

765
src/GF/Source/SourceToGrammar.hs Normal file
View File

@@ -0,0 +1,765 @@
----------------------------------------------------------------------
-- |
-- Module : SourceToGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/04 11:05:07 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.28 $
--
-- based on the skeleton Haskell module generated by the BNF converter
-----------------------------------------------------------------------------
module GF.Source.SourceToGrammar ( transGrammar,
transInclude,
transModDef,
transOldGrammar,
transExp,
newReservedWords
) where
import qualified GF.Grammar.Grammar as G
import qualified GF.Grammar.PrGrammar as GP
import qualified GF.Infra.Modules as GM
import qualified GF.Grammar.Macros as M
import qualified GF.Compile.Update as U
import qualified GF.Infra.Option as GO
import qualified GF.Compile.ModDeps as GD
import GF.Grammar.Predef
import GF.Infra.Ident
import GF.Source.AbsGF
import GF.Source.PrintGF
import GF.Compile.RemoveLiT --- for bw compat
import GF.Data.Operations
import GF.Infra.Option
import Control.Monad
import Data.Char
import Data.List (genericReplicate)
import qualified Data.ByteString.Char8 as BS
-- based on the skeleton Haskell module generated by the BNF converter
type Result = Err String
failure :: Show a => a -> Err b
failure x = Bad $ "Undefined case: " ++ show x
getIdentPos :: PIdent -> Err (Ident,Int)
getIdentPos x = case x of
PIdent ((line,_),c) -> return (IC c,line)
transIdent :: PIdent -> Err Ident
transIdent = liftM fst . getIdentPos
transName :: Name -> Err Ident
transName n = case n of
IdentName i -> transIdent i
ListName i -> liftM mkListId (transIdent i)
transNamePos :: Name -> Err (Ident,Int)
transNamePos n = case n of
IdentName i -> getIdentPos i
ListName i -> liftM (\ (c,p) -> (mkListId c,p)) (getIdentPos i)
transGrammar :: Grammar -> Err G.SourceGrammar
transGrammar x = case x of
Gr moddefs -> do
moddefs' <- mapM transModDef moddefs
GD.mkSourceGrammar moddefs'
transModDef :: ModDef -> Err (Ident, G.SourceModInfo)
transModDef x = case x of
MMain id0 id concspecs -> do
id0' <- transIdent id0
id' <- transIdent id
concspecs' <- mapM transConcSpec concspecs
return $ (id0', GM.ModMainGrammar (GM.MainGrammar id' concspecs'))
MModule compl mtyp body -> do
let mstat' = transComplMod compl
(trDef, mtyp', id') <- case mtyp of
MTAbstract id -> do
id' <- transIdent id
return (transAbsDef, GM.MTAbstract, id')
MTResource id -> mkModRes id GM.MTResource body
MTConcrete id open -> do
id' <- transIdent id
open' <- transIdent open
return (transCncDef, GM.MTConcrete open', id')
MTTransfer id a b -> do
id' <- transIdent id
a' <- transOpen a
b' <- transOpen a
return (transAbsDef, GM.MTTransfer a' b', id')
MTInterface id -> mkModRes id GM.MTInterface body
MTInstance id open -> do
open' <- transIdent open
mkModRes id (GM.MTInstance open') body
mkBody (mstat', trDef, mtyp', id') body
where
poss = emptyBinTree ----
mkBody xx@(mstat', trDef, mtyp', id') bod = case bod of
MNoBody incls -> do
mkBody xx $ MBody (Ext incls) NoOpens []
MBody extends opens defs -> do
extends' <- transExtend extends
opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs
poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds]
defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatModuleOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id',
GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1))
MReuse _ -> do
return (id', GM.ModMod (GM.Module mtyp' mstat' noModuleOptions [] [] emptyBinTree poss))
MUnion imps -> do
imps' <- mapM transIncluded imps
return (id',
GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' noModuleOptions [] [] emptyBinTree poss))
MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
MWithE extends m insts -> mkBody xx $ MWithEBody extends m insts NoOpens []
MWithEBody extends m insts opens defs -> do
extends' <- mapM transIncludedExt extends
m' <- transIncludedExt m
insts' <- mapM transOpen insts
opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs
poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds]
defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatModuleOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id',
GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1) m' insts')
mkModRes id mtyp body = do
id' <- transIdent id
case body of
MReuse c -> do
c' <- transIdent c
mtyp' <- trMReuseType mtyp c'
return (transResDef, GM.MTReuse mtyp', id')
_ -> return (transResDef, mtyp, id')
trMReuseType mtyp c = case mtyp of
GM.MTInterface -> return $ GM.MRInterface c
GM.MTInstance op -> return $ GM.MRInstance c op
GM.MTResource -> return $ GM.MRResource c
transComplMod :: ComplMod -> GM.ModuleStatus
transComplMod x = case x of
CMCompl -> GM.MSComplete
CMIncompl -> GM.MSIncomplete
getTopDefs :: [TopDef] -> [TopDef]
getTopDefs x = x
transConcSpec :: ConcSpec -> Err (GM.MainConcreteSpec Ident)
transConcSpec x = case x of
ConcSpec id concexp -> do
id' <- transIdent id
(m,mi,mo) <- transConcExp concexp
return $ GM.MainConcreteSpec id' m mi mo
transConcExp :: ConcExp ->
Err (Ident, Maybe (GM.OpenSpec Ident),Maybe (GM.OpenSpec Ident))
transConcExp x = case x of
ConcExp id transfers -> do
id' <- transIdent id
trs <- mapM transTransfer transfers
tin <- case [o | Left o <- trs] of
[o] -> return $ Just o
[] -> return $ Nothing
_ -> Bad "ambiguous transfer in"
tout <- case [o | Right o <- trs] of
[o] -> return $ Just o
[] -> return $ Nothing
_ -> Bad "ambiguous transfer out"
return (id',tin,tout)
transTransfer :: Transfer ->
Err (Either (GM.OpenSpec Ident)(GM.OpenSpec Ident))
transTransfer x = case x of
TransferIn open -> liftM Left $ transOpen open
TransferOut open -> liftM Right $ transOpen open
transExtend :: Extend -> Err [(Ident,GM.MInclude Ident)]
transExtend x = case x of
Ext ids -> mapM transIncludedExt ids
NoExt -> return []
transOpens :: Opens -> Err [GM.OpenSpec Ident]
transOpens x = case x of
NoOpens -> return []
OpenIn opens -> mapM transOpen opens
transOpen :: Open -> Err (GM.OpenSpec Ident)
transOpen x = case x of
OName id -> liftM (GM.OSimple GM.OQNormal) $ transIdent id
OQualQO q id -> liftM2 GM.OSimple (transQualOpen q) (transIdent id)
OQual q id m -> liftM3 GM.OQualif (transQualOpen q) (transIdent id) (transIdent m)
transQualOpen :: QualOpen -> Err GM.OpenQualif
transQualOpen x = case x of
QOCompl -> return GM.OQNormal
QOInterface -> return GM.OQInterface
QOIncompl -> return GM.OQIncomplete
transIncluded :: Included -> Err (Ident,[Ident])
transIncluded x = case x of
IAll i -> liftM (flip (curry id) []) $ transIdent i
ISome i ids -> liftM2 (curry id) (transIdent i) (mapM transIdent ids)
IMinus i ids -> liftM2 (curry id) (transIdent i) (mapM transIdent ids) ----
transIncludedExt :: Included -> Err (Ident, GM.MInclude Ident)
transIncludedExt x = case x of
IAll i -> liftM2 (,) (transIdent i) (return GM.MIAll)
ISome i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly $ mapM transIdent ids)
IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ mapM transIdent ids)
--- where no position is saved
nopos :: Int
nopos = -1
buildPosTree :: Ident -> [(Ident,Int)] -> BinTree Ident (String,(Int,Int))
buildPosTree m = buildTree . mkPoss . filter ((>0) . snd) where
mkPoss cs = case cs of
(i,p):rest@((_,q):_) -> (i,(name,(p,max p (q-1)))) : mkPoss rest
(i,p):[] -> (i,(name,(p,p+100))) : [] --- don't know last line
_ -> []
name = prIdent m ++ ".gf" ----
transAbsDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.ModuleOptions)
transAbsDef x = case x of
DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
DefFun fundefs -> do
fundefs' <- mapM transFunDef fundefs
returnl [(fun, nopos, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs]
DefFunData fundefs -> do
fundefs' <- mapM transFunDef fundefs
returnl $
[(cat, nopos, G.AbsCat nope (yes [G.Cn fun])) | (funs,typ) <- fundefs',
fun <- funs,
Ok (_,cat) <- [M.valCat typ]
] ++
[(fun, nopos, G.AbsFun (yes typ) (yes G.EData)) | (funs,typ) <- fundefs', fun <- funs]
DefDef defs -> do
defs' <- liftM concat $ mapM getDefsGen defs
returnl [(c, nopos, G.AbsFun nope pe) | ((c,p),(_,pe)) <- defs']
DefData ds -> do
ds' <- mapM transDataDef ds
returnl $
[(c, nopos, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++
[(f, nopos, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf]
DefTrans defs -> do
defs' <- liftM concat $ mapM getDefsGen defs
returnl [(c, nopos, G.AbsTrans f) | ((c,p),(_,Yes f)) <- defs']
DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
where
-- to get data constructors as terms
funs t = case t of
G.Cn f -> [f]
G.Q _ f -> [f]
G.QC _ f -> [f]
_ -> []
returnl :: a -> Err (Either a b)
returnl = return . Left
transFlagDef :: FlagDef -> Err GO.ModuleOptions
transFlagDef x = case x of
FlagDef f x -> parseModuleOptions ["--" ++ prPIdent f ++ "=" ++ prPIdent x]
where
prPIdent (PIdent (_,c)) = BS.unpack c
-- | Cat definitions can also return some fun defs
-- if it is a list category definition
transCatDef :: CatDef -> Err [(Ident, Int, G.Info)]
transCatDef x = case x of
SimpleCatDef id ddecls -> do
(id',pos) <- getIdentPos id
liftM (:[]) $ cat id' pos ddecls
ListCatDef id ddecls -> listCat id ddecls 0
ListSizeCatDef id ddecls size -> listCat id ddecls size
where
cat i pos ddecls = do
-- i <- transIdent id
cont <- liftM concat $ mapM transDDecl ddecls
return (i, pos, G.AbsCat (yes cont) nope)
listCat id ddecls size = do
(id',pos) <- getIdentPos id
let
li = mkListId id'
baseId = mkBaseId id'
consId = mkConsId id'
catd0@(c,p,G.AbsCat (Yes cont0) _) <- cat li pos ddecls
let
catd = (c,pos,G.AbsCat (Yes cont0) (Yes [G.Cn baseId,G.Cn consId]))
cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0]
xs = map (G.Vr . fst) cont
cd = M.mkDecl (M.mkApp (G.Vr id') xs)
lc = M.mkApp (G.Vr li) xs
niltyp = M.mkProdSimple (cont ++ genericReplicate size cd) lc
nilfund = (baseId, nopos, G.AbsFun (yes niltyp) (yes G.EData))
constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc
consfund = (consId, nopos, G.AbsFun (yes constyp) (yes G.EData))
return [catd,nilfund,consfund]
mkId x i = if isWildIdent x then (varX i) else x
transFunDef :: FunDef -> Err ([Ident], G.Type)
transFunDef x = case x of
FunDef ids typ -> liftM2 (,) (mapM transIdent ids) (transExp typ)
transDataDef :: DataDef -> Err (Ident,[G.Term])
transDataDef x = case x of
DataDef id ds -> liftM2 (,) (transIdent id) (mapM transData ds)
where
transData d = case d of
DataId id -> liftM G.Cn $ transIdent id
DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id)
transResDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.ModuleOptions)
transResDef x = case x of
DefPar pardefs -> do
pardefs' <- mapM transParDef pardefs
returnl $ [(p, nopos, G.ResParam (if null pars
then nope -- abstract param type
else (yes (pars,Nothing))))
| (p,pars) <- pardefs']
++ [(f, nopos, G.ResValue (yes (M.mkProdSimple co (G.Cn p),Nothing))) |
(p,pars) <- pardefs', (f,co) <- pars]
DefOper defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl $
concatMap mkOverload [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs']
DefLintype defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs']
DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition form in resource" +++ printTree x
where
mkOverload op@(c,p,j) = case j of
G.ResOper _ (Yes df) -> case M.appForm df of
(keyw, ts@(_:_)) | isOverloading keyw -> case last ts of
G.R fs ->
[(c,p,G.ResOverload [m | G.Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs])]
_ -> [op]
_ -> [op]
-- to enable separare type signature --- not type-checked
G.ResOper (Yes df) _ -> case M.appForm df of
(keyw, ts@(_:_)) | isOverloading keyw -> case last ts of
G.RecType _ -> []
_ -> [op]
_ -> [op]
_ -> [(c,p,j)]
isOverloading keyw =
GP.prt keyw == "overload" -- overload is a "soft keyword"
isRec t = case t of
G.R _ -> True
_ -> False
transParDef :: ParDef -> Err (Ident, [G.Param])
transParDef x = case x of
ParDefDir id params -> liftM2 (,) (transIdent id) (mapM transParConstr params)
ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
_ -> Bad $ "illegal definition in resource:" ++++ printTree x
transCncDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.ModuleOptions)
transCncDef x = case x of
DefLincat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, nopos, G.CncCat (yes t) nope nope) | (f,t) <- defs']
DefLindef defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, p, G.CncCat pt pe nope) | ((f,p),(pt,pe)) <- defs']
DefLin defs -> do
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, p, G.CncFun Nothing pe nope) | ((f,p),(_,pe)) <- defs']
DefPrintCat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, nopos, G.CncCat nope nope (yes e)) | (f,e) <- defs']
DefPrintFun defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, nopos, G.CncFun Nothing nope (yes e)) | (f,e) <- defs']
DefPrintOld defs -> do --- a guess, for backward compatibility
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, nopos, G.CncFun Nothing nope (yes e)) | (f,e) <- defs']
DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs
DefPattern defs -> do
defs' <- liftM concat $ mapM getDefs defs
let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs']
returnl [(f, p, G.CncFun Nothing (yes t) nope) | ((f,p),t) <- defs2]
_ -> errIn ("illegal definition in concrete syntax:") $ transResDef x
transPrintDef :: PrintDef -> Err [(Ident,G.Term)]
transPrintDef x = case x of
PrintDef ids exp -> do
(ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp)
return $ [(i,e) | i <- ids]
getDefsGen :: Def -> Err [((Ident, Int),(G.Perh G.Type, G.Perh G.Term))]
getDefsGen d = case d of
DDecl ids t -> do
ids' <- mapM transNamePos ids
t' <- transExp t
return [(i,(yes t', nope)) | i <- ids']
DDef ids e -> do
ids' <- mapM transNamePos ids
e' <- transExp e
return [(i,(nope, yes e')) | i <- ids']
DFull ids t e -> do
ids' <- mapM transNamePos ids
t' <- transExp t
e' <- transExp e
return [(i,(yes t', yes e')) | i <- ids']
DPatt id patts e -> do
id' <- transNamePos id
ps' <- mapM transPatt patts
e' <- transExp e
return [(id',(nope, yes (G.Eqs [(ps',e')])))]
-- | sometimes you need this special case, e.g. in linearization rules
getDefs :: Def -> Err [((Ident,Int), (G.Perh G.Type, G.Perh G.Term))]
getDefs d = case d of
DPatt id patts e -> do
id' <- transNamePos id
xs <- mapM tryMakeVar patts
e' <- transExp e
return [(id',(nope, yes (M.mkAbs xs e')))]
_ -> getDefsGen d
-- | accepts a pattern that is either a variable or a wild card
tryMakeVar :: Patt -> Err Ident
tryMakeVar p = do
p' <- transPatt p
case p' of
G.PV i -> return i
G.PW -> return identW
_ -> Bad $ "not a legal pattern in lambda binding" +++ GP.prt p'
transExp :: Exp -> Err G.Term
transExp x = case x of
EIdent id -> liftM G.Vr $ transIdent id
EConstr id -> liftM G.Con $ transIdent id
ECons id -> liftM G.Cn $ transIdent id
EQConstr m c -> liftM2 G.QC (transIdent m) (transIdent c)
EQCons m c -> liftM2 G.Q (transIdent m) (transIdent c)
EString str -> return $ G.K str
ESort sort -> return $ G.Sort $ transSort sort
EInt n -> return $ G.EInt n
EFloat n -> return $ G.EFloat n
EMeta -> return $ G.Meta $ M.int2meta 0
EEmpty -> return G.Empty
-- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n)
EList i es -> do
i' <- transIdent i
es' <- mapM transExp (exps2list es)
return $ foldl G.App (G.Vr (mkListId i')) es'
EStrings [] -> return G.Empty
EStrings str -> return $ foldr1 G.C $ map G.K $ words str
ERecord defs -> erecord2term defs
ETupTyp _ _ -> do
let tups t = case t of
ETupTyp x y -> tups x ++ [y] -- right-associative parsing
_ -> [t]
es <- mapM transExp $ tups x
return $ G.RecType $ M.tuple2recordType es
ETuple tuplecomps -> do
es <- mapM transExp [e | TComp e <- tuplecomps]
return $ G.R $ M.tuple2record es
EProj exp id -> liftM2 G.P (transExp exp) (trLabel id)
EApp exp0 exp -> liftM2 G.App (transExp exp0) (transExp exp)
ETable cases -> liftM (G.T G.TRaw) (transCases cases)
ETTable exp cases ->
liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases)
EVTable exp cases ->
liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases)
ECase exp cases -> do
exp' <- transExp exp
cases' <- transCases cases
let annot = case exp' of
G.Typed _ t -> G.TTyped t
_ -> G.TRaw
return $ G.S (G.T annot cases') exp'
ECTable binds exp -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp)
EVariants exps -> liftM G.FV $ mapM transExp exps
EPre exp alts -> liftM2 (curry G.Alts) (transExp exp) (mapM transAltern alts)
EStrs exps -> liftM G.Strs $ mapM transExp exps
ESelect exp0 exp -> liftM2 G.S (transExp exp0) (transExp exp)
EExtend exp0 exp -> liftM2 G.ExtR (transExp exp0) (transExp exp)
EAbstr binds exp -> liftM2 M.mkAbs (mapM transBind binds) (transExp exp)
ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp)
EExample exp str -> liftM2 G.Example (transExp exp) (return str)
EProd decl exp -> liftM2 M.mkProdSimple (transDecl decl) (transExp exp)
ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp)
EConcat exp0 exp -> liftM2 G.C (transExp exp0) (transExp exp)
EGlue exp0 exp -> liftM2 G.Glue (transExp exp0) (transExp exp)
ELet defs exp -> do
exp' <- transExp exp
defs0 <- mapM locdef2fields defs
defs' <- mapM tryLoc $ concat defs0
return $ M.mkLet defs' exp'
where
tryLoc (c,(mty,Just e)) = return (c,(mty,e))
tryLoc (c,_) = Bad $ "local definition of" +++ GP.prt c +++ "without value"
ELetb defs exp -> transExp $ ELet defs exp
EWhere exp defs -> transExp $ ELet defs exp
EPattType typ -> liftM G.EPattType (transExp typ)
EPatt patt -> liftM G.EPatt (transPatt patt)
ELString (LString str) -> return $ G.K (BS.unpack str) -- use the grammar encoding here
ELin id -> liftM G.LiT $ transIdent id
EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs
_ -> Bad $ "translation not yet defined for" +++ printTree x ----
exps2list :: Exps -> [Exp]
exps2list NilExp = []
exps2list (ConsExp e es) = e : exps2list es
--- this is complicated: should we change Exp or G.Term ?
erecord2term :: [LocDef] -> Err G.Term
erecord2term ds = do
ds' <- mapM locdef2fields ds
mkR $ concat ds'
where
mkR fs = do
fs' <- transF fs
return $ case fs' of
Left ts -> G.RecType ts
Right ds -> G.R ds
transF [] = return $ Left [] --- empty record always interpreted as record type
transF fs@(f:_) = case f of
(lab,(Just ty,Nothing)) -> mapM tryRT fs >>= return . Left
_ -> mapM tryR fs >>= return . Right
tryRT f = case f of
(lab,(Just ty,Nothing)) -> return (G.ident2label lab,ty)
_ -> Bad $ "illegal record type field" +++ GP.prt (fst f) --- manifest fields ?!
tryR f = case f of
(lab,(mty, Just t)) -> return (G.ident2label lab,(mty,t))
_ -> Bad $ "illegal record field" +++ GP.prt (fst f)
locdef2fields :: LocDef -> Err [(Ident, (Maybe G.Type, Maybe G.Type))]
locdef2fields d = case d of
LDDecl ids t -> do
labs <- mapM transIdent ids
t' <- transExp t
return [(lab,(Just t',Nothing)) | lab <- labs]
LDDef ids e -> do
labs <- mapM transIdent ids
e' <- transExp e
return [(lab,(Nothing, Just e')) | lab <- labs]
LDFull ids t e -> do
labs <- mapM transIdent ids
t' <- transExp t
e' <- transExp e
return [(lab,(Just t', Just e')) | lab <- labs]
trLabel :: Label -> Err G.Label
trLabel x = case x of
LIdent (PIdent (_, s)) -> return $ G.LIdent s
LVar x -> return $ G.LVar $ fromInteger x
transSort :: Sort -> Ident
transSort Sort_Type = cType
transSort Sort_PType = cPType
transSort Sort_Tok = cTok
transSort Sort_Str = cStr
transSort Sort_Strs = cStrs
{-
--- no more used 7/1/2006 AR
transPatts :: Patt -> Err [G.Patt]
transPatts p = case p of
PDisj p1 p2 -> liftM2 (++) (transPatts p1) (transPatts p2)
PC id patts -> liftM (map (G.PC id) . combinations) $ mapM transPatts patts
PQC q id patts -> liftM (map (G.PP q id) . combinations) (mapM transPatts patts)
PR pattasss -> do
let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]
ls = map LIdent $ concat lss
ps0 <- mapM transPatts ps
let ps' = combinations ps0
lss' <- mapM trLabel ls
let rss = map (zip lss') ps'
return $ map G.PR rss
PTup pcs -> do
ps0 <- mapM transPatts [e | PTComp e <- pcs]
let ps' = combinations ps0
return $ map (G.PR . M.tuple2recordPatt) ps'
_ -> liftM singleton $ transPatt p
-}
transPatt :: Patt -> Err G.Patt
transPatt x = case x of
PW -> return G.wildPatt
PV id -> liftM G.PV $ transIdent id
PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts)
PCon id -> liftM2 G.PC (transIdent id) (return [])
PInt n -> return $ G.PInt n
PFloat n -> return $ G.PFloat n
PStr str -> return $ G.PString str
PR pattasss -> do
let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]
ls = map LIdent $ concat lss
liftM G.PR $ liftM2 zip (mapM trLabel ls) (mapM transPatt ps)
PTup pcs ->
liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs])
PQ id0 id -> liftM3 G.PP (transIdent id0) (transIdent id) (return [])
PQC id0 id patts ->
liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts)
PDisj p1 p2 -> liftM2 G.PAlt (transPatt p1) (transPatt p2)
PSeq p1 p2 -> liftM2 G.PSeq (transPatt p1) (transPatt p2)
PRep p -> liftM G.PRep (transPatt p)
PNeg p -> liftM G.PNeg (transPatt p)
PAs x p -> liftM2 G.PAs (transIdent x) (transPatt p)
PChar -> return G.PChar
PChars s -> return $ G.PChars s
PMacro c -> liftM G.PMacro $ transIdent c
PM m c -> liftM2 G.PM (transIdent m) (transIdent c)
transBind :: Bind -> Err Ident
transBind x = case x of
BIdent id -> transIdent id
BWild -> return identW
transDecl :: Decl -> Err [G.Decl]
transDecl x = case x of
DDec binds exp -> do
xs <- mapM transBind binds
exp' <- transExp exp
return [(x,exp') | x <- xs]
DExp exp -> liftM (return . M.mkDecl) $ transExp exp
transCases :: [Case] -> Err [G.Case]
transCases = mapM transCase
transCase :: Case -> Err G.Case
transCase (Case p exp) = do
patt <- transPatt p
exp' <- transExp exp
return (patt,exp')
transEquation :: Equation -> Err G.Equation
transEquation x = case x of
Equ apatts exp -> liftM2 (,) (mapM transPatt apatts) (transExp exp)
transAltern :: Altern -> Err (G.Term, G.Term)
transAltern x = case x of
Alt exp0 exp -> liftM2 (,) (transExp exp0) (transExp exp)
transParConstr :: ParConstr -> Err G.Param
transParConstr x = case x of
ParConstr id ddecls -> do
id' <- transIdent id
ddecls' <- mapM transDDecl ddecls
return (id',concat ddecls')
transDDecl :: DDecl -> Err [G.Decl]
transDDecl x = case x of
DDDec binds exp -> transDecl $ DDec binds exp
DDExp exp -> transDecl $ DExp exp
-- | to deal with the old format, sort judgements in two modules, forming
-- their names from a given string, e.g. file name or overriding user-given string
transOldGrammar :: Options -> FilePath -> OldGrammar -> Err G.SourceGrammar
transOldGrammar opts name0 x = case x of
OldGr includes topdefs -> do --- includes must be collected separately
let moddefs = sortTopDefs topdefs
g1 <- transGrammar $ Gr moddefs
removeLiT g1 --- needed for bw compatibility with an obsolete feature
where
sortTopDefs ds = [mkAbs a, mkCnc ops (c ++ r)]
where
ops = map fst ps
(a,r,c,ps) = foldr srt ([],[],[],[]) ds
srt d (a,r,c,ps) = case d of
DefCat catdefs -> (d:a,r,c,ps)
DefFun fundefs -> (d:a,r,c,ps)
DefFunData fundefs -> (d:a,r,c,ps)
DefDef defs -> (d:a,r,c,ps)
DefData pardefs -> (d:a,r,c,ps)
DefPar pardefs -> (a,d:r,c,ps)
DefOper defs -> (a,d:r,c,ps)
DefLintype defs -> (a,d:r,c,ps)
DefLincat defs -> (a,r,d:c,ps)
DefLindef defs -> (a,r,d:c,ps)
DefLin defs -> (a,r,d:c,ps)
DefPattern defs -> (a,r,d:c,ps)
DefFlag defs -> (a,r,d:c,ps) --- a guess
DefPrintCat printdefs -> (a,r,d:c,ps)
DefPrintFun printdefs -> (a,r,d:c,ps)
DefPrintOld printdefs -> (a,r,d:c,ps)
-- DefPackage m ds -> (a,r,c,(m,ds):ps) -- OBSOLETE
_ -> (a,r,c,ps)
mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn []) (topDefs a))
mkCnc ps r = MModule q (MTConcrete cncName absName) (MBody ne (OpenIn []) (topDefs r))
topDefs t = t
ne = NoExt
q = CMCompl
name = maybe name0 (++ ".gf") $ moduleFlag optName opts
absName = identPI $ maybe topic id $ moduleFlag optAbsName opts
resName = identPI $ maybe ("Res" ++ lang) id $ moduleFlag optResName opts
cncName = identPI $ maybe lang id $ moduleFlag optCncName opts
identPI s = PIdent ((0,0),BS.pack s)
(beg,rest) = span (/='.') name
(topic,lang) = case rest of -- to avoid overwriting old files
".gf" -> ("Abs" ++ beg,"Cnc" ++ beg)
".cf" -> ("Abs" ++ beg,"Cnc" ++ beg)
".ebnf" -> ("Abs" ++ beg,"Cnc" ++ beg)
[] -> ("Abs" ++ beg,"Cnc" ++ beg)
_:s -> (beg, takeWhile (/='.') s)
transInclude :: Include -> Err [FilePath]
transInclude x = Bad "Old GF with includes no more supported in GF 3.0"
newReservedWords :: [String]
newReservedWords =
words $ "abstract concrete interface incomplete " ++
"instance out open resource reuse transfer union with where"
termInPattern :: G.Term -> G.Term
termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where
toP t = case t of
G.Vr x -> G.P t s
_ -> M.composSafeOp toP t
s = G.LIdent (BS.pack "s")
(xx,body) = abss [] t
abss xs t = case t of
G.Abs x b -> abss (x:xs) b
_ -> (reverse xs,t)
mkListId,mkConsId,mkBaseId :: Ident -> Ident
mkListId = prefixId (BS.pack "List")
mkConsId = prefixId (BS.pack "Cons")
mkBaseId = prefixId (BS.pack "Base")
prefixId :: BS.ByteString -> Ident -> Ident
prefixId pref id = identC (BS.append pref (ident2bs id))

344
src/GF/Speech/CFG.hs Normal file
View File

@@ -0,0 +1,344 @@
----------------------------------------------------------------------
-- |
-- Module : GF.Speech.CFG
--
-- Context-free grammar representation and manipulation.
----------------------------------------------------------------------
module GF.Speech.CFG where
import GF.Data.Utilities
import PGF.CId
import GF.Infra.Option
import GF.Infra.PrintClass
import GF.Speech.Relation
import Control.Monad
import Control.Monad.State (State, get, put, evalState)
import qualified Data.ByteString.Char8 as BS
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List
import Data.Maybe (fromMaybe)
import Data.Monoid (mconcat)
import Data.Set (Set)
import qualified Data.Set as Set
--
-- * Types
--
type Cat = String
type Token = String
data Symbol c t = NonTerminal c | Terminal t
deriving (Eq, Ord, Show)
type CFSymbol = Symbol Cat Token
data CFRule = CFRule {
lhsCat :: Cat,
ruleRhs :: [CFSymbol],
ruleName :: CFTerm
}
deriving (Eq, Ord, Show)
data CFTerm
= CFObj CId [CFTerm] -- ^ an abstract syntax function with arguments
| CFAbs Int CFTerm -- ^ A lambda abstraction. The Int is the variable id.
| CFApp CFTerm CFTerm -- ^ Application
| CFRes Int -- ^ The result of the n:th (0-based) non-terminal
| CFVar Int -- ^ A lambda-bound variable
| CFMeta CId -- ^ A metavariable
deriving (Eq, Ord, Show)
data CFG = CFG { cfgStartCat :: Cat,
cfgExternalCats :: Set Cat,
cfgRules :: Map Cat (Set CFRule) }
deriving (Eq, Ord, Show)
--
-- * Grammar filtering
--
-- | Removes all directly and indirectly cyclic productions.
-- FIXME: this may be too aggressive, only one production
-- needs to be removed to break a given cycle. But which
-- one should we pick?
-- FIXME: Does not (yet) remove productions which are cyclic
-- because of empty productions.
removeCycles :: CFG -> CFG
removeCycles = onRules f
where f rs = filter (not . isCycle) rs
where alias = transitiveClosure $ mkRel [(c,c') | CFRule c [NonTerminal c'] _ <- rs]
isCycle (CFRule c [NonTerminal c'] _) = isRelatedTo alias c' c
isCycle _ = False
-- | Better bottom-up filter that also removes categories which contain no finite
-- strings.
bottomUpFilter :: CFG -> CFG
bottomUpFilter gr = fix grow (gr { cfgRules = Map.empty })
where grow g = g `unionCFG` filterCFG (all (okSym g) . ruleRhs) gr
okSym g = symbol (`elem` allCats g) (const True)
-- | Removes categories which are not reachable from any external category.
topDownFilter :: CFG -> CFG
topDownFilter cfg = filterCFGCats (`Set.member` keep) cfg
where
rhsCats = [ (lhsCat r, c') | r <- allRules cfg, c' <- filterCats (ruleRhs r) ]
uses = reflexiveClosure_ (allCats cfg) $ transitiveClosure $ mkRel rhsCats
keep = Set.unions $ map (allRelated uses) $ Set.toList $ cfgExternalCats cfg
-- | Merges categories with identical right-hand-sides.
-- FIXME: handle probabilities
mergeIdentical :: CFG -> CFG
mergeIdentical g = onRules (map subst) g
where
-- maps categories to their replacement
m = Map.fromList [(y,concat (intersperse "+" xs))
| (_,xs) <- buildMultiMap [(rulesKey rs,c) | (c,rs) <- Map.toList (cfgRules g)], y <- xs]
-- build data to compare for each category: a set of name,rhs pairs
rulesKey = Set.map (\ (CFRule _ r n) -> (n,r))
subst (CFRule c r n) = CFRule (substCat c) (map (mapSymbol substCat id) r) n
substCat c = Map.findWithDefault (error $ "mergeIdentical: " ++ c) c m
--
-- * Removing left recursion
--
-- The LC_LR algorithm from
-- http://research.microsoft.com/users/bobmoore/naacl2k-proc-rev.pdf
removeLeftRecursion :: CFG -> CFG
removeLeftRecursion gr
= gr { cfgRules = groupProds $ concat [scheme1, scheme2, scheme3, scheme4] }
where
scheme1 = [CFRule a [x,NonTerminal a_x] n' |
a <- retainedLeftRecursive,
x <- properLeftCornersOf a,
not (isLeftRecursive x),
let a_x = mkCat (NonTerminal a) x,
-- this is an extension of LC_LR to avoid generating
-- A-X categories for which there are no productions:
a_x `Set.member` newCats,
let n' = symbol (\_ -> CFApp (CFRes 1) (CFRes 0))
(\_ -> CFRes 0) x]
scheme2 = [CFRule a_x (beta++[NonTerminal a_b]) n' |
a <- retainedLeftRecursive,
b@(NonTerminal b') <- properLeftCornersOf a,
isLeftRecursive b,
CFRule _ (x:beta) n <- catRules gr b',
let a_x = mkCat (NonTerminal a) x,
let a_b = mkCat (NonTerminal a) b,
let i = length $ filterCats beta,
let n' = symbol (\_ -> CFAbs 1 (CFApp (CFRes i) (shiftTerm n)))
(\_ -> CFApp (CFRes i) n) x]
scheme3 = [CFRule a_x beta n' |
a <- retainedLeftRecursive,
x <- properLeftCornersOf a,
CFRule _ (x':beta) n <- catRules gr a,
x == x',
let a_x = mkCat (NonTerminal a) x,
let n' = symbol (\_ -> CFAbs 1 (shiftTerm n))
(\_ -> n) x]
scheme4 = catSetRules gr $ Set.fromList $ filter (not . isLeftRecursive . NonTerminal) cats
newCats = Set.fromList (map lhsCat (scheme2 ++ scheme3))
shiftTerm :: CFTerm -> CFTerm
shiftTerm (CFObj f ts) = CFObj f (map shiftTerm ts)
shiftTerm (CFRes 0) = CFVar 1
shiftTerm (CFRes n) = CFRes (n-1)
shiftTerm t = t
-- note: the rest don't occur in the original grammar
cats = allCats gr
rules = allRules gr
directLeftCorner = mkRel [(NonTerminal c,t) | CFRule c (t:_) _ <- allRules gr]
leftCorner = reflexiveClosure_ (map NonTerminal cats) $ transitiveClosure directLeftCorner
properLeftCorner = transitiveClosure directLeftCorner
properLeftCornersOf = Set.toList . allRelated properLeftCorner . NonTerminal
isProperLeftCornerOf = flip (isRelatedTo properLeftCorner)
leftRecursive = reflexiveElements properLeftCorner
isLeftRecursive = (`Set.member` leftRecursive)
retained = cfgStartCat gr `Set.insert`
Set.fromList [a | r <- allRules (filterCFGCats (not . isLeftRecursive . NonTerminal) gr),
NonTerminal a <- ruleRhs r]
isRetained = (`Set.member` retained)
retainedLeftRecursive = filter (isLeftRecursive . NonTerminal) $ Set.toList retained
mkCat :: CFSymbol -> CFSymbol -> Cat
mkCat x y = showSymbol x ++ "-" ++ showSymbol y
where showSymbol = symbol id show
-- | Get the sets of mutually recursive non-terminals for a grammar.
mutRecCats :: Bool -- ^ If true, all categories will be in some set.
-- If false, only recursive categories will be included.
-> CFG -> [Set Cat]
mutRecCats incAll g = equivalenceClasses $ refl $ symmetricSubrelation $ transitiveClosure r
where r = mkRel [(c,c') | CFRule c ss _ <- allRules g, NonTerminal c' <- ss]
refl = if incAll then reflexiveClosure_ (allCats g) else reflexiveSubrelation
--
-- * Approximate context-free grammars with regular grammars.
--
makeSimpleRegular :: CFG -> CFG
makeSimpleRegular = makeRegular . topDownFilter . bottomUpFilter . removeCycles
-- Use the transformation algorithm from \"Regular Approximation of Context-free
-- Grammars through Approximation\", Mohri and Nederhof, 2000
-- to create an over-generating regular frammar for a context-free
-- grammar
makeRegular :: CFG -> CFG
makeRegular g = g { cfgRules = groupProds $ concatMap trSet (mutRecCats True g) }
where trSet cs | allXLinear cs rs = rs
| otherwise = concatMap handleCat csl
where csl = Set.toList cs
rs = catSetRules g cs
handleCat c = [CFRule c' [] (mkCFTerm (c++"-empty"))] -- introduce A' -> e
++ concatMap (makeRightLinearRules c) (catRules g c)
where c' = newCat c
makeRightLinearRules b' (CFRule c ss n) =
case ys of
[] -> newRule b' (xs ++ [NonTerminal (newCat c)]) n -- no non-terminals left
(NonTerminal b:zs) -> newRule b' (xs ++ [NonTerminal b]) n
++ makeRightLinearRules (newCat b) (CFRule c zs n)
where (xs,ys) = break (`catElem` cs) ss
-- don't add rules on the form A -> A
newRule c rhs n | rhs == [NonTerminal c] = []
| otherwise = [CFRule c rhs n]
newCat c = c ++ "$"
--
-- * CFG Utilities
--
mkCFG :: Cat -> Set Cat -> [CFRule] -> CFG
mkCFG start ext rs = CFG { cfgStartCat = start, cfgExternalCats = ext, cfgRules = groupProds rs }
groupProds :: [CFRule] -> Map Cat (Set CFRule)
groupProds = Map.fromListWith Set.union . map (\r -> (lhsCat r,Set.singleton r))
-- | Gets all rules in a CFG.
allRules :: CFG -> [CFRule]
allRules = concat . map Set.toList . Map.elems . cfgRules
-- | Gets all rules in a CFG, grouped by their LHS categories.
allRulesGrouped :: CFG -> [(Cat,[CFRule])]
allRulesGrouped = Map.toList . Map.map Set.toList . cfgRules
-- | Gets all categories which have rules.
allCats :: CFG -> [Cat]
allCats = Map.keys . cfgRules
-- | Gets all rules for the given category.
catRules :: CFG -> Cat -> [CFRule]
catRules gr c = Set.toList $ Map.findWithDefault Set.empty c (cfgRules gr)
-- | Gets all rules for categories in the given set.
catSetRules :: CFG -> Set Cat -> [CFRule]
catSetRules gr cs = allRules $ filterCFGCats (`Set.member` cs) gr
mapCFGCats :: (Cat -> Cat) -> CFG -> CFG
mapCFGCats f cfg = mkCFG (f (cfgStartCat cfg))
(Set.map f (cfgExternalCats cfg))
[CFRule (f lhs) (map (mapSymbol f id) rhs) t | CFRule lhs rhs t <- allRules cfg]
onCFG :: (Map Cat (Set CFRule) -> Map Cat (Set CFRule)) -> CFG -> CFG
onCFG f cfg = cfg { cfgRules = f (cfgRules cfg) }
onRules :: ([CFRule] -> [CFRule]) -> CFG -> CFG
onRules f cfg = cfg { cfgRules = groupProds $ f $ allRules cfg }
-- | Clean up CFG after rules have been removed.
cleanCFG :: CFG -> CFG
cleanCFG = onCFG (Map.filter (not . Set.null))
-- | Combine two CFGs.
unionCFG :: CFG -> CFG -> CFG
unionCFG x y = onCFG (\rs -> Map.unionWith Set.union rs (cfgRules y)) x
filterCFG :: (CFRule -> Bool) -> CFG -> CFG
filterCFG p = cleanCFG . onCFG (Map.map (Set.filter p))
filterCFGCats :: (Cat -> Bool) -> CFG -> CFG
filterCFGCats p = onCFG (Map.filterWithKey (\c _ -> p c))
countCats :: CFG -> Int
countCats = Map.size . cfgRules . cleanCFG
countRules :: CFG -> Int
countRules = length . allRules
prCFG :: CFG -> String
prCFG = unlines . map prRule . allRules
where
prRule r = lhsCat r ++ " ::= " ++ unwords (map prSym (ruleRhs r))
prSym = symbol id (\t -> "\""++ t ++"\"")
--
-- * CFRule Utilities
--
ruleFun :: CFRule -> CId
ruleFun (CFRule _ _ t) = f t
where f (CFObj n _) = n
f (CFApp _ x) = f x
f (CFAbs _ x) = f x
f _ = mkCId ""
-- | Check if any of the categories used on the right-hand side
-- are in the given list of categories.
anyUsedBy :: [Cat] -> CFRule -> Bool
anyUsedBy cs (CFRule _ ss _) = any (`elem` cs) (filterCats ss)
mkCFTerm :: String -> CFTerm
mkCFTerm n = CFObj (mkCId n) []
ruleIsNonRecursive :: Set Cat -> CFRule -> Bool
ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs
-- | Check if all the rules are right-linear, or all the rules are
-- left-linear, with respect to given categories.
allXLinear :: Set Cat -> [CFRule] -> Bool
allXLinear cs rs = all (isRightLinear cs) rs || all (isLeftLinear cs) rs
-- | Checks if a context-free rule is right-linear.
isRightLinear :: Set Cat -- ^ The categories to consider
-> CFRule -- ^ The rule to check for right-linearity
-> Bool
isRightLinear cs = noCatsInSet cs . safeInit . ruleRhs
-- | Checks if a context-free rule is left-linear.
isLeftLinear :: Set Cat -- ^ The categories to consider
-> CFRule -- ^ The rule to check for left-linearity
-> Bool
isLeftLinear cs = noCatsInSet cs . drop 1 . ruleRhs
--
-- * Symbol utilities
--
symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a
symbol fc ft (NonTerminal cat) = fc cat
symbol fc ft (Terminal tok) = ft tok
mapSymbol :: (c -> c') -> (t -> t') -> Symbol c t -> Symbol c' t'
mapSymbol fc ft = symbol (NonTerminal . fc) (Terminal . ft)
filterCats :: [Symbol c t] -> [c]
filterCats syms = [ cat | NonTerminal cat <- syms ]
filterToks :: [Symbol c t] -> [t]
filterToks syms = [ tok | Terminal tok <- syms ]
-- | Checks if a symbol is a non-terminal of one of the given categories.
catElem :: Ord c => Symbol c t -> Set c -> Bool
catElem s cs = symbol (`Set.member` cs) (const False) s
noCatsInSet :: Ord c => Set c -> [Symbol c t] -> Bool
noCatsInSet cs = not . any (`catElem` cs)

244
src/GF/Speech/CFGToFA.hs Normal file
View File

@@ -0,0 +1,244 @@
----------------------------------------------------------------------
-- |
-- Module : GF.Speech.CFGToFA
--
-- Approximates CFGs with finite state networks.
----------------------------------------------------------------------
module GF.Speech.CFGToFA (cfgToFA, makeSimpleRegular,
MFA(..), cfgToMFA, cfgToFA') where
import Data.List
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import PGF.CId
import PGF.Data
import GF.Data.Utilities
import GF.Speech.CFG
import GF.Speech.PGFToCFG
import GF.Infra.Ident (Ident)
import GF.Speech.FiniteState
import GF.Speech.Graph
import GF.Speech.Relation
import GF.Speech.CFG
data Recursivity = RightR | LeftR | NotR
data MutRecSet = MutRecSet {
mrCats :: Set Cat,
mrNonRecRules :: [CFRule],
mrRecRules :: [CFRule],
mrRec :: Recursivity
}
type MutRecSets = Map Cat MutRecSet
--
-- * Multiple DFA type
--
data MFA = MFA Cat [(Cat,DFA CFSymbol)]
cfgToFA :: CFG -> DFA Token
cfgToFA = minimize . compileAutomaton . makeSimpleRegular
--
-- * Compile strongly regular grammars to NFAs
--
-- Convert a strongly regular grammar to a finite automaton.
compileAutomaton :: CFG -> NFA Token
compileAutomaton g = make_fa (g,ns) s [NonTerminal (cfgStartCat g)] f fa
where
(fa,s,f) = newFA_
ns = mutRecSets g $ mutRecCats False g
-- | The make_fa algorithm from \"Regular approximation of CFLs: a grammatical view\",
-- Mark-Jan Nederhof, Advances in Probabilistic and other Parsing Technologies, 2000.
make_fa :: (CFG,MutRecSets) -> State -> [CFSymbol] -> State
-> NFA Token -> NFA Token
make_fa c@(g,ns) q0 alpha q1 fa =
case alpha of
[] -> newTransition q0 q1 Nothing fa
[Terminal t] -> newTransition q0 q1 (Just t) fa
[NonTerminal a] ->
case Map.lookup a ns of
-- a is recursive
Just n@(MutRecSet { mrCats = ni, mrNonRecRules = nrs, mrRecRules = rs} ) ->
case mrRec n of
-- the set Ni is right-recursive or cyclic
RightR ->
let new = [(getState c, xs, q1) | CFRule c xs _ <- nrs]
++ [(getState c, xs, getState d) | CFRule c ss _ <- rs,
let (xs,NonTerminal d) = (init ss,last ss)]
in make_fas new $ newTransition q0 (getState a) Nothing fa'
-- the set Ni is left-recursive
LeftR ->
let new = [(q0, xs, getState c) | CFRule c xs _ <- nrs]
++ [(getState d, xs, getState c) | CFRule c (NonTerminal d:xs) _ <- rs]
in make_fas new $ newTransition (getState a) q1 Nothing fa'
where
(fa',stateMap) = addStatesForCats ni fa
getState x = Map.findWithDefault
(error $ "CFGToFiniteState: No state for " ++ x)
x stateMap
-- a is not recursive
Nothing -> let rs = catRules g a
in foldl' (\f (CFRule _ b _) -> make_fa_ q0 b q1 f) fa rs
(x:beta) -> let (fa',q) = newState () fa
in make_fa_ q beta q1 $ make_fa_ q0 [x] q fa'
where
make_fa_ = make_fa c
make_fas xs fa = foldl' (\f' (s1,xs,s2) -> make_fa_ s1 xs s2 f') fa xs
--
-- * Compile a strongly regular grammar to a DFA with sub-automata
--
cfgToMFA :: CFG -> MFA
cfgToMFA = buildMFA . makeSimpleRegular
-- | Build a DFA by building and expanding an MFA
cfgToFA' :: CFG -> DFA Token
cfgToFA' = mfaToDFA . cfgToMFA
buildMFA :: CFG -> MFA
buildMFA g = sortSubLats $ removeUnusedSubLats mfa
where fas = compileAutomata g
mfa = MFA (cfgStartCat g) [(c, minimize fa) | (c,fa) <- fas]
mfaStartDFA :: MFA -> DFA CFSymbol
mfaStartDFA (MFA start subs) =
fromMaybe (error $ "Bad start MFA: " ++ start) $ lookup start subs
mfaToDFA :: MFA -> DFA Token
mfaToDFA mfa@(MFA _ subs) = minimize $ expand $ dfa2nfa $ mfaStartDFA mfa
where
subs' = Map.fromList [(c, dfa2nfa n) | (c,n) <- subs]
getSub l = fromJust $ Map.lookup l subs'
expand (FA (Graph c ns es) s f)
= foldl' expandEdge (FA (Graph c ns []) s f) es
expandEdge fa (f,t,x) =
case x of
Nothing -> newTransition f t Nothing fa
Just (Terminal s) -> newTransition f t (Just s) fa
Just (NonTerminal l) -> insertNFA fa (f,t) (expand $ getSub l)
removeUnusedSubLats :: MFA -> MFA
removeUnusedSubLats mfa@(MFA start subs) = MFA start [(c,s) | (c,s) <- subs, isUsed c]
where
usedMap = subLatUseMap mfa
used = growUsedSet (Set.singleton start)
isUsed c = c `Set.member` used
growUsedSet = fix (\s -> foldl Set.union s $ mapMaybe (flip Map.lookup usedMap) $ Set.toList s)
subLatUseMap :: MFA -> Map Cat (Set Cat)
subLatUseMap (MFA _ subs) = Map.fromList [(c,usedSubLats n) | (c,n) <- subs]
usedSubLats :: DFA CFSymbol -> Set Cat
usedSubLats fa = Set.fromList [s | (_,_,NonTerminal s) <- transitions fa]
-- | Sort sub-networks topologically.
sortSubLats :: MFA -> MFA
sortSubLats mfa@(MFA main subs) = MFA main (reverse $ sortLats usedByMap subs)
where
usedByMap = revMultiMap (subLatUseMap mfa)
sortLats _ [] = []
sortLats ub ls = xs ++ sortLats ub' ys
where (xs,ys) = partition ((==0) . indeg) ls
ub' = Map.map (Set.\\ Set.fromList (map fst xs)) ub
indeg (c,_) = maybe 0 Set.size $ Map.lookup c ub
-- | Convert a strongly regular grammar to a number of finite automata,
-- one for each non-terminal.
-- The edges in the automata accept tokens, or name another automaton to use.
compileAutomata :: CFG
-> [(Cat,NFA CFSymbol)]
-- ^ A map of non-terminals and their automata.
compileAutomata g = [(c, makeOneFA c) | c <- allCats g]
where
mrs = mutRecSets g $ mutRecCats True g
makeOneFA c = make_fa1 mr s [NonTerminal c] f fa
where (fa,s,f) = newFA_
mr = fromJust (Map.lookup c mrs)
-- | The make_fa algorithm from \"Regular approximation of CFLs: a grammatical view\",
-- Mark-Jan Nederhof, Advances in Probabilistic and other Parsing Technologies, 2000,
-- adapted to build a finite automaton for a single (mutually recursive) set only.
-- Categories not in the set will result in category-labelled edges.
make_fa1 :: MutRecSet -- ^ The set of (mutually recursive) categories for which
-- we are building the automaton.
-> State -- ^ State to come from
-> [CFSymbol] -- ^ Symbols to accept
-> State -- ^ State to end up in
-> NFA CFSymbol -- ^ FA to add to.
-> NFA CFSymbol
make_fa1 mr q0 alpha q1 fa =
case alpha of
[] -> newTransition q0 q1 Nothing fa
[t@(Terminal _)] -> newTransition q0 q1 (Just t) fa
[c@(NonTerminal a)] | not (a `Set.member` mrCats mr) -> newTransition q0 q1 (Just c) fa
[NonTerminal a] ->
case mrRec mr of
NotR -> -- the set is a non-recursive (always singleton) set of categories
-- so the set of category rules is the set of rules for the whole set
make_fas [(q0, b, q1) | CFRule _ b _ <- mrNonRecRules mr] fa
RightR -> -- the set is right-recursive or cyclic
let new = [(getState c, xs, q1) | CFRule c xs _ <- mrNonRecRules mr]
++ [(getState c, xs, getState d) | CFRule c ss _ <- mrRecRules mr,
let (xs,NonTerminal d) = (init ss,last ss)]
in make_fas new $ newTransition q0 (getState a) Nothing fa'
LeftR -> -- the set is left-recursive
let new = [(q0, xs, getState c) | CFRule c xs _ <- mrNonRecRules mr]
++ [(getState d, xs, getState c) | CFRule c (NonTerminal d:xs) _ <- mrRecRules mr]
in make_fas new $ newTransition (getState a) q1 Nothing fa'
where
(fa',stateMap) = addStatesForCats (mrCats mr) fa
getState x = Map.findWithDefault
(error $ "CFGToFiniteState: No state for " ++ x)
x stateMap
(x:beta) -> let (fa',q) = newState () fa
in make_fas [(q0,[x],q),(q,beta,q1)] fa'
where
make_fas xs fa = foldl' (\f' (s1,xs,s2) -> make_fa1 mr s1 xs s2 f') fa xs
mutRecSets :: CFG -> [Set Cat] -> MutRecSets
mutRecSets g = Map.fromList . concatMap mkMutRecSet
where
mkMutRecSet cs = [ (c,ms) | c <- csl ]
where csl = Set.toList cs
rs = catSetRules g cs
(nrs,rrs) = partition (ruleIsNonRecursive cs) rs
ms = MutRecSet {
mrCats = cs,
mrNonRecRules = nrs,
mrRecRules = rrs,
mrRec = rec
}
rec | null rrs = NotR
| all (isRightLinear cs) rrs = RightR
| otherwise = LeftR
--
-- * Utilities
--
-- | Add a state for the given NFA for each of the categories
-- in the given set. Returns a map of categories to their
-- corresponding states.
addStatesForCats :: Set Cat -> NFA t -> (NFA t, Map Cat State)
addStatesForCats cs fa = (fa', m)
where (fa', ns) = newStates (replicate (Set.size cs) ()) fa
m = Map.fromList (zip (Set.toList cs) (map fst ns))
revMultiMap :: (Ord a, Ord b) => Map a (Set b) -> Map b (Set a)
revMultiMap m = Map.fromListWith Set.union [ (y,Set.singleton x) | (x,s) <- Map.toList m, y <- Set.toList s]

329
src/GF/Speech/FiniteState.hs Normal file
View File

@@ -0,0 +1,329 @@
----------------------------------------------------------------------
-- |
-- Module : FiniteState
-- Maintainer : BB
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/10 16:43:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.16 $
--
-- A simple finite state network module.
-----------------------------------------------------------------------------
module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
startState, finalStates,
states, transitions,
isInternal,
newFA, newFA_,
addFinalState,
newState, newStates,
newTransition, newTransitions,
insertTransitionWith, insertTransitionsWith,
mapStates, mapTransitions,
modifyTransitions,
nonLoopTransitionsTo, nonLoopTransitionsFrom,
loops,
removeState,
oneFinalState,
insertNFA,
onGraph,
moveLabelsToNodes, removeTrivialEmptyNodes,
minimize,
dfa2nfa,
unusedNames, renameStates,
prFAGraphviz, faToGraphviz) where
import Data.List
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import GF.Data.Utilities
import GF.Speech.Graph
import qualified GF.Speech.Graphviz as Dot
type State = Int
-- | Type parameters: node id type, state label type, edge label type
-- Data constructor arguments: nodes and edges, start state, final states
data FA n a b = FA !(Graph n a b) !n ![n]
type NFA a = FA State () (Maybe a)
type DFA a = FA State () a
startState :: FA n a b -> n
startState (FA _ s _) = s
finalStates :: FA n a b -> [n]
finalStates (FA _ _ ss) = ss
states :: FA n a b -> [(n,a)]
states (FA g _ _) = nodes g
transitions :: FA n a b -> [(n,n,b)]
transitions (FA g _ _) = edges g
newFA :: Enum n => a -- ^ Start node label
-> FA n a b
newFA l = FA g s []
where (g,s) = newNode l (newGraph [toEnum 0..])
-- | Create a new finite automaton with an initial and a final state.
newFA_ :: Enum n => (FA n () b, n, n)
newFA_ = (fa'', s, f)
where fa = newFA ()
s = startState fa
(fa',f) = newState () fa
fa'' = addFinalState f fa'
addFinalState :: n -> FA n a b -> FA n a b
addFinalState f (FA g s ss) = FA g s (f:ss)
newState :: a -> FA n a b -> (FA n a b, n)
newState x (FA g s ss) = (FA g' s ss, n)
where (g',n) = newNode x g
newStates :: [a] -> FA n a b -> (FA n a b, [(n,a)])
newStates xs (FA g s ss) = (FA g' s ss, ns)
where (g',ns) = newNodes xs g
newTransition :: n -> n -> b -> FA n a b -> FA n a b
newTransition f t l = onGraph (newEdge (f,t,l))
newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b
newTransitions es = onGraph (newEdges es)
insertTransitionWith :: Eq n =>
(b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b
insertTransitionWith f t = onGraph (insertEdgeWith f t)
insertTransitionsWith :: Eq n =>
(b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b
insertTransitionsWith f ts fa =
foldl' (flip (insertTransitionWith f)) fa ts
mapStates :: (a -> c) -> FA n a b -> FA n c b
mapStates f = onGraph (nmap f)
mapTransitions :: (b -> c) -> FA n a b -> FA n a c
mapTransitions f = onGraph (emap f)
modifyTransitions :: ([(n,n,b)] -> [(n,n,b)]) -> FA n a b -> FA n a b
modifyTransitions f = onGraph (\ (Graph r ns es) -> Graph r ns (f es))
removeState :: Ord n => n -> FA n a b -> FA n a b
removeState n = onGraph (removeNode n)
minimize :: Ord a => NFA a -> DFA a
minimize = determinize . reverseNFA . dfa2nfa . determinize . reverseNFA
unusedNames :: FA n a b -> [n]
unusedNames (FA (Graph names _ _) _ _) = names
-- | Gets all incoming transitions to a given state, excluding
-- transtions from the state itself.
nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)]
nonLoopTransitionsTo s fa =
[(f,l) | (f,t,l) <- transitions fa, t == s && f /= s]
nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)]
nonLoopTransitionsFrom s fa =
[(t,l) | (f,t,l) <- transitions fa, f == s && t /= s]
loops :: Eq n => n -> FA n a b -> [b]
loops s fa = [l | (f,t,l) <- transitions fa, f == s && t == s]
-- | Give new names to all nodes.
renameStates :: Ord x => [y] -- ^ Infinite supply of new names
-> FA x a b
-> FA y a b
renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs'
where (ns,rest) = splitAt (length (nodes g)) supply
newNodes = Map.fromList (zip (map fst (nodes g)) ns)
newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
s' = newName s
fs' = map newName fs
-- | Insert an NFA into another
insertNFA :: NFA a -- ^ NFA to insert into
-> (State, State) -- ^ States to insert between
-> NFA a -- ^ NFA to insert.
-> NFA a
insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2)
= FA (newEdges es g') s1 fs1
where
es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2]
(g',ren) = mergeGraphs g1 g2
onGraph :: (Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph f (FA g s ss) = FA (f g) s ss
-- | Make the finite automaton have a single final state
-- by adding a new final state and adding an edge
-- from the old final states to the new state.
oneFinalState :: a -- ^ Label to give the new node
-> b -- ^ Label to give the new edges
-> FA n a b -- ^ The old network
-> FA n a b -- ^ The new network
oneFinalState nl el fa =
let (FA g s fs,nf) = newState nl fa
es = [ (f,nf,el) | f <- fs ]
in FA (newEdges es g) s [nf]
-- | Transform a standard finite automaton with labelled edges
-- to one where the labels are on the nodes instead. This can add
-- up to one extra node per edge.
moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) ()
moveLabelsToNodes = onGraph f
where f g@(Graph c _ _) = Graph c' ns (concat ess)
where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
(c',is') = mapAccumL fixIncoming c is
(ns,ess) = unzip (concat is')
-- | Remove empty nodes which are not start or final, and have
-- exactly one outgoing edge or exactly one incoming edge.
removeTrivialEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) ()
removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes
-- | Move edges to empty nodes to point to the next node(s).
-- This is not done if the pointed-to node is a final node.
skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) ()
skipSimpleEmptyNodes fa = onGraph og fa
where
og g@(Graph c ns es) = if es' == es then g else og (Graph c ns es')
where
es' = concatMap changeEdge es
info = nodeInfo g
changeEdge e@(f,t,())
| isNothing (getNodeLabel info t)
-- && (i * o <= i + o)
&& not (isFinal fa t)
= [ (f,t',()) | (_,t',()) <- getOutgoing info t]
| otherwise = [e]
-- where i = inDegree info t
-- o = outDegree info t
isInternal :: Eq n => FA n a b -> n -> Bool
isInternal (FA _ start final) n = n /= start && n `notElem` final
isFinal :: Eq n => FA n a b -> n -> Bool
isFinal (FA _ _ final) n = n `elem` final
-- | Remove all internal nodes with no incoming edges
-- or no outgoing edges.
pruneUnusable :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) ()
pruneUnusable fa = onGraph f fa
where
f g = if Set.null rns then g else f (removeNodes rns g)
where info = nodeInfo g
rns = Set.fromList [ n | (n,_) <- nodes g,
isInternal fa n,
inDegree info n == 0
|| outDegree info n == 0]
fixIncoming :: (Ord n, Eq a) => [n]
-> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges
-> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their
-- incoming edges.
fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts)
where ls = nub $ map edgeLabel es
(cs',cs'') = splitAt (length ls) cs
newNodes = zip cs' ls
es' = [ (x,n,()) | x <- map fst newNodes ]
-- separate cyclic and non-cyclic edges
(cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
-- keep all incoming non-cyclic edges with the right label
to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
-- for each cyclic edge with the right label,
-- add an edge from each of the new nodes (including this one)
++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
newContexts = [ (v, to v) | v <- newNodes ]
alphabet :: Eq b => Graph n a (Maybe b) -> [b]
alphabet = nub . catMaybes . map edgeLabel . edges
determinize :: Ord a => NFA a -> DFA a
determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.empty
(ns',es') = (Set.toList ns, Set.toList es)
final = filter isDFAFinal ns'
fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final
in renameStates [0..] fa
where info = nodeInfo g
-- reach = nodesReachable out
start = closure info $ Set.singleton s
isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n))
h currentStates oldStates es
| Set.null currentStates = (oldStates,es)
| otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
where
allOldStates = oldStates `Set.union` currentStates
(newStates,es') = new (Set.toList currentStates) Set.empty es
uniqueNewStates = newStates Set.\\ allOldStates
-- Get the sets of states reachable from the given states
-- by consuming one symbol, and the associated edges.
new [] rs es = (rs,es)
new (n:ns) rs es = new ns rs' es'
where cs = reachable info n --reachable reach n
rs' = rs `Set.union` Set.fromList (map snd cs)
es' = es `Set.union` Set.fromList [(n,s,c) | (c,s) <- cs]
-- | Get all the nodes reachable from a list of nodes by only empty edges.
closure :: Ord n => NodeInfo n a (Maybe b) -> Set n -> Set n
closure info x = closure_ x x
where closure_ acc check | Set.null check = acc
| otherwise = closure_ acc' check'
where
reach = Set.fromList [y | x <- Set.toList check,
(_,y,Nothing) <- getOutgoing info x]
acc' = acc `Set.union` reach
check' = reach Set.\\ acc
-- | Get a map of labels to sets of all nodes reachable
-- from a the set of nodes by one edge with the given
-- label and then any number of empty edges.
reachable :: (Ord n,Ord b) => NodeInfo n a (Maybe b) -> Set n -> [(b,Set n)]
reachable info ns = Map.toList $ Map.map (closure info . Set.fromList) $ reachable1 info ns
reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y,Just c) <- getOutgoing info n]
reverseNFA :: NFA a -> NFA a
reverseNFA (FA g s fs) = FA g''' s' [s]
where g' = reverseGraph g
(g'',s') = newNode () g'
g''' = newEdges [(s',f,Nothing) | f <- fs] g''
dfa2nfa :: DFA a -> NFA a
dfa2nfa = mapTransitions Just
--
-- * Visualization
--
prFAGraphviz :: (Eq n,Show n) => FA n String String -> String
prFAGraphviz = Dot.prGraphviz . faToGraphviz
prFAGraphviz_ :: (Eq n,Show n,Show a, Show b) => FA n a b -> String
prFAGraphviz_ = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show
faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph
faToGraphviz (FA (Graph _ ns es) s f)
= Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) []
where mkNode (n,l) = Dot.Node (show n) attrs
where attrs = [("label",l)]
++ if n == s then [("shape","box")] else []
++ if n `elem` f then [("style","bold")] else []
mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
--
-- * Utilities
--
lookups :: Ord k => [k] -> Map k a -> [a]
lookups xs m = mapMaybe (flip Map.lookup m) xs

94
src/GF/Speech/GSL.hs Normal file
View File

@@ -0,0 +1,94 @@
----------------------------------------------------------------------
-- |
-- Module : GF.Speech.GSL
--
-- This module prints a CFG as a Nuance GSL 2.0 grammar.
--
-----------------------------------------------------------------------------
module GF.Speech.GSL (gslPrinter) where
import GF.Data.Utilities
import GF.Speech.CFG
import GF.Speech.SRG
import GF.Speech.RegExp
import GF.Infra.Ident
import PGF.CId
import PGF.Data
import Data.Char (toUpper,toLower)
import Data.List (partition)
import Text.PrettyPrint.HughesPJ
width :: Int
width = 75
gslPrinter :: PGF -> CId -> String
gslPrinter pgf cnc = renderStyle st $ prGSL $ makeSimpleSRG pgf cnc
where st = style { lineLength = width }
prGSL :: SRG -> Doc
prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg))
where
header = text ";GSL2.0" $$
comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
comment ("Generated by GF")
mainCat = text ".MAIN" <+> prCat (srgStartCat srg)
prRule (SRGRule cat rhs) = prCat cat <+> union (map prAlt rhs)
-- FIXME: use the probability
prAlt (SRGAlt mp _ rhs) = prItem rhs
prItem :: SRGItem -> Doc
prItem = f
where
f (REUnion xs) = (if null es then empty else text "?") <> union (map f nes)
where (es,nes) = partition isEpsilon xs
f (REConcat [x]) = f x
f (REConcat xs) = text "(" <> fsep (map f xs) <> text ")"
f (RERepeat x) = text "*" <> f x
f (RESymbol s) = prSymbol s
union :: [Doc] -> Doc
union [x] = x
union xs = text "[" <> fsep xs <> text "]"
prSymbol :: Symbol SRGNT Token -> Doc
prSymbol = symbol (prCat . fst) (doubleQuotes . showToken)
-- GSL requires an upper case letter in category names
prCat :: Cat -> Doc
prCat = text . firstToUpper
firstToUpper :: String -> String
firstToUpper [] = []
firstToUpper (x:xs) = toUpper x : xs
{-
rmPunctCFG :: CGrammar -> CGrammar
rmPunctCFG g = [CFRule c (filter keepSymbol ss) n | CFRule c ss n <- g]
keepSymbol :: Symbol c Token -> Bool
keepSymbol (Tok t) = not (all isPunct (prt t))
keepSymbol _ = True
-}
-- Nuance does not like upper case characters in tokens
showToken :: Token -> Doc
showToken = text . map toLower
isPunct :: Char -> Bool
isPunct c = c `elem` "-_.:;.,?!()[]{}"
comment :: String -> Doc
comment s = text ";" <+> text s
-- Pretty-printing utilities
emptyLine :: Doc
emptyLine = text ""
($++$) :: Doc -> Doc -> Doc
x $++$ y = x $$ emptyLine $$ y

178
src/GF/Speech/Graph.hs Normal file
View File

@@ -0,0 +1,178 @@
----------------------------------------------------------------------
-- |
-- Module : Graph
-- Maintainer : BB
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/10 16:43:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.2 $
--
-- A simple graph module.
-----------------------------------------------------------------------------
module GF.Speech.Graph ( Graph(..), Node, Edge, NodeInfo
, newGraph, nodes, edges
, nmap, emap, newNode, newNodes, newEdge, newEdges
, insertEdgeWith
, removeNode, removeNodes
, nodeInfo
, getIncoming, getOutgoing, getNodeLabel
, inDegree, outDegree
, nodeLabel
, edgeFrom, edgeTo, edgeLabel
, reverseGraph, mergeGraphs, renameNodes
) where
import GF.Data.Utilities
import Data.List
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
deriving (Eq,Show)
type Node n a = (n,a)
type Edge n b = (n,n,b)
type NodeInfo n a b = Map n (a, [Edge n b], [Edge n b])
-- | Create a new empty graph.
newGraph :: [n] -> Graph n a b
newGraph ns = Graph ns [] []
-- | Get all the nodes in the graph.
nodes :: Graph n a b -> [Node n a]
nodes (Graph _ ns _) = ns
-- | Get all the edges in the graph.
edges :: Graph n a b -> [Edge n b]
edges (Graph _ _ es) = es
-- | Map a function over the node labels.
nmap :: (a -> c) -> Graph n a b -> Graph n c b
nmap f (Graph c ns es) = Graph c [(n,f l) | (n,l) <- ns] es
-- | Map a function over the edge labels.
emap :: (b -> c) -> Graph n a b -> Graph n a c
emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
-- | Add a node to the graph.
newNode :: a -- ^ Node label
-> Graph n a b
-> (Graph n a b,n) -- ^ Node graph and name of new node
newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
newNodes :: [a] -> Graph n a b -> (Graph n a b,[Node n a])
newNodes ls g = (g', zip ns ls)
where (g',ns) = mapAccumL (flip newNode) g ls
-- lazy version:
--newNodes ls (Graph cs ns es) = (Graph cs' (ns'++ns) es, ns')
-- where (xs,cs') = splitAt (length ls) cs
-- ns' = zip xs ls
newEdge :: Edge n b -> Graph n a b -> Graph n a b
newEdge e (Graph c ns es) = Graph c ns (e:es)
newEdges :: [Edge n b] -> Graph n a b -> Graph n a b
newEdges es g = foldl' (flip newEdge) g es
-- lazy version:
-- newEdges es' (Graph c ns es) = Graph c ns (es'++es)
insertEdgeWith :: Eq n =>
(b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es)
where h [] = [e]
h (e'@(x',y',l'):es') | x' == x && y' == y = (x',y', f l l'):es'
| otherwise = e':h es'
-- | Remove a node and all edges to and from that node.
removeNode :: Ord n => n -> Graph n a b -> Graph n a b
removeNode n = removeNodes (Set.singleton n)
-- | Remove a set of nodes and all edges to and from those nodes.
removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b
removeNodes xs (Graph c ns es) = Graph c ns' es'
where
keepNode n = not (Set.member n xs)
ns' = [ x | x@(n,_) <- ns, keepNode n ]
es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ]
-- | Get a map of node names to info about each node.
nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ]
where
inc = groupEdgesBy edgeTo g
out = groupEdgesBy edgeFrom g
fn m n = fromMaybe [] (Map.lookup n m)
groupEdgesBy :: (Ord n) => (Edge n b -> n) -- ^ Gets the node to group by
-> Graph n a b -> Map n [Edge n b]
groupEdgesBy f g = Map.fromListWith (++) [(f e, [e]) | e <- edges g]
lookupNode :: Ord n => NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
lookupNode i n = fromJust $ Map.lookup n i
getIncoming :: Ord n => NodeInfo n a b -> n -> [Edge n b]
getIncoming i n = let (_,inc,_) = lookupNode i n in inc
getOutgoing :: Ord n => NodeInfo n a b -> n -> [Edge n b]
getOutgoing i n = let (_,_,out) = lookupNode i n in out
inDegree :: Ord n => NodeInfo n a b -> n -> Int
inDegree i n = length $ getIncoming i n
outDegree :: Ord n => NodeInfo n a b -> n -> Int
outDegree i n = length $ getOutgoing i n
getNodeLabel :: Ord n => NodeInfo n a b -> n -> a
getNodeLabel i n = let (l,_,_) = lookupNode i n in l
nodeLabel :: Node n a -> a
nodeLabel = snd
edgeFrom :: Edge n b -> n
edgeFrom (f,_,_) = f
edgeTo :: Edge n b -> n
edgeTo (_,t,_) = t
edgeLabel :: Edge n b -> b
edgeLabel (_,_,l) = l
reverseGraph :: Graph n a b -> Graph n a b
reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
-- | Add the nodes from the second graph to the first graph.
-- The nodes in the second graph will be renamed using the name
-- supply in the first graph.
-- This function is more efficient when the second graph
-- is smaller than the first.
mergeGraphs :: Ord m => Graph n a b -> Graph m a b
-> (Graph n a b, m -> n) -- ^ The new graph and a function translating
-- the old names of nodes in the second graph
-- to names in the new graph.
mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
where
(xs,c') = splitAt (length (nodes g2)) c
newNames = Map.fromList (zip (map fst (nodes g2)) xs)
newName n = fromJust $ Map.lookup n newNames
Graph _ ns2 es2 = renameNodes newName undefined g2
-- | Rename the nodes in the graph.
renameNodes :: (n -> m) -- ^ renaming function
-> [m] -- ^ infinite supply of fresh node names, to
-- use when adding nodes in the future.
-> Graph n a b -> Graph m a b
renameNodes newName c (Graph _ ns es) = Graph c ns' es'
where ns' = map' (\ (n,x) -> (newName n,x)) ns
es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
-- | A strict 'map'
map' :: (a -> b) -> [a] -> [b]
map' _ [] = []
map' f (x:xs) = ((:) $! f x) $! map' f xs

116
src/GF/Speech/Graphviz.hs Normal file
View File

@@ -0,0 +1,116 @@
----------------------------------------------------------------------
-- |
-- Module : Graphviz
-- Maintainer : BB
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/15 18:10:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.2 $
--
-- Graphviz DOT format representation and printing.
-----------------------------------------------------------------------------
module GF.Speech.Graphviz (
Graph(..), GraphType(..),
Node(..), Edge(..),
Attr,
addSubGraphs,
setName,
setAttr,
prGraphviz
) where
import Data.Char
import GF.Data.Utilities
-- | Graph type, graph ID, graph attirbutes, graph nodes, graph edges, subgraphs
data Graph = Graph {
gType :: GraphType,
gId :: Maybe String,
gAttrs :: [Attr],
gNodes :: [Node],
gEdges :: [Edge],
gSubgraphs :: [Graph]
}
deriving (Show)
data GraphType = Directed | Undirected
deriving (Show)
data Node = Node String [Attr]
deriving Show
data Edge = Edge String String [Attr]
deriving Show
type Attr = (String,String)
--
-- * Graph construction
--
addSubGraphs :: [Graph] -> Graph -> Graph
addSubGraphs gs g = g { gSubgraphs = gs ++ gSubgraphs g }
setName :: String -> Graph -> Graph
setName n g = g { gId = Just n }
setAttr :: String -> String -> Graph -> Graph
setAttr n v g = g { gAttrs = tableSet n v (gAttrs g) }
--
-- * Pretty-printing
--
prGraphviz :: Graph -> String
prGraphviz g@(Graph t i _ _ _ _) =
graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n"
prSubGraph :: Graph -> String
prSubGraph g@(Graph _ i _ _ _ _) =
"subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}"
prGraph :: Graph -> String
prGraph (Graph t id at ns es ss) =
unlines $ map (++";") (map prAttr at
++ map prNode ns
++ map (prEdge t) es
++ map prSubGraph ss)
graphtype :: GraphType -> String
graphtype Directed = "digraph"
graphtype Undirected = "graph"
prNode :: Node -> String
prNode (Node n at) = esc n ++ " " ++ prAttrList at
prEdge :: GraphType -> Edge -> String
prEdge t (Edge x y at) = esc x ++ " " ++ edgeop t ++ " " ++ esc y ++ " " ++ prAttrList at
edgeop :: GraphType -> String
edgeop Directed = "->"
edgeop Undirected = "--"
prAttrList :: [Attr] -> String
prAttrList [] = ""
prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
prAttr :: Attr -> String
prAttr (n,v) = esc n ++ " = " ++ esc v
esc :: String -> String
esc s | needEsc s = "\"" ++ concat [ if shouldEsc c then ['\\',c] else [c] | c <- s ] ++ "\""
| otherwise = s
where shouldEsc = (`elem` ['"', '\\'])
needEsc :: String -> Bool
needEsc [] = True
needEsc xs | all isDigit xs = False
needEsc (x:xs) = not (isIDFirst x && all isIDChar xs)
isIDFirst, isIDChar :: Char -> Bool
isIDFirst c = c `elem` (['_']++['a'..'z']++['A'..'Z'])
isIDChar c = isIDFirst c || isDigit c

111
src/GF/Speech/JSGF.hs Normal file
View File

@@ -0,0 +1,111 @@
----------------------------------------------------------------------
-- |
-- Module : GF.Speech.JSGF
--
-- This module prints a CFG as a JSGF grammar.
--
-- FIXME: remove \/ warn \/ fail if there are int \/ string literal
-- categories in the grammar
--
-- FIXME: convert to UTF-8
-----------------------------------------------------------------------------
module GF.Speech.JSGF (jsgfPrinter) where
import GF.Data.Utilities
import GF.Speech.CFG
import GF.Speech.RegExp
import GF.Speech.SISR
import GF.Speech.SRG
import PGF.CId
import PGF.Data
import Data.Char
import Data.List
import Data.Maybe
import Text.PrettyPrint.HughesPJ
import Debug.Trace
width :: Int
width = 75
jsgfPrinter :: Maybe SISRFormat
-> PGF
-> CId -> String
jsgfPrinter sisr pgf cnc = renderStyle st $ prJSGF sisr $ makeSimpleSRG pgf cnc
where st = style { lineLength = width }
prJSGF :: Maybe SISRFormat -> SRG -> Doc
prJSGF sisr srg
= header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg))
where
header = text "#JSGF" <+> text "V1.0" <+> text "UTF-8" <+> lang <> char ';' $$
comment ("JSGF speech recognition grammar for " ++ srgName srg) $$
comment "Generated by GF" $$
text ("grammar " ++ srgName srg ++ ";")
lang = maybe empty text (srgLanguage srg)
mainCat = rule True "MAIN" [prCat (srgStartCat srg)]
prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs)
prAlt (SRGAlt mp n rhs) = sep [initTag, p (prItem sisr n rhs), finalTag]
where initTag | isEmpty t = empty
| otherwise = text "<NULL>" <+> t
where t = tag sisr (profileInitSISR n)
finalTag = tag sisr (profileFinalSISR n)
p = if isEmpty initTag && isEmpty finalTag then id else parens
prCat :: Cat -> Doc
prCat c = char '<' <> text c <> char '>'
prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
prItem sisr t = f 0
where
f _ (REUnion []) = text "<VOID>"
f p (REUnion xs)
| not (null es) = brackets (f 0 (REUnion nes))
| otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
where (es,nes) = partition isEpsilon xs
f _ (REConcat []) = text "<NULL>"
f p (REConcat xs) = (if p >= 3 then parens else id) (fsep (map (f 2) xs))
f p (RERepeat x) = f 3 x <> char '*'
f _ (RESymbol s) = prSymbol sisr t s
prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc
prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n)
prSymbol _ cn (Terminal t) | all isPunct t = empty -- removes punctuation
| otherwise = text t -- FIXME: quote if there is whitespace or odd chars
tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
tag Nothing _ = empty
tag (Just fmt) t = case t fmt of
[] -> empty
ts -> char '{' <+> (text (e $ prSISR ts)) <+> char '}'
where e [] = []
e ('}':xs) = '\\':'}':e xs
e ('\n':xs) = ' ' : e (dropWhile isSpace xs)
e (x:xs) = x:e xs
isPunct :: Char -> Bool
isPunct c = c `elem` "-_.;.,?!"
comment :: String -> Doc
comment s = text "//" <+> text s
alts :: [Doc] -> Doc
alts = fsep . prepunctuate (text "| ")
rule :: Bool -> Cat -> [Doc] -> Doc
rule pub c xs = p <+> prCat c <+> char '=' <+> nest 2 (alts xs) <+> char ';'
where p = if pub then text "public" else empty
-- Pretty-printing utilities
emptyLine :: Doc
emptyLine = text ""
prepunctuate :: Doc -> [Doc] -> [Doc]
prepunctuate _ [] = []
prepunctuate p (x:xs) = x : map (p <>) xs
($++$) :: Doc -> Doc -> Doc
x $++$ y = x $$ emptyLine $$ y

84
src/GF/Speech/PGFToCFG.hs Normal file
View File

@@ -0,0 +1,84 @@
----------------------------------------------------------------------
-- |
-- Module : GF.Speech.PGFToCFG
--
-- Approximates PGF grammars with context-free grammars.
----------------------------------------------------------------------
module GF.Speech.PGFToCFG (bnfPrinter, pgfToCFG) where
import PGF.CId
import PGF.Data as PGF
import PGF.Macros
import GF.Infra.Ident
import GF.Speech.CFG
import Data.Array as Array
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
bnfPrinter :: PGF -> CId -> String
bnfPrinter pgf cnc = prCFG $ pgfToCFG pgf cnc
pgfToCFG :: PGF
-> CId -- ^ Concrete syntax name
-> CFG
pgfToCFG pgf lang = mkCFG (lookStartCat pgf) extCats (startRules ++ concatMap fruleToCFRule rules)
where
pinfo = fromMaybe (error "pgfToCFG: No parser.") (lookParser pgf lang)
rules :: [FRule]
rules = Array.elems (PGF.allRules pinfo)
fcatGFCats :: Map FCat CId
fcatGFCats = Map.fromList [(fc,c) | (c,fcs) <- Map.toList (startupCats pinfo), fc <- fcs]
fcatGFCat :: FCat -> CId
fcatGFCat c = fromMaybe (mkCId "Unknown") (Map.lookup c fcatGFCats)
fcatToCat :: FCat -> FIndex -> Cat
fcatToCat c l = prCId (fcatGFCat c) ++ "_" ++ show c ++ "_" ++ show l
extCats :: Set Cat
extCats = Set.fromList $ map lhsCat startRules
-- NOTE: this is only correct for cats that have a lincat with exactly one row.
startRules :: [CFRule]
startRules = [CFRule (prCId c) [NonTerminal (fcatToCat fc 0)] (CFRes 0)
| (c,fcs) <- Map.toList (startupCats pinfo),
fc <- fcs, not (isLiteralFCat fc)]
fruleToCFRule :: FRule -> [CFRule]
fruleToCFRule (FRule f ps args c rhs) =
[CFRule (fcatToCat c l) (mkRhs row) (profilesToTerm (map (fixProfile row) ps))
| (l,row) <- Array.assocs rhs, not (containsLiterals row)]
where
mkRhs :: Array FPointPos FSymbol -> [CFSymbol]
mkRhs = map fsymbolToSymbol . Array.elems
containsLiterals :: Array FPointPos FSymbol -> Bool
containsLiterals row = any isLiteralFCat [args!!n | FSymCat _ n <- Array.elems row]
fsymbolToSymbol :: FSymbol -> CFSymbol
fsymbolToSymbol (FSymCat l n) = NonTerminal (fcatToCat (args!!n) l)
fsymbolToSymbol (FSymTok t) = Terminal t
fixProfile :: Array FPointPos FSymbol -> Profile -> Profile
fixProfile row = concatMap positions
where
nts = zip [0..] [nt | nt@(FSymCat _ _) <- Array.elems row ]
positions i = [k | (k,FSymCat _ j) <- nts, j == i]
profilesToTerm :: [Profile] -> CFTerm
profilesToTerm [[n]] | f == wildCId = CFRes n
profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps)
where (argTypes,_) = catSkeleton $ lookType pgf f
profileToTerm :: CId -> Profile -> CFTerm
profileToTerm t [] = CFMeta t
profileToTerm _ xs = CFRes (last xs) -- FIXME: unify
isLiteralFCat :: FCat -> Bool
isLiteralFCat = (`elem` [fcatString, fcatInt, fcatFloat, fcatVar])

27
src/GF/Speech/PrRegExp.hs Normal file
View File

@@ -0,0 +1,27 @@
----------------------------------------------------------------------
-- |
-- Module : GF.Speech.PrRegExp
--
-- This module prints a grammar as a regular expression.
-----------------------------------------------------------------------------
module GF.Speech.PrRegExp (regexpPrinter,multiRegexpPrinter) where
import GF.Speech.CFG
import GF.Speech.CFGToFA
import GF.Speech.PGFToCFG
import GF.Speech.RegExp
import PGF
regexpPrinter :: PGF -> CId -> String
regexpPrinter pgf cnc = (++"\n") $ prRE $ dfa2re $ cfgToFA $ pgfToCFG pgf cnc
multiRegexpPrinter :: PGF -> CId -> String
multiRegexpPrinter pgf cnc = prREs $ mfa2res $ cfgToMFA $ pgfToCFG pgf cnc
prREs :: [(String,RE CFSymbol)] -> String
prREs res = unlines [l ++ " = " ++ prRE (mapRE showLabel re) | (l,re) <- res]
where showLabel = symbol (\l -> "<" ++ l ++ ">") id
mfa2res :: MFA -> [(String,RE CFSymbol)]
mfa2res (MFA _ dfas) = [(l, minimizeRE (dfa2re dfa)) | (l,dfa) <- dfas]

143
src/GF/Speech/RegExp.hs Normal file
View File

@@ -0,0 +1,143 @@
module GF.Speech.RegExp (RE(..),
epsilonRE, nullRE,
isEpsilon, isNull,
unionRE, concatRE, seqRE,
repeatRE, minimizeRE,
mapRE, mapRE', joinRE,
symbolsRE,
dfa2re, prRE) where
import Data.List
import GF.Data.Utilities
import GF.Speech.FiniteState
data RE a =
REUnion [RE a] -- ^ REUnion [] is null
| REConcat [RE a] -- ^ REConcat [] is epsilon
| RERepeat (RE a)
| RESymbol a
deriving (Eq,Ord,Show)
dfa2re :: (Ord a) => DFA a -> RE a
dfa2re = finalRE . elimStates . modifyTransitions merge . addLoops
. oneFinalState () epsilonRE . mapTransitions RESymbol
where addLoops fa = newTransitions [(s,s,nullRE) | (s,_) <- states fa] fa
merge es = [(f,t,unionRE ls)
| ((f,t),ls) <- buildMultiMap [((f,t),l) | (f,t,l) <- es]]
elimStates :: (Ord a) => DFA (RE a) -> DFA (RE a)
elimStates fa =
case [s | (s,_) <- states fa, isInternal fa s] of
[] -> fa
sE:_ -> elimStates $ insertTransitionsWith (\x y -> unionRE [x,y]) ts $ removeState sE fa
where sAs = nonLoopTransitionsTo sE fa
sBs = nonLoopTransitionsFrom sE fa
r2 = unionRE $ loops sE fa
ts = [(sA, sB, r r1 r3) | (sA,r1) <- sAs, (sB,r3) <- sBs]
r r1 r3 = concatRE [r1, repeatRE r2, r3]
epsilonRE :: RE a
epsilonRE = REConcat []
nullRE :: RE a
nullRE = REUnion []
isNull :: RE a -> Bool
isNull (REUnion []) = True
isNull _ = False
isEpsilon :: RE a -> Bool
isEpsilon (REConcat []) = True
isEpsilon _ = False
unionRE :: Ord a => [RE a] -> RE a
unionRE = unionOrId . sortNub . concatMap toList
where
toList (REUnion xs) = xs
toList x = [x]
unionOrId [r] = r
unionOrId rs = REUnion rs
concatRE :: [RE a] -> RE a
concatRE xs | any isNull xs = nullRE
| otherwise = case concatMap toList xs of
[r] -> r
rs -> REConcat rs
where
toList (REConcat xs) = xs
toList x = [x]
seqRE :: [a] -> RE a
seqRE = concatRE . map RESymbol
repeatRE :: RE a -> RE a
repeatRE x | isNull x || isEpsilon x = epsilonRE
| otherwise = RERepeat x
finalRE :: Ord a => DFA (RE a) -> RE a
finalRE fa = concatRE [repeatRE r1, r2,
repeatRE (unionRE [r3, concatRE [r4, repeatRE r1, r2]])]
where
s0 = startState fa
[sF] = finalStates fa
r1 = unionRE $ loops s0 fa
r2 = unionRE $ map snd $ nonLoopTransitionsTo sF fa
r3 = unionRE $ loops sF fa
r4 = unionRE $ map snd $ nonLoopTransitionsFrom sF fa
reverseRE :: RE a -> RE a
reverseRE (REConcat xs) = REConcat $ map reverseRE $ reverse xs
reverseRE (REUnion xs) = REUnion (map reverseRE xs)
reverseRE (RERepeat x) = RERepeat (reverseRE x)
reverseRE x = x
minimizeRE :: Ord a => RE a -> RE a
minimizeRE = reverseRE . mergeForward . reverseRE . mergeForward
mergeForward :: Ord a => RE a -> RE a
mergeForward (REUnion xs) =
unionRE [concatRE [mergeForward y,mergeForward (unionRE rs)] | (y,rs) <- buildMultiMap (map firstRE xs)]
mergeForward (REConcat (x:xs)) = concatRE [mergeForward x,mergeForward (REConcat xs)]
mergeForward (RERepeat r) = repeatRE (mergeForward r)
mergeForward r = r
firstRE :: RE a -> (RE a, RE a)
firstRE (REConcat (x:xs)) = (x, REConcat xs)
firstRE r = (r,epsilonRE)
mapRE :: (a -> b) -> RE a -> RE b
mapRE f = mapRE' (RESymbol . f)
mapRE' :: (a -> RE b) -> RE a -> RE b
mapRE' f (REConcat xs) = REConcat (map (mapRE' f) xs)
mapRE' f (REUnion xs) = REUnion (map (mapRE' f) xs)
mapRE' f (RERepeat x) = RERepeat (mapRE' f x)
mapRE' f (RESymbol s) = f s
joinRE :: RE (RE a) -> RE a
joinRE (REConcat xs) = REConcat (map joinRE xs)
joinRE (REUnion xs) = REUnion (map joinRE xs)
joinRE (RERepeat xs) = RERepeat (joinRE xs)
joinRE (RESymbol ss) = ss
symbolsRE :: RE a -> [a]
symbolsRE (REConcat xs) = concatMap symbolsRE xs
symbolsRE (REUnion xs) = concatMap symbolsRE xs
symbolsRE (RERepeat x) = symbolsRE x
symbolsRE (RESymbol x) = [x]
-- Debugging
prRE :: RE String -> String
prRE = prRE' 0
prRE' _ (REUnion []) = "<NULL>"
prRE' n (REUnion xs) = p n 1 (concat (intersperse " | " (map (prRE' 1) xs)))
prRE' n (REConcat xs) = p n 2 (unwords (map (prRE' 2) xs))
prRE' n (RERepeat x) = p n 3 (prRE' 3 x) ++ "*"
prRE' _ (RESymbol s) = s
p n m s | n >= m = "(" ++ s ++ ")"
| True = s

130
src/GF/Speech/Relation.hs Normal file
View File

@@ -0,0 +1,130 @@
----------------------------------------------------------------------
-- |
-- Module : Relation
-- Maintainer : BB
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/26 17:13:13 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.1 $
--
-- A simple module for relations.
-----------------------------------------------------------------------------
module GF.Speech.Relation (Rel, mkRel, mkRel'
, allRelated , isRelatedTo
, transitiveClosure
, reflexiveClosure, reflexiveClosure_
, symmetricClosure
, symmetricSubrelation, reflexiveSubrelation
, reflexiveElements
, equivalenceClasses
, isTransitive, isReflexive, isSymmetric
, isEquivalence
, isSubRelationOf) where
import Data.List
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import GF.Data.Utilities
type Rel a = Map a (Set a)
-- | Creates a relation from a list of related pairs.
mkRel :: Ord a => [(a,a)] -> Rel a
mkRel ps = relates ps Map.empty
-- | Creates a relation from a list pairs of elements and the elements
-- related to them.
mkRel' :: Ord a => [(a,[a])] -> Rel a
mkRel' xs = Map.fromListWith Set.union [(x,Set.fromList ys) | (x,ys) <- xs]
relToList :: Rel a -> [(a,a)]
relToList r = [ (x,y) | (x,ys) <- Map.toList r, y <- Set.toList ys ]
-- | Add a pair to the relation.
relate :: Ord a => a -> a -> Rel a -> Rel a
relate x y r = Map.insertWith Set.union x (Set.singleton y) r
-- | Add a list of pairs to the relation.
relates :: Ord a => [(a,a)] -> Rel a -> Rel a
relates ps r = foldl (\r' (x,y) -> relate x y r') r ps
-- | Checks if an element is related to another.
isRelatedTo :: Ord a => Rel a -> a -> a -> Bool
isRelatedTo r x y = maybe False (y `Set.member`) (Map.lookup x r)
-- | Get the set of elements to which a given element is related.
allRelated :: Ord a => Rel a -> a -> Set a
allRelated r x = fromMaybe Set.empty (Map.lookup x r)
-- | Get all elements in the relation.
domain :: Ord a => Rel a -> Set a
domain r = foldl Set.union (Map.keysSet r) (Map.elems r)
-- | Keep only pairs for which both elements are in the given set.
intersectSetRel :: Ord a => Set a -> Rel a -> Rel a
intersectSetRel s = filterRel (\x y -> x `Set.member` s && y `Set.member` s)
transitiveClosure :: Ord a => Rel a -> Rel a
transitiveClosure r = fix (Map.map growSet) r
where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
-> Rel a -> Rel a
reflexiveClosure_ u r = relates [(x,x) | x <- u] r
-- | Uses 'domain'
reflexiveClosure :: Ord a => Rel a -> Rel a
reflexiveClosure r = reflexiveClosure_ (Set.toList $ domain r) r
symmetricClosure :: Ord a => Rel a -> Rel a
symmetricClosure r = relates [ (y,x) | (x,y) <- relToList r ] r
symmetricSubrelation :: Ord a => Rel a -> Rel a
symmetricSubrelation r = filterRel (flip $ isRelatedTo r) r
reflexiveSubrelation :: Ord a => Rel a -> Rel a
reflexiveSubrelation r = intersectSetRel (reflexiveElements r) r
-- | Get the set of elements which are related to themselves.
reflexiveElements :: Ord a => Rel a -> Set a
reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
-- | Keep the related pairs for which the predicate is true.
filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
filterRel p = purgeEmpty . Map.mapWithKey (Set.filter . p)
-- | Remove keys that map to no elements.
purgeEmpty :: Ord a => Rel a -> Rel a
purgeEmpty r = Map.filter (not . Set.null) r
-- | Get the equivalence classes from an equivalence relation.
equivalenceClasses :: Ord a => Rel a -> [Set a]
equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
where equivalenceClasses_ [] _ = []
equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
where ys = allRelated r x
zs = [x' | x' <- xs, not (x' `Set.member` ys)]
isTransitive :: Ord a => Rel a -> Bool
isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
y <- Set.toList ys, z <- Set.toList (allRelated r y)]
isReflexive :: Ord a => Rel a -> Bool
isReflexive r = all (\ (x,ys) -> x `Set.member` ys) (Map.toList r)
isSymmetric :: Ord a => Rel a -> Bool
isSymmetric r = and [isRelatedTo r y x | (x,y) <- relToList r]
isEquivalence :: Ord a => Rel a -> Bool
isEquivalence r = isReflexive r && isSymmetric r && isTransitive r
isSubRelationOf :: Ord a => Rel a -> Rel a -> Bool
isSubRelationOf r1 r2 = all (uncurry (isRelatedTo r2)) (relToList r1)

75
src/GF/Speech/SISR.hs Normal file
View File

@@ -0,0 +1,75 @@
----------------------------------------------------------------------
-- |
-- Module : GF.Speech.SISR
--
-- Abstract syntax and pretty printer for SISR,
-- (Semantic Interpretation for Speech Recognition)
----------------------------------------------------------------------
module GF.Speech.SISR (SISRFormat(..), SISRTag, prSISR,
topCatSISR, profileInitSISR, catSISR, profileFinalSISR) where
import Data.List
import GF.Data.Utilities
import GF.Infra.Ident
import GF.Infra.Option (SISRFormat(..))
import GF.Speech.CFG
import GF.Speech.SRG (SRGNT)
import PGF.CId
import qualified GF.JavaScript.AbsJS as JS
import qualified GF.JavaScript.PrintJS as JS
type SISRTag = [JS.DeclOrExpr]
prSISR :: SISRTag -> String
prSISR = JS.printTree
topCatSISR :: String -> SISRFormat -> SISRTag
topCatSISR c fmt = map JS.DExpr [fmtOut fmt `ass` fmtRef fmt c]
profileInitSISR :: CFTerm -> SISRFormat -> SISRTag
profileInitSISR t fmt
| null (usedArgs t) = []
| otherwise = [JS.Decl [JS.DInit args (JS.EArray [])]]
usedArgs :: CFTerm -> [Int]
usedArgs (CFObj _ ts) = foldr union [] (map usedArgs ts)
usedArgs (CFAbs _ x) = usedArgs x
usedArgs (CFApp x y) = usedArgs x `union` usedArgs y
usedArgs (CFRes i) = [i]
usedArgs _ = []
catSISR :: CFTerm -> SRGNT -> SISRFormat -> SISRTag
catSISR t (c,i) fmt
| i `elem` usedArgs t = map JS.DExpr
[JS.EIndex (JS.EVar args) (JS.EInt (fromIntegral i)) `ass` fmtRef fmt c]
| otherwise = []
profileFinalSISR :: CFTerm -> SISRFormat -> SISRTag
profileFinalSISR term fmt = [JS.DExpr $ fmtOut fmt `ass` f term]
where
f (CFObj n ts) = tree (prCId n) (map f ts)
f (CFAbs v x) = JS.EFun [var v] [JS.SReturn (f x)]
f (CFApp x y) = JS.ECall (f x) [f y]
f (CFRes i) = JS.EIndex (JS.EVar args) (JS.EInt (fromIntegral i))
f (CFVar v) = JS.EVar (var v)
f (CFMeta typ) = obj [("name",JS.EStr "?"), ("type",JS.EStr (prCId typ))]
fmtOut SISR_WD20030401 = JS.EVar (JS.Ident "$")
fmtRef SISR_WD20030401 c = JS.EVar (JS.Ident ("$" ++ c))
args = JS.Ident "a"
var v = JS.Ident ("x" ++ show v)
field x y = JS.EMember x (JS.Ident y)
ass = JS.EAssign
tree n xs = obj [("name", JS.EStr n), ("args", JS.EArray xs)]
obj ps = JS.EObj [JS.Prop (JS.StringPropName x) y | (x,y) <- ps]

178
src/GF/Speech/SLF.hs Normal file
View File

@@ -0,0 +1,178 @@
----------------------------------------------------------------------
-- |
-- Module : GF.Speech.SLF
--
-- This module converts a CFG to an SLF finite-state network
-- for use with the ATK recognizer. The SLF format is described
-- in the HTK manual, and an example for use in ATK is shown
-- in the ATK manual.
--
-----------------------------------------------------------------------------
module GF.Speech.SLF (slfPrinter,slfGraphvizPrinter,
slfSubPrinter,slfSubGraphvizPrinter) where
import GF.Data.Utilities
import GF.Speech.CFG
import GF.Speech.FiniteState
import GF.Speech.CFG
import GF.Speech.CFGToFA
import GF.Speech.PGFToCFG
import qualified GF.Speech.Graphviz as Dot
import PGF
import PGF.CId
import Control.Monad
import qualified Control.Monad.State as STM
import Data.Char (toUpper)
import Data.List
import Data.Maybe
data SLFs = SLFs [(String,SLF)] SLF
data SLF = SLF { slfNodes :: [SLFNode], slfEdges :: [SLFEdge] }
data SLFNode = SLFNode { nId :: Int, nWord :: SLFWord, nTag :: Maybe String }
| SLFSubLat { nId :: Int, nLat :: String }
-- | An SLF word is a word, or the empty string.
type SLFWord = Maybe String
data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int }
type SLF_FA = FA State (Maybe CFSymbol) ()
mkFAs :: PGF -> CId -> (SLF_FA, [(String,SLF_FA)])
mkFAs pgf cnc = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs])
where MFA start subs = {- renameSubs $ -} cfgToMFA $ pgfToCFG pgf cnc
main = let (fa,s,f) = newFA_ in newTransition s f (NonTerminal start) fa
slfStyleFA :: Eq a => DFA a -> FA State (Maybe a) ()
slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothing ()
. moveLabelsToNodes . dfa2nfa
-- | Give sequential names to subnetworks.
renameSubs :: MFA -> MFA
renameSubs (MFA start subs) = MFA (newName start) subs'
where newNames = zip (map fst subs) ["sub"++show n | n <- [0..]]
newName s = lookup' s newNames
subs' = [(newName s,renameLabels n) | (s,n) <- subs]
renameLabels = mapTransitions (mapSymbol newName id)
--
-- * SLF graphviz printing (without sub-networks)
--
slfGraphvizPrinter :: PGF -> CId -> String
slfGraphvizPrinter pgf cnc
= prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc
where
gvFA = mapStates (fromMaybe "") . mapTransitions (const "")
--
-- * SLF graphviz printing (with sub-networks)
--
slfSubGraphvizPrinter :: PGF -> CId -> String
slfSubGraphvizPrinter pgf cnc = Dot.prGraphviz g
where (main, subs) = mkFAs pgf cnc
g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..]
ss = mapM (\ (c,f) -> gvSLFFA (Just c) f) subs
m = gvSLFFA Nothing main
gvSLFFA :: Maybe String -> SLF_FA -> STM.State [State] Dot.Graph
gvSLFFA n fa =
liftM (mkCluster n . faToGraphviz . mapStates (maybe "" mfaLabelToGv)
. mapTransitions (const "")) (rename fa)
where mfaLabelToGv = symbol ("#"++) id
mkCluster Nothing = id
mkCluster (Just x)
= Dot.setName ("cluster_"++x) . Dot.setAttr "label" x
rename fa = do
names <- STM.get
let fa' = renameStates names fa
names' = unusedNames fa'
STM.put names'
return fa'
--
-- * SLF printing (without sub-networks)
--
slfPrinter :: PGF -> CId -> String
slfPrinter pgf cnc
= prSLF $ automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc
--
-- * SLF printing (with sub-networks)
--
-- | Make a network with subnetworks in SLF
slfSubPrinter :: PGF -> CId -> String
slfSubPrinter pgf cnc = prSLFs slfs
where
(main,subs) = mkFAs pgf cnc
slfs = SLFs [(c, faToSLF fa) | (c,fa) <- subs] (faToSLF main)
faToSLF = automatonToSLF mfaNodeToSLFNode
automatonToSLF :: (Int -> a -> SLFNode) -> FA State a () -> SLF
automatonToSLF mkNode fa = SLF { slfNodes = ns, slfEdges = es }
where ns = map (uncurry mkNode) (states fa)
es = zipWith (\i (f,t,()) -> mkSLFEdge i (f,t)) [0..] (transitions fa)
mfaNodeToSLFNode :: Int -> Maybe CFSymbol -> SLFNode
mfaNodeToSLFNode i l = case l of
Nothing -> mkSLFNode i Nothing
Just (Terminal x) -> mkSLFNode i (Just x)
Just (NonTerminal s) -> mkSLFSubLat i s
mkSLFNode :: Int -> Maybe String -> SLFNode
mkSLFNode i Nothing = SLFNode { nId = i, nWord = Nothing, nTag = Nothing }
mkSLFNode i (Just w)
| isNonWord w = SLFNode { nId = i,
nWord = Nothing,
nTag = Just w }
| otherwise = SLFNode { nId = i,
nWord = Just (map toUpper w),
nTag = Just w }
mkSLFSubLat :: Int -> String -> SLFNode
mkSLFSubLat i sub = SLFSubLat { nId = i, nLat = sub }
mkSLFEdge :: Int -> (Int,Int) -> SLFEdge
mkSLFEdge i (f,t) = SLFEdge { eId = i, eStart = f, eEnd = t }
prSLFs :: SLFs -> String
prSLFs (SLFs subs main) = unlinesS (map prSub subs ++ [prOneSLF main]) ""
where prSub (n,s) = showString "SUBLAT=" . shows n
. nl . prOneSLF s . showString "." . nl
prSLF :: SLF -> String
prSLF slf = prOneSLF slf ""
prOneSLF :: SLF -> ShowS
prOneSLF (SLF { slfNodes = ns, slfEdges = es})
= header . unlinesS (map prNode ns) . nl . unlinesS (map prEdge es) . nl
where
header = prFields [("N",show (length ns)),("L", show (length es))] . nl
prNode (SLFNode { nId = i, nWord = w, nTag = t })
= prFields $ [("I",show i),("W",showWord w)]
++ maybe [] (\t -> [("s",t)]) t
prNode (SLFSubLat { nId = i, nLat = l })
= prFields [("I",show i),("L",show l)]
prEdge e = prFields [("J",show (eId e)),("S",show (eStart e)),("E",show (eEnd e))]
-- | Check if a word should not correspond to a word in the SLF file.
isNonWord :: String -> Bool
isNonWord = any isPunct
isPunct :: Char -> Bool
isPunct c = c `elem` "-_.;.,?!()[]{}"
showWord :: SLFWord -> String
showWord Nothing = "!NULL"
showWord (Just w) | null w = "!NULL"
| otherwise = w
prFields :: [(String,String)] -> ShowS
prFields fs = unwordsS [ showString l . showChar '=' . showString v | (l,v) <- fs ]

175
src/GF/Speech/SRG.hs Normal file
View File

@@ -0,0 +1,175 @@
----------------------------------------------------------------------
-- |
-- Module : SRG
--
-- Representation of, conversion to, and utilities for
-- printing of a general Speech Recognition Grammar.
--
-- FIXME: remove \/ warn \/ fail if there are int \/ string literal
-- categories in the grammar
----------------------------------------------------------------------
module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol
, SRGNT, CFTerm
, makeSimpleSRG
, makeNonRecursiveSRG
, getSpeechLanguage
, isExternalCat
, lookupFM_, prtS
) where
import GF.Data.Operations
import GF.Data.Utilities
import GF.Infra.Ident
import GF.Infra.PrintClass
import GF.Speech.CFG
import GF.Speech.PGFToCFG
import GF.Speech.Relation
import GF.Speech.FiniteState
import GF.Speech.RegExp
import GF.Speech.CFGToFA
import GF.Infra.Option
import PGF.CId
import PGF.Data
import PGF.Macros
import Data.List
import Data.Maybe (fromMaybe, maybeToList)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Debug.Trace
data SRG = SRG { srgName :: String -- ^ grammar name
, srgStartCat :: Cat -- ^ start category name
, srgExternalCats :: Set Cat
, srgLanguage :: Maybe String -- ^ The language for which the grammar
-- is intended, e.g. en-UK
, srgRules :: [SRGRule]
}
deriving (Eq,Show)
data SRGRule = SRGRule Cat [SRGAlt] -- ^ SRG category name, original category name
-- and productions
deriving (Eq,Show)
-- | maybe a probability, a rule name and an EBNF right-hand side
data SRGAlt = SRGAlt (Maybe Double) CFTerm SRGItem
deriving (Eq,Show)
type SRGItem = RE SRGSymbol
type SRGSymbol = Symbol SRGNT Token
-- | An SRG non-terminal. Category name and its number in the profile.
type SRGNT = (Cat, Int)
-- | Create a compact filtered non-left-recursive SRG.
makeSimpleSRG :: PGF -> CId -> SRG
makeSimpleSRG = mkSRG cfgToSRG preprocess
where
preprocess = traceStats "After mergeIdentical"
. mergeIdentical
. traceStats "After removeLeftRecursion"
. removeLeftRecursion
. traceStats "After topDownFilter"
. topDownFilter
. traceStats "After bottomUpFilter"
. bottomUpFilter
. traceStats "After removeCycles"
. removeCycles
. traceStats "Inital CFG"
cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg]
traceStats s g = trace ("---- " ++ s ++ ": " ++ stats g {- ++ "\n" ++ prCFRules g ++ "----" -}) g
stats g = "Categories: " ++ show (countCats g)
++ ", External categories: " ++ show (Set.size (cfgExternalCats g))
++ ", Rules: " ++ show (countRules g)
makeNonRecursiveSRG :: PGF
-> CId -- ^ Concrete syntax name.
-> SRG
makeNonRecursiveSRG = mkSRG cfgToSRG id
where
cfgToSRG cfg = [SRGRule l [SRGAlt Nothing dummyCFTerm (dfaToSRGItem dfa)] | (l,dfa) <- dfas]
where
MFA _ dfas = cfgToMFA cfg
dfaToSRGItem = mapRE dummySRGNT . minimizeRE . dfa2re
dummyCFTerm = CFMeta (mkCId "dummy")
dummySRGNT = mapSymbol (\c -> (c,0)) id
mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
mkSRG mkRules preprocess pgf cnc =
SRG { srgName = prCId cnc,
srgStartCat = cfgStartCat cfg,
srgExternalCats = cfgExternalCats cfg,
srgLanguage = getSpeechLanguage pgf cnc,
srgRules = mkRules cfg }
where cfg = renameCats (prCId cnc) $ preprocess $ pgfToCFG pgf cnc
-- | Renames all external cats C to C_cat, and all internal cats to
-- GrammarName_N where N is an integer.
renameCats :: String -> CFG -> CFG
renameCats prefix cfg = mapCFGCats renameCat cfg
where renameCat c | isExternal c = c ++ "_cat"
| otherwise = fromMaybe ("renameCats: " ++ c) (Map.lookup c names)
isExternal c = c `Set.member` cfgExternalCats cfg
names = Map.fromList $ zip (allCats cfg) [prefix ++ "_" ++ show x | x <- [0..]]
getSpeechLanguage :: PGF -> CId -> Maybe String
getSpeechLanguage pgf cnc = fmap (replace '_' '-') $ lookConcrFlag pgf cnc (mkCId "language")
cfRulesToSRGRule :: [CFRule] -> SRGRule
cfRulesToSRGRule rs@(r:_) = SRGRule (lhsCat r) rhs
where
alts = [((n,Nothing),mkSRGSymbols 0 ss) | CFRule c ss n <- rs]
rhs = [SRGAlt p n (srgItem sss) | ((n,p),sss) <- buildMultiMap alts ]
mkSRGSymbols _ [] = []
mkSRGSymbols i (NonTerminal c:ss) = NonTerminal (c,i) : mkSRGSymbols (i+1) ss
mkSRGSymbols i (Terminal t:ss) = Terminal t : mkSRGSymbols i ss
allSRGCats :: SRG -> [String]
allSRGCats SRG { srgRules = rs } = [c | SRGRule c _ <- rs]
isExternalCat :: SRG -> Cat -> Bool
isExternalCat srg c = c `Set.member` srgExternalCats srg
--
-- * Size-optimized EBNF SRGs
--
srgItem :: [[SRGSymbol]] -> SRGItem
srgItem = unionRE . map mergeItems . sortGroupBy (compareBy filterCats)
-- non-optimizing version:
--srgItem = unionRE . map seqRE
-- | Merges a list of right-hand sides which all have the same
-- sequence of non-terminals.
mergeItems :: [[SRGSymbol]] -> SRGItem
mergeItems = minimizeRE . ungroupTokens . minimizeRE . unionRE . map seqRE . map groupTokens
groupTokens :: [SRGSymbol] -> [Symbol SRGNT [Token]]
groupTokens [] = []
groupTokens (Terminal t:ss) = case groupTokens ss of
Terminal ts:ss' -> Terminal (t:ts):ss'
ss' -> Terminal [t]:ss'
groupTokens (NonTerminal c:ss) = NonTerminal c : groupTokens ss
ungroupTokens :: RE (Symbol SRGNT [Token]) -> RE SRGSymbol
ungroupTokens = joinRE . mapRE (symbol (RESymbol . NonTerminal) (REConcat . map (RESymbol . Terminal)))
--
-- * Utilities for building and printing SRGs
--
lookupFM_ :: (Ord key, Show key) => Map key elt -> key -> elt
lookupFM_ fm k = Map.findWithDefault err k fm
where err = error $ "Key not found: " ++ show k
++ "\namong " ++ show (Map.keys fm)
prtS :: Print a => a -> ShowS
prtS = showString . prt

104
src/GF/Speech/SRGS_XML.hs Normal file
View File

@@ -0,0 +1,104 @@
----------------------------------------------------------------------
-- |
-- Module : GF.Speech.SRGS_XML
--
-- Prints an SRGS XML speech recognition grammars.
----------------------------------------------------------------------
module GF.Speech.SRGS_XML (srgsXmlPrinter, srgsXmlNonRecursivePrinter) where
import GF.Data.Utilities
import GF.Data.XML
import GF.Infra.Option
import GF.Speech.CFG
import GF.Speech.RegExp
import GF.Speech.SISR as SISR
import GF.Speech.SRG
import PGF (PGF, CId)
import Control.Monad
import Data.Char (toUpper,toLower)
import Data.List
import Data.Maybe
import qualified Data.Map as Map
srgsXmlPrinter :: Maybe SISRFormat
-> PGF -> CId -> String
srgsXmlPrinter sisr pgf cnc = prSrgsXml sisr $ makeSimpleSRG pgf cnc
srgsXmlNonRecursivePrinter :: PGF -> CId -> String
srgsXmlNonRecursivePrinter pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG pgf cnc
prSrgsXml :: Maybe SISRFormat -> SRG -> String
prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr)
where
xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $
[meta "description"
("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."),
meta "generator" "Grammatical Framework"]
++ map ruleToXML (srgRules srg)
ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts)
where pub = if isExternalCat srg cat then [("scope","public")] else []
prRhs rhss = [oneOf (map (mkProd sisr) rhss)]
mkProd :: Maybe SISRFormat -> SRGAlt -> XML
mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf)
where x = mkItem sisr n rhs
ti = tag sisr (profileInitSISR n)
tf = tag sisr (profileFinalSISR n)
mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML
mkItem sisr cn = f
where
f (REUnion []) = ETag "ruleref" [("special","VOID")]
f (REUnion xs)
| not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)]
| otherwise = oneOf (map f xs)
where (es,nes) = partition isEpsilon xs
f (REConcat []) = ETag "ruleref" [("special","NULL")]
f (REConcat xs) = Tag "item" [] (map f xs)
f (RERepeat x) = Tag "item" [("repeat","0-")] [f x]
f (RESymbol s) = symItem sisr cn s
symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML
symItem sisr cn (NonTerminal n@(c,_)) =
Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n)
symItem _ _ (Terminal t) = Tag "item" [] [Data (showToken t)]
tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> [XML]
tag Nothing _ = []
tag (Just fmt) t = case t fmt of
[] -> []
ts -> [Tag "tag" [] [Data (prSISR ts)]]
showToken :: Token -> String
showToken t = t
oneOf :: [XML] -> XML
oneOf = Tag "one-of" []
grammar :: Maybe SISRFormat
-> String -- ^ root
-> Maybe String -- ^language
-> [XML] -> XML
grammar sisr root ml =
Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"),
("version","1.0"),
("mode","voice"),
("root",root)]
++ (if isJust sisr then [("tag-format","semantics/1.0")] else [])
++ maybe [] (\l -> [("xml:lang", l)]) ml
meta :: String -> String -> XML
meta n c = ETag "meta" [("name",n),("content",c)]
optimizeSRGS :: XML -> XML
optimizeSRGS = bottomUpXML f
where f (Tag "item" [] [x@(Tag "item" _ _)]) = x
f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x
f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs
f (Tag "item" as xs) = Tag "item" as (map g xs)
where g (Tag "item" [] [x@(ETag "ruleref" _)]) = x
g x = x
f (Tag "one-of" [] [x]) = x
f x = x

247
src/GF/Speech/VoiceXML.hs Normal file
View File

@@ -0,0 +1,247 @@
----------------------------------------------------------------------
-- |
-- Module : GF.Speech.VoiceXML
--
-- Creates VoiceXML dialogue systems from PGF grammars.
-----------------------------------------------------------------------------
module GF.Speech.VoiceXML (grammar2vxml) where
import GF.Data.Operations
import GF.Data.Str (sstrV)
import GF.Data.Utilities
import GF.Data.XML
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Speech.SRG (getSpeechLanguage)
import PGF.CId
import PGF.Data
import PGF.Macros
import PGF.Linearize (realize)
import Control.Monad (liftM)
import Data.List (isPrefixOf, find, intersperse)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Debug.Trace
-- | the main function
grammar2vxml :: PGF -> CId -> String
grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
where skel = pgfSkeleton pgf
name = prCId cnc
qs = catQuestions pgf cnc (map fst skel)
language = getSpeechLanguage pgf cnc
start = mkCId (lookStartCat pgf)
--
-- * VSkeleton: a simple description of the abstract syntax.
--
type Skeleton = [(CId, [(CId, [CId])])]
pgfSkeleton :: PGF -> Skeleton
pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType pgf f))) | f <- fs])
| (c,fs) <- Map.toList (catfuns (abstract pgf)),
not (isLiteralCat c)]
-- FIXME: should this go in a more general module?
isLiteralCat :: CId -> Bool
isLiteralCat = (`elem` [mkCId "String", mkCId "Float", mkCId "Int"])
--
-- * Questions to ask
--
type CatQuestions = [(CId,String)]
catQuestions :: PGF -> CId -> [CId] -> CatQuestions
catQuestions pgf cnc cats = [(c,catQuestion pgf cnc c) | c <- cats]
catQuestion :: PGF -> CId -> CId -> String
catQuestion pgf cnc cat = realize (lookPrintName pgf cnc cat)
{-
lin :: StateGrammar -> String -> Err String
lin gr fun = do
tree <- string2treeErr gr fun
let ls = map unt $ linTree2strings noMark g c tree
case ls of
[] -> fail $ "No linearization of " ++ fun
l:_ -> return l
where c = cncId gr
g = stateGrammarST gr
unt = formatAsText
-}
getCatQuestion :: CId -> CatQuestions -> String
getCatQuestion c qs =
fromMaybe (error "No question for category " ++ prCId c) (lookup c qs)
--
-- * Generate VoiceXML
--
skel2vxml :: String -> Maybe String -> CId -> Skeleton -> CatQuestions -> XML
skel2vxml name language start skel qs =
vxml language ([startForm] ++ concatMap (uncurry (catForms gr qs)) skel)
where
gr = grammarURI name
startForm = Tag "form" [] [subdialog "sub" [("src", "#"++catFormId start)]
[param "old" "{ name : '?' }"]]
grammarURI :: String -> String
grammarURI name = name ++ ".grxml"
catForms :: String -> CatQuestions -> CId -> [(CId, [CId])] -> [XML]
catForms gr qs cat fs =
comments [prCId cat ++ " category."]
++ [cat2form gr qs cat fs]
cat2form :: String -> CatQuestions -> CId -> [(CId, [CId])] -> XML
cat2form gr qs cat fs =
form (catFormId cat) $
[var "old" Nothing,
blockCond "old.name != '?'" [assign "term" "old"],
field "term" []
[promptString (getCatQuestion cat qs),
vxmlGrammar (gr++"#"++catFormId cat)
]
]
++ concatMap (uncurry (fun2sub gr cat)) fs
++ [block [return_ ["term"]{-]-}]]
fun2sub :: String -> CId -> CId -> [CId] -> [XML]
fun2sub gr cat fun args =
comments [prCId fun ++ " : ("
++ concat (intersperse ", " (map prCId args))
++ ") " ++ prCId cat] ++ ss
where
ss = zipWith mkSub [0..] args
mkSub n t = subdialog s [("src","#"++catFormId t),
("cond","term.name == "++string (prCId fun))]
[param "old" v,
filled [] [assign v (s++".term")]]
where s = prCId fun ++ "_" ++ show n
v = "term.args["++show n++"]"
catFormId :: CId -> String
catFormId c = prCId c ++ "_cat"
--
-- * VoiceXML stuff
--
vxml :: Maybe String -> [XML] -> XML
vxml ml = Tag "vxml" $ [("version","2.0"),
("xmlns","http://www.w3.org/2001/vxml")]
++ maybe [] (\l -> [("xml:lang", l)]) ml
form :: String -> [XML] -> XML
form id xs = Tag "form" [("id", id)] xs
field :: String -> [(String,String)] -> [XML] -> XML
field name attrs = Tag "field" ([("name",name)]++attrs)
subdialog :: String -> [(String,String)] -> [XML] -> XML
subdialog name attrs = Tag "subdialog" ([("name",name)]++attrs)
filled :: [(String,String)] -> [XML] -> XML
filled = Tag "filled"
vxmlGrammar :: String -> XML
vxmlGrammar uri = ETag "grammar" [("src",uri)]
prompt :: [XML] -> XML
prompt = Tag "prompt" []
promptString :: String -> XML
promptString p = prompt [Data p]
reprompt :: XML
reprompt = ETag "reprompt" []
assign :: String -> String -> XML
assign n e = ETag "assign" [("name",n),("expr",e)]
value :: String -> XML
value expr = ETag "value" [("expr",expr)]
if_ :: String -> [XML] -> XML
if_ c b = if_else c b []
if_else :: String -> [XML] -> [XML] -> XML
if_else c t f = cond [(c,t)] f
cond :: [(String,[XML])] -> [XML] -> XML
cond ((c,b):rest) els = Tag "if" [("cond",c)] (b ++ es)
where es = [Tag "elseif" [("cond",c')] b' | (c',b') <- rest]
++ if null els then [] else (Tag "else" [] []:els)
goto_item :: String -> XML
goto_item nextitem = ETag "goto" [("nextitem",nextitem)]
return_ :: [String] -> XML
return_ names = ETag "return" [("namelist", unwords names)]
block :: [XML] -> XML
block = Tag "block" []
blockCond :: String -> [XML] -> XML
blockCond cond = Tag "block" [("cond", cond)]
throw :: String -> String -> XML
throw event msg = Tag "throw" [("event",event),("message",msg)] []
nomatch :: [XML] -> XML
nomatch = Tag "nomatch" []
help :: [XML] -> XML
help = Tag "help" []
param :: String -> String -> XML
param name expr = ETag "param" [("name",name),("expr",expr)]
var :: String -> Maybe String -> XML
var name expr = ETag "var" ([("name",name)]++e)
where e = maybe [] ((:[]) . (,) "expr") expr
script :: String -> XML
script s = Tag "script" [] [CData s]
scriptURI :: String -> XML
scriptURI uri = Tag "script" [("uri", uri)] []
--
-- * ECMAScript stuff
--
string :: String -> String
string s = "'" ++ concatMap esc s ++ "'"
where esc '\'' = "\\'"
esc c = [c]
{-
--
-- * List stuff
--
isListCat :: (CId, [(CId, [CId])]) -> Bool
isListCat (cat,rules) = "List" `isPrefixOf` prIdent cat && length rules == 2
&& ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
where c = drop 4 (prIdent cat)
fs = map (prIdent . fst) rules
isBaseFun :: CId -> Bool
isBaseFun f = "Base" `isPrefixOf` prIdent f
isConsFun :: CId -> Bool
isConsFun f = "Cons" `isPrefixOf` prIdent f
baseSize :: (CId, [(CId, [CId])]) -> Int
baseSize (_,rules) = length bs
where Just (_,bs) = find (isBaseFun . fst) rules
-}

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