diff options
Diffstat (limited to 'src/GF')
107 files changed, 28642 insertions, 0 deletions
diff --git a/src/GF/Command/Abstract.hs b/src/GF/Command/Abstract.hs new file mode 100644 index 000000000..29111b432 --- /dev/null +++ b/src/GF/Command/Abstract.hs @@ -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 + diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs new file mode 100644 index 000000000..96e7c57f4 --- /dev/null +++ b/src/GF/Command/Commands.hs @@ -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) diff --git a/src/GF/Command/Importing.hs b/src/GF/Command/Importing.hs new file mode 100644 index 000000000..c3ad9d746 --- /dev/null +++ b/src/GF/Command/Importing.hs @@ -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 diff --git a/src/GF/Command/Interpreter.hs b/src/GF/Command/Interpreter.hs new file mode 100644 index 000000000..e1a06a205 --- /dev/null +++ b/src/GF/Command/Interpreter.hs @@ -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 + diff --git a/src/GF/Command/Parse.hs b/src/GF/Command/Parse.hs new file mode 100644 index 000000000..eaf4cba84 --- /dev/null +++ b/src/GF/Command/Parse.hs @@ -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)) diff --git a/src/GF/Compile.hs b/src/GF/Compile.hs new file mode 100644 index 000000000..eb491cc78 --- /dev/null +++ b/src/GF/Compile.hs @@ -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 + + diff --git a/src/GF/Compile/BackOpt.hs b/src/GF/Compile/BackOpt.hs new file mode 100644 index 000000000..8667023c0 --- /dev/null +++ b/src/GF/Compile/BackOpt.hs @@ -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 diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs new file mode 100644 index 000000000..0a8361d36 --- /dev/null +++ b/src/GF/Compile/CheckGrammar.hs @@ -0,0 +1,1105 @@ +{-# LANGUAGE PatternGuards #-} +---------------------------------------------------------------------- +-- | +-- Module : CheckGrammar +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/11 23:24:33 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.31 $ +-- +-- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003 +-- +-- type checking also does the following modifications: +-- +-- - types of operations and local constants are inferred and put in place +-- +-- - both these types and linearization types are computed +-- +-- - tables are type-annotated +----------------------------------------------------------------------------- + +module GF.Compile.CheckGrammar ( + showCheckModule, justCheckLTerm, allOperDependencies, topoSortOpers) where + +import GF.Infra.Ident +import GF.Infra.Modules + +import GF.Compile.TypeCheck + +import GF.Compile.Refresh +import GF.Grammar.Grammar +import GF.Grammar.PrGrammar +import GF.Grammar.Lookup +import GF.Grammar.LookAbs +import GF.Grammar.Predef +import GF.Grammar.Macros +import GF.Grammar.ReservedWords +import GF.Grammar.PatternMatch +import GF.Grammar.AppPredefined +import GF.Grammar.Lockfield (isLockLabel) + +import GF.Data.Operations +import GF.Infra.CheckM + +import Data.List +import qualified Data.Set as Set +import qualified Data.Map as Map +import Control.Monad +import Debug.Trace --- + + +showCheckModule :: [SourceModule] -> SourceModule -> Err ([SourceModule],String) +showCheckModule mos m = do + (st,(_,msg)) <- checkStart $ checkModule mos m + return (st, unlines $ reverse msg) + +mapsCheckTree :: + (Ord a) => ((a,b) -> Check (a,c)) -> BinTree a b -> Check (BinTree a c) +mapsCheckTree f = checkErr . mapsErrTree (\t -> checkStart (f t) >>= return . fst) + + +-- | checking is performed in the dependency order of modules +checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule] +checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of + + ModMod mo -> do + let js = jments mo + checkRestrictedInheritance ms (name, mo) + js' <- case mtype mo of + MTAbstract -> mapsCheckTree (checkAbsInfo gr name mo) js + + MTTransfer a b -> mapsCheckTree (checkAbsInfo gr name mo) js + + MTResource -> mapsCheckTree (checkResInfo gr name mo) js + + MTConcrete a -> do + checkErr $ topoSortOpers $ allOperDependencies name js + ModMod abs <- checkErr $ lookupModule gr a + js1 <- checkCompleteGrammar abs mo + mapsCheckTree (checkCncInfo gr name mo (a,abs)) js1 + + MTInterface -> mapsCheckTree (checkResInfo gr name mo) js + + MTInstance a -> do + ModMod abs <- checkErr $ lookupModule gr a + -- checkCompleteInstance abs mo -- this is done in Rebuild + mapsCheckTree (checkResInfo gr name mo) js + + return $ (name, ModMod (replaceJudgements mo js')) : ms + + _ -> return $ (name,mod) : ms + where + gr = MGrammar $ (name,mod):ms + +-- check if restricted inheritance modules are still coherent +-- i.e. that the defs of remaining names don't depend on omitted names +---checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check () +checkRestrictedInheritance mos (name,mo) = do + let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll] -- names with restr. inh. + let mrs = [((i,m),mi) | (i,ModMod m) <- mos, Just mi <- [lookup i irs]] + -- the restr. modules themself, with restr. infos + mapM_ checkRem mrs + where + checkRem ((i,m),mi) = do + let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m))) + let incld c = Set.member c (Set.fromList incl) + let illegal c = Set.member c (Set.fromList excl) + let illegals = [(f,is) | + (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)] + case illegals of + [] -> return () + cs -> fail $ "In inherited module" +++ prt i ++ + ", dependence of excluded constants:" ++++ + unlines [" " ++ prt f +++ "on" +++ unwords (map prt is) | + (f,is) <- cs] + allDeps = ---- transClosure $ Map.fromList $ + concatMap (allDependencies (const True)) + [jments m | (_,ModMod m) <- mos] + transClosure ds = ds ---- TODO: check in deeper modules + +-- | check if a term is typable +justCheckLTerm :: SourceGrammar -> Term -> Err Term +justCheckLTerm src t = do + ((t',_),_) <- checkStart (inferLType src t) + return t' + +checkAbsInfo :: + SourceGrammar -> Ident -> Module Ident Info -> (Ident,Info) -> Check (Ident,Info) +checkAbsInfo st m mo (c,info) = do +---- checkReservedId c + case info of + AbsCat (Yes cont) _ -> mkCheck "category" $ + checkContext st cont ---- also cstrs + AbsFun (Yes typ0) md -> do + typ <- compAbsTyp [] typ0 -- to calculate let definitions + mkCheck "type of function" $ checkTyp st typ + md' <- case md of + Yes d -> do + let d' = elimTables d + mkCheckWarn "definition of function" $ checkEquation st (m,c) d' + return $ Yes d' + _ -> return md + return $ (c,AbsFun (Yes typ) md') + _ -> return (c,info) + where + mkCheck cat ss = case ss of + [] -> return (c,info) + ["[]"] -> return (c,info) ---- + _ -> checkErr $ Bad (unlines ss ++++ "in" +++ cat +++ prt c +++ pos c) + ---- temporary solution when tc of defs is incomplete + mkCheckWarn cat ss = case ss of + [] -> return (c,info) + ["[]"] -> return (c,info) ---- + _ -> do + checkWarn (unlines ss ++++ "in" +++ cat +++ prt c +++ pos c) + return (c,info) + + pos c = showPosition mo c + + compAbsTyp g t = case t of + Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g + Let (x,(_,a)) b -> do + a' <- compAbsTyp g a + compAbsTyp ((x, a'):g) b + Prod x a b -> do + a' <- compAbsTyp g a + b' <- compAbsTyp ((x,Vr x):g) b + return $ Prod x a' b' + Abs _ _ -> return t + _ -> composOp (compAbsTyp g) t + + elimTables e = case e of + S t a -> elimSel (elimTables t) (elimTables a) + T _ cs -> Eqs [(elimPatt p, elimTables t) | (p,t) <- cs] + _ -> composSafeOp elimTables e + elimPatt p = case p of + PR lps -> map snd lps + _ -> [p] + elimSel t a = case a of + R fs -> mkApp t (map (snd . snd) fs) + _ -> mkApp t [a] + +checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info) +checkCompleteGrammar abs cnc = do + let js = jments cnc + let fs = tree2list $ jments abs + foldM checkOne js fs + where + checkOne js i@(c,info) = case info of + AbsFun (Yes _) _ -> case lookupIdent c js of + Ok _ -> return js + _ -> do + checkWarn $ "WARNING: no linearization of" +++ prt c + return js + AbsCat (Yes _) _ -> case lookupIdent c js of + Ok (AnyInd _ _) -> return js + Ok (CncCat (Yes _) _ _) -> return js + Ok (CncCat _ mt mp) -> do + checkWarn $ + "Warning: no linearization type for" +++ prt c ++ + ", inserting default {s : Str}" + return $ updateTree (c,CncCat (Yes defLinType) mt mp) js + _ -> do + checkWarn $ + "Warning: no linearization type for" +++ prt c ++ + ", inserting default {s : Str}" + return $ updateTree (c,CncCat (Yes defLinType) nope nope) js + _ -> return js + +-- | General Principle: only Yes-values are checked. +-- A May-value has always been checked in its origin module. +checkResInfo :: + SourceGrammar -> Ident -> Module Ident Info -> (Ident,Info) -> Check (Ident,Info) +checkResInfo gr mo mm (c,info) = do + checkReservedId c + case info of + ResOper pty pde -> chIn "operation" $ do + (pty', pde') <- case (pty,pde) of + (Yes ty, Yes de) -> do + ty' <- check ty typeType >>= comp . fst + (de',_) <- check de ty' + return (Yes ty', Yes de') + (_, Yes de) -> do + (de',ty') <- infer de + return (Yes ty', Yes de') + (_,Nope) -> do + checkWarn "No definition given to oper" + return (pty,pde) + _ -> return (pty, pde) --- other cases are uninteresting + return (c, ResOper pty' pde') + + ResOverload os tysts -> chIn "overloading" $ do + tysts' <- mapM (uncurry $ flip check) tysts -- return explicit ones + tysts0 <- checkErr $ lookupOverload gr mo c -- check against inherited ones too + tysts1 <- mapM (uncurry $ flip check) + [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0] + let tysts2 = [(y,x) | (x,y) <- tysts1] + --- this can only be a partial guarantee, since matching + --- with value type is only possible if expected type is given + checkUniq $ + sort [t : map snd xs | (x,_) <- tysts2, Ok (xs,t) <- [typeFormCnc x]] + return (c,ResOverload os [(y,x) | (x,y) <- tysts']) + + ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do +---- mapM ((mapM (computeLType gr . snd)) . snd) pcs + mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs + ts <- checkErr $ lookupParamValues gr mo c + return (c,ResParam (Yes (pcs, Just ts))) + + _ -> return (c,info) + where + infer = inferLType gr + check = checkLType gr + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ pos c +++ ":") + comp = computeLType gr + pos c = showPosition mm c + + checkUniq xss = case xss of + x:y:xs + | x == y -> raise $ "ambiguous for type" +++ + prtType gr (mkFunType (tail x) (head x)) + | otherwise -> checkUniq $ y:xs + _ -> return () + + +checkCncInfo :: SourceGrammar -> Ident -> Module Ident Info -> + (Ident,SourceAbs) -> + (Ident,Info) -> Check (Ident,Info) +checkCncInfo gr m mo (a,abs) (c,info) = do + checkReservedId c + case info of + + CncFun _ (Yes trm) mpr -> chIn "linearization of" $ do + typ <- checkErr $ lookupFunType gr a c + cat0 <- checkErr $ valCat typ + (cont,val) <- linTypeOfType gr m typ -- creates arg vars + (trm',_) <- check trm (mkFunType (map snd cont) val) -- erases arg vars + checkPrintname gr mpr + cat <- return $ snd cat0 + return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr) + -- cat for cf, typ for pe + + CncCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do + checkErr $ lookupCatContext gr a c + typ' <- checkIfLinType gr typ + mdef' <- case mdef of + Yes def -> do + (def',_) <- checkLType gr def (mkFunType [typeStr] typ) + return $ Yes def' + _ -> return mdef + checkPrintname gr mpr + return (c,CncCat (Yes typ') mdef' mpr) + + _ -> checkResInfo gr m mo (c,info) + + where + env = gr + infer = inferLType gr + comp = computeLType gr + check = checkLType gr + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ pos c +++ ":") + pos c = showPosition mo c + +checkIfParType :: SourceGrammar -> Type -> Check () +checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ) + where + isParType ty = True ---- +{- case ty of + Cn typ -> case lookupConcrete st typ of + Ok (CncParType _ _ _) -> True + Ok (CncOper _ ty' _) -> isParType ty' + _ -> False + Q p t -> case lookupInPackage st (p,t) of + Ok (CncParType _ _ _) -> True + _ -> False + RecType r -> all (isParType . snd) r + _ -> False +-} + +checkIfStrType :: SourceGrammar -> Type -> Check () +checkIfStrType st typ = case typ of + Table arg val -> do + checkIfParType st arg + checkIfStrType st val + _ | typ == typeStr -> return () + _ -> prtFail "not a string type" typ + + +checkIfLinType :: SourceGrammar -> Type -> Check Type +checkIfLinType st typ0 = do + typ <- computeLType st typ0 +{- ---- should check that not fun type + case typ of + RecType r -> do + let (lins,ihs) = partition (isLinLabel .fst) r + --- checkErr $ checkUnique $ map fst r + mapM_ checkInh ihs + mapM_ checkLin lins + _ -> prtFail "a linearization type cannot be" typ +-} + return typ + + where + checkInh (label,typ) = checkIfParType st typ + checkLin (label,typ) = return () ---- checkIfStrType st typ + + +computeLType :: SourceGrammar -> Type -> Check Type +computeLType gr t = do + g0 <- checkGetContext + let g = [(x, Vr x) | (x,_) <- g0] + checkInContext g $ comp t + where + comp ty = case ty of + _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed + | isPredefConstant ty -> return ty ---- shouldn't be needed + + Q m ident -> checkIn ("module" +++ prt m) $ do + ty' <- checkErr (lookupResDef gr m ident) + if ty' == ty then return ty else comp ty' --- is this necessary to test? + + Vr ident -> checkLookup ident -- never needed to compute! + + App f a -> do + f' <- comp f + a' <- comp a + case f' of + Abs x b -> checkInContext [(x,a')] $ comp b + _ -> return $ App f' a' + + Prod x a b -> do + a' <- comp a + b' <- checkInContext [(x,Vr x)] $ comp b + return $ Prod x a' b' + + Abs x b -> do + b' <- checkInContext [(x,Vr x)] $ comp b + return $ Abs x b' + + ExtR r s -> do + r' <- comp r + s' <- comp s + case (r',s') of + (RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp + _ -> return $ ExtR r' s' + + RecType fs -> do + let fs' = sortRec fs + liftM RecType $ mapPairsM comp fs' + + _ | ty == typeTok -> return typeStr + _ | isPredefConstant ty -> return ty + + _ -> composOp comp ty + +checkPrintname :: SourceGrammar -> Perh Term -> Check () +checkPrintname st (Yes t) = checkLType st t typeStr >> return () +checkPrintname _ _ = return () + +-- | for grammars obtained otherwise than by parsing ---- update!! +checkReservedId :: Ident -> Check () +checkReservedId x = let c = prt x in + if isResWord c + then checkWarn ("Warning: reserved word used as identifier:" +++ c) + else return () + +-- to normalize records and record types +labelIndex :: Type -> Label -> Int +labelIndex ty lab = case ty of + RecType ts -> maybe (error ("label index" +++ prt lab)) id $ lookup lab $ labs ts + _ -> error $ "label index" +++ prt ty + where + labs ts = zip (map fst (sortRec ts)) [0..] + +-- the underlying algorithms + +inferLType :: SourceGrammar -> Term -> Check (Term, Type) +inferLType gr trm = case trm of + + Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) + + Q m ident -> checks [ + termWith trm $ checkErr (lookupResType gr m ident) >>= comp + , + checkErr (lookupResDef gr m ident) >>= infer + , + prtFail "cannot infer type of constant" trm + ] + + QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) + + QC m ident -> checks [ + termWith trm $ checkErr (lookupResType gr m ident) >>= comp + , + checkErr (lookupResDef gr m ident) >>= infer + , + prtFail "cannot infer type of canonical constant" trm + ] + + Val ty i -> termWith trm $ return ty + + Vr ident -> termWith trm $ checkLookup ident + + Typed e t -> do + t' <- comp t + check e t' + return (e,t') + + App f a -> do + over <- getOverload gr Nothing trm + case over of + Just trty -> return trty + _ -> do + (f',fty) <- infer f + fty' <- comp fty + case fty' of + Prod z arg val -> do + a' <- justCheck a arg + ty <- if isWildIdent z + then return val + else substituteLType [(z,a')] val + return (App f' a',ty) + _ -> raise ("function type expected for"+++ + prt f +++"instead of" +++ prtType env fty) + + S f x -> do + (f', fty) <- infer f + case fty of + Table arg val -> do + x'<- justCheck x arg + return (S f' x', val) + _ -> prtFail "table lintype expected for the table in" trm + + P t i -> do + (t',ty) <- infer t --- ?? + ty' <- comp ty +----- let tr2 = PI t' i (labelIndex ty' i) + let tr2 = P t' i + termWith tr2 $ checkErr $ case ty' of + RecType ts -> maybeErr ("unknown label" +++ prt i +++ "in" +++ prt ty') $ + lookup i ts + _ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty' + PI t i _ -> infer $ P t i + + R r -> do + let (ls,fs) = unzip r + fsts <- mapM inferM fs + let ts = [ty | (Just ty,_) <- fsts] + checkCond ("cannot infer type of record"+++ prt trm) (length ts == length fsts) + return $ (R (zip ls fsts), RecType (zip ls ts)) + + T (TTyped arg) pts -> do + (_,val) <- checks $ map (inferCase (Just arg)) pts + check trm (Table arg val) + T (TComp arg) pts -> do + (_,val) <- checks $ map (inferCase (Just arg)) pts + check trm (Table arg val) + T ti pts -> do -- tries to guess: good in oper type inference + let pts' = [pt | pt@(p,_) <- pts, isConstPatt p] + case pts' of + [] -> prtFail "cannot infer table type of" trm +---- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] + _ -> do + (arg,val) <- checks $ map (inferCase Nothing) pts' + check trm (Table arg val) + V arg pts -> do + (_,val) <- checks $ map infer pts + return (trm, Table arg val) + + K s -> do + if elem ' ' s + then do + let ss = foldr C Empty (map K (words s)) + ----- removed irritating warning AR 24/5/2008 + ----- checkWarn ("WARNING: token \"" ++ s ++ + ----- "\" converted to token list" ++ prt ss) + return (ss, typeStr) + else return (trm, typeStr) + + EInt i -> return (trm, typeInt) + + EFloat i -> return (trm, typeFloat) + + Empty -> return (trm, typeStr) + + C s1 s2 -> + check2 (flip justCheck typeStr) C s1 s2 typeStr + + Glue s1 s2 -> + check2 (flip justCheck typeStr) Glue s1 s2 typeStr ---- typeTok + +---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 + Strs (Cn c : ts) | c == cConflict -> do + trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts) +-- checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) +-- infer $ head ts + + Strs ts -> do + ts' <- mapM (\t -> justCheck t typeStr) ts + return (Strs ts', typeStrs) + + Alts (t,aa) -> do + t' <- justCheck t typeStr + aa' <- flip mapM aa (\ (c,v) -> do + c' <- justCheck c typeStr + v' <- justCheck v typeStrs + return (c',v')) + return (Alts (t',aa'), typeStr) + + RecType r -> do + let (ls,ts) = unzip r + ts' <- mapM (flip justCheck typeType) ts + return (RecType (zip ls ts'), typeType) + + ExtR r s -> do + (r',rT) <- infer r + rT' <- comp rT + (s',sT) <- infer s + sT' <- comp sT + + let trm' = ExtR r' s' + ---- trm' <- checkErr $ plusRecord r' s' + case (rT', sT') of + (RecType rs, RecType ss) -> do + rt <- checkErr $ plusRecType rT' sT' + check trm' rt ---- return (trm', rt) + _ | rT' == typeType && sT' == typeType -> return (trm', typeType) + _ -> prtFail "records or record types expected in" trm + + Sort _ -> + termWith trm $ return typeType + + Prod x a b -> do + a' <- justCheck a typeType + b' <- checkInContext [(x,a')] $ justCheck b typeType + return (Prod x a' b', typeType) + + Table p t -> do + p' <- justCheck p typeType --- check p partype! + t' <- justCheck t typeType + return $ (Table p' t', typeType) + + FV vs -> do + (_,ty) <- checks $ map infer vs +--- checkIfComplexVariantType trm ty + check trm ty + + EPattType ty -> do + ty' <- justCheck ty typeType + return (ty',typeType) + EPatt p -> do + ty <- inferPatt p + return (trm, EPattType ty) + + _ -> prtFail "cannot infer lintype of" trm + + where + env = gr + infer = inferLType env + comp = computeLType env + + check = checkLType env + + isPredef m = elem m [cPredef,cPredefAbs] + + justCheck ty te = check ty te >>= return . fst + + -- for record fields, which may be typed + inferM (mty, t) = do + (t', ty') <- case mty of + Just ty -> check ty t + _ -> infer t + return (Just ty',t') + + inferCase mty (patt,term) = do + arg <- maybe (inferPatt patt) return mty + cont <- pattContext env arg patt + i <- checkUpdates cont + (_,val) <- infer term + checkResets i + return (arg,val) + isConstPatt p = case p of + PC _ ps -> True --- all isConstPatt ps + PP _ _ ps -> True --- all isConstPatt ps + PR ps -> all (isConstPatt . snd) ps + PT _ p -> isConstPatt p + PString _ -> True + PInt _ -> True + PFloat _ -> True + PChar -> True + PChars _ -> True + PSeq p q -> isConstPatt p && isConstPatt q + PAlt p q -> isConstPatt p && isConstPatt q + PRep p -> isConstPatt p + PNeg p -> isConstPatt p + PAs _ p -> isConstPatt p + _ -> False + + inferPatt p = case p of + PP q c ps | q /= cPredef -> checkErr $ lookupResType gr q c >>= valTypeCnc + PAs _ p -> inferPatt p + PNeg p -> inferPatt p + PAlt p q -> checks [inferPatt p, inferPatt q] + PSeq _ _ -> return $ typeStr + PRep _ -> return $ typeStr + PChar -> return $ typeStr + PChars _ -> return $ typeStr + _ -> infer (patt2term p) >>= return . snd + + +-- type inference: Nothing, type checking: Just t +-- the latter permits matching with value type +getOverload :: SourceGrammar -> Maybe Type -> Term -> Check (Maybe (Term,Type)) +getOverload env@gr mt ot = case appForm ot of + (f@(Q m c), ts) -> case lookupOverload gr m c of + Ok typs -> do + ttys <- mapM infer ts + v <- matchOverload f typs ttys + return $ Just v + _ -> return Nothing + _ -> return Nothing + where + infer = inferLType env + matchOverload f typs ttys = do + let (tts,tys) = unzip ttys + let vfs = lookupOverloadInstance tys typs + let matches = [vf | vf@((v,_),_) <- vfs, matchVal mt v] + + case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of + ([(val,fun)],_) -> return (mkApp fun tts, val) + ([],[(val,fun)]) -> do + checkWarn ("ignoring lock fields in resolving" +++ prt ot) + return (mkApp fun tts, val) + ([],[]) -> do + raise $ "no overload instance of" +++ prt f +++ + "for" +++ unwords (map (prtType env) tys) +++ "among" ++++ + unlines [" " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++ + maybe [] (("with value type" +++) . prtType env) mt + + (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of + ([(val,fun)],_) -> do + return (mkApp fun tts, val) + ([],[(val,fun)]) -> do + checkWarn ("ignoring lock fields in resolving" +++ prt ot) + return (mkApp fun tts, val) + +----- unsafely exclude irritating warning AR 24/5/2008 +----- checkWarn $ "WARNING: overloading of" +++ prt f +++ +----- "resolved by excluding partial applications:" ++++ +----- unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] + + + _ -> raise $ "ambiguous overloading of" +++ prt f +++ + "for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++ + unlines [prtType env ty | (ty,_) <- if (null vfs1) then vfs2 else vfs2] + + matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)] + + unlocked v = case v of + RecType fs -> RecType $ filter (not . isLockLabel . fst) fs + _ -> v + ---- TODO: accept subtypes + ---- TODO: use a trie + lookupOverloadInstance tys typs = + [((mkFunType rest val, t),isExact) | + let lt = length tys, + (ty,(val,t)) <- typs, length ty >= lt, + let (pre,rest) = splitAt lt ty, + let isExact = pre == tys, + isExact || map unlocked pre == map unlocked tys + ] + + noProds vfs = [(v,f) | (v,f) <- vfs, noProd v] + + noProd ty = case ty of + Prod _ _ _ -> False + _ -> True + +checkLType :: SourceGrammar -> Term -> Type -> Check (Term, Type) +checkLType env trm typ0 = do + + typ <- comp typ0 + + case trm of + + Abs x c -> do + case typ of + Prod z a b -> do + checkUpdate (x,a) + (c',b') <- if isWildIdent z + then check c b + else do + b' <- checkIn "abs" $ substituteLType [(z,Vr x)] b + check c b' + checkReset + return $ (Abs x c', Prod x a b') + _ -> raise $ "product expected instead of" +++ prtType env typ + + App f a -> do + over <- getOverload env (Just typ) trm + case over of + Just trty -> return trty + _ -> do + (trm',ty') <- infer trm + termWith trm' $ checkEq typ ty' trm' + + Q _ _ -> do + over <- getOverload env (Just typ) trm + case over of + Just trty -> return trty + _ -> do + (trm',ty') <- infer trm + termWith trm' $ checkEq typ ty' trm' + + T _ [] -> + prtFail "found empty table in type" typ + T _ cs -> case typ of + Table arg val -> do + case allParamValues env arg of + Ok vs -> do + let ps0 = map fst cs + ps <- checkErr $ testOvershadow ps0 vs + if null ps + then return () + else checkWarn $ "WARNING: patterns never reached:" +++ + concat (intersperse ", " (map prt ps)) + + _ -> return () -- happens with variable types + cs' <- mapM (checkCase arg val) cs + return (T (TTyped arg) cs', typ) + _ -> raise $ "table type expected for table instead of" +++ prtType env typ + + R r -> case typ of --- why needed? because inference may be too difficult + RecType rr -> do + let (ls,_) = unzip rr -- labels of expected type + fsts <- mapM (checkM r) rr -- check that they are found in the record + return $ (R fsts, typ) -- normalize record + + _ -> prtFail "record type expected in type checking instead of" typ + + ExtR r s -> case typ of + _ | typ == typeType -> do + trm' <- comp trm + case trm' of + RecType _ -> termWith trm $ return typeType + ExtR (Vr _) (RecType _) -> termWith trm $ return typeType + -- ext t = t ** ... + _ -> prtFail "invalid record type extension" trm + RecType rr -> do + (r',ty,s') <- checks [ + do (r',ty) <- infer r + return (r',ty,s) + , + do (s',ty) <- infer s + return (s',ty,r) + ] + case ty of + RecType rr1 -> do + let (rr0,rr2) = recParts rr rr1 + r2 <- justCheck r' rr0 + s2 <- justCheck s' rr2 + return $ (ExtR r2 s2, typ) + _ -> raise ("record type expected in extension of" +++ prt r +++ + "but found" +++ prt ty) + + ExtR ty ex -> do + r' <- justCheck r ty + s' <- justCheck s ex + return $ (ExtR r' s', typ) --- is this all? + + _ -> prtFail "record extension not meaningful for" typ + + FV vs -> do + ttys <- mapM (flip check typ) vs +--- checkIfComplexVariantType trm typ + return (FV (map fst ttys), typ) --- typ' ? + + S tab arg -> checks [ do + (tab',ty) <- infer tab + ty' <- comp ty + case ty' of + Table p t -> do + (arg',val) <- check arg p + checkEq typ t trm + return (S tab' arg', t) + _ -> raise $ "table type expected for applied table instead of" +++ + prtType env ty' + , do + (arg',ty) <- infer arg + ty' <- comp ty + (tab',_) <- check tab (Table ty' typ) + return (S tab' arg', typ) + ] + Let (x,(mty,def)) body -> case mty of + Just ty -> do + (def',ty') <- check def ty + checkUpdate (x,ty') + body' <- justCheck body typ + checkReset + return (Let (x,(Just ty',def')) body', typ) + _ -> do + (def',ty) <- infer def -- tries to infer type of local constant + check (Let (x,(Just ty,def')) body) typ + + _ -> do + (trm',ty') <- infer trm + termWith trm' $ checkEq typ ty' trm' + where + cnc = env + infer = inferLType env + comp = computeLType env + + check = checkLType env + + justCheck ty te = check ty te >>= return . fst + + checkEq = checkEqLType env + + recParts rr t = (RecType rr1,RecType rr2) where + (rr1,rr2) = partition (flip elem (map fst t) . fst) rr + + checkM rms (l,ty) = case lookup l rms of + Just (Just ty0,t) -> do + checkEq ty ty0 t + (t',ty') <- check t ty + return (l,(Just ty',t')) + Just (_,t) -> do + (t',ty') <- check t ty + return (l,(Just ty',t')) + _ -> prtFail "cannot find value for label" l + + checkCase arg val (p,t) = do + cont <- pattContext env arg p + i <- checkUpdates cont + t' <- justCheck t val + checkResets i + return (p,t') + +pattContext :: LTEnv -> Type -> Patt -> Check Context +pattContext env typ p = case p of + PV x | not (isWildIdent x) -> return [(x,typ)] + PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 + t <- checkErr $ lookupResType cnc q c + (cont,v) <- checkErr $ typeFormCnc t + checkCond ("wrong number of arguments for constructor in" +++ prt p) + (length cont == length ps) + checkEqLType env typ v (patt2term p) + mapM (uncurry (pattContext env)) (zip (map snd cont) ps) >>= return . concat + PR r -> do + typ' <- computeLType env typ + case typ' of + RecType t -> do + let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]] + ----- checkWarn $ prt p ++++ show pts ----- debug + mapM (uncurry (pattContext env)) pts >>= return . concat + _ -> prtFail "record type expected for pattern instead of" typ' + PT t p' -> do + checkEqLType env typ t (patt2term p') + pattContext env typ p' + + PAs x p -> do + g <- pattContext env typ p + return $ (x,typ):g + + PAlt p' q -> do + g1 <- pattContext env typ p' + g2 <- pattContext env typ q + let pts = [pt | pt <- g1, notElem pt g2] ++ [pt | pt <- g2, notElem pt g1] + checkCond + ("incompatible bindings of" +++ + unwords (nub (map (prt . fst) pts))+++ + "in pattern alterantives" +++ prt p) (null pts) + return g1 -- must be g1 == g2 + PSeq p q -> do + g1 <- pattContext env typ p + g2 <- pattContext env typ q + return $ g1 ++ g2 + PRep p' -> noBind typeStr p' + PNeg p' -> noBind typ p' + + _ -> return [] ---- check types! + where + cnc = env + noBind typ p' = do + co <- pattContext env typ p' + if not (null co) + then checkWarn ("no variable bound inside pattern" +++ prt p) + >> return [] + else return [] + +-- auxiliaries + +type LTEnv = SourceGrammar + +termWith :: Term -> Check Type -> Check (Term, Type) +termWith t ct = do + ty <- ct + return (t,ty) + +-- | light-weight substitution for dep. types +substituteLType :: Context -> Type -> Check Type +substituteLType g t = case t of + Vr x -> return $ maybe t id $ lookup x g + _ -> composOp (substituteLType g) t + +-- | compositional check\/infer of binary operations +check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> + Term -> Term -> Type -> Check (Term,Type) +check2 chk con a b t = do + a' <- chk a + b' <- chk b + return (con a' b', t) + +checkEqLType :: LTEnv -> Type -> Type -> Term -> Check Type +checkEqLType env t u trm = do + (b,t',u',s) <- checkIfEqLType env t u trm + case b of + True -> return t' + False -> raise $ s +++ "type of" +++ prt trm +++ + ": expected:" +++ prtType env t ++++ + "inferred:" +++ prtType env u + +checkIfEqLType :: LTEnv -> Type -> Type -> Term -> Check (Bool,Type,Type,String) +checkIfEqLType env t u trm = do + t' <- comp t + u' <- comp u + case t' == u' || alpha [] t' u' of + True -> return (True,t',u',[]) + -- forgive missing lock fields by only generating a warning. + --- better: use a flag to forgive? (AR 31/1/2006) + _ -> case missingLock [] t' u' of + Ok lo -> do + checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo) + return (True,t',u',[]) + Bad s -> return (False,t',u',s) + + where + + -- t is a subtype of u + --- quick hack version of TC.eqVal + alpha g t u = case (t,u) of + + -- error (the empty type!) is subtype of any other type + (_,u) | u == typeError -> True + + -- contravariance + (Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d + + -- record subtyping + (RecType rs, RecType ts) -> all (\ (l,a) -> + any (\ (k,b) -> alpha g a b && l == k) ts) rs + (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s' + (ExtR r s, t) -> alpha g r t || alpha g s t + + -- the following say that Ints n is a subset of Int and of Ints m >= n + (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts t -> m >= n + | Just _ <- isTypeInts t, u == typeInt -> True ---- check size! + | t == typeInt, Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005 + + ---- this should be made in Rename + (Q m a, Q n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + || m == n --- for Predef + (QC m a, QC n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + (QC m a, Q n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + (Q m a, QC n b) | a == b -> elem m (allExtendsPlus env n) + || elem n (allExtendsPlus env m) + + (Table a b, Table c d) -> alpha g a c && alpha g b d + (Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g + _ -> t == u + --- the following should be one-way coercions only. AR 4/1/2001 + || elem t sTypes && elem u sTypes + || (t == typeType && u == typePType) + || (u == typeType && t == typePType) + + missingLock g t u = case (t,u) of + (RecType rs, RecType ts) -> + let + ls = [l | (l,a) <- rs, + not (any (\ (k,b) -> alpha g a b && l == k) ts)] + (locks,others) = partition isLockLabel ls + in case others of + _:_ -> Bad $ "missing record fields" +++ unwords (map prt others) + _ -> return locks + -- contravariance + (Prod x a b, Prod y c d) -> do + ls1 <- missingLock g c a + ls2 <- missingLock g b d + return $ ls1 ++ ls2 + + _ -> Bad "" + + sTypes = [typeStr, typeTok, typeString] + comp = computeLType env + +-- printing a type with a lock field lock_C as C +prtType :: LTEnv -> Type -> String +prtType env ty = case ty of + RecType fs -> case filter isLockLabel $ map fst fs of + [lock] -> (drop 5 $ prt lock) --- ++++ "Full form" +++ prt ty + _ -> prtt ty + Prod x a b -> prtType env a +++ "->" +++ prtType env b + _ -> prtt ty + where + prtt t = prt t + ---- use computeLType gr to check if really equal to the cat with lock + + +-- | linearization types and defaults +linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type) +linTypeOfType cnc m typ = do + (cont,cat) <- checkErr $ typeSkeleton typ + val <- lookLin cat + args <- mapM mkLinArg (zip [0..] cont) + return (args, val) + where + mkLinArg (i,(n,mc@(m,cat))) = do + val <- lookLin mc + let vars = mkRecType varLabel $ replicate n typeStr + symb = argIdent n cat i + rec <- if n==0 then return val else + checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $ + plusRecType vars val + return (symb,rec) + lookLin (_,c) = checks [ --- rather: update with defLinType ? + checkErr (lookupLincat cnc m c) >>= computeLType cnc + ,return defLinType + ] + +-- | dependency check, detecting circularities and returning topo-sorted list + +allOperDependencies :: Ident -> BinTree Ident Info -> [(Ident,[Ident])] +allOperDependencies m = allDependencies (==m) + +allDependencies :: (Ident -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])] +allDependencies ism b = + [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b] + where + opersIn t = case t of + Q n c | ism n -> [c] + QC n c | ism n -> [c] + _ -> collectOp opersIn t + opty (Yes ty) = opersIn ty + opty _ = [] + pts i = case i of + ResOper pty pt -> [pty,pt] + ResParam (Yes (ps,_)) -> [Yes t | (_,cont) <- ps, (_,t) <- cont] + CncCat pty _ _ -> [pty] + CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) + AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual + AbsCat (Yes co) _ -> [Yes ty | (_,ty) <- co] + _ -> [] + +topoSortOpers :: [(Ident,[Ident])] -> Err [Ident] +topoSortOpers st = do + let eops = topoTest st + either + return + (\ops -> Bad ("circular definitions:" +++ unwords (map prt (head ops)))) + eops diff --git a/src/GF/Compile/Compute.hs b/src/GF/Compile/Compute.hs new file mode 100644 index 000000000..f35e7c6a9 --- /dev/null +++ b/src/GF/Compile/Compute.hs @@ -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 + + + diff --git a/src/GF/Compile/Export.hs b/src/GF/Compile/Export.hs new file mode 100644 index 000000000..9e9a99e99 --- /dev/null +++ b/src/GF/Compile/Export.hs @@ -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 diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs new file mode 100644 index 000000000..8344a1696 --- /dev/null +++ b/src/GF/Compile/Extend.hs @@ -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 +-} diff --git a/src/GF/Compile/GFCCtoHaskell.hs b/src/GF/Compile/GFCCtoHaskell.hs new file mode 100644 index 000000000..59db9c364 --- /dev/null +++ b/src/GF/Compile/GFCCtoHaskell.hs @@ -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 diff --git a/src/GF/Compile/GFCCtoJS.hs b/src/GF/Compile/GFCCtoJS.hs new file mode 100644 index 000000000..8259e7385 --- /dev/null +++ b/src/GF/Compile/GFCCtoJS.hs @@ -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 diff --git a/src/GF/Compile/GenerateFCFG.hs b/src/GF/Compile/GenerateFCFG.hs new file mode 100644 index 000000000..c2854ef3d --- /dev/null +++ b/src/GF/Compile/GenerateFCFG.hs @@ -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 diff --git a/src/GF/Compile/GeneratePMCFG.hs b/src/GF/Compile/GeneratePMCFG.hs new file mode 100644 index 000000000..e0343e8d6 --- /dev/null +++ b/src/GF/Compile/GeneratePMCFG.hs @@ -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) diff --git a/src/GF/Compile/GetGrammar.hs b/src/GF/Compile/GetGrammar.hs new file mode 100644 index 000000000..a8eb8b749 --- /dev/null +++ b/src/GF/Compile/GetGrammar.hs @@ -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 diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs new file mode 100644 index 000000000..d14a914f1 --- /dev/null +++ b/src/GF/Compile/GrammarToGFCC.hs @@ -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 diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs new file mode 100644 index 000000000..b5b1b798c --- /dev/null +++ b/src/GF/Compile/ModDeps.hs @@ -0,0 +1,153 @@ +---------------------------------------------------------------------- +-- | +-- Module : ModDeps +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/11 23:24:34 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.14 $ +-- +-- Check correctness of module dependencies. Incomplete. +-- +-- AR 13\/5\/2003 +----------------------------------------------------------------------------- + +module GF.Compile.ModDeps (mkSourceGrammar, + moduleDeps, + openInterfaces, + requiredCanModules + ) where + +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Infra.Option +import GF.Grammar.PrGrammar +import GF.Compile.Update +import GF.Grammar.Lookup +import GF.Infra.Modules + +import GF.Data.Operations + +import Control.Monad +import Data.List + +-- | to check uniqueness of module names and import names, the +-- appropriateness of import and extend types, +-- to build a dependency graph of modules, and to sort them topologically +mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar +mkSourceGrammar ms = do + let ns = map fst ms + checkUniqueErr ns + mapM (checkUniqueImportNames ns . snd) ms + deps <- moduleDeps ms + deplist <- either + return + (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ + topoTest deps + return $ MGrammar [(m, maybe undefined id $ lookup m ms) | IdentM m _ <- deplist] + +checkUniqueErr :: (Show i, Eq i) => [i] -> Err () +checkUniqueErr ms = do + let msg = checkUnique ms + if null msg then return () else Bad $ unlines msg + +-- | check that import names don't clash with module names +checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err () +checkUniqueImportNames ns mo = case mo of + ModMod m -> test [n | OQualif _ n v <- opens m, n /= v] + _ -> return () --- Bad $ "bug: ModDeps does not treat" +++ show mo + where + + test ms = testErr (all (`notElem` ns) ms) + ("import names clashing with module names among" +++ + unwords (map prt ms)) + +type Dependencies = [(IdentM Ident,[IdentM Ident])] + +-- | to decide what modules immediately depend on what, and check if the +-- dependencies are appropriate +moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies +moduleDeps ms = mapM deps ms where + deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of + ModMod m -> case mtype m of + MTConcrete a -> do + aty <- lookupModuleType gr a + testErr (aty == MTAbstract) "the of-module is not an abstract syntax" + chDep (IdentM c (MTConcrete a)) + (extends m) (MTConcrete a) (opens m) MTResource + t -> chDep (IdentM c t) (extends m) t (opens m) t + + chDep it es ety os oty = do + ests <- mapM (lookupModuleType gr) es + testErr (all (compatMType ety) ests) "inappropriate extension module type" +---- osts <- mapM (lookupModuleType gr . openedModule) os +---- testErr (all (compatOType oty) osts) "inappropriate open module type" + let ab = case it of + IdentM _ (MTConcrete a) -> [IdentM a MTAbstract] + _ -> [] ---- + return (it, ab ++ + [IdentM e ety | e <- es] ++ + [IdentM (openedModule o) oty | o <- os]) + + -- check for superficial compatibility, not submodule relation etc: what can be extended + compatMType mt0 mt = case (mt0,mt) of + (MTResource, MTConcrete _) -> True + (MTInstance _, MTConcrete _) -> True + (MTInterface, MTAbstract) -> True + (MTConcrete _, MTConcrete _) -> True + (MTInstance _, MTInstance _) -> True + (MTReuse _, MTReuse _) -> True + (MTInstance _, MTResource) -> True + (MTResource, MTInstance _) -> True + ---- some more? + _ -> mt0 == mt + -- in the same way; this defines what can be opened + compatOType mt0 mt = case mt0 of + MTAbstract -> mt == MTAbstract + MTTransfer _ _ -> mt == MTAbstract + _ -> case mt of + MTResource -> True + MTReuse _ -> True + MTInterface -> True + MTInstance _ -> True + _ -> False + + gr = MGrammar ms --- hack + +openInterfaces :: Dependencies -> Ident -> Err [Ident] +openInterfaces ds m = do + let deps = [(i,ds) | (IdentM i _,ds) <- ds] + let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is] + let mods = iterFix (concatMap more) (more (m,undefined)) + return $ [i | (i,MTInterface) <- mods] + +-- | this function finds out what modules are really needed in the canonical gr. +-- its argument is typically a concrete module name +requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i 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 +-} + diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs new file mode 100644 index 000000000..83cbeb57a --- /dev/null +++ b/src/GF/Compile/Optimize.hs @@ -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 + diff --git a/src/GF/Compile/OptimizeGF.hs b/src/GF/Compile/OptimizeGF.hs new file mode 100644 index 000000000..41b828aa3 --- /dev/null +++ b/src/GF/Compile/OptimizeGF.hs @@ -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''") diff --git a/src/GF/Compile/OptimizeGFCC.hs b/src/GF/Compile/OptimizeGFCC.hs new file mode 100644 index 000000000..c73d5bbcb --- /dev/null +++ b/src/GF/Compile/OptimizeGFCC.hs @@ -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) + diff --git a/src/GF/Compile/ReadFiles.hs b/src/GF/Compile/ReadFiles.hs new file mode 100644 index 000000000..cd2faec15 --- /dev/null +++ b/src/GF/Compile/ReadFiles.hs @@ -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 diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs new file mode 100644 index 000000000..ec9076e1c --- /dev/null +++ b/src/GF/Compile/Rebuild.hs @@ -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):) + diff --git a/src/GF/Compile/Refresh.hs b/src/GF/Compile/Refresh.hs new file mode 100644 index 000000000..39fb57db0 --- /dev/null +++ b/src/GF/Compile/Refresh.hs @@ -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) + diff --git a/src/GF/Compile/RemoveLiT.hs b/src/GF/Compile/RemoveLiT.hs new file mode 100644 index 000000000..d06b80400 --- /dev/null +++ b/src/GF/Compile/RemoveLiT.hs @@ -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 diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs new file mode 100644 index 000000000..7b4d09277 --- /dev/null +++ b/src/GF/Compile/Rename.hs @@ -0,0 +1,338 @@ +---------------------------------------------------------------------- +-- | +-- Module : Rename +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/30 18:39:44 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.19 $ +-- +-- AR 14\/5\/2003 +-- The top-level function 'renameGrammar' does several things: +-- +-- - extends each module symbol table by indirections to extended module +-- +-- - changes unqualified and as-qualified imports to absolutely qualified +-- +-- - goes through the definitions and resolves names +-- +-- Dependency analysis between modules has been performed before this pass. +-- Hence we can proceed by @fold@ing "from left to right". +----------------------------------------------------------------------------- + +module GF.Compile.Rename (renameGrammar, + renameSourceTerm, + renameModule + ) where + +import GF.Grammar.Grammar +import GF.Grammar.Values +import GF.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') diff --git a/src/GF/Compile/TC.hs b/src/GF/Compile/TC.hs new file mode 100644 index 000000000..c0c8a83ae --- /dev/null +++ b/src/GF/Compile/TC.hs @@ -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) + diff --git a/src/GF/Compile/TypeCheck.hs b/src/GF/Compile/TypeCheck.hs new file mode 100644 index 000000000..2d58a33ee --- /dev/null +++ b/src/GF/Compile/TypeCheck.hs @@ -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! diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs new file mode 100644 index 000000000..82d7a609e --- /dev/null +++ b/src/GF/Compile/Update.hs @@ -0,0 +1,135 @@ +---------------------------------------------------------------------- +-- | +-- Module : Update +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/30 18:39:44 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.8 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Compile.Update (updateRes, buildAnyTree, combineAnyInfos, unifyAnyInfo, + -- * these auxiliaries should be somewhere else + -- since they don't use the info types + groupInfos, sortInfos, combineInfos, unifyInfos, + tryInsert, unifAbsDefs, unifConstrs + ) where + +import GF.Infra.Ident +import GF.Grammar.Grammar +import GF.Grammar.PrGrammar +import GF.Infra.Modules + +import GF.Data.Operations + +import Data.List +import Control.Monad + +-- | update a resource module by adding a new or changing an old definition +updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar +updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where + upd (n,mod) + | n /= m = (n,mod) + | n == m = case mod of + ModMod r -> (m,ModMod $ updateModule r i info) + _ -> (n,mod) --- no error msg + +-- | combine a list of definitions into a balanced binary search tree +buildAnyTree :: [(Ident,Info)] -> Err (BinTree Ident Info) +buildAnyTree ias = do + ias' <- combineAnyInfos ias + return $ buildTree ias' + + +-- | unifying information for abstract, resource, and concrete +combineAnyInfos :: [(Ident,Info)] -> Err [(Ident,Info)] +combineAnyInfos = combineInfos unifyAnyInfo + +unifyAnyInfo :: Ident -> Info -> Info -> Err Info +unifyAnyInfo c i j = errIn ("combining information for" +++ prt c) $ case (i,j) of + (AbsCat mc1 mf1, AbsCat mc2 mf2) -> + liftM2 AbsCat (unifPerhaps mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs + (AbsFun mt1 md1, AbsFun mt2 md2) -> + liftM2 AbsFun (unifPerhaps mt1 mt2) (unifAbsDefs md1 md2) -- adding defs + + (ResParam mt1, ResParam mt2) -> liftM ResParam $ unifPerhaps mt1 mt2 + (ResOper mt1 m1, ResOper mt2 m2) -> + liftM2 ResOper (unifPerhaps mt1 mt2) (unifPerhaps m1 m2) + + (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> + liftM3 CncCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) (unifPerhaps mp1 mp2) + (CncFun m mt1 md1, CncFun _ mt2 md2) -> + liftM2 (CncFun m) (unifPerhaps mt1 mt2) (unifPerhaps md1 md2) ---- adding defs +-- for bw compatibility with unspecified printnames in old GF + (CncFun Nothing Nope (Yes pr),_) -> + unifyAnyInfo c (CncCat Nope Nope (Yes pr)) j + (_,CncFun Nothing Nope (Yes pr)) -> + unifyAnyInfo c i (CncCat Nope Nope (Yes pr)) + + _ -> Bad $ "cannot unify informations in" ++++ show i ++++ "and" ++++ show j + +--- these auxiliaries should be somewhere else since they don't use the info types + +groupInfos :: Eq a => [(a,b)] -> [[(a,b)]] +groupInfos = groupBy (\i j -> fst i == fst j) + +sortInfos :: Ord a => [(a,b)] -> [(a,b)] +sortInfos = sortBy (\i j -> compare (fst i) (fst j)) + +combineInfos :: Ord a => (a -> b -> b -> Err b) -> [(a,b)] -> Err [(a,b)] +combineInfos f ris = do + let riss = groupInfos $ sortInfos ris + mapM (unifyInfos f) riss + +unifyInfos :: (a -> b -> b -> Err b) -> [(a,b)] -> Err (a,b) +unifyInfos _ [] = Bad "empty info list" +unifyInfos unif ris = do + let c = fst $ head ris + let infos = map snd ris + let ([i],is) = splitAt 1 infos + info <- foldM (unif c) i is + return (c,info) + + +tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) -> + BinTree a b -> (a,b) -> Err (BinTree a b) +tryInsert unif indir tree z@(x, info) = case justLookupTree x tree of + Ok info0 -> do + info1 <- unif info info0 + return $ updateTree (x,info1) tree + _ -> return $ updateTree (x,indir info) tree + +{- ---- +case tree of + NT -> return $ BT (x, indir info) NT NT + BT c@(a,info0) left right + | x < a -> do + left' <- tryInsert unif indir left z + return $ BT c left' right + | x > a -> do + right' <- tryInsert unif indir right z + return $ BT c left right' + | x == a -> do + info' <- unif info info0 + return $ BT (x,info') left right +-} + +--- addToMaybeList m c = maybe (return c) (\old -> return (c ++ old)) m + +unifAbsDefs :: Perh Term -> Perh Term -> Err (Perh Term) +unifAbsDefs p1 p2 = case (p1,p2) of + (Nope, _) -> return p2 + (_, Nope) -> return p1 + (Yes (Eqs bs), Yes (Eqs ds)) -> return $ yes $ Eqs $ bs ++ ds --- order! + _ -> Bad "update conflict for definitions" + +unifConstrs :: Perh [Term] -> Perh [Term] -> Err (Perh [Term]) +unifConstrs p1 p2 = case (p1,p2) of + (Nope, _) -> return p2 + (_, Nope) -> return p1 + (Yes bs, Yes ds) -> return $ yes $ bs ++ ds + _ -> Bad "update conflict for constructors" diff --git a/src/GF/Data/Assoc.hs b/src/GF/Data/Assoc.hs new file mode 100644 index 000000000..f775319ea --- /dev/null +++ b/src/GF/Data/Assoc.hs @@ -0,0 +1,143 @@ +---------------------------------------------------------------------- +-- | +-- Module : Assoc +-- Maintainer : Peter Ljunglöf +-- Stability : Stable +-- Portability : Haskell 98 +-- +-- > CVS $Date: 2005/05/09 09:28:44 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.4 $ +-- +-- Association lists, or finite maps, +-- including sets as maps with result type @()@. +-- function names stolen from module @Array@. +-- /O(log n)/ key lookup +----------------------------------------------------------------------------- + +module GF.Data.Assoc ( Assoc, + Set, + emptyAssoc, + emptySet, + listAssoc, + listSet, + accumAssoc, + aAssocs, + aElems, + assocMap, + assocFilter, + lookupAssoc, + lookupWith, + (?), + (?=) + ) where + +import GF.Data.SortedList + +infixl 9 ?, ?= + +-- | a set is a finite map with empty values +type Set a = Assoc a () + +emptyAssoc :: Ord a => Assoc a b +emptySet :: Ord a => Set a + +-- | creating a finite map from a sorted key-value list +listAssoc :: Ord a => SList (a, b) -> Assoc a b + +-- | creating a set from a sorted list +listSet :: Ord a => SList a -> Set a + +-- | building a finite map from a list of keys and 'b's, +-- and a function that combines a sorted list of 'b's into a value +accumAssoc :: (Ord a, Ord c) => (SList c -> b) -> [(a, c)] -> Assoc a b + +-- | all key-value pairs from an association list +aAssocs :: Ord a => Assoc a b -> SList (a, b) + +-- | all keys from an association list +aElems :: Ord a => Assoc a b -> SList a + +-- fmap :: Ord a => (b -> b') -> Assoc a b -> Assoc a b' + +-- | mapping values to other values. +-- the mapping function can take the key as information +assocMap :: Ord a => (a -> b -> b') -> Assoc a b -> Assoc a b' + +assocFilter :: Ord a => (b -> Bool) -> Assoc a b -> Assoc a b +assocFilter pred = listAssoc . filter (pred . snd) . aAssocs + +-- | monadic lookup function, +-- returning failure if the key does not exist +lookupAssoc :: (Ord a, Monad m) => Assoc a b -> a -> m b + +-- | if the key does not exist, +-- the first argument is returned +lookupWith :: Ord a => b -> Assoc a b -> a -> b + +-- | if the values are monadic, we can return the value type +(?) :: (Ord a, Monad m) => Assoc a (m b) -> a -> m b + +-- | checking wheter the map contains a given key +(?=) :: Ord a => Assoc a b -> a -> Bool + + +------------------------------------------------------------ + +data Assoc a b = ANil | ANode (Assoc a b) a b (Assoc a b) + deriving (Eq, Ord, Show) + +emptyAssoc = ANil +emptySet = emptyAssoc + +listAssoc as = assoc + where (assoc, []) = sl2bst (length as) as + sl2bst 0 xs = (ANil, xs) + sl2bst 1 (x:xs) = (ANode ANil (fst x) (snd x) ANil, xs) + sl2bst n xs = (ANode left (fst x) (snd x) right, zs) + where llen = (n-1) `div` 2 + rlen = n - 1 - llen + (left, x:ys) = sl2bst llen xs + (right, zs) = sl2bst rlen ys + +listSet as = listAssoc (zip as (repeat ())) + +accumAssoc join = listAssoc . map (mapSnd join) . groupPairs . nubsort + where mapSnd f (a, b) = (a, f b) + +aAssocs as = prs as [] + where prs ANil = id + prs (ANode left a b right) = prs left . ((a,b) :) . prs right + +aElems = map fst . aAssocs + + +instance Ord a => Functor (Assoc a) where + fmap f = assocMap (const f) + +assocMap f ANil = ANil +assocMap f (ANode left a b right) = ANode (assocMap f left) a (f a b) (assocMap f right) + + +lookupAssoc ANil _ = fail "key not found" +lookupAssoc (ANode left a b right) a' = case compare a a' of + GT -> lookupAssoc left a' + LT -> lookupAssoc right a' + EQ -> return b + +lookupWith z ANil _ = z +lookupWith z (ANode left a b right) a' = case compare a a' of + GT -> lookupWith z left a' + LT -> lookupWith z right a' + EQ -> b + +(?) = lookupWith (fail "key not found") + +(?=) = \assoc -> maybe False (const True) . lookupAssoc assoc + + + + + + + diff --git a/src/GF/Data/BacktrackM.hs b/src/GF/Data/BacktrackM.hs new file mode 100644 index 000000000..790d11a83 --- /dev/null +++ b/src/GF/Data/BacktrackM.hs @@ -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) diff --git a/src/GF/Data/ErrM.hs b/src/GF/Data/ErrM.hs new file mode 100644 index 000000000..e8cea12d4 --- /dev/null +++ b/src/GF/Data/ErrM.hs @@ -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 diff --git a/src/GF/Data/MultiMap.hs b/src/GF/Data/MultiMap.hs new file mode 100644 index 000000000..e565f433b --- /dev/null +++ b/src/GF/Data/MultiMap.hs @@ -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]
\ No newline at end of file diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs new file mode 100644 index 000000000..253723876 --- /dev/null +++ b/src/GF/Data/Operations.hs @@ -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 diff --git a/src/GF/Data/SortedList.hs b/src/GF/Data/SortedList.hs new file mode 100644 index 000000000..d77ff68d4 --- /dev/null +++ b/src/GF/Data/SortedList.hs @@ -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 + + + + + diff --git a/src/GF/Data/Str.hs b/src/GF/Data/Str.hs new file mode 100644 index 000000000..6f65764c7 --- /dev/null +++ b/src/GF/Data/Str.hs @@ -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 diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs new file mode 100644 index 000000000..74d3ef81e --- /dev/null +++ b/src/GF/Data/Utilities.hs @@ -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) + + + diff --git a/src/GF/Data/XML.hs b/src/GF/Data/XML.hs new file mode 100644 index 000000000..0c2efb7dc --- /dev/null +++ b/src/GF/Data/XML.hs @@ -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 '<' = "<" + escChar '>' = ">" + escChar '&' = "&" + escChar '"' = """ + 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 diff --git a/src/GF/Data/Zipper.hs b/src/GF/Data/Zipper.hs new file mode 100644 index 000000000..a4491f76e --- /dev/null +++ b/src/GF/Data/Zipper.hs @@ -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 diff --git a/src/GF/Devel/README-testgf3 b/src/GF/Devel/README-testgf3 new file mode 100644 index 000000000..0d1b6e80a --- /dev/null +++ b/src/GF/Devel/README-testgf3 @@ -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 + diff --git a/src/GF/Devel/gf-code.txt b/src/GF/Devel/gf-code.txt new file mode 100644 index 000000000..e8954bedf --- /dev/null +++ b/src/GF/Devel/gf-code.txt @@ -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== + + + + + + diff --git a/src/GF/Devel/gf3.txt b/src/GF/Devel/gf3.txt new file mode 100644 index 000000000..56feeba2a --- /dev/null +++ b/src/GF/Devel/gf3.txt @@ -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 + + diff --git a/src/GF/Grammar/API.hs b/src/GF/Grammar/API.hs new file mode 100644 index 000000000..182b5e94e --- /dev/null +++ b/src/GF/Grammar/API.hs @@ -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 + + diff --git a/src/GF/Grammar/Abstract.hs b/src/GF/Grammar/Abstract.hs new file mode 100644 index 000000000..c03783a52 --- /dev/null +++ b/src/GF/Grammar/Abstract.hs @@ -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 --- + + + diff --git a/src/GF/Grammar/AppPredefined.hs b/src/GF/Grammar/AppPredefined.hs new file mode 100644 index 000000000..cfb6baf1d --- /dev/null +++ b/src/GF/Grammar/AppPredefined.hs @@ -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) diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs new file mode 100644 index 000000000..4210358f1 --- /dev/null +++ b/src/GF/Grammar/Grammar.hs @@ -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 diff --git a/src/GF/Grammar/Lockfield.hs b/src/GF/Grammar/Lockfield.hs new file mode 100644 index 000000000..12b78ab9b --- /dev/null +++ b/src/GF/Grammar/Lockfield.hs @@ -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_" diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs new file mode 100644 index 000000000..f9a251eb1 --- /dev/null +++ b/src/GF/Grammar/LookAbs.hs @@ -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" diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs new file mode 100644 index 000000000..a4208b21b --- /dev/null +++ b/src/GF/Grammar/Lookup.hs @@ -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 --- + ] diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs new file mode 100644 index 000000000..f2a0f2cb2 --- /dev/null +++ b/src/GF/Grammar/MMacros.hs @@ -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) diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs new file mode 100644 index 000000000..be03c02a7 --- /dev/null +++ b/src/GF/Grammar/Macros.hs @@ -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 + + + diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs new file mode 100644 index 000000000..b96d35b93 --- /dev/null +++ b/src/GF/Grammar/PatternMatch.hs @@ -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 + diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs new file mode 100644 index 000000000..c1593dd63 --- /dev/null +++ b/src/GF/Grammar/PrGrammar.hs @@ -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 diff --git a/src/GF/Grammar/Predef.hs b/src/GF/Grammar/Predef.hs new file mode 100644 index 000000000..71f152f92 --- /dev/null +++ b/src/GF/Grammar/Predef.hs @@ -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") diff --git a/src/GF/Grammar/ReservedWords.hs b/src/GF/Grammar/ReservedWords.hs new file mode 100644 index 000000000..b440141d6 --- /dev/null +++ b/src/GF/Grammar/ReservedWords.hs @@ -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 + diff --git a/src/GF/Grammar/Unify.hs b/src/GF/Grammar/Unify.hs new file mode 100644 index 000000000..588c1b306 --- /dev/null +++ b/src/GF/Grammar/Unify.hs @@ -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 + diff --git a/src/GF/Grammar/Values.hs b/src/GF/Grammar/Values.hs new file mode 100644 index 000000000..ab7d874da --- /dev/null +++ b/src/GF/Grammar/Values.hs @@ -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)) + diff --git a/src/GF/Infra/CheckM.hs b/src/GF/Infra/CheckM.hs new file mode 100644 index 000000000..251ed2b8b --- /dev/null +++ b/src/GF/Infra/CheckM.hs @@ -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 diff --git a/src/GF/Infra/CompactPrint.hs b/src/GF/Infra/CompactPrint.hs new file mode 100644 index 000000000..486c9e183 --- /dev/null +++ b/src/GF/Infra/CompactPrint.hs @@ -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"] diff --git a/src/GF/Infra/GetOpt.hs b/src/GF/Infra/GetOpt.hs new file mode 100644 index 000000000..ede561c90 --- /dev/null +++ b/src/GF/Infra/GetOpt.hs @@ -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. + +-} diff --git a/src/GF/Infra/Ident.hs b/src/GF/Infra/Ident.hs new file mode 100644 index 000000000..45ebf3a5b --- /dev/null +++ b/src/GF/Infra/Ident.hs @@ -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")) + +-} diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs new file mode 100644 index 000000000..797f729c8 --- /dev/null +++ b/src/GF/Infra/Modules.hs @@ -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] diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs new file mode 100644 index 000000000..380cb3af7 --- /dev/null +++ b/src/GF/Infra/Option.hs @@ -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 diff --git a/src/GF/Infra/PrintClass.hs b/src/GF/Infra/PrintClass.hs new file mode 100644 index 000000000..5e94984a6 --- /dev/null +++ b/src/GF/Infra/PrintClass.hs @@ -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" diff --git a/src/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs new file mode 100644 index 000000000..00b956708 --- /dev/null +++ b/src/GF/Infra/UseIO.hs @@ -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 + diff --git a/src/GF/JavaScript/AbsJS.hs b/src/GF/JavaScript/AbsJS.hs new file mode 100644 index 000000000..2632ade48 --- /dev/null +++ b/src/GF/JavaScript/AbsJS.hs @@ -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) + diff --git a/src/GF/JavaScript/JS.cf b/src/GF/JavaScript/JS.cf new file mode 100644 index 000000000..fe31a2074 --- /dev/null +++ b/src/GF/JavaScript/JS.cf @@ -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 ; diff --git a/src/GF/JavaScript/LexJS.x b/src/GF/JavaScript/LexJS.x new file mode 100644 index 000000000..10ba66d69 --- /dev/null +++ b/src/GF/JavaScript/LexJS.x @@ -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 +} diff --git a/src/GF/JavaScript/Makefile b/src/GF/JavaScript/Makefile new file mode 100644 index 000000000..10f867b06 --- /dev/null +++ b/src/GF/JavaScript/Makefile @@ -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* + diff --git a/src/GF/JavaScript/ParJS.y b/src/GF/JavaScript/ParJS.y new file mode 100644 index 000000000..bf0614757 --- /dev/null +++ b/src/GF/JavaScript/ParJS.y @@ -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_) +} + diff --git a/src/GF/JavaScript/PrintJS.hs b/src/GF/JavaScript/PrintJS.hs new file mode 100644 index 000000000..4e04e3cbf --- /dev/null +++ b/src/GF/JavaScript/PrintJS.hs @@ -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]) + + + diff --git a/src/GF/Source/AbsGF.hs b/src/GF/Source/AbsGF.hs new file mode 100644 index 000000000..86e521318 --- /dev/null +++ b/src/GF/Source/AbsGF.hs @@ -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)
+
diff --git a/src/GF/Source/ErrM.hs b/src/GF/Source/ErrM.hs new file mode 100644 index 000000000..addd22f69 --- /dev/null +++ b/src/GF/Source/ErrM.hs @@ -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
diff --git a/src/GF/Source/GF.cf b/src/GF/Source/GF.cf new file mode 100644 index 000000000..ef458c91a --- /dev/null +++ b/src/GF/Source/GF.cf @@ -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 | '_' | '\'')* ; diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs new file mode 100644 index 000000000..f76fe6cee --- /dev/null +++ b/src/GF/Source/GrammarToSource.hs @@ -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 diff --git a/src/GF/Source/LexGF.hs b/src/GF/Source/LexGF.hs new file mode 100644 index 000000000..1a2e507be --- /dev/null +++ b/src/GF/Source/LexGF.hs @@ -0,0 +1,350 @@ +{-# OPTIONS -fglasgow-exts -cpp #-}
+{-# LINE 3 "LexGF.x" #-}
+
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+module GF.Source.LexGF where
+
+import GF.Source.SharedString
+import qualified Data.ByteString.Char8 as BS
+
+#if __GLASGOW_HASKELL__ >= 603
+#include "ghcconfig.h"
+#elif defined(__GLASGOW_HASKELL__)
+#include "config.h"
+#endif
+#if __GLASGOW_HASKELL__ >= 503
+import Data.Array
+import Data.Char (ord)
+import Data.Array.Base (unsafeAt)
+#else
+import Array
+import Char (ord)
+#endif
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.Exts
+#else
+import GlaExts
+#endif
+alex_base :: AlexAddr
+alex_base = AlexA# "\x01\x00\x00\x00\x15\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x18\x00\x00\x00\x19\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x45\x00\x00\x00\x1b\x00\x00\x00\x1c\x00\x00\x00\x1d\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x26\x00\x00\x00\x27\x00\x00\x00\x13\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x6c\x01\x00\x00\x3c\x02\x00\x00\x0c\x03\x00\x00\x00\x00\x00\x00\x17\x01\x00\x00\xe7\x01\x00\x00\xd5\x00\x00\x00\x35\x00\x00\x00\xe7\x00\x00\x00\xf2\x00\x00\x00\x1d\x01\x00\x00\xc2\x01\x00\x00\xcc\x01\x00\x00"#
+
+alex_table :: AlexAddr
+alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x1a\x00\x0e\x00\x0e\x00\x0e\x00\xff\xff\x14\x00\x0e\x00\x0e\x00\x0f\x00\x10\x00\x0e\x00\x05\x00\x0e\x00\x0e\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x0e\x00\x0e\x00\x0e\x00\x11\x00\x0e\x00\x0e\x00\x0e\x00\x04\x00\xff\xff\xff\xff\x02\x00\x02\x00\x09\x00\x09\x00\x09\x00\x0a\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0e\x00\x0e\x00\x0e\x00\x13\x00\x13\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\xff\xff\x12\x00\xff\xff\x0d\x00\x20\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x09\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0e\x00\x0e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x06\x00\x07\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x1b\x00\xff\xff\x00\x00\x00\x00\x17\x00\x1b\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xff\xff\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x21\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x1c\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x18\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\xff\xff\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x1c\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x17\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x18\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00"#
+
+alex_check :: AlexAddr
+alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2d\x00\x0a\x00\x0a\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2a\x00\x3e\x00\x2b\x00\x27\x00\x27\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x2d\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x7d\x00\x7d\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xf7\x00\xff\xff\xff\xff\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"#
+
+alex_deflt :: AlexAddr
+alex_deflt = AlexA# "\x16\x00\xff\xff\x03\x00\x03\x00\xff\xff\xff\xff\x0b\x00\xff\xff\x0b\x00\x0b\x00\x0b\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
+
+alex_accept = listArray (0::Int,34) [[],[],[(AlexAccSkip)],[(AlexAccSkip)],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_7))],[],[],[],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_9))],[],[],[]]
+{-# LINE 37 "LexGF.x" #-}
+
+
+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
+
+alex_action_3 = tok (\p s -> PT p (eitherResIdent (T_PIdent . share) s))
+alex_action_4 = tok (\p s -> PT p (eitherResIdent (T_LString . share) s))
+alex_action_5 = tok (\p s -> PT p (eitherResIdent (T_PIdent . share) s))
+alex_action_6 = tok (\p s -> PT p (eitherResIdent (TV . share) s))
+alex_action_7 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s))
+alex_action_8 = tok (\p s -> PT p (TI $ share s))
+alex_action_9 = tok (\p s -> PT p (TD $ share s))
+{-# LINE 1 "templates/GenericTemplate.hs" #-}
+{-# LINE 1 "templates/GenericTemplate.hs" #-}
+{-# LINE 1 "<built-in>" #-}
+{-# LINE 1 "<command line>" #-}
+{-# LINE 1 "templates/GenericTemplate.hs" #-}
+-- -----------------------------------------------------------------------------
+-- ALEX TEMPLATE
+--
+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use
+-- it for any purpose whatsoever.
+
+-- -----------------------------------------------------------------------------
+-- INTERNALS and main scanner engine
+
+{-# LINE 35 "templates/GenericTemplate.hs" #-}
+
+{-# LINE 45 "templates/GenericTemplate.hs" #-}
+
+
+data AlexAddr = AlexA# Addr#
+
+#if __GLASGOW_HASKELL__ < 503
+uncheckedShiftL# = shiftL#
+#endif
+
+{-# INLINE alexIndexInt16OffAddr #-}
+alexIndexInt16OffAddr (AlexA# arr) off =
+#ifdef WORDS_BIGENDIAN
+ narrow16Int# i
+ where
+ i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
+ high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
+ low = int2Word# (ord# (indexCharOffAddr# arr off'))
+ off' = off *# 2#
+#else
+ indexInt16OffAddr# arr off
+#endif
+
+
+
+
+
+{-# INLINE alexIndexInt32OffAddr #-}
+alexIndexInt32OffAddr (AlexA# arr) off =
+#ifdef WORDS_BIGENDIAN
+ narrow32Int# i
+ where
+ i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`
+ (b2 `uncheckedShiftL#` 16#) `or#`
+ (b1 `uncheckedShiftL#` 8#) `or#` b0)
+ b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))
+ b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))
+ b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
+ b0 = int2Word# (ord# (indexCharOffAddr# arr off'))
+ off' = off *# 4#
+#else
+ indexInt32OffAddr# arr off
+#endif
+
+
+
+
+
+#if __GLASGOW_HASKELL__ < 503
+quickIndex arr i = arr ! i
+#else
+-- GHC >= 503, unsafeAt is available from Data.Array.Base.
+quickIndex = unsafeAt
+#endif
+
+
+
+
+-- -----------------------------------------------------------------------------
+-- Main lexing routines
+
+data AlexReturn a
+ = AlexEOF
+ | AlexError !AlexInput
+ | AlexSkip !AlexInput !Int
+ | AlexToken !AlexInput !Int a
+
+-- alexScan :: AlexInput -> StartCode -> AlexReturn a
+alexScan input (I# (sc))
+ = alexScanUser undefined input (I# (sc))
+
+alexScanUser user input (I# (sc))
+ = case alex_scan_tkn user input 0# input sc AlexNone of
+ (AlexNone, input') ->
+ case alexGetChar input of
+ Nothing ->
+
+
+
+ AlexEOF
+ Just _ ->
+
+
+
+ AlexError input'
+
+ (AlexLastSkip input len, _) ->
+
+
+
+ AlexSkip input len
+
+ (AlexLastAcc k input len, _) ->
+
+
+
+ AlexToken input len k
+
+
+-- Push the input through the DFA, remembering the most recent accepting
+-- state it encountered.
+
+alex_scan_tkn user orig_input len input s last_acc =
+ input `seq` -- strict in the input
+ let
+ new_acc = check_accs (alex_accept `quickIndex` (I# (s)))
+ in
+ new_acc `seq`
+ case alexGetChar input of
+ Nothing -> (new_acc, input)
+ Just (c, new_input) ->
+
+
+
+ let
+ base = alexIndexInt32OffAddr alex_base s
+ (I# (ord_c)) = ord c
+ offset = (base +# ord_c)
+ check = alexIndexInt16OffAddr alex_check offset
+
+ new_s = if (offset >=# 0#) && (check ==# ord_c)
+ then alexIndexInt16OffAddr alex_table offset
+ else alexIndexInt16OffAddr alex_deflt s
+ in
+ case new_s of
+ -1# -> (new_acc, input)
+ -- on an error, we want to keep the input *before* the
+ -- character that failed, not after.
+ _ -> alex_scan_tkn user orig_input (len +# 1#)
+ new_input new_s new_acc
+
+ where
+ check_accs [] = last_acc
+ check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))
+ check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))
+ check_accs (AlexAccPred a pred : rest)
+ | pred user orig_input (I# (len)) input
+ = AlexLastAcc a input (I# (len))
+ check_accs (AlexAccSkipPred pred : rest)
+ | pred user orig_input (I# (len)) input
+ = AlexLastSkip input (I# (len))
+ check_accs (_ : rest) = check_accs rest
+
+data AlexLastAcc a
+ = AlexNone
+ | AlexLastAcc a !AlexInput !Int
+ | AlexLastSkip !AlexInput !Int
+
+data AlexAcc a user
+ = AlexAcc a
+ | AlexAccSkip
+ | AlexAccPred a (AlexAccPred user)
+ | AlexAccSkipPred (AlexAccPred user)
+
+type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool
+
+-- -----------------------------------------------------------------------------
+-- Predicates on a rule
+
+alexAndPred p1 p2 user in1 len in2
+ = p1 user in1 len in2 && p2 user in1 len in2
+
+--alexPrevCharIsPred :: Char -> AlexAccPred _
+alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input
+
+--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _
+alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input
+
+--alexRightContext :: Int -> AlexAccPred _
+alexRightContext (I# (sc)) user _ _ input =
+ case alex_scan_tkn user input 0# input sc AlexNone of
+ (AlexNone, _) -> False
+ _ -> True
+ -- TODO: there's no need to find the longest
+ -- match when checking the right context, just
+ -- the first match will do.
+
+-- used by wrappers
+iUnbox (I# (i)) = i
diff --git a/src/GF/Source/LexGF.x b/src/GF/Source/LexGF.x new file mode 100644 index 000000000..15671c9de --- /dev/null +++ b/src/GF/Source/LexGF.x @@ -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
+}
diff --git a/src/GF/Source/ParGF.hs b/src/GF/Source/ParGF.hs new file mode 100644 index 000000000..863e6c7e9 --- /dev/null +++ b/src/GF/Source/ParGF.hs @@ -0,0 +1,7843 @@ +{-# OPTIONS -fglasgow-exts -cpp #-}
+{-# 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
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.Exts
+#else
+import GlaExts
+#endif
+
+-- parser produced by Happy Version 1.17
+
+data HappyAbsSyn
+ = HappyTerminal Token
+ | HappyErrorToken Int
+ | HappyAbsSyn8 (Integer)
+ | HappyAbsSyn9 (String)
+ | HappyAbsSyn10 (Double)
+ | HappyAbsSyn11 (LString)
+ | HappyAbsSyn12 (PIdent)
+ | HappyAbsSyn13 (Grammar)
+ | HappyAbsSyn14 ([ModDef])
+ | HappyAbsSyn15 (ModDef)
+ | HappyAbsSyn16 (ConcSpec)
+ | HappyAbsSyn17 ([ConcSpec])
+ | HappyAbsSyn18 (ConcExp)
+ | HappyAbsSyn19 ([Transfer])
+ | HappyAbsSyn20 (Transfer)
+ | HappyAbsSyn22 (ModBody)
+ | HappyAbsSyn23 (ModType)
+ | HappyAbsSyn25 ([TopDef])
+ | HappyAbsSyn26 (Extend)
+ | HappyAbsSyn27 ([Open])
+ | HappyAbsSyn28 (Opens)
+ | HappyAbsSyn29 (Open)
+ | HappyAbsSyn30 (ComplMod)
+ | HappyAbsSyn31 (QualOpen)
+ | HappyAbsSyn32 ([Included])
+ | HappyAbsSyn33 (Included)
+ | HappyAbsSyn34 (Def)
+ | HappyAbsSyn35 (TopDef)
+ | HappyAbsSyn36 (CatDef)
+ | HappyAbsSyn37 (FunDef)
+ | HappyAbsSyn38 (DataDef)
+ | HappyAbsSyn39 (DataConstr)
+ | HappyAbsSyn40 ([DataConstr])
+ | HappyAbsSyn41 (ParDef)
+ | HappyAbsSyn42 (ParConstr)
+ | HappyAbsSyn43 (PrintDef)
+ | HappyAbsSyn44 (FlagDef)
+ | HappyAbsSyn45 ([Def])
+ | HappyAbsSyn46 ([CatDef])
+ | HappyAbsSyn47 ([FunDef])
+ | HappyAbsSyn48 ([DataDef])
+ | HappyAbsSyn49 ([ParDef])
+ | HappyAbsSyn50 ([PrintDef])
+ | HappyAbsSyn51 ([FlagDef])
+ | HappyAbsSyn52 ([ParConstr])
+ | HappyAbsSyn53 ([PIdent])
+ | HappyAbsSyn54 (Name)
+ | HappyAbsSyn55 ([Name])
+ | HappyAbsSyn56 (LocDef)
+ | HappyAbsSyn57 ([LocDef])
+ | HappyAbsSyn58 (Exp)
+ | HappyAbsSyn65 ([Exp])
+ | HappyAbsSyn66 (Exps)
+ | HappyAbsSyn67 (Patt)
+ | HappyAbsSyn70 (PattAss)
+ | HappyAbsSyn71 (Label)
+ | HappyAbsSyn72 (Sort)
+ | HappyAbsSyn73 ([PattAss])
+ | HappyAbsSyn74 ([Patt])
+ | HappyAbsSyn75 (Bind)
+ | HappyAbsSyn76 ([Bind])
+ | HappyAbsSyn77 (Decl)
+ | HappyAbsSyn78 (TupleComp)
+ | HappyAbsSyn79 (PattTupleComp)
+ | HappyAbsSyn80 ([TupleComp])
+ | HappyAbsSyn81 ([PattTupleComp])
+ | HappyAbsSyn82 (Case)
+ | HappyAbsSyn83 ([Case])
+ | HappyAbsSyn84 (Equation)
+ | HappyAbsSyn85 ([Equation])
+ | HappyAbsSyn86 (Altern)
+ | HappyAbsSyn87 ([Altern])
+ | HappyAbsSyn88 (DDecl)
+ | HappyAbsSyn89 ([DDecl])
+ | HappyAbsSyn90 (OldGrammar)
+ | HappyAbsSyn91 (Include)
+ | HappyAbsSyn92 (FileName)
+ | HappyAbsSyn93 ([FileName])
+
+type HappyReduction m =
+ Int#
+ -> (Token)
+ -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)
+ -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)]
+ -> HappyStk HappyAbsSyn
+ -> [(Token)] -> m HappyAbsSyn
+
+action_0,
+ action_1,
+ action_2,
+ action_3,
+ action_4,
+ action_5,
+ action_6,
+ action_7,
+ action_8,
+ action_9,
+ action_10,
+ action_11,
+ action_12,
+ action_13,
+ action_14,
+ action_15,
+ action_16,
+ action_17,
+ action_18,
+ action_19,
+ action_20,
+ action_21,
+ action_22,
+ action_23,
+ action_24,
+ action_25,
+ action_26,
+ action_27,
+ action_28,
+ action_29,
+ action_30,
+ action_31,
+ action_32,
+ action_33,
+ action_34,
+ action_35,
+ action_36,
+ action_37,
+ action_38,
+ action_39,
+ action_40,
+ action_41,
+ action_42,
+ action_43,
+ action_44,
+ action_45,
+ action_46,
+ action_47,
+ action_48,
+ action_49,
+ action_50,
+ action_51,
+ action_52,
+ action_53,
+ action_54,
+ action_55,
+ action_56,
+ action_57,
+ action_58,
+ action_59,
+ action_60,
+ action_61,
+ action_62,
+ action_63,
+ action_64,
+ action_65,
+ action_66,
+ action_67,
+ action_68,
+ action_69,
+ action_70,
+ action_71,
+ action_72,
+ action_73,
+ action_74,
+ action_75,
+ action_76,
+ action_77,
+ action_78,
+ action_79,
+ action_80,
+ action_81,
+ action_82,
+ action_83,
+ action_84,
+ action_85,
+ action_86,
+ action_87,
+ action_88,
+ action_89,
+ action_90,
+ action_91,
+ action_92,
+ action_93,
+ action_94,
+ action_95,
+ action_96,
+ action_97,
+ action_98,
+ action_99,
+ action_100,
+ action_101,
+ action_102,
+ action_103,
+ action_104,
+ action_105,
+ action_106,
+ action_107,
+ action_108,
+ action_109,
+ action_110,
+ action_111,
+ action_112,
+ action_113,
+ action_114,
+ action_115,
+ action_116,
+ action_117,
+ action_118,
+ action_119,
+ action_120,
+ action_121,
+ action_122,
+ action_123,
+ action_124,
+ action_125,
+ action_126,
+ action_127,
+ action_128,
+ action_129,
+ action_130,
+ action_131,
+ action_132,
+ action_133,
+ action_134,
+ action_135,
+ action_136,
+ action_137,
+ action_138,
+ action_139,
+ action_140,
+ action_141,
+ action_142,
+ action_143,
+ action_144,
+ action_145,
+ action_146,
+ action_147,
+ action_148,
+ action_149,
+ action_150,
+ action_151,
+ action_152,
+ action_153,
+ action_154,
+ action_155,
+ action_156,
+ action_157,
+ action_158,
+ action_159,
+ action_160,
+ action_161,
+ action_162,
+ action_163,
+ action_164,
+ action_165,
+ action_166,
+ action_167,
+ action_168,
+ action_169,
+ action_170,
+ action_171,
+ action_172,
+ action_173,
+ action_174,
+ action_175,
+ action_176,
+ action_177,
+ action_178,
+ action_179,
+ action_180,
+ action_181,
+ action_182,
+ action_183,
+ action_184,
+ action_185,
+ action_186,
+ action_187,
+ action_188,
+ action_189,
+ action_190,
+ action_191,
+ action_192,
+ action_193,
+ action_194,
+ action_195,
+ action_196,
+ action_197,
+ action_198,
+ action_199,
+ action_200,
+ action_201,
+ action_202,
+ action_203,
+ action_204,
+ action_205,
+ action_206,
+ action_207,
+ action_208,
+ action_209,
+ action_210,
+ action_211,
+ action_212,
+ action_213,
+ action_214,
+ action_215,
+ action_216,
+ action_217,
+ action_218,
+ action_219,
+ action_220,
+ action_221,
+ action_222,
+ action_223,
+ action_224,
+ action_225,
+ action_226,
+ action_227,
+ action_228,
+ action_229,
+ action_230,
+ action_231,
+ action_232,
+ action_233,
+ action_234,
+ action_235,
+ action_236,
+ action_237,
+ action_238,
+ action_239,
+ action_240,
+ action_241,
+ action_242,
+ action_243,
+ action_244,
+ action_245,
+ action_246,
+ action_247,
+ action_248,
+ action_249,
+ action_250,
+ action_251,
+ action_252,
+ action_253,
+ action_254,
+ action_255,
+ action_256,
+ action_257,
+ action_258,
+ action_259,
+ action_260,
+ action_261,
+ action_262,
+ action_263,
+ action_264,
+ action_265,
+ action_266,
+ action_267,
+ action_268,
+ action_269,
+ action_270,
+ action_271,
+ action_272,
+ action_273,
+ action_274,
+ action_275,
+ action_276,
+ action_277,
+ action_278,
+ action_279,
+ action_280,
+ action_281,
+ action_282,
+ action_283,
+ action_284,
+ action_285,
+ action_286,
+ action_287,
+ action_288,
+ action_289,
+ action_290,
+ action_291,
+ action_292,
+ action_293,
+ action_294,
+ action_295,
+ action_296,
+ action_297,
+ action_298,
+ action_299,
+ action_300,
+ action_301,
+ action_302,
+ action_303,
+ action_304,
+ action_305,
+ action_306,
+ action_307,
+ action_308,
+ action_309,
+ action_310,
+ action_311,
+ action_312,
+ action_313,
+ action_314,
+ action_315,
+ action_316,
+ action_317,
+ action_318,
+ action_319,
+ action_320,
+ action_321,
+ action_322,
+ action_323,
+ action_324,
+ action_325,
+ action_326,
+ action_327,
+ action_328,
+ action_329,
+ action_330,
+ action_331,
+ action_332,
+ action_333,
+ action_334,
+ action_335,
+ action_336,
+ action_337,
+ action_338,
+ action_339,
+ action_340,
+ action_341,
+ action_342,
+ action_343,
+ action_344,
+ action_345,
+ action_346,
+ action_347,
+ action_348,
+ action_349,
+ action_350,
+ action_351,
+ action_352,
+ action_353,
+ action_354,
+ action_355,
+ action_356,
+ action_357,
+ action_358,
+ action_359,
+ action_360,
+ action_361,
+ action_362,
+ action_363,
+ action_364,
+ action_365,
+ action_366,
+ action_367,
+ action_368,
+ action_369,
+ action_370,
+ action_371,
+ action_372,
+ action_373,
+ action_374,
+ action_375,
+ action_376,
+ action_377,
+ action_378,
+ action_379,
+ action_380,
+ action_381,
+ action_382,
+ action_383,
+ action_384,
+ action_385,
+ action_386,
+ action_387,
+ action_388,
+ action_389,
+ action_390,
+ action_391,
+ action_392,
+ action_393,
+ action_394,
+ action_395,
+ action_396,
+ action_397,
+ action_398,
+ action_399,
+ action_400,
+ action_401,
+ action_402,
+ action_403,
+ action_404,
+ action_405,
+ action_406,
+ action_407,
+ action_408,
+ action_409,
+ action_410,
+ action_411,
+ action_412,
+ action_413,
+ action_414,
+ action_415,
+ action_416,
+ action_417,
+ action_418,
+ action_419,
+ action_420,
+ action_421,
+ action_422,
+ action_423,
+ action_424,
+ action_425,
+ action_426,
+ action_427,
+ action_428,
+ action_429,
+ action_430,
+ action_431,
+ action_432,
+ action_433,
+ action_434,
+ action_435,
+ action_436,
+ action_437,
+ action_438,
+ action_439,
+ action_440,
+ action_441,
+ action_442,
+ action_443,
+ action_444,
+ action_445,
+ action_446,
+ action_447,
+ action_448,
+ action_449,
+ action_450,
+ action_451,
+ action_452,
+ action_453,
+ action_454,
+ action_455,
+ action_456,
+ action_457,
+ action_458,
+ action_459,
+ action_460,
+ action_461,
+ action_462,
+ action_463,
+ action_464,
+ action_465,
+ action_466,
+ action_467,
+ action_468,
+ action_469,
+ action_470,
+ action_471,
+ action_472,
+ action_473,
+ action_474,
+ action_475,
+ action_476,
+ action_477,
+ action_478,
+ action_479,
+ action_480,
+ action_481,
+ action_482,
+ action_483,
+ action_484,
+ action_485,
+ action_486,
+ action_487,
+ action_488,
+ action_489,
+ action_490,
+ action_491,
+ action_492,
+ action_493,
+ action_494,
+ action_495,
+ action_496,
+ action_497,
+ action_498,
+ action_499,
+ action_500,
+ action_501,
+ action_502,
+ action_503,
+ action_504,
+ action_505,
+ action_506,
+ action_507,
+ action_508,
+ action_509,
+ action_510,
+ action_511,
+ action_512,
+ action_513,
+ action_514,
+ action_515,
+ action_516,
+ action_517,
+ action_518,
+ action_519,
+ action_520,
+ action_521,
+ action_522,
+ action_523,
+ action_524,
+ action_525,
+ action_526,
+ action_527,
+ action_528,
+ action_529,
+ action_530,
+ action_531,
+ action_532,
+ action_533,
+ action_534,
+ action_535,
+ action_536,
+ action_537,
+ action_538,
+ action_539,
+ action_540,
+ action_541,
+ action_542,
+ action_543,
+ action_544,
+ action_545,
+ action_546,
+ action_547 :: () => Int# -> HappyReduction (Err)
+
+happyReduce_5,
+ happyReduce_6,
+ happyReduce_7,
+ happyReduce_8,
+ happyReduce_9,
+ happyReduce_10,
+ happyReduce_11,
+ happyReduce_12,
+ happyReduce_13,
+ happyReduce_14,
+ happyReduce_15,
+ happyReduce_16,
+ happyReduce_17,
+ happyReduce_18,
+ happyReduce_19,
+ happyReduce_20,
+ happyReduce_21,
+ happyReduce_22,
+ happyReduce_23,
+ happyReduce_24,
+ happyReduce_25,
+ happyReduce_26,
+ happyReduce_27,
+ happyReduce_28,
+ happyReduce_29,
+ happyReduce_30,
+ happyReduce_31,
+ happyReduce_32,
+ happyReduce_33,
+ happyReduce_34,
+ happyReduce_35,
+ happyReduce_36,
+ happyReduce_37,
+ happyReduce_38,
+ happyReduce_39,
+ happyReduce_40,
+ happyReduce_41,
+ happyReduce_42,
+ happyReduce_43,
+ happyReduce_44,
+ happyReduce_45,
+ happyReduce_46,
+ happyReduce_47,
+ happyReduce_48,
+ happyReduce_49,
+ happyReduce_50,
+ happyReduce_51,
+ happyReduce_52,
+ happyReduce_53,
+ happyReduce_54,
+ happyReduce_55,
+ happyReduce_56,
+ happyReduce_57,
+ happyReduce_58,
+ happyReduce_59,
+ happyReduce_60,
+ happyReduce_61,
+ happyReduce_62,
+ happyReduce_63,
+ happyReduce_64,
+ happyReduce_65,
+ happyReduce_66,
+ happyReduce_67,
+ happyReduce_68,
+ happyReduce_69,
+ happyReduce_70,
+ happyReduce_71,
+ happyReduce_72,
+ happyReduce_73,
+ happyReduce_74,
+ happyReduce_75,
+ happyReduce_76,
+ happyReduce_77,
+ happyReduce_78,
+ happyReduce_79,
+ happyReduce_80,
+ happyReduce_81,
+ happyReduce_82,
+ happyReduce_83,
+ happyReduce_84,
+ happyReduce_85,
+ happyReduce_86,
+ happyReduce_87,
+ happyReduce_88,
+ happyReduce_89,
+ happyReduce_90,
+ happyReduce_91,
+ happyReduce_92,
+ happyReduce_93,
+ happyReduce_94,
+ happyReduce_95,
+ happyReduce_96,
+ happyReduce_97,
+ happyReduce_98,
+ happyReduce_99,
+ happyReduce_100,
+ happyReduce_101,
+ happyReduce_102,
+ happyReduce_103,
+ happyReduce_104,
+ happyReduce_105,
+ happyReduce_106,
+ happyReduce_107,
+ happyReduce_108,
+ happyReduce_109,
+ happyReduce_110,
+ happyReduce_111,
+ happyReduce_112,
+ happyReduce_113,
+ happyReduce_114,
+ happyReduce_115,
+ happyReduce_116,
+ happyReduce_117,
+ happyReduce_118,
+ happyReduce_119,
+ happyReduce_120,
+ happyReduce_121,
+ happyReduce_122,
+ happyReduce_123,
+ happyReduce_124,
+ happyReduce_125,
+ happyReduce_126,
+ happyReduce_127,
+ happyReduce_128,
+ happyReduce_129,
+ happyReduce_130,
+ happyReduce_131,
+ happyReduce_132,
+ happyReduce_133,
+ happyReduce_134,
+ happyReduce_135,
+ happyReduce_136,
+ happyReduce_137,
+ happyReduce_138,
+ happyReduce_139,
+ happyReduce_140,
+ happyReduce_141,
+ happyReduce_142,
+ happyReduce_143,
+ happyReduce_144,
+ happyReduce_145,
+ happyReduce_146,
+ happyReduce_147,
+ happyReduce_148,
+ happyReduce_149,
+ happyReduce_150,
+ happyReduce_151,
+ happyReduce_152,
+ happyReduce_153,
+ happyReduce_154,
+ happyReduce_155,
+ happyReduce_156,
+ happyReduce_157,
+ happyReduce_158,
+ happyReduce_159,
+ happyReduce_160,
+ happyReduce_161,
+ happyReduce_162,
+ happyReduce_163,
+ happyReduce_164,
+ happyReduce_165,
+ happyReduce_166,
+ happyReduce_167,
+ happyReduce_168,
+ happyReduce_169,
+ happyReduce_170,
+ happyReduce_171,
+ happyReduce_172,
+ happyReduce_173,
+ happyReduce_174,
+ happyReduce_175,
+ happyReduce_176,
+ happyReduce_177,
+ happyReduce_178,
+ happyReduce_179,
+ happyReduce_180,
+ happyReduce_181,
+ happyReduce_182,
+ happyReduce_183,
+ happyReduce_184,
+ happyReduce_185,
+ happyReduce_186,
+ happyReduce_187,
+ happyReduce_188,
+ happyReduce_189,
+ happyReduce_190,
+ happyReduce_191,
+ happyReduce_192,
+ happyReduce_193,
+ happyReduce_194,
+ happyReduce_195,
+ happyReduce_196,
+ happyReduce_197,
+ happyReduce_198,
+ happyReduce_199,
+ happyReduce_200,
+ happyReduce_201,
+ happyReduce_202,
+ happyReduce_203,
+ happyReduce_204,
+ happyReduce_205,
+ happyReduce_206,
+ happyReduce_207,
+ happyReduce_208,
+ happyReduce_209,
+ happyReduce_210,
+ happyReduce_211,
+ happyReduce_212,
+ happyReduce_213,
+ happyReduce_214,
+ happyReduce_215,
+ happyReduce_216,
+ happyReduce_217,
+ happyReduce_218,
+ happyReduce_219,
+ happyReduce_220,
+ happyReduce_221,
+ happyReduce_222,
+ happyReduce_223,
+ happyReduce_224,
+ happyReduce_225,
+ happyReduce_226,
+ happyReduce_227,
+ happyReduce_228,
+ happyReduce_229,
+ happyReduce_230,
+ happyReduce_231,
+ happyReduce_232,
+ happyReduce_233,
+ happyReduce_234,
+ happyReduce_235,
+ happyReduce_236,
+ happyReduce_237,
+ happyReduce_238,
+ happyReduce_239,
+ happyReduce_240,
+ happyReduce_241,
+ happyReduce_242,
+ happyReduce_243,
+ happyReduce_244,
+ happyReduce_245,
+ happyReduce_246,
+ happyReduce_247,
+ happyReduce_248,
+ happyReduce_249,
+ happyReduce_250,
+ happyReduce_251,
+ happyReduce_252,
+ happyReduce_253,
+ happyReduce_254,
+ happyReduce_255,
+ happyReduce_256,
+ happyReduce_257,
+ happyReduce_258,
+ happyReduce_259,
+ happyReduce_260,
+ happyReduce_261,
+ happyReduce_262,
+ happyReduce_263,
+ happyReduce_264,
+ happyReduce_265,
+ happyReduce_266,
+ happyReduce_267,
+ happyReduce_268,
+ happyReduce_269,
+ happyReduce_270,
+ happyReduce_271,
+ happyReduce_272,
+ happyReduce_273,
+ happyReduce_274 :: () => HappyReduction (Err)
+
+action_0 (13#) = happyGoto action_58
+action_0 (14#) = happyGoto action_59
+action_0 x = happyTcHack x happyReduce_11
+
+action_1 (136#) = happyShift action_57
+action_1 (139#) = happyShift action_51
+action_1 (15#) = happyGoto action_55
+action_1 (30#) = happyGoto action_56
+action_1 x = happyTcHack x happyReduce_60
+
+action_2 (138#) = happyShift action_54
+action_2 (90#) = happyGoto action_52
+action_2 (91#) = happyGoto action_53
+action_2 x = happyTcHack x happyReduce_265
+
+action_3 (139#) = happyShift action_51
+action_3 (21#) = happyGoto action_49
+action_3 (30#) = happyGoto action_50
+action_3 x = happyTcHack x happyReduce_60
+
+action_4 (95#) = happyShift action_21
+action_4 (97#) = happyShift action_22
+action_4 (98#) = happyShift action_23
+action_4 (111#) = happyShift action_24
+action_4 (115#) = happyShift action_25
+action_4 (117#) = happyShift action_26
+action_4 (118#) = happyShift action_27
+action_4 (119#) = happyShift action_28
+action_4 (120#) = happyShift action_29
+action_4 (121#) = happyShift action_30
+action_4 (122#) = happyShift action_31
+action_4 (123#) = happyShift action_32
+action_4 (124#) = happyShift action_33
+action_4 (128#) = happyShift action_34
+action_4 (131#) = happyShift action_35
+action_4 (134#) = happyShift action_36
+action_4 (137#) = happyShift action_37
+action_4 (142#) = happyShift action_38
+action_4 (153#) = happyShift action_39
+action_4 (154#) = happyShift action_40
+action_4 (158#) = happyShift action_41
+action_4 (159#) = happyShift action_42
+action_4 (164#) = happyShift action_43
+action_4 (167#) = happyShift action_44
+action_4 (170#) = happyShift action_6
+action_4 (171#) = happyShift action_45
+action_4 (172#) = happyShift action_46
+action_4 (173#) = happyShift action_47
+action_4 (174#) = happyShift action_48
+action_4 (8#) = happyGoto action_7
+action_4 (9#) = happyGoto action_8
+action_4 (10#) = happyGoto action_9
+action_4 (11#) = happyGoto action_10
+action_4 (12#) = happyGoto action_11
+action_4 (58#) = happyGoto action_12
+action_4 (59#) = happyGoto action_13
+action_4 (60#) = happyGoto action_14
+action_4 (61#) = happyGoto action_15
+action_4 (62#) = happyGoto action_16
+action_4 (63#) = happyGoto action_17
+action_4 (64#) = happyGoto action_18
+action_4 (72#) = happyGoto action_19
+action_4 (77#) = happyGoto action_20
+action_4 x = happyTcHack x happyFail
+
+action_5 (170#) = happyShift action_6
+action_5 x = happyTcHack x happyFail
+
+action_6 x = happyTcHack x happyReduce_5
+
+action_7 x = happyTcHack x happyReduce_145
+
+action_8 x = happyTcHack x happyReduce_144
+
+action_9 x = happyTcHack x happyReduce_146
+
+action_10 x = happyTcHack x happyReduce_157
+
+action_11 (116#) = happyShift action_137
+action_11 x = happyTcHack x happyReduce_140
+
+action_12 x = happyTcHack x happyReduce_161
+
+action_13 (107#) = happyShift action_136
+action_13 x = happyTcHack x happyReduce_173
+
+action_14 (97#) = happyShift action_22
+action_14 (98#) = happyShift action_87
+action_14 (106#) = happyReduce_240
+action_14 (111#) = happyShift action_24
+action_14 (115#) = happyShift action_25
+action_14 (118#) = happyShift action_27
+action_14 (119#) = happyShift action_28
+action_14 (120#) = happyShift action_29
+action_14 (121#) = happyShift action_30
+action_14 (122#) = happyShift action_31
+action_14 (123#) = happyShift action_32
+action_14 (131#) = happyShift action_35
+action_14 (167#) = happyShift action_44
+action_14 (170#) = happyShift action_6
+action_14 (171#) = happyShift action_45
+action_14 (172#) = happyShift action_46
+action_14 (173#) = happyShift action_47
+action_14 (174#) = happyShift action_48
+action_14 (8#) = happyGoto action_7
+action_14 (9#) = happyGoto action_8
+action_14 (10#) = happyGoto action_9
+action_14 (11#) = happyGoto action_10
+action_14 (12#) = happyGoto action_84
+action_14 (58#) = happyGoto action_12
+action_14 (59#) = happyGoto action_135
+action_14 (72#) = happyGoto action_19
+action_14 x = happyTcHack x happyReduce_178
+
+action_15 (94#) = happyShift action_130
+action_15 (100#) = happyShift action_131
+action_15 (101#) = happyShift action_132
+action_15 (113#) = happyShift action_133
+action_15 (165#) = happyShift action_134
+action_15 x = happyTcHack x happyReduce_192
+
+action_16 (103#) = happyShift action_129
+action_16 x = happyTcHack x happyReduce_191
+
+action_17 (176#) = happyAccept
+action_17 x = happyTcHack x happyFail
+
+action_18 (102#) = happyShift action_128
+action_18 x = happyTcHack x happyReduce_180
+
+action_19 x = happyTcHack x happyReduce_143
+
+action_20 (106#) = happyShift action_127
+action_20 x = happyTcHack x happyFail
+
+action_21 (95#) = happyShift action_120
+action_21 (98#) = happyShift action_121
+action_21 (111#) = happyShift action_122
+action_21 (115#) = happyShift action_123
+action_21 (123#) = happyShift action_124
+action_21 (126#) = happyShift action_125
+action_21 (167#) = happyShift action_126
+action_21 (170#) = happyShift action_6
+action_21 (171#) = happyShift action_45
+action_21 (172#) = happyShift action_46
+action_21 (174#) = happyShift action_48
+action_21 (8#) = happyGoto action_115
+action_21 (9#) = happyGoto action_116
+action_21 (10#) = happyGoto action_117
+action_21 (12#) = happyGoto action_118
+action_21 (67#) = happyGoto action_119
+action_21 x = happyTcHack x happyFail
+
+action_22 (174#) = happyShift action_48
+action_22 (12#) = happyGoto action_114
+action_22 x = happyTcHack x happyFail
+
+action_23 (95#) = happyShift action_21
+action_23 (97#) = happyShift action_22
+action_23 (98#) = happyShift action_23
+action_23 (111#) = happyShift action_24
+action_23 (115#) = happyShift action_25
+action_23 (117#) = happyShift action_26
+action_23 (118#) = happyShift action_27
+action_23 (119#) = happyShift action_28
+action_23 (120#) = happyShift action_29
+action_23 (121#) = happyShift action_30
+action_23 (122#) = happyShift action_31
+action_23 (123#) = happyShift action_32
+action_23 (124#) = happyShift action_33
+action_23 (126#) = happyShift action_102
+action_23 (128#) = happyShift action_34
+action_23 (131#) = happyShift action_35
+action_23 (134#) = happyShift action_36
+action_23 (137#) = happyShift action_113
+action_23 (142#) = happyShift action_38
+action_23 (153#) = happyShift action_39
+action_23 (154#) = happyShift action_40
+action_23 (158#) = happyShift action_41
+action_23 (159#) = happyShift action_42
+action_23 (164#) = happyShift action_43
+action_23 (167#) = happyShift action_44
+action_23 (170#) = happyShift action_6
+action_23 (171#) = happyShift action_45
+action_23 (172#) = happyShift action_46
+action_23 (173#) = happyShift action_47
+action_23 (174#) = happyShift action_48
+action_23 (8#) = happyGoto action_7
+action_23 (9#) = happyGoto action_8
+action_23 (10#) = happyGoto action_9
+action_23 (11#) = happyGoto action_10
+action_23 (12#) = happyGoto action_110
+action_23 (58#) = happyGoto action_12
+action_23 (59#) = happyGoto action_13
+action_23 (60#) = happyGoto action_14
+action_23 (61#) = happyGoto action_15
+action_23 (62#) = happyGoto action_16
+action_23 (63#) = happyGoto action_111
+action_23 (64#) = happyGoto action_18
+action_23 (72#) = happyGoto action_19
+action_23 (75#) = happyGoto action_99
+action_23 (76#) = happyGoto action_112
+action_23 (77#) = happyGoto action_20
+action_23 x = happyTcHack x happyReduce_236
+
+action_24 (95#) = happyShift action_21
+action_24 (97#) = happyShift action_22
+action_24 (98#) = happyShift action_23
+action_24 (111#) = happyShift action_24
+action_24 (115#) = happyShift action_25
+action_24 (117#) = happyShift action_26
+action_24 (118#) = happyShift action_27
+action_24 (119#) = happyShift action_28
+action_24 (120#) = happyShift action_29
+action_24 (121#) = happyShift action_30
+action_24 (122#) = happyShift action_31
+action_24 (123#) = happyShift action_32
+action_24 (124#) = happyShift action_33
+action_24 (128#) = happyShift action_34
+action_24 (131#) = happyShift action_35
+action_24 (134#) = happyShift action_36
+action_24 (137#) = happyShift action_37
+action_24 (142#) = happyShift action_38
+action_24 (153#) = happyShift action_39
+action_24 (154#) = happyShift action_40
+action_24 (158#) = happyShift action_41
+action_24 (159#) = happyShift action_42
+action_24 (164#) = happyShift action_43
+action_24 (167#) = happyShift action_44
+action_24 (170#) = happyShift action_6
+action_24 (171#) = happyShift action_45
+action_24 (172#) = happyShift action_46
+action_24 (173#) = happyShift action_47
+action_24 (174#) = happyShift action_48
+action_24 (8#) = happyGoto action_7
+action_24 (9#) = happyGoto action_8
+action_24 (10#) = happyGoto action_9
+action_24 (11#) = happyGoto action_10
+action_24 (12#) = happyGoto action_11
+action_24 (58#) = happyGoto action_12
+action_24 (59#) = happyGoto action_13
+action_24 (60#) = happyGoto action_14
+action_24 (61#) = happyGoto action_15
+action_24 (62#) = happyGoto action_16
+action_24 (63#) = happyGoto action_107
+action_24 (64#) = happyGoto action_18
+action_24 (72#) = happyGoto action_19
+action_24 (77#) = happyGoto action_20
+action_24 (78#) = happyGoto action_108
+action_24 (80#) = happyGoto action_109
+action_24 x = happyTcHack x happyReduce_243
+
+action_25 x = happyTcHack x happyReduce_147
+
+action_26 (174#) = happyShift action_48
+action_26 (12#) = happyGoto action_106
+action_26 x = happyTcHack x happyFail
+
+action_27 x = happyTcHack x happyReduce_225
+
+action_28 x = happyTcHack x happyReduce_227
+
+action_29 x = happyTcHack x happyReduce_228
+
+action_30 x = happyTcHack x happyReduce_226
+
+action_31 x = happyTcHack x happyReduce_224
+
+action_32 (125#) = happyShift action_105
+action_32 (171#) = happyShift action_45
+action_32 (174#) = happyShift action_48
+action_32 (9#) = happyGoto action_103
+action_32 (12#) = happyGoto action_104
+action_32 x = happyTcHack x happyFail
+
+action_33 (124#) = happyShift action_101
+action_33 (126#) = happyShift action_102
+action_33 (174#) = happyShift action_48
+action_33 (12#) = happyGoto action_98
+action_33 (75#) = happyGoto action_99
+action_33 (76#) = happyGoto action_100
+action_33 x = happyTcHack x happyReduce_236
+
+action_34 (95#) = happyShift action_21
+action_34 (97#) = happyShift action_22
+action_34 (98#) = happyShift action_23
+action_34 (111#) = happyShift action_24
+action_34 (115#) = happyShift action_25
+action_34 (117#) = happyShift action_26
+action_34 (118#) = happyShift action_27
+action_34 (119#) = happyShift action_28
+action_34 (120#) = happyShift action_29
+action_34 (121#) = happyShift action_30
+action_34 (122#) = happyShift action_31
+action_34 (123#) = happyShift action_32
+action_34 (124#) = happyShift action_33
+action_34 (128#) = happyShift action_34
+action_34 (131#) = happyShift action_35
+action_34 (134#) = happyShift action_36
+action_34 (137#) = happyShift action_37
+action_34 (142#) = happyShift action_38
+action_34 (153#) = happyShift action_39
+action_34 (154#) = happyShift action_40
+action_34 (158#) = happyShift action_41
+action_34 (159#) = happyShift action_42
+action_34 (164#) = happyShift action_43
+action_34 (167#) = happyShift action_44
+action_34 (170#) = happyShift action_6
+action_34 (171#) = happyShift action_45
+action_34 (172#) = happyShift action_46
+action_34 (173#) = happyShift action_47
+action_34 (174#) = happyShift action_48
+action_34 (8#) = happyGoto action_7
+action_34 (9#) = happyGoto action_8
+action_34 (10#) = happyGoto action_9
+action_34 (11#) = happyGoto action_10
+action_34 (12#) = happyGoto action_11
+action_34 (58#) = happyGoto action_12
+action_34 (59#) = happyGoto action_13
+action_34 (60#) = happyGoto action_14
+action_34 (61#) = happyGoto action_15
+action_34 (62#) = happyGoto action_16
+action_34 (63#) = happyGoto action_97
+action_34 (64#) = happyGoto action_18
+action_34 (72#) = happyGoto action_19
+action_34 (77#) = happyGoto action_20
+action_34 x = happyTcHack x happyFail
+
+action_35 x = happyTcHack x happyReduce_149
+
+action_36 (167#) = happyShift action_96
+action_36 x = happyTcHack x happyFail
+
+action_37 (97#) = happyShift action_22
+action_37 (98#) = happyShift action_87
+action_37 (111#) = happyShift action_24
+action_37 (115#) = happyShift action_25
+action_37 (118#) = happyShift action_27
+action_37 (119#) = happyShift action_28
+action_37 (120#) = happyShift action_29
+action_37 (121#) = happyShift action_30
+action_37 (122#) = happyShift action_31
+action_37 (123#) = happyShift action_32
+action_37 (131#) = happyShift action_35
+action_37 (167#) = happyShift action_44
+action_37 (170#) = happyShift action_6
+action_37 (171#) = happyShift action_45
+action_37 (172#) = happyShift action_46
+action_37 (173#) = happyShift action_47
+action_37 (174#) = happyShift action_48
+action_37 (8#) = happyGoto action_7
+action_37 (9#) = happyGoto action_8
+action_37 (10#) = happyGoto action_9
+action_37 (11#) = happyGoto action_10
+action_37 (12#) = happyGoto action_84
+action_37 (58#) = happyGoto action_12
+action_37 (59#) = happyGoto action_95
+action_37 (72#) = happyGoto action_19
+action_37 x = happyTcHack x happyFail
+
+action_38 (167#) = happyShift action_94
+action_38 (174#) = happyShift action_48
+action_38 (12#) = happyGoto action_92
+action_38 (53#) = happyGoto action_80
+action_38 (56#) = happyGoto action_81
+action_38 (57#) = happyGoto action_93
+action_38 x = happyTcHack x happyReduce_137
+
+action_39 (97#) = happyShift action_22
+action_39 (98#) = happyShift action_87
+action_39 (111#) = happyShift action_24
+action_39 (115#) = happyShift action_25
+action_39 (118#) = happyShift action_27
+action_39 (119#) = happyShift action_28
+action_39 (120#) = happyShift action_29
+action_39 (121#) = happyShift action_30
+action_39 (122#) = happyShift action_31
+action_39 (123#) = happyShift action_32
+action_39 (131#) = happyShift action_35
+action_39 (167#) = happyShift action_44
+action_39 (170#) = happyShift action_6
+action_39 (171#) = happyShift action_45
+action_39 (172#) = happyShift action_46
+action_39 (173#) = happyShift action_47
+action_39 (174#) = happyShift action_48
+action_39 (8#) = happyGoto action_7
+action_39 (9#) = happyGoto action_8
+action_39 (10#) = happyGoto action_9
+action_39 (11#) = happyGoto action_10
+action_39 (12#) = happyGoto action_84
+action_39 (58#) = happyGoto action_12
+action_39 (59#) = happyGoto action_91
+action_39 (72#) = happyGoto action_19
+action_39 x = happyTcHack x happyFail
+
+action_40 (167#) = happyShift action_90
+action_40 x = happyTcHack x happyFail
+
+action_41 (167#) = happyShift action_89
+action_41 x = happyTcHack x happyFail
+
+action_42 (97#) = happyShift action_86
+action_42 (98#) = happyShift action_87
+action_42 (111#) = happyShift action_24
+action_42 (115#) = happyShift action_25
+action_42 (118#) = happyShift action_27
+action_42 (119#) = happyShift action_28
+action_42 (120#) = happyShift action_29
+action_42 (121#) = happyShift action_30
+action_42 (122#) = happyShift action_31
+action_42 (123#) = happyShift action_32
+action_42 (131#) = happyShift action_35
+action_42 (167#) = happyShift action_88
+action_42 (170#) = happyShift action_6
+action_42 (171#) = happyShift action_45
+action_42 (172#) = happyShift action_46
+action_42 (173#) = happyShift action_47
+action_42 (174#) = happyShift action_48
+action_42 (8#) = happyGoto action_7
+action_42 (9#) = happyGoto action_8
+action_42 (10#) = happyGoto action_9
+action_42 (11#) = happyGoto action_10
+action_42 (12#) = happyGoto action_84
+action_42 (58#) = happyGoto action_85
+action_42 (72#) = happyGoto action_19
+action_42 x = happyTcHack x happyFail
+
+action_43 (167#) = happyShift action_83
+action_43 x = happyTcHack x happyFail
+
+action_44 (174#) = happyShift action_48
+action_44 (12#) = happyGoto action_79
+action_44 (53#) = happyGoto action_80
+action_44 (56#) = happyGoto action_81
+action_44 (57#) = happyGoto action_82
+action_44 x = happyTcHack x happyReduce_137
+
+action_45 x = happyTcHack x happyReduce_6
+
+action_46 x = happyTcHack x happyReduce_7
+
+action_47 x = happyTcHack x happyReduce_8
+
+action_48 x = happyTcHack x happyReduce_9
+
+action_49 (1#) = happyAccept
+action_49 x = happyTcHack x happyFail
+
+action_50 (127#) = happyShift action_63
+action_50 (130#) = happyShift action_64
+action_50 (140#) = happyShift action_65
+action_50 (141#) = happyShift action_66
+action_50 (156#) = happyShift action_67
+action_50 (161#) = happyShift action_68
+action_50 (23#) = happyGoto action_78
+action_50 x = happyTcHack x happyFail
+
+action_51 x = happyTcHack x happyReduce_61
+
+action_52 (176#) = happyAccept
+action_52 x = happyTcHack x happyFail
+
+action_53 (25#) = happyGoto action_77
+action_53 x = happyTcHack x happyReduce_48
+
+action_54 (105#) = happyShift action_74
+action_54 (107#) = happyShift action_75
+action_54 (108#) = happyShift action_76
+action_54 (171#) = happyShift action_45
+action_54 (174#) = happyShift action_48
+action_54 (9#) = happyGoto action_70
+action_54 (12#) = happyGoto action_71
+action_54 (92#) = happyGoto action_72
+action_54 (93#) = happyGoto action_73
+action_54 x = happyTcHack x happyFail
+
+action_55 (110#) = happyShift action_69
+action_55 (176#) = happyAccept
+action_55 x = happyTcHack x happyFail
+
+action_56 (127#) = happyShift action_63
+action_56 (130#) = happyShift action_64
+action_56 (140#) = happyShift action_65
+action_56 (141#) = happyShift action_66
+action_56 (156#) = happyShift action_67
+action_56 (161#) = happyShift action_68
+action_56 (23#) = happyGoto action_62
+action_56 x = happyTcHack x happyFail
+
+action_57 (174#) = happyShift action_48
+action_57 (12#) = happyGoto action_61
+action_57 x = happyTcHack x happyFail
+
+action_58 (176#) = happyAccept
+action_58 x = happyTcHack x happyFail
+
+action_59 (136#) = happyShift action_57
+action_59 (139#) = happyShift action_51
+action_59 (176#) = happyReduce_10
+action_59 (15#) = happyGoto action_60
+action_59 (30#) = happyGoto action_56
+action_59 x = happyTcHack x happyReduce_60
+
+action_60 (110#) = happyShift action_69
+action_60 x = happyTcHack x happyReduce_12
+
+action_61 (112#) = happyShift action_239
+action_61 x = happyTcHack x happyFail
+
+action_62 (112#) = happyShift action_238
+action_62 x = happyTcHack x happyFail
+
+action_63 (174#) = happyShift action_48
+action_63 (12#) = happyGoto action_237
+action_63 x = happyTcHack x happyFail
+
+action_64 (174#) = happyShift action_48
+action_64 (12#) = happyGoto action_236
+action_64 x = happyTcHack x happyFail
+
+action_65 (174#) = happyShift action_48
+action_65 (12#) = happyGoto action_235
+action_65 x = happyTcHack x happyFail
+
+action_66 (174#) = happyShift action_48
+action_66 (12#) = happyGoto action_234
+action_66 x = happyTcHack x happyFail
+
+action_67 (174#) = happyShift action_48
+action_67 (12#) = happyGoto action_233
+action_67 x = happyTcHack x happyFail
+
+action_68 (174#) = happyShift action_48
+action_68 (12#) = happyGoto action_232
+action_68 x = happyTcHack x happyFail
+
+action_69 x = happyTcHack x happyReduce_13
+
+action_70 x = happyTcHack x happyReduce_267
+
+action_71 (105#) = happyShift action_74
+action_71 (107#) = happyShift action_75
+action_71 (108#) = happyShift action_76
+action_71 (171#) = happyShift action_45
+action_71 (174#) = happyShift action_48
+action_71 (9#) = happyGoto action_70
+action_71 (12#) = happyGoto action_71
+action_71 (92#) = happyGoto action_231
+action_71 x = happyTcHack x happyReduce_268
+
+action_72 (110#) = happyShift action_230
+action_72 x = happyTcHack x happyFail
+
+action_73 x = happyTcHack x happyReduce_266
+
+action_74 (105#) = happyShift action_74
+action_74 (107#) = happyShift action_75
+action_74 (108#) = happyShift action_76
+action_74 (171#) = happyShift action_45
+action_74 (174#) = happyShift action_48
+action_74 (9#) = happyGoto action_70
+action_74 (12#) = happyGoto action_71
+action_74 (92#) = happyGoto action_229
+action_74 x = happyTcHack x happyFail
+
+action_75 (105#) = happyShift action_74
+action_75 (107#) = happyShift action_75
+action_75 (108#) = happyShift action_76
+action_75 (171#) = happyShift action_45
+action_75 (174#) = happyShift action_48
+action_75 (9#) = happyGoto action_70
+action_75 (12#) = happyGoto action_71
+action_75 (92#) = happyGoto action_228
+action_75 x = happyTcHack x happyFail
+
+action_76 (105#) = happyShift action_74
+action_76 (107#) = happyShift action_75
+action_76 (108#) = happyShift action_76
+action_76 (171#) = happyShift action_45
+action_76 (174#) = happyShift action_48
+action_76 (9#) = happyGoto action_70
+action_76 (12#) = happyGoto action_71
+action_76 (92#) = happyGoto action_227
+action_76 x = happyTcHack x happyFail
+
+action_77 (129#) = happyShift action_210
+action_77 (131#) = happyShift action_211
+action_77 (132#) = happyShift action_212
+action_77 (133#) = happyShift action_213
+action_77 (135#) = happyShift action_214
+action_77 (143#) = happyShift action_215
+action_77 (144#) = happyShift action_216
+action_77 (145#) = happyShift action_217
+action_77 (146#) = happyShift action_218
+action_77 (149#) = happyShift action_219
+action_77 (151#) = happyShift action_220
+action_77 (152#) = happyShift action_221
+action_77 (153#) = happyShift action_222
+action_77 (155#) = happyShift action_223
+action_77 (160#) = happyShift action_224
+action_77 (161#) = happyShift action_225
+action_77 (163#) = happyShift action_226
+action_77 (35#) = happyGoto action_209
+action_77 x = happyTcHack x happyReduce_264
+
+action_78 (112#) = happyShift action_208
+action_78 x = happyTcHack x happyFail
+
+action_79 (104#) = happyShift action_190
+action_79 (107#) = happyShift action_206
+action_79 (169#) = happyShift action_207
+action_79 x = happyTcHack x happyReduce_128
+
+action_80 (109#) = happyShift action_204
+action_80 (112#) = happyShift action_205
+action_80 x = happyTcHack x happyFail
+
+action_81 (110#) = happyShift action_203
+action_81 x = happyTcHack x happyReduce_138
+
+action_82 (169#) = happyShift action_202
+action_82 x = happyTcHack x happyFail
+
+action_83 (95#) = happyShift action_21
+action_83 (97#) = happyShift action_22
+action_83 (98#) = happyShift action_23
+action_83 (111#) = happyShift action_24
+action_83 (115#) = happyShift action_25
+action_83 (117#) = happyShift action_26
+action_83 (118#) = happyShift action_27
+action_83 (119#) = happyShift action_28
+action_83 (120#) = happyShift action_29
+action_83 (121#) = happyShift action_30
+action_83 (122#) = happyShift action_31
+action_83 (123#) = happyShift action_32
+action_83 (124#) = happyShift action_33
+action_83 (128#) = happyShift action_34
+action_83 (131#) = happyShift action_35
+action_83 (134#) = happyShift action_36
+action_83 (137#) = happyShift action_37
+action_83 (142#) = happyShift action_38
+action_83 (153#) = happyShift action_39
+action_83 (154#) = happyShift action_40
+action_83 (158#) = happyShift action_41
+action_83 (159#) = happyShift action_42
+action_83 (164#) = happyShift action_43
+action_83 (167#) = happyShift action_44
+action_83 (170#) = happyShift action_6
+action_83 (171#) = happyShift action_45
+action_83 (172#) = happyShift action_46
+action_83 (173#) = happyShift action_47
+action_83 (174#) = happyShift action_48
+action_83 (8#) = happyGoto action_7
+action_83 (9#) = happyGoto action_8
+action_83 (10#) = happyGoto action_9
+action_83 (11#) = happyGoto action_10
+action_83 (12#) = happyGoto action_11
+action_83 (58#) = happyGoto action_12
+action_83 (59#) = happyGoto action_13
+action_83 (60#) = happyGoto action_14
+action_83 (61#) = happyGoto action_15
+action_83 (62#) = happyGoto action_16
+action_83 (63#) = happyGoto action_192
+action_83 (64#) = happyGoto action_18
+action_83 (65#) = happyGoto action_201
+action_83 (72#) = happyGoto action_19
+action_83 (77#) = happyGoto action_20
+action_83 x = happyTcHack x happyReduce_193
+
+action_84 x = happyTcHack x happyReduce_140
+
+action_85 (123#) = happyShift action_199
+action_85 (167#) = happyShift action_200
+action_85 x = happyTcHack x happyFail
+
+action_86 (174#) = happyShift action_48
+action_86 (12#) = happyGoto action_198
+action_86 x = happyTcHack x happyFail
+
+action_87 (95#) = happyShift action_21
+action_87 (97#) = happyShift action_22
+action_87 (98#) = happyShift action_23
+action_87 (111#) = happyShift action_24
+action_87 (115#) = happyShift action_25
+action_87 (117#) = happyShift action_26
+action_87 (118#) = happyShift action_27
+action_87 (119#) = happyShift action_28
+action_87 (120#) = happyShift action_29
+action_87 (121#) = happyShift action_30
+action_87 (122#) = happyShift action_31
+action_87 (123#) = happyShift action_32
+action_87 (124#) = happyShift action_33
+action_87 (128#) = happyShift action_34
+action_87 (131#) = happyShift action_35
+action_87 (134#) = happyShift action_36
+action_87 (137#) = happyShift action_113
+action_87 (142#) = happyShift action_38
+action_87 (153#) = happyShift action_39
+action_87 (154#) = happyShift action_40
+action_87 (158#) = happyShift action_41
+action_87 (159#) = happyShift action_42
+action_87 (164#) = happyShift action_43
+action_87 (167#) = happyShift action_44
+action_87 (170#) = happyShift action_6
+action_87 (171#) = happyShift action_45
+action_87 (172#) = happyShift action_46
+action_87 (173#) = happyShift action_47
+action_87 (174#) = happyShift action_48
+action_87 (8#) = happyGoto action_7
+action_87 (9#) = happyGoto action_8
+action_87 (10#) = happyGoto action_9
+action_87 (11#) = happyGoto action_10
+action_87 (12#) = happyGoto action_11
+action_87 (58#) = happyGoto action_12
+action_87 (59#) = happyGoto action_13
+action_87 (60#) = happyGoto action_14
+action_87 (61#) = happyGoto action_15
+action_87 (62#) = happyGoto action_16
+action_87 (63#) = happyGoto action_111
+action_87 (64#) = happyGoto action_18
+action_87 (72#) = happyGoto action_19
+action_87 (77#) = happyGoto action_20
+action_87 x = happyTcHack x happyFail
+
+action_88 (95#) = happyShift action_120
+action_88 (98#) = happyShift action_121
+action_88 (105#) = happyShift action_164
+action_88 (111#) = happyShift action_122
+action_88 (115#) = happyShift action_123
+action_88 (123#) = happyShift action_124
+action_88 (126#) = happyShift action_125
+action_88 (167#) = happyShift action_126
+action_88 (170#) = happyShift action_6
+action_88 (171#) = happyShift action_45
+action_88 (172#) = happyShift action_46
+action_88 (174#) = happyShift action_48
+action_88 (8#) = happyGoto action_115
+action_88 (9#) = happyGoto action_116
+action_88 (10#) = happyGoto action_117
+action_88 (12#) = happyGoto action_194
+action_88 (53#) = happyGoto action_80
+action_88 (56#) = happyGoto action_81
+action_88 (57#) = happyGoto action_82
+action_88 (67#) = happyGoto action_159
+action_88 (68#) = happyGoto action_160
+action_88 (69#) = happyGoto action_195
+action_88 (82#) = happyGoto action_196
+action_88 (83#) = happyGoto action_197
+action_88 x = happyTcHack x happyReduce_137
+
+action_89 (95#) = happyShift action_21
+action_89 (97#) = happyShift action_22
+action_89 (98#) = happyShift action_23
+action_89 (111#) = happyShift action_24
+action_89 (115#) = happyShift action_25
+action_89 (117#) = happyShift action_26
+action_89 (118#) = happyShift action_27
+action_89 (119#) = happyShift action_28
+action_89 (120#) = happyShift action_29
+action_89 (121#) = happyShift action_30
+action_89 (122#) = happyShift action_31
+action_89 (123#) = happyShift action_32
+action_89 (124#) = happyShift action_33
+action_89 (128#) = happyShift action_34
+action_89 (131#) = happyShift action_35
+action_89 (134#) = happyShift action_36
+action_89 (137#) = happyShift action_37
+action_89 (142#) = happyShift action_38
+action_89 (153#) = happyShift action_39
+action_89 (154#) = happyShift action_40
+action_89 (158#) = happyShift action_41
+action_89 (159#) = happyShift action_42
+action_89 (164#) = happyShift action_43
+action_89 (167#) = happyShift action_44
+action_89 (170#) = happyShift action_6
+action_89 (171#) = happyShift action_45
+action_89 (172#) = happyShift action_46
+action_89 (173#) = happyShift action_47
+action_89 (174#) = happyShift action_48
+action_89 (8#) = happyGoto action_7
+action_89 (9#) = happyGoto action_8
+action_89 (10#) = happyGoto action_9
+action_89 (11#) = happyGoto action_10
+action_89 (12#) = happyGoto action_11
+action_89 (58#) = happyGoto action_12
+action_89 (59#) = happyGoto action_13
+action_89 (60#) = happyGoto action_14
+action_89 (61#) = happyGoto action_15
+action_89 (62#) = happyGoto action_16
+action_89 (63#) = happyGoto action_192
+action_89 (64#) = happyGoto action_18
+action_89 (65#) = happyGoto action_193
+action_89 (72#) = happyGoto action_19
+action_89 (77#) = happyGoto action_20
+action_89 x = happyTcHack x happyReduce_193
+
+action_90 (95#) = happyShift action_21
+action_90 (97#) = happyShift action_22
+action_90 (98#) = happyShift action_23
+action_90 (111#) = happyShift action_24
+action_90 (115#) = happyShift action_25
+action_90 (117#) = happyShift action_26
+action_90 (118#) = happyShift action_27
+action_90 (119#) = happyShift action_28
+action_90 (120#) = happyShift action_29
+action_90 (121#) = happyShift action_30
+action_90 (122#) = happyShift action_31
+action_90 (123#) = happyShift action_32
+action_90 (124#) = happyShift action_33
+action_90 (128#) = happyShift action_34
+action_90 (131#) = happyShift action_35
+action_90 (134#) = happyShift action_36
+action_90 (137#) = happyShift action_37
+action_90 (142#) = happyShift action_38
+action_90 (153#) = happyShift action_39
+action_90 (154#) = happyShift action_40
+action_90 (158#) = happyShift action_41
+action_90 (159#) = happyShift action_42
+action_90 (164#) = happyShift action_43
+action_90 (167#) = happyShift action_44
+action_90 (170#) = happyShift action_6
+action_90 (171#) = happyShift action_45
+action_90 (172#) = happyShift action_46
+action_90 (173#) = happyShift action_47
+action_90 (174#) = happyShift action_48
+action_90 (8#) = happyGoto action_7
+action_90 (9#) = happyGoto action_8
+action_90 (10#) = happyGoto action_9
+action_90 (11#) = happyGoto action_10
+action_90 (12#) = happyGoto action_11
+action_90 (58#) = happyGoto action_12
+action_90 (59#) = happyGoto action_13
+action_90 (60#) = happyGoto action_14
+action_90 (61#) = happyGoto action_15
+action_90 (62#) = happyGoto action_16
+action_90 (63#) = happyGoto action_191
+action_90 (64#) = happyGoto action_18
+action_90 (72#) = happyGoto action_19
+action_90 (77#) = happyGoto action_20
+action_90 x = happyTcHack x happyFail
+
+action_91 (107#) = happyShift action_136
+action_91 x = happyTcHack x happyReduce_172
+
+action_92 (104#) = happyShift action_190
+action_92 x = happyTcHack x happyReduce_128
+
+action_93 (137#) = happyShift action_189
+action_93 x = happyTcHack x happyFail
+
+action_94 (174#) = happyShift action_48
+action_94 (12#) = happyGoto action_92
+action_94 (53#) = happyGoto action_80
+action_94 (56#) = happyGoto action_81
+action_94 (57#) = happyGoto action_188
+action_94 x = happyTcHack x happyReduce_137
+
+action_95 (107#) = happyShift action_136
+action_95 (171#) = happyShift action_45
+action_95 (9#) = happyGoto action_187
+action_95 x = happyTcHack x happyFail
+
+action_96 (95#) = happyShift action_120
+action_96 (98#) = happyShift action_121
+action_96 (111#) = happyShift action_122
+action_96 (115#) = happyShift action_123
+action_96 (123#) = happyShift action_124
+action_96 (126#) = happyShift action_125
+action_96 (167#) = happyShift action_126
+action_96 (170#) = happyShift action_6
+action_96 (171#) = happyShift action_45
+action_96 (172#) = happyShift action_46
+action_96 (174#) = happyShift action_48
+action_96 (8#) = happyGoto action_115
+action_96 (9#) = happyGoto action_116
+action_96 (10#) = happyGoto action_117
+action_96 (12#) = happyGoto action_118
+action_96 (67#) = happyGoto action_183
+action_96 (74#) = happyGoto action_184
+action_96 (84#) = happyGoto action_185
+action_96 (85#) = happyGoto action_186
+action_96 x = happyTcHack x happyReduce_253
+
+action_97 (147#) = happyShift action_182
+action_97 x = happyTcHack x happyFail
+
+action_98 x = happyTcHack x happyReduce_234
+
+action_99 (104#) = happyShift action_181
+action_99 x = happyTcHack x happyReduce_237
+
+action_100 (106#) = happyShift action_180
+action_100 x = happyTcHack x happyFail
+
+action_101 (126#) = happyShift action_102
+action_101 (174#) = happyShift action_48
+action_101 (12#) = happyGoto action_98
+action_101 (75#) = happyGoto action_99
+action_101 (76#) = happyGoto action_179
+action_101 x = happyTcHack x happyReduce_236
+
+action_102 x = happyTcHack x happyReduce_235
+
+action_103 (125#) = happyShift action_178
+action_103 x = happyTcHack x happyFail
+
+action_104 (97#) = happyShift action_86
+action_104 (98#) = happyShift action_87
+action_104 (111#) = happyShift action_24
+action_104 (115#) = happyShift action_25
+action_104 (118#) = happyShift action_27
+action_104 (119#) = happyShift action_28
+action_104 (120#) = happyShift action_29
+action_104 (121#) = happyShift action_30
+action_104 (122#) = happyShift action_31
+action_104 (123#) = happyShift action_32
+action_104 (131#) = happyShift action_35
+action_104 (167#) = happyShift action_139
+action_104 (170#) = happyShift action_6
+action_104 (171#) = happyShift action_45
+action_104 (172#) = happyShift action_46
+action_104 (173#) = happyShift action_47
+action_104 (174#) = happyShift action_48
+action_104 (8#) = happyGoto action_7
+action_104 (9#) = happyGoto action_8
+action_104 (10#) = happyGoto action_9
+action_104 (11#) = happyGoto action_10
+action_104 (12#) = happyGoto action_84
+action_104 (58#) = happyGoto action_176
+action_104 (66#) = happyGoto action_177
+action_104 (72#) = happyGoto action_19
+action_104 x = happyTcHack x happyReduce_196
+
+action_105 x = happyTcHack x happyReduce_148
+
+action_106 x = happyTcHack x happyReduce_174
+
+action_107 (109#) = happyShift action_175
+action_107 x = happyTcHack x happyReduce_241
+
+action_108 (104#) = happyShift action_174
+action_108 x = happyTcHack x happyReduce_244
+
+action_109 (114#) = happyShift action_173
+action_109 x = happyTcHack x happyFail
+
+action_110 (104#) = happyReduce_234
+action_110 (109#) = happyReduce_234
+action_110 (116#) = happyShift action_137
+action_110 x = happyTcHack x happyReduce_140
+
+action_111 (99#) = happyShift action_172
+action_111 x = happyTcHack x happyFail
+
+action_112 (109#) = happyShift action_171
+action_112 x = happyTcHack x happyFail
+
+action_113 (97#) = happyShift action_22
+action_113 (98#) = happyShift action_87
+action_113 (111#) = happyShift action_24
+action_113 (115#) = happyShift action_25
+action_113 (118#) = happyShift action_27
+action_113 (119#) = happyShift action_28
+action_113 (120#) = happyShift action_29
+action_113 (121#) = happyShift action_30
+action_113 (122#) = happyShift action_31
+action_113 (123#) = happyShift action_32
+action_113 (131#) = happyShift action_35
+action_113 (167#) = happyShift action_44
+action_113 (170#) = happyShift action_6
+action_113 (171#) = happyShift action_45
+action_113 (172#) = happyShift action_46
+action_113 (173#) = happyShift action_47
+action_113 (174#) = happyShift action_48
+action_113 (8#) = happyGoto action_7
+action_113 (9#) = happyGoto action_8
+action_113 (10#) = happyGoto action_9
+action_113 (11#) = happyGoto action_10
+action_113 (12#) = happyGoto action_170
+action_113 (58#) = happyGoto action_12
+action_113 (59#) = happyGoto action_95
+action_113 (72#) = happyGoto action_19
+action_113 x = happyTcHack x happyFail
+
+action_114 (97#) = happyShift action_168
+action_114 (107#) = happyShift action_169
+action_114 x = happyTcHack x happyFail
+
+action_115 x = happyTcHack x happyReduce_206
+
+action_116 x = happyTcHack x happyReduce_208
+
+action_117 x = happyTcHack x happyReduce_207
+
+action_118 (107#) = happyShift action_167
+action_118 x = happyTcHack x happyReduce_203
+
+action_119 x = happyTcHack x happyReduce_171
+
+action_120 (174#) = happyShift action_48
+action_120 (12#) = happyGoto action_166
+action_120 x = happyTcHack x happyFail
+
+action_121 (95#) = happyShift action_120
+action_121 (98#) = happyShift action_121
+action_121 (105#) = happyShift action_164
+action_121 (111#) = happyShift action_122
+action_121 (115#) = happyShift action_123
+action_121 (123#) = happyShift action_124
+action_121 (126#) = happyShift action_125
+action_121 (167#) = happyShift action_126
+action_121 (170#) = happyShift action_6
+action_121 (171#) = happyShift action_45
+action_121 (172#) = happyShift action_46
+action_121 (174#) = happyShift action_48
+action_121 (8#) = happyGoto action_115
+action_121 (9#) = happyGoto action_116
+action_121 (10#) = happyGoto action_117
+action_121 (12#) = happyGoto action_158
+action_121 (67#) = happyGoto action_159
+action_121 (68#) = happyGoto action_160
+action_121 (69#) = happyGoto action_165
+action_121 x = happyTcHack x happyFail
+
+action_122 (95#) = happyShift action_120
+action_122 (98#) = happyShift action_121
+action_122 (105#) = happyShift action_164
+action_122 (111#) = happyShift action_122
+action_122 (115#) = happyShift action_123
+action_122 (123#) = happyShift action_124
+action_122 (126#) = happyShift action_125
+action_122 (167#) = happyShift action_126
+action_122 (170#) = happyShift action_6
+action_122 (171#) = happyShift action_45
+action_122 (172#) = happyShift action_46
+action_122 (174#) = happyShift action_48
+action_122 (8#) = happyGoto action_115
+action_122 (9#) = happyGoto action_116
+action_122 (10#) = happyGoto action_117
+action_122 (12#) = happyGoto action_158
+action_122 (67#) = happyGoto action_159
+action_122 (68#) = happyGoto action_160
+action_122 (69#) = happyGoto action_161
+action_122 (79#) = happyGoto action_162
+action_122 (81#) = happyGoto action_163
+action_122 x = happyTcHack x happyReduce_246
+
+action_123 x = happyTcHack x happyReduce_198
+
+action_124 (171#) = happyShift action_45
+action_124 (9#) = happyGoto action_157
+action_124 x = happyTcHack x happyFail
+
+action_125 x = happyTcHack x happyReduce_202
+
+action_126 (174#) = happyShift action_48
+action_126 (12#) = happyGoto action_153
+action_126 (53#) = happyGoto action_154
+action_126 (70#) = happyGoto action_155
+action_126 (73#) = happyGoto action_156
+action_126 x = happyTcHack x happyReduce_229
+
+action_127 (95#) = happyShift action_21
+action_127 (97#) = happyShift action_22
+action_127 (98#) = happyShift action_23
+action_127 (111#) = happyShift action_24
+action_127 (115#) = happyShift action_25
+action_127 (117#) = happyShift action_26
+action_127 (118#) = happyShift action_27
+action_127 (119#) = happyShift action_28
+action_127 (120#) = happyShift action_29
+action_127 (121#) = happyShift action_30
+action_127 (122#) = happyShift action_31
+action_127 (123#) = happyShift action_32
+action_127 (124#) = happyShift action_33
+action_127 (128#) = happyShift action_34
+action_127 (131#) = happyShift action_35
+action_127 (134#) = happyShift action_36
+action_127 (137#) = happyShift action_37
+action_127 (142#) = happyShift action_38
+action_127 (153#) = happyShift action_39
+action_127 (154#) = happyShift action_40
+action_127 (158#) = happyShift action_41
+action_127 (159#) = happyShift action_42
+action_127 (164#) = happyShift action_43
+action_127 (167#) = happyShift action_44
+action_127 (170#) = happyShift action_6
+action_127 (171#) = happyShift action_45
+action_127 (172#) = happyShift action_46
+action_127 (173#) = happyShift action_47
+action_127 (174#) = happyShift action_48
+action_127 (8#) = happyGoto action_7
+action_127 (9#) = happyGoto action_8
+action_127 (10#) = happyGoto action_9
+action_127 (11#) = happyGoto action_10
+action_127 (12#) = happyGoto action_11
+action_127 (58#) = happyGoto action_12
+action_127 (59#) = happyGoto action_13
+action_127 (60#) = happyGoto action_14
+action_127 (61#) = happyGoto action_15
+action_127 (62#) = happyGoto action_16
+action_127 (63#) = happyGoto action_152
+action_127 (64#) = happyGoto action_18
+action_127 (72#) = happyGoto action_19
+action_127 (77#) = happyGoto action_20
+action_127 x = happyTcHack x happyFail
+
+action_128 (95#) = happyShift action_21
+action_128 (97#) = happyShift action_22
+action_128 (98#) = happyShift action_87
+action_128 (111#) = happyShift action_24
+action_128 (115#) = happyShift action_25
+action_128 (117#) = happyShift action_26
+action_128 (118#) = happyShift action_27
+action_128 (119#) = happyShift action_28
+action_128 (120#) = happyShift action_29
+action_128 (121#) = happyShift action_30
+action_128 (122#) = happyShift action_31
+action_128 (123#) = happyShift action_32
+action_128 (128#) = happyShift action_34
+action_128 (131#) = happyShift action_35
+action_128 (153#) = happyShift action_39
+action_128 (154#) = happyShift action_40
+action_128 (158#) = happyShift action_41
+action_128 (159#) = happyShift action_42
+action_128 (164#) = happyShift action_43
+action_128 (167#) = happyShift action_44
+action_128 (170#) = happyShift action_6
+action_128 (171#) = happyShift action_45
+action_128 (172#) = happyShift action_46
+action_128 (173#) = happyShift action_47
+action_128 (174#) = happyShift action_48
+action_128 (8#) = happyGoto action_7
+action_128 (9#) = happyGoto action_8
+action_128 (10#) = happyGoto action_9
+action_128 (11#) = happyGoto action_10
+action_128 (12#) = happyGoto action_11
+action_128 (58#) = happyGoto action_12
+action_128 (59#) = happyGoto action_13
+action_128 (60#) = happyGoto action_149
+action_128 (61#) = happyGoto action_150
+action_128 (62#) = happyGoto action_151
+action_128 (64#) = happyGoto action_18
+action_128 (72#) = happyGoto action_19
+action_128 x = happyTcHack x happyFail
+
+action_129 (95#) = happyShift action_21
+action_129 (97#) = happyShift action_22
+action_129 (98#) = happyShift action_23
+action_129 (111#) = happyShift action_24
+action_129 (115#) = happyShift action_25
+action_129 (117#) = happyShift action_26
+action_129 (118#) = happyShift action_27
+action_129 (119#) = happyShift action_28
+action_129 (120#) = happyShift action_29
+action_129 (121#) = happyShift action_30
+action_129 (122#) = happyShift action_31
+action_129 (123#) = happyShift action_32
+action_129 (124#) = happyShift action_33
+action_129 (128#) = happyShift action_34
+action_129 (131#) = happyShift action_35
+action_129 (134#) = happyShift action_36
+action_129 (137#) = happyShift action_37
+action_129 (142#) = happyShift action_38
+action_129 (153#) = happyShift action_39
+action_129 (154#) = happyShift action_40
+action_129 (158#) = happyShift action_41
+action_129 (159#) = happyShift action_42
+action_129 (164#) = happyShift action_43
+action_129 (167#) = happyShift action_44
+action_129 (170#) = happyShift action_6
+action_129 (171#) = happyShift action_45
+action_129 (172#) = happyShift action_46
+action_129 (173#) = happyShift action_47
+action_129 (174#) = happyShift action_48
+action_129 (8#) = happyGoto action_7
+action_129 (9#) = happyGoto action_8
+action_129 (10#) = happyGoto action_9
+action_129 (11#) = happyGoto action_10
+action_129 (12#) = happyGoto action_11
+action_129 (58#) = happyGoto action_12
+action_129 (59#) = happyGoto action_13
+action_129 (60#) = happyGoto action_14
+action_129 (61#) = happyGoto action_15
+action_129 (62#) = happyGoto action_16
+action_129 (63#) = happyGoto action_148
+action_129 (64#) = happyGoto action_18
+action_129 (72#) = happyGoto action_19
+action_129 (77#) = happyGoto action_20
+action_129 x = happyTcHack x happyFail
+
+action_130 (95#) = happyShift action_21
+action_130 (97#) = happyShift action_22
+action_130 (98#) = happyShift action_87
+action_130 (111#) = happyShift action_24
+action_130 (115#) = happyShift action_25
+action_130 (117#) = happyShift action_26
+action_130 (118#) = happyShift action_27
+action_130 (119#) = happyShift action_28
+action_130 (120#) = happyShift action_29
+action_130 (121#) = happyShift action_30
+action_130 (122#) = happyShift action_31
+action_130 (123#) = happyShift action_32
+action_130 (128#) = happyShift action_34
+action_130 (131#) = happyShift action_35
+action_130 (153#) = happyShift action_39
+action_130 (154#) = happyShift action_40
+action_130 (158#) = happyShift action_41
+action_130 (159#) = happyShift action_42
+action_130 (164#) = happyShift action_43
+action_130 (167#) = happyShift action_44
+action_130 (170#) = happyShift action_6
+action_130 (171#) = happyShift action_45
+action_130 (172#) = happyShift action_46
+action_130 (173#) = happyShift action_47
+action_130 (174#) = happyShift action_48
+action_130 (8#) = happyGoto action_7
+action_130 (9#) = happyGoto action_8
+action_130 (10#) = happyGoto action_9
+action_130 (11#) = happyGoto action_10
+action_130 (12#) = happyGoto action_11
+action_130 (58#) = happyGoto action_12
+action_130 (59#) = happyGoto action_13
+action_130 (60#) = happyGoto action_147
+action_130 (72#) = happyGoto action_19
+action_130 x = happyTcHack x happyFail
+
+action_131 (95#) = happyShift action_21
+action_131 (97#) = happyShift action_22
+action_131 (98#) = happyShift action_87
+action_131 (111#) = happyShift action_24
+action_131 (115#) = happyShift action_25
+action_131 (117#) = happyShift action_26
+action_131 (118#) = happyShift action_27
+action_131 (119#) = happyShift action_28
+action_131 (120#) = happyShift action_29
+action_131 (121#) = happyShift action_30
+action_131 (122#) = happyShift action_31
+action_131 (123#) = happyShift action_32
+action_131 (128#) = happyShift action_34
+action_131 (131#) = happyShift action_35
+action_131 (153#) = happyShift action_39
+action_131 (154#) = happyShift action_40
+action_131 (158#) = happyShift action_41
+action_131 (159#) = happyShift action_42
+action_131 (164#) = happyShift action_43
+action_131 (167#) = happyShift action_44
+action_131 (170#) = happyShift action_6
+action_131 (171#) = happyShift action_45
+action_131 (172#) = happyShift action_46
+action_131 (173#) = happyShift action_47
+action_131 (174#) = happyShift action_48
+action_131 (8#) = happyGoto action_7
+action_131 (9#) = happyGoto action_8
+action_131 (10#) = happyGoto action_9
+action_131 (11#) = happyGoto action_10
+action_131 (12#) = happyGoto action_11
+action_131 (58#) = happyGoto action_12
+action_131 (59#) = happyGoto action_13
+action_131 (60#) = happyGoto action_146
+action_131 (72#) = happyGoto action_19
+action_131 x = happyTcHack x happyFail
+
+action_132 (95#) = happyShift action_21
+action_132 (97#) = happyShift action_22
+action_132 (98#) = happyShift action_87
+action_132 (111#) = happyShift action_24
+action_132 (115#) = happyShift action_25
+action_132 (117#) = happyShift action_26
+action_132 (118#) = happyShift action_27
+action_132 (119#) = happyShift action_28
+action_132 (120#) = happyShift action_29
+action_132 (121#) = happyShift action_30
+action_132 (122#) = happyShift action_31
+action_132 (123#) = happyShift action_32
+action_132 (128#) = happyShift action_34
+action_132 (131#) = happyShift action_35
+action_132 (153#) = happyShift action_39
+action_132 (154#) = happyShift action_40
+action_132 (158#) = happyShift action_41
+action_132 (159#) = happyShift action_42
+action_132 (164#) = happyShift action_43
+action_132 (167#) = happyShift action_44
+action_132 (170#) = happyShift action_6
+action_132 (171#) = happyShift action_45
+action_132 (172#) = happyShift action_46
+action_132 (173#) = happyShift action_47
+action_132 (174#) = happyShift action_48
+action_132 (8#) = happyGoto action_7
+action_132 (9#) = happyGoto action_8
+action_132 (10#) = happyGoto action_9
+action_132 (11#) = happyGoto action_10
+action_132 (12#) = happyGoto action_11
+action_132 (58#) = happyGoto action_12
+action_132 (59#) = happyGoto action_13
+action_132 (60#) = happyGoto action_145
+action_132 (72#) = happyGoto action_19
+action_132 x = happyTcHack x happyFail
+
+action_133 (95#) = happyShift action_21
+action_133 (97#) = happyShift action_22
+action_133 (98#) = happyShift action_23
+action_133 (111#) = happyShift action_24
+action_133 (115#) = happyShift action_25
+action_133 (117#) = happyShift action_26
+action_133 (118#) = happyShift action_27
+action_133 (119#) = happyShift action_28
+action_133 (120#) = happyShift action_29
+action_133 (121#) = happyShift action_30
+action_133 (122#) = happyShift action_31
+action_133 (123#) = happyShift action_32
+action_133 (124#) = happyShift action_33
+action_133 (128#) = happyShift action_34
+action_133 (131#) = happyShift action_35
+action_133 (134#) = happyShift action_36
+action_133 (137#) = happyShift action_37
+action_133 (142#) = happyShift action_38
+action_133 (153#) = happyShift action_39
+action_133 (154#) = happyShift action_40
+action_133 (158#) = happyShift action_41
+action_133 (159#) = happyShift action_42
+action_133 (164#) = happyShift action_43
+action_133 (167#) = happyShift action_44
+action_133 (170#) = happyShift action_6
+action_133 (171#) = happyShift action_45
+action_133 (172#) = happyShift action_46
+action_133 (173#) = happyShift action_47
+action_133 (174#) = happyShift action_48
+action_133 (8#) = happyGoto action_7
+action_133 (9#) = happyGoto action_8
+action_133 (10#) = happyGoto action_9
+action_133 (11#) = happyGoto action_10
+action_133 (12#) = happyGoto action_11
+action_133 (58#) = happyGoto action_12
+action_133 (59#) = happyGoto action_13
+action_133 (60#) = happyGoto action_14
+action_133 (61#) = happyGoto action_15
+action_133 (62#) = happyGoto action_16
+action_133 (63#) = happyGoto action_144
+action_133 (64#) = happyGoto action_18
+action_133 (72#) = happyGoto action_19
+action_133 (77#) = happyGoto action_20
+action_133 x = happyTcHack x happyFail
+
+action_134 (167#) = happyShift action_143
+action_134 x = happyTcHack x happyFail
+
+action_135 (107#) = happyShift action_136
+action_135 x = happyTcHack x happyReduce_162
+
+action_136 (96#) = happyShift action_142
+action_136 (174#) = happyShift action_48
+action_136 (12#) = happyGoto action_140
+action_136 (71#) = happyGoto action_141
+action_136 x = happyTcHack x happyFail
+
+action_137 (97#) = happyShift action_86
+action_137 (98#) = happyShift action_87
+action_137 (111#) = happyShift action_24
+action_137 (115#) = happyShift action_25
+action_137 (118#) = happyShift action_27
+action_137 (119#) = happyShift action_28
+action_137 (120#) = happyShift action_29
+action_137 (121#) = happyShift action_30
+action_137 (122#) = happyShift action_31
+action_137 (123#) = happyShift action_32
+action_137 (131#) = happyShift action_35
+action_137 (167#) = happyShift action_139
+action_137 (170#) = happyShift action_6
+action_137 (171#) = happyShift action_45
+action_137 (172#) = happyShift action_46
+action_137 (173#) = happyShift action_47
+action_137 (174#) = happyShift action_48
+action_137 (8#) = happyGoto action_7
+action_137 (9#) = happyGoto action_8
+action_137 (10#) = happyGoto action_9
+action_137 (11#) = happyGoto action_10
+action_137 (12#) = happyGoto action_84
+action_137 (58#) = happyGoto action_138
+action_137 (72#) = happyGoto action_19
+action_137 x = happyTcHack x happyFail
+
+action_138 x = happyTcHack x happyReduce_170
+
+action_139 (174#) = happyShift action_48
+action_139 (12#) = happyGoto action_348
+action_139 (53#) = happyGoto action_80
+action_139 (56#) = happyGoto action_81
+action_139 (57#) = happyGoto action_82
+action_139 x = happyTcHack x happyReduce_137
+
+action_140 x = happyTcHack x happyReduce_222
+
+action_141 x = happyTcHack x happyReduce_158
+
+action_142 (170#) = happyShift action_6
+action_142 (8#) = happyGoto action_347
+action_142 x = happyTcHack x happyFail
+
+action_143 (174#) = happyShift action_48
+action_143 (12#) = happyGoto action_92
+action_143 (53#) = happyGoto action_80
+action_143 (56#) = happyGoto action_81
+action_143 (57#) = happyGoto action_346
+action_143 x = happyTcHack x happyReduce_137
+
+action_144 x = happyTcHack x happyReduce_185
+
+action_145 (97#) = happyShift action_22
+action_145 (98#) = happyShift action_87
+action_145 (111#) = happyShift action_24
+action_145 (115#) = happyShift action_25
+action_145 (118#) = happyShift action_27
+action_145 (119#) = happyShift action_28
+action_145 (120#) = happyShift action_29
+action_145 (121#) = happyShift action_30
+action_145 (122#) = happyShift action_31
+action_145 (123#) = happyShift action_32
+action_145 (131#) = happyShift action_35
+action_145 (167#) = happyShift action_44
+action_145 (170#) = happyShift action_6
+action_145 (171#) = happyShift action_45
+action_145 (172#) = happyShift action_46
+action_145 (173#) = happyShift action_47
+action_145 (174#) = happyShift action_48
+action_145 (8#) = happyGoto action_7
+action_145 (9#) = happyGoto action_8
+action_145 (10#) = happyGoto action_9
+action_145 (11#) = happyGoto action_10
+action_145 (12#) = happyGoto action_84
+action_145 (58#) = happyGoto action_12
+action_145 (59#) = happyGoto action_135
+action_145 (72#) = happyGoto action_19
+action_145 x = happyTcHack x happyReduce_177
+
+action_146 (97#) = happyShift action_22
+action_146 (98#) = happyShift action_87
+action_146 (111#) = happyShift action_24
+action_146 (115#) = happyShift action_25
+action_146 (118#) = happyShift action_27
+action_146 (119#) = happyShift action_28
+action_146 (120#) = happyShift action_29
+action_146 (121#) = happyShift action_30
+action_146 (122#) = happyShift action_31
+action_146 (123#) = happyShift action_32
+action_146 (131#) = happyShift action_35
+action_146 (167#) = happyShift action_44
+action_146 (170#) = happyShift action_6
+action_146 (171#) = happyShift action_45
+action_146 (172#) = happyShift action_46
+action_146 (173#) = happyShift action_47
+action_146 (174#) = happyShift action_48
+action_146 (8#) = happyGoto action_7
+action_146 (9#) = happyGoto action_8
+action_146 (10#) = happyGoto action_9
+action_146 (11#) = happyGoto action_10
+action_146 (12#) = happyGoto action_84
+action_146 (58#) = happyGoto action_12
+action_146 (59#) = happyGoto action_135
+action_146 (72#) = happyGoto action_19
+action_146 x = happyTcHack x happyReduce_176
+
+action_147 (97#) = happyShift action_22
+action_147 (98#) = happyShift action_87
+action_147 (111#) = happyShift action_24
+action_147 (115#) = happyShift action_25
+action_147 (118#) = happyShift action_27
+action_147 (119#) = happyShift action_28
+action_147 (120#) = happyShift action_29
+action_147 (121#) = happyShift action_30
+action_147 (122#) = happyShift action_31
+action_147 (123#) = happyShift action_32
+action_147 (131#) = happyShift action_35
+action_147 (167#) = happyShift action_44
+action_147 (170#) = happyShift action_6
+action_147 (171#) = happyShift action_45
+action_147 (172#) = happyShift action_46
+action_147 (173#) = happyShift action_47
+action_147 (174#) = happyShift action_48
+action_147 (8#) = happyGoto action_7
+action_147 (9#) = happyGoto action_8
+action_147 (10#) = happyGoto action_9
+action_147 (11#) = happyGoto action_10
+action_147 (12#) = happyGoto action_84
+action_147 (58#) = happyGoto action_12
+action_147 (59#) = happyGoto action_135
+action_147 (72#) = happyGoto action_19
+action_147 x = happyTcHack x happyReduce_175
+
+action_148 x = happyTcHack x happyReduce_181
+
+action_149 (97#) = happyShift action_22
+action_149 (98#) = happyShift action_87
+action_149 (111#) = happyShift action_24
+action_149 (115#) = happyShift action_25
+action_149 (118#) = happyShift action_27
+action_149 (119#) = happyShift action_28
+action_149 (120#) = happyShift action_29
+action_149 (121#) = happyShift action_30
+action_149 (122#) = happyShift action_31
+action_149 (123#) = happyShift action_32
+action_149 (131#) = happyShift action_35
+action_149 (167#) = happyShift action_44
+action_149 (170#) = happyShift action_6
+action_149 (171#) = happyShift action_45
+action_149 (172#) = happyShift action_46
+action_149 (173#) = happyShift action_47
+action_149 (174#) = happyShift action_48
+action_149 (8#) = happyGoto action_7
+action_149 (9#) = happyGoto action_8
+action_149 (10#) = happyGoto action_9
+action_149 (11#) = happyGoto action_10
+action_149 (12#) = happyGoto action_84
+action_149 (58#) = happyGoto action_12
+action_149 (59#) = happyGoto action_135
+action_149 (72#) = happyGoto action_19
+action_149 x = happyTcHack x happyReduce_178
+
+action_150 (94#) = happyShift action_130
+action_150 (100#) = happyShift action_131
+action_150 (101#) = happyShift action_132
+action_150 x = happyTcHack x happyReduce_192
+
+action_151 x = happyTcHack x happyReduce_179
+
+action_152 x = happyTcHack x happyReduce_184
+
+action_153 (104#) = happyShift action_190
+action_153 (169#) = happyShift action_345
+action_153 x = happyTcHack x happyReduce_128
+
+action_154 (112#) = happyShift action_344
+action_154 x = happyTcHack x happyFail
+
+action_155 (110#) = happyShift action_343
+action_155 x = happyTcHack x happyReduce_230
+
+action_156 (169#) = happyShift action_342
+action_156 x = happyTcHack x happyFail
+
+action_157 (125#) = happyShift action_341
+action_157 x = happyTcHack x happyFail
+
+action_158 (95#) = happyShift action_120
+action_158 (98#) = happyShift action_121
+action_158 (107#) = happyShift action_310
+action_158 (111#) = happyShift action_122
+action_158 (115#) = happyShift action_123
+action_158 (116#) = happyShift action_311
+action_158 (123#) = happyShift action_124
+action_158 (126#) = happyShift action_125
+action_158 (167#) = happyShift action_126
+action_158 (170#) = happyShift action_6
+action_158 (171#) = happyShift action_45
+action_158 (172#) = happyShift action_46
+action_158 (174#) = happyShift action_48
+action_158 (8#) = happyGoto action_115
+action_158 (9#) = happyGoto action_116
+action_158 (10#) = happyGoto action_117
+action_158 (12#) = happyGoto action_118
+action_158 (67#) = happyGoto action_183
+action_158 (74#) = happyGoto action_309
+action_158 x = happyTcHack x happyReduce_203
+
+action_159 (100#) = happyShift action_340
+action_159 x = happyTcHack x happyReduce_217
+
+action_160 x = happyTcHack x happyReduce_220
+
+action_161 (102#) = happyShift action_306
+action_161 (168#) = happyShift action_308
+action_161 x = happyTcHack x happyReduce_242
+
+action_162 (104#) = happyShift action_339
+action_162 x = happyTcHack x happyReduce_247
+
+action_163 (114#) = happyShift action_338
+action_163 x = happyTcHack x happyFail
+
+action_164 (95#) = happyShift action_120
+action_164 (98#) = happyShift action_121
+action_164 (111#) = happyShift action_122
+action_164 (115#) = happyShift action_123
+action_164 (123#) = happyShift action_124
+action_164 (126#) = happyShift action_125
+action_164 (167#) = happyShift action_126
+action_164 (170#) = happyShift action_6
+action_164 (171#) = happyShift action_45
+action_164 (172#) = happyShift action_46
+action_164 (174#) = happyShift action_48
+action_164 (8#) = happyGoto action_115
+action_164 (9#) = happyGoto action_116
+action_164 (10#) = happyGoto action_117
+action_164 (12#) = happyGoto action_118
+action_164 (67#) = happyGoto action_337
+action_164 x = happyTcHack x happyFail
+
+action_165 (99#) = happyShift action_336
+action_165 (102#) = happyShift action_306
+action_165 (168#) = happyShift action_308
+action_165 x = happyTcHack x happyFail
+
+action_166 (107#) = happyShift action_335
+action_166 x = happyTcHack x happyReduce_200
+
+action_167 (174#) = happyShift action_48
+action_167 (12#) = happyGoto action_334
+action_167 x = happyTcHack x happyFail
+
+action_168 x = happyTcHack x happyReduce_142
+
+action_169 (174#) = happyShift action_48
+action_169 (12#) = happyGoto action_333
+action_169 x = happyTcHack x happyFail
+
+action_170 (99#) = happyShift action_332
+action_170 x = happyTcHack x happyReduce_140
+
+action_171 (95#) = happyShift action_21
+action_171 (97#) = happyShift action_22
+action_171 (98#) = happyShift action_23
+action_171 (111#) = happyShift action_24
+action_171 (115#) = happyShift action_25
+action_171 (117#) = happyShift action_26
+action_171 (118#) = happyShift action_27
+action_171 (119#) = happyShift action_28
+action_171 (120#) = happyShift action_29
+action_171 (121#) = happyShift action_30
+action_171 (122#) = happyShift action_31
+action_171 (123#) = happyShift action_32
+action_171 (124#) = happyShift action_33
+action_171 (128#) = happyShift action_34
+action_171 (131#) = happyShift action_35
+action_171 (134#) = happyShift action_36
+action_171 (137#) = happyShift action_37
+action_171 (142#) = happyShift action_38
+action_171 (153#) = happyShift action_39
+action_171 (154#) = happyShift action_40
+action_171 (158#) = happyShift action_41
+action_171 (159#) = happyShift action_42
+action_171 (164#) = happyShift action_43
+action_171 (167#) = happyShift action_44
+action_171 (170#) = happyShift action_6
+action_171 (171#) = happyShift action_45
+action_171 (172#) = happyShift action_46
+action_171 (173#) = happyShift action_47
+action_171 (174#) = happyShift action_48
+action_171 (8#) = happyGoto action_7
+action_171 (9#) = happyGoto action_8
+action_171 (10#) = happyGoto action_9
+action_171 (11#) = happyGoto action_10
+action_171 (12#) = happyGoto action_11
+action_171 (58#) = happyGoto action_12
+action_171 (59#) = happyGoto action_13
+action_171 (60#) = happyGoto action_14
+action_171 (61#) = happyGoto action_15
+action_171 (62#) = happyGoto action_16
+action_171 (63#) = happyGoto action_331
+action_171 (64#) = happyGoto action_18
+action_171 (72#) = happyGoto action_19
+action_171 (77#) = happyGoto action_20
+action_171 x = happyTcHack x happyFail
+
+action_172 x = happyTcHack x happyReduce_156
+
+action_173 x = happyTcHack x happyReduce_153
+
+action_174 (95#) = happyShift action_21
+action_174 (97#) = happyShift action_22
+action_174 (98#) = happyShift action_23
+action_174 (111#) = happyShift action_24
+action_174 (115#) = happyShift action_25
+action_174 (117#) = happyShift action_26
+action_174 (118#) = happyShift action_27
+action_174 (119#) = happyShift action_28
+action_174 (120#) = happyShift action_29
+action_174 (121#) = happyShift action_30
+action_174 (122#) = happyShift action_31
+action_174 (123#) = happyShift action_32
+action_174 (124#) = happyShift action_33
+action_174 (128#) = happyShift action_34
+action_174 (131#) = happyShift action_35
+action_174 (134#) = happyShift action_36
+action_174 (137#) = happyShift action_37
+action_174 (142#) = happyShift action_38
+action_174 (153#) = happyShift action_39
+action_174 (154#) = happyShift action_40
+action_174 (158#) = happyShift action_41
+action_174 (159#) = happyShift action_42
+action_174 (164#) = happyShift action_43
+action_174 (167#) = happyShift action_44
+action_174 (170#) = happyShift action_6
+action_174 (171#) = happyShift action_45
+action_174 (172#) = happyShift action_46
+action_174 (173#) = happyShift action_47
+action_174 (174#) = happyShift action_48
+action_174 (8#) = happyGoto action_7
+action_174 (9#) = happyGoto action_8
+action_174 (10#) = happyGoto action_9
+action_174 (11#) = happyGoto action_10
+action_174 (12#) = happyGoto action_11
+action_174 (58#) = happyGoto action_12
+action_174 (59#) = happyGoto action_13
+action_174 (60#) = happyGoto action_14
+action_174 (61#) = happyGoto action_15
+action_174 (62#) = happyGoto action_16
+action_174 (63#) = happyGoto action_329
+action_174 (64#) = happyGoto action_18
+action_174 (72#) = happyGoto action_19
+action_174 (77#) = happyGoto action_20
+action_174 (78#) = happyGoto action_108
+action_174 (80#) = happyGoto action_330
+action_174 x = happyTcHack x happyReduce_243
+
+action_175 (95#) = happyShift action_21
+action_175 (97#) = happyShift action_22
+action_175 (98#) = happyShift action_23
+action_175 (111#) = happyShift action_24
+action_175 (115#) = happyShift action_25
+action_175 (117#) = happyShift action_26
+action_175 (118#) = happyShift action_27
+action_175 (119#) = happyShift action_28
+action_175 (120#) = happyShift action_29
+action_175 (121#) = happyShift action_30
+action_175 (122#) = happyShift action_31
+action_175 (123#) = happyShift action_32
+action_175 (124#) = happyShift action_33
+action_175 (128#) = happyShift action_34
+action_175 (131#) = happyShift action_35
+action_175 (134#) = happyShift action_36
+action_175 (137#) = happyShift action_37
+action_175 (142#) = happyShift action_38
+action_175 (153#) = happyShift action_39
+action_175 (154#) = happyShift action_40
+action_175 (158#) = happyShift action_41
+action_175 (159#) = happyShift action_42
+action_175 (164#) = happyShift action_43
+action_175 (167#) = happyShift action_44
+action_175 (170#) = happyShift action_6
+action_175 (171#) = happyShift action_45
+action_175 (172#) = happyShift action_46
+action_175 (173#) = happyShift action_47
+action_175 (174#) = happyShift action_48
+action_175 (8#) = happyGoto action_7
+action_175 (9#) = happyGoto action_8
+action_175 (10#) = happyGoto action_9
+action_175 (11#) = happyGoto action_10
+action_175 (12#) = happyGoto action_11
+action_175 (58#) = happyGoto action_12
+action_175 (59#) = happyGoto action_13
+action_175 (60#) = happyGoto action_14
+action_175 (61#) = happyGoto action_15
+action_175 (62#) = happyGoto action_16
+action_175 (63#) = happyGoto action_328
+action_175 (64#) = happyGoto action_18
+action_175 (72#) = happyGoto action_19
+action_175 (77#) = happyGoto action_20
+action_175 x = happyTcHack x happyFail
+
+action_176 (97#) = happyShift action_86
+action_176 (98#) = happyShift action_87
+action_176 (111#) = happyShift action_24
+action_176 (115#) = happyShift action_25
+action_176 (118#) = happyShift action_27
+action_176 (119#) = happyShift action_28
+action_176 (120#) = happyShift action_29
+action_176 (121#) = happyShift action_30
+action_176 (122#) = happyShift action_31
+action_176 (123#) = happyShift action_32
+action_176 (131#) = happyShift action_35
+action_176 (167#) = happyShift action_139
+action_176 (170#) = happyShift action_6
+action_176 (171#) = happyShift action_45
+action_176 (172#) = happyShift action_46
+action_176 (173#) = happyShift action_47
+action_176 (174#) = happyShift action_48
+action_176 (8#) = happyGoto action_7
+action_176 (9#) = happyGoto action_8
+action_176 (10#) = happyGoto action_9
+action_176 (11#) = happyGoto action_10
+action_176 (12#) = happyGoto action_84
+action_176 (58#) = happyGoto action_176
+action_176 (66#) = happyGoto action_327
+action_176 (72#) = happyGoto action_19
+action_176 x = happyTcHack x happyReduce_196
+
+action_177 (125#) = happyShift action_326
+action_177 x = happyTcHack x happyFail
+
+action_178 x = happyTcHack x happyReduce_151
+
+action_179 (113#) = happyShift action_325
+action_179 x = happyTcHack x happyFail
+
+action_180 (95#) = happyShift action_21
+action_180 (97#) = happyShift action_22
+action_180 (98#) = happyShift action_23
+action_180 (111#) = happyShift action_24
+action_180 (115#) = happyShift action_25
+action_180 (117#) = happyShift action_26
+action_180 (118#) = happyShift action_27
+action_180 (119#) = happyShift action_28
+action_180 (120#) = happyShift action_29
+action_180 (121#) = happyShift action_30
+action_180 (122#) = happyShift action_31
+action_180 (123#) = happyShift action_32
+action_180 (124#) = happyShift action_33
+action_180 (128#) = happyShift action_34
+action_180 (131#) = happyShift action_35
+action_180 (134#) = happyShift action_36
+action_180 (137#) = happyShift action_37
+action_180 (142#) = happyShift action_38
+action_180 (153#) = happyShift action_39
+action_180 (154#) = happyShift action_40
+action_180 (158#) = happyShift action_41
+action_180 (159#) = happyShift action_42
+action_180 (164#) = happyShift action_43
+action_180 (167#) = happyShift action_44
+action_180 (170#) = happyShift action_6
+action_180 (171#) = happyShift action_45
+action_180 (172#) = happyShift action_46
+action_180 (173#) = happyShift action_47
+action_180 (174#) = happyShift action_48
+action_180 (8#) = happyGoto action_7
+action_180 (9#) = happyGoto action_8
+action_180 (10#) = happyGoto action_9
+action_180 (11#) = happyGoto action_10
+action_180 (12#) = happyGoto action_11
+action_180 (58#) = happyGoto action_12
+action_180 (59#) = happyGoto action_13
+action_180 (60#) = happyGoto action_14
+action_180 (61#) = happyGoto action_15
+action_180 (62#) = happyGoto action_16
+action_180 (63#) = happyGoto action_324
+action_180 (64#) = happyGoto action_18
+action_180 (72#) = happyGoto action_19
+action_180 (77#) = happyGoto action_20
+action_180 x = happyTcHack x happyFail
+
+action_181 (126#) = happyShift action_102
+action_181 (174#) = happyShift action_48
+action_181 (12#) = happyGoto action_98
+action_181 (75#) = happyGoto action_99
+action_181 (76#) = happyGoto action_323
+action_181 x = happyTcHack x happyReduce_236
+
+action_182 (167#) = happyShift action_322
+action_182 x = happyTcHack x happyFail
+
+action_183 (95#) = happyShift action_120
+action_183 (98#) = happyShift action_121
+action_183 (111#) = happyShift action_122
+action_183 (115#) = happyShift action_123
+action_183 (123#) = happyShift action_124
+action_183 (126#) = happyShift action_125
+action_183 (167#) = happyShift action_126
+action_183 (170#) = happyShift action_6
+action_183 (171#) = happyShift action_45
+action_183 (172#) = happyShift action_46
+action_183 (174#) = happyShift action_48
+action_183 (8#) = happyGoto action_115
+action_183 (9#) = happyGoto action_116
+action_183 (10#) = happyGoto action_117
+action_183 (12#) = happyGoto action_118
+action_183 (67#) = happyGoto action_183
+action_183 (74#) = happyGoto action_321
+action_183 x = happyTcHack x happyReduce_232
+
+action_184 (106#) = happyShift action_320
+action_184 x = happyTcHack x happyFail
+
+action_185 (110#) = happyShift action_319
+action_185 x = happyTcHack x happyReduce_254
+
+action_186 (169#) = happyShift action_318
+action_186 x = happyTcHack x happyFail
+
+action_187 x = happyTcHack x happyReduce_190
+
+action_188 (169#) = happyShift action_317
+action_188 x = happyTcHack x happyFail
+
+action_189 (95#) = happyShift action_21
+action_189 (97#) = happyShift action_22
+action_189 (98#) = happyShift action_23
+action_189 (111#) = happyShift action_24
+action_189 (115#) = happyShift action_25
+action_189 (117#) = happyShift action_26
+action_189 (118#) = happyShift action_27
+action_189 (119#) = happyShift action_28
+action_189 (120#) = happyShift action_29
+action_189 (121#) = happyShift action_30
+action_189 (122#) = happyShift action_31
+action_189 (123#) = happyShift action_32
+action_189 (124#) = happyShift action_33
+action_189 (128#) = happyShift action_34
+action_189 (131#) = happyShift action_35
+action_189 (134#) = happyShift action_36
+action_189 (137#) = happyShift action_37
+action_189 (142#) = happyShift action_38
+action_189 (153#) = happyShift action_39
+action_189 (154#) = happyShift action_40
+action_189 (158#) = happyShift action_41
+action_189 (159#) = happyShift action_42
+action_189 (164#) = happyShift action_43
+action_189 (167#) = happyShift action_44
+action_189 (170#) = happyShift action_6
+action_189 (171#) = happyShift action_45
+action_189 (172#) = happyShift action_46
+action_189 (173#) = happyShift action_47
+action_189 (174#) = happyShift action_48
+action_189 (8#) = happyGoto action_7
+action_189 (9#) = happyGoto action_8
+action_189 (10#) = happyGoto action_9
+action_189 (11#) = happyGoto action_10
+action_189 (12#) = happyGoto action_11
+action_189 (58#) = happyGoto action_12
+action_189 (59#) = happyGoto action_13
+action_189 (60#) = happyGoto action_14
+action_189 (61#) = happyGoto action_15
+action_189 (62#) = happyGoto action_16
+action_189 (63#) = happyGoto action_316
+action_189 (64#) = happyGoto action_18
+action_189 (72#) = happyGoto action_19
+action_189 (77#) = happyGoto action_20
+action_189 x = happyTcHack x happyFail
+
+action_190 (174#) = happyShift action_48
+action_190 (12#) = happyGoto action_92
+action_190 (53#) = happyGoto action_315
+action_190 x = happyTcHack x happyFail
+
+action_191 (110#) = happyShift action_314
+action_191 x = happyTcHack x happyFail
+
+action_192 (110#) = happyShift action_313
+action_192 x = happyTcHack x happyReduce_194
+
+action_193 (169#) = happyShift action_312
+action_193 x = happyTcHack x happyFail
+
+action_194 (95#) = happyShift action_120
+action_194 (98#) = happyShift action_121
+action_194 (104#) = happyShift action_190
+action_194 (107#) = happyShift action_310
+action_194 (109#) = happyReduce_128
+action_194 (111#) = happyShift action_122
+action_194 (112#) = happyReduce_128
+action_194 (115#) = happyShift action_123
+action_194 (116#) = happyShift action_311
+action_194 (123#) = happyShift action_124
+action_194 (126#) = happyShift action_125
+action_194 (167#) = happyShift action_126
+action_194 (169#) = happyShift action_207
+action_194 (170#) = happyShift action_6
+action_194 (171#) = happyShift action_45
+action_194 (172#) = happyShift action_46
+action_194 (174#) = happyShift action_48
+action_194 (8#) = happyGoto action_115
+action_194 (9#) = happyGoto action_116
+action_194 (10#) = happyGoto action_117
+action_194 (12#) = happyGoto action_118
+action_194 (67#) = happyGoto action_183
+action_194 (74#) = happyGoto action_309
+action_194 x = happyTcHack x happyReduce_203
+
+action_195 (102#) = happyShift action_306
+action_195 (113#) = happyShift action_307
+action_195 (168#) = happyShift action_308
+action_195 x = happyTcHack x happyFail
+
+action_196 (110#) = happyShift action_305
+action_196 x = happyTcHack x happyReduce_250
+
+action_197 (169#) = happyShift action_304
+action_197 x = happyTcHack x happyFail
+
+action_198 (97#) = happyShift action_168
+action_198 x = happyTcHack x happyFail
+
+action_199 (95#) = happyShift action_21
+action_199 (97#) = happyShift action_22
+action_199 (98#) = happyShift action_23
+action_199 (111#) = happyShift action_24
+action_199 (115#) = happyShift action_25
+action_199 (117#) = happyShift action_26
+action_199 (118#) = happyShift action_27
+action_199 (119#) = happyShift action_28
+action_199 (120#) = happyShift action_29
+action_199 (121#) = happyShift action_30
+action_199 (122#) = happyShift action_31
+action_199 (123#) = happyShift action_32
+action_199 (124#) = happyShift action_33
+action_199 (128#) = happyShift action_34
+action_199 (131#) = happyShift action_35
+action_199 (134#) = happyShift action_36
+action_199 (137#) = happyShift action_37
+action_199 (142#) = happyShift action_38
+action_199 (153#) = happyShift action_39
+action_199 (154#) = happyShift action_40
+action_199 (158#) = happyShift action_41
+action_199 (159#) = happyShift action_42
+action_199 (164#) = happyShift action_43
+action_199 (167#) = happyShift action_44
+action_199 (170#) = happyShift action_6
+action_199 (171#) = happyShift action_45
+action_199 (172#) = happyShift action_46
+action_199 (173#) = happyShift action_47
+action_199 (174#) = happyShift action_48
+action_199 (8#) = happyGoto action_7
+action_199 (9#) = happyGoto action_8
+action_199 (10#) = happyGoto action_9
+action_199 (11#) = happyGoto action_10
+action_199 (12#) = happyGoto action_11
+action_199 (58#) = happyGoto action_12
+action_199 (59#) = happyGoto action_13
+action_199 (60#) = happyGoto action_14
+action_199 (61#) = happyGoto action_15
+action_199 (62#) = happyGoto action_16
+action_199 (63#) = happyGoto action_192
+action_199 (64#) = happyGoto action_18
+action_199 (65#) = happyGoto action_303
+action_199 (72#) = happyGoto action_19
+action_199 (77#) = happyGoto action_20
+action_199 x = happyTcHack x happyReduce_193
+
+action_200 (95#) = happyShift action_120
+action_200 (98#) = happyShift action_121
+action_200 (105#) = happyShift action_164
+action_200 (111#) = happyShift action_122
+action_200 (115#) = happyShift action_123
+action_200 (123#) = happyShift action_124
+action_200 (126#) = happyShift action_125
+action_200 (167#) = happyShift action_126
+action_200 (170#) = happyShift action_6
+action_200 (171#) = happyShift action_45
+action_200 (172#) = happyShift action_46
+action_200 (174#) = happyShift action_48
+action_200 (8#) = happyGoto action_115
+action_200 (9#) = happyGoto action_116
+action_200 (10#) = happyGoto action_117
+action_200 (12#) = happyGoto action_158
+action_200 (67#) = happyGoto action_159
+action_200 (68#) = happyGoto action_160
+action_200 (69#) = happyGoto action_195
+action_200 (82#) = happyGoto action_196
+action_200 (83#) = happyGoto action_302
+action_200 x = happyTcHack x happyFail
+
+action_201 (169#) = happyShift action_301
+action_201 x = happyTcHack x happyFail
+
+action_202 x = happyTcHack x happyReduce_152
+
+action_203 (174#) = happyShift action_48
+action_203 (12#) = happyGoto action_92
+action_203 (53#) = happyGoto action_80
+action_203 (56#) = happyGoto action_81
+action_203 (57#) = happyGoto action_300
+action_203 x = happyTcHack x happyReduce_137
+
+action_204 (95#) = happyShift action_21
+action_204 (97#) = happyShift action_22
+action_204 (98#) = happyShift action_23
+action_204 (111#) = happyShift action_24
+action_204 (115#) = happyShift action_25
+action_204 (117#) = happyShift action_26
+action_204 (118#) = happyShift action_27
+action_204 (119#) = happyShift action_28
+action_204 (120#) = happyShift action_29
+action_204 (121#) = happyShift action_30
+action_204 (122#) = happyShift action_31
+action_204 (123#) = happyShift action_32
+action_204 (124#) = happyShift action_33
+action_204 (128#) = happyShift action_34
+action_204 (131#) = happyShift action_35
+action_204 (134#) = happyShift action_36
+action_204 (137#) = happyShift action_37
+action_204 (142#) = happyShift action_38
+action_204 (153#) = happyShift action_39
+action_204 (154#) = happyShift action_40
+action_204 (158#) = happyShift action_41
+action_204 (159#) = happyShift action_42
+action_204 (164#) = happyShift action_43
+action_204 (167#) = happyShift action_44
+action_204 (170#) = happyShift action_6
+action_204 (171#) = happyShift action_45
+action_204 (172#) = happyShift action_46
+action_204 (173#) = happyShift action_47
+action_204 (174#) = happyShift action_48
+action_204 (8#) = happyGoto action_7
+action_204 (9#) = happyGoto action_8
+action_204 (10#) = happyGoto action_9
+action_204 (11#) = happyGoto action_10
+action_204 (12#) = happyGoto action_11
+action_204 (58#) = happyGoto action_12
+action_204 (59#) = happyGoto action_13
+action_204 (60#) = happyGoto action_14
+action_204 (61#) = happyGoto action_15
+action_204 (62#) = happyGoto action_16
+action_204 (63#) = happyGoto action_299
+action_204 (64#) = happyGoto action_18
+action_204 (72#) = happyGoto action_19
+action_204 (77#) = happyGoto action_20
+action_204 x = happyTcHack x happyFail
+
+action_205 (95#) = happyShift action_21
+action_205 (97#) = happyShift action_22
+action_205 (98#) = happyShift action_23
+action_205 (111#) = happyShift action_24
+action_205 (115#) = happyShift action_25
+action_205 (117#) = happyShift action_26
+action_205 (118#) = happyShift action_27
+action_205 (119#) = happyShift action_28
+action_205 (120#) = happyShift action_29
+action_205 (121#) = happyShift action_30
+action_205 (122#) = happyShift action_31
+action_205 (123#) = happyShift action_32
+action_205 (124#) = happyShift action_33
+action_205 (128#) = happyShift action_34
+action_205 (131#) = happyShift action_35
+action_205 (134#) = happyShift action_36
+action_205 (137#) = happyShift action_37
+action_205 (142#) = happyShift action_38
+action_205 (153#) = happyShift action_39
+action_205 (154#) = happyShift action_40
+action_205 (158#) = happyShift action_41
+action_205 (159#) = happyShift action_42
+action_205 (164#) = happyShift action_43
+action_205 (167#) = happyShift action_44
+action_205 (170#) = happyShift action_6
+action_205 (171#) = happyShift action_45
+action_205 (172#) = happyShift action_46
+action_205 (173#) = happyShift action_47
+action_205 (174#) = happyShift action_48
+action_205 (8#) = happyGoto action_7
+action_205 (9#) = happyGoto action_8
+action_205 (10#) = happyGoto action_9
+action_205 (11#) = happyGoto action_10
+action_205 (12#) = happyGoto action_11
+action_205 (58#) = happyGoto action_12
+action_205 (59#) = happyGoto action_13
+action_205 (60#) = happyGoto action_14
+action_205 (61#) = happyGoto action_15
+action_205 (62#) = happyGoto action_16
+action_205 (63#) = happyGoto action_298
+action_205 (64#) = happyGoto action_18
+action_205 (72#) = happyGoto action_19
+action_205 (77#) = happyGoto action_20
+action_205 x = happyTcHack x happyFail
+
+action_206 (174#) = happyShift action_48
+action_206 (12#) = happyGoto action_297
+action_206 x = happyTcHack x happyFail
+
+action_207 x = happyTcHack x happyReduce_141
+
+action_208 (1#) = happyReduce_65
+action_208 (101#) = happyReduce_65
+action_208 (148#) = happyReduce_51
+action_208 (157#) = happyShift action_295
+action_208 (162#) = happyShift action_296
+action_208 (174#) = happyShift action_48
+action_208 (12#) = happyGoto action_241
+action_208 (22#) = happyGoto action_291
+action_208 (26#) = happyGoto action_292
+action_208 (32#) = happyGoto action_293
+action_208 (33#) = happyGoto action_294
+action_208 x = happyTcHack x happyReduce_65
+
+action_209 x = happyTcHack x happyReduce_49
+
+action_210 (123#) = happyShift action_290
+action_210 (174#) = happyShift action_48
+action_210 (12#) = happyGoto action_287
+action_210 (36#) = happyGoto action_288
+action_210 (46#) = happyGoto action_289
+action_210 x = happyTcHack x happyFail
+
+action_211 (174#) = happyShift action_48
+action_211 (12#) = happyGoto action_283
+action_211 (37#) = happyGoto action_276
+action_211 (38#) = happyGoto action_284
+action_211 (47#) = happyGoto action_285
+action_211 (48#) = happyGoto action_286
+action_211 (53#) = happyGoto action_278
+action_211 x = happyTcHack x happyFail
+
+action_212 (123#) = happyShift action_257
+action_212 (174#) = happyShift action_48
+action_212 (12#) = happyGoto action_252
+action_212 (34#) = happyGoto action_253
+action_212 (45#) = happyGoto action_282
+action_212 (54#) = happyGoto action_255
+action_212 (55#) = happyGoto action_256
+action_212 x = happyTcHack x happyFail
+
+action_213 (174#) = happyShift action_48
+action_213 (12#) = happyGoto action_279
+action_213 (44#) = happyGoto action_280
+action_213 (51#) = happyGoto action_281
+action_213 x = happyTcHack x happyFail
+
+action_214 (174#) = happyShift action_48
+action_214 (12#) = happyGoto action_92
+action_214 (37#) = happyGoto action_276
+action_214 (47#) = happyGoto action_277
+action_214 (53#) = happyGoto action_278
+action_214 x = happyTcHack x happyFail
+
+action_215 (123#) = happyShift action_257
+action_215 (174#) = happyShift action_48
+action_215 (12#) = happyGoto action_252
+action_215 (34#) = happyGoto action_253
+action_215 (45#) = happyGoto action_275
+action_215 (54#) = happyGoto action_255
+action_215 (55#) = happyGoto action_256
+action_215 x = happyTcHack x happyFail
+
+action_216 (123#) = happyShift action_257
+action_216 (174#) = happyShift action_48
+action_216 (12#) = happyGoto action_252
+action_216 (43#) = happyGoto action_260
+action_216 (50#) = happyGoto action_274
+action_216 (54#) = happyGoto action_262
+action_216 (55#) = happyGoto action_263
+action_216 x = happyTcHack x happyFail
+
+action_217 (123#) = happyShift action_257
+action_217 (174#) = happyShift action_48
+action_217 (12#) = happyGoto action_252
+action_217 (34#) = happyGoto action_253
+action_217 (45#) = happyGoto action_273
+action_217 (54#) = happyGoto action_255
+action_217 (55#) = happyGoto action_256
+action_217 x = happyTcHack x happyFail
+
+action_218 (123#) = happyShift action_257
+action_218 (174#) = happyShift action_48
+action_218 (12#) = happyGoto action_252
+action_218 (34#) = happyGoto action_253
+action_218 (45#) = happyGoto action_272
+action_218 (54#) = happyGoto action_255
+action_218 (55#) = happyGoto action_256
+action_218 x = happyTcHack x happyFail
+
+action_219 (123#) = happyShift action_257
+action_219 (174#) = happyShift action_48
+action_219 (12#) = happyGoto action_252
+action_219 (34#) = happyGoto action_253
+action_219 (45#) = happyGoto action_271
+action_219 (54#) = happyGoto action_255
+action_219 (55#) = happyGoto action_256
+action_219 x = happyTcHack x happyFail
+
+action_220 (174#) = happyShift action_48
+action_220 (12#) = happyGoto action_270
+action_220 x = happyTcHack x happyFail
+
+action_221 (174#) = happyShift action_48
+action_221 (12#) = happyGoto action_267
+action_221 (41#) = happyGoto action_268
+action_221 (49#) = happyGoto action_269
+action_221 x = happyTcHack x happyFail
+
+action_222 (123#) = happyShift action_257
+action_222 (174#) = happyShift action_48
+action_222 (12#) = happyGoto action_252
+action_222 (34#) = happyGoto action_253
+action_222 (45#) = happyGoto action_266
+action_222 (54#) = happyGoto action_255
+action_222 (55#) = happyGoto action_256
+action_222 x = happyTcHack x happyFail
+
+action_223 (123#) = happyShift action_257
+action_223 (129#) = happyShift action_264
+action_223 (135#) = happyShift action_265
+action_223 (174#) = happyShift action_48
+action_223 (12#) = happyGoto action_252
+action_223 (43#) = happyGoto action_260
+action_223 (50#) = happyGoto action_261
+action_223 (54#) = happyGoto action_262
+action_223 (55#) = happyGoto action_263
+action_223 x = happyTcHack x happyFail
+
+action_224 (174#) = happyShift action_48
+action_224 (12#) = happyGoto action_259
+action_224 x = happyTcHack x happyFail
+
+action_225 (123#) = happyShift action_257
+action_225 (174#) = happyShift action_48
+action_225 (12#) = happyGoto action_252
+action_225 (34#) = happyGoto action_253
+action_225 (45#) = happyGoto action_258
+action_225 (54#) = happyGoto action_255
+action_225 (55#) = happyGoto action_256
+action_225 x = happyTcHack x happyFail
+
+action_226 (123#) = happyShift action_257
+action_226 (174#) = happyShift action_48
+action_226 (12#) = happyGoto action_252
+action_226 (34#) = happyGoto action_253
+action_226 (45#) = happyGoto action_254
+action_226 (54#) = happyGoto action_255
+action_226 (55#) = happyGoto action_256
+action_226 x = happyTcHack x happyFail
+
+action_227 x = happyTcHack x happyReduce_269
+
+action_228 x = happyTcHack x happyReduce_270
+
+action_229 x = happyTcHack x happyReduce_271
+
+action_230 (105#) = happyShift action_74
+action_230 (107#) = happyShift action_75
+action_230 (108#) = happyShift action_76
+action_230 (171#) = happyShift action_45
+action_230 (174#) = happyShift action_48
+action_230 (9#) = happyGoto action_70
+action_230 (12#) = happyGoto action_71
+action_230 (92#) = happyGoto action_72
+action_230 (93#) = happyGoto action_251
+action_230 x = happyTcHack x happyReduce_273
+
+action_231 x = happyTcHack x happyReduce_272
+
+action_232 (109#) = happyShift action_250
+action_232 x = happyTcHack x happyFail
+
+action_233 x = happyTcHack x happyReduce_35
+
+action_234 x = happyTcHack x happyReduce_36
+
+action_235 (147#) = happyShift action_249
+action_235 x = happyTcHack x happyFail
+
+action_236 (147#) = happyShift action_248
+action_236 x = happyTcHack x happyFail
+
+action_237 x = happyTcHack x happyReduce_34
+
+action_238 (148#) = happyReduce_51
+action_238 (157#) = happyShift action_246
+action_238 (162#) = happyShift action_247
+action_238 (167#) = happyReduce_51
+action_238 (174#) = happyShift action_48
+action_238 (12#) = happyGoto action_241
+action_238 (24#) = happyGoto action_242
+action_238 (26#) = happyGoto action_243
+action_238 (32#) = happyGoto action_244
+action_238 (33#) = happyGoto action_245
+action_238 x = happyTcHack x happyReduce_65
+
+action_239 (167#) = happyShift action_240
+action_239 x = happyTcHack x happyFail
+
+action_240 (127#) = happyShift action_418
+action_240 x = happyTcHack x happyFail
+
+action_241 (105#) = happyShift action_416
+action_241 (123#) = happyShift action_417
+action_241 x = happyTcHack x happyReduce_68
+
+action_242 x = happyTcHack x happyReduce_15
+
+action_243 (148#) = happyShift action_382
+action_243 (28#) = happyGoto action_415
+action_243 x = happyTcHack x happyReduce_55
+
+action_244 (101#) = happyShift action_414
+action_244 x = happyTcHack x happyReduce_41
+
+action_245 (104#) = happyShift action_378
+action_245 (166#) = happyShift action_413
+action_245 x = happyTcHack x happyReduce_66
+
+action_246 (174#) = happyShift action_48
+action_246 (12#) = happyGoto action_412
+action_246 x = happyTcHack x happyFail
+
+action_247 (174#) = happyShift action_48
+action_247 (12#) = happyGoto action_241
+action_247 (32#) = happyGoto action_411
+action_247 (33#) = happyGoto action_376
+action_247 x = happyTcHack x happyReduce_65
+
+action_248 (174#) = happyShift action_48
+action_248 (12#) = happyGoto action_410
+action_248 x = happyTcHack x happyFail
+
+action_249 (174#) = happyShift action_48
+action_249 (12#) = happyGoto action_409
+action_249 x = happyTcHack x happyFail
+
+action_250 (98#) = happyShift action_408
+action_250 (174#) = happyShift action_48
+action_250 (12#) = happyGoto action_406
+action_250 (29#) = happyGoto action_407
+action_250 x = happyTcHack x happyFail
+
+action_251 x = happyTcHack x happyReduce_274
+
+action_252 x = happyTcHack x happyReduce_130
+
+action_253 (110#) = happyShift action_405
+action_253 x = happyTcHack x happyFail
+
+action_254 x = happyTcHack x happyReduce_93
+
+action_255 (95#) = happyShift action_120
+action_255 (98#) = happyShift action_121
+action_255 (104#) = happyShift action_398
+action_255 (111#) = happyShift action_122
+action_255 (115#) = happyShift action_123
+action_255 (123#) = happyShift action_124
+action_255 (126#) = happyShift action_125
+action_255 (167#) = happyShift action_126
+action_255 (170#) = happyShift action_6
+action_255 (171#) = happyShift action_45
+action_255 (172#) = happyShift action_46
+action_255 (174#) = happyShift action_48
+action_255 (8#) = happyGoto action_115
+action_255 (9#) = happyGoto action_116
+action_255 (10#) = happyGoto action_117
+action_255 (12#) = happyGoto action_118
+action_255 (67#) = happyGoto action_183
+action_255 (74#) = happyGoto action_404
+action_255 x = happyTcHack x happyReduce_132
+
+action_256 (109#) = happyShift action_402
+action_256 (112#) = happyShift action_403
+action_256 x = happyTcHack x happyFail
+
+action_257 (174#) = happyShift action_48
+action_257 (12#) = happyGoto action_401
+action_257 x = happyTcHack x happyFail
+
+action_258 x = happyTcHack x happyReduce_80
+
+action_259 (110#) = happyShift action_400
+action_259 x = happyTcHack x happyFail
+
+action_260 (110#) = happyShift action_399
+action_260 x = happyTcHack x happyFail
+
+action_261 x = happyTcHack x happyReduce_89
+
+action_262 (104#) = happyShift action_398
+action_262 x = happyTcHack x happyReduce_132
+
+action_263 (112#) = happyShift action_397
+action_263 x = happyTcHack x happyFail
+
+action_264 (123#) = happyShift action_257
+action_264 (174#) = happyShift action_48
+action_264 (12#) = happyGoto action_252
+action_264 (43#) = happyGoto action_260
+action_264 (50#) = happyGoto action_396
+action_264 (54#) = happyGoto action_262
+action_264 (55#) = happyGoto action_263
+action_264 x = happyTcHack x happyFail
+
+action_265 (123#) = happyShift action_257
+action_265 (174#) = happyShift action_48
+action_265 (12#) = happyGoto action_252
+action_265 (43#) = happyGoto action_260
+action_265 (50#) = happyGoto action_395
+action_265 (54#) = happyGoto action_262
+action_265 (55#) = happyGoto action_263
+action_265 x = happyTcHack x happyFail
+
+action_266 x = happyTcHack x happyReduce_91
+
+action_267 (112#) = happyShift action_394
+action_267 x = happyTcHack x happyReduce_107
+
+action_268 (110#) = happyShift action_393
+action_268 x = happyTcHack x happyFail
+
+action_269 x = happyTcHack x happyReduce_81
+
+action_270 (112#) = happyShift action_392
+action_270 x = happyTcHack x happyFail
+
+action_271 x = happyTcHack x happyReduce_82
+
+action_272 x = happyTcHack x happyReduce_90
+
+action_273 x = happyTcHack x happyReduce_84
+
+action_274 x = happyTcHack x happyReduce_83
+
+action_275 x = happyTcHack x happyReduce_85
+
+action_276 (110#) = happyShift action_391
+action_276 x = happyTcHack x happyFail
+
+action_277 x = happyTcHack x happyReduce_76
+
+action_278 (109#) = happyShift action_390
+action_278 x = happyTcHack x happyFail
+
+action_279 (112#) = happyShift action_389
+action_279 x = happyTcHack x happyFail
+
+action_280 (110#) = happyShift action_388
+action_280 x = happyTcHack x happyFail
+
+action_281 x = happyTcHack x happyReduce_88
+
+action_282 x = happyTcHack x happyReduce_78
+
+action_283 (104#) = happyShift action_190
+action_283 (112#) = happyShift action_387
+action_283 x = happyTcHack x happyReduce_128
+
+action_284 (110#) = happyShift action_386
+action_284 x = happyTcHack x happyFail
+
+action_285 x = happyTcHack x happyReduce_77
+
+action_286 x = happyTcHack x happyReduce_79
+
+action_287 (89#) = happyGoto action_385
+action_287 x = happyTcHack x happyReduce_262
+
+action_288 (110#) = happyShift action_384
+action_288 x = happyTcHack x happyFail
+
+action_289 x = happyTcHack x happyReduce_75
+
+action_290 (174#) = happyShift action_48
+action_290 (12#) = happyGoto action_383
+action_290 x = happyTcHack x happyFail
+
+action_291 x = happyTcHack x happyReduce_25
+
+action_292 (148#) = happyShift action_382
+action_292 (28#) = happyGoto action_381
+action_292 x = happyTcHack x happyReduce_55
+
+action_293 (101#) = happyShift action_380
+action_293 x = happyTcHack x happyReduce_27
+
+action_294 (104#) = happyShift action_378
+action_294 (166#) = happyShift action_379
+action_294 x = happyTcHack x happyReduce_66
+
+action_295 (174#) = happyShift action_48
+action_295 (12#) = happyGoto action_377
+action_295 x = happyTcHack x happyFail
+
+action_296 (174#) = happyShift action_48
+action_296 (12#) = happyGoto action_241
+action_296 (32#) = happyGoto action_375
+action_296 (33#) = happyGoto action_376
+action_296 x = happyTcHack x happyReduce_65
+
+action_297 (169#) = happyShift action_374
+action_297 x = happyTcHack x happyFail
+
+action_298 x = happyTcHack x happyReduce_135
+
+action_299 (112#) = happyShift action_373
+action_299 x = happyTcHack x happyReduce_134
+
+action_300 x = happyTcHack x happyReduce_139
+
+action_301 x = happyTcHack x happyReduce_167
+
+action_302 (169#) = happyShift action_372
+action_302 x = happyTcHack x happyFail
+
+action_303 (125#) = happyShift action_371
+action_303 x = happyTcHack x happyFail
+
+action_304 x = happyTcHack x happyReduce_163
+
+action_305 (95#) = happyShift action_120
+action_305 (98#) = happyShift action_121
+action_305 (105#) = happyShift action_164
+action_305 (111#) = happyShift action_122
+action_305 (115#) = happyShift action_123
+action_305 (123#) = happyShift action_124
+action_305 (126#) = happyShift action_125
+action_305 (167#) = happyShift action_126
+action_305 (170#) = happyShift action_6
+action_305 (171#) = happyShift action_45
+action_305 (172#) = happyShift action_46
+action_305 (174#) = happyShift action_48
+action_305 (8#) = happyGoto action_115
+action_305 (9#) = happyGoto action_116
+action_305 (10#) = happyGoto action_117
+action_305 (12#) = happyGoto action_158
+action_305 (67#) = happyGoto action_159
+action_305 (68#) = happyGoto action_160
+action_305 (69#) = happyGoto action_195
+action_305 (82#) = happyGoto action_196
+action_305 (83#) = happyGoto action_370
+action_305 x = happyTcHack x happyFail
+
+action_306 (95#) = happyShift action_120
+action_306 (98#) = happyShift action_121
+action_306 (105#) = happyShift action_164
+action_306 (111#) = happyShift action_122
+action_306 (115#) = happyShift action_123
+action_306 (123#) = happyShift action_124
+action_306 (126#) = happyShift action_125
+action_306 (167#) = happyShift action_126
+action_306 (170#) = happyShift action_6
+action_306 (171#) = happyShift action_45
+action_306 (172#) = happyShift action_46
+action_306 (174#) = happyShift action_48
+action_306 (8#) = happyGoto action_115
+action_306 (9#) = happyGoto action_116
+action_306 (10#) = happyGoto action_117
+action_306 (12#) = happyGoto action_158
+action_306 (67#) = happyGoto action_159
+action_306 (68#) = happyGoto action_369
+action_306 x = happyTcHack x happyFail
+
+action_307 (95#) = happyShift action_21
+action_307 (97#) = happyShift action_22
+action_307 (98#) = happyShift action_23
+action_307 (111#) = happyShift action_24
+action_307 (115#) = happyShift action_25
+action_307 (117#) = happyShift action_26
+action_307 (118#) = happyShift action_27
+action_307 (119#) = happyShift action_28
+action_307 (120#) = happyShift action_29
+action_307 (121#) = happyShift action_30
+action_307 (122#) = happyShift action_31
+action_307 (123#) = happyShift action_32
+action_307 (124#) = happyShift action_33
+action_307 (128#) = happyShift action_34
+action_307 (131#) = happyShift action_35
+action_307 (134#) = happyShift action_36
+action_307 (137#) = happyShift action_37
+action_307 (142#) = happyShift action_38
+action_307 (153#) = happyShift action_39
+action_307 (154#) = happyShift action_40
+action_307 (158#) = happyShift action_41
+action_307 (159#) = happyShift action_42
+action_307 (164#) = happyShift action_43
+action_307 (167#) = happyShift action_44
+action_307 (170#) = happyShift action_6
+action_307 (171#) = happyShift action_45
+action_307 (172#) = happyShift action_46
+action_307 (173#) = happyShift action_47
+action_307 (174#) = happyShift action_48
+action_307 (8#) = happyGoto action_7
+action_307 (9#) = happyGoto action_8
+action_307 (10#) = happyGoto action_9
+action_307 (11#) = happyGoto action_10
+action_307 (12#) = happyGoto action_11
+action_307 (58#) = happyGoto action_12
+action_307 (59#) = happyGoto action_13
+action_307 (60#) = happyGoto action_14
+action_307 (61#) = happyGoto action_15
+action_307 (62#) = happyGoto action_16
+action_307 (63#) = happyGoto action_368
+action_307 (64#) = happyGoto action_18
+action_307 (72#) = happyGoto action_19
+action_307 (77#) = happyGoto action_20
+action_307 x = happyTcHack x happyFail
+
+action_308 (95#) = happyShift action_120
+action_308 (98#) = happyShift action_121
+action_308 (105#) = happyShift action_164
+action_308 (111#) = happyShift action_122
+action_308 (115#) = happyShift action_123
+action_308 (123#) = happyShift action_124
+action_308 (126#) = happyShift action_125
+action_308 (167#) = happyShift action_126
+action_308 (170#) = happyShift action_6
+action_308 (171#) = happyShift action_45
+action_308 (172#) = happyShift action_46
+action_308 (174#) = happyShift action_48
+action_308 (8#) = happyGoto action_115
+action_308 (9#) = happyGoto action_116
+action_308 (10#) = happyGoto action_117
+action_308 (12#) = happyGoto action_158
+action_308 (67#) = happyGoto action_159
+action_308 (68#) = happyGoto action_367
+action_308 x = happyTcHack x happyFail
+
+action_309 x = happyTcHack x happyReduce_212
+
+action_310 (174#) = happyShift action_48
+action_310 (12#) = happyGoto action_366
+action_310 x = happyTcHack x happyFail
+
+action_311 (95#) = happyShift action_120
+action_311 (98#) = happyShift action_121
+action_311 (111#) = happyShift action_122
+action_311 (115#) = happyShift action_123
+action_311 (123#) = happyShift action_124
+action_311 (126#) = happyShift action_125
+action_311 (167#) = happyShift action_126
+action_311 (170#) = happyShift action_6
+action_311 (171#) = happyShift action_45
+action_311 (172#) = happyShift action_46
+action_311 (174#) = happyShift action_48
+action_311 (8#) = happyGoto action_115
+action_311 (9#) = happyGoto action_116
+action_311 (10#) = happyGoto action_117
+action_311 (12#) = happyGoto action_118
+action_311 (67#) = happyGoto action_365
+action_311 x = happyTcHack x happyFail
+
+action_312 x = happyTcHack x happyReduce_169
+
+action_313 (95#) = happyShift action_21
+action_313 (97#) = happyShift action_22
+action_313 (98#) = happyShift action_23
+action_313 (111#) = happyShift action_24
+action_313 (115#) = happyShift action_25
+action_313 (117#) = happyShift action_26
+action_313 (118#) = happyShift action_27
+action_313 (119#) = happyShift action_28
+action_313 (120#) = happyShift action_29
+action_313 (121#) = happyShift action_30
+action_313 (122#) = happyShift action_31
+action_313 (123#) = happyShift action_32
+action_313 (124#) = happyShift action_33
+action_313 (128#) = happyShift action_34
+action_313 (131#) = happyShift action_35
+action_313 (134#) = happyShift action_36
+action_313 (137#) = happyShift action_37
+action_313 (142#) = happyShift action_38
+action_313 (153#) = happyShift action_39
+action_313 (154#) = happyShift action_40
+action_313 (158#) = happyShift action_41
+action_313 (159#) = happyShift action_42
+action_313 (164#) = happyShift action_43
+action_313 (167#) = happyShift action_44
+action_313 (170#) = happyShift action_6
+action_313 (171#) = happyShift action_45
+action_313 (172#) = happyShift action_46
+action_313 (173#) = happyShift action_47
+action_313 (174#) = happyShift action_48
+action_313 (8#) = happyGoto action_7
+action_313 (9#) = happyGoto action_8
+action_313 (10#) = happyGoto action_9
+action_313 (11#) = happyGoto action_10
+action_313 (12#) = happyGoto action_11
+action_313 (58#) = happyGoto action_12
+action_313 (59#) = happyGoto action_13
+action_313 (60#) = happyGoto action_14
+action_313 (61#) = happyGoto action_15
+action_313 (62#) = happyGoto action_16
+action_313 (63#) = happyGoto action_192
+action_313 (64#) = happyGoto action_18
+action_313 (65#) = happyGoto action_364
+action_313 (72#) = happyGoto action_19
+action_313 (77#) = happyGoto action_20
+action_313 x = happyTcHack x happyReduce_193
+
+action_314 (95#) = happyShift action_21
+action_314 (97#) = happyShift action_22
+action_314 (98#) = happyShift action_23
+action_314 (111#) = happyShift action_24
+action_314 (115#) = happyShift action_25
+action_314 (117#) = happyShift action_26
+action_314 (118#) = happyShift action_27
+action_314 (119#) = happyShift action_28
+action_314 (120#) = happyShift action_29
+action_314 (121#) = happyShift action_30
+action_314 (122#) = happyShift action_31
+action_314 (123#) = happyShift action_32
+action_314 (124#) = happyShift action_33
+action_314 (128#) = happyShift action_34
+action_314 (131#) = happyShift action_35
+action_314 (134#) = happyShift action_36
+action_314 (137#) = happyShift action_37
+action_314 (142#) = happyShift action_38
+action_314 (153#) = happyShift action_39
+action_314 (154#) = happyShift action_40
+action_314 (158#) = happyShift action_41
+action_314 (159#) = happyShift action_42
+action_314 (164#) = happyShift action_43
+action_314 (167#) = happyShift action_44
+action_314 (170#) = happyShift action_6
+action_314 (171#) = happyShift action_45
+action_314 (172#) = happyShift action_46
+action_314 (173#) = happyShift action_47
+action_314 (174#) = happyShift action_48
+action_314 (8#) = happyGoto action_7
+action_314 (9#) = happyGoto action_8
+action_314 (10#) = happyGoto action_9
+action_314 (11#) = happyGoto action_10
+action_314 (12#) = happyGoto action_11
+action_314 (58#) = happyGoto action_12
+action_314 (59#) = happyGoto action_13
+action_314 (60#) = happyGoto action_14
+action_314 (61#) = happyGoto action_15
+action_314 (62#) = happyGoto action_16
+action_314 (63#) = happyGoto action_361
+action_314 (64#) = happyGoto action_18
+action_314 (72#) = happyGoto action_19
+action_314 (77#) = happyGoto action_20
+action_314 (86#) = happyGoto action_362
+action_314 (87#) = happyGoto action_363
+action_314 x = happyTcHack x happyReduce_257
+
+action_315 x = happyTcHack x happyReduce_129
+
+action_316 x = happyTcHack x happyReduce_187
+
+action_317 (137#) = happyShift action_360
+action_317 x = happyTcHack x happyFail
+
+action_318 x = happyTcHack x happyReduce_189
+
+action_319 (95#) = happyShift action_120
+action_319 (98#) = happyShift action_121
+action_319 (111#) = happyShift action_122
+action_319 (115#) = happyShift action_123
+action_319 (123#) = happyShift action_124
+action_319 (126#) = happyShift action_125
+action_319 (167#) = happyShift action_126
+action_319 (170#) = happyShift action_6
+action_319 (171#) = happyShift action_45
+action_319 (172#) = happyShift action_46
+action_319 (174#) = happyShift action_48
+action_319 (8#) = happyGoto action_115
+action_319 (9#) = happyGoto action_116
+action_319 (10#) = happyGoto action_117
+action_319 (12#) = happyGoto action_118
+action_319 (67#) = happyGoto action_183
+action_319 (74#) = happyGoto action_184
+action_319 (84#) = happyGoto action_185
+action_319 (85#) = happyGoto action_359
+action_319 x = happyTcHack x happyReduce_253
+
+action_320 (95#) = happyShift action_21
+action_320 (97#) = happyShift action_22
+action_320 (98#) = happyShift action_23
+action_320 (111#) = happyShift action_24
+action_320 (115#) = happyShift action_25
+action_320 (117#) = happyShift action_26
+action_320 (118#) = happyShift action_27
+action_320 (119#) = happyShift action_28
+action_320 (120#) = happyShift action_29
+action_320 (121#) = happyShift action_30
+action_320 (122#) = happyShift action_31
+action_320 (123#) = happyShift action_32
+action_320 (124#) = happyShift action_33
+action_320 (128#) = happyShift action_34
+action_320 (131#) = happyShift action_35
+action_320 (134#) = happyShift action_36
+action_320 (137#) = happyShift action_37
+action_320 (142#) = happyShift action_38
+action_320 (153#) = happyShift action_39
+action_320 (154#) = happyShift action_40
+action_320 (158#) = happyShift action_41
+action_320 (159#) = happyShift action_42
+action_320 (164#) = happyShift action_43
+action_320 (167#) = happyShift action_44
+action_320 (170#) = happyShift action_6
+action_320 (171#) = happyShift action_45
+action_320 (172#) = happyShift action_46
+action_320 (173#) = happyShift action_47
+action_320 (174#) = happyShift action_48
+action_320 (8#) = happyGoto action_7
+action_320 (9#) = happyGoto action_8
+action_320 (10#) = happyGoto action_9
+action_320 (11#) = happyGoto action_10
+action_320 (12#) = happyGoto action_11
+action_320 (58#) = happyGoto action_12
+action_320 (59#) = happyGoto action_13
+action_320 (60#) = happyGoto action_14
+action_320 (61#) = happyGoto action_15
+action_320 (62#) = happyGoto action_16
+action_320 (63#) = happyGoto action_358
+action_320 (64#) = happyGoto action_18
+action_320 (72#) = happyGoto action_19
+action_320 (77#) = happyGoto action_20
+action_320 x = happyTcHack x happyFail
+
+action_321 x = happyTcHack x happyReduce_233
+
+action_322 (95#) = happyShift action_120
+action_322 (98#) = happyShift action_121
+action_322 (105#) = happyShift action_164
+action_322 (111#) = happyShift action_122
+action_322 (115#) = happyShift action_123
+action_322 (123#) = happyShift action_124
+action_322 (126#) = happyShift action_125
+action_322 (167#) = happyShift action_126
+action_322 (170#) = happyShift action_6
+action_322 (171#) = happyShift action_45
+action_322 (172#) = happyShift action_46
+action_322 (174#) = happyShift action_48
+action_322 (8#) = happyGoto action_115
+action_322 (9#) = happyGoto action_116
+action_322 (10#) = happyGoto action_117
+action_322 (12#) = happyGoto action_158
+action_322 (67#) = happyGoto action_159
+action_322 (68#) = happyGoto action_160
+action_322 (69#) = happyGoto action_195
+action_322 (82#) = happyGoto action_196
+action_322 (83#) = happyGoto action_357
+action_322 x = happyTcHack x happyFail
+
+action_323 x = happyTcHack x happyReduce_238
+
+action_324 x = happyTcHack x happyReduce_182
+
+action_325 (95#) = happyShift action_21
+action_325 (97#) = happyShift action_22
+action_325 (98#) = happyShift action_23
+action_325 (111#) = happyShift action_24
+action_325 (115#) = happyShift action_25
+action_325 (117#) = happyShift action_26
+action_325 (118#) = happyShift action_27
+action_325 (119#) = happyShift action_28
+action_325 (120#) = happyShift action_29
+action_325 (121#) = happyShift action_30
+action_325 (122#) = happyShift action_31
+action_325 (123#) = happyShift action_32
+action_325 (124#) = happyShift action_33
+action_325 (128#) = happyShift action_34
+action_325 (131#) = happyShift action_35
+action_325 (134#) = happyShift action_36
+action_325 (137#) = happyShift action_37
+action_325 (142#) = happyShift action_38
+action_325 (153#) = happyShift action_39
+action_325 (154#) = happyShift action_40
+action_325 (158#) = happyShift action_41
+action_325 (159#) = happyShift action_42
+action_325 (164#) = happyShift action_43
+action_325 (167#) = happyShift action_44
+action_325 (170#) = happyShift action_6
+action_325 (171#) = happyShift action_45
+action_325 (172#) = happyShift action_46
+action_325 (173#) = happyShift action_47
+action_325 (174#) = happyShift action_48
+action_325 (8#) = happyGoto action_7
+action_325 (9#) = happyGoto action_8
+action_325 (10#) = happyGoto action_9
+action_325 (11#) = happyGoto action_10
+action_325 (12#) = happyGoto action_11
+action_325 (58#) = happyGoto action_12
+action_325 (59#) = happyGoto action_13
+action_325 (60#) = happyGoto action_14
+action_325 (61#) = happyGoto action_15
+action_325 (62#) = happyGoto action_16
+action_325 (63#) = happyGoto action_356
+action_325 (64#) = happyGoto action_18
+action_325 (72#) = happyGoto action_19
+action_325 (77#) = happyGoto action_20
+action_325 x = happyTcHack x happyFail
+
+action_326 x = happyTcHack x happyReduce_150
+
+action_327 x = happyTcHack x happyReduce_197
+
+action_328 (114#) = happyShift action_355
+action_328 x = happyTcHack x happyFail
+
+action_329 x = happyTcHack x happyReduce_241
+
+action_330 x = happyTcHack x happyReduce_245
+
+action_331 (99#) = happyShift action_354
+action_331 x = happyTcHack x happyFail
+
+action_332 x = happyTcHack x happyReduce_154
+
+action_333 x = happyTcHack x happyReduce_160
+
+action_334 x = happyTcHack x happyReduce_205
+
+action_335 (174#) = happyShift action_48
+action_335 (12#) = happyGoto action_353
+action_335 x = happyTcHack x happyFail
+
+action_336 x = happyTcHack x happyReduce_211
+
+action_337 x = happyTcHack x happyReduce_216
+
+action_338 x = happyTcHack x happyReduce_210
+
+action_339 (95#) = happyShift action_120
+action_339 (98#) = happyShift action_121
+action_339 (105#) = happyShift action_164
+action_339 (111#) = happyShift action_122
+action_339 (115#) = happyShift action_123
+action_339 (123#) = happyShift action_124
+action_339 (126#) = happyShift action_125
+action_339 (167#) = happyShift action_126
+action_339 (170#) = happyShift action_6
+action_339 (171#) = happyShift action_45
+action_339 (172#) = happyShift action_46
+action_339 (174#) = happyShift action_48
+action_339 (8#) = happyGoto action_115
+action_339 (9#) = happyGoto action_116
+action_339 (10#) = happyGoto action_117
+action_339 (12#) = happyGoto action_158
+action_339 (67#) = happyGoto action_159
+action_339 (68#) = happyGoto action_160
+action_339 (69#) = happyGoto action_161
+action_339 (79#) = happyGoto action_162
+action_339 (81#) = happyGoto action_352
+action_339 x = happyTcHack x happyReduce_246
+
+action_340 x = happyTcHack x happyReduce_214
+
+action_341 x = happyTcHack x happyReduce_199
+
+action_342 x = happyTcHack x happyReduce_209
+
+action_343 (174#) = happyShift action_48
+action_343 (12#) = happyGoto action_92
+action_343 (53#) = happyGoto action_154
+action_343 (70#) = happyGoto action_155
+action_343 (73#) = happyGoto action_351
+action_343 x = happyTcHack x happyReduce_229
+
+action_344 (95#) = happyShift action_120
+action_344 (98#) = happyShift action_121
+action_344 (105#) = happyShift action_164
+action_344 (111#) = happyShift action_122
+action_344 (115#) = happyShift action_123
+action_344 (123#) = happyShift action_124
+action_344 (126#) = happyShift action_125
+action_344 (167#) = happyShift action_126
+action_344 (170#) = happyShift action_6
+action_344 (171#) = happyShift action_45
+action_344 (172#) = happyShift action_46
+action_344 (174#) = happyShift action_48
+action_344 (8#) = happyGoto action_115
+action_344 (9#) = happyGoto action_116
+action_344 (10#) = happyGoto action_117
+action_344 (12#) = happyGoto action_158
+action_344 (67#) = happyGoto action_159
+action_344 (68#) = happyGoto action_160
+action_344 (69#) = happyGoto action_350
+action_344 x = happyTcHack x happyFail
+
+action_345 x = happyTcHack x happyReduce_204
+
+action_346 (169#) = happyShift action_349
+action_346 x = happyTcHack x happyFail
+
+action_347 x = happyTcHack x happyReduce_223
+
+action_348 (104#) = happyShift action_190
+action_348 (169#) = happyShift action_207
+action_348 x = happyTcHack x happyReduce_128
+
+action_349 x = happyTcHack x happyReduce_188
+
+action_350 (102#) = happyShift action_306
+action_350 (168#) = happyShift action_308
+action_350 x = happyTcHack x happyReduce_221
+
+action_351 x = happyTcHack x happyReduce_231
+
+action_352 x = happyTcHack x happyReduce_248
+
+action_353 x = happyTcHack x happyReduce_201
+
+action_354 x = happyTcHack x happyReduce_239
+
+action_355 x = happyTcHack x happyReduce_155
+
+action_356 x = happyTcHack x happyReduce_183
+
+action_357 (169#) = happyShift action_468
+action_357 x = happyTcHack x happyFail
+
+action_358 x = happyTcHack x happyReduce_252
+
+action_359 x = happyTcHack x happyReduce_255
+
+action_360 (95#) = happyShift action_21
+action_360 (97#) = happyShift action_22
+action_360 (98#) = happyShift action_23
+action_360 (111#) = happyShift action_24
+action_360 (115#) = happyShift action_25
+action_360 (117#) = happyShift action_26
+action_360 (118#) = happyShift action_27
+action_360 (119#) = happyShift action_28
+action_360 (120#) = happyShift action_29
+action_360 (121#) = happyShift action_30
+action_360 (122#) = happyShift action_31
+action_360 (123#) = happyShift action_32
+action_360 (124#) = happyShift action_33
+action_360 (128#) = happyShift action_34
+action_360 (131#) = happyShift action_35
+action_360 (134#) = happyShift action_36
+action_360 (137#) = happyShift action_37
+action_360 (142#) = happyShift action_38
+action_360 (153#) = happyShift action_39
+action_360 (154#) = happyShift action_40
+action_360 (158#) = happyShift action_41
+action_360 (159#) = happyShift action_42
+action_360 (164#) = happyShift action_43
+action_360 (167#) = happyShift action_44
+action_360 (170#) = happyShift action_6
+action_360 (171#) = happyShift action_45
+action_360 (172#) = happyShift action_46
+action_360 (173#) = happyShift action_47
+action_360 (174#) = happyShift action_48
+action_360 (8#) = happyGoto action_7
+action_360 (9#) = happyGoto action_8
+action_360 (10#) = happyGoto action_9
+action_360 (11#) = happyGoto action_10
+action_360 (12#) = happyGoto action_11
+action_360 (58#) = happyGoto action_12
+action_360 (59#) = happyGoto action_13
+action_360 (60#) = happyGoto action_14
+action_360 (61#) = happyGoto action_15
+action_360 (62#) = happyGoto action_16
+action_360 (63#) = happyGoto action_467
+action_360 (64#) = happyGoto action_18
+action_360 (72#) = happyGoto action_19
+action_360 (77#) = happyGoto action_20
+action_360 x = happyTcHack x happyFail
+
+action_361 (108#) = happyShift action_466
+action_361 x = happyTcHack x happyFail
+
+action_362 (110#) = happyShift action_465
+action_362 x = happyTcHack x happyReduce_258
+
+action_363 (169#) = happyShift action_464
+action_363 x = happyTcHack x happyFail
+
+action_364 x = happyTcHack x happyReduce_195
+
+action_365 x = happyTcHack x happyReduce_215
+
+action_366 (95#) = happyShift action_120
+action_366 (98#) = happyShift action_121
+action_366 (111#) = happyShift action_122
+action_366 (115#) = happyShift action_123
+action_366 (123#) = happyShift action_124
+action_366 (126#) = happyShift action_125
+action_366 (167#) = happyShift action_126
+action_366 (170#) = happyShift action_6
+action_366 (171#) = happyShift action_45
+action_366 (172#) = happyShift action_46
+action_366 (174#) = happyShift action_48
+action_366 (8#) = happyGoto action_115
+action_366 (9#) = happyGoto action_116
+action_366 (10#) = happyGoto action_117
+action_366 (12#) = happyGoto action_118
+action_366 (67#) = happyGoto action_183
+action_366 (74#) = happyGoto action_463
+action_366 x = happyTcHack x happyReduce_205
+
+action_367 x = happyTcHack x happyReduce_218
+
+action_368 x = happyTcHack x happyReduce_249
+
+action_369 x = happyTcHack x happyReduce_219
+
+action_370 x = happyTcHack x happyReduce_251
+
+action_371 x = happyTcHack x happyReduce_165
+
+action_372 x = happyTcHack x happyReduce_164
+
+action_373 (95#) = happyShift action_21
+action_373 (97#) = happyShift action_22
+action_373 (98#) = happyShift action_23
+action_373 (111#) = happyShift action_24
+action_373 (115#) = happyShift action_25
+action_373 (117#) = happyShift action_26
+action_373 (118#) = happyShift action_27
+action_373 (119#) = happyShift action_28
+action_373 (120#) = happyShift action_29
+action_373 (121#) = happyShift action_30
+action_373 (122#) = happyShift action_31
+action_373 (123#) = happyShift action_32
+action_373 (124#) = happyShift action_33
+action_373 (128#) = happyShift action_34
+action_373 (131#) = happyShift action_35
+action_373 (134#) = happyShift action_36
+action_373 (137#) = happyShift action_37
+action_373 (142#) = happyShift action_38
+action_373 (153#) = happyShift action_39
+action_373 (154#) = happyShift action_40
+action_373 (158#) = happyShift action_41
+action_373 (159#) = happyShift action_42
+action_373 (164#) = happyShift action_43
+action_373 (167#) = happyShift action_44
+action_373 (170#) = happyShift action_6
+action_373 (171#) = happyShift action_45
+action_373 (172#) = happyShift action_46
+action_373 (173#) = happyShift action_47
+action_373 (174#) = happyShift action_48
+action_373 (8#) = happyGoto action_7
+action_373 (9#) = happyGoto action_8
+action_373 (10#) = happyGoto action_9
+action_373 (11#) = happyGoto action_10
+action_373 (12#) = happyGoto action_11
+action_373 (58#) = happyGoto action_12
+action_373 (59#) = happyGoto action_13
+action_373 (60#) = happyGoto action_14
+action_373 (61#) = happyGoto action_15
+action_373 (62#) = happyGoto action_16
+action_373 (63#) = happyGoto action_462
+action_373 (64#) = happyGoto action_18
+action_373 (72#) = happyGoto action_19
+action_373 (77#) = happyGoto action_20
+action_373 x = happyTcHack x happyFail
+
+action_374 x = happyTcHack x happyReduce_159
+
+action_375 x = happyTcHack x happyReduce_33
+
+action_376 (104#) = happyShift action_378
+action_376 x = happyTcHack x happyReduce_66
+
+action_377 x = happyTcHack x happyReduce_32
+
+action_378 (174#) = happyShift action_48
+action_378 (12#) = happyGoto action_241
+action_378 (32#) = happyGoto action_461
+action_378 (33#) = happyGoto action_376
+action_378 x = happyTcHack x happyReduce_65
+
+action_379 (98#) = happyShift action_408
+action_379 (174#) = happyShift action_48
+action_379 (12#) = happyGoto action_406
+action_379 (27#) = happyGoto action_460
+action_379 (29#) = happyGoto action_425
+action_379 x = happyTcHack x happyReduce_52
+
+action_380 (174#) = happyShift action_48
+action_380 (12#) = happyGoto action_241
+action_380 (33#) = happyGoto action_459
+action_380 x = happyTcHack x happyReduce_50
+
+action_381 x = happyTcHack x happyReduce_26
+
+action_382 (98#) = happyShift action_408
+action_382 (174#) = happyShift action_48
+action_382 (12#) = happyGoto action_406
+action_382 (27#) = happyGoto action_458
+action_382 (29#) = happyGoto action_425
+action_382 x = happyTcHack x happyReduce_52
+
+action_383 (89#) = happyGoto action_457
+action_383 x = happyTcHack x happyReduce_262
+
+action_384 (123#) = happyShift action_290
+action_384 (174#) = happyShift action_48
+action_384 (12#) = happyGoto action_287
+action_384 (36#) = happyGoto action_288
+action_384 (46#) = happyGoto action_456
+action_384 x = happyTcHack x happyReduce_113
+
+action_385 (97#) = happyShift action_86
+action_385 (98#) = happyShift action_455
+action_385 (111#) = happyShift action_24
+action_385 (115#) = happyShift action_25
+action_385 (118#) = happyShift action_27
+action_385 (119#) = happyShift action_28
+action_385 (120#) = happyShift action_29
+action_385 (121#) = happyShift action_30
+action_385 (122#) = happyShift action_31
+action_385 (123#) = happyShift action_32
+action_385 (131#) = happyShift action_35
+action_385 (167#) = happyShift action_139
+action_385 (170#) = happyShift action_6
+action_385 (171#) = happyShift action_45
+action_385 (172#) = happyShift action_46
+action_385 (173#) = happyShift action_47
+action_385 (174#) = happyShift action_48
+action_385 (8#) = happyGoto action_7
+action_385 (9#) = happyGoto action_8
+action_385 (10#) = happyGoto action_9
+action_385 (11#) = happyGoto action_10
+action_385 (12#) = happyGoto action_84
+action_385 (58#) = happyGoto action_453
+action_385 (72#) = happyGoto action_19
+action_385 (88#) = happyGoto action_454
+action_385 x = happyTcHack x happyReduce_95
+
+action_386 (174#) = happyShift action_48
+action_386 (12#) = happyGoto action_451
+action_386 (38#) = happyGoto action_284
+action_386 (48#) = happyGoto action_452
+action_386 x = happyTcHack x happyReduce_117
+
+action_387 (174#) = happyShift action_48
+action_387 (12#) = happyGoto action_448
+action_387 (39#) = happyGoto action_449
+action_387 (40#) = happyGoto action_450
+action_387 x = happyTcHack x happyReduce_102
+
+action_388 (174#) = happyShift action_48
+action_388 (12#) = happyGoto action_279
+action_388 (44#) = happyGoto action_280
+action_388 (51#) = happyGoto action_447
+action_388 x = happyTcHack x happyReduce_123
+
+action_389 (174#) = happyShift action_48
+action_389 (12#) = happyGoto action_446
+action_389 x = happyTcHack x happyFail
+
+action_390 (95#) = happyShift action_21
+action_390 (97#) = happyShift action_22
+action_390 (98#) = happyShift action_23
+action_390 (111#) = happyShift action_24
+action_390 (115#) = happyShift action_25
+action_390 (117#) = happyShift action_26
+action_390 (118#) = happyShift action_27
+action_390 (119#) = happyShift action_28
+action_390 (120#) = happyShift action_29
+action_390 (121#) = happyShift action_30
+action_390 (122#) = happyShift action_31
+action_390 (123#) = happyShift action_32
+action_390 (124#) = happyShift action_33
+action_390 (128#) = happyShift action_34
+action_390 (131#) = happyShift action_35
+action_390 (134#) = happyShift action_36
+action_390 (137#) = happyShift action_37
+action_390 (142#) = happyShift action_38
+action_390 (153#) = happyShift action_39
+action_390 (154#) = happyShift action_40
+action_390 (158#) = happyShift action_41
+action_390 (159#) = happyShift action_42
+action_390 (164#) = happyShift action_43
+action_390 (167#) = happyShift action_44
+action_390 (170#) = happyShift action_6
+action_390 (171#) = happyShift action_45
+action_390 (172#) = happyShift action_46
+action_390 (173#) = happyShift action_47
+action_390 (174#) = happyShift action_48
+action_390 (8#) = happyGoto action_7
+action_390 (9#) = happyGoto action_8
+action_390 (10#) = happyGoto action_9
+action_390 (11#) = happyGoto action_10
+action_390 (12#) = happyGoto action_11
+action_390 (58#) = happyGoto action_12
+action_390 (59#) = happyGoto action_13
+action_390 (60#) = happyGoto action_14
+action_390 (61#) = happyGoto action_15
+action_390 (62#) = happyGoto action_16
+action_390 (63#) = happyGoto action_445
+action_390 (64#) = happyGoto action_18
+action_390 (72#) = happyGoto action_19
+action_390 (77#) = happyGoto action_20
+action_390 x = happyTcHack x happyFail
+
+action_391 (174#) = happyShift action_48
+action_391 (12#) = happyGoto action_92
+action_391 (37#) = happyGoto action_276
+action_391 (47#) = happyGoto action_444
+action_391 (53#) = happyGoto action_278
+action_391 x = happyTcHack x happyReduce_115
+
+action_392 (167#) = happyShift action_443
+action_392 x = happyTcHack x happyFail
+
+action_393 (174#) = happyShift action_48
+action_393 (12#) = happyGoto action_267
+action_393 (41#) = happyGoto action_268
+action_393 (49#) = happyGoto action_442
+action_393 x = happyTcHack x happyReduce_119
+
+action_394 (98#) = happyShift action_441
+action_394 (174#) = happyShift action_48
+action_394 (12#) = happyGoto action_438
+action_394 (42#) = happyGoto action_439
+action_394 (52#) = happyGoto action_440
+action_394 x = happyTcHack x happyReduce_125
+
+action_395 x = happyTcHack x happyReduce_87
+
+action_396 x = happyTcHack x happyReduce_86
+
+action_397 (95#) = happyShift action_21
+action_397 (97#) = happyShift action_22
+action_397 (98#) = happyShift action_23
+action_397 (111#) = happyShift action_24
+action_397 (115#) = happyShift action_25
+action_397 (117#) = happyShift action_26
+action_397 (118#) = happyShift action_27
+action_397 (119#) = happyShift action_28
+action_397 (120#) = happyShift action_29
+action_397 (121#) = happyShift action_30
+action_397 (122#) = happyShift action_31
+action_397 (123#) = happyShift action_32
+action_397 (124#) = happyShift action_33
+action_397 (128#) = happyShift action_34
+action_397 (131#) = happyShift action_35
+action_397 (134#) = happyShift action_36
+action_397 (137#) = happyShift action_37
+action_397 (142#) = happyShift action_38
+action_397 (153#) = happyShift action_39
+action_397 (154#) = happyShift action_40
+action_397 (158#) = happyShift action_41
+action_397 (159#) = happyShift action_42
+action_397 (164#) = happyShift action_43
+action_397 (167#) = happyShift action_44
+action_397 (170#) = happyShift action_6
+action_397 (171#) = happyShift action_45
+action_397 (172#) = happyShift action_46
+action_397 (173#) = happyShift action_47
+action_397 (174#) = happyShift action_48
+action_397 (8#) = happyGoto action_7
+action_397 (9#) = happyGoto action_8
+action_397 (10#) = happyGoto action_9
+action_397 (11#) = happyGoto action_10
+action_397 (12#) = happyGoto action_11
+action_397 (58#) = happyGoto action_12
+action_397 (59#) = happyGoto action_13
+action_397 (60#) = happyGoto action_14
+action_397 (61#) = happyGoto action_15
+action_397 (62#) = happyGoto action_16
+action_397 (63#) = happyGoto action_437
+action_397 (64#) = happyGoto action_18
+action_397 (72#) = happyGoto action_19
+action_397 (77#) = happyGoto action_20
+action_397 x = happyTcHack x happyFail
+
+action_398 (123#) = happyShift action_257
+action_398 (174#) = happyShift action_48
+action_398 (12#) = happyGoto action_252
+action_398 (54#) = happyGoto action_262
+action_398 (55#) = happyGoto action_436
+action_398 x = happyTcHack x happyFail
+
+action_399 (123#) = happyShift action_257
+action_399 (174#) = happyShift action_48
+action_399 (12#) = happyGoto action_252
+action_399 (43#) = happyGoto action_260
+action_399 (50#) = happyGoto action_435
+action_399 (54#) = happyGoto action_262
+action_399 (55#) = happyGoto action_263
+action_399 x = happyTcHack x happyReduce_121
+
+action_400 x = happyTcHack x happyReduce_94
+
+action_401 (125#) = happyShift action_434
+action_401 x = happyTcHack x happyFail
+
+action_402 (95#) = happyShift action_21
+action_402 (97#) = happyShift action_22
+action_402 (98#) = happyShift action_23
+action_402 (111#) = happyShift action_24
+action_402 (115#) = happyShift action_25
+action_402 (117#) = happyShift action_26
+action_402 (118#) = happyShift action_27
+action_402 (119#) = happyShift action_28
+action_402 (120#) = happyShift action_29
+action_402 (121#) = happyShift action_30
+action_402 (122#) = happyShift action_31
+action_402 (123#) = happyShift action_32
+action_402 (124#) = happyShift action_33
+action_402 (128#) = happyShift action_34
+action_402 (131#) = happyShift action_35
+action_402 (134#) = happyShift action_36
+action_402 (137#) = happyShift action_37
+action_402 (142#) = happyShift action_38
+action_402 (153#) = happyShift action_39
+action_402 (154#) = happyShift action_40
+action_402 (158#) = happyShift action_41
+action_402 (159#) = happyShift action_42
+action_402 (164#) = happyShift action_43
+action_402 (167#) = happyShift action_44
+action_402 (170#) = happyShift action_6
+action_402 (171#) = happyShift action_45
+action_402 (172#) = happyShift action_46
+action_402 (173#) = happyShift action_47
+action_402 (174#) = happyShift action_48
+action_402 (8#) = happyGoto action_7
+action_402 (9#) = happyGoto action_8
+action_402 (10#) = happyGoto action_9
+action_402 (11#) = happyGoto action_10
+action_402 (12#) = happyGoto action_11
+action_402 (58#) = happyGoto action_12
+action_402 (59#) = happyGoto action_13
+action_402 (60#) = happyGoto action_14
+action_402 (61#) = happyGoto action_15
+action_402 (62#) = happyGoto action_16
+action_402 (63#) = happyGoto action_433
+action_402 (64#) = happyGoto action_18
+action_402 (72#) = happyGoto action_19
+action_402 (77#) = happyGoto action_20
+action_402 x = happyTcHack x happyFail
+
+action_403 (95#) = happyShift action_21
+action_403 (97#) = happyShift action_22
+action_403 (98#) = happyShift action_23
+action_403 (111#) = happyShift action_24
+action_403 (115#) = happyShift action_25
+action_403 (117#) = happyShift action_26
+action_403 (118#) = happyShift action_27
+action_403 (119#) = happyShift action_28
+action_403 (120#) = happyShift action_29
+action_403 (121#) = happyShift action_30
+action_403 (122#) = happyShift action_31
+action_403 (123#) = happyShift action_32
+action_403 (124#) = happyShift action_33
+action_403 (128#) = happyShift action_34
+action_403 (131#) = happyShift action_35
+action_403 (134#) = happyShift action_36
+action_403 (137#) = happyShift action_37
+action_403 (142#) = happyShift action_38
+action_403 (153#) = happyShift action_39
+action_403 (154#) = happyShift action_40
+action_403 (158#) = happyShift action_41
+action_403 (159#) = happyShift action_42
+action_403 (164#) = happyShift action_43
+action_403 (167#) = happyShift action_44
+action_403 (170#) = happyShift action_6
+action_403 (171#) = happyShift action_45
+action_403 (172#) = happyShift action_46
+action_403 (173#) = happyShift action_47
+action_403 (174#) = happyShift action_48
+action_403 (8#) = happyGoto action_7
+action_403 (9#) = happyGoto action_8
+action_403 (10#) = happyGoto action_9
+action_403 (11#) = happyGoto action_10
+action_403 (12#) = happyGoto action_11
+action_403 (58#) = happyGoto action_12
+action_403 (59#) = happyGoto action_13
+action_403 (60#) = happyGoto action_14
+action_403 (61#) = happyGoto action_15
+action_403 (62#) = happyGoto action_16
+action_403 (63#) = happyGoto action_432
+action_403 (64#) = happyGoto action_18
+action_403 (72#) = happyGoto action_19
+action_403 (77#) = happyGoto action_20
+action_403 x = happyTcHack x happyFail
+
+action_404 (112#) = happyShift action_431
+action_404 x = happyTcHack x happyFail
+
+action_405 (123#) = happyShift action_257
+action_405 (174#) = happyShift action_48
+action_405 (12#) = happyGoto action_252
+action_405 (34#) = happyGoto action_253
+action_405 (45#) = happyGoto action_430
+action_405 (54#) = happyGoto action_255
+action_405 (55#) = happyGoto action_256
+action_405 x = happyTcHack x happyReduce_111
+
+action_406 x = happyTcHack x happyReduce_57
+
+action_407 (106#) = happyShift action_429
+action_407 x = happyTcHack x happyFail
+
+action_408 (139#) = happyShift action_427
+action_408 (141#) = happyShift action_428
+action_408 (31#) = happyGoto action_426
+action_408 x = happyTcHack x happyReduce_62
+
+action_409 x = happyTcHack x happyReduce_38
+
+action_410 x = happyTcHack x happyReduce_37
+
+action_411 x = happyTcHack x happyReduce_47
+
+action_412 x = happyTcHack x happyReduce_46
+
+action_413 (98#) = happyShift action_408
+action_413 (174#) = happyShift action_48
+action_413 (12#) = happyGoto action_406
+action_413 (27#) = happyGoto action_424
+action_413 (29#) = happyGoto action_425
+action_413 x = happyTcHack x happyReduce_52
+
+action_414 (174#) = happyShift action_48
+action_414 (12#) = happyGoto action_241
+action_414 (33#) = happyGoto action_423
+action_414 x = happyTcHack x happyReduce_50
+
+action_415 (167#) = happyShift action_422
+action_415 x = happyTcHack x happyFail
+
+action_416 (123#) = happyShift action_421
+action_416 x = happyTcHack x happyFail
+
+action_417 (174#) = happyShift action_48
+action_417 (12#) = happyGoto action_92
+action_417 (53#) = happyGoto action_420
+action_417 x = happyTcHack x happyFail
+
+action_418 (112#) = happyShift action_419
+action_418 x = happyTcHack x happyFail
+
+action_419 (174#) = happyShift action_48
+action_419 (12#) = happyGoto action_492
+action_419 x = happyTcHack x happyFail
+
+action_420 (125#) = happyShift action_491
+action_420 x = happyTcHack x happyFail
+
+action_421 (174#) = happyShift action_48
+action_421 (12#) = happyGoto action_92
+action_421 (53#) = happyGoto action_490
+action_421 x = happyTcHack x happyFail
+
+action_422 (25#) = happyGoto action_489
+action_422 x = happyTcHack x happyReduce_48
+
+action_423 (166#) = happyShift action_488
+action_423 x = happyTcHack x happyFail
+
+action_424 (101#) = happyShift action_487
+action_424 x = happyTcHack x happyReduce_42
+
+action_425 (104#) = happyShift action_486
+action_425 x = happyTcHack x happyReduce_53
+
+action_426 (174#) = happyShift action_48
+action_426 (12#) = happyGoto action_485
+action_426 x = happyTcHack x happyFail
+
+action_427 x = happyTcHack x happyReduce_63
+
+action_428 x = happyTcHack x happyReduce_64
+
+action_429 (98#) = happyShift action_408
+action_429 (174#) = happyShift action_48
+action_429 (12#) = happyGoto action_406
+action_429 (29#) = happyGoto action_484
+action_429 x = happyTcHack x happyFail
+
+action_430 x = happyTcHack x happyReduce_112
+
+action_431 (95#) = happyShift action_21
+action_431 (97#) = happyShift action_22
+action_431 (98#) = happyShift action_23
+action_431 (111#) = happyShift action_24
+action_431 (115#) = happyShift action_25
+action_431 (117#) = happyShift action_26
+action_431 (118#) = happyShift action_27
+action_431 (119#) = happyShift action_28
+action_431 (120#) = happyShift action_29
+action_431 (121#) = happyShift action_30
+action_431 (122#) = happyShift action_31
+action_431 (123#) = happyShift action_32
+action_431 (124#) = happyShift action_33
+action_431 (128#) = happyShift action_34
+action_431 (131#) = happyShift action_35
+action_431 (134#) = happyShift action_36
+action_431 (137#) = happyShift action_37
+action_431 (142#) = happyShift action_38
+action_431 (153#) = happyShift action_39
+action_431 (154#) = happyShift action_40
+action_431 (158#) = happyShift action_41
+action_431 (159#) = happyShift action_42
+action_431 (164#) = happyShift action_43
+action_431 (167#) = happyShift action_44
+action_431 (170#) = happyShift action_6
+action_431 (171#) = happyShift action_45
+action_431 (172#) = happyShift action_46
+action_431 (173#) = happyShift action_47
+action_431 (174#) = happyShift action_48
+action_431 (8#) = happyGoto action_7
+action_431 (9#) = happyGoto action_8
+action_431 (10#) = happyGoto action_9
+action_431 (11#) = happyGoto action_10
+action_431 (12#) = happyGoto action_11
+action_431 (58#) = happyGoto action_12
+action_431 (59#) = happyGoto action_13
+action_431 (60#) = happyGoto action_14
+action_431 (61#) = happyGoto action_15
+action_431 (62#) = happyGoto action_16
+action_431 (63#) = happyGoto action_483
+action_431 (64#) = happyGoto action_18
+action_431 (72#) = happyGoto action_19
+action_431 (77#) = happyGoto action_20
+action_431 x = happyTcHack x happyFail
+
+action_432 x = happyTcHack x happyReduce_72
+
+action_433 (112#) = happyShift action_482
+action_433 x = happyTcHack x happyReduce_71
+
+action_434 x = happyTcHack x happyReduce_131
+
+action_435 x = happyTcHack x happyReduce_122
+
+action_436 x = happyTcHack x happyReduce_133
+
+action_437 x = happyTcHack x happyReduce_109
+
+action_438 (89#) = happyGoto action_481
+action_438 x = happyTcHack x happyReduce_262
+
+action_439 (168#) = happyShift action_480
+action_439 x = happyTcHack x happyReduce_126
+
+action_440 x = happyTcHack x happyReduce_105
+
+action_441 (137#) = happyShift action_479
+action_441 x = happyTcHack x happyFail
+
+action_442 x = happyTcHack x happyReduce_120
+
+action_443 (25#) = happyGoto action_478
+action_443 x = happyTcHack x happyReduce_48
+
+action_444 x = happyTcHack x happyReduce_116
+
+action_445 x = happyTcHack x happyReduce_98
+
+action_446 x = happyTcHack x happyReduce_110
+
+action_447 x = happyTcHack x happyReduce_124
+
+action_448 (107#) = happyShift action_477
+action_448 x = happyTcHack x happyReduce_100
+
+action_449 (168#) = happyShift action_476
+action_449 x = happyTcHack x happyReduce_103
+
+action_450 x = happyTcHack x happyReduce_99
+
+action_451 (112#) = happyShift action_387
+action_451 x = happyTcHack x happyFail
+
+action_452 x = happyTcHack x happyReduce_118
+
+action_453 x = happyTcHack x happyReduce_261
+
+action_454 x = happyTcHack x happyReduce_263
+
+action_455 (95#) = happyShift action_21
+action_455 (97#) = happyShift action_22
+action_455 (98#) = happyShift action_23
+action_455 (111#) = happyShift action_24
+action_455 (115#) = happyShift action_25
+action_455 (117#) = happyShift action_26
+action_455 (118#) = happyShift action_27
+action_455 (119#) = happyShift action_28
+action_455 (120#) = happyShift action_29
+action_455 (121#) = happyShift action_30
+action_455 (122#) = happyShift action_31
+action_455 (123#) = happyShift action_32
+action_455 (124#) = happyShift action_33
+action_455 (126#) = happyShift action_102
+action_455 (128#) = happyShift action_34
+action_455 (131#) = happyShift action_35
+action_455 (134#) = happyShift action_36
+action_455 (137#) = happyShift action_113
+action_455 (142#) = happyShift action_38
+action_455 (153#) = happyShift action_39
+action_455 (154#) = happyShift action_40
+action_455 (158#) = happyShift action_41
+action_455 (159#) = happyShift action_42
+action_455 (164#) = happyShift action_43
+action_455 (167#) = happyShift action_44
+action_455 (170#) = happyShift action_6
+action_455 (171#) = happyShift action_45
+action_455 (172#) = happyShift action_46
+action_455 (173#) = happyShift action_47
+action_455 (174#) = happyShift action_48
+action_455 (8#) = happyGoto action_7
+action_455 (9#) = happyGoto action_8
+action_455 (10#) = happyGoto action_9
+action_455 (11#) = happyGoto action_10
+action_455 (12#) = happyGoto action_110
+action_455 (58#) = happyGoto action_12
+action_455 (59#) = happyGoto action_13
+action_455 (60#) = happyGoto action_14
+action_455 (61#) = happyGoto action_15
+action_455 (62#) = happyGoto action_16
+action_455 (63#) = happyGoto action_111
+action_455 (64#) = happyGoto action_18
+action_455 (72#) = happyGoto action_19
+action_455 (75#) = happyGoto action_99
+action_455 (76#) = happyGoto action_475
+action_455 (77#) = happyGoto action_20
+action_455 x = happyTcHack x happyReduce_236
+
+action_456 x = happyTcHack x happyReduce_114
+
+action_457 (97#) = happyShift action_86
+action_457 (98#) = happyShift action_455
+action_457 (111#) = happyShift action_24
+action_457 (115#) = happyShift action_25
+action_457 (118#) = happyShift action_27
+action_457 (119#) = happyShift action_28
+action_457 (120#) = happyShift action_29
+action_457 (121#) = happyShift action_30
+action_457 (122#) = happyShift action_31
+action_457 (123#) = happyShift action_32
+action_457 (125#) = happyShift action_474
+action_457 (131#) = happyShift action_35
+action_457 (167#) = happyShift action_139
+action_457 (170#) = happyShift action_6
+action_457 (171#) = happyShift action_45
+action_457 (172#) = happyShift action_46
+action_457 (173#) = happyShift action_47
+action_457 (174#) = happyShift action_48
+action_457 (8#) = happyGoto action_7
+action_457 (9#) = happyGoto action_8
+action_457 (10#) = happyGoto action_9
+action_457 (11#) = happyGoto action_10
+action_457 (12#) = happyGoto action_84
+action_457 (58#) = happyGoto action_453
+action_457 (72#) = happyGoto action_19
+action_457 (88#) = happyGoto action_454
+action_457 x = happyTcHack x happyFail
+
+action_458 (137#) = happyShift action_473
+action_458 x = happyTcHack x happyFail
+
+action_459 (166#) = happyShift action_472
+action_459 x = happyTcHack x happyFail
+
+action_460 (101#) = happyShift action_471
+action_460 x = happyTcHack x happyReduce_28
+
+action_461 x = happyTcHack x happyReduce_67
+
+action_462 x = happyTcHack x happyReduce_136
+
+action_463 x = happyTcHack x happyReduce_213
+
+action_464 x = happyTcHack x happyReduce_168
+
+action_465 (95#) = happyShift action_21
+action_465 (97#) = happyShift action_22
+action_465 (98#) = happyShift action_23
+action_465 (111#) = happyShift action_24
+action_465 (115#) = happyShift action_25
+action_465 (117#) = happyShift action_26
+action_465 (118#) = happyShift action_27
+action_465 (119#) = happyShift action_28
+action_465 (120#) = happyShift action_29
+action_465 (121#) = happyShift action_30
+action_465 (122#) = happyShift action_31
+action_465 (123#) = happyShift action_32
+action_465 (124#) = happyShift action_33
+action_465 (128#) = happyShift action_34
+action_465 (131#) = happyShift action_35
+action_465 (134#) = happyShift action_36
+action_465 (137#) = happyShift action_37
+action_465 (142#) = happyShift action_38
+action_465 (153#) = happyShift action_39
+action_465 (154#) = happyShift action_40
+action_465 (158#) = happyShift action_41
+action_465 (159#) = happyShift action_42
+action_465 (164#) = happyShift action_43
+action_465 (167#) = happyShift action_44
+action_465 (170#) = happyShift action_6
+action_465 (171#) = happyShift action_45
+action_465 (172#) = happyShift action_46
+action_465 (173#) = happyShift action_47
+action_465 (174#) = happyShift action_48
+action_465 (8#) = happyGoto action_7
+action_465 (9#) = happyGoto action_8
+action_465 (10#) = happyGoto action_9
+action_465 (11#) = happyGoto action_10
+action_465 (12#) = happyGoto action_11
+action_465 (58#) = happyGoto action_12
+action_465 (59#) = happyGoto action_13
+action_465 (60#) = happyGoto action_14
+action_465 (61#) = happyGoto action_15
+action_465 (62#) = happyGoto action_16
+action_465 (63#) = happyGoto action_361
+action_465 (64#) = happyGoto action_18
+action_465 (72#) = happyGoto action_19
+action_465 (77#) = happyGoto action_20
+action_465 (86#) = happyGoto action_362
+action_465 (87#) = happyGoto action_470
+action_465 x = happyTcHack x happyReduce_257
+
+action_466 (95#) = happyShift action_21
+action_466 (97#) = happyShift action_22
+action_466 (98#) = happyShift action_23
+action_466 (111#) = happyShift action_24
+action_466 (115#) = happyShift action_25
+action_466 (117#) = happyShift action_26
+action_466 (118#) = happyShift action_27
+action_466 (119#) = happyShift action_28
+action_466 (120#) = happyShift action_29
+action_466 (121#) = happyShift action_30
+action_466 (122#) = happyShift action_31
+action_466 (123#) = happyShift action_32
+action_466 (124#) = happyShift action_33
+action_466 (128#) = happyShift action_34
+action_466 (131#) = happyShift action_35
+action_466 (134#) = happyShift action_36
+action_466 (137#) = happyShift action_37
+action_466 (142#) = happyShift action_38
+action_466 (153#) = happyShift action_39
+action_466 (154#) = happyShift action_40
+action_466 (158#) = happyShift action_41
+action_466 (159#) = happyShift action_42
+action_466 (164#) = happyShift action_43
+action_466 (167#) = happyShift action_44
+action_466 (170#) = happyShift action_6
+action_466 (171#) = happyShift action_45
+action_466 (172#) = happyShift action_46
+action_466 (173#) = happyShift action_47
+action_466 (174#) = happyShift action_48
+action_466 (8#) = happyGoto action_7
+action_466 (9#) = happyGoto action_8
+action_466 (10#) = happyGoto action_9
+action_466 (11#) = happyGoto action_10
+action_466 (12#) = happyGoto action_11
+action_466 (58#) = happyGoto action_12
+action_466 (59#) = happyGoto action_13
+action_466 (60#) = happyGoto action_14
+action_466 (61#) = happyGoto action_15
+action_466 (62#) = happyGoto action_16
+action_466 (63#) = happyGoto action_469
+action_466 (64#) = happyGoto action_18
+action_466 (72#) = happyGoto action_19
+action_466 (77#) = happyGoto action_20
+action_466 x = happyTcHack x happyFail
+
+action_467 x = happyTcHack x happyReduce_186
+
+action_468 x = happyTcHack x happyReduce_166
+
+action_469 x = happyTcHack x happyReduce_256
+
+action_470 x = happyTcHack x happyReduce_259
+
+action_471 (148#) = happyShift action_382
+action_471 (28#) = happyGoto action_510
+action_471 x = happyTcHack x happyReduce_55
+
+action_472 (98#) = happyShift action_408
+action_472 (174#) = happyShift action_48
+action_472 (12#) = happyGoto action_406
+action_472 (27#) = happyGoto action_509
+action_472 (29#) = happyGoto action_425
+action_472 x = happyTcHack x happyReduce_52
+
+action_473 x = happyTcHack x happyReduce_56
+
+action_474 (167#) = happyShift action_508
+action_474 x = happyTcHack x happyReduce_96
+
+action_475 (109#) = happyShift action_507
+action_475 x = happyTcHack x happyFail
+
+action_476 (174#) = happyShift action_48
+action_476 (12#) = happyGoto action_448
+action_476 (39#) = happyGoto action_449
+action_476 (40#) = happyGoto action_506
+action_476 x = happyTcHack x happyReduce_102
+
+action_477 (174#) = happyShift action_48
+action_477 (12#) = happyGoto action_505
+action_477 x = happyTcHack x happyFail
+
+action_478 (129#) = happyShift action_210
+action_478 (131#) = happyShift action_211
+action_478 (132#) = happyShift action_212
+action_478 (133#) = happyShift action_213
+action_478 (135#) = happyShift action_214
+action_478 (143#) = happyShift action_215
+action_478 (144#) = happyShift action_216
+action_478 (145#) = happyShift action_217
+action_478 (146#) = happyShift action_218
+action_478 (149#) = happyShift action_219
+action_478 (151#) = happyShift action_220
+action_478 (152#) = happyShift action_221
+action_478 (153#) = happyShift action_222
+action_478 (155#) = happyShift action_223
+action_478 (160#) = happyShift action_224
+action_478 (161#) = happyShift action_225
+action_478 (163#) = happyShift action_226
+action_478 (169#) = happyShift action_504
+action_478 (35#) = happyGoto action_209
+action_478 x = happyTcHack x happyFail
+
+action_479 (174#) = happyShift action_48
+action_479 (12#) = happyGoto action_503
+action_479 x = happyTcHack x happyFail
+
+action_480 (174#) = happyShift action_48
+action_480 (12#) = happyGoto action_438
+action_480 (42#) = happyGoto action_439
+action_480 (52#) = happyGoto action_502
+action_480 x = happyTcHack x happyReduce_125
+
+action_481 (97#) = happyShift action_86
+action_481 (98#) = happyShift action_455
+action_481 (111#) = happyShift action_24
+action_481 (115#) = happyShift action_25
+action_481 (118#) = happyShift action_27
+action_481 (119#) = happyShift action_28
+action_481 (120#) = happyShift action_29
+action_481 (121#) = happyShift action_30
+action_481 (122#) = happyShift action_31
+action_481 (123#) = happyShift action_32
+action_481 (131#) = happyShift action_35
+action_481 (167#) = happyShift action_139
+action_481 (170#) = happyShift action_6
+action_481 (171#) = happyShift action_45
+action_481 (172#) = happyShift action_46
+action_481 (173#) = happyShift action_47
+action_481 (174#) = happyShift action_48
+action_481 (8#) = happyGoto action_7
+action_481 (9#) = happyGoto action_8
+action_481 (10#) = happyGoto action_9
+action_481 (11#) = happyGoto action_10
+action_481 (12#) = happyGoto action_84
+action_481 (58#) = happyGoto action_453
+action_481 (72#) = happyGoto action_19
+action_481 (88#) = happyGoto action_454
+action_481 x = happyTcHack x happyReduce_108
+
+action_482 (95#) = happyShift action_21
+action_482 (97#) = happyShift action_22
+action_482 (98#) = happyShift action_23
+action_482 (111#) = happyShift action_24
+action_482 (115#) = happyShift action_25
+action_482 (117#) = happyShift action_26
+action_482 (118#) = happyShift action_27
+action_482 (119#) = happyShift action_28
+action_482 (120#) = happyShift action_29
+action_482 (121#) = happyShift action_30
+action_482 (122#) = happyShift action_31
+action_482 (123#) = happyShift action_32
+action_482 (124#) = happyShift action_33
+action_482 (128#) = happyShift action_34
+action_482 (131#) = happyShift action_35
+action_482 (134#) = happyShift action_36
+action_482 (137#) = happyShift action_37
+action_482 (142#) = happyShift action_38
+action_482 (153#) = happyShift action_39
+action_482 (154#) = happyShift action_40
+action_482 (158#) = happyShift action_41
+action_482 (159#) = happyShift action_42
+action_482 (164#) = happyShift action_43
+action_482 (167#) = happyShift action_44
+action_482 (170#) = happyShift action_6
+action_482 (171#) = happyShift action_45
+action_482 (172#) = happyShift action_46
+action_482 (173#) = happyShift action_47
+action_482 (174#) = happyShift action_48
+action_482 (8#) = happyGoto action_7
+action_482 (9#) = happyGoto action_8
+action_482 (10#) = happyGoto action_9
+action_482 (11#) = happyGoto action_10
+action_482 (12#) = happyGoto action_11
+action_482 (58#) = happyGoto action_12
+action_482 (59#) = happyGoto action_13
+action_482 (60#) = happyGoto action_14
+action_482 (61#) = happyGoto action_15
+action_482 (62#) = happyGoto action_16
+action_482 (63#) = happyGoto action_501
+action_482 (64#) = happyGoto action_18
+action_482 (72#) = happyGoto action_19
+action_482 (77#) = happyGoto action_20
+action_482 x = happyTcHack x happyFail
+
+action_483 x = happyTcHack x happyReduce_73
+
+action_484 x = happyTcHack x happyReduce_39
+
+action_485 (99#) = happyShift action_499
+action_485 (112#) = happyShift action_500
+action_485 x = happyTcHack x happyFail
+
+action_486 (98#) = happyShift action_408
+action_486 (174#) = happyShift action_48
+action_486 (12#) = happyGoto action_406
+action_486 (27#) = happyGoto action_498
+action_486 (29#) = happyGoto action_425
+action_486 x = happyTcHack x happyReduce_52
+
+action_487 (148#) = happyShift action_382
+action_487 (28#) = happyGoto action_497
+action_487 x = happyTcHack x happyReduce_55
+
+action_488 (98#) = happyShift action_408
+action_488 (174#) = happyShift action_48
+action_488 (12#) = happyGoto action_406
+action_488 (27#) = happyGoto action_496
+action_488 (29#) = happyGoto action_425
+action_488 x = happyTcHack x happyReduce_52
+
+action_489 (129#) = happyShift action_210
+action_489 (131#) = happyShift action_211
+action_489 (132#) = happyShift action_212
+action_489 (133#) = happyShift action_213
+action_489 (135#) = happyShift action_214
+action_489 (143#) = happyShift action_215
+action_489 (144#) = happyShift action_216
+action_489 (145#) = happyShift action_217
+action_489 (146#) = happyShift action_218
+action_489 (149#) = happyShift action_219
+action_489 (151#) = happyShift action_220
+action_489 (152#) = happyShift action_221
+action_489 (153#) = happyShift action_222
+action_489 (155#) = happyShift action_223
+action_489 (160#) = happyShift action_224
+action_489 (161#) = happyShift action_225
+action_489 (163#) = happyShift action_226
+action_489 (169#) = happyShift action_495
+action_489 (35#) = happyGoto action_209
+action_489 x = happyTcHack x happyFail
+
+action_490 (125#) = happyShift action_494
+action_490 x = happyTcHack x happyFail
+
+action_491 x = happyTcHack x happyReduce_69
+
+action_492 (110#) = happyShift action_493
+action_492 x = happyTcHack x happyFail
+
+action_493 (174#) = happyShift action_48
+action_493 (12#) = happyGoto action_519
+action_493 (16#) = happyGoto action_520
+action_493 (17#) = happyGoto action_521
+action_493 x = happyTcHack x happyReduce_17
+
+action_494 x = happyTcHack x happyReduce_70
+
+action_495 x = happyTcHack x happyReduce_40
+
+action_496 (101#) = happyShift action_518
+action_496 x = happyTcHack x happyReduce_44
+
+action_497 (167#) = happyShift action_517
+action_497 x = happyTcHack x happyFail
+
+action_498 x = happyTcHack x happyReduce_54
+
+action_499 x = happyTcHack x happyReduce_58
+
+action_500 (174#) = happyShift action_48
+action_500 (12#) = happyGoto action_516
+action_500 x = happyTcHack x happyFail
+
+action_501 x = happyTcHack x happyReduce_74
+
+action_502 x = happyTcHack x happyReduce_127
+
+action_503 (99#) = happyShift action_515
+action_503 x = happyTcHack x happyFail
+
+action_504 (110#) = happyShift action_514
+action_504 x = happyTcHack x happyFail
+
+action_505 x = happyTcHack x happyReduce_101
+
+action_506 x = happyTcHack x happyReduce_104
+
+action_507 (95#) = happyShift action_21
+action_507 (97#) = happyShift action_22
+action_507 (98#) = happyShift action_23
+action_507 (111#) = happyShift action_24
+action_507 (115#) = happyShift action_25
+action_507 (117#) = happyShift action_26
+action_507 (118#) = happyShift action_27
+action_507 (119#) = happyShift action_28
+action_507 (120#) = happyShift action_29
+action_507 (121#) = happyShift action_30
+action_507 (122#) = happyShift action_31
+action_507 (123#) = happyShift action_32
+action_507 (124#) = happyShift action_33
+action_507 (128#) = happyShift action_34
+action_507 (131#) = happyShift action_35
+action_507 (134#) = happyShift action_36
+action_507 (137#) = happyShift action_37
+action_507 (142#) = happyShift action_38
+action_507 (153#) = happyShift action_39
+action_507 (154#) = happyShift action_40
+action_507 (158#) = happyShift action_41
+action_507 (159#) = happyShift action_42
+action_507 (164#) = happyShift action_43
+action_507 (167#) = happyShift action_44
+action_507 (170#) = happyShift action_6
+action_507 (171#) = happyShift action_45
+action_507 (172#) = happyShift action_46
+action_507 (173#) = happyShift action_47
+action_507 (174#) = happyShift action_48
+action_507 (8#) = happyGoto action_7
+action_507 (9#) = happyGoto action_8
+action_507 (10#) = happyGoto action_9
+action_507 (11#) = happyGoto action_10
+action_507 (12#) = happyGoto action_11
+action_507 (58#) = happyGoto action_12
+action_507 (59#) = happyGoto action_13
+action_507 (60#) = happyGoto action_14
+action_507 (61#) = happyGoto action_15
+action_507 (62#) = happyGoto action_16
+action_507 (63#) = happyGoto action_513
+action_507 (64#) = happyGoto action_18
+action_507 (72#) = happyGoto action_19
+action_507 (77#) = happyGoto action_20
+action_507 x = happyTcHack x happyFail
+
+action_508 (170#) = happyShift action_6
+action_508 (8#) = happyGoto action_512
+action_508 x = happyTcHack x happyFail
+
+action_509 (101#) = happyShift action_511
+action_509 x = happyTcHack x happyReduce_30
+
+action_510 x = happyTcHack x happyReduce_29
+
+action_511 (148#) = happyShift action_382
+action_511 (28#) = happyGoto action_530
+action_511 x = happyTcHack x happyReduce_55
+
+action_512 (169#) = happyShift action_529
+action_512 x = happyTcHack x happyFail
+
+action_513 (99#) = happyShift action_528
+action_513 x = happyTcHack x happyFail
+
+action_514 x = happyTcHack x happyReduce_92
+
+action_515 x = happyTcHack x happyReduce_106
+
+action_516 (99#) = happyShift action_527
+action_516 x = happyTcHack x happyFail
+
+action_517 (25#) = happyGoto action_526
+action_517 x = happyTcHack x happyReduce_48
+
+action_518 (148#) = happyShift action_382
+action_518 (28#) = happyGoto action_525
+action_518 x = happyTcHack x happyReduce_55
+
+action_519 (112#) = happyShift action_524
+action_519 x = happyTcHack x happyFail
+
+action_520 (110#) = happyShift action_523
+action_520 x = happyTcHack x happyReduce_18
+
+action_521 (169#) = happyShift action_522
+action_521 x = happyTcHack x happyFail
+
+action_522 x = happyTcHack x happyReduce_14
+
+action_523 (174#) = happyShift action_48
+action_523 (12#) = happyGoto action_519
+action_523 (16#) = happyGoto action_520
+action_523 (17#) = happyGoto action_535
+action_523 x = happyTcHack x happyReduce_17
+
+action_524 (174#) = happyShift action_48
+action_524 (12#) = happyGoto action_533
+action_524 (18#) = happyGoto action_534
+action_524 x = happyTcHack x happyFail
+
+action_525 (167#) = happyShift action_532
+action_525 x = happyTcHack x happyFail
+
+action_526 (129#) = happyShift action_210
+action_526 (131#) = happyShift action_211
+action_526 (132#) = happyShift action_212
+action_526 (133#) = happyShift action_213
+action_526 (135#) = happyShift action_214
+action_526 (143#) = happyShift action_215
+action_526 (144#) = happyShift action_216
+action_526 (145#) = happyShift action_217
+action_526 (146#) = happyShift action_218
+action_526 (149#) = happyShift action_219
+action_526 (151#) = happyShift action_220
+action_526 (152#) = happyShift action_221
+action_526 (153#) = happyShift action_222
+action_526 (155#) = happyShift action_223
+action_526 (160#) = happyShift action_224
+action_526 (161#) = happyShift action_225
+action_526 (163#) = happyShift action_226
+action_526 (169#) = happyShift action_531
+action_526 (35#) = happyGoto action_209
+action_526 x = happyTcHack x happyFail
+
+action_527 x = happyTcHack x happyReduce_59
+
+action_528 x = happyTcHack x happyReduce_260
+
+action_529 x = happyTcHack x happyReduce_97
+
+action_530 x = happyTcHack x happyReduce_31
+
+action_531 x = happyTcHack x happyReduce_43
+
+action_532 (25#) = happyGoto action_537
+action_532 x = happyTcHack x happyReduce_48
+
+action_533 (19#) = happyGoto action_536
+action_533 x = happyTcHack x happyReduce_21
+
+action_534 x = happyTcHack x happyReduce_16
+
+action_535 x = happyTcHack x happyReduce_19
+
+action_536 (98#) = happyShift action_540
+action_536 (20#) = happyGoto action_539
+action_536 x = happyTcHack x happyReduce_20
+
+action_537 (129#) = happyShift action_210
+action_537 (131#) = happyShift action_211
+action_537 (132#) = happyShift action_212
+action_537 (133#) = happyShift action_213
+action_537 (135#) = happyShift action_214
+action_537 (143#) = happyShift action_215
+action_537 (144#) = happyShift action_216
+action_537 (145#) = happyShift action_217
+action_537 (146#) = happyShift action_218
+action_537 (149#) = happyShift action_219
+action_537 (151#) = happyShift action_220
+action_537 (152#) = happyShift action_221
+action_537 (153#) = happyShift action_222
+action_537 (155#) = happyShift action_223
+action_537 (160#) = happyShift action_224
+action_537 (161#) = happyShift action_225
+action_537 (163#) = happyShift action_226
+action_537 (169#) = happyShift action_538
+action_537 (35#) = happyGoto action_209
+action_537 x = happyTcHack x happyFail
+
+action_538 x = happyTcHack x happyReduce_45
+
+action_539 x = happyTcHack x happyReduce_22
+
+action_540 (161#) = happyShift action_541
+action_540 x = happyTcHack x happyFail
+
+action_541 (137#) = happyShift action_542
+action_541 (150#) = happyShift action_543
+action_541 x = happyTcHack x happyFail
+
+action_542 (98#) = happyShift action_408
+action_542 (174#) = happyShift action_48
+action_542 (12#) = happyGoto action_406
+action_542 (29#) = happyGoto action_545
+action_542 x = happyTcHack x happyFail
+
+action_543 (98#) = happyShift action_408
+action_543 (174#) = happyShift action_48
+action_543 (12#) = happyGoto action_406
+action_543 (29#) = happyGoto action_544
+action_543 x = happyTcHack x happyFail
+
+action_544 (99#) = happyShift action_547
+action_544 x = happyTcHack x happyFail
+
+action_545 (99#) = happyShift action_546
+action_545 x = happyTcHack x happyFail
+
+action_546 x = happyTcHack x happyReduce_23
+
+action_547 x = happyTcHack x happyReduce_24
+
+happyReduce_5 = happySpecReduce_1 8# happyReduction_5
+happyReduction_5 (HappyTerminal (PT _ (TI happy_var_1)))
+ = HappyAbsSyn8
+ ((read (BS.unpack happy_var_1)) :: Integer
+ )
+happyReduction_5 _ = notHappyAtAll
+
+happyReduce_6 = happySpecReduce_1 9# happyReduction_6
+happyReduction_6 (HappyTerminal (PT _ (TL happy_var_1)))
+ = HappyAbsSyn9
+ (BS.unpack happy_var_1
+ )
+happyReduction_6 _ = notHappyAtAll
+
+happyReduce_7 = happySpecReduce_1 10# happyReduction_7
+happyReduction_7 (HappyTerminal (PT _ (TD happy_var_1)))
+ = HappyAbsSyn10
+ ((read (BS.unpack happy_var_1)) :: Double
+ )
+happyReduction_7 _ = notHappyAtAll
+
+happyReduce_8 = happySpecReduce_1 11# happyReduction_8
+happyReduction_8 (HappyTerminal (PT _ (T_LString happy_var_1)))
+ = HappyAbsSyn11
+ (LString (happy_var_1)
+ )
+happyReduction_8 _ = notHappyAtAll
+
+happyReduce_9 = happySpecReduce_1 12# happyReduction_9
+happyReduction_9 (HappyTerminal happy_var_1)
+ = HappyAbsSyn12
+ (PIdent (mkPosToken happy_var_1)
+ )
+happyReduction_9 _ = notHappyAtAll
+
+happyReduce_10 = happySpecReduce_1 13# happyReduction_10
+happyReduction_10 (HappyAbsSyn14 happy_var_1)
+ = HappyAbsSyn13
+ (Gr (reverse happy_var_1)
+ )
+happyReduction_10 _ = notHappyAtAll
+
+happyReduce_11 = happySpecReduce_0 14# happyReduction_11
+happyReduction_11 = HappyAbsSyn14
+ ([]
+ )
+
+happyReduce_12 = happySpecReduce_2 14# happyReduction_12
+happyReduction_12 (HappyAbsSyn15 happy_var_2)
+ (HappyAbsSyn14 happy_var_1)
+ = HappyAbsSyn14
+ (flip (:) happy_var_1 happy_var_2
+ )
+happyReduction_12 _ _ = notHappyAtAll
+
+happyReduce_13 = happySpecReduce_2 15# happyReduction_13
+happyReduction_13 _
+ (HappyAbsSyn15 happy_var_1)
+ = HappyAbsSyn15
+ (happy_var_1
+ )
+happyReduction_13 _ _ = notHappyAtAll
+
+happyReduce_14 = happyReduce 10# 15# happyReduction_14
+happyReduction_14 (_ `HappyStk`
+ (HappyAbsSyn17 happy_var_9) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_7) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn15
+ (MMain happy_var_2 happy_var_7 happy_var_9
+ ) `HappyStk` happyRest
+
+happyReduce_15 = happyReduce 4# 15# happyReduction_15
+happyReduction_15 ((HappyAbsSyn22 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn23 happy_var_2) `HappyStk`
+ (HappyAbsSyn30 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn15
+ (MModule happy_var_1 happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_16 = happySpecReduce_3 16# happyReduction_16
+happyReduction_16 (HappyAbsSyn18 happy_var_3)
+ _
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn16
+ (ConcSpec happy_var_1 happy_var_3
+ )
+happyReduction_16 _ _ _ = notHappyAtAll
+
+happyReduce_17 = happySpecReduce_0 17# happyReduction_17
+happyReduction_17 = HappyAbsSyn17
+ ([]
+ )
+
+happyReduce_18 = happySpecReduce_1 17# happyReduction_18
+happyReduction_18 (HappyAbsSyn16 happy_var_1)
+ = HappyAbsSyn17
+ ((:[]) happy_var_1
+ )
+happyReduction_18 _ = notHappyAtAll
+
+happyReduce_19 = happySpecReduce_3 17# happyReduction_19
+happyReduction_19 (HappyAbsSyn17 happy_var_3)
+ _
+ (HappyAbsSyn16 happy_var_1)
+ = HappyAbsSyn17
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_19 _ _ _ = notHappyAtAll
+
+happyReduce_20 = happySpecReduce_2 18# happyReduction_20
+happyReduction_20 (HappyAbsSyn19 happy_var_2)
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn18
+ (ConcExp happy_var_1 (reverse happy_var_2)
+ )
+happyReduction_20 _ _ = notHappyAtAll
+
+happyReduce_21 = happySpecReduce_0 19# happyReduction_21
+happyReduction_21 = HappyAbsSyn19
+ ([]
+ )
+
+happyReduce_22 = happySpecReduce_2 19# happyReduction_22
+happyReduction_22 (HappyAbsSyn20 happy_var_2)
+ (HappyAbsSyn19 happy_var_1)
+ = HappyAbsSyn19
+ (flip (:) happy_var_1 happy_var_2
+ )
+happyReduction_22 _ _ = notHappyAtAll
+
+happyReduce_23 = happyReduce 5# 20# happyReduction_23
+happyReduction_23 (_ `HappyStk`
+ (HappyAbsSyn29 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn20
+ (TransferIn happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_24 = happyReduce 5# 20# happyReduction_24
+happyReduction_24 (_ `HappyStk`
+ (HappyAbsSyn29 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn20
+ (TransferOut happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_25 = happyReduce 4# 21# happyReduction_25
+happyReduction_25 ((HappyAbsSyn22 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn23 happy_var_2) `HappyStk`
+ (HappyAbsSyn30 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn15
+ (MModule happy_var_1 happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_26 = happySpecReduce_2 22# happyReduction_26
+happyReduction_26 (HappyAbsSyn28 happy_var_2)
+ (HappyAbsSyn26 happy_var_1)
+ = HappyAbsSyn22
+ (MBody happy_var_1 happy_var_2 []
+ )
+happyReduction_26 _ _ = notHappyAtAll
+
+happyReduce_27 = happySpecReduce_1 22# happyReduction_27
+happyReduction_27 (HappyAbsSyn32 happy_var_1)
+ = HappyAbsSyn22
+ (MNoBody happy_var_1
+ )
+happyReduction_27 _ = notHappyAtAll
+
+happyReduce_28 = happySpecReduce_3 22# happyReduction_28
+happyReduction_28 (HappyAbsSyn27 happy_var_3)
+ _
+ (HappyAbsSyn33 happy_var_1)
+ = HappyAbsSyn22
+ (MWith happy_var_1 happy_var_3
+ )
+happyReduction_28 _ _ _ = notHappyAtAll
+
+happyReduce_29 = happyReduce 5# 22# happyReduction_29
+happyReduction_29 ((HappyAbsSyn28 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn27 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn33 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn22
+ (MWithBody happy_var_1 happy_var_3 happy_var_5 []
+ ) `HappyStk` happyRest
+
+happyReduce_30 = happyReduce 5# 22# happyReduction_30
+happyReduction_30 ((HappyAbsSyn27 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn33 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn32 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn22
+ (MWithE happy_var_1 happy_var_3 happy_var_5
+ ) `HappyStk` happyRest
+
+happyReduce_31 = happyReduce 7# 22# happyReduction_31
+happyReduction_31 ((HappyAbsSyn28 happy_var_7) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn27 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn33 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn32 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn22
+ (MWithEBody happy_var_1 happy_var_3 happy_var_5 happy_var_7 []
+ ) `HappyStk` happyRest
+
+happyReduce_32 = happySpecReduce_2 22# happyReduction_32
+happyReduction_32 (HappyAbsSyn12 happy_var_2)
+ _
+ = HappyAbsSyn22
+ (MReuse happy_var_2
+ )
+happyReduction_32 _ _ = notHappyAtAll
+
+happyReduce_33 = happySpecReduce_2 22# happyReduction_33
+happyReduction_33 (HappyAbsSyn32 happy_var_2)
+ _
+ = HappyAbsSyn22
+ (MUnion happy_var_2
+ )
+happyReduction_33 _ _ = notHappyAtAll
+
+happyReduce_34 = happySpecReduce_2 23# happyReduction_34
+happyReduction_34 (HappyAbsSyn12 happy_var_2)
+ _
+ = HappyAbsSyn23
+ (MTAbstract happy_var_2
+ )
+happyReduction_34 _ _ = notHappyAtAll
+
+happyReduce_35 = happySpecReduce_2 23# happyReduction_35
+happyReduction_35 (HappyAbsSyn12 happy_var_2)
+ _
+ = HappyAbsSyn23
+ (MTResource happy_var_2
+ )
+happyReduction_35 _ _ = notHappyAtAll
+
+happyReduce_36 = happySpecReduce_2 23# happyReduction_36
+happyReduction_36 (HappyAbsSyn12 happy_var_2)
+ _
+ = HappyAbsSyn23
+ (MTInterface happy_var_2
+ )
+happyReduction_36 _ _ = notHappyAtAll
+
+happyReduce_37 = happyReduce 4# 23# happyReduction_37
+happyReduction_37 ((HappyAbsSyn12 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn23
+ (MTConcrete happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_38 = happyReduce 4# 23# happyReduction_38
+happyReduction_38 ((HappyAbsSyn12 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn23
+ (MTInstance happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_39 = happyReduce 6# 23# happyReduction_39
+happyReduction_39 ((HappyAbsSyn29 happy_var_6) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn29 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn23
+ (MTTransfer happy_var_2 happy_var_4 happy_var_6
+ ) `HappyStk` happyRest
+
+happyReduce_40 = happyReduce 5# 24# happyReduction_40
+happyReduction_40 (_ `HappyStk`
+ (HappyAbsSyn25 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn28 happy_var_2) `HappyStk`
+ (HappyAbsSyn26 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn22
+ (MBody happy_var_1 happy_var_2 (reverse happy_var_4)
+ ) `HappyStk` happyRest
+
+happyReduce_41 = happySpecReduce_1 24# happyReduction_41
+happyReduction_41 (HappyAbsSyn32 happy_var_1)
+ = HappyAbsSyn22
+ (MNoBody happy_var_1
+ )
+happyReduction_41 _ = notHappyAtAll
+
+happyReduce_42 = happySpecReduce_3 24# happyReduction_42
+happyReduction_42 (HappyAbsSyn27 happy_var_3)
+ _
+ (HappyAbsSyn33 happy_var_1)
+ = HappyAbsSyn22
+ (MWith happy_var_1 happy_var_3
+ )
+happyReduction_42 _ _ _ = notHappyAtAll
+
+happyReduce_43 = happyReduce 8# 24# happyReduction_43
+happyReduction_43 (_ `HappyStk`
+ (HappyAbsSyn25 happy_var_7) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn28 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn27 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn33 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn22
+ (MWithBody happy_var_1 happy_var_3 happy_var_5 (reverse happy_var_7)
+ ) `HappyStk` happyRest
+
+happyReduce_44 = happyReduce 5# 24# happyReduction_44
+happyReduction_44 ((HappyAbsSyn27 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn33 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn32 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn22
+ (MWithE happy_var_1 happy_var_3 happy_var_5
+ ) `HappyStk` happyRest
+
+happyReduce_45 = happyReduce 10# 24# happyReduction_45
+happyReduction_45 (_ `HappyStk`
+ (HappyAbsSyn25 happy_var_9) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn28 happy_var_7) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn27 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn33 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn32 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn22
+ (MWithEBody happy_var_1 happy_var_3 happy_var_5 happy_var_7 (reverse happy_var_9)
+ ) `HappyStk` happyRest
+
+happyReduce_46 = happySpecReduce_2 24# happyReduction_46
+happyReduction_46 (HappyAbsSyn12 happy_var_2)
+ _
+ = HappyAbsSyn22
+ (MReuse happy_var_2
+ )
+happyReduction_46 _ _ = notHappyAtAll
+
+happyReduce_47 = happySpecReduce_2 24# happyReduction_47
+happyReduction_47 (HappyAbsSyn32 happy_var_2)
+ _
+ = HappyAbsSyn22
+ (MUnion happy_var_2
+ )
+happyReduction_47 _ _ = notHappyAtAll
+
+happyReduce_48 = happySpecReduce_0 25# happyReduction_48
+happyReduction_48 = HappyAbsSyn25
+ ([]
+ )
+
+happyReduce_49 = happySpecReduce_2 25# happyReduction_49
+happyReduction_49 (HappyAbsSyn35 happy_var_2)
+ (HappyAbsSyn25 happy_var_1)
+ = HappyAbsSyn25
+ (flip (:) happy_var_1 happy_var_2
+ )
+happyReduction_49 _ _ = notHappyAtAll
+
+happyReduce_50 = happySpecReduce_2 26# happyReduction_50
+happyReduction_50 _
+ (HappyAbsSyn32 happy_var_1)
+ = HappyAbsSyn26
+ (Ext happy_var_1
+ )
+happyReduction_50 _ _ = notHappyAtAll
+
+happyReduce_51 = happySpecReduce_0 26# happyReduction_51
+happyReduction_51 = HappyAbsSyn26
+ (NoExt
+ )
+
+happyReduce_52 = happySpecReduce_0 27# happyReduction_52
+happyReduction_52 = HappyAbsSyn27
+ ([]
+ )
+
+happyReduce_53 = happySpecReduce_1 27# happyReduction_53
+happyReduction_53 (HappyAbsSyn29 happy_var_1)
+ = HappyAbsSyn27
+ ((:[]) happy_var_1
+ )
+happyReduction_53 _ = notHappyAtAll
+
+happyReduce_54 = happySpecReduce_3 27# happyReduction_54
+happyReduction_54 (HappyAbsSyn27 happy_var_3)
+ _
+ (HappyAbsSyn29 happy_var_1)
+ = HappyAbsSyn27
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_54 _ _ _ = notHappyAtAll
+
+happyReduce_55 = happySpecReduce_0 28# happyReduction_55
+happyReduction_55 = HappyAbsSyn28
+ (NoOpens
+ )
+
+happyReduce_56 = happySpecReduce_3 28# happyReduction_56
+happyReduction_56 _
+ (HappyAbsSyn27 happy_var_2)
+ _
+ = HappyAbsSyn28
+ (OpenIn happy_var_2
+ )
+happyReduction_56 _ _ _ = notHappyAtAll
+
+happyReduce_57 = happySpecReduce_1 29# happyReduction_57
+happyReduction_57 (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn29
+ (OName happy_var_1
+ )
+happyReduction_57 _ = notHappyAtAll
+
+happyReduce_58 = happyReduce 4# 29# happyReduction_58
+happyReduction_58 (_ `HappyStk`
+ (HappyAbsSyn12 happy_var_3) `HappyStk`
+ (HappyAbsSyn31 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn29
+ (OQualQO happy_var_2 happy_var_3
+ ) `HappyStk` happyRest
+
+happyReduce_59 = happyReduce 6# 29# happyReduction_59
+happyReduction_59 (_ `HappyStk`
+ (HappyAbsSyn12 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_3) `HappyStk`
+ (HappyAbsSyn31 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn29
+ (OQual happy_var_2 happy_var_3 happy_var_5
+ ) `HappyStk` happyRest
+
+happyReduce_60 = happySpecReduce_0 30# happyReduction_60
+happyReduction_60 = HappyAbsSyn30
+ (CMCompl
+ )
+
+happyReduce_61 = happySpecReduce_1 30# happyReduction_61
+happyReduction_61 _
+ = HappyAbsSyn30
+ (CMIncompl
+ )
+
+happyReduce_62 = happySpecReduce_0 31# happyReduction_62
+happyReduction_62 = HappyAbsSyn31
+ (QOCompl
+ )
+
+happyReduce_63 = happySpecReduce_1 31# happyReduction_63
+happyReduction_63 _
+ = HappyAbsSyn31
+ (QOIncompl
+ )
+
+happyReduce_64 = happySpecReduce_1 31# happyReduction_64
+happyReduction_64 _
+ = HappyAbsSyn31
+ (QOInterface
+ )
+
+happyReduce_65 = happySpecReduce_0 32# happyReduction_65
+happyReduction_65 = HappyAbsSyn32
+ ([]
+ )
+
+happyReduce_66 = happySpecReduce_1 32# happyReduction_66
+happyReduction_66 (HappyAbsSyn33 happy_var_1)
+ = HappyAbsSyn32
+ ((:[]) happy_var_1
+ )
+happyReduction_66 _ = notHappyAtAll
+
+happyReduce_67 = happySpecReduce_3 32# happyReduction_67
+happyReduction_67 (HappyAbsSyn32 happy_var_3)
+ _
+ (HappyAbsSyn33 happy_var_1)
+ = HappyAbsSyn32
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_67 _ _ _ = notHappyAtAll
+
+happyReduce_68 = happySpecReduce_1 33# happyReduction_68
+happyReduction_68 (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn33
+ (IAll happy_var_1
+ )
+happyReduction_68 _ = notHappyAtAll
+
+happyReduce_69 = happyReduce 4# 33# happyReduction_69
+happyReduction_69 (_ `HappyStk`
+ (HappyAbsSyn53 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn33
+ (ISome happy_var_1 happy_var_3
+ ) `HappyStk` happyRest
+
+happyReduce_70 = happyReduce 5# 33# happyReduction_70
+happyReduction_70 (_ `HappyStk`
+ (HappyAbsSyn53 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn33
+ (IMinus happy_var_1 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_71 = happySpecReduce_3 34# happyReduction_71
+happyReduction_71 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn55 happy_var_1)
+ = HappyAbsSyn34
+ (DDecl happy_var_1 happy_var_3
+ )
+happyReduction_71 _ _ _ = notHappyAtAll
+
+happyReduce_72 = happySpecReduce_3 34# happyReduction_72
+happyReduction_72 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn55 happy_var_1)
+ = HappyAbsSyn34
+ (DDef happy_var_1 happy_var_3
+ )
+happyReduction_72 _ _ _ = notHappyAtAll
+
+happyReduce_73 = happyReduce 4# 34# happyReduction_73
+happyReduction_73 ((HappyAbsSyn58 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn74 happy_var_2) `HappyStk`
+ (HappyAbsSyn54 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn34
+ (DPatt happy_var_1 happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_74 = happyReduce 5# 34# happyReduction_74
+happyReduction_74 ((HappyAbsSyn58 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn58 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn55 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn34
+ (DFull happy_var_1 happy_var_3 happy_var_5
+ ) `HappyStk` happyRest
+
+happyReduce_75 = happySpecReduce_2 35# happyReduction_75
+happyReduction_75 (HappyAbsSyn46 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefCat happy_var_2
+ )
+happyReduction_75 _ _ = notHappyAtAll
+
+happyReduce_76 = happySpecReduce_2 35# happyReduction_76
+happyReduction_76 (HappyAbsSyn47 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefFun happy_var_2
+ )
+happyReduction_76 _ _ = notHappyAtAll
+
+happyReduce_77 = happySpecReduce_2 35# happyReduction_77
+happyReduction_77 (HappyAbsSyn47 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefFunData happy_var_2
+ )
+happyReduction_77 _ _ = notHappyAtAll
+
+happyReduce_78 = happySpecReduce_2 35# happyReduction_78
+happyReduction_78 (HappyAbsSyn45 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefDef happy_var_2
+ )
+happyReduction_78 _ _ = notHappyAtAll
+
+happyReduce_79 = happySpecReduce_2 35# happyReduction_79
+happyReduction_79 (HappyAbsSyn48 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefData happy_var_2
+ )
+happyReduction_79 _ _ = notHappyAtAll
+
+happyReduce_80 = happySpecReduce_2 35# happyReduction_80
+happyReduction_80 (HappyAbsSyn45 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefTrans happy_var_2
+ )
+happyReduction_80 _ _ = notHappyAtAll
+
+happyReduce_81 = happySpecReduce_2 35# happyReduction_81
+happyReduction_81 (HappyAbsSyn49 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefPar happy_var_2
+ )
+happyReduction_81 _ _ = notHappyAtAll
+
+happyReduce_82 = happySpecReduce_2 35# happyReduction_82
+happyReduction_82 (HappyAbsSyn45 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefOper happy_var_2
+ )
+happyReduction_82 _ _ = notHappyAtAll
+
+happyReduce_83 = happySpecReduce_2 35# happyReduction_83
+happyReduction_83 (HappyAbsSyn50 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefLincat happy_var_2
+ )
+happyReduction_83 _ _ = notHappyAtAll
+
+happyReduce_84 = happySpecReduce_2 35# happyReduction_84
+happyReduction_84 (HappyAbsSyn45 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefLindef happy_var_2
+ )
+happyReduction_84 _ _ = notHappyAtAll
+
+happyReduce_85 = happySpecReduce_2 35# happyReduction_85
+happyReduction_85 (HappyAbsSyn45 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefLin happy_var_2
+ )
+happyReduction_85 _ _ = notHappyAtAll
+
+happyReduce_86 = happySpecReduce_3 35# happyReduction_86
+happyReduction_86 (HappyAbsSyn50 happy_var_3)
+ _
+ _
+ = HappyAbsSyn35
+ (DefPrintCat happy_var_3
+ )
+happyReduction_86 _ _ _ = notHappyAtAll
+
+happyReduce_87 = happySpecReduce_3 35# happyReduction_87
+happyReduction_87 (HappyAbsSyn50 happy_var_3)
+ _
+ _
+ = HappyAbsSyn35
+ (DefPrintFun happy_var_3
+ )
+happyReduction_87 _ _ _ = notHappyAtAll
+
+happyReduce_88 = happySpecReduce_2 35# happyReduction_88
+happyReduction_88 (HappyAbsSyn51 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefFlag happy_var_2
+ )
+happyReduction_88 _ _ = notHappyAtAll
+
+happyReduce_89 = happySpecReduce_2 35# happyReduction_89
+happyReduction_89 (HappyAbsSyn50 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefPrintOld happy_var_2
+ )
+happyReduction_89 _ _ = notHappyAtAll
+
+happyReduce_90 = happySpecReduce_2 35# happyReduction_90
+happyReduction_90 (HappyAbsSyn45 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefLintype happy_var_2
+ )
+happyReduction_90 _ _ = notHappyAtAll
+
+happyReduce_91 = happySpecReduce_2 35# happyReduction_91
+happyReduction_91 (HappyAbsSyn45 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefPattern happy_var_2
+ )
+happyReduction_91 _ _ = notHappyAtAll
+
+happyReduce_92 = happyReduce 7# 35# happyReduction_92
+happyReduction_92 (_ `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn25 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn35
+ (DefPackage happy_var_2 (reverse happy_var_5)
+ ) `HappyStk` happyRest
+
+happyReduce_93 = happySpecReduce_2 35# happyReduction_93
+happyReduction_93 (HappyAbsSyn45 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefVars happy_var_2
+ )
+happyReduction_93 _ _ = notHappyAtAll
+
+happyReduce_94 = happySpecReduce_3 35# happyReduction_94
+happyReduction_94 _
+ (HappyAbsSyn12 happy_var_2)
+ _
+ = HappyAbsSyn35
+ (DefTokenizer happy_var_2
+ )
+happyReduction_94 _ _ _ = notHappyAtAll
+
+happyReduce_95 = happySpecReduce_2 36# happyReduction_95
+happyReduction_95 (HappyAbsSyn89 happy_var_2)
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn36
+ (SimpleCatDef happy_var_1 (reverse happy_var_2)
+ )
+happyReduction_95 _ _ = notHappyAtAll
+
+happyReduce_96 = happyReduce 4# 36# happyReduction_96
+happyReduction_96 (_ `HappyStk`
+ (HappyAbsSyn89 happy_var_3) `HappyStk`
+ (HappyAbsSyn12 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn36
+ (ListCatDef happy_var_2 (reverse happy_var_3)
+ ) `HappyStk` happyRest
+
+happyReduce_97 = happyReduce 7# 36# happyReduction_97
+happyReduction_97 (_ `HappyStk`
+ (HappyAbsSyn8 happy_var_6) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn89 happy_var_3) `HappyStk`
+ (HappyAbsSyn12 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn36
+ (ListSizeCatDef happy_var_2 (reverse happy_var_3) happy_var_6
+ ) `HappyStk` happyRest
+
+happyReduce_98 = happySpecReduce_3 37# happyReduction_98
+happyReduction_98 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn53 happy_var_1)
+ = HappyAbsSyn37
+ (FunDef happy_var_1 happy_var_3
+ )
+happyReduction_98 _ _ _ = notHappyAtAll
+
+happyReduce_99 = happySpecReduce_3 38# happyReduction_99
+happyReduction_99 (HappyAbsSyn40 happy_var_3)
+ _
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn38
+ (DataDef happy_var_1 happy_var_3
+ )
+happyReduction_99 _ _ _ = notHappyAtAll
+
+happyReduce_100 = happySpecReduce_1 39# happyReduction_100
+happyReduction_100 (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn39
+ (DataId happy_var_1
+ )
+happyReduction_100 _ = notHappyAtAll
+
+happyReduce_101 = happySpecReduce_3 39# happyReduction_101
+happyReduction_101 (HappyAbsSyn12 happy_var_3)
+ _
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn39
+ (DataQId happy_var_1 happy_var_3
+ )
+happyReduction_101 _ _ _ = notHappyAtAll
+
+happyReduce_102 = happySpecReduce_0 40# happyReduction_102
+happyReduction_102 = HappyAbsSyn40
+ ([]
+ )
+
+happyReduce_103 = happySpecReduce_1 40# happyReduction_103
+happyReduction_103 (HappyAbsSyn39 happy_var_1)
+ = HappyAbsSyn40
+ ((:[]) happy_var_1
+ )
+happyReduction_103 _ = notHappyAtAll
+
+happyReduce_104 = happySpecReduce_3 40# happyReduction_104
+happyReduction_104 (HappyAbsSyn40 happy_var_3)
+ _
+ (HappyAbsSyn39 happy_var_1)
+ = HappyAbsSyn40
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_104 _ _ _ = notHappyAtAll
+
+happyReduce_105 = happySpecReduce_3 41# happyReduction_105
+happyReduction_105 (HappyAbsSyn52 happy_var_3)
+ _
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn41
+ (ParDefDir happy_var_1 happy_var_3
+ )
+happyReduction_105 _ _ _ = notHappyAtAll
+
+happyReduce_106 = happyReduce 6# 41# happyReduction_106
+happyReduction_106 (_ `HappyStk`
+ (HappyAbsSyn12 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn41
+ (ParDefIndir happy_var_1 happy_var_5
+ ) `HappyStk` happyRest
+
+happyReduce_107 = happySpecReduce_1 41# happyReduction_107
+happyReduction_107 (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn41
+ (ParDefAbs happy_var_1
+ )
+happyReduction_107 _ = notHappyAtAll
+
+happyReduce_108 = happySpecReduce_2 42# happyReduction_108
+happyReduction_108 (HappyAbsSyn89 happy_var_2)
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn42
+ (ParConstr happy_var_1 (reverse happy_var_2)
+ )
+happyReduction_108 _ _ = notHappyAtAll
+
+happyReduce_109 = happySpecReduce_3 43# happyReduction_109
+happyReduction_109 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn55 happy_var_1)
+ = HappyAbsSyn43
+ (PrintDef happy_var_1 happy_var_3
+ )
+happyReduction_109 _ _ _ = notHappyAtAll
+
+happyReduce_110 = happySpecReduce_3 44# happyReduction_110
+happyReduction_110 (HappyAbsSyn12 happy_var_3)
+ _
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn44
+ (FlagDef happy_var_1 happy_var_3
+ )
+happyReduction_110 _ _ _ = notHappyAtAll
+
+happyReduce_111 = happySpecReduce_2 45# happyReduction_111
+happyReduction_111 _
+ (HappyAbsSyn34 happy_var_1)
+ = HappyAbsSyn45
+ ((:[]) happy_var_1
+ )
+happyReduction_111 _ _ = notHappyAtAll
+
+happyReduce_112 = happySpecReduce_3 45# happyReduction_112
+happyReduction_112 (HappyAbsSyn45 happy_var_3)
+ _
+ (HappyAbsSyn34 happy_var_1)
+ = HappyAbsSyn45
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_112 _ _ _ = notHappyAtAll
+
+happyReduce_113 = happySpecReduce_2 46# happyReduction_113
+happyReduction_113 _
+ (HappyAbsSyn36 happy_var_1)
+ = HappyAbsSyn46
+ ((:[]) happy_var_1
+ )
+happyReduction_113 _ _ = notHappyAtAll
+
+happyReduce_114 = happySpecReduce_3 46# happyReduction_114
+happyReduction_114 (HappyAbsSyn46 happy_var_3)
+ _
+ (HappyAbsSyn36 happy_var_1)
+ = HappyAbsSyn46
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_114 _ _ _ = notHappyAtAll
+
+happyReduce_115 = happySpecReduce_2 47# happyReduction_115
+happyReduction_115 _
+ (HappyAbsSyn37 happy_var_1)
+ = HappyAbsSyn47
+ ((:[]) happy_var_1
+ )
+happyReduction_115 _ _ = notHappyAtAll
+
+happyReduce_116 = happySpecReduce_3 47# happyReduction_116
+happyReduction_116 (HappyAbsSyn47 happy_var_3)
+ _
+ (HappyAbsSyn37 happy_var_1)
+ = HappyAbsSyn47
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_116 _ _ _ = notHappyAtAll
+
+happyReduce_117 = happySpecReduce_2 48# happyReduction_117
+happyReduction_117 _
+ (HappyAbsSyn38 happy_var_1)
+ = HappyAbsSyn48
+ ((:[]) happy_var_1
+ )
+happyReduction_117 _ _ = notHappyAtAll
+
+happyReduce_118 = happySpecReduce_3 48# happyReduction_118
+happyReduction_118 (HappyAbsSyn48 happy_var_3)
+ _
+ (HappyAbsSyn38 happy_var_1)
+ = HappyAbsSyn48
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_118 _ _ _ = notHappyAtAll
+
+happyReduce_119 = happySpecReduce_2 49# happyReduction_119
+happyReduction_119 _
+ (HappyAbsSyn41 happy_var_1)
+ = HappyAbsSyn49
+ ((:[]) happy_var_1
+ )
+happyReduction_119 _ _ = notHappyAtAll
+
+happyReduce_120 = happySpecReduce_3 49# happyReduction_120
+happyReduction_120 (HappyAbsSyn49 happy_var_3)
+ _
+ (HappyAbsSyn41 happy_var_1)
+ = HappyAbsSyn49
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_120 _ _ _ = notHappyAtAll
+
+happyReduce_121 = happySpecReduce_2 50# happyReduction_121
+happyReduction_121 _
+ (HappyAbsSyn43 happy_var_1)
+ = HappyAbsSyn50
+ ((:[]) happy_var_1
+ )
+happyReduction_121 _ _ = notHappyAtAll
+
+happyReduce_122 = happySpecReduce_3 50# happyReduction_122
+happyReduction_122 (HappyAbsSyn50 happy_var_3)
+ _
+ (HappyAbsSyn43 happy_var_1)
+ = HappyAbsSyn50
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_122 _ _ _ = notHappyAtAll
+
+happyReduce_123 = happySpecReduce_2 51# happyReduction_123
+happyReduction_123 _
+ (HappyAbsSyn44 happy_var_1)
+ = HappyAbsSyn51
+ ((:[]) happy_var_1
+ )
+happyReduction_123 _ _ = notHappyAtAll
+
+happyReduce_124 = happySpecReduce_3 51# happyReduction_124
+happyReduction_124 (HappyAbsSyn51 happy_var_3)
+ _
+ (HappyAbsSyn44 happy_var_1)
+ = HappyAbsSyn51
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_124 _ _ _ = notHappyAtAll
+
+happyReduce_125 = happySpecReduce_0 52# happyReduction_125
+happyReduction_125 = HappyAbsSyn52
+ ([]
+ )
+
+happyReduce_126 = happySpecReduce_1 52# happyReduction_126
+happyReduction_126 (HappyAbsSyn42 happy_var_1)
+ = HappyAbsSyn52
+ ((:[]) happy_var_1
+ )
+happyReduction_126 _ = notHappyAtAll
+
+happyReduce_127 = happySpecReduce_3 52# happyReduction_127
+happyReduction_127 (HappyAbsSyn52 happy_var_3)
+ _
+ (HappyAbsSyn42 happy_var_1)
+ = HappyAbsSyn52
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_127 _ _ _ = notHappyAtAll
+
+happyReduce_128 = happySpecReduce_1 53# happyReduction_128
+happyReduction_128 (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn53
+ ((:[]) happy_var_1
+ )
+happyReduction_128 _ = notHappyAtAll
+
+happyReduce_129 = happySpecReduce_3 53# happyReduction_129
+happyReduction_129 (HappyAbsSyn53 happy_var_3)
+ _
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn53
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_129 _ _ _ = notHappyAtAll
+
+happyReduce_130 = happySpecReduce_1 54# happyReduction_130
+happyReduction_130 (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn54
+ (IdentName happy_var_1
+ )
+happyReduction_130 _ = notHappyAtAll
+
+happyReduce_131 = happySpecReduce_3 54# happyReduction_131
+happyReduction_131 _
+ (HappyAbsSyn12 happy_var_2)
+ _
+ = HappyAbsSyn54
+ (ListName happy_var_2
+ )
+happyReduction_131 _ _ _ = notHappyAtAll
+
+happyReduce_132 = happySpecReduce_1 55# happyReduction_132
+happyReduction_132 (HappyAbsSyn54 happy_var_1)
+ = HappyAbsSyn55
+ ((:[]) happy_var_1
+ )
+happyReduction_132 _ = notHappyAtAll
+
+happyReduce_133 = happySpecReduce_3 55# happyReduction_133
+happyReduction_133 (HappyAbsSyn55 happy_var_3)
+ _
+ (HappyAbsSyn54 happy_var_1)
+ = HappyAbsSyn55
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_133 _ _ _ = notHappyAtAll
+
+happyReduce_134 = happySpecReduce_3 56# happyReduction_134
+happyReduction_134 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn53 happy_var_1)
+ = HappyAbsSyn56
+ (LDDecl happy_var_1 happy_var_3
+ )
+happyReduction_134 _ _ _ = notHappyAtAll
+
+happyReduce_135 = happySpecReduce_3 56# happyReduction_135
+happyReduction_135 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn53 happy_var_1)
+ = HappyAbsSyn56
+ (LDDef happy_var_1 happy_var_3
+ )
+happyReduction_135 _ _ _ = notHappyAtAll
+
+happyReduce_136 = happyReduce 5# 56# happyReduction_136
+happyReduction_136 ((HappyAbsSyn58 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn58 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn53 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn56
+ (LDFull happy_var_1 happy_var_3 happy_var_5
+ ) `HappyStk` happyRest
+
+happyReduce_137 = happySpecReduce_0 57# happyReduction_137
+happyReduction_137 = HappyAbsSyn57
+ ([]
+ )
+
+happyReduce_138 = happySpecReduce_1 57# happyReduction_138
+happyReduction_138 (HappyAbsSyn56 happy_var_1)
+ = HappyAbsSyn57
+ ((:[]) happy_var_1
+ )
+happyReduction_138 _ = notHappyAtAll
+
+happyReduce_139 = happySpecReduce_3 57# happyReduction_139
+happyReduction_139 (HappyAbsSyn57 happy_var_3)
+ _
+ (HappyAbsSyn56 happy_var_1)
+ = HappyAbsSyn57
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_139 _ _ _ = notHappyAtAll
+
+happyReduce_140 = happySpecReduce_1 58# happyReduction_140
+happyReduction_140 (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn58
+ (EIdent happy_var_1
+ )
+happyReduction_140 _ = notHappyAtAll
+
+happyReduce_141 = happySpecReduce_3 58# happyReduction_141
+happyReduction_141 _
+ (HappyAbsSyn12 happy_var_2)
+ _
+ = HappyAbsSyn58
+ (EConstr happy_var_2
+ )
+happyReduction_141 _ _ _ = notHappyAtAll
+
+happyReduce_142 = happySpecReduce_3 58# happyReduction_142
+happyReduction_142 _
+ (HappyAbsSyn12 happy_var_2)
+ _
+ = HappyAbsSyn58
+ (ECons happy_var_2
+ )
+happyReduction_142 _ _ _ = notHappyAtAll
+
+happyReduce_143 = happySpecReduce_1 58# happyReduction_143
+happyReduction_143 (HappyAbsSyn72 happy_var_1)
+ = HappyAbsSyn58
+ (ESort happy_var_1
+ )
+happyReduction_143 _ = notHappyAtAll
+
+happyReduce_144 = happySpecReduce_1 58# happyReduction_144
+happyReduction_144 (HappyAbsSyn9 happy_var_1)
+ = HappyAbsSyn58
+ (EString happy_var_1
+ )
+happyReduction_144 _ = notHappyAtAll
+
+happyReduce_145 = happySpecReduce_1 58# happyReduction_145
+happyReduction_145 (HappyAbsSyn8 happy_var_1)
+ = HappyAbsSyn58
+ (EInt happy_var_1
+ )
+happyReduction_145 _ = notHappyAtAll
+
+happyReduce_146 = happySpecReduce_1 58# happyReduction_146
+happyReduction_146 (HappyAbsSyn10 happy_var_1)
+ = HappyAbsSyn58
+ (EFloat happy_var_1
+ )
+happyReduction_146 _ = notHappyAtAll
+
+happyReduce_147 = happySpecReduce_1 58# happyReduction_147
+happyReduction_147 _
+ = HappyAbsSyn58
+ (EMeta
+ )
+
+happyReduce_148 = happySpecReduce_2 58# happyReduction_148
+happyReduction_148 _
+ _
+ = HappyAbsSyn58
+ (EEmpty
+ )
+
+happyReduce_149 = happySpecReduce_1 58# happyReduction_149
+happyReduction_149 _
+ = HappyAbsSyn58
+ (EData
+ )
+
+happyReduce_150 = happyReduce 4# 58# happyReduction_150
+happyReduction_150 (_ `HappyStk`
+ (HappyAbsSyn66 happy_var_3) `HappyStk`
+ (HappyAbsSyn12 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (EList happy_var_2 happy_var_3
+ ) `HappyStk` happyRest
+
+happyReduce_151 = happySpecReduce_3 58# happyReduction_151
+happyReduction_151 _
+ (HappyAbsSyn9 happy_var_2)
+ _
+ = HappyAbsSyn58
+ (EStrings happy_var_2
+ )
+happyReduction_151 _ _ _ = notHappyAtAll
+
+happyReduce_152 = happySpecReduce_3 58# happyReduction_152
+happyReduction_152 _
+ (HappyAbsSyn57 happy_var_2)
+ _
+ = HappyAbsSyn58
+ (ERecord happy_var_2
+ )
+happyReduction_152 _ _ _ = notHappyAtAll
+
+happyReduce_153 = happySpecReduce_3 58# happyReduction_153
+happyReduction_153 _
+ (HappyAbsSyn80 happy_var_2)
+ _
+ = HappyAbsSyn58
+ (ETuple happy_var_2
+ )
+happyReduction_153 _ _ _ = notHappyAtAll
+
+happyReduce_154 = happyReduce 4# 58# happyReduction_154
+happyReduction_154 (_ `HappyStk`
+ (HappyAbsSyn12 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (EIndir happy_var_3
+ ) `HappyStk` happyRest
+
+happyReduce_155 = happyReduce 5# 58# happyReduction_155
+happyReduction_155 (_ `HappyStk`
+ (HappyAbsSyn58 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn58 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (ETyped happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_156 = happySpecReduce_3 58# happyReduction_156
+happyReduction_156 _
+ (HappyAbsSyn58 happy_var_2)
+ _
+ = HappyAbsSyn58
+ (happy_var_2
+ )
+happyReduction_156 _ _ _ = notHappyAtAll
+
+happyReduce_157 = happySpecReduce_1 58# happyReduction_157
+happyReduction_157 (HappyAbsSyn11 happy_var_1)
+ = HappyAbsSyn58
+ (ELString happy_var_1
+ )
+happyReduction_157 _ = notHappyAtAll
+
+happyReduce_158 = happySpecReduce_3 59# happyReduction_158
+happyReduction_158 (HappyAbsSyn71 happy_var_3)
+ _
+ (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (EProj happy_var_1 happy_var_3
+ )
+happyReduction_158 _ _ _ = notHappyAtAll
+
+happyReduce_159 = happyReduce 5# 59# happyReduction_159
+happyReduction_159 (_ `HappyStk`
+ (HappyAbsSyn12 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (EQConstr happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_160 = happyReduce 4# 59# happyReduction_160
+happyReduction_160 ((HappyAbsSyn12 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (EQCons happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_161 = happySpecReduce_1 59# happyReduction_161
+happyReduction_161 (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (happy_var_1
+ )
+happyReduction_161 _ = notHappyAtAll
+
+happyReduce_162 = happySpecReduce_2 60# happyReduction_162
+happyReduction_162 (HappyAbsSyn58 happy_var_2)
+ (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (EApp happy_var_1 happy_var_2
+ )
+happyReduction_162 _ _ = notHappyAtAll
+
+happyReduce_163 = happyReduce 4# 60# happyReduction_163
+happyReduction_163 (_ `HappyStk`
+ (HappyAbsSyn83 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (ETable happy_var_3
+ ) `HappyStk` happyRest
+
+happyReduce_164 = happyReduce 5# 60# happyReduction_164
+happyReduction_164 (_ `HappyStk`
+ (HappyAbsSyn83 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn58 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (ETTable happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_165 = happyReduce 5# 60# happyReduction_165
+happyReduction_165 (_ `HappyStk`
+ (HappyAbsSyn65 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn58 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (EVTable happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_166 = happyReduce 6# 60# happyReduction_166
+happyReduction_166 (_ `HappyStk`
+ (HappyAbsSyn83 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn58 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (ECase happy_var_2 happy_var_5
+ ) `HappyStk` happyRest
+
+happyReduce_167 = happyReduce 4# 60# happyReduction_167
+happyReduction_167 (_ `HappyStk`
+ (HappyAbsSyn65 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (EVariants happy_var_3
+ ) `HappyStk` happyRest
+
+happyReduce_168 = happyReduce 6# 60# happyReduction_168
+happyReduction_168 (_ `HappyStk`
+ (HappyAbsSyn87 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn58 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (EPre happy_var_3 happy_var_5
+ ) `HappyStk` happyRest
+
+happyReduce_169 = happyReduce 4# 60# happyReduction_169
+happyReduction_169 (_ `HappyStk`
+ (HappyAbsSyn65 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (EStrs happy_var_3
+ ) `HappyStk` happyRest
+
+happyReduce_170 = happySpecReduce_3 60# happyReduction_170
+happyReduction_170 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn58
+ (EConAt happy_var_1 happy_var_3
+ )
+happyReduction_170 _ _ _ = notHappyAtAll
+
+happyReduce_171 = happySpecReduce_2 60# happyReduction_171
+happyReduction_171 (HappyAbsSyn67 happy_var_2)
+ _
+ = HappyAbsSyn58
+ (EPatt happy_var_2
+ )
+happyReduction_171 _ _ = notHappyAtAll
+
+happyReduce_172 = happySpecReduce_2 60# happyReduction_172
+happyReduction_172 (HappyAbsSyn58 happy_var_2)
+ _
+ = HappyAbsSyn58
+ (EPattType happy_var_2
+ )
+happyReduction_172 _ _ = notHappyAtAll
+
+happyReduce_173 = happySpecReduce_1 60# happyReduction_173
+happyReduction_173 (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (happy_var_1
+ )
+happyReduction_173 _ = notHappyAtAll
+
+happyReduce_174 = happySpecReduce_2 60# happyReduction_174
+happyReduction_174 (HappyAbsSyn12 happy_var_2)
+ _
+ = HappyAbsSyn58
+ (ELin happy_var_2
+ )
+happyReduction_174 _ _ = notHappyAtAll
+
+happyReduce_175 = happySpecReduce_3 61# happyReduction_175
+happyReduction_175 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (ESelect happy_var_1 happy_var_3
+ )
+happyReduction_175 _ _ _ = notHappyAtAll
+
+happyReduce_176 = happySpecReduce_3 61# happyReduction_176
+happyReduction_176 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (ETupTyp happy_var_1 happy_var_3
+ )
+happyReduction_176 _ _ _ = notHappyAtAll
+
+happyReduce_177 = happySpecReduce_3 61# happyReduction_177
+happyReduction_177 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (EExtend happy_var_1 happy_var_3
+ )
+happyReduction_177 _ _ _ = notHappyAtAll
+
+happyReduce_178 = happySpecReduce_1 61# happyReduction_178
+happyReduction_178 (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (happy_var_1
+ )
+happyReduction_178 _ = notHappyAtAll
+
+happyReduce_179 = happySpecReduce_3 62# happyReduction_179
+happyReduction_179 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (EGlue happy_var_1 happy_var_3
+ )
+happyReduction_179 _ _ _ = notHappyAtAll
+
+happyReduce_180 = happySpecReduce_1 62# happyReduction_180
+happyReduction_180 (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (happy_var_1
+ )
+happyReduction_180 _ = notHappyAtAll
+
+happyReduce_181 = happySpecReduce_3 63# happyReduction_181
+happyReduction_181 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (EConcat happy_var_1 happy_var_3
+ )
+happyReduction_181 _ _ _ = notHappyAtAll
+
+happyReduce_182 = happyReduce 4# 63# happyReduction_182
+happyReduction_182 ((HappyAbsSyn58 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn76 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (EAbstr happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_183 = happyReduce 5# 63# happyReduction_183
+happyReduction_183 ((HappyAbsSyn58 happy_var_5) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn76 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (ECTable happy_var_3 happy_var_5
+ ) `HappyStk` happyRest
+
+happyReduce_184 = happySpecReduce_3 63# happyReduction_184
+happyReduction_184 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn77 happy_var_1)
+ = HappyAbsSyn58
+ (EProd happy_var_1 happy_var_3
+ )
+happyReduction_184 _ _ _ = notHappyAtAll
+
+happyReduce_185 = happySpecReduce_3 63# happyReduction_185
+happyReduction_185 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (ETType happy_var_1 happy_var_3
+ )
+happyReduction_185 _ _ _ = notHappyAtAll
+
+happyReduce_186 = happyReduce 6# 63# happyReduction_186
+happyReduction_186 ((HappyAbsSyn58 happy_var_6) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn57 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (ELet happy_var_3 happy_var_6
+ ) `HappyStk` happyRest
+
+happyReduce_187 = happyReduce 4# 63# happyReduction_187
+happyReduction_187 ((HappyAbsSyn58 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn57 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (ELetb happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_188 = happyReduce 5# 63# happyReduction_188
+happyReduction_188 (_ `HappyStk`
+ (HappyAbsSyn57 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn58 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (EWhere happy_var_1 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_189 = happyReduce 4# 63# happyReduction_189
+happyReduction_189 (_ `HappyStk`
+ (HappyAbsSyn85 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn58
+ (EEqs happy_var_3
+ ) `HappyStk` happyRest
+
+happyReduce_190 = happySpecReduce_3 63# happyReduction_190
+happyReduction_190 (HappyAbsSyn9 happy_var_3)
+ (HappyAbsSyn58 happy_var_2)
+ _
+ = HappyAbsSyn58
+ (EExample happy_var_2 happy_var_3
+ )
+happyReduction_190 _ _ _ = notHappyAtAll
+
+happyReduce_191 = happySpecReduce_1 63# happyReduction_191
+happyReduction_191 (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (happy_var_1
+ )
+happyReduction_191 _ = notHappyAtAll
+
+happyReduce_192 = happySpecReduce_1 64# happyReduction_192
+happyReduction_192 (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn58
+ (happy_var_1
+ )
+happyReduction_192 _ = notHappyAtAll
+
+happyReduce_193 = happySpecReduce_0 65# happyReduction_193
+happyReduction_193 = HappyAbsSyn65
+ ([]
+ )
+
+happyReduce_194 = happySpecReduce_1 65# happyReduction_194
+happyReduction_194 (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn65
+ ((:[]) happy_var_1
+ )
+happyReduction_194 _ = notHappyAtAll
+
+happyReduce_195 = happySpecReduce_3 65# happyReduction_195
+happyReduction_195 (HappyAbsSyn65 happy_var_3)
+ _
+ (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn65
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_195 _ _ _ = notHappyAtAll
+
+happyReduce_196 = happySpecReduce_0 66# happyReduction_196
+happyReduction_196 = HappyAbsSyn66
+ (NilExp
+ )
+
+happyReduce_197 = happySpecReduce_2 66# happyReduction_197
+happyReduction_197 (HappyAbsSyn66 happy_var_2)
+ (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn66
+ (ConsExp happy_var_1 happy_var_2
+ )
+happyReduction_197 _ _ = notHappyAtAll
+
+happyReduce_198 = happySpecReduce_1 67# happyReduction_198
+happyReduction_198 _
+ = HappyAbsSyn67
+ (PChar
+ )
+
+happyReduce_199 = happySpecReduce_3 67# happyReduction_199
+happyReduction_199 _
+ (HappyAbsSyn9 happy_var_2)
+ _
+ = HappyAbsSyn67
+ (PChars happy_var_2
+ )
+happyReduction_199 _ _ _ = notHappyAtAll
+
+happyReduce_200 = happySpecReduce_2 67# happyReduction_200
+happyReduction_200 (HappyAbsSyn12 happy_var_2)
+ _
+ = HappyAbsSyn67
+ (PMacro happy_var_2
+ )
+happyReduction_200 _ _ = notHappyAtAll
+
+happyReduce_201 = happyReduce 4# 67# happyReduction_201
+happyReduction_201 ((HappyAbsSyn12 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn67
+ (PM happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_202 = happySpecReduce_1 67# happyReduction_202
+happyReduction_202 _
+ = HappyAbsSyn67
+ (PW
+ )
+
+happyReduce_203 = happySpecReduce_1 67# happyReduction_203
+happyReduction_203 (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn67
+ (PV happy_var_1
+ )
+happyReduction_203 _ = notHappyAtAll
+
+happyReduce_204 = happySpecReduce_3 67# happyReduction_204
+happyReduction_204 _
+ (HappyAbsSyn12 happy_var_2)
+ _
+ = HappyAbsSyn67
+ (PCon happy_var_2
+ )
+happyReduction_204 _ _ _ = notHappyAtAll
+
+happyReduce_205 = happySpecReduce_3 67# happyReduction_205
+happyReduction_205 (HappyAbsSyn12 happy_var_3)
+ _
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn67
+ (PQ happy_var_1 happy_var_3
+ )
+happyReduction_205 _ _ _ = notHappyAtAll
+
+happyReduce_206 = happySpecReduce_1 67# happyReduction_206
+happyReduction_206 (HappyAbsSyn8 happy_var_1)
+ = HappyAbsSyn67
+ (PInt happy_var_1
+ )
+happyReduction_206 _ = notHappyAtAll
+
+happyReduce_207 = happySpecReduce_1 67# happyReduction_207
+happyReduction_207 (HappyAbsSyn10 happy_var_1)
+ = HappyAbsSyn67
+ (PFloat happy_var_1
+ )
+happyReduction_207 _ = notHappyAtAll
+
+happyReduce_208 = happySpecReduce_1 67# happyReduction_208
+happyReduction_208 (HappyAbsSyn9 happy_var_1)
+ = HappyAbsSyn67
+ (PStr happy_var_1
+ )
+happyReduction_208 _ = notHappyAtAll
+
+happyReduce_209 = happySpecReduce_3 67# happyReduction_209
+happyReduction_209 _
+ (HappyAbsSyn73 happy_var_2)
+ _
+ = HappyAbsSyn67
+ (PR happy_var_2
+ )
+happyReduction_209 _ _ _ = notHappyAtAll
+
+happyReduce_210 = happySpecReduce_3 67# happyReduction_210
+happyReduction_210 _
+ (HappyAbsSyn81 happy_var_2)
+ _
+ = HappyAbsSyn67
+ (PTup happy_var_2
+ )
+happyReduction_210 _ _ _ = notHappyAtAll
+
+happyReduce_211 = happySpecReduce_3 67# happyReduction_211
+happyReduction_211 _
+ (HappyAbsSyn67 happy_var_2)
+ _
+ = HappyAbsSyn67
+ (happy_var_2
+ )
+happyReduction_211 _ _ _ = notHappyAtAll
+
+happyReduce_212 = happySpecReduce_2 68# happyReduction_212
+happyReduction_212 (HappyAbsSyn74 happy_var_2)
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn67
+ (PC happy_var_1 happy_var_2
+ )
+happyReduction_212 _ _ = notHappyAtAll
+
+happyReduce_213 = happyReduce 4# 68# happyReduction_213
+happyReduction_213 ((HappyAbsSyn74 happy_var_4) `HappyStk`
+ (HappyAbsSyn12 happy_var_3) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn12 happy_var_1) `HappyStk`
+ happyRest)
+ = HappyAbsSyn67
+ (PQC happy_var_1 happy_var_3 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_214 = happySpecReduce_2 68# happyReduction_214
+happyReduction_214 _
+ (HappyAbsSyn67 happy_var_1)
+ = HappyAbsSyn67
+ (PRep happy_var_1
+ )
+happyReduction_214 _ _ = notHappyAtAll
+
+happyReduce_215 = happySpecReduce_3 68# happyReduction_215
+happyReduction_215 (HappyAbsSyn67 happy_var_3)
+ _
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn67
+ (PAs happy_var_1 happy_var_3
+ )
+happyReduction_215 _ _ _ = notHappyAtAll
+
+happyReduce_216 = happySpecReduce_2 68# happyReduction_216
+happyReduction_216 (HappyAbsSyn67 happy_var_2)
+ _
+ = HappyAbsSyn67
+ (PNeg happy_var_2
+ )
+happyReduction_216 _ _ = notHappyAtAll
+
+happyReduce_217 = happySpecReduce_1 68# happyReduction_217
+happyReduction_217 (HappyAbsSyn67 happy_var_1)
+ = HappyAbsSyn67
+ (happy_var_1
+ )
+happyReduction_217 _ = notHappyAtAll
+
+happyReduce_218 = happySpecReduce_3 69# happyReduction_218
+happyReduction_218 (HappyAbsSyn67 happy_var_3)
+ _
+ (HappyAbsSyn67 happy_var_1)
+ = HappyAbsSyn67
+ (PDisj happy_var_1 happy_var_3
+ )
+happyReduction_218 _ _ _ = notHappyAtAll
+
+happyReduce_219 = happySpecReduce_3 69# happyReduction_219
+happyReduction_219 (HappyAbsSyn67 happy_var_3)
+ _
+ (HappyAbsSyn67 happy_var_1)
+ = HappyAbsSyn67
+ (PSeq happy_var_1 happy_var_3
+ )
+happyReduction_219 _ _ _ = notHappyAtAll
+
+happyReduce_220 = happySpecReduce_1 69# happyReduction_220
+happyReduction_220 (HappyAbsSyn67 happy_var_1)
+ = HappyAbsSyn67
+ (happy_var_1
+ )
+happyReduction_220 _ = notHappyAtAll
+
+happyReduce_221 = happySpecReduce_3 70# happyReduction_221
+happyReduction_221 (HappyAbsSyn67 happy_var_3)
+ _
+ (HappyAbsSyn53 happy_var_1)
+ = HappyAbsSyn70
+ (PA happy_var_1 happy_var_3
+ )
+happyReduction_221 _ _ _ = notHappyAtAll
+
+happyReduce_222 = happySpecReduce_1 71# happyReduction_222
+happyReduction_222 (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn71
+ (LIdent happy_var_1
+ )
+happyReduction_222 _ = notHappyAtAll
+
+happyReduce_223 = happySpecReduce_2 71# happyReduction_223
+happyReduction_223 (HappyAbsSyn8 happy_var_2)
+ _
+ = HappyAbsSyn71
+ (LVar happy_var_2
+ )
+happyReduction_223 _ _ = notHappyAtAll
+
+happyReduce_224 = happySpecReduce_1 72# happyReduction_224
+happyReduction_224 _
+ = HappyAbsSyn72
+ (Sort_Type
+ )
+
+happyReduce_225 = happySpecReduce_1 72# happyReduction_225
+happyReduction_225 _
+ = HappyAbsSyn72
+ (Sort_PType
+ )
+
+happyReduce_226 = happySpecReduce_1 72# happyReduction_226
+happyReduction_226 _
+ = HappyAbsSyn72
+ (Sort_Tok
+ )
+
+happyReduce_227 = happySpecReduce_1 72# happyReduction_227
+happyReduction_227 _
+ = HappyAbsSyn72
+ (Sort_Str
+ )
+
+happyReduce_228 = happySpecReduce_1 72# happyReduction_228
+happyReduction_228 _
+ = HappyAbsSyn72
+ (Sort_Strs
+ )
+
+happyReduce_229 = happySpecReduce_0 73# happyReduction_229
+happyReduction_229 = HappyAbsSyn73
+ ([]
+ )
+
+happyReduce_230 = happySpecReduce_1 73# happyReduction_230
+happyReduction_230 (HappyAbsSyn70 happy_var_1)
+ = HappyAbsSyn73
+ ((:[]) happy_var_1
+ )
+happyReduction_230 _ = notHappyAtAll
+
+happyReduce_231 = happySpecReduce_3 73# happyReduction_231
+happyReduction_231 (HappyAbsSyn73 happy_var_3)
+ _
+ (HappyAbsSyn70 happy_var_1)
+ = HappyAbsSyn73
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_231 _ _ _ = notHappyAtAll
+
+happyReduce_232 = happySpecReduce_1 74# happyReduction_232
+happyReduction_232 (HappyAbsSyn67 happy_var_1)
+ = HappyAbsSyn74
+ ((:[]) happy_var_1
+ )
+happyReduction_232 _ = notHappyAtAll
+
+happyReduce_233 = happySpecReduce_2 74# happyReduction_233
+happyReduction_233 (HappyAbsSyn74 happy_var_2)
+ (HappyAbsSyn67 happy_var_1)
+ = HappyAbsSyn74
+ ((:) happy_var_1 happy_var_2
+ )
+happyReduction_233 _ _ = notHappyAtAll
+
+happyReduce_234 = happySpecReduce_1 75# happyReduction_234
+happyReduction_234 (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn75
+ (BIdent happy_var_1
+ )
+happyReduction_234 _ = notHappyAtAll
+
+happyReduce_235 = happySpecReduce_1 75# happyReduction_235
+happyReduction_235 _
+ = HappyAbsSyn75
+ (BWild
+ )
+
+happyReduce_236 = happySpecReduce_0 76# happyReduction_236
+happyReduction_236 = HappyAbsSyn76
+ ([]
+ )
+
+happyReduce_237 = happySpecReduce_1 76# happyReduction_237
+happyReduction_237 (HappyAbsSyn75 happy_var_1)
+ = HappyAbsSyn76
+ ((:[]) happy_var_1
+ )
+happyReduction_237 _ = notHappyAtAll
+
+happyReduce_238 = happySpecReduce_3 76# happyReduction_238
+happyReduction_238 (HappyAbsSyn76 happy_var_3)
+ _
+ (HappyAbsSyn75 happy_var_1)
+ = HappyAbsSyn76
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_238 _ _ _ = notHappyAtAll
+
+happyReduce_239 = happyReduce 5# 77# happyReduction_239
+happyReduction_239 (_ `HappyStk`
+ (HappyAbsSyn58 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn76 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn77
+ (DDec happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_240 = happySpecReduce_1 77# happyReduction_240
+happyReduction_240 (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn77
+ (DExp happy_var_1
+ )
+happyReduction_240 _ = notHappyAtAll
+
+happyReduce_241 = happySpecReduce_1 78# happyReduction_241
+happyReduction_241 (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn78
+ (TComp happy_var_1
+ )
+happyReduction_241 _ = notHappyAtAll
+
+happyReduce_242 = happySpecReduce_1 79# happyReduction_242
+happyReduction_242 (HappyAbsSyn67 happy_var_1)
+ = HappyAbsSyn79
+ (PTComp happy_var_1
+ )
+happyReduction_242 _ = notHappyAtAll
+
+happyReduce_243 = happySpecReduce_0 80# happyReduction_243
+happyReduction_243 = HappyAbsSyn80
+ ([]
+ )
+
+happyReduce_244 = happySpecReduce_1 80# happyReduction_244
+happyReduction_244 (HappyAbsSyn78 happy_var_1)
+ = HappyAbsSyn80
+ ((:[]) happy_var_1
+ )
+happyReduction_244 _ = notHappyAtAll
+
+happyReduce_245 = happySpecReduce_3 80# happyReduction_245
+happyReduction_245 (HappyAbsSyn80 happy_var_3)
+ _
+ (HappyAbsSyn78 happy_var_1)
+ = HappyAbsSyn80
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_245 _ _ _ = notHappyAtAll
+
+happyReduce_246 = happySpecReduce_0 81# happyReduction_246
+happyReduction_246 = HappyAbsSyn81
+ ([]
+ )
+
+happyReduce_247 = happySpecReduce_1 81# happyReduction_247
+happyReduction_247 (HappyAbsSyn79 happy_var_1)
+ = HappyAbsSyn81
+ ((:[]) happy_var_1
+ )
+happyReduction_247 _ = notHappyAtAll
+
+happyReduce_248 = happySpecReduce_3 81# happyReduction_248
+happyReduction_248 (HappyAbsSyn81 happy_var_3)
+ _
+ (HappyAbsSyn79 happy_var_1)
+ = HappyAbsSyn81
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_248 _ _ _ = notHappyAtAll
+
+happyReduce_249 = happySpecReduce_3 82# happyReduction_249
+happyReduction_249 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn67 happy_var_1)
+ = HappyAbsSyn82
+ (Case happy_var_1 happy_var_3
+ )
+happyReduction_249 _ _ _ = notHappyAtAll
+
+happyReduce_250 = happySpecReduce_1 83# happyReduction_250
+happyReduction_250 (HappyAbsSyn82 happy_var_1)
+ = HappyAbsSyn83
+ ((:[]) happy_var_1
+ )
+happyReduction_250 _ = notHappyAtAll
+
+happyReduce_251 = happySpecReduce_3 83# happyReduction_251
+happyReduction_251 (HappyAbsSyn83 happy_var_3)
+ _
+ (HappyAbsSyn82 happy_var_1)
+ = HappyAbsSyn83
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_251 _ _ _ = notHappyAtAll
+
+happyReduce_252 = happySpecReduce_3 84# happyReduction_252
+happyReduction_252 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn74 happy_var_1)
+ = HappyAbsSyn84
+ (Equ happy_var_1 happy_var_3
+ )
+happyReduction_252 _ _ _ = notHappyAtAll
+
+happyReduce_253 = happySpecReduce_0 85# happyReduction_253
+happyReduction_253 = HappyAbsSyn85
+ ([]
+ )
+
+happyReduce_254 = happySpecReduce_1 85# happyReduction_254
+happyReduction_254 (HappyAbsSyn84 happy_var_1)
+ = HappyAbsSyn85
+ ((:[]) happy_var_1
+ )
+happyReduction_254 _ = notHappyAtAll
+
+happyReduce_255 = happySpecReduce_3 85# happyReduction_255
+happyReduction_255 (HappyAbsSyn85 happy_var_3)
+ _
+ (HappyAbsSyn84 happy_var_1)
+ = HappyAbsSyn85
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_255 _ _ _ = notHappyAtAll
+
+happyReduce_256 = happySpecReduce_3 86# happyReduction_256
+happyReduction_256 (HappyAbsSyn58 happy_var_3)
+ _
+ (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn86
+ (Alt happy_var_1 happy_var_3
+ )
+happyReduction_256 _ _ _ = notHappyAtAll
+
+happyReduce_257 = happySpecReduce_0 87# happyReduction_257
+happyReduction_257 = HappyAbsSyn87
+ ([]
+ )
+
+happyReduce_258 = happySpecReduce_1 87# happyReduction_258
+happyReduction_258 (HappyAbsSyn86 happy_var_1)
+ = HappyAbsSyn87
+ ((:[]) happy_var_1
+ )
+happyReduction_258 _ = notHappyAtAll
+
+happyReduce_259 = happySpecReduce_3 87# happyReduction_259
+happyReduction_259 (HappyAbsSyn87 happy_var_3)
+ _
+ (HappyAbsSyn86 happy_var_1)
+ = HappyAbsSyn87
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_259 _ _ _ = notHappyAtAll
+
+happyReduce_260 = happyReduce 5# 88# happyReduction_260
+happyReduction_260 (_ `HappyStk`
+ (HappyAbsSyn58 happy_var_4) `HappyStk`
+ _ `HappyStk`
+ (HappyAbsSyn76 happy_var_2) `HappyStk`
+ _ `HappyStk`
+ happyRest)
+ = HappyAbsSyn88
+ (DDDec happy_var_2 happy_var_4
+ ) `HappyStk` happyRest
+
+happyReduce_261 = happySpecReduce_1 88# happyReduction_261
+happyReduction_261 (HappyAbsSyn58 happy_var_1)
+ = HappyAbsSyn88
+ (DDExp happy_var_1
+ )
+happyReduction_261 _ = notHappyAtAll
+
+happyReduce_262 = happySpecReduce_0 89# happyReduction_262
+happyReduction_262 = HappyAbsSyn89
+ ([]
+ )
+
+happyReduce_263 = happySpecReduce_2 89# happyReduction_263
+happyReduction_263 (HappyAbsSyn88 happy_var_2)
+ (HappyAbsSyn89 happy_var_1)
+ = HappyAbsSyn89
+ (flip (:) happy_var_1 happy_var_2
+ )
+happyReduction_263 _ _ = notHappyAtAll
+
+happyReduce_264 = happySpecReduce_2 90# happyReduction_264
+happyReduction_264 (HappyAbsSyn25 happy_var_2)
+ (HappyAbsSyn91 happy_var_1)
+ = HappyAbsSyn90
+ (OldGr happy_var_1 (reverse happy_var_2)
+ )
+happyReduction_264 _ _ = notHappyAtAll
+
+happyReduce_265 = happySpecReduce_0 91# happyReduction_265
+happyReduction_265 = HappyAbsSyn91
+ (NoIncl
+ )
+
+happyReduce_266 = happySpecReduce_2 91# happyReduction_266
+happyReduction_266 (HappyAbsSyn93 happy_var_2)
+ _
+ = HappyAbsSyn91
+ (Incl happy_var_2
+ )
+happyReduction_266 _ _ = notHappyAtAll
+
+happyReduce_267 = happySpecReduce_1 92# happyReduction_267
+happyReduction_267 (HappyAbsSyn9 happy_var_1)
+ = HappyAbsSyn92
+ (FString happy_var_1
+ )
+happyReduction_267 _ = notHappyAtAll
+
+happyReduce_268 = happySpecReduce_1 92# happyReduction_268
+happyReduction_268 (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn92
+ (FIdent happy_var_1
+ )
+happyReduction_268 _ = notHappyAtAll
+
+happyReduce_269 = happySpecReduce_2 92# happyReduction_269
+happyReduction_269 (HappyAbsSyn92 happy_var_2)
+ _
+ = HappyAbsSyn92
+ (FSlash happy_var_2
+ )
+happyReduction_269 _ _ = notHappyAtAll
+
+happyReduce_270 = happySpecReduce_2 92# happyReduction_270
+happyReduction_270 (HappyAbsSyn92 happy_var_2)
+ _
+ = HappyAbsSyn92
+ (FDot happy_var_2
+ )
+happyReduction_270 _ _ = notHappyAtAll
+
+happyReduce_271 = happySpecReduce_2 92# happyReduction_271
+happyReduction_271 (HappyAbsSyn92 happy_var_2)
+ _
+ = HappyAbsSyn92
+ (FMinus happy_var_2
+ )
+happyReduction_271 _ _ = notHappyAtAll
+
+happyReduce_272 = happySpecReduce_2 92# happyReduction_272
+happyReduction_272 (HappyAbsSyn92 happy_var_2)
+ (HappyAbsSyn12 happy_var_1)
+ = HappyAbsSyn92
+ (FAddId happy_var_1 happy_var_2
+ )
+happyReduction_272 _ _ = notHappyAtAll
+
+happyReduce_273 = happySpecReduce_2 93# happyReduction_273
+happyReduction_273 _
+ (HappyAbsSyn92 happy_var_1)
+ = HappyAbsSyn93
+ ((:[]) happy_var_1
+ )
+happyReduction_273 _ _ = notHappyAtAll
+
+happyReduce_274 = happySpecReduce_3 93# happyReduction_274
+happyReduction_274 (HappyAbsSyn93 happy_var_3)
+ _
+ (HappyAbsSyn92 happy_var_1)
+ = HappyAbsSyn93
+ ((:) happy_var_1 happy_var_3
+ )
+happyReduction_274 _ _ _ = notHappyAtAll
+
+happyNewToken action sts stk [] =
+ action 176# 176# notHappyAtAll (HappyState action) sts stk []
+
+happyNewToken action sts stk (tk:tks) =
+ let cont i = action i i tk (HappyState action) sts stk tks in
+ case tk of {
+ PT _ (TS _ 1) -> cont 94#;
+ PT _ (TS _ 2) -> cont 95#;
+ PT _ (TS _ 3) -> cont 96#;
+ PT _ (TS _ 4) -> cont 97#;
+ PT _ (TS _ 5) -> cont 98#;
+ PT _ (TS _ 6) -> cont 99#;
+ PT _ (TS _ 7) -> cont 100#;
+ PT _ (TS _ 8) -> cont 101#;
+ PT _ (TS _ 9) -> cont 102#;
+ PT _ (TS _ 10) -> cont 103#;
+ PT _ (TS _ 11) -> cont 104#;
+ PT _ (TS _ 12) -> cont 105#;
+ PT _ (TS _ 13) -> cont 106#;
+ PT _ (TS _ 14) -> cont 107#;
+ PT _ (TS _ 15) -> cont 108#;
+ PT _ (TS _ 16) -> cont 109#;
+ PT _ (TS _ 17) -> cont 110#;
+ PT _ (TS _ 18) -> cont 111#;
+ PT _ (TS _ 19) -> cont 112#;
+ PT _ (TS _ 20) -> cont 113#;
+ PT _ (TS _ 21) -> cont 114#;
+ PT _ (TS _ 22) -> cont 115#;
+ PT _ (TS _ 23) -> cont 116#;
+ PT _ (TS _ 24) -> cont 117#;
+ PT _ (TS _ 25) -> cont 118#;
+ PT _ (TS _ 26) -> cont 119#;
+ PT _ (TS _ 27) -> cont 120#;
+ PT _ (TS _ 28) -> cont 121#;
+ PT _ (TS _ 29) -> cont 122#;
+ PT _ (TS _ 30) -> cont 123#;
+ PT _ (TS _ 31) -> cont 124#;
+ PT _ (TS _ 32) -> cont 125#;
+ PT _ (TS _ 33) -> cont 126#;
+ PT _ (TS _ 34) -> cont 127#;
+ PT _ (TS _ 35) -> cont 128#;
+ PT _ (TS _ 36) -> cont 129#;
+ PT _ (TS _ 37) -> cont 130#;
+ PT _ (TS _ 38) -> cont 131#;
+ PT _ (TS _ 39) -> cont 132#;
+ PT _ (TS _ 40) -> cont 133#;
+ PT _ (TS _ 41) -> cont 134#;
+ PT _ (TS _ 42) -> cont 135#;
+ PT _ (TS _ 43) -> cont 136#;
+ PT _ (TS _ 44) -> cont 137#;
+ PT _ (TS _ 45) -> cont 138#;
+ PT _ (TS _ 46) -> cont 139#;
+ PT _ (TS _ 47) -> cont 140#;
+ PT _ (TS _ 48) -> cont 141#;
+ PT _ (TS _ 49) -> cont 142#;
+ PT _ (TS _ 50) -> cont 143#;
+ PT _ (TS _ 51) -> cont 144#;
+ PT _ (TS _ 52) -> cont 145#;
+ PT _ (TS _ 53) -> cont 146#;
+ PT _ (TS _ 54) -> cont 147#;
+ PT _ (TS _ 55) -> cont 148#;
+ PT _ (TS _ 56) -> cont 149#;
+ PT _ (TS _ 57) -> cont 150#;
+ PT _ (TS _ 58) -> cont 151#;
+ PT _ (TS _ 59) -> cont 152#;
+ PT _ (TS _ 60) -> cont 153#;
+ PT _ (TS _ 61) -> cont 154#;
+ PT _ (TS _ 62) -> cont 155#;
+ PT _ (TS _ 63) -> cont 156#;
+ PT _ (TS _ 64) -> cont 157#;
+ PT _ (TS _ 65) -> cont 158#;
+ PT _ (TS _ 66) -> cont 159#;
+ PT _ (TS _ 67) -> cont 160#;
+ PT _ (TS _ 68) -> cont 161#;
+ PT _ (TS _ 69) -> cont 162#;
+ PT _ (TS _ 70) -> cont 163#;
+ PT _ (TS _ 71) -> cont 164#;
+ PT _ (TS _ 72) -> cont 165#;
+ PT _ (TS _ 73) -> cont 166#;
+ PT _ (TS _ 74) -> cont 167#;
+ PT _ (TS _ 75) -> cont 168#;
+ PT _ (TS _ 76) -> cont 169#;
+ PT _ (TI happy_dollar_dollar) -> cont 170#;
+ PT _ (TL happy_dollar_dollar) -> cont 171#;
+ PT _ (TD happy_dollar_dollar) -> cont 172#;
+ PT _ (T_LString happy_dollar_dollar) -> cont 173#;
+ PT _ (T_PIdent _) -> cont 174#;
+ _ -> cont 175#;
+ _ -> happyError' (tk:tks)
+ }
+
+happyError_ tk tks = happyError' (tk:tks)
+
+happyThen :: () => Err a -> (a -> Err b) -> Err b
+happyThen = (thenM)
+happyReturn :: () => a -> Err a
+happyReturn = (returnM)
+happyThen1 m k tks = (thenM) m (\a -> k a tks)
+happyReturn1 :: () => a -> b -> Err a
+happyReturn1 = \a tks -> (returnM) a
+happyError' :: () => [Token] -> Err a
+happyError' = happyError
+
+pGrammar tks = happySomeParser where
+ happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn13 z -> happyReturn z; _other -> notHappyAtAll })
+
+pModDef tks = happySomeParser where
+ happySomeParser = happyThen (happyParse action_1 tks) (\x -> case x of {HappyAbsSyn15 z -> happyReturn z; _other -> notHappyAtAll })
+
+pOldGrammar tks = happySomeParser where
+ happySomeParser = happyThen (happyParse action_2 tks) (\x -> case x of {HappyAbsSyn90 z -> happyReturn z; _other -> notHappyAtAll })
+
+pModHeader tks = happySomeParser where
+ happySomeParser = happyThen (happyParse action_3 tks) (\x -> case x of {HappyAbsSyn15 z -> happyReturn z; _other -> notHappyAtAll })
+
+pExp tks = happySomeParser where
+ happySomeParser = happyThen (happyParse action_4 tks) (\x -> case x of {HappyAbsSyn58 z -> happyReturn z; _other -> notHappyAtAll })
+
+happySeq = happyDontSeq
+
+
+returnM :: a -> Err a
+returnM = return
+
+thenM :: Err a -> (a -> Err b) -> Err b
+thenM = (>>=)
+
+happyError :: [Token] -> Err a
+happyError ts =
+ Bad $ "syntax error at " ++ tokenPos ts ++
+ case ts of
+ [] -> []
+ [Err _] -> " due to lexer error"
+ _ -> " before " ++ unwords (map (BS.unpack . prToken) (take 4 ts))
+
+myLexer = tokens
+{-# LINE 1 "templates/GenericTemplate.hs" #-}
+{-# LINE 1 "templates/GenericTemplate.hs" #-}
+{-# LINE 1 "<built-in>" #-}
+{-# LINE 1 "<command line>" #-}
+{-# LINE 1 "templates/GenericTemplate.hs" #-}
+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp
+
+{-# LINE 28 "templates/GenericTemplate.hs" #-}
+
+
+
+
+
+
+
+
+{-# LINE 49 "templates/GenericTemplate.hs" #-}
+
+{-# LINE 59 "templates/GenericTemplate.hs" #-}
+
+{-# LINE 68 "templates/GenericTemplate.hs" #-}
+
+infixr 9 `HappyStk`
+data HappyStk a = HappyStk a (HappyStk a)
+
+-----------------------------------------------------------------------------
+-- starting the parse
+
+happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
+
+-----------------------------------------------------------------------------
+-- Accepting the parse
+
+-- If the current token is 1#, it means we've just accepted a partial
+-- parse (a %partial parser). We must ignore the saved token on the top of
+-- the stack in this case.
+happyAccept 1# tk st sts (_ `HappyStk` ans `HappyStk` _) =
+ happyReturn1 ans
+happyAccept j tk st sts (HappyStk ans _) =
+ (happyTcHack j ) (happyReturn1 ans)
+
+-----------------------------------------------------------------------------
+-- Arrays only: do the next action
+
+{-# LINE 155 "templates/GenericTemplate.hs" #-}
+
+-----------------------------------------------------------------------------
+-- HappyState data type (not arrays)
+
+
+
+newtype HappyState b c = HappyState
+ (Int# -> -- token number
+ Int# -> -- token number (yes, again)
+ b -> -- token semantic value
+ HappyState b c -> -- current state
+ [HappyState b c] -> -- state stack
+ c)
+
+
+
+-----------------------------------------------------------------------------
+-- Shifting a token
+
+happyShift new_state 1# tk st sts stk@(x `HappyStk` _) =
+ let i = (case x of { HappyErrorToken (I# (i)) -> i }) in
+-- trace "shifting the error token" $
+ new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)
+
+happyShift new_state i tk st sts stk =
+ happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)
+
+-- happyReduce is specialised for the common cases.
+
+happySpecReduce_0 i fn 1# tk st sts stk
+ = happyFail 1# tk st sts stk
+happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk
+ = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)
+
+happySpecReduce_1 i fn 1# tk st sts stk
+ = happyFail 1# tk st sts stk
+happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')
+ = let r = fn v1 in
+ happySeq r (action nt j tk st sts (r `HappyStk` stk'))
+
+happySpecReduce_2 i fn 1# tk st sts stk
+ = happyFail 1# tk st sts stk
+happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')
+ = let r = fn v1 v2 in
+ happySeq r (action nt j tk st sts (r `HappyStk` stk'))
+
+happySpecReduce_3 i fn 1# tk st sts stk
+ = happyFail 1# tk st sts stk
+happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
+ = let r = fn v1 v2 v3 in
+ happySeq r (action nt j tk st sts (r `HappyStk` stk'))
+
+happyReduce k i fn 1# tk st sts stk
+ = happyFail 1# tk st sts stk
+happyReduce k nt fn j tk st sts stk
+ = case happyDrop (k -# (1# :: Int#)) sts of
+ sts1@(((st1@(HappyState (action))):(_))) ->
+ let r = fn stk in -- it doesn't hurt to always seq here...
+ happyDoSeq r (action nt j tk st1 sts1 r)
+
+happyMonadReduce k nt fn 1# tk st sts stk
+ = happyFail 1# tk st sts stk
+happyMonadReduce k nt fn j tk st sts stk =
+ happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))
+ where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))
+ drop_stk = happyDropStk k stk
+
+happyMonad2Reduce k nt fn 1# tk st sts stk
+ = happyFail 1# tk st sts stk
+happyMonad2Reduce k nt fn j tk st sts stk =
+ happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))
+ where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))
+ drop_stk = happyDropStk k stk
+
+
+
+
+
+ new_state = action
+
+
+happyDrop 0# l = l
+happyDrop n ((_):(t)) = happyDrop (n -# (1# :: Int#)) t
+
+happyDropStk 0# l = l
+happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs
+
+-----------------------------------------------------------------------------
+-- Moving to a new state after a reduction
+
+{-# LINE 253 "templates/GenericTemplate.hs" #-}
+happyGoto action j tk st = action j j tk (HappyState action)
+
+
+-----------------------------------------------------------------------------
+-- Error recovery (1# is the error token)
+
+-- parse error if we are in recovery and we fail again
+happyFail 1# tk old_st _ stk =
+-- trace "failing" $
+ happyError_ tk
+
+{- We don't need state discarding for our restricted implementation of
+ "error". In fact, it can cause some bogus parses, so I've disabled it
+ for now --SDM
+
+-- discard a state
+happyFail 1# tk old_st (((HappyState (action))):(sts))
+ (saved_tok `HappyStk` _ `HappyStk` stk) =
+-- trace ("discarding state, depth " ++ show (length stk)) $
+ action 1# 1# tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))
+-}
+
+-- Enter error recovery: generate an error token,
+-- save the old token and carry on.
+happyFail i tk (HappyState (action)) sts stk =
+-- trace "entering error recovery" $
+ action 1# 1# tk (HappyState (action)) sts ( (HappyErrorToken (I# (i))) `HappyStk` stk)
+
+-- Internal happy errors:
+
+notHappyAtAll = error "Internal Happy error\n"
+
+-----------------------------------------------------------------------------
+-- Hack to get the typechecker to accept our action functions
+
+
+happyTcHack :: Int# -> a -> a
+happyTcHack x y = y
+{-# INLINE happyTcHack #-}
+
+
+-----------------------------------------------------------------------------
+-- Seq-ing. If the --strict flag is given, then Happy emits
+-- happySeq = happyDoSeq
+-- otherwise it emits
+-- happySeq = happyDontSeq
+
+happyDoSeq, happyDontSeq :: a -> b -> b
+happyDoSeq a b = a `seq` b
+happyDontSeq a b = b
+
+-----------------------------------------------------------------------------
+-- Don't inline any functions from the template. GHC has a nasty habit
+-- of deciding to inline happyGoto everywhere, which increases the size of
+-- the generated parser quite a bit.
+
+{-# LINE 317 "templates/GenericTemplate.hs" #-}
+{-# NOINLINE happyShift #-}
+{-# NOINLINE happySpecReduce_0 #-}
+{-# NOINLINE happySpecReduce_1 #-}
+{-# NOINLINE happySpecReduce_2 #-}
+{-# NOINLINE happySpecReduce_3 #-}
+{-# NOINLINE happyReduce #-}
+{-# NOINLINE happyMonadReduce #-}
+{-# NOINLINE happyGoto #-}
+{-# NOINLINE happyFail #-}
+
+-- end of Happy Template.
diff --git a/src/GF/Source/ParGF.y b/src/GF/Source/ParGF.y new file mode 100644 index 000000000..22a15cd93 --- /dev/null +++ b/src/GF/Source/ParGF.y @@ -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
+}
+
diff --git a/src/GF/Source/PrintGF.hs b/src/GF/Source/PrintGF.hs new file mode 100644 index 000000000..ea2277e67 --- /dev/null +++ b/src/GF/Source/PrintGF.hs @@ -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])
+
+
diff --git a/src/GF/Source/SharedString.hs b/src/GF/Source/SharedString.hs new file mode 100644 index 000000000..732873fe6 --- /dev/null +++ b/src/GF/Source/SharedString.hs @@ -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'
diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs new file mode 100644 index 000000000..e80219f30 --- /dev/null +++ b/src/GF/Source/SourceToGrammar.hs @@ -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)) diff --git a/src/GF/Speech/CFG.hs b/src/GF/Speech/CFG.hs new file mode 100644 index 000000000..5b2a0f2ca --- /dev/null +++ b/src/GF/Speech/CFG.hs @@ -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) diff --git a/src/GF/Speech/CFGToFA.hs b/src/GF/Speech/CFGToFA.hs new file mode 100644 index 000000000..1ac4bd24e --- /dev/null +++ b/src/GF/Speech/CFGToFA.hs @@ -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] diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs new file mode 100644 index 000000000..c809eb544 --- /dev/null +++ b/src/GF/Speech/FiniteState.hs @@ -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 diff --git a/src/GF/Speech/GSL.hs b/src/GF/Speech/GSL.hs new file mode 100644 index 000000000..637552bf4 --- /dev/null +++ b/src/GF/Speech/GSL.hs @@ -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 diff --git a/src/GF/Speech/Graph.hs b/src/GF/Speech/Graph.hs new file mode 100644 index 000000000..1a0ebe0c0 --- /dev/null +++ b/src/GF/Speech/Graph.hs @@ -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 diff --git a/src/GF/Speech/Graphviz.hs b/src/GF/Speech/Graphviz.hs new file mode 100644 index 000000000..1851fcb64 --- /dev/null +++ b/src/GF/Speech/Graphviz.hs @@ -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 diff --git a/src/GF/Speech/JSGF.hs b/src/GF/Speech/JSGF.hs new file mode 100644 index 000000000..dc9f4170a --- /dev/null +++ b/src/GF/Speech/JSGF.hs @@ -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 + diff --git a/src/GF/Speech/PGFToCFG.hs b/src/GF/Speech/PGFToCFG.hs new file mode 100644 index 000000000..1f3ebaeb4 --- /dev/null +++ b/src/GF/Speech/PGFToCFG.hs @@ -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]) diff --git a/src/GF/Speech/PrRegExp.hs b/src/GF/Speech/PrRegExp.hs new file mode 100644 index 000000000..ae450dee8 --- /dev/null +++ b/src/GF/Speech/PrRegExp.hs @@ -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] diff --git a/src/GF/Speech/RegExp.hs b/src/GF/Speech/RegExp.hs new file mode 100644 index 000000000..5ee40828e --- /dev/null +++ b/src/GF/Speech/RegExp.hs @@ -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 diff --git a/src/GF/Speech/Relation.hs b/src/GF/Speech/Relation.hs new file mode 100644 index 000000000..641d671a9 --- /dev/null +++ b/src/GF/Speech/Relation.hs @@ -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) diff --git a/src/GF/Speech/SISR.hs b/src/GF/Speech/SISR.hs new file mode 100644 index 000000000..723dc1a49 --- /dev/null +++ b/src/GF/Speech/SISR.hs @@ -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] + diff --git a/src/GF/Speech/SLF.hs b/src/GF/Speech/SLF.hs new file mode 100644 index 000000000..4bdc05212 --- /dev/null +++ b/src/GF/Speech/SLF.hs @@ -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 ] diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs new file mode 100644 index 000000000..a861d889d --- /dev/null +++ b/src/GF/Speech/SRG.hs @@ -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 diff --git a/src/GF/Speech/SRGS_XML.hs b/src/GF/Speech/SRGS_XML.hs new file mode 100644 index 000000000..33e2d0374 --- /dev/null +++ b/src/GF/Speech/SRGS_XML.hs @@ -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 diff --git a/src/GF/Speech/VoiceXML.hs b/src/GF/Speech/VoiceXML.hs new file mode 100644 index 000000000..14a93c796 --- /dev/null +++ b/src/GF/Speech/VoiceXML.hs @@ -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 +-} diff --git a/src/GF/System/NoReadline.hs b/src/GF/System/NoReadline.hs new file mode 100644 index 000000000..1f1050e8c --- /dev/null +++ b/src/GF/System/NoReadline.hs @@ -0,0 +1,33 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.System.NoReadline +-- Maintainer : BB +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/10 15:04:01 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.1 $ +-- +-- Do not use readline. +----------------------------------------------------------------------------- + +module GF.System.NoReadline (fetchCommand, setCompletionFunction, filenameCompletionFunction) where + +import System.IO.Error (try) +import System.IO (stdout,hFlush) + +fetchCommand :: String -> IO (String) +fetchCommand s = do + putStr s + hFlush stdout + res <- try getLine + case res of + Left e -> return "q" + Right l -> return l + +setCompletionFunction :: Maybe (String -> String -> Int -> IO [String]) -> IO () +setCompletionFunction _ = return () + +filenameCompletionFunction :: String -> IO [String] +filenameCompletionFunction _ = return [] diff --git a/src/GF/System/NoSignal.hs b/src/GF/System/NoSignal.hs new file mode 100644 index 000000000..5d82a431e --- /dev/null +++ b/src/GF/System/NoSignal.hs @@ -0,0 +1,29 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.System.NoSignal +-- Maintainer : Bjorn Bringert +-- Stability : (stability) +-- Portability : (portability) +-- +-- > CVS $Date: 2005/11/11 11:12:50 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.1 $ +-- +-- Dummy implementation of signal handling. +----------------------------------------------------------------------------- + +module GF.System.NoSignal where + +import Control.Exception (Exception,catch) +import Prelude hiding (catch) + +{-# NOINLINE runInterruptibly #-} +runInterruptibly :: IO a -> IO (Either Exception a) +--runInterruptibly = fmap Right +runInterruptibly a = + p `catch` h + where p = a >>= \x -> return $! Right $! x + h e = return $ Left e + +blockInterrupt :: IO a -> IO a +blockInterrupt = id diff --git a/src/GF/System/Readline.hs b/src/GF/System/Readline.hs new file mode 100644 index 000000000..db122c3e2 --- /dev/null +++ b/src/GF/System/Readline.hs @@ -0,0 +1,27 @@ +{-# OPTIONS -cpp #-} + +---------------------------------------------------------------------- +-- | +-- Module : GF.System.Readline +-- Maintainer : BB +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/10 15:04:01 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.2 $ +-- +-- Uses the right readline library to read user input. +----------------------------------------------------------------------------- + +module GF.System.Readline (fetchCommand, setCompletionFunction, filenameCompletionFunction) where + +#ifdef USE_READLINE + +import GF.System.UseReadline + +#else + +import GF.System.NoReadline + +#endif diff --git a/src/GF/System/Signal.hs b/src/GF/System/Signal.hs new file mode 100644 index 000000000..fe8a12483 --- /dev/null +++ b/src/GF/System/Signal.hs @@ -0,0 +1,27 @@ +{-# OPTIONS -cpp #-} + +---------------------------------------------------------------------- +-- | +-- Module : GF.System.Signal +-- Maintainer : Bjorn Bringert +-- Stability : (stability) +-- Portability : (portability) +-- +-- > CVS $Date: 2005/11/11 11:12:50 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.3 $ +-- +-- Import the right singal handling module. +----------------------------------------------------------------------------- + +module GF.System.Signal (runInterruptibly,blockInterrupt) where + +#ifdef USE_INTERRUPT + +import GF.System.UseSignal (runInterruptibly,blockInterrupt) + +#else + +import GF.System.NoSignal (runInterruptibly,blockInterrupt) + +#endif diff --git a/src/GF/System/UseReadline.hs b/src/GF/System/UseReadline.hs new file mode 100644 index 000000000..a0e051601 --- /dev/null +++ b/src/GF/System/UseReadline.hs @@ -0,0 +1,36 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.System.UseReadline +-- Maintainer : BB +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/10 15:04:01 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.1 $ +-- +-- Use GNU readline +----------------------------------------------------------------------------- + +module GF.System.UseReadline (fetchCommand, setCompletionFunction, filenameCompletionFunction) where + +import System.Console.Readline + +fetchCommand :: String -> IO (String) +fetchCommand s = do + setCompletionAppendCharacter Nothing + setBasicQuoteCharacters "" + res <- readline s + case res of + Nothing -> return "q" + Just s -> do addHistory s + return s + +setCompletionFunction :: Maybe (String -> String -> Int -> IO [String]) -> IO () +setCompletionFunction Nothing = setCompletionEntryFunction Nothing +setCompletionFunction (Just fn) = setCompletionEntryFunction (Just my_fn) + where + my_fn prefix = do + s <- getLineBuffer + p <- getPoint + fn s prefix p diff --git a/src/GF/System/UseSignal.hs b/src/GF/System/UseSignal.hs new file mode 100644 index 000000000..628f5888d --- /dev/null +++ b/src/GF/System/UseSignal.hs @@ -0,0 +1,72 @@ +{-# OPTIONS -cpp #-} +---------------------------------------------------------------------- +-- | +-- Module : GF.System.UseSignal +-- Maintainer : Bjorn Bringert +-- Stability : (stability) +-- Portability : (portability) +-- +-- > CVS $Date: 2005/11/11 11:12:50 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.1 $ +-- +-- Allows SIGINT (Ctrl-C) to interrupt computations. +----------------------------------------------------------------------------- + +module GF.System.UseSignal where + +import Control.Concurrent (myThreadId, killThread) +import Control.Exception (Exception,catch) +import Prelude hiding (catch) +import System.IO + +#ifdef mingw32_HOST_OS +import GHC.ConsoleHandler + +myInstallHandler handler = installHandler handler +myCatch = Catch . const +myIgnore = Ignore +#else +import System.Posix.Signals + +myInstallHandler handler = installHandler sigINT handler Nothing +myCatch = Catch +myIgnore = Ignore +#endif + +{-# NOINLINE runInterruptibly #-} + +-- | Run an IO action, and allow it to be interrupted +-- by a SIGINT to the current process. Returns +-- an exception if the process did not complete +-- normally. +-- NOTES: +-- * This will replace any existing SIGINT +-- handler during the action. After the computation +-- has completed the existing handler will be restored. +-- * If the IO action is lazy (e.g. using readFile, +-- unsafeInterleaveIO etc.) the lazy computation will +-- not be interruptible, as it will be performed +-- after the signal handler has been removed. +runInterruptibly :: IO a -> IO (Either Exception a) +runInterruptibly a = + do t <- myThreadId + oldH <- myInstallHandler (myCatch (print "Seek and Destroy" >> killThread t)) + x <- p `catch` h + myInstallHandler oldH + return x + where p = a >>= \x -> return $! Right $! x + h e = return $ Left e + +-- | Like 'runInterruptibly', but always returns (), whether +-- the computation fails or not. +runInterruptibly_ :: IO () -> IO () +runInterruptibly_ = fmap (either (const ()) id) . runInterruptibly + +-- | Run an action with SIGINT blocked. +blockInterrupt :: IO a -> IO a +blockInterrupt a = + do oldH <- myInstallHandler Ignore + x <- a + myInstallHandler oldH + return x diff --git a/src/GF/Text/Lexing.hs b/src/GF/Text/Lexing.hs new file mode 100644 index 000000000..2c6b417b8 --- /dev/null +++ b/src/GF/Text/Lexing.hs @@ -0,0 +1,115 @@ +module GF.Text.Lexing (stringOp) where + +import GF.Text.Transliterations +import GF.Text.UTF8 + +import Data.Char +import Data.List (intersperse) + +-- lexers and unlexers - they work on space-separated word strings + +stringOp :: String -> Maybe (String -> String) +stringOp name = case name of + "chars" -> Just $ appLexer (filter (not . all isSpace) . map return) + "lextext" -> Just $ appLexer lexText + "lexcode" -> Just $ appLexer lexText + "lexmixed" -> Just $ appLexer lexMixed + "words" -> Just $ appLexer words + "bind" -> Just $ appUnlexer bindTok + "uncars" -> Just $ appUnlexer concat + "unlextext" -> Just $ appUnlexer unlexText + "unlexcode" -> Just $ appUnlexer unlexCode + "unlexmixed" -> Just $ appUnlexer unlexMixed + "unwords" -> Just $ appUnlexer unwords + "to_html" -> Just wrapHTML + "to_utf8" -> Just encodeUTF8 + "from_utf8" -> Just decodeUTF8 + "to_cp1251" -> Just encodeCP1251 + "from_cp1251" -> Just decodeCP1251 + _ -> transliterate name + +appLexer :: (String -> [String]) -> String -> String +appLexer f = unwords . filter (not . null) . f + +appUnlexer :: ([String] -> String) -> String -> String +appUnlexer f = unlines . map (f . words) . lines + +wrapHTML :: String -> String +wrapHTML = unlines . tag . intersperse "<br>" . lines where + tag ss = "<html>":"<body>" : ss ++ ["</body>","</html>"] + +lexText :: String -> [String] +lexText s = case s of + c:cs | isPunct c -> [c] : lexText cs + c:cs | isSpace c -> lexText cs + _:_ -> let (w,cs) = break (\x -> isSpace x || isPunct x) s in w : lexText cs + _ -> [s] + +-- | Haskell lexer, usable for much code +lexCode :: String -> [String] +lexCode ss = case lex ss of + [(w@(_:_),ws)] -> w : lexCode ws + _ -> [] + +-- | LaTeX style lexer, with "math" environment using Code between $...$ +lexMixed :: String -> [String] +lexMixed = concat . alternate False where + alternate env s = case s of + _:_ -> case break (=='$') s of + (t,[]) -> lex env t : [] + (t,c:m) -> lex env t : [[c]] : alternate (not env) m + _ -> [] + lex env = if env then lexCode else lexText + +bindTok :: [String] -> String +bindTok ws = case ws of + w:"&+":ws2 -> w ++ bindTok ws2 + w:[] -> w + w:ws2 -> w ++ " " ++ bindTok ws2 + [] -> "" + +unlexText :: [String] -> String +unlexText s = case s of + w:[] -> w + w:[c]:[] | isPunct c -> w ++ [c] + w:[c]:cs | isPunct c -> w ++ [c] ++ " " ++ unlexText cs + w:ws -> w ++ " " ++ unlexText ws + _ -> [] + +unlexCode :: [String] -> String +unlexCode s = case s of + w:[] -> w + [c]:cs | isParen c -> [c] ++ unlexCode cs + w:cs@([c]:_) | isClosing c -> w ++ unlexCode cs + w:ws -> w ++ " " ++ unlexCode ws + _ -> [] + + +unlexMixed :: [String] -> String +unlexMixed = concat . alternate False where + alternate env s = case s of + _:_ -> case break (=="$") s of + (t,[]) -> unlex env t : [] + (t,c:m) -> unlex env t : sep env c : alternate (not env) m + _ -> [] + unlex env = if env then unlexCode else unlexText + sep env c = if env then c ++ " " else " " ++ c + +isPunct = flip elem ".?!,:;" +isParen = flip elem "()[]{}" +isClosing = flip elem ")]}" + + +-- might be in a file of its own: Windows Cyrillic, used in Bulgarian resource + +decodeCP1251 = map convert where + convert c + | c >= '\192' && c <= '\255' = chr (ord c + 848) + | otherwise = c + +encodeCP1251 = map convert where + convert c + | oc >= 1040 && oc <= 1103 = chr (oc - 848) + | otherwise = c + where oc = ord c + diff --git a/src/GF/Text/Transliterations.hs b/src/GF/Text/Transliterations.hs new file mode 100644 index 000000000..30c098df8 --- /dev/null +++ b/src/GF/Text/Transliterations.hs @@ -0,0 +1,97 @@ +module GF.Text.Transliterations (transliterate,transliteration,characterTable) where + +import GF.Text.UTF8 + +import Data.Char +import qualified Data.Map as Map + +-- transliterations between ASCII and a Unicode character set + +-- current transliterations: devanagari, thai + +-- to add a new one: define the Unicode range and the corresponding ASCII strings, +-- which may be one or two characters long + +-- conventions to be followed: +-- each character is either [letter] or [letter+nonletter] +-- when using a sparse range of unicodes, mark missing codes as "-" in transliterations +-- characters can be invisible: ignored in translation to unicode + +transliterate :: String -> Maybe (String -> String) +transliterate s = case s of + 'f':'r':'o':'m':'_':t -> fmap appTransFromUnicode $ transliteration t + 't':'o':'_':t -> fmap appTransToUnicode $ transliteration t + _ -> Nothing + +transliteration :: String -> Maybe Transliteration +transliteration s = case s of + "devanagari" -> Just transDevanagari + "thai" -> Just transThai + _ -> Nothing + +characterTable :: Transliteration -> String +characterTable = unlines . map prOne . Map.assocs . trans_from_unicode where + prOne (i,s) = unwords ["|", show i, "|", encodeUTF8 [toEnum i], "|", s, "|"] + +data Transliteration = Trans { + trans_to_unicode :: Map.Map String Int, + trans_from_unicode :: Map.Map Int String, + invisible_chars :: [String] + } + +appTransToUnicode :: Transliteration -> String -> String +appTransToUnicode trans = + concat . + map (\c -> maybe c (return . toEnum) $ + Map.lookup c (trans_to_unicode trans) + ) . + filter (flip notElem (invisible_chars trans)) . + unchar + +appTransFromUnicode :: Transliteration -> String -> String +appTransFromUnicode trans = + concat . + map (maybe "?" id . + flip Map.lookup (trans_from_unicode trans) + ) . + map fromEnum + + +mkTransliteration :: [String] -> [Int] -> Transliteration +mkTransliteration ts us = Trans (Map.fromList (tzip ts us)) (Map.fromList (uzip us ts)) [] + where + tzip ts us = [(t,u) | (t,u) <- zip ts us, t /= "-"] + uzip us ts = [(u,t) | (u,t) <- zip us ts, t /= "-"] + + +unchar :: String -> [String] +unchar s = case s of + c:d:cs + | isAlpha d -> [c] : unchar (d:cs) + | isSpace d -> [c]:[d]: unchar cs + | otherwise -> [c,d] : unchar cs + [_] -> [s] + _ -> [] + +transThai :: Transliteration +transThai = mkTransliteration allTrans allCodes where + allTrans = words $ + "- k k1 - k2 - k3 g c c1 c2 s' c3 y' d' t' " ++ + "t1 t2 t3 n' d t t4 t5 t6 n b p p1 f p2 f' " ++ + "p3 m y r - l - w s- s. s h l' O h' - " ++ + "a. a a: a+ i i: v v: u u: - - - - - - " ++ + "e e' o: a% a& L R S T1 T2 T3 T4 K - - - " ++ + "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 - - - - - - " + allCodes = [0x0e00 .. 0x0e7f] + +transDevanagari :: Transliteration +transDevanagari = (mkTransliteration allTrans allCodes){invisible_chars = ["a"]} where + allTrans = words $ + "M N - - " ++ + "a- A- i- I- u- U- R- - - - e- E- - - o- O- " ++ + "k K g G N: c C j J n: t. T. d. D. n. t " ++ + "T d D n - p P b B m y r - l - - v " ++ + "S s. s h - - r. - A i I u U R - - " ++ + "- e E o O " + allCodes = [0x0901 .. 0x094c] + diff --git a/src/GF/Text/UTF8.hs b/src/GF/Text/UTF8.hs new file mode 100644 index 000000000..5e9687684 --- /dev/null +++ b/src/GF/Text/UTF8.hs @@ -0,0 +1,48 @@ +---------------------------------------------------------------------- +-- | +-- Module : UTF8 +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/04/21 16:23:42 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.5 $ +-- +-- From the Char module supplied with HBC. +-- code by Thomas Hallgren (Jul 10 1999) +----------------------------------------------------------------------------- + +module GF.Text.UTF8 (decodeUTF8, encodeUTF8) where + +-- | Take a Unicode string and encode it as a string +-- with the UTF8 method. +decodeUTF8 :: String -> String +decodeUTF8 "" = "" +decodeUTF8 (c:cs) | c < '\x80' = c : decodeUTF8 cs +decodeUTF8 (c:c':cs) | '\xc0' <= c && c <= '\xdf' && + '\x80' <= c' && c' <= '\xbf' = + toEnum ((fromEnum c `mod` 0x20) * 0x40 + fromEnum c' `mod` 0x40) : decodeUTF8 cs +decodeUTF8 (c:c':c'':cs) | '\xe0' <= c && c <= '\xef' && + '\x80' <= c' && c' <= '\xbf' && + '\x80' <= c'' && c'' <= '\xbf' = + toEnum ((fromEnum c `mod` 0x10 * 0x1000) + (fromEnum c' `mod` 0x40) * 0x40 + fromEnum c'' `mod` 0x40) : decodeUTF8 cs +decodeUTF8 s = s ---- AR workaround 22/6/2006 +----decodeUTF8 _ = error "UniChar.decodeUTF8: bad data" + +encodeUTF8 :: String -> String +encodeUTF8 "" = "" +encodeUTF8 (c:cs) = + if c > '\x0000' && c < '\x0080' then + c : encodeUTF8 cs + else if c < toEnum 0x0800 then + let i = fromEnum c + in toEnum (0xc0 + i `div` 0x40) : + toEnum (0x80 + i `mod` 0x40) : + encodeUTF8 cs + else + let i = fromEnum c + in toEnum (0xe0 + i `div` 0x1000) : + toEnum (0x80 + (i `mod` 0x1000) `div` 0x40) : + toEnum (0x80 + i `mod` 0x40) : + encodeUTF8 cs |