diff --git a/AbsBNF.hs b/AbsBNF.hs deleted file mode 100644 --- a/AbsBNF.hs +++ /dev/null @@ -1,112 +0,0 @@ -module AbsBNF where - --- Haskell module generated by the BNF converter - -newtype Ident = Ident String deriving (Eq,Ord,Show) -data LGrammar = - LGr [LDef] - deriving (Eq,Ord,Show) - -data LDef = - DefAll Def - | DefSome [Ident] Def - | LDefView [Ident] - deriving (Eq,Ord,Show) - -data Grammar = - Grammar [Def] - deriving (Eq,Ord,Show) - -data Def = - Rule Label Cat [Item] - | Comment String - | Comments String String - | Internal Label Cat [Item] - | Token Ident Reg - | PosToken Ident Reg - | Entryp [Ident] - | Separator MinimumSize Cat String - | Terminator MinimumSize Cat String - | Coercions Ident Integer - | Rules Ident [RHS] - | Function Ident [Arg] Exp - | Layout [String] - | LayoutStop [String] - | LayoutTop - deriving (Eq,Ord,Show) - -data Item = - Terminal String - | NTerminal Cat - deriving (Eq,Ord,Show) - -data Cat = - ListCat Cat - | IdCat Ident - deriving (Eq,Ord,Show) - -data Label = - LabNoP LabelId - | LabP LabelId [ProfItem] - | LabPF LabelId LabelId [ProfItem] - | LabF LabelId LabelId - deriving (Eq,Ord,Show) - -data LabelId = - Id Ident - | Wild - | ListE - | ListCons - | ListOne - deriving (Eq,Ord,Show) - -data ProfItem = - ProfIt [IntList] [Integer] - deriving (Eq,Ord,Show) - -data IntList = - Ints [Integer] - deriving (Eq,Ord,Show) - -data Arg = - Arg Ident - deriving (Eq,Ord,Show) - -data Exp = - Cons Exp Exp - | App Ident [Exp] - | Var Ident - | LitInt Integer - | LitChar Char - | LitString String - | LitDouble Double - | List [Exp] - deriving (Eq,Ord,Show) - -data RHS = - RHS [Item] - deriving (Eq,Ord,Show) - -data MinimumSize = - MNonempty - | MEmpty - deriving (Eq,Ord,Show) - -data Reg = - RSeq Reg Reg - | RAlt Reg Reg - | RMinus Reg Reg - | RStar Reg - | RPlus Reg - | ROpt Reg - | REps - | RChar Char - | RAlts String - | RSeqs String - | RDigit - | RLetter - | RUpper - | RLower - | RAny - deriving (Eq,Ord,Show) - diff --git a/BNF.cf b/BNF.cf deleted file mode 100644 --- a/BNF.cf +++ /dev/null @@ -1,148 +0,0 @@ -{- - BNF Converter: Language definition - Copyright (C) 2004 Author: Markus Forberg, Michael Pellauer, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - --- A Grammar is a sequence of definitions - -LGr. LGrammar ::= [LDef] ; - -DefAll. LDef ::= Def ; -DefSome. LDef ::= [Ident] ":" Def ; -LDefView. LDef ::= "views" [Ident] ; - -separator LDef ";" ; - -Grammar . Grammar ::= [Def] ; - -separator Def ";" ; - -[] . [Item] ::= ; -(:) . [Item] ::= Item [Item] ; - ---The rules of the grammar -Rule . Def ::= Label "." Cat "::=" [Item] ; - --- Items -Terminal . Item ::= String ; -NTerminal . Item ::= Cat ; - --- Categories -ListCat . Cat ::= "[" Cat "]" ; -IdCat . Cat ::= Ident ; - --- labels with or without profiles -LabNoP . Label ::= LabelId ; -LabP . Label ::= LabelId [ProfItem] ; -LabPF . Label ::= LabelId LabelId [ProfItem] ; -LabF . Label ::= LabelId LabelId ; - --- functional labels -Id . LabelId ::= Ident ; -Wild . LabelId ::= "_" ; -ListE . LabelId ::= "[" "]" ; -ListCons . LabelId ::= "(" ":" ")" ; -ListOne . LabelId ::= "(" ":" "[" "]" ")" ; - --- profiles (= permutation and binding patterns) -ProfIt . ProfItem ::= "(" "[" [IntList] "]" "," "[" [Integer] "]" ")" ; - -Ints . IntList ::= "[" [Integer] "]" ; - -separator Integer "," ; -separator IntList "," ; -terminator nonempty ProfItem "" ; - --- Pragmas -Comment . Def ::= "comment" String ; -Comments . Def ::= "comment" String String ; -Internal . Def ::= "internal" Label "." Cat "::=" [Item] ; -Token. Def ::= "token" Ident Reg ; -PosToken. Def ::= "position" "token" Ident Reg ; -Entryp. Def ::= "entrypoints" [Ident] ; -Separator. Def ::= "separator" MinimumSize Cat String ; -Terminator. Def ::= "terminator" MinimumSize Cat String ; -Coercions. Def ::= "coercions" Ident Integer ; -Rules. Def ::= "rules" Ident "::=" [RHS] ; -Function. Def ::= "define" Ident [Arg] "=" Exp ; - -Layout. Def ::= "layout" [String] ; -LayoutStop. Def ::= "layout" "stop" [String] ; -LayoutTop. Def ::= "layout" "toplevel" ; - -Arg. Arg ::= Ident ; -separator Arg "" ; - --- Expressions -Cons. Exp ::= Exp1 ":" Exp ; -App. Exp1 ::= Ident [Exp2] ; -Var. Exp2 ::= Ident ; -LitInt. Exp2 ::= Integer ; -LitChar. Exp2 ::= Char ; -LitString. Exp2 ::= String ; -LitDouble. Exp2 ::= Double ; -List. Exp2 ::= "[" [Exp] "]" ; - - -coercions Exp 2; -separator nonempty Exp2 "" ; -separator Exp "," ; - -separator nonempty String "," ; - -separator nonempty RHS "|" ; -RHS. RHS ::= [Item] ; - --- List size condition -MNonempty. MinimumSize ::= "nonempty" ; -MEmpty. MinimumSize ::= ; - --- regular expressions -RSeq. Reg2 ::= Reg2 Reg3 ; -RAlt. Reg1 ::= Reg1 "|" Reg2 ; -RMinus. Reg1 ::= Reg2 "-" Reg2 ; - -RStar. Reg3 ::= Reg3 "*" ; -RPlus. Reg3 ::= Reg3 "+" ; -ROpt. Reg3 ::= Reg3 "?" ; - -REps. Reg3 ::= "eps" ; - -RChar. Reg3 ::= Char ; -- single character -RAlts. Reg3 ::= "[" String "]" ; -- list of alternative characters -RSeqs. Reg3 ::= "{" String "}" ; -- character sequence - -RDigit. Reg3 ::= "digit" ; -RLetter. Reg3 ::= "letter" ; -RUpper. Reg3 ::= "upper" ; -RLower. Reg3 ::= "lower" ; -RAny. Reg3 ::= "char" ; - -_. Reg ::= Reg1 ; -_. Reg1 ::= Reg2 ; -_. Reg2 ::= Reg3 ; -_. Reg3 ::= "(" Reg ")" ; - --- list of categories in the entrypoint pragma -(:[]). [Ident] ::= Ident ; -(:). [Ident] ::= Ident "," [Ident] ; - --- comments in BNF source -comment "--" ; -comment "{-" "-}" ; - - diff --git a/BNFC.cabal b/BNFC.cabal --- a/BNFC.cabal +++ b/BNFC.cabal @@ -1,17 +1,18 @@ Name: BNFC -Version: 2.4.2.1 -cabal-version: >= 1.2 +Version: 2.5.0 +cabal-version: >= 1.8 build-type: Simple category: Development -Copyright: (c) Krasimir Angelov, Bjorn Bringert, Johan Broberg, Paul Callaghan, Markus Forsberg, Ola Frid, Peter Gammie, Patrik Jansson, Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell, Michael Pellauer and Aarne Ranta 2002 - 2010. Free software under GNU General Public License (GPL). +Copyright: (c) Krasimir Angelov, Jean-Philippe Bernardy, Bjorn Bringert, Johan Broberg, Paul Callaghan, Markus Forsberg, Ola Frid, Peter Gammie, Patrik Jansson, Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell, Michael Pellauer and Aarne Ranta 2002 - 2012. Free software under GNU General Public License (GPL). License: GPL -License-File: COPYING -Maintainer: Markus Forsberg Aarne Ranta -Homepage: http://www.cse.chalmers.se/research/group/Language-technology/BNFC/ +License-File: LICENSE +Maintainer: bnfc-dev@googlegroups.com +Homepage: http://bnfc.digitalgrammars.com/ +bug-reports: https://github.com/BNFC/bnfc/issues Synopsis: A compiler front-end generator. Description: - The BNF Converter is a compiler construction tool generating a compiler front-end - from a Labelled BNF grammar. It was originally written to generate Haskell, + The BNF Converter is a compiler construction tool generating a compiler front-end + from a Labelled BNF grammar. It was originally written to generate Haskell, but starting from Version 2.0, it can also be used for generating Java, C++, and C. . Given a Labelled BNF grammar the tool produces: @@ -21,29 +22,39 @@ a Happy, CUP, or Bison parser generator file, a pretty-printer as a Haskell/Java/C++/C module, a Latex file containing a readable specification of the language. - . - This version only works with Alex version < 3, e.g. alex-2.3.5. -tested-with: GHC == 7.4.1 -Extra-source-files: BNF.cf +-- Includes some extra files in the distributed package +Extra-source-files: src/BNF.cf INSTALL Makefile + +Library + hs-source-dirs: runtime, src + Build-Depends: base>=4.4 && <5, array + exposed-modules: + Algebra.RingUtils + Data.Pair + Data.Matrix.Quad + Data.Matrix.Class + Parsing.Chart + Parsing.TestProgram + Executable bnfc - Build-Depends: mtl, directory, array, process, base>=4 && <5 --- haskell98, + Build-Depends: base>=4.4 && <5, mtl, directory, array, process, containers, pretty >=1.1 && <1.2, filepath Main-is: Main.hs - HS-source-dirs: . formats - formats/haskell2 - formats/haskell-gadt - formats/xml - formats/profile - formats/java - formats/java1.5 - formats/cpp - formats/c - formats/ocaml - formats/cpp_stl - formats/c-sharp - formats/f-sharp + HS-source-dirs: src src/formats + src/formats/haskell2 + src/formats/haskell-gadt + src/formats/xml + src/formats/profile + src/formats/java + src/formats/java1.5 + src/formats/cpp + src/formats/c + src/formats/ocaml + src/formats/cpp_stl + src/formats/c-sharp + src/formats/f-sharp Other-modules: + Paths_BNFC, LexBNF, ParBNF, AbsBNF, @@ -58,11 +69,15 @@ OOAbstract, CFtoLatex, CFtoXML, - CFtoTxt, + CFtoTxt, + Options, + ToCNF, + Common.Makefile -- Haskell HaskellTop, RegToAlex, CFtoTemplate, + CFtoAlex3, CFtoAlex2, CFtoAlex, CFtoHappy, @@ -71,6 +86,7 @@ CFtoLayout, MkErrM, MkSharedString, + HsOpts, -- Profile ProfileTop, CFtoHappyProfile, @@ -146,3 +162,101 @@ CFtoCup15, -- F-sharp FSharpTop + +Flag haskell-tests + Description: Enable/disable testing using the haskell backend + Default: True + +Test-suite system-tests-haskell + Type: exitcode-stdio-1.0 + Build-Depends: base>=4 && <5, + HUnit, test-framework, test-framework-hunit, + shelly, system-filepath, text + Main-is: system-tests-haskell.hs + HS-source-dirs: test/src + if flag(haskell-tests) + Buildable: True + else + Buildable: False + + +Flag java-tests + Description: Enable/disable testing using the java backend + Default: True + +Test-suite system-tests-java + Type: exitcode-stdio-1.0 + Build-Depends: base>=4 && <5, + HUnit, test-framework, test-framework-hunit, + shelly, system-filepath, text + Main-is: system-tests-java.hs + HS-source-dirs: test/src + if flag(java-tests) + Buildable: True + else + Buildable: False + +Flag c-tests + Description: Enable/disable testing using the C backend + Default: True + +Test-suite system-tests-c + Type: exitcode-stdio-1.0 + Build-Depends: base>=4 && <5, + HUnit, test-framework, test-framework-hunit, + shelly, system-filepath, text + Main-is: system-tests-c.hs + HS-source-dirs: test/src + if flag(c-tests) + Buildable: True + else + Buildable: False + +Flag cpp-tests + Description: Enable/disable testing using the C++ backend + Default: True + +Test-suite system-tests-cpp + Type: exitcode-stdio-1.0 + Build-Depends: base>=4 && <5, + HUnit, test-framework, test-framework-hunit, + shelly, system-filepath, text + Main-is: system-tests-cpp.hs + HS-source-dirs: test/src + if flag(cpp-tests) + Buildable: True + else + Buildable: False + +Test-suite system-tests-cpp-no-stl + Type: exitcode-stdio-1.0 + Build-Depends: base>=4 && <5, + HUnit, test-framework, test-framework-hunit, + shelly, system-filepath, text + Main-is: system-tests-cpp-no-stl.hs + HS-source-dirs: test/src + if flag(cpp-tests) + Buildable: True + else + Buildable: False + + +Test-suite unit-tests + Type: exitcode-stdio-1.0 + Build-Depends: base>=4 && <5, mtl, directory, array, process, filepath, + HUnit, test-framework, test-framework-hunit + Main-is: unit-tests.hs + HS-source-dirs: src test/src src/formats + src/formats/haskell2 + src/formats/haskell-gadt + src/formats/xml + src/formats/profile + src/formats/java + src/formats/java1.5 + src/formats/cpp + src/formats/c + src/formats/ocaml + src/formats/cpp_stl + src/formats/c-sharp + src/formats/f-sharp + diff --git a/CF.hs b/CF.hs deleted file mode 100644 --- a/CF.hs +++ /dev/null @@ -1,566 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -{- - BNF Converter: Abstract syntax - Copyright (C) 2004 Author: Markus Forberg, Michael Pellauer, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CF ( - -- Types. - CF, - Rule, - Pragma(..), - Exp(..), - Literal, - Symbol, - KeyWord, - Cat, - Fun, - Tree(..), - prTree, -- print an abstract syntax tree - Data, -- describes the abstract syntax of a grammar - cf2data, -- translates a grammar to a Data object. - cf2dataLists, -- translates to a Data with List categories included. - -- Literal categories, constants, - firstCat, -- the first value category in the grammar. - firstEntry, -- the first entry or the first value category - specialCats, -- ident - specialCatsP, -- all literals - specialData, -- special data - isCoercion, -- wildcards in grammar (avoid syntactic clutter) - isDefinedRule, -- defined rules (allows syntactic sugar) - isProperLabel, -- not coercion or defined rule - allCats, -- all categories of a grammar - allCatsIdNorm, - allEntryPoints, -- those categories that are entry points to the parser - reservedWords, -- get the keywords of a grammar. - symbols, -- get all symbols - literals, -- get all literals of a grammar. (e.g. String, Double) - reversibleCats, -- categories that is left-recursive transformable. - findAllReversibleCats, -- find all reversible categories - identCat, -- transforms '[C]' to ListC (others, unchanged). - valCat, -- The value category of a rule. - isParsable, -- Checks if the rule is parsable. - rulesOfCF, -- All rules of a grammar. - rulesForCat, -- rules for a given category - ruleGroups, -- Categories are grouped with their rules. - ruleGroupsInternals, --As above, but includes internal cats. - funRule, -- The function name of a rule. - notUniqueFuns, -- Returns a list of function labels that are not unique. - badInheritence, -- Returns a list of all function labels that can cause problems in languages with inheritence. - isList, -- Checks if a category is a list category. - -- Information functions for list functions. - isNilFun, -- empty list function? ([]) - isOneFun, -- one element list function? (:[]) - isConsFun, -- constructor function? (:) - isNilCons, -- either three of above? - isEmptyListCat, -- checks if the list permits [] - revSepListRule, -- reverse a rule, if it is of form C t [C]. - rhsRule, -- The list of Terminals/NonTerminals of a rule. - normCat, -- Removes precendence information. C1 => C, [C2] => [C] - normCatOfList, -- Removes precendence information and enclosed List. C1 => C, C2 => C - catOfList, -- Removes enclosed list: [C1] => C1 - comments, -- translates the pragmas into two list containing the s./m. comments - tokenPragmas, -- user-defined regular expression tokens - tokenNames, -- The names of all user-defined tokens - precCat, -- get the precendence level of a Cat C1 => 1, C => 0 - precLevels, -- get all precendence levels in the grammar, sorted in increasing order. - precRule, -- get the precendence level of the value category of a rule. - precCF, -- Check if the CF consists of precendence levels. - isUsedCat, - internalCat, -- the symbol # - isPositionCat, -- category that has a position in AST - hasIdent, - hasLayout, - layoutPragmas, - checkRule, - - CFP, -- CF with profiles - RuleP, - FunP, - Prof, - cf2cfpRule, - cf2cfp, - cfp2cf, - trivialProf, - rulesOfCFP, - funRuleP, ruleGroupsP, allCatsP, allEntryPointsP - ) where - -import Utils (prParenth,(+++)) -import Data.List (nub, intersperse, partition, sort,sort,group) -import Data.Char -import AbsBNF (Reg()) - --- A context free grammar consists of a set of rules and some extended --- information (e.g. pragmas, literals, symbols, keywords) -type CF = (Exts,[Rule]) - --- A rule consists of a function name, a main category and a sequence of --- terminals and non-terminals. --- function_name . Main_Cat ::= sequence -type Rule = (Fun, (Cat, [Either Cat String])) - --- polymorphic types for common type signatures for CF and CFP -type Rul f = (f, (Cat, [Either Cat String])) -type CFG f = (Exts,[Rul f]) - -type Exts = ([Pragma],Info) --- Info is information extracted from the CF, for easy access. --- Literals - Char, String, Ident, Integer, Double --- Strings are quoted strings, and Ident are unquoted. --- Symbols - symbols in the grammar, e.g. ´*´, '->'. --- KeyWord - reserved words, e.g. 'if' 'while' -type Info = ([Literal],[Symbol],[KeyWord],[Cat]) - --- Expressions for function definitions -data Exp = App String [Exp] - | LitInt Integer - | LitDouble Double - | LitChar Char - | LitString String - -instance Show Exp where - showsPrec p e = - case listView e of - Right es -> - showString "[" - . foldr (.) id (intersperse (showString ", ") $ map shows es) - . showString "]" - Left (App x []) -> showString x - Left (App "(:)" [e1,e2]) -> - showParen (p>0) - $ showsPrec 1 e1 - . showString " : " - . shows e2 - Left (App x es) -> - showParen (p>1) - $ foldr (.) id - $ intersperse (showString " ") - $ showString x : map (showsPrec 2) es - Left (LitInt n) -> shows n - Left (LitDouble x) -> shows x - Left (LitChar c) -> shows c - Left (LitString s) -> shows s - where - listView (App "[]" []) = Right [] - listView (App "(:)" [e1,e2]) - | Right es <- listView e2 = Right $ e1:es - listView e = Left e - --- pragmas for single line comments and for multiple-line comments. -data Pragma = CommentS String - | CommentM (String,String) - | TokenReg String Bool Reg - | EntryPoints [Cat] - | Layout [String] - | LayoutStop [String] - | LayoutTop - | FunDef String [String] Exp - -- ... - deriving (Show) - -tokenPragmas :: CFG f -> [(String,Reg)] -tokenPragmas cf = [(name,exp) | TokenReg name _ exp <- pragmasOfCF cf] - -tokenNames :: CF -> [String] -tokenNames cf = fst (unzip (tokenPragmas cf)) - -layoutPragmas :: CF -> (Bool,[String],[String]) -layoutPragmas cf = let ps = pragmasOfCF cf in ( - not (null [() | LayoutTop <- ps]), -- if there's layout betw top-level - concat [ss | Layout ss <- ps], -- layout-block starting words - concat [ss | LayoutStop ss <- ps] -- layout-block ending words - ) - -hasLayout :: CF -> Bool -hasLayout cf = case layoutPragmas cf of - (t,ws,_) -> t || not (null ws) -- (True,[],_) means: top-level layout only - --- Literal: Char, String, Ident, Integer, Double -type Literal = Cat -type Symbol = String -type KeyWord = String - --- Cat is the Non-terminals of the grammar. -type Cat = String --- Fun is the function name of a rule. -type Fun = String - -internalCat :: Cat -internalCat = "#" - --- Abstract syntax tree. -newtype Tree = Tree (Fun,[Tree]) - --- The abstract syntax of a grammar. -type Data = (Cat, [(Fun,[Cat])]) - --- firstCat returns the first Category appearing in the grammar. -firstCat :: CF -> Cat -firstCat = valCat . head . rulesOfCF - -firstEntry :: CF -> Cat -firstEntry cf = case allEntryPoints cf of - (x:_) -> x - _ -> firstCat cf - -rulesOfCF :: CF -> [Rule] -rulesOfCF = snd - -notUniqueFuns :: CF -> [Fun] -notUniqueFuns cf = let xss = group $ sort [ f | (f,_) <- rulesOfCF cf, - not (isNilCons f || isCoercion f)] - in [ head xs | xs <- xss, length xs > 1] - -badInheritence :: CF -> [Cat] -badInheritence cf = concatMap checkGroup (ruleGroups cf) - where - checkGroup (cat, rs) = if (length rs <= 1) - then [] - else case lookup cat rs of - Nothing -> [] - Just x -> [cat] - -infoOfCF :: CFG f -> Info -infoOfCF = snd . fst - -pragmasOfCF :: CFG f -> [Pragma] -pragmasOfCF = fst . fst - --- extract the comment pragmas. -commentPragmas :: [Pragma] -> [Pragma] -commentPragmas = filter isComment - where isComment (CommentS _) = True - isComment (CommentM _) = True - isComment _ = False - --- returns all normal rules that constructs the given Cat. -rulesForCat :: CF -> Cat -> [Rule] -rulesForCat cf cat = [normRuleFun r | r <- rulesOfCF cf, isParsable r, valCat r == cat] - ---This version doesn't exclude internal rules. -rulesForCat' :: CF -> Cat -> [Rule] -rulesForCat' cf cat = [normRuleFun r | r <- rulesOfCF cf, valCat r == cat] - -valCat :: Rul f -> Cat -valCat = fst . snd - --- Get all categories of a grammar. -allCats :: CF -> [Cat] -allCats = nub . map valCat . rulesOfCF -- no cats w/o production - --- Gets all normalized identified Categories -allCatsIdNorm :: CF -> [Cat] -allCatsIdNorm = nub . map identCat . map normCat . allCats - --- category is used on an rhs -isUsedCat :: CF -> Cat -> Bool -isUsedCat cf cat = elem cat [c | r <- (rulesOfCF cf), Left c <- rhsRule r] - --- entry points to parser ---- -allEntryPoints :: CF -> [Cat] -allEntryPoints cf = case concat [cats | EntryPoints cats <- pragmasOfCF cf] of - [] -> allCats cf - cs -> cs - --- group all categories with their rules. -ruleGroups :: CF -> [(Cat,[Rule])] -ruleGroups cf = [(c, rulesForCat cf c) | c <- allCats cf] - --- group all categories with their rules including internal rules. -ruleGroupsInternals :: CF -> [(Cat,[Rule])] -ruleGroupsInternals cf = [(c, rulesForCat' cf c) | c <- allCats cf] - -literals :: CFG f -> [Cat] -literals cf = lits ++ owns - where - (lits,_,_,_) = infoOfCF cf - owns = map fst $ tokenPragmas cf - -symbols :: CFG f -> [String] -symbols cf = syms - where (_,syms,_,_) = infoOfCF cf - -reservedWords :: CFG f -> [String] -reservedWords cf = sort keywords - where (_,_,keywords,_) = infoOfCF cf - -reversibleCats :: CFG f -> [Cat] -reversibleCats cf = cats - where (_,_,_,cats) = infoOfCF cf - --- Comments can be defined by the 'comment' pragma -comments :: CF -> ([(String,String)],[String]) -comments cf = case commentPragmas (pragmasOfCF cf) of - xs -> ([p | CommentM p <- xs], - [s | CommentS s <- xs]) - -funRule :: Rule -> Fun -funRule = fst - -rhsRule :: Rul f -> [Either Cat String] -rhsRule = snd . snd - --- built-in categories (corresponds to lexer) - --- if the gramamr uses the predefined Ident type -hasIdent :: CF -> Bool -hasIdent cf = isUsedCat cf "Ident" - --- these need new datatypes -specialCats :: CF -> [Cat] -specialCats cf = (if hasIdent cf then ("Ident":) else id) (map fst (tokenPragmas cf)) - --- the parser needs these -specialCatsP :: [Cat] -specialCatsP = words "Ident Integer String Char Double" - --- to print parse trees -prTree :: Tree -> String -prTree (Tree (fun,[])) = fun -prTree (Tree (fun,trees)) = fun +++ unwords (map pr2 trees) where - pr2 t@(Tree (_,ts)) = (if (null ts) then id else prParenth) (prTree t) - --- abstract syntax trees: data type definitions - -cf2data :: CF -> [Data] -cf2data cf = - [(cat, nub (map mkData [r | r@(f,_) <- rulesOfCF cf, - not (isDefinedRule f), - not (isCoercion f), eqCat cat (valCat r)])) - | cat <- allNormalCats cf] - where - mkData (f,(_,its)) = (normFun f,[normCat c | Left c <- its, c /= internalCat]) - ---This version includes lists in the returned data. ---Michael 4/03 -cf2dataLists :: CF -> [Data] -cf2dataLists cf = - [(cat, nub (map mkData [r | r@(f,_) <- rulesOfCF cf, - not (isDefinedRule f), - not (isCoercion f), eqCat cat (valCat r)])) - | cat <- (filter (\x -> not $ isDigit $ last x) (allCats cf))] - where - mkData (f,(_,its)) = (normFun f,[normCat c | Left c <- its, c /= internalCat]) - -specialData :: CF -> [Data] -specialData cf = [(c,[(c,[arg c])]) | c <- specialCats cf] where - arg c = case c of - _ -> "String" - -allNormalCats :: CF -> [Cat] -allNormalCats = filter isNormal . allCats - --- to deal with coercions - --- the Haskell convention: the wildcard _ is not a constructor - -isCoercion :: Fun -> Bool -isCoercion = (== "_") - -isDefinedRule :: Fun -> Bool -isDefinedRule (x:_) = isLower x - -isProperLabel :: Fun -> Bool -isProperLabel f = not (isCoercion f || isDefinedRule f) - --- categories C1, C2,... (one digit in end) are variants of C - -eqCat :: Cat -> Cat -> Bool -eqCat c c1 = catCat c == catCat c1 - -normCat :: Cat -> Cat -normCat c = case c of - '[':cs -> "[" ++ norm (init cs) ++ "]" - _ -> unList $ norm c -- to be deprecated - where - norm = reverse . dropWhile isDigit . reverse - -normCatOfList :: Cat -> Cat -normCatOfList = normCat . catOfList - --- for Happy and Latex --- When given a list Cat, i.e. '[C]', it removes the square brackets, --- and adds the prefix List, i.e. 'ListC'. -identCat :: Cat -> Cat -identCat c = case c of - '[':cs -> "List" ++ identCat (init cs) - _ -> c - -normFun :: Fun -> Fun -normFun = id -- takeWhile (not . isDigit) - -normRuleFun :: Rule -> Rule -normRuleFun (f,p) = (normFun f, p) - -isNormal :: Cat -> Bool -isNormal c = not (isList c || isDigit (last c)) - -isParsable :: Rul f -> Bool -isParsable (_,(_, Left "#":_)) = False -isParsable _ = True - -isList :: Cat -> Bool -isList c = head c == '[' - -unList :: Cat -> Cat -unList c = c - -catOfList :: Cat -> Cat -catOfList c = case c of - '[':_:_ -> init (tail c) - _ -> c - -isNilFun, isOneFun, isConsFun, isNilCons :: Fun -> Bool -isNilCons f = isNilFun f || isOneFun f || isConsFun f -isNilFun f = f == "[]" -isOneFun f = f == "(:[])" -isConsFun f = f == "(:)" - -isEmptyListCat :: CF -> Cat -> Bool -isEmptyListCat cf c = elem "[]" $ map fst $ rulesForCat' cf c - -isNonterm = either (const True) (const False) - --- used in Happy to parse lists of form 'C t [C]' in reverse order --- applies only if the [] rule has no terminals -revSepListRule :: Rul f -> Rul f -revSepListRule r@(f,(c, ts)) = (f, (c, xs : x : sep)) where - (x,sep,xs) = (head ts, init (tail ts), last ts) --- invariant: test in findAllReversibleCats have been performed - -findAllReversibleCats :: CF -> [Cat] -findAllReversibleCats cf = [c | (c,r) <- ruleGroups cf, isRev c r] where - isRev c rs = case rs of - [r1,r2] | isList c -> if isConsFun (funRule r2) - then tryRev r2 r1 - else if isConsFun (funRule r1) - then tryRev r1 r2 - else False - _ -> False - tryRev (f,(_,ts@(x:_:xs))) r = isEmptyNilRule r && - isConsFun f && isNonterm x && isNonterm (last ts) - tryRev _ _ = False - -isEmptyNilRule (f,(_,ts)) = isNilFun f && null ts - -precCat :: Cat -> Int -precCat = snd . analyseCat - -precRule :: Rule -> Int -precRule = precCat . valCat - -precLevels :: CF -> [Int] -precLevels cf = sort $ nub $ [ precCat c | c <- allCats cf] - -precCF :: CF -> Bool -precCF cf = length (precLevels cf) > 1 - -catCat :: Cat -> Cat -catCat = fst . analyseCat - -analyseCat :: Cat -> (Cat,Int) -analyseCat c = if (isList c) then list c else noList c - where - list cat = let (rc,n) = noList (init (tail cat)) in ("[" ++ rc ++ "]",n) - noList cat = case span isDigit (reverse cat) of - ([],c') -> (reverse c', 0) - (d,c') -> (reverse c', read (reverse d)) - --- we should actually check that --- (1) coercions are always between variants --- (2) no other digits are used - -checkRule :: CF -> RuleP -> Either RuleP String -checkRule cf r@((f,_),(cat,rhs)) - | badCoercion = Right $ "Bad coercion in rule" +++ s - | badNil = Right $ "Bad empty list rule" +++ s - | badOne = Right $ "Bad one-element list rule" +++ s - | badCons = Right $ "Bad list construction rule" +++ s - | badList = Right $ "Bad list formation rule" +++ s - | badSpecial = Right $ "Bad special category rule" +++ s - | badTypeName = Right $ "Bad type name" +++ unwords badtypes +++ "in" +++ s - | badFunName = Right $ "Bad constructor name" +++ f +++ "in" +++ s - | badMissing = Right $ "No production for" +++ unwords missing ++ - ", appearing in rule" +++ s - | otherwise = Left r - where - s = f ++ "." +++ cat +++ "::=" +++ unwords (map (either id show) rhs) --- - c = normCat cat - cs = [normCat c | Left c <- rhs] - badCoercion = isCoercion f && not ([c] == cs) - badNil = isNilFun f && not (isList c && null cs) - badOne = isOneFun f && not (isList c && cs == [catOfList c]) - badCons = isConsFun f && not (isList c && cs == [catOfList c, c]) - badList = isList c && - not (isCoercion f || isNilFun f || isOneFun f || isConsFun f) - badSpecial = elem c specialCatsP && not (isCoercion f) - - badMissing = not (null missing) - missing = filter nodef [c | Left c <- rhs] - nodef t = notElem t defineds - defineds = - "#" : map fst (tokenPragmas cf) ++ specialCatsP ++ map valCat (rulesOfCF cf) - badTypeName = not (null badtypes) - badtypes = filter isBadType $ cat : [c | Left c <- rhs] - isBadType c = not (isUpper (head c) || isList c || c == "#") - badFunName = not (all (\c -> isAlphaNum c || c == '_') f {-isUpper (head f)-} - || isCoercion f || isNilFun f || isOneFun f || isConsFun f) - -isPositionCat :: CFG f -> Cat -> Bool -isPositionCat cf cat = or [b | TokenReg name b _ <- pragmasOfCF cf, name == cat] - - --- grammar with permutation profile à la GF. AR 22/9/2004 - -type CFP = (Exts,[RuleP]) -type FunP = (Fun,Prof) -type RuleP = (FunP, (Cat, [Either Cat String])) - -type Prof = (Fun, [([[Int]],[Int])]) -- the original function name, profile - -cf2cfp :: CF -> CFP -cf2cfp (es,rs) = (es, map cf2cfpRule rs) - -cf2cfpRule :: Rule -> RuleP -cf2cfpRule (f,(c,its)) = ((f, (f, trivialProf its)),(c,its)) - -cfp2cf :: CFP -> CF -cfp2cf (es,rs) = (es,[(f,(c,its)) | ((f,_),(c,its)) <- rs]) - -trivialProf :: [Either Cat String] -> [([[Int]],[Int])] -trivialProf its = [([],[i]) | (i,_) <- zip [0..] [c | Left c <- its]] - -rulesOfCFP :: CFP -> [RuleP] -rulesOfCFP = snd - -funRuleP :: RuleP -> Fun -funRuleP = fst . snd . fst - -ruleGroupsP :: CFP -> [(Cat,[RuleP])] -ruleGroupsP cf = [(c, rulesForCatP cf c) | c <- allCatsP cf] - -rulesForCatP :: CFP -> Cat -> [RuleP] -rulesForCatP cf cat = [r | r <- rulesOfCFP cf, isParsable r, valCat r == cat] - -allCatsP :: CFP -> [Cat] -allCatsP = nub . map valCat . rulesOfCFP -- no cats w/o production - -allEntryPointsP :: CFP -> [Cat] -allEntryPointsP cf = case concat [cats | EntryPoints cats <- pragmasOfCF cf] of - [] -> allCatsP cf - cs -> cs diff --git a/COPYING b/COPYING deleted file mode 100644 --- a/COPYING +++ /dev/null @@ -1,340 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) year name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - , 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. diff --git a/ErrM.hs b/ErrM.hs deleted file mode 100644 --- a/ErrM.hs +++ /dev/null @@ -1,26 +0,0 @@ --- BNF Converter: Error Monad --- Copyright (C) 2004 Author: Aarne Ranta - --- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE. -module 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/GetCF.hs b/GetCF.hs deleted file mode 100644 --- a/GetCF.hs +++ /dev/null @@ -1,242 +0,0 @@ -{- - BNF Converter: Abstract syntax - Copyright (C) 2004 Author: Markus Forsberg, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - - -module GetCF where - -import System.Directory ( doesFileExist, renameFile ) -import Control.Monad ( when ) - -import CF -import Utils -import ParBNF -import Data.List(nub,partition) -import qualified AbsBNF as Abs --- import LexBNF -import ErrM -import Data.Char -import TypeChecker - -readCF :: FilePath -> IO CF -readCF f = tryReadCF f >>= return . fst - -tryReadCF :: FilePath -> IO (CF,Bool) -tryReadCF file = do - (cfp,m) <- tryReadCFP file - return (cfp2cf cfp, m) - -tryReadCFP :: FilePath -> IO (CFP,Bool) -tryReadCFP file = do - putStrLn $ "\nReading grammar from " ++ file - s <- readFile file - let (cfp,msg') = getCFP s - cf = cfp2cf cfp - msg = case checkDefinitions cf of - Bad err -> msg' ++ [err] - Ok () -> msg' - ret = cfp - if not (null msg) then do - putStrLn $ unlines msg - return (ret,False) - else do - putStrLn $ show (length (rulesOfCF cf)) +++ "rules accepted\n" - - let c3s = [(b,e) | (b,e) <- fst (comments cf), length b > 2 || length e > 2] - if null c3s then return () else do - putStrLn - "Warning: comment delimiters longer than 2 characters ignored in Haskell:" - mapM_ putStrLn [b +++ "-" +++ e | (b,e) <- c3s] - case filter (not . isDefinedRule) $ notUniqueFuns cf of - [] -> case (badInheritence cf) of - [] -> return (ret,True) - xs -> do - putStrLn "Warning :" - putStrLn $ " Bad Label name in Category(s) :" ++ unwords xs - putStrLn $ " These categories have more than one Label, yet one of these" - putStrLn $ " Labels has the same name as the Category. This will almost" - putStrLn $ " certainly cause problems in languages other than Haskell.\n" - return (ret,True) - xs -> do - putStrLn $ "Warning :" - putStrLn $ " Non-unique label name(s) : " ++ unwords xs - putStrLn $ " There may be problems with the pretty-printer.\n" - case (badInheritence cf) of - [] -> return (ret,True) - xs -> do - putStrLn $ "Warning :" - putStrLn $ " Bad Label name in Category(s) :" ++ unwords xs - putStrLn $ " These categories have more than one Label, yet one of these" - putStrLn $ " Labels has the same name as the Category. This will almost" - putStrLn $ " certainly cause problems in languages other than Haskell.\n" - return (ret,True) - - --- peteg: FIXME this is racey. --- want to be a bit smarter about whether we actually generate the file --- or save it... e.g. ErrM.hs need not be regenerated if it exists. -writeFileRep :: FilePath -> String -> IO () -writeFileRep f s = - do exists <- doesFileExist f - backedUp <- if exists - then do let fbak = f ++ ".bak" - renameFile f fbak - return $ " (saving old file as " ++ fbak ++ ")" - else return "" - putStrLn $ "writing file " ++ f ++ backedUp - writeFile f s - -getCF :: String -> (CF, [String]) -getCF s = let (cfp,msg) = getCFP s in (cfp2cf cfp, msg) - -getCFP :: String -> (CFP, [String]) -getCFP s = (cf,msgs ++ msgs1) where - (cf,msgs1) = ((exts,ruls2),msgs2) - (ruls2,msgs2) = untag $ partition (isRule) $ map (checkRule cf00) $ rulesOfCFP cf0 - untag (ls,rs) = ([c | Left c <- ls], [c | Right c <- rs]) - isRule = either (const True) (const False) - cf00 = cfp2cf cf0 - (cf0@(exts,_),msgs) = (revs . srt . conv . pGrammar . myLexer) s - srt rs = let rules = [r | Left (Right r) <- rs] - literals = nub [lit | xs <- map (snd . snd) rules, - (Left lit) <- xs, - elem lit specialCatsP] - pragma = [r | Left (Left r) <- rs] - errors = [s | Right s <- rs, not (null s)] - (symbols,keywords) = partition notIdent reservedWords - notIdent s = null s || not (isAlpha (head s)) || any (not . isIdentRest) s - isIdentRest c = isAlphaNum c || c == '_' || c == '\'' - reservedWords = nub [t | (_,(_,its)) <- rules, Right t <- its] - cats = [] - in (((pragma,(literals,symbols,keywords,cats)),rules),errors) - revs (cf@((pragma,(literals,symbols,keywords,_)),rules),errors) = - (((pragma, - (literals,symbols,keywords,findAllReversibleCats (cfp2cf cf))),rules),errors) - -conv :: Err Abs.Grammar -> [Either (Either Pragma RuleP) String] -conv (Bad s) = [Right s] -conv (Ok (Abs.Grammar defs)) = map Left $ concatMap transDef defs - -transDef :: Abs.Def -> [Either Pragma RuleP] -transDef x = case x of - Abs.Rule label cat items -> - [Right (transLabel label,(transCat cat,map transItem items))] - Abs.Comment str -> [Left $ CommentS str] - Abs.Comments str0 str -> [Left $ CommentM (str0,str)] - Abs.Token ident reg -> [Left $ TokenReg (transIdent ident) False reg] - Abs.PosToken ident reg -> [Left $ TokenReg (transIdent ident) True reg] - Abs.Entryp idents -> [Left $ EntryPoints (map transIdent idents)] - Abs.Internal label cat items -> - [Right (transLabel label,(transCat cat,(Left "#":(map transItem items))))] - Abs.Separator size ident str -> map (Right . cf2cfpRule) $ separatorRules size ident str - Abs.Terminator size ident str -> map (Right . cf2cfpRule) $ terminatorRules size ident str - Abs.Coercions ident int -> map (Right . cf2cfpRule) $ coercionRules ident int - Abs.Rules ident strs -> map (Right . cf2cfpRule) $ ebnfRules ident strs - Abs.Layout ss -> [Left $ Layout ss] - Abs.LayoutStop ss -> [Left $ LayoutStop ss] - Abs.LayoutTop -> [Left $ LayoutTop] - Abs.Function f xs e -> [Left $ FunDef (transIdent f) (map transArg xs) (transExp e)] - -separatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [Rule] -separatorRules size c s = if null s then terminatorRules size c s else ifEmpty [ - ("(:[])", (cs,[Left c'])), - ("(:)", (cs,[Left c', Right s, Left cs])) - ] - where - c' = transCat c - cs = "[" ++ c' ++ "]" - ifEmpty rs = if (size == Abs.MNonempty) then rs else (("[]", (cs,[])) : rs) - -terminatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [Rule] -terminatorRules size c s = [ - ifEmpty, - ("(:)", (cs,Left c' : s' [Left cs])) - ] - where - c' = transCat c - cs = "[" ++ c' ++ "]" - s' its = if null s then its else (Right s : its) - ifEmpty = if (size == Abs.MNonempty) - then ("(:[])",(cs,[Left c'] ++ if null s then [] else [Right s])) - else ("[]", (cs,[])) - -coercionRules :: Abs.Ident -> Integer -> [Rule] -coercionRules (Abs.Ident c) n = - ("_", (c, [Left (c ++ "1")])) : - [("_", (c ++ show (i-1), [Left (c ++ show i)])) | i <- [2..n]] ++ - [("_", (c ++ show n, [Right "(", Left c, Right ")"]))] - -ebnfRules :: Abs.Ident -> [Abs.RHS] -> [Rule] -ebnfRules (Abs.Ident c) rhss = - [(mkFun k c its, (c, map transItem its)) | (k, Abs.RHS its) <- zip [1 :: Int ..] rhss] - where - mkFun k c i = case i of - [Abs.Terminal s] -> c' ++ "_" ++ mkName k s - [Abs.NTerminal n] -> c' ++ identCat (transCat n) - _ -> c' ++ "_" ++ show k - c' = c --- normCat c - mkName k s = if all (\c -> isAlphaNum c || elem c "_'") s - then s else show k - -transItem :: Abs.Item -> Either Cat String -transItem x = case x of - Abs.Terminal str -> Right str - Abs.NTerminal cat -> Left (transCat cat) - -transCat :: Abs.Cat -> Cat -transCat x = case x of - Abs.ListCat cat -> "[" ++ (transCat cat) ++ "]" - Abs.IdCat id -> transIdent id - -transLabel :: Abs.Label -> (Fun,Prof) -transLabel y = case y of - Abs.LabNoP f -> let g = transLabelId f in (g,(g,[])) ---- should be Nothing - Abs.LabP f p -> let g = transLabelId f in (g,(g, map transProf p)) - Abs.LabPF f g p -> (transLabelId f,(transLabelId g, map transProf p)) - Abs.LabF f g -> (transLabelId f,(transLabelId g, [])) - where - transLabelId x = case x of - Abs.Id id -> transIdent id - Abs.Wild -> "_" - Abs.ListE -> "[]" - Abs.ListCons -> "(:)" - Abs.ListOne -> "(:[])" - transProf (Abs.ProfIt bss as) = - ([map fromInteger bs | Abs.Ints bs <- bss], map fromInteger as) - -transIdent :: Abs.Ident -> String -transIdent x = case x of - Abs.Ident str -> str - -transArg :: Abs.Arg -> String -transArg (Abs.Arg x) = transIdent x - -transExp :: Abs.Exp -> Exp -transExp e = case e of - Abs.App x es -> App (transIdent x) (map transExp es) - Abs.Var x -> App (transIdent x) [] - Abs.Cons e1 e2 -> cons e1 (transExp e2) - Abs.List es -> foldr cons nil es - Abs.LitInt x -> LitInt x - Abs.LitDouble x -> LitDouble x - Abs.LitChar x -> LitChar x - Abs.LitString x -> LitString x - where - cons e1 e2 = App "(:)" [transExp e1, e2] - nil = App "[]" [] - diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -0,0 +1,9 @@ +# Installing using cabal + + cabal install + +# Installing using the makefile + + make + make install + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/LexBNF.x b/LexBNF.x deleted file mode 100644 --- a/LexBNF.x +++ /dev/null @@ -1,134 +0,0 @@ --- -*- haskell -*- --- This Alex file was machine-generated by the BNF converter -{ -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module LexBNF 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 - \: | \; | \. | \: \: \= | \[ | \] | \_ | \( | \) | \, | \= | \| | \- | \* | \+ | \? | \{ | \} - -:- -"--" [.]* ; -- Toss single line comments -"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; - -$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)) } -\' ($u # [\' \\] | \\ [\\ \' n t]) \' { tok (\p s -> PT p (TC $ share 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 "lower" (b "entrypoints" (b "comment" (b "coercions" (b "char" N N) N) (b "digit" (b "define" N N) N)) (b "layout" (b "internal" (b "eps" N N) N) (b "letter" N N))) (b "terminator" (b "rules" (b "position" (b "nonempty" N N) N) (b "stop" (b "separator" N N) N)) (b "upper" (b "toplevel" (b "token" N N) N) (b "views" 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/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,205 +0,0 @@ -{- - BNF Converter: Main file - Copyright (C) 2002-2010 Authors: - Björn Bringert, Johan Broberg, Markus Forberg, Peter Gammie, - Patrik Jansson, Antti-Juhani Kaijanaho, Ulf Norell, - Michael Pellauer, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - - -module Main where - --- import Utils --- import CF -import HaskellTop -import HaskellTopGADT -import ProfileTop -import JavaTop -import JavaTop15 -import CPPTop -import CSharpTop -import STLTop -import CTop -import OCamlTop -import FSharpTop -import CFtoXML -import Utils - -import MultiView (preprocessMCF, mkTestMulti, mkMakefileMulti) - -import System.IO -import System.Cmd -import System.Exit -import System.Environment -import Data.Char -import Data.List (elemIndex) - -version = "2.4.2.1" - -title = unlines [ - "The BNF Converter, "++version, - "(c) Krasimir Angelov, Bjorn Bringert, Johan Broberg, Paul Callaghan, ", - " Markus Forsberg, Ola Frid, Peter Gammie, Patrik Jansson, ", - " Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell, ", - " Michael Pellauer and Aarne Ranta 2002 - 2010.", - "Free software under GNU General Public License (GPL).", - "Bug reports to {markus,aarne}@cs.chalmers.se." - ] - -main :: IO () -main = do - xx <- getArgs - - case xx of - ["--numeric-version"] -> do - putStrLn version - exitSuccess - [] -> printUsage - _ | elem "-multi" xx -> do - putStrLn "preprocessing multilingual BNF" - let file = last xx - (files,entryp) <- preprocessMCF file - mapM_ mkOne [init xx ++ [f] | f <- files] - mkTestMulti entryp xx file files - mkMakefileMulti xx file files - _ -> mkOne xx - -mkOne :: [String] -> IO () -mkOne xx = do - let args = (map (filter (not . isSpace)) xx) - let file = last args - let name = takeWhile (/= '.') $ basename file - let make = elem "-m" args - let multi = elem "-multi" args - let c = elem "-c" args - let cpp = elem "-cpp" args - let cpp_stl = elem "-cpp_stl" args - let csharp = elem "-csharp" args - let java = elem "-java" args - let java15 = elem "-java1.5" args - let ocaml = elem "-ocaml" args - let fsharp = elem "-fsharp" args - let haskell = elem "-haskell" args - let haskellGADT = elem "-gadt" args - let profile = elem "-prof" args - let alex1 = "-alex1" `elem` args - alex2 = "-alex2" `elem` args - alex1or2 = alex1 - alex2StringSharing = elem "-sharestrings" args - alex2ByteString = elem "-bytestrings" args - glr = "-glr" `elem` args - let xml = if elem "-xml" args then 1 else - if elem "-xmlt" args then 2 else 0 - let inDir = elem "-d" args - let vsfiles = elem "-vs" args - let wcfSupport = elem "-wcf" args - let linenumbers = elem "-l" args -- for C++ STL target - inPackage <- case elemIndex "-p" args of - Nothing -> return Nothing - Just i | i < length args - 1 -> return (Just (args!!(i+1))) - _ -> do - putStrLn "-p option requires an argument" - printUsage - if checkUsage False [c, cpp, cpp_stl, csharp, java, haskell, profile] then - do - if (isCF (reverse file)) then - do - putStrLn title - case () of - _ | c -> makeC make name file - _ | cpp -> makeCPP make name file - _ | cpp_stl-> makeSTL make linenumbers inPackage name file - _ | csharp -> makeCSharp make vsfiles wcfSupport inPackage file - _ | java -> makeJava make name file - _ | java15 -> makeJava15 make inPackage name file - _ | ocaml -> makeOCaml make alex1or2 inDir alex2StringSharing glr xml inPackage name file - _ | fsharp -> makeFSharp make alex1or2 inDir alex2StringSharing glr xml inPackage name file - _ | profile-> makeAllProfile make alex1or2 False xml name file - _ | haskellGADT -> makeAllGADT make alex1or2 inDir alex2StringSharing alex2ByteString glr xml inPackage name file - _ -> makeAll make alex1or2 inDir alex2StringSharing alex2ByteString glr xml inPackage name multi file - if (make && multi) - then (system ("cp Makefile Makefile_" ++ name)) >> return () - else return () - else endFileErr - else endLanguageErr - where isCF ('f':'c':'.':_) = True - isCF _ = False - endFileErr = do - putStr title - putStrLn "Error: the input file must end with .cf" - exitFailure - endLanguageErr = do - putStr title - putStrLn "Error: only one language mode may be chosen" - exitFailure - -printUsage = do - putStrLn title - putStrLn "Usage: bnfc * ? * file.cf" - putStrLn "" - putStrLn "Version options:" - putStrLn " --numeric-version Print just the version number" - putStrLn "" - putStrLn "Make option:" - putStrLn " -m generate Makefile" - putStrLn "" - putStrLn "Languages (Only one language mode may be selected.)" - putStrLn " -java Output Java code for use with JLex and CUP" - putStrLn " -java1.5 Output Java 1.5 code for use with JLex and CUP" - putStrLn " -c Output C code for use with FLex and Bison" - putStrLn " -cpp Output C++ code for use with FLex and Bison" - putStrLn " -cpp_stl Output C++ code for use with FLex and Bison" - putStrLn " and the Standard Template Library" - putStrLn " -csharp Output C# code for use with GPLEX and GPPG" - putStrLn " -ocaml Output OCaml code for use with ocamllex and ocamlyacc" - putStrLn " -fsharp Output F# code for use with fslex and fsyacc" - putStrLn " -haskell Output Haskell code for use with Alex and Happy (default)" - putStrLn " -prof Output Haskell code for rules with permutation profiles" - putStrLn " -gadt Output Haskell code which uses GADTs" - putStrLn "" - putStrLn "Special options for the Haskell back-end:" - putStrLn " -d Put Haskell code in modules Lang.* instead of Lang*" - putStrLn " -p Prepend to the Haskell module names." - putStrLn " Dots in the module name create hierarchical modules." - putStrLn " -alex1 Use Alex 1.1 as Haskell lexer tool" - putStrLn " -alex2 Use Alex 2 as Haskell lexer tool (default)" - putStrLn " -sharestrings Use string sharing in Alex 2 lexer" - putStrLn " -bytestrings Use byte string in Alex 2 lexer" - putStrLn " -glr Output Happy GLR parser" - putStrLn " -xml Also generate a DTD and an XML printer" - putStrLn " -xmlt DTD and an XML printer, another encoding" - putStrLn "" - putStrLn "Special options for the C++ STL back-end:" - putStrLn " -l Add and set line_number field for all syntax classes" - putStrLn " -p Use as the C++ namespace" - putStrLn "" - putStrLn "Special options for the Java 1.5 back-end:" - putStrLn " -p Prepend to the Java package name" - putStrLn "" - putStrLn "Special options for the C# backend:" - putStrLn " -p Use as the C# namespace" - putStrLn " -vs Generate Visual Studio solution/project files" - putStrLn " -wcf Add support for Windows Communication Foundation, by" - putStrLn " marking abstract syntax classes as DataContracts" - exitFailure --- putStrLn " : -gf write GF files" - - -checkUsage _ [] = True -checkUsage True (True:xs) = False -checkUsage False (True:xs) = checkUsage True xs -checkUsage old (x:xs) = checkUsage old xs diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,53 @@ +CABALVERSION:=$(shell grep -Po "(?<=^Version: ).*" BNFC.cabal) +VERSION:=$(CABALVERSION) +RELEASEDIR=dist/releases/$(VERSION) +MACBUILDER=grammaticalframework.org + +all: build + +build: + cabal configure && cabal build + +install: + cabal install + +clean: + cabal clean + +.PHONY: all build install clean + +release: $(RELEASEDIR)/bnfc-$(VERSION).tar.gz \ + $(RELEASEDIR)/bnfc-$(VERSION)-mac.gz + +# Commane line aliases +release-source: $(RELEASEDIR)/bnfc-$(VERSION).tar.gz +release-linux: $(RELEASEDIR)/bnfc-$(VERSION)-linux.gz +release-mac: $(RELEASEDIR)/bnfc-$(VERSION)-mac.gz +release-win: $(RELEASEDIR)/bnfc-$(VERSION)-win.exe +.PHONY: release release-source release-linux release-mac release-win + +$(RELEASEDIR): + mkdir -p $@ + +$(RELEASEDIR)/bnfc-$(VERSION).tar.gz: | $(RELEASEDIR) + cabal configure + cabal sdist + mv dist/BNFC-$(CABALVERSION).tar.gz $@ + +$(RELEASEDIR)/bnfc-$(VERSION)-linux.gz: $(RELEASEDIR)/bnfc-$(VERSION).tar.gz + $(eval TMPDIR=$(shell mktemp -d)) + $(eval CURDIR=$(shell pwd)) + tar xf $< -C $(TMPDIR) + ls $(TMPDIR) + rm -rf $(TMPDIR) + +$(RELEASEDIR)/bnfc-$(VERSION)-mac.gz: $(RELEASEDIR)/bnfc-$(VERSION).tar.gz + scp $< $(MACBUILDER): + ssh $(MACBUILDER) "\ + [ -d 'BNFC-$(CABALVERSION)' ] && rm -rf 'BNFC-$(CABALVERSION)'; \ + tar xf bnfc-$(VERSION).tar.gz; \ + cd BNFC-$(CABALVERSION); \ + cabal configure && cabal build; \ + gzip -c dist/build/bnfc/bnfc > ../bnfc-$(VERSION)-mac.gz" + scp $(MACBUILDER):bnfc-$(VERSION)-mac.gz $@ + diff --git a/MultiView.hs b/MultiView.hs deleted file mode 100644 --- a/MultiView.hs +++ /dev/null @@ -1,137 +0,0 @@ -{- - BNF Converter: Abstract syntax - Copyright (C) 2004 Author: Markus Forsberg, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - - -module MultiView where - -import System.Directory ( doesFileExist, renameFile ) - -import qualified CF as CF -import Utils -import ParBNF -import PrintBNF -import Data.List(nub,partition) -import AbsBNF --- import LexBNF -import ErrM -import Data.Char -import TypeChecker - -preprocessMCF :: FilePath -> IO ([FilePath],String) -preprocessMCF f = do - s <- readFile f - gr <- case pLGrammar $ myLexer s of - Ok g -> return g - Bad s -> error s - let name = takeWhile (/='.') f - let grs = extract name gr - let entryp = entrypoint gr - mapM_ writeCF grs - return $ (map fst grs,entryp) - -extract :: String -> LGrammar -> [(FilePath, Grammar)] -extract name (LGr ldefs) = - [(file lang,Grammar [unldef ldef | ldef <- ldefs, isFor lang ldef]) | - lang <- views] - where - views = [lang | LDefView langs <- ldefs, Ident lang <- langs] - isFor lang ldef = case ldef of - DefAll _ -> True - DefSome ids _ -> elem (Ident lang) ids - _ -> False - unldef ldef = case ldef of - DefAll d -> d - DefSome _ d -> d - file lang = name ++ "_" ++ lang ++ ".cf" - ---- the entrypoint is the same for all languages - could be different - -entrypoint :: LGrammar -> String -entrypoint (LGr rs0) = head $ - [c | Entryp (Ident c:_) <- rs] ++ - [c | Rule _ (IdCat (Ident c)) _ <- rs] - where - rs = concatMap getR rs0 - getR d = case d of - DefAll d -> [d] - DefSome _ d -> [d] - _ -> [] --- LDefView - -writeCF :: (FilePath, Grammar) -> IO () -writeCF (file,gr) = do - writeFile file $ printTree gr - putStrLn $ "wrote file " ++ file - ----- These are Haskell specific; ----- should be generalized by inspecting the options xx - -mkTestMulti :: String -> [String] -> FilePath -> [FilePath] -> IO () -mkTestMulti cat xx file files = do - let abs = takeWhile (/='.') file - let cncs = map (takeWhile (/='.')) files - let content = testfile cat xx abs cncs - writeFile ("TestTrans" ++ abs ++ ".hs") content - -mkMakefileMulti :: [String] -> FilePath -> [FilePath] -> IO () -mkMakefileMulti xx file files = do - let abs = takeWhile (/='.') file - let cncs = map (takeWhile (/='.')) files - let content = makefile xx abs cncs - writeFile "Makefile" content - -makefile xx abs cncs = unlines $ - "all:" : - ["\tmake -f Makefile_" ++ cnc | cnc <- cncs] ++ - ["\tghc --make -o TestTrans" ++ abs ++ " TestTrans" ++ abs, - "" - ] - -testfile cat xx abs cncs = unlines $ - ["module Main where"] ++ - ["import qualified Lex" ++ cnc | cnc <- cncs] ++ - ["import qualified Par" ++ cnc | cnc <- cncs] ++ - ["import qualified Print" ++ cnc | cnc <- cncs] ++ - ["import Abs" ++ abs, - "import ErrM", - "import System.IO (getArgs)", - "", - "main :: IO ()", - "main = do", - " i:o:f:_ <- getArgs", - " s <- readFile f", - " case parse i s of", - " Ok t -> putStrLn $ prin o t", - " Bad s -> error s", - "", - "parse i = case i of" - ] ++ - [ - " " ++ sho cnc ++ " -> Par" ++ cnc ++ ".p" ++ cat ++ - " . Par" ++ cnc ++ ".myLexer" | cnc <- cncs - ] ++ - [ - "", - "prin o = case o of" - ] ++ - [ - " " ++ sho cnc ++ " -> Print" ++ cnc ++ - ".printTree" | cnc <- cncs - ] - where - sho = show . tail . dropWhile (/='_') diff --git a/ParBNF.hs b/ParBNF.hs deleted file mode 100644 --- a/ParBNF.hs +++ /dev/null @@ -1,1658 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} -module ParBNF where -import AbsBNF -import LexBNF -import ErrM -import Data.Array -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif - --- parser produced by Happy Version 1.15 - -newtype HappyAbsSyn = HappyAbsSyn (() -> ()) -happyIn35 :: (String) -> (HappyAbsSyn ) -happyIn35 x = unsafeCoerce# x -{-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn ) -> (String) -happyOut35 x = unsafeCoerce# x -{-# INLINE happyOut35 #-} -happyIn36 :: (Ident) -> (HappyAbsSyn ) -happyIn36 x = unsafeCoerce# x -{-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn ) -> (Ident) -happyOut36 x = unsafeCoerce# x -{-# INLINE happyOut36 #-} -happyIn37 :: (Integer) -> (HappyAbsSyn ) -happyIn37 x = unsafeCoerce# x -{-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn ) -> (Integer) -happyOut37 x = unsafeCoerce# x -{-# INLINE happyOut37 #-} -happyIn38 :: (Char) -> (HappyAbsSyn ) -happyIn38 x = unsafeCoerce# x -{-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn ) -> (Char) -happyOut38 x = unsafeCoerce# x -{-# INLINE happyOut38 #-} -happyIn39 :: (Double) -> (HappyAbsSyn ) -happyIn39 x = unsafeCoerce# x -{-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn ) -> (Double) -happyOut39 x = unsafeCoerce# x -{-# INLINE happyOut39 #-} -happyIn40 :: (LGrammar) -> (HappyAbsSyn ) -happyIn40 x = unsafeCoerce# x -{-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn ) -> (LGrammar) -happyOut40 x = unsafeCoerce# x -{-# INLINE happyOut40 #-} -happyIn41 :: (LDef) -> (HappyAbsSyn ) -happyIn41 x = unsafeCoerce# x -{-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn ) -> (LDef) -happyOut41 x = unsafeCoerce# x -{-# INLINE happyOut41 #-} -happyIn42 :: ([LDef]) -> (HappyAbsSyn ) -happyIn42 x = unsafeCoerce# x -{-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn ) -> ([LDef]) -happyOut42 x = unsafeCoerce# x -{-# INLINE happyOut42 #-} -happyIn43 :: (Grammar) -> (HappyAbsSyn ) -happyIn43 x = unsafeCoerce# x -{-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn ) -> (Grammar) -happyOut43 x = unsafeCoerce# x -{-# INLINE happyOut43 #-} -happyIn44 :: ([Def]) -> (HappyAbsSyn ) -happyIn44 x = unsafeCoerce# x -{-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn ) -> ([Def]) -happyOut44 x = unsafeCoerce# x -{-# INLINE happyOut44 #-} -happyIn45 :: ([Item]) -> (HappyAbsSyn ) -happyIn45 x = unsafeCoerce# x -{-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn ) -> ([Item]) -happyOut45 x = unsafeCoerce# x -{-# INLINE happyOut45 #-} -happyIn46 :: (Def) -> (HappyAbsSyn ) -happyIn46 x = unsafeCoerce# x -{-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn ) -> (Def) -happyOut46 x = unsafeCoerce# x -{-# INLINE happyOut46 #-} -happyIn47 :: (Item) -> (HappyAbsSyn ) -happyIn47 x = unsafeCoerce# x -{-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn ) -> (Item) -happyOut47 x = unsafeCoerce# x -{-# INLINE happyOut47 #-} -happyIn48 :: (Cat) -> (HappyAbsSyn ) -happyIn48 x = unsafeCoerce# x -{-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn ) -> (Cat) -happyOut48 x = unsafeCoerce# x -{-# INLINE happyOut48 #-} -happyIn49 :: (Label) -> (HappyAbsSyn ) -happyIn49 x = unsafeCoerce# x -{-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn ) -> (Label) -happyOut49 x = unsafeCoerce# x -{-# INLINE happyOut49 #-} -happyIn50 :: (LabelId) -> (HappyAbsSyn ) -happyIn50 x = unsafeCoerce# x -{-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn ) -> (LabelId) -happyOut50 x = unsafeCoerce# x -{-# INLINE happyOut50 #-} -happyIn51 :: (ProfItem) -> (HappyAbsSyn ) -happyIn51 x = unsafeCoerce# x -{-# INLINE happyIn51 #-} -happyOut51 :: (HappyAbsSyn ) -> (ProfItem) -happyOut51 x = unsafeCoerce# x -{-# INLINE happyOut51 #-} -happyIn52 :: (IntList) -> (HappyAbsSyn ) -happyIn52 x = unsafeCoerce# x -{-# INLINE happyIn52 #-} -happyOut52 :: (HappyAbsSyn ) -> (IntList) -happyOut52 x = unsafeCoerce# x -{-# INLINE happyOut52 #-} -happyIn53 :: ([Integer]) -> (HappyAbsSyn ) -happyIn53 x = unsafeCoerce# x -{-# INLINE happyIn53 #-} -happyOut53 :: (HappyAbsSyn ) -> ([Integer]) -happyOut53 x = unsafeCoerce# x -{-# INLINE happyOut53 #-} -happyIn54 :: ([IntList]) -> (HappyAbsSyn ) -happyIn54 x = unsafeCoerce# x -{-# INLINE happyIn54 #-} -happyOut54 :: (HappyAbsSyn ) -> ([IntList]) -happyOut54 x = unsafeCoerce# x -{-# INLINE happyOut54 #-} -happyIn55 :: ([ProfItem]) -> (HappyAbsSyn ) -happyIn55 x = unsafeCoerce# x -{-# INLINE happyIn55 #-} -happyOut55 :: (HappyAbsSyn ) -> ([ProfItem]) -happyOut55 x = unsafeCoerce# x -{-# INLINE happyOut55 #-} -happyIn56 :: (Arg) -> (HappyAbsSyn ) -happyIn56 x = unsafeCoerce# x -{-# INLINE happyIn56 #-} -happyOut56 :: (HappyAbsSyn ) -> (Arg) -happyOut56 x = unsafeCoerce# x -{-# INLINE happyOut56 #-} -happyIn57 :: ([Arg]) -> (HappyAbsSyn ) -happyIn57 x = unsafeCoerce# x -{-# INLINE happyIn57 #-} -happyOut57 :: (HappyAbsSyn ) -> ([Arg]) -happyOut57 x = unsafeCoerce# x -{-# INLINE happyOut57 #-} -happyIn58 :: (Exp) -> (HappyAbsSyn ) -happyIn58 x = unsafeCoerce# x -{-# INLINE happyIn58 #-} -happyOut58 :: (HappyAbsSyn ) -> (Exp) -happyOut58 x = unsafeCoerce# x -{-# INLINE happyOut58 #-} -happyIn59 :: (Exp) -> (HappyAbsSyn ) -happyIn59 x = unsafeCoerce# x -{-# INLINE happyIn59 #-} -happyOut59 :: (HappyAbsSyn ) -> (Exp) -happyOut59 x = unsafeCoerce# x -{-# INLINE happyOut59 #-} -happyIn60 :: (Exp) -> (HappyAbsSyn ) -happyIn60 x = unsafeCoerce# x -{-# INLINE happyIn60 #-} -happyOut60 :: (HappyAbsSyn ) -> (Exp) -happyOut60 x = unsafeCoerce# x -{-# INLINE happyOut60 #-} -happyIn61 :: ([Exp]) -> (HappyAbsSyn ) -happyIn61 x = unsafeCoerce# x -{-# INLINE happyIn61 #-} -happyOut61 :: (HappyAbsSyn ) -> ([Exp]) -happyOut61 x = unsafeCoerce# x -{-# INLINE happyOut61 #-} -happyIn62 :: ([Exp]) -> (HappyAbsSyn ) -happyIn62 x = unsafeCoerce# x -{-# INLINE happyIn62 #-} -happyOut62 :: (HappyAbsSyn ) -> ([Exp]) -happyOut62 x = unsafeCoerce# x -{-# INLINE happyOut62 #-} -happyIn63 :: ([String]) -> (HappyAbsSyn ) -happyIn63 x = unsafeCoerce# x -{-# INLINE happyIn63 #-} -happyOut63 :: (HappyAbsSyn ) -> ([String]) -happyOut63 x = unsafeCoerce# x -{-# INLINE happyOut63 #-} -happyIn64 :: ([RHS]) -> (HappyAbsSyn ) -happyIn64 x = unsafeCoerce# x -{-# INLINE happyIn64 #-} -happyOut64 :: (HappyAbsSyn ) -> ([RHS]) -happyOut64 x = unsafeCoerce# x -{-# INLINE happyOut64 #-} -happyIn65 :: (RHS) -> (HappyAbsSyn ) -happyIn65 x = unsafeCoerce# x -{-# INLINE happyIn65 #-} -happyOut65 :: (HappyAbsSyn ) -> (RHS) -happyOut65 x = unsafeCoerce# x -{-# INLINE happyOut65 #-} -happyIn66 :: (MinimumSize) -> (HappyAbsSyn ) -happyIn66 x = unsafeCoerce# x -{-# INLINE happyIn66 #-} -happyOut66 :: (HappyAbsSyn ) -> (MinimumSize) -happyOut66 x = unsafeCoerce# x -{-# INLINE happyOut66 #-} -happyIn67 :: (Reg) -> (HappyAbsSyn ) -happyIn67 x = unsafeCoerce# x -{-# INLINE happyIn67 #-} -happyOut67 :: (HappyAbsSyn ) -> (Reg) -happyOut67 x = unsafeCoerce# x -{-# INLINE happyOut67 #-} -happyIn68 :: (Reg) -> (HappyAbsSyn ) -happyIn68 x = unsafeCoerce# x -{-# INLINE happyIn68 #-} -happyOut68 :: (HappyAbsSyn ) -> (Reg) -happyOut68 x = unsafeCoerce# x -{-# INLINE happyOut68 #-} -happyIn69 :: (Reg) -> (HappyAbsSyn ) -happyIn69 x = unsafeCoerce# x -{-# INLINE happyIn69 #-} -happyOut69 :: (HappyAbsSyn ) -> (Reg) -happyOut69 x = unsafeCoerce# x -{-# INLINE happyOut69 #-} -happyIn70 :: (Reg) -> (HappyAbsSyn ) -happyIn70 x = unsafeCoerce# x -{-# INLINE happyIn70 #-} -happyOut70 :: (HappyAbsSyn ) -> (Reg) -happyOut70 x = unsafeCoerce# x -{-# INLINE happyOut70 #-} -happyIn71 :: ([Ident]) -> (HappyAbsSyn ) -happyIn71 x = unsafeCoerce# x -{-# INLINE happyIn71 #-} -happyOut71 :: (HappyAbsSyn ) -> ([Ident]) -happyOut71 x = unsafeCoerce# x -{-# INLINE happyOut71 #-} -happyInTok :: Token -> (HappyAbsSyn ) -happyInTok x = unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> Token -happyOutTok x = unsafeCoerce# x -{-# INLINE happyOutTok #-} - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x4c\x00\x4c\x00\x4c\x00\x6f\x00\x6f\x00\x00\x00\x6f\x00\x0d\x00\x11\x00\x73\x00\x73\x00\xcf\x01\xcc\x01\xc7\x01\xcb\x01\xca\x01\xc9\x01\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\xc8\x01\x00\x00\x00\x00\xc6\x01\x33\x00\x33\x00\x33\x00\x33\x00\xc5\x01\xc2\x01\x00\x00\xc4\x01\xc1\x01\x00\x00\x00\x00\x2c\x00\xc0\x01\x86\x01\xb8\x01\xba\x01\x33\x00\xba\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x14\x00\xfc\xff\xb2\x01\x00\x00\x0d\x00\xb2\x01\xb2\x01\xbe\x01\xbf\x01\xaf\x01\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\xbc\x01\xc3\x01\x00\x00\xae\x01\x04\x00\x04\x00\x00\x00\x00\x00\x00\x00\x04\x00\xae\x01\xae\x01\xae\x01\xae\x01\xab\x00\x00\x00\xae\x01\xbb\x01\xad\x01\xbd\x01\xb7\x01\xab\x01\xa9\x01\xb1\x01\xa8\x01\xa8\x01\xa8\x01\x00\x00\xa8\x01\xb9\x01\x00\x00\xb6\x01\xa7\x01\x53\x00\x00\x00\xa7\x01\x11\x00\x00\x00\xa7\x01\x00\x00\xa7\x01\xb5\x01\xa6\x01\xa5\x01\x9f\x01\x9f\x01\x09\x00\x69\x01\x95\x01\x9e\x01\xa0\x01\xa0\x01\x94\x01\xfd\xff\x92\x01\xb4\x01\x8e\x01\x00\x00\x17\x00\xb3\x01\x8c\x01\x00\x00\xb0\x01\x8b\x01\x80\x01\x80\x01\x00\x00\x00\x00\x6f\x00\x4c\x00\x8a\x01\x6f\x00\x00\x00\x33\x00\x11\x00\x11\x00\xac\x01\x89\x01\x00\x00\x87\x01\x00\x00\xaa\x01\x00\x00\x00\x00\x84\x01\x7f\x01\x11\x00\xa4\x01\xa3\x01\x00\x00\x88\x01\x66\x01\x00\x00\x7d\x01\xa2\x01\xa1\x01\xa1\x01\x00\x00\x00\x00\x00\x00\x9c\x01\x9d\x01\x04\x00\x04\x00\x00\x00\x7c\x01\x00\x00\x86\x01\x33\x00\x00\x00\x00\x00\x00\x00\x90\x01\x96\x01\x9b\x01\x33\x00\x33\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x01\x00\x00\x00\x00\x00\x00\x98\x01\x00\x00\x00\x00\x00\x00\x99\x01\x00\x00\x00\x00\xfa\xff\x11\x00\x00\x00\x33\x00\x00\x00\x74\x01\x74\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x01\x04\x00\x00\x00\x91\x01\x8f\x01\x93\x01\x00\x00\x0d\x00\x00\x00\x00\x00\x0d\x00\x6d\x01\x8d\x01\x6c\x01\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x90\x00\xb6\x00\xa7\x00\x5f\x01\x6f\x01\x62\x01\x56\x01\x83\x01\x85\x01\x73\x01\x4d\x00\x41\x01\x3a\x01\xf0\x00\x79\x01\x52\x01\x64\x00\x34\x01\x36\x01\x3b\x01\x40\x01\x0d\x01\xe8\x00\x7d\x00\x3f\x01\x1e\x00\x0e\x01\xbb\x00\x60\x00\x83\x00\xb5\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x2c\x01\xb0\x00\x23\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x7b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x1c\x01\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x14\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x01\x00\x00\x00\x00\x78\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\xfd\x00\xf3\x00\x1a\x00\x71\x01\x56\x00\x00\x00\xf2\x00\xbd\x00\xa4\x00\xc1\x00\x7b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x01\x9c\x00\x05\x00\x68\x01\x00\x00\xac\x00\x4b\x01\x24\x01\x00\x00\xaf\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x96\x00\x7f\x00\x8a\x00\xf7\x00\x00\x00\xf7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\xa8\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x01\xde\x00\x00\x00\x41\x00\x3d\x01\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x99\x00\x00\x00\xa6\x00\x28\x01\x1d\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x01\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x01\x00\x00\xfe\xff\x7b\x01\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xd6\xff\x00\x00\xd6\xff\xd2\xff\xd2\xff\xcf\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\xff\xac\xff\x00\x00\x00\x00\xa6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x97\xff\x00\x00\xcf\xff\xcf\xff\x8e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\xff\x7a\xff\x00\x00\xde\xff\x84\xff\x89\xff\x7b\xff\x8c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xff\x81\xff\x85\xff\x80\xff\x7e\xff\x7f\xff\xdc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8f\xff\x90\xff\x00\x00\x00\x00\x92\xff\x94\xff\x00\x00\x9d\xff\xa0\xff\x9f\xff\x9e\xff\x9c\xff\x96\xff\xa3\xff\xa1\xff\x00\x00\x97\xff\x00\x00\xdd\xff\xdb\xff\xa0\xff\x99\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\xff\x00\x00\xa9\xff\x00\x00\x00\x00\xab\xff\x00\x00\xaf\xff\xae\xff\x00\x00\x00\x00\x00\x00\xb6\xff\x00\x00\x00\x00\xb5\xff\x00\x00\x00\x00\xba\xff\xbb\xff\x00\x00\x00\x00\xbe\xff\x00\x00\xbd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\xff\x8e\xff\x00\x00\x00\x00\x00\x00\xd1\xff\x00\x00\xd3\xff\x7a\xff\xd5\xff\x00\x00\xd9\xff\x00\x00\x00\x00\x00\x00\x00\x00\xda\xff\xd7\xff\x00\x00\xd6\xff\x00\x00\xd2\xff\xce\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\xff\x00\x00\xbf\xff\x00\x00\xc7\xff\xa6\xff\xcc\xff\x00\x00\x00\x00\x00\x00\xb7\xff\xb9\xff\x00\x00\x00\x00\xb4\xff\xaf\xff\x00\x00\xac\xff\xac\xff\xa8\xff\xa5\xff\x98\xff\x00\x00\x00\x00\x00\x00\x97\xff\xa2\xff\x00\x00\xcf\xff\x8d\xff\x00\x00\x88\xff\x87\xff\x86\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8a\xff\x83\xff\x7c\xff\x82\xff\x8b\xff\x91\xff\x93\xff\x95\xff\xa4\xff\x9b\xff\x9a\xff\x00\x00\xaa\xff\xb0\xff\xad\xff\x00\x00\xb3\xff\xb8\xff\xbc\xff\x00\x00\xc4\xff\xcb\xff\x00\x00\x00\x00\xc0\xff\x00\x00\xcf\xff\x00\x00\x00\x00\xc9\xff\xd0\xff\x79\xff\xd4\xff\xd8\xff\xc5\xff\xc6\xff\xc3\xff\xc8\xff\x00\x00\x00\x00\xcf\xff\x00\x00\x00\x00\x00\x00\xb2\xff\xcd\xff\xc2\xff\xcf\xff\xca\xff\xaf\xff\x00\x00\x00\x00\xb1\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x05\x00\x05\x00\x01\x00\x08\x00\x0b\x00\x01\x00\x10\x00\x0a\x00\x05\x00\x00\x00\x14\x00\x08\x00\x11\x00\x05\x00\x13\x00\x07\x00\x08\x00\x05\x00\x17\x00\x01\x00\x19\x00\x05\x00\x15\x00\x1c\x00\x1d\x00\x03\x00\x01\x00\x05\x00\x00\x00\x07\x00\x08\x00\x0c\x00\x0a\x00\x26\x00\x29\x00\x01\x00\x28\x00\x29\x00\x2b\x00\x0a\x00\x24\x00\x2e\x00\x2e\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x05\x00\x29\x00\x0a\x00\x08\x00\x28\x00\x29\x00\x24\x00\x05\x00\x0d\x00\x29\x00\x08\x00\x1e\x00\x11\x00\x24\x00\x13\x00\x29\x00\x00\x00\x2e\x00\x17\x00\x11\x00\x19\x00\x13\x00\x24\x00\x1c\x00\x1d\x00\x17\x00\x11\x00\x19\x00\x13\x00\x01\x00\x1c\x00\x1d\x00\x05\x00\x26\x00\x07\x00\x08\x00\x00\x00\x00\x00\x2b\x00\x05\x00\x26\x00\x07\x00\x08\x00\x0f\x00\x1c\x00\x2b\x00\x03\x00\x14\x00\x15\x00\x16\x00\x03\x00\x18\x00\x01\x00\x1a\x00\x1b\x00\x0e\x00\x0f\x00\x10\x00\x1f\x00\x20\x00\x21\x00\x03\x00\x23\x00\x24\x00\x1c\x00\x1c\x00\x27\x00\x05\x00\x29\x00\x07\x00\x08\x00\x05\x00\x15\x00\x07\x00\x08\x00\x29\x00\x00\x00\x22\x00\x00\x00\x20\x00\x21\x00\x22\x00\x14\x00\x15\x00\x16\x00\x03\x00\x18\x00\x2e\x00\x1a\x00\x1b\x00\x20\x00\x02\x00\x22\x00\x1f\x00\x20\x00\x21\x00\x01\x00\x23\x00\x24\x00\x02\x00\x05\x00\x06\x00\x07\x00\x29\x00\x1c\x00\x01\x00\x0b\x00\x29\x00\x01\x00\x0e\x00\x0f\x00\x03\x00\x02\x00\x06\x00\x07\x00\x12\x00\x22\x00\x0d\x00\x0b\x00\x01\x00\x03\x00\x0e\x00\x0f\x00\x16\x00\x06\x00\x07\x00\x03\x00\x01\x00\x12\x00\x0b\x00\x03\x00\x24\x00\x0e\x00\x0f\x00\x01\x00\x03\x00\x11\x00\x02\x00\x13\x00\x06\x00\x20\x00\x03\x00\x22\x00\x24\x00\x0b\x00\x01\x00\x1f\x00\x0e\x00\x0f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x12\x00\x24\x00\x20\x00\x21\x00\x22\x00\x23\x00\x20\x00\x21\x00\x22\x00\x23\x00\x29\x00\x20\x00\x21\x00\x22\x00\x23\x00\x2e\x00\x24\x00\x20\x00\x1f\x00\x22\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x02\x00\x01\x00\x01\x00\x17\x00\x18\x00\x19\x00\x01\x00\x1b\x00\x17\x00\x18\x00\x19\x00\x00\x00\x1b\x00\x17\x00\x18\x00\x19\x00\x12\x00\x1b\x00\x0d\x00\x01\x00\x19\x00\x1a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x19\x00\x1a\x00\x00\x00\x10\x00\x01\x00\x19\x00\x1a\x00\x14\x00\x17\x00\x18\x00\x19\x00\x00\x00\x1f\x00\x17\x00\x18\x00\x19\x00\x0d\x00\x0a\x00\x17\x00\x18\x00\x19\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x1d\x00\x1e\x00\x0a\x00\x01\x00\x0a\x00\x16\x00\x11\x00\x01\x00\x17\x00\x18\x00\x19\x00\x01\x00\x10\x00\x0b\x00\x18\x00\x19\x00\x0e\x00\x0f\x00\x01\x00\x0d\x00\x19\x00\x1d\x00\x1e\x00\x1d\x00\x1e\x00\x0f\x00\x10\x00\x01\x00\x0b\x00\x10\x00\x14\x00\x0e\x00\x0f\x00\x14\x00\x08\x00\x09\x00\x01\x00\x0b\x00\x05\x00\x0a\x00\x0e\x00\x0f\x00\x09\x00\x01\x00\x09\x00\x01\x00\x0b\x00\x01\x00\x09\x00\x0e\x00\x0f\x00\x09\x00\x01\x00\x0b\x00\x00\x00\x01\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x00\x00\x01\x00\x0d\x00\x01\x00\x0c\x00\x0d\x00\x01\x00\x11\x00\x22\x00\x13\x00\x05\x00\x25\x00\x0c\x00\x0d\x00\x28\x00\x0d\x00\x06\x00\x0e\x00\x0f\x00\x10\x00\x2a\x00\x05\x00\x0a\x00\x09\x00\x04\x00\x28\x00\x04\x00\x06\x00\x09\x00\x06\x00\x06\x00\x12\x00\x06\x00\x28\x00\x09\x00\x05\x00\x2a\x00\x06\x00\x2a\x00\x06\x00\x08\x00\x28\x00\x03\x00\x2e\x00\x28\x00\x04\x00\x01\x00\x29\x00\x29\x00\x29\x00\x02\x00\x02\x00\x01\x00\x03\x00\x24\x00\x2e\x00\x0a\x00\x2e\x00\x29\x00\x1e\x00\x06\x00\x2e\x00\x0a\x00\x05\x00\x08\x00\x01\x00\xff\xff\x0a\x00\x29\x00\x29\x00\x0a\x00\x0c\x00\xff\xff\x0c\x00\x28\x00\x0a\x00\x29\x00\x05\x00\x05\x00\x08\x00\x2a\x00\xff\xff\x2e\x00\x2e\x00\x08\x00\xff\xff\x2e\x00\xff\xff\x2e\x00\x2e\x00\x2e\x00\xff\xff\xff\xff\x2e\x00\xff\xff\x28\x00\xff\xff\x1e\x00\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\x29\x00\x2e\x00\x28\x00\x2a\x00\x29\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"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x2b\x00\x69\x00\x53\x00\x2c\x00\xe0\x00\x22\x00\x55\x00\xe8\x00\x49\x00\xda\x00\xc9\x00\x4a\x00\x2d\x00\x62\x00\x2e\x00\x63\x00\x64\x00\x69\x00\x2f\x00\x22\x00\x30\x00\x69\x00\xa6\x00\x31\x00\x32\x00\xb6\xff\x22\x00\xb6\xff\xdb\x00\xb6\xff\xb6\xff\xb1\x00\x8b\x00\x33\x00\x25\x00\x22\x00\x22\x00\x25\x00\x34\x00\x39\x00\xd7\x00\xff\xff\xff\xff\x22\x00\x25\x00\x4b\x00\x34\x00\x4c\x00\x2b\x00\x25\x00\xe5\x00\x2c\x00\x22\x00\x25\x00\x87\x00\x2b\x00\xb8\x00\x25\x00\x2c\x00\x3a\x00\x2d\x00\x96\x00\x2e\x00\xb6\xff\x3d\x00\xff\xff\x2f\x00\x2d\x00\x30\x00\x2e\x00\x23\x00\x31\x00\x32\x00\x2f\x00\x58\x00\x30\x00\xc3\x00\x5f\x00\x31\x00\x32\x00\x62\x00\x33\x00\x63\x00\x64\x00\x3d\x00\x3d\x00\x34\x00\x62\x00\x33\x00\x63\x00\x9f\x00\x60\x00\xbe\x00\x34\x00\x25\x00\x6f\x00\x70\x00\x71\x00\x25\x00\x72\x00\x53\x00\x73\x00\x74\x00\xb2\x00\xb3\x00\xb4\x00\x75\x00\x76\x00\x77\x00\x25\x00\x78\x00\x79\x00\xd0\x00\x92\x00\x84\x00\x62\x00\x25\x00\x63\x00\x64\x00\x62\x00\x54\x00\x63\x00\x64\x00\x25\x00\x3d\x00\xaf\x00\xcd\x00\x26\x00\x35\x00\x28\x00\x6f\x00\x70\x00\x71\x00\x25\x00\x72\x00\xff\xff\x73\x00\x74\x00\xb8\x00\xcc\x00\x28\x00\x75\x00\x76\x00\x77\x00\x7e\x00\x78\x00\x79\x00\x5b\x00\x85\x00\x7f\x00\x86\x00\x25\x00\x3e\x00\x66\x00\x81\x00\x25\x00\x7e\x00\x6d\x00\x65\x00\x25\x00\x5b\x00\x7f\x00\xd8\x00\xea\x00\x34\x00\xde\x00\x81\x00\x7e\x00\x25\x00\x6d\x00\x65\x00\xce\x00\x7f\x00\x80\x00\x25\x00\xd1\x00\xc6\x00\x81\x00\x25\x00\x82\x00\x6d\x00\x65\x00\x7e\x00\x25\x00\x58\x00\x5b\x00\xc4\x00\x84\x00\xbc\x00\x25\x00\x28\x00\x82\x00\x81\x00\x8d\x00\x8e\x00\x6d\x00\x65\x00\x26\x00\x27\x00\x28\x00\xdd\x00\xa2\x00\x82\x00\x26\x00\x27\x00\x28\x00\xd5\x00\x26\x00\x27\x00\x28\x00\xb5\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\x82\x00\x36\x00\x8f\x00\x28\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x3f\x00\x4c\x00\x41\x00\x42\x00\x43\x00\x5b\x00\x90\x00\x97\x00\x44\x00\x45\x00\x46\x00\x66\x00\xbf\x00\x44\x00\x45\x00\x46\x00\x98\x00\xa9\x00\x44\x00\x45\x00\x46\x00\x5c\x00\x47\x00\xcb\x00\x99\x00\x4d\x00\xa7\x00\x3f\x00\x4c\x00\x41\x00\x42\x00\x43\x00\x3f\x00\x4c\x00\x41\x00\x42\x00\x43\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x4d\x00\xac\x00\xb4\x00\x55\x00\x66\x00\x4d\x00\x4e\x00\xa5\x00\xe6\x00\x45\x00\x46\x00\xb6\x00\x37\x00\xc0\x00\x45\x00\x46\x00\xd3\x00\x39\x00\xa8\x00\x45\x00\x46\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x3f\x00\x4c\x00\x41\x00\x42\x00\x43\x00\xdc\x00\x3c\x00\x39\x00\x5f\x00\x39\x00\x52\x00\x5d\x00\x66\x00\x51\x00\x45\x00\x46\x00\x5f\x00\x5e\x00\xd9\x00\x50\x00\x46\x00\x6d\x00\x65\x00\x5f\x00\xd4\x00\x4f\x00\xbd\x00\x3c\x00\x3b\x00\x3c\x00\x9c\x00\x55\x00\x5f\x00\x6c\x00\x55\x00\x9d\x00\x6d\x00\x65\x00\x56\x00\x7c\x00\x7d\x00\x5f\x00\x7b\x00\xc8\x00\x79\x00\x6d\x00\x65\x00\xc9\x00\x5f\x00\xd6\x00\x5f\x00\x7b\x00\x5f\x00\xed\x00\x6d\x00\x65\x00\x7a\x00\x66\x00\x7b\x00\x69\x00\x66\x00\x6d\x00\x65\x00\x95\x00\x65\x00\x64\x00\x65\x00\x69\x00\x66\x00\x9b\x00\x66\x00\x8c\x00\x6b\x00\xa0\x00\x58\x00\x94\x00\x59\x00\xa5\x00\x95\x00\x6a\x00\x6b\x00\x22\x00\x67\x00\xec\x00\xb2\x00\xb3\x00\xb4\x00\x4b\x00\xea\x00\xe4\x00\xe5\x00\xe8\x00\x22\x00\xe1\x00\xe2\x00\xbb\x00\xe3\x00\xba\x00\xbc\x00\xc2\x00\x22\x00\xc3\x00\x5b\x00\x4b\x00\xc6\x00\x4b\x00\xcb\x00\x58\x00\x22\x00\xd0\x00\xff\xff\x22\x00\xd3\x00\x89\x00\x25\x00\x25\x00\x25\x00\x8a\x00\x8c\x00\xa0\x00\x9b\x00\x92\x00\xff\xff\xa2\x00\xff\xff\x25\x00\x39\x00\xa1\x00\xff\xff\xa4\x00\xa5\x00\x58\x00\xab\x00\x00\x00\xac\x00\x25\x00\x25\x00\xae\x00\xaf\x00\x00\x00\xb1\x00\x22\x00\x8b\x00\x25\x00\x5b\x00\x5b\x00\x58\x00\x4b\x00\x00\x00\xff\xff\xff\xff\x58\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x22\x00\x00\x00\x39\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x25\x00\xff\xff\x22\x00\x4b\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = array (32, 134) [ - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50), - (51 , happyReduce_51), - (52 , happyReduce_52), - (53 , happyReduce_53), - (54 , happyReduce_54), - (55 , happyReduce_55), - (56 , happyReduce_56), - (57 , happyReduce_57), - (58 , happyReduce_58), - (59 , happyReduce_59), - (60 , happyReduce_60), - (61 , happyReduce_61), - (62 , happyReduce_62), - (63 , happyReduce_63), - (64 , happyReduce_64), - (65 , happyReduce_65), - (66 , happyReduce_66), - (67 , happyReduce_67), - (68 , happyReduce_68), - (69 , happyReduce_69), - (70 , happyReduce_70), - (71 , happyReduce_71), - (72 , happyReduce_72), - (73 , happyReduce_73), - (74 , happyReduce_74), - (75 , happyReduce_75), - (76 , happyReduce_76), - (77 , happyReduce_77), - (78 , happyReduce_78), - (79 , happyReduce_79), - (80 , happyReduce_80), - (81 , happyReduce_81), - (82 , happyReduce_82), - (83 , happyReduce_83), - (84 , happyReduce_84), - (85 , happyReduce_85), - (86 , happyReduce_86), - (87 , happyReduce_87), - (88 , happyReduce_88), - (89 , happyReduce_89), - (90 , happyReduce_90), - (91 , happyReduce_91), - (92 , happyReduce_92), - (93 , happyReduce_93), - (94 , happyReduce_94), - (95 , happyReduce_95), - (96 , happyReduce_96), - (97 , happyReduce_97), - (98 , happyReduce_98), - (99 , happyReduce_99), - (100 , happyReduce_100), - (101 , happyReduce_101), - (102 , happyReduce_102), - (103 , happyReduce_103), - (104 , happyReduce_104), - (105 , happyReduce_105), - (106 , happyReduce_106), - (107 , happyReduce_107), - (108 , happyReduce_108), - (109 , happyReduce_109), - (110 , happyReduce_110), - (111 , happyReduce_111), - (112 , happyReduce_112), - (113 , happyReduce_113), - (114 , happyReduce_114), - (115 , happyReduce_115), - (116 , happyReduce_116), - (117 , happyReduce_117), - (118 , happyReduce_118), - (119 , happyReduce_119), - (120 , happyReduce_120), - (121 , happyReduce_121), - (122 , happyReduce_122), - (123 , happyReduce_123), - (124 , happyReduce_124), - (125 , happyReduce_125), - (126 , happyReduce_126), - (127 , happyReduce_127), - (128 , happyReduce_128), - (129 , happyReduce_129), - (130 , happyReduce_130), - (131 , happyReduce_131), - (132 , happyReduce_132), - (133 , happyReduce_133), - (134 , happyReduce_134) - ] - -happy_n_terms = 47 :: Int -happy_n_nonterms = 37 :: Int - -happyReduce_32 = happySpecReduce_1 0# happyReduction_32 -happyReduction_32 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> - happyIn35 - (happy_var_1 - )} - -happyReduce_33 = happySpecReduce_1 1# happyReduction_33 -happyReduction_33 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) -> - happyIn36 - (Ident happy_var_1 - )} - -happyReduce_34 = happySpecReduce_1 2# happyReduction_34 -happyReduction_34 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> - happyIn37 - ((read happy_var_1) :: Integer - )} - -happyReduce_35 = happySpecReduce_1 3# happyReduction_35 -happyReduction_35 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TC happy_var_1)) -> - happyIn38 - ((read happy_var_1) :: Char - )} - -happyReduce_36 = happySpecReduce_1 4# happyReduction_36 -happyReduction_36 happy_x_1 - = case happyOutTok happy_x_1 of { (PT _ (TD happy_var_1)) -> - happyIn39 - ((read happy_var_1) :: Double - )} - -happyReduce_37 = happySpecReduce_1 5# happyReduction_37 -happyReduction_37 happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - happyIn40 - (LGr happy_var_1 - )} - -happyReduce_38 = happySpecReduce_1 6# happyReduction_38 -happyReduction_38 happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - happyIn41 - (DefAll happy_var_1 - )} - -happyReduce_39 = happySpecReduce_3 6# happyReduction_39 -happyReduction_39 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut71 happy_x_1 of { happy_var_1 -> - case happyOut46 happy_x_3 of { happy_var_3 -> - happyIn41 - (DefSome happy_var_1 happy_var_3 - )}} - -happyReduce_40 = happySpecReduce_2 6# happyReduction_40 -happyReduction_40 happy_x_2 - happy_x_1 - = case happyOut71 happy_x_2 of { happy_var_2 -> - happyIn41 - (LDefView happy_var_2 - )} - -happyReduce_41 = happySpecReduce_0 7# happyReduction_41 -happyReduction_41 = happyIn42 - ([] - ) - -happyReduce_42 = happySpecReduce_1 7# happyReduction_42 -happyReduction_42 happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - happyIn42 - ((:[]) happy_var_1 - )} - -happyReduce_43 = happySpecReduce_3 7# happyReduction_43 -happyReduction_43 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - case happyOut42 happy_x_3 of { happy_var_3 -> - happyIn42 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_44 = happySpecReduce_1 8# happyReduction_44 -happyReduction_44 happy_x_1 - = case happyOut44 happy_x_1 of { happy_var_1 -> - happyIn43 - (Grammar happy_var_1 - )} - -happyReduce_45 = happySpecReduce_0 9# happyReduction_45 -happyReduction_45 = happyIn44 - ([] - ) - -happyReduce_46 = happySpecReduce_1 9# happyReduction_46 -happyReduction_46 happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - happyIn44 - ((:[]) happy_var_1 - )} - -happyReduce_47 = happySpecReduce_3 9# happyReduction_47 -happyReduction_47 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - case happyOut44 happy_x_3 of { happy_var_3 -> - happyIn44 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_48 = happySpecReduce_0 10# happyReduction_48 -happyReduction_48 = happyIn45 - ([] - ) - -happyReduce_49 = happySpecReduce_2 10# happyReduction_49 -happyReduction_49 happy_x_2 - happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_2 of { happy_var_2 -> - happyIn45 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_50 = happyReduce 5# 11# happyReduction_50 -happyReduction_50 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut49 happy_x_1 of { happy_var_1 -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut45 happy_x_5 of { happy_var_5 -> - happyIn46 - (Rule happy_var_1 happy_var_3 (reverse happy_var_5) - ) `HappyStk` happyRest}}} - -happyReduce_51 = happySpecReduce_2 11# happyReduction_51 -happyReduction_51 happy_x_2 - happy_x_1 - = case happyOut35 happy_x_2 of { happy_var_2 -> - happyIn46 - (Comment happy_var_2 - )} - -happyReduce_52 = happySpecReduce_3 11# happyReduction_52 -happyReduction_52 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut35 happy_x_2 of { happy_var_2 -> - case happyOut35 happy_x_3 of { happy_var_3 -> - happyIn46 - (Comments happy_var_2 happy_var_3 - )}} - -happyReduce_53 = happyReduce 6# 11# happyReduction_53 -happyReduction_53 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut49 happy_x_2 of { happy_var_2 -> - case happyOut48 happy_x_4 of { happy_var_4 -> - case happyOut45 happy_x_6 of { happy_var_6 -> - happyIn46 - (Internal happy_var_2 happy_var_4 (reverse happy_var_6) - ) `HappyStk` happyRest}}} - -happyReduce_54 = happySpecReduce_3 11# happyReduction_54 -happyReduction_54 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut36 happy_x_2 of { happy_var_2 -> - case happyOut70 happy_x_3 of { happy_var_3 -> - happyIn46 - (Token happy_var_2 happy_var_3 - )}} - -happyReduce_55 = happyReduce 4# 11# happyReduction_55 -happyReduction_55 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut36 happy_x_3 of { happy_var_3 -> - case happyOut70 happy_x_4 of { happy_var_4 -> - happyIn46 - (PosToken happy_var_3 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_56 = happySpecReduce_2 11# happyReduction_56 -happyReduction_56 happy_x_2 - happy_x_1 - = case happyOut71 happy_x_2 of { happy_var_2 -> - happyIn46 - (Entryp happy_var_2 - )} - -happyReduce_57 = happyReduce 4# 11# happyReduction_57 -happyReduction_57 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut66 happy_x_2 of { happy_var_2 -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut35 happy_x_4 of { happy_var_4 -> - happyIn46 - (Separator happy_var_2 happy_var_3 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_58 = happyReduce 4# 11# happyReduction_58 -happyReduction_58 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut66 happy_x_2 of { happy_var_2 -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut35 happy_x_4 of { happy_var_4 -> - happyIn46 - (Terminator happy_var_2 happy_var_3 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_59 = happySpecReduce_3 11# happyReduction_59 -happyReduction_59 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut36 happy_x_2 of { happy_var_2 -> - case happyOut37 happy_x_3 of { happy_var_3 -> - happyIn46 - (Coercions happy_var_2 happy_var_3 - )}} - -happyReduce_60 = happyReduce 4# 11# happyReduction_60 -happyReduction_60 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut36 happy_x_2 of { happy_var_2 -> - case happyOut64 happy_x_4 of { happy_var_4 -> - happyIn46 - (Rules happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_61 = happyReduce 5# 11# happyReduction_61 -happyReduction_61 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut36 happy_x_2 of { happy_var_2 -> - case happyOut57 happy_x_3 of { happy_var_3 -> - case happyOut58 happy_x_5 of { happy_var_5 -> - happyIn46 - (Function happy_var_2 (reverse happy_var_3) happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_62 = happySpecReduce_2 11# happyReduction_62 -happyReduction_62 happy_x_2 - happy_x_1 - = case happyOut63 happy_x_2 of { happy_var_2 -> - happyIn46 - (Layout happy_var_2 - )} - -happyReduce_63 = happySpecReduce_3 11# happyReduction_63 -happyReduction_63 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut63 happy_x_3 of { happy_var_3 -> - happyIn46 - (LayoutStop happy_var_3 - )} - -happyReduce_64 = happySpecReduce_2 11# happyReduction_64 -happyReduction_64 happy_x_2 - happy_x_1 - = happyIn46 - (LayoutTop - ) - -happyReduce_65 = happySpecReduce_1 12# happyReduction_65 -happyReduction_65 happy_x_1 - = case happyOut35 happy_x_1 of { happy_var_1 -> - happyIn47 - (Terminal happy_var_1 - )} - -happyReduce_66 = happySpecReduce_1 12# happyReduction_66 -happyReduction_66 happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - happyIn47 - (NTerminal happy_var_1 - )} - -happyReduce_67 = happySpecReduce_3 13# happyReduction_67 -happyReduction_67 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut48 happy_x_2 of { happy_var_2 -> - happyIn48 - (ListCat happy_var_2 - )} - -happyReduce_68 = happySpecReduce_1 13# happyReduction_68 -happyReduction_68 happy_x_1 - = case happyOut36 happy_x_1 of { happy_var_1 -> - happyIn48 - (IdCat happy_var_1 - )} - -happyReduce_69 = happySpecReduce_1 14# happyReduction_69 -happyReduction_69 happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - happyIn49 - (LabNoP happy_var_1 - )} - -happyReduce_70 = happySpecReduce_2 14# happyReduction_70 -happyReduction_70 happy_x_2 - happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - case happyOut55 happy_x_2 of { happy_var_2 -> - happyIn49 - (LabP happy_var_1 happy_var_2 - )}} - -happyReduce_71 = happySpecReduce_3 14# happyReduction_71 -happyReduction_71 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_2 of { happy_var_2 -> - case happyOut55 happy_x_3 of { happy_var_3 -> - happyIn49 - (LabPF happy_var_1 happy_var_2 happy_var_3 - )}}} - -happyReduce_72 = happySpecReduce_2 14# happyReduction_72 -happyReduction_72 happy_x_2 - happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_2 of { happy_var_2 -> - happyIn49 - (LabF happy_var_1 happy_var_2 - )}} - -happyReduce_73 = happySpecReduce_1 15# happyReduction_73 -happyReduction_73 happy_x_1 - = case happyOut36 happy_x_1 of { happy_var_1 -> - happyIn50 - (Id happy_var_1 - )} - -happyReduce_74 = happySpecReduce_1 15# happyReduction_74 -happyReduction_74 happy_x_1 - = happyIn50 - (Wild - ) - -happyReduce_75 = happySpecReduce_2 15# happyReduction_75 -happyReduction_75 happy_x_2 - happy_x_1 - = happyIn50 - (ListE - ) - -happyReduce_76 = happySpecReduce_3 15# happyReduction_76 -happyReduction_76 happy_x_3 - happy_x_2 - happy_x_1 - = happyIn50 - (ListCons - ) - -happyReduce_77 = happyReduce 5# 15# happyReduction_77 -happyReduction_77 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = happyIn50 - (ListOne - ) `HappyStk` happyRest - -happyReduce_78 = happyReduce 9# 16# happyReduction_78 -happyReduction_78 (happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut54 happy_x_3 of { happy_var_3 -> - case happyOut53 happy_x_7 of { happy_var_7 -> - happyIn51 - (ProfIt happy_var_3 happy_var_7 - ) `HappyStk` happyRest}} - -happyReduce_79 = happySpecReduce_3 17# happyReduction_79 -happyReduction_79 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut53 happy_x_2 of { happy_var_2 -> - happyIn52 - (Ints happy_var_2 - )} - -happyReduce_80 = happySpecReduce_0 18# happyReduction_80 -happyReduction_80 = happyIn53 - ([] - ) - -happyReduce_81 = happySpecReduce_1 18# happyReduction_81 -happyReduction_81 happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - happyIn53 - ((:[]) happy_var_1 - )} - -happyReduce_82 = happySpecReduce_3 18# happyReduction_82 -happyReduction_82 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut53 happy_x_3 of { happy_var_3 -> - happyIn53 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_83 = happySpecReduce_0 19# happyReduction_83 -happyReduction_83 = happyIn54 - ([] - ) - -happyReduce_84 = happySpecReduce_1 19# happyReduction_84 -happyReduction_84 happy_x_1 - = case happyOut52 happy_x_1 of { happy_var_1 -> - happyIn54 - ((:[]) happy_var_1 - )} - -happyReduce_85 = happySpecReduce_3 19# happyReduction_85 -happyReduction_85 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut52 happy_x_1 of { happy_var_1 -> - case happyOut54 happy_x_3 of { happy_var_3 -> - happyIn54 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_86 = happySpecReduce_1 20# happyReduction_86 -happyReduction_86 happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - happyIn55 - ((:[]) happy_var_1 - )} - -happyReduce_87 = happySpecReduce_2 20# happyReduction_87 -happyReduction_87 happy_x_2 - happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut55 happy_x_2 of { happy_var_2 -> - happyIn55 - ((:) happy_var_1 happy_var_2 - )}} - -happyReduce_88 = happySpecReduce_1 21# happyReduction_88 -happyReduction_88 happy_x_1 - = case happyOut36 happy_x_1 of { happy_var_1 -> - happyIn56 - (Arg happy_var_1 - )} - -happyReduce_89 = happySpecReduce_0 22# happyReduction_89 -happyReduction_89 = happyIn57 - ([] - ) - -happyReduce_90 = happySpecReduce_2 22# happyReduction_90 -happyReduction_90 happy_x_2 - happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - case happyOut56 happy_x_2 of { happy_var_2 -> - happyIn57 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_91 = happySpecReduce_3 23# happyReduction_91 -happyReduction_91 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut59 happy_x_1 of { happy_var_1 -> - case happyOut58 happy_x_3 of { happy_var_3 -> - happyIn58 - (Cons happy_var_1 happy_var_3 - )}} - -happyReduce_92 = happySpecReduce_1 23# happyReduction_92 -happyReduction_92 happy_x_1 - = case happyOut59 happy_x_1 of { happy_var_1 -> - happyIn58 - (happy_var_1 - )} - -happyReduce_93 = happySpecReduce_2 24# happyReduction_93 -happyReduction_93 happy_x_2 - happy_x_1 - = case happyOut36 happy_x_1 of { happy_var_1 -> - case happyOut61 happy_x_2 of { happy_var_2 -> - happyIn59 - (App happy_var_1 happy_var_2 - )}} - -happyReduce_94 = happySpecReduce_1 24# happyReduction_94 -happyReduction_94 happy_x_1 - = case happyOut60 happy_x_1 of { happy_var_1 -> - happyIn59 - (happy_var_1 - )} - -happyReduce_95 = happySpecReduce_1 25# happyReduction_95 -happyReduction_95 happy_x_1 - = case happyOut36 happy_x_1 of { happy_var_1 -> - happyIn60 - (Var happy_var_1 - )} - -happyReduce_96 = happySpecReduce_1 25# happyReduction_96 -happyReduction_96 happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - happyIn60 - (LitInt happy_var_1 - )} - -happyReduce_97 = happySpecReduce_1 25# happyReduction_97 -happyReduction_97 happy_x_1 - = case happyOut38 happy_x_1 of { happy_var_1 -> - happyIn60 - (LitChar happy_var_1 - )} - -happyReduce_98 = happySpecReduce_1 25# happyReduction_98 -happyReduction_98 happy_x_1 - = case happyOut35 happy_x_1 of { happy_var_1 -> - happyIn60 - (LitString happy_var_1 - )} - -happyReduce_99 = happySpecReduce_1 25# happyReduction_99 -happyReduction_99 happy_x_1 - = case happyOut39 happy_x_1 of { happy_var_1 -> - happyIn60 - (LitDouble happy_var_1 - )} - -happyReduce_100 = happySpecReduce_3 25# happyReduction_100 -happyReduction_100 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut62 happy_x_2 of { happy_var_2 -> - happyIn60 - (List happy_var_2 - )} - -happyReduce_101 = happySpecReduce_3 25# happyReduction_101 -happyReduction_101 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut58 happy_x_2 of { happy_var_2 -> - happyIn60 - (happy_var_2 - )} - -happyReduce_102 = happySpecReduce_1 26# happyReduction_102 -happyReduction_102 happy_x_1 - = case happyOut60 happy_x_1 of { happy_var_1 -> - happyIn61 - ((:[]) happy_var_1 - )} - -happyReduce_103 = happySpecReduce_2 26# happyReduction_103 -happyReduction_103 happy_x_2 - happy_x_1 - = case happyOut60 happy_x_1 of { happy_var_1 -> - case happyOut61 happy_x_2 of { happy_var_2 -> - happyIn61 - ((:) happy_var_1 happy_var_2 - )}} - -happyReduce_104 = happySpecReduce_0 27# happyReduction_104 -happyReduction_104 = happyIn62 - ([] - ) - -happyReduce_105 = happySpecReduce_1 27# happyReduction_105 -happyReduction_105 happy_x_1 - = case happyOut58 happy_x_1 of { happy_var_1 -> - happyIn62 - ((:[]) happy_var_1 - )} - -happyReduce_106 = happySpecReduce_3 27# happyReduction_106 -happyReduction_106 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut58 happy_x_1 of { happy_var_1 -> - case happyOut62 happy_x_3 of { happy_var_3 -> - happyIn62 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_107 = happySpecReduce_1 28# happyReduction_107 -happyReduction_107 happy_x_1 - = case happyOut35 happy_x_1 of { happy_var_1 -> - happyIn63 - ((:[]) happy_var_1 - )} - -happyReduce_108 = happySpecReduce_3 28# happyReduction_108 -happyReduction_108 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut35 happy_x_1 of { happy_var_1 -> - case happyOut63 happy_x_3 of { happy_var_3 -> - happyIn63 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_109 = happySpecReduce_1 29# happyReduction_109 -happyReduction_109 happy_x_1 - = case happyOut65 happy_x_1 of { happy_var_1 -> - happyIn64 - ((:[]) happy_var_1 - )} - -happyReduce_110 = happySpecReduce_3 29# happyReduction_110 -happyReduction_110 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut65 happy_x_1 of { happy_var_1 -> - case happyOut64 happy_x_3 of { happy_var_3 -> - happyIn64 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_111 = happySpecReduce_1 30# happyReduction_111 -happyReduction_111 happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - happyIn65 - (RHS (reverse happy_var_1) - )} - -happyReduce_112 = happySpecReduce_1 31# happyReduction_112 -happyReduction_112 happy_x_1 - = happyIn66 - (MNonempty - ) - -happyReduce_113 = happySpecReduce_0 31# happyReduction_113 -happyReduction_113 = happyIn66 - (MEmpty - ) - -happyReduce_114 = happySpecReduce_2 32# happyReduction_114 -happyReduction_114 happy_x_2 - happy_x_1 - = case happyOut67 happy_x_1 of { happy_var_1 -> - case happyOut69 happy_x_2 of { happy_var_2 -> - happyIn67 - (RSeq happy_var_1 happy_var_2 - )}} - -happyReduce_115 = happySpecReduce_1 32# happyReduction_115 -happyReduction_115 happy_x_1 - = case happyOut69 happy_x_1 of { happy_var_1 -> - happyIn67 - (happy_var_1 - )} - -happyReduce_116 = happySpecReduce_3 33# happyReduction_116 -happyReduction_116 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut68 happy_x_1 of { happy_var_1 -> - case happyOut67 happy_x_3 of { happy_var_3 -> - happyIn68 - (RAlt happy_var_1 happy_var_3 - )}} - -happyReduce_117 = happySpecReduce_3 33# happyReduction_117 -happyReduction_117 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut67 happy_x_1 of { happy_var_1 -> - case happyOut67 happy_x_3 of { happy_var_3 -> - happyIn68 - (RMinus happy_var_1 happy_var_3 - )}} - -happyReduce_118 = happySpecReduce_1 33# happyReduction_118 -happyReduction_118 happy_x_1 - = case happyOut67 happy_x_1 of { happy_var_1 -> - happyIn68 - (happy_var_1 - )} - -happyReduce_119 = happySpecReduce_2 34# happyReduction_119 -happyReduction_119 happy_x_2 - happy_x_1 - = case happyOut69 happy_x_1 of { happy_var_1 -> - happyIn69 - (RStar happy_var_1 - )} - -happyReduce_120 = happySpecReduce_2 34# happyReduction_120 -happyReduction_120 happy_x_2 - happy_x_1 - = case happyOut69 happy_x_1 of { happy_var_1 -> - happyIn69 - (RPlus happy_var_1 - )} - -happyReduce_121 = happySpecReduce_2 34# happyReduction_121 -happyReduction_121 happy_x_2 - happy_x_1 - = case happyOut69 happy_x_1 of { happy_var_1 -> - happyIn69 - (ROpt happy_var_1 - )} - -happyReduce_122 = happySpecReduce_1 34# happyReduction_122 -happyReduction_122 happy_x_1 - = happyIn69 - (REps - ) - -happyReduce_123 = happySpecReduce_1 34# happyReduction_123 -happyReduction_123 happy_x_1 - = case happyOut38 happy_x_1 of { happy_var_1 -> - happyIn69 - (RChar happy_var_1 - )} - -happyReduce_124 = happySpecReduce_3 34# happyReduction_124 -happyReduction_124 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut35 happy_x_2 of { happy_var_2 -> - happyIn69 - (RAlts happy_var_2 - )} - -happyReduce_125 = happySpecReduce_3 34# happyReduction_125 -happyReduction_125 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut35 happy_x_2 of { happy_var_2 -> - happyIn69 - (RSeqs happy_var_2 - )} - -happyReduce_126 = happySpecReduce_1 34# happyReduction_126 -happyReduction_126 happy_x_1 - = happyIn69 - (RDigit - ) - -happyReduce_127 = happySpecReduce_1 34# happyReduction_127 -happyReduction_127 happy_x_1 - = happyIn69 - (RLetter - ) - -happyReduce_128 = happySpecReduce_1 34# happyReduction_128 -happyReduction_128 happy_x_1 - = happyIn69 - (RUpper - ) - -happyReduce_129 = happySpecReduce_1 34# happyReduction_129 -happyReduction_129 happy_x_1 - = happyIn69 - (RLower - ) - -happyReduce_130 = happySpecReduce_1 34# happyReduction_130 -happyReduction_130 happy_x_1 - = happyIn69 - (RAny - ) - -happyReduce_131 = happySpecReduce_3 34# happyReduction_131 -happyReduction_131 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut70 happy_x_2 of { happy_var_2 -> - happyIn69 - (happy_var_2 - )} - -happyReduce_132 = happySpecReduce_1 35# happyReduction_132 -happyReduction_132 happy_x_1 - = case happyOut68 happy_x_1 of { happy_var_1 -> - happyIn70 - (happy_var_1 - )} - -happyReduce_133 = happySpecReduce_1 36# happyReduction_133 -happyReduction_133 happy_x_1 - = case happyOut36 happy_x_1 of { happy_var_1 -> - happyIn71 - ((:[]) happy_var_1 - )} - -happyReduce_134 = happySpecReduce_3 36# happyReduction_134 -happyReduction_134 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut36 happy_x_1 of { happy_var_1 -> - case happyOut71 happy_x_3 of { happy_var_3 -> - happyIn71 - ((:) happy_var_1 happy_var_3 - )}} - -happyNewToken action sts stk [] = - happyDoAction 46# (error "reading EOF!") action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - PT _ (TS ":") -> cont 1#; - PT _ (TS ";") -> cont 2#; - PT _ (TS ".") -> cont 3#; - PT _ (TS "::=") -> cont 4#; - PT _ (TS "[") -> cont 5#; - PT _ (TS "]") -> cont 6#; - PT _ (TS "_") -> cont 7#; - PT _ (TS "(") -> cont 8#; - PT _ (TS ")") -> cont 9#; - PT _ (TS ",") -> cont 10#; - PT _ (TS "=") -> cont 11#; - PT _ (TS "|") -> cont 12#; - PT _ (TS "-") -> cont 13#; - PT _ (TS "*") -> cont 14#; - PT _ (TS "+") -> cont 15#; - PT _ (TS "?") -> cont 16#; - PT _ (TS "{") -> cont 17#; - PT _ (TS "}") -> cont 18#; - PT _ (TS "char") -> cont 19#; - PT _ (TS "coercions") -> cont 20#; - PT _ (TS "comment") -> cont 21#; - PT _ (TS "define") -> cont 22#; - PT _ (TS "digit") -> cont 23#; - PT _ (TS "entrypoints") -> cont 24#; - PT _ (TS "eps") -> cont 25#; - PT _ (TS "internal") -> cont 26#; - PT _ (TS "layout") -> cont 27#; - PT _ (TS "letter") -> cont 28#; - PT _ (TS "lower") -> cont 29#; - PT _ (TS "nonempty") -> cont 30#; - PT _ (TS "position") -> cont 31#; - PT _ (TS "rules") -> cont 32#; - PT _ (TS "separator") -> cont 33#; - PT _ (TS "stop") -> cont 34#; - PT _ (TS "terminator") -> cont 35#; - PT _ (TS "token") -> cont 36#; - PT _ (TS "toplevel") -> cont 37#; - PT _ (TS "upper") -> cont 38#; - PT _ (TS "views") -> cont 39#; - PT _ (TL happy_dollar_dollar) -> cont 40#; - PT _ (TV happy_dollar_dollar) -> cont 41#; - PT _ (TI happy_dollar_dollar) -> cont 42#; - PT _ (TC happy_dollar_dollar) -> cont 43#; - PT _ (TD happy_dollar_dollar) -> cont 44#; - _ -> cont 45#; - _ -> 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 - -pLGrammar tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut40 x)) - -pLDef tks = happySomeParser where - happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut41 x)) - -pListLDef tks = happySomeParser where - happySomeParser = happyThen (happyParse 2# tks) (\x -> happyReturn (happyOut42 x)) - -pGrammar tks = happySomeParser where - happySomeParser = happyThen (happyParse 3# tks) (\x -> happyReturn (happyOut43 x)) - -pListDef tks = happySomeParser where - happySomeParser = happyThen (happyParse 4# tks) (\x -> happyReturn (happyOut44 x)) - -pListItem tks = happySomeParser where - happySomeParser = happyThen (happyParse 5# tks) (\x -> happyReturn (happyOut45 x)) - -pDef tks = happySomeParser where - happySomeParser = happyThen (happyParse 6# tks) (\x -> happyReturn (happyOut46 x)) - -pItem tks = happySomeParser where - happySomeParser = happyThen (happyParse 7# tks) (\x -> happyReturn (happyOut47 x)) - -pCat tks = happySomeParser where - happySomeParser = happyThen (happyParse 8# tks) (\x -> happyReturn (happyOut48 x)) - -pLabel tks = happySomeParser where - happySomeParser = happyThen (happyParse 9# tks) (\x -> happyReturn (happyOut49 x)) - -pLabelId tks = happySomeParser where - happySomeParser = happyThen (happyParse 10# tks) (\x -> happyReturn (happyOut50 x)) - -pProfItem tks = happySomeParser where - happySomeParser = happyThen (happyParse 11# tks) (\x -> happyReturn (happyOut51 x)) - -pIntList tks = happySomeParser where - happySomeParser = happyThen (happyParse 12# tks) (\x -> happyReturn (happyOut52 x)) - -pListInteger tks = happySomeParser where - happySomeParser = happyThen (happyParse 13# tks) (\x -> happyReturn (happyOut53 x)) - -pListIntList tks = happySomeParser where - happySomeParser = happyThen (happyParse 14# tks) (\x -> happyReturn (happyOut54 x)) - -pListProfItem tks = happySomeParser where - happySomeParser = happyThen (happyParse 15# tks) (\x -> happyReturn (happyOut55 x)) - -pArg tks = happySomeParser where - happySomeParser = happyThen (happyParse 16# tks) (\x -> happyReturn (happyOut56 x)) - -pListArg tks = happySomeParser where - happySomeParser = happyThen (happyParse 17# tks) (\x -> happyReturn (happyOut57 x)) - -pExp tks = happySomeParser where - happySomeParser = happyThen (happyParse 18# tks) (\x -> happyReturn (happyOut58 x)) - -pExp1 tks = happySomeParser where - happySomeParser = happyThen (happyParse 19# tks) (\x -> happyReturn (happyOut59 x)) - -pExp2 tks = happySomeParser where - happySomeParser = happyThen (happyParse 20# tks) (\x -> happyReturn (happyOut60 x)) - -pListExp2 tks = happySomeParser where - happySomeParser = happyThen (happyParse 21# tks) (\x -> happyReturn (happyOut61 x)) - -pListExp tks = happySomeParser where - happySomeParser = happyThen (happyParse 22# tks) (\x -> happyReturn (happyOut62 x)) - -pListString tks = happySomeParser where - happySomeParser = happyThen (happyParse 23# tks) (\x -> happyReturn (happyOut63 x)) - -pListRHS tks = happySomeParser where - happySomeParser = happyThen (happyParse 24# tks) (\x -> happyReturn (happyOut64 x)) - -pRHS tks = happySomeParser where - happySomeParser = happyThen (happyParse 25# tks) (\x -> happyReturn (happyOut65 x)) - -pMinimumSize tks = happySomeParser where - happySomeParser = happyThen (happyParse 26# tks) (\x -> happyReturn (happyOut66 x)) - -pReg2 tks = happySomeParser where - happySomeParser = happyThen (happyParse 27# tks) (\x -> happyReturn (happyOut67 x)) - -pReg1 tks = happySomeParser where - happySomeParser = happyThen (happyParse 28# tks) (\x -> happyReturn (happyOut68 x)) - -pReg3 tks = happySomeParser where - happySomeParser = happyThen (happyParse 29# tks) (\x -> happyReturn (happyOut69 x)) - -pReg tks = happySomeParser where - happySomeParser = happyThen (happyParse 30# tks) (\x -> happyReturn (happyOut70 x)) - -pListIdent tks = happySomeParser where - happySomeParser = happyThen (happyParse 31# tks) (\x -> happyReturn (happyOut71 x)) - -happySeq = happyDontSeq - -returnM :: a -> Err a -returnM = return - -thenM :: Err a -> (a -> Err b) -> Err b -thenM = (>>=) - -happyError :: [Token] -> Err a -happyError ts = - Bad $ "syntax error at " ++ tokenPos ts ++ - case ts of - [] -> [] - [Err _] -> " due to lexer error" - _ -> " before " ++ unwords (map prToken (take 4 ts)) - -myLexer = tokens -{-# LINE 1 "GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "GenericTemplate.hs" #-} --- $Id: ParBNF.hs,v 1.14 2007/01/08 17:54:31 aarne Exp $ - - -{-# LINE 28 "GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Int# Happy_IntList - - - - - - -{-# LINE 49 "GenericTemplate.hs" #-} - - -{-# LINE 59 "GenericTemplate.hs" #-} - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | (n <# (0# :: Int#)) -> {- nothing -} - - (happyReduceArr ! rule) i tk st - where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n -# (1# :: Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off +# i) - check = if (off_i >=# (0# :: Int#)) - then (indexShortOffAddr happyCheck off_i ==# i) - else False - action | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - - - - - - - - - - -indexShortOffAddr (HappyA# arr) off = -#if __GLASGOW_HASKELL__ > 500 - narrow16Int# i -#elif __GLASGOW_HASKELL__ == 500 - intToInt16# i -#else - (i `iShiftL#` 16#) `iShiftRA#` 16# -#endif - where -#if __GLASGOW_HASKELL__ >= 503 - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) -#else - i = word2Int# ((high `shiftL#` 8#) `or#` low) -#endif - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# - - - - - -data HappyAddr = HappyA# Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - -{-# LINE 170 "GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k -# (1# :: Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) - drop_stk = happyDropStk k stk - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off +# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk = --- trace "failing" $ - happyError_ tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. diff --git a/PrintBNF.hs b/PrintBNF.hs deleted file mode 100644 --- a/PrintBNF.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module PrintBNF where - --- pretty-printer generated by the BNF converter - -import AbsBNF -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 - "[" :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 (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - - -instance Print Double where - prt _ x = doc (shows x) - - -instance Print Ident where - prt _ (Ident i) = doc (showString i) - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - - - -instance Print LGrammar where - prt i e = case e of - LGr ldefs -> prPrec i 0 (concatD [prt 0 ldefs]) - - -instance Print LDef where - prt i e = case e of - DefAll def -> prPrec i 0 (concatD [prt 0 def]) - DefSome ids def -> prPrec i 0 (concatD [prt 0 ids , doc (showString ":") , prt 0 def]) - LDefView ids -> prPrec i 0 (concatD [doc (showString "views") , prt 0 ids]) - - prtList es = case es of - [] -> (concatD []) - [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 - Grammar defs -> prPrec i 0 (concatD [prt 0 defs]) - - -instance Print Def where - prt i e = case e of - Rule label cat items -> prPrec i 0 (concatD [prt 0 label , doc (showString ".") , prt 0 cat , doc (showString "::=") , prt 0 items]) - Comment str -> prPrec i 0 (concatD [doc (showString "comment") , prt 0 str]) - Comments str0 str -> prPrec i 0 (concatD [doc (showString "comment") , prt 0 str0 , prt 0 str]) - Internal label cat items -> prPrec i 0 (concatD [doc (showString "internal") , prt 0 label , doc (showString ".") , prt 0 cat , doc (showString "::=") , prt 0 items]) - Token id reg -> prPrec i 0 (concatD [doc (showString "token") , prt 0 id , prt 0 reg]) - PosToken id reg -> prPrec i 0 (concatD [doc (showString "position") , doc (showString "token") , prt 0 id , prt 0 reg]) - Entryp ids -> prPrec i 0 (concatD [doc (showString "entrypoints") , prt 0 ids]) - Separator minimumsize cat str -> prPrec i 0 (concatD [doc (showString "separator") , prt 0 minimumsize , prt 0 cat , prt 0 str]) - Terminator minimumsize cat str -> prPrec i 0 (concatD [doc (showString "terminator") , prt 0 minimumsize , prt 0 cat , prt 0 str]) - Coercions id n -> prPrec i 0 (concatD [doc (showString "coercions") , prt 0 id , prt 0 n]) - Rules id rhss -> prPrec i 0 (concatD [doc (showString "rules") , prt 0 id , doc (showString "::=") , prt 0 rhss]) - Function id args exp -> prPrec i 0 (concatD [doc (showString "define") , prt 0 id , prt 0 args , doc (showString "=") , prt 0 exp]) - Layout strs -> prPrec i 0 (concatD [doc (showString "layout") , prt 0 strs]) - LayoutStop strs -> prPrec i 0 (concatD [doc (showString "layout") , doc (showString "stop") , prt 0 strs]) - LayoutTop -> prPrec i 0 (concatD [doc (showString "layout") , doc (showString "toplevel")]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) - -instance Print Item where - prt i e = case e of - Terminal str -> prPrec i 0 (concatD [prt 0 str]) - NTerminal cat -> prPrec i 0 (concatD [prt 0 cat]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print Cat where - prt i e = case e of - ListCat cat -> prPrec i 0 (concatD [doc (showString "[") , prt 0 cat , doc (showString "]")]) - IdCat id -> prPrec i 0 (concatD [prt 0 id]) - - -instance Print Label where - prt i e = case e of - LabNoP labelid -> prPrec i 0 (concatD [prt 0 labelid]) - LabP labelid profitems -> prPrec i 0 (concatD [prt 0 labelid , prt 0 profitems]) - LabPF labelid0 labelid profitems -> prPrec i 0 (concatD [prt 0 labelid0 , prt 0 labelid , prt 0 profitems]) - LabF labelid0 labelid -> prPrec i 0 (concatD [prt 0 labelid0 , prt 0 labelid]) - - -instance Print LabelId where - prt i e = case e of - Id id -> prPrec i 0 (concatD [prt 0 id]) - Wild -> prPrec i 0 (concatD [doc (showString "_")]) - ListE -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "]")]) - ListCons -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ":") , doc (showString ")")]) - ListOne -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ":") , doc (showString "[") , doc (showString "]") , doc (showString ")")]) - - -instance Print ProfItem where - prt i e = case e of - ProfIt intlists ns -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "[") , prt 0 intlists , doc (showString "]") , doc (showString ",") , doc (showString "[") , prt 0 ns , doc (showString "]") , doc (showString ")")]) - - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print IntList where - prt i e = case e of - Ints ns -> prPrec i 0 (concatD [doc (showString "[") , prt 0 ns , 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 Arg where - prt i e = case e of - Arg id -> prPrec i 0 (concatD [prt 0 id]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print Exp where - prt i e = case e of - Cons exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString ":") , prt 0 exp]) - App id exps -> prPrec i 1 (concatD [prt 0 id , prt 2 exps]) - Var id -> prPrec i 2 (concatD [prt 0 id]) - LitInt n -> prPrec i 2 (concatD [prt 0 n]) - LitChar c -> prPrec i 2 (concatD [prt 0 c]) - LitString str -> prPrec i 2 (concatD [prt 0 str]) - LitDouble d -> prPrec i 2 (concatD [prt 0 d]) - List exps -> prPrec i 2 (concatD [doc (showString "[") , prt 0 exps , doc (showString "]")]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 2 x]) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 2 x , prt 2 xs]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print RHS where - prt i e = case e of - RHS items -> prPrec i 0 (concatD [prt 0 items]) - - prtList es = case es of - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) - -instance Print MinimumSize where - prt i e = case e of - MNonempty -> prPrec i 0 (concatD [doc (showString "nonempty")]) - MEmpty -> prPrec i 0 (concatD []) - - -instance Print Reg where - prt i e = case e of - RSeq reg0 reg -> prPrec i 2 (concatD [prt 2 reg0 , prt 3 reg]) - RAlt reg0 reg -> prPrec i 1 (concatD [prt 1 reg0 , doc (showString "|") , prt 2 reg]) - RMinus reg0 reg -> prPrec i 1 (concatD [prt 2 reg0 , doc (showString "-") , prt 2 reg]) - RStar reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "*")]) - RPlus reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "+")]) - ROpt reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "?")]) - REps -> prPrec i 3 (concatD [doc (showString "eps")]) - RChar c -> prPrec i 3 (concatD [prt 0 c]) - RAlts str -> prPrec i 3 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")]) - RSeqs str -> prPrec i 3 (concatD [doc (showString "{") , prt 0 str , doc (showString "}")]) - RDigit -> prPrec i 3 (concatD [doc (showString "digit")]) - RLetter -> prPrec i 3 (concatD [doc (showString "letter")]) - RUpper -> prPrec i 3 (concatD [doc (showString "upper")]) - RLower -> prPrec i 3 (concatD [doc (showString "lower")]) - RAny -> prPrec i 3 (concatD [doc (showString "char")]) - - - diff --git a/TypeChecker.hs b/TypeChecker.hs deleted file mode 100644 --- a/TypeChecker.hs +++ /dev/null @@ -1,146 +0,0 @@ - -module TypeChecker where - -import Control.Monad -import Data.List -import Data.Char - -import CF -import ErrM - -data Base = BaseT String - | ListT Base - deriving (Eq) - -data Type = FunT [Base] Base - deriving (Eq) - -instance Show Base where - show (BaseT x) = x - show (ListT t) = "[" ++ show t ++ "]" - -instance Show Type where - show (FunT ts t) = unwords $ map show ts ++ ["->", show t] - -data Context = Ctx { ctxLabels :: [(String, Type)] - , ctxTokens :: [String] - } - -catchErr :: Err a -> (String -> Err a) -> Err a -catchErr (Bad s) f = f s -catchErr (Ok x) _ = Ok x - -buildContext :: CF -> Context -buildContext cf@(_,rules) = - Ctx - [ (f, mkType cat args) | (f,(cat,args)) <- rules - , not (isCoercion f) - , not (isNilCons f) - ] - ("Ident" : tokenNames cf) - where - - mkType cat args = FunT [ mkBase t | Left t <- args, t /= internalCat ] - (mkBase cat) - mkBase t - | isList t = ListT $ mkBase $ normCatOfList t - | otherwise = BaseT $ normCat t - -isToken :: String -> Context -> Bool -isToken x ctx = elem x $ ctxTokens ctx - -extendContext :: Context -> [(String,Type)] -> Context -extendContext ctx xs = ctx { ctxLabels = xs ++ ctxLabels ctx } - -lookupCtx :: String -> Context -> Err Type -lookupCtx x ctx - | isToken x ctx = return $ FunT [BaseT "String"] (BaseT x) - | otherwise = - case lookup x $ ctxLabels ctx of - Nothing -> fail $ "Undefined symbol '" ++ x ++ "'." - Just t -> return t - -checkDefinitions :: CF -> Err () -checkDefinitions cf@((ps,_),_) = - do checkContext ctx - sequence_ [ checkDefinition ctx f xs e | FunDef f xs e <- ps ] - where - ctx = buildContext cf - -checkContext :: Context -> Err () -checkContext ctx = - mapM_ checkEntry $ groupSnd $ ctxLabels ctx - where - -- This is a very handy function which transforms a lookup table - -- with duplicate keys to a list valued lookup table with no duplicate - -- keys. - groupSnd :: Ord a => [(a,b)] -> [(a,[b])] - groupSnd = - map ((fst . head) /\ map snd) - . groupBy ((==) **.* fst) - . sortBy (compare **.* fst) - - (f /\ g) x = (f x, g x) - (f **.* g) x y = f (g x) (g y) - - checkEntry (f,ts) = - case nub ts of - [_] -> return () - ts' -> - fail $ "The symbol '" ++ f ++ "' is used at conflicting types:\n" ++ - unlines (map ((" " ++) . show) ts') - -checkDefinition :: Context -> String -> [String] -> Exp -> Err () -checkDefinition ctx f xs e = - do checkDefinition' dummyConstructors ctx f xs e - return () - -data ListConstructors = LC - { nil :: Base -> String - , cons :: Base -> String - } - -dummyConstructors :: ListConstructors -dummyConstructors = LC (const "[]") (const "(:)") - -checkDefinition' :: ListConstructors -> Context -> String -> [String] -> Exp -> Err ([(String,Base)],(Exp,Base)) -checkDefinition' list ctx f xs e = - do unless (isLower $ head f) $ fail "Defined functions must start with a lowercase letter." - t@(FunT ts t') <- lookupCtx f ctx `catchErr` \_ -> - fail $ "'" ++ f ++ "' must be used in a rule." - let expect = length ts - given = length xs - unless (expect == given) $ fail $ "'" ++ f ++ "' is used with type " ++ show t ++ " but defined with " ++ show given ++ " argument" ++ plural given ++ "." - e' <- checkExp list (extendContext ctx $ zip xs (map (FunT []) ts)) e t' - return (zip xs ts, (e', t')) - `catchErr` \err -> fail $ "In the definition " ++ unwords (f : xs ++ ["=",show e,";"]) ++ "\n " ++ err - where - plural 1 = "" - plural _ = "s" - -checkExp :: ListConstructors -> Context -> Exp -> Base -> Err Exp -checkExp list ctx (App "[]" []) (ListT t) = return (App (nil list t) []) -checkExp _ _ (App "[]" _) _ = fail $ "[] is applied to too many arguments." -checkExp list ctx (App "(:)" [e,es]) (ListT t) = - do e' <- checkExp list ctx e t - es' <- checkExp list ctx es (ListT t) - return $ App (cons list t) [e',es'] -checkExp _ _ (App "(:)" es) _ = fail $ "(:) takes 2 arguments, but has been given " ++ show (length es) ++ "." -checkExp list ctx e@(App x es) t = - do FunT ts t' <- lookupCtx x ctx - es' <- matchArgs ctx es ts - unless (t == t') $ fail $ show e ++ " has type " ++ show t' ++ ", but something of type " ++ show t ++ " was expected." - return $ App x es' - where - matchArgs ctx es ts - | expect /= given = fail $ "'" ++ x ++ "' takes " ++ show expect ++ " arguments, but has been given " ++ show given ++ "." - | otherwise = zipWithM (checkExp list ctx) es ts - where - expect = length ts - given = length es -checkExp _ _ e@(LitInt _) (BaseT "Integer") = return e -checkExp _ _ e@(LitDouble _) (BaseT "Double") = return e -checkExp _ _ e@(LitChar _) (BaseT "Char") = return e -checkExp _ _ e@(LitString _) (BaseT "String") = return e -checkExp _ _ e t = fail $ show e ++ " does not have type " ++ show t ++ "." - diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 --- a/Utils.hs +++ /dev/null @@ -1,125 +0,0 @@ -{- - BNF Converter: Abstract syntax - Copyright (C) 2004 Author: Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module Utils where - -import Control.Monad (unless) -import System.Directory (createDirectory, doesDirectoryExist) - -infixr 5 +++ -infixr 5 ++++ -infixr 5 +++++ -infixr 2 ||| -infixr 5 ... -infixr 3 *** - - --- printing operations - -a +++ b = a ++ " " ++ b -a ++++ b = a ++ "\n" ++ b -a +++++ b = a ++ "\n\n" ++ b - -prParenth s = if s == "" then "" else "(" ++ s ++ ")" - - --- parser combinators a` la Wadler and Hutton - -type Parser a b = [a] -> [(b,[a])] - -(...) :: Parser a b -> Parser a c -> Parser a (b,c) -(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t] - -(|||) :: Parser a b -> Parser a b -> Parser a b -(p ||| q) s = p s ++ q s - -lit :: (Eq a) => a -> Parser a a -lit x (c:cs) = [(x,cs) | x == c] -lit _ _ = [] - -(***) :: Parser a b -> (b -> c) -> Parser a c -(p *** f) s = [(f x,r) | (x,r) <- p s] - -succeed :: b -> Parser a b -succeed v s = [(v,s)] - -fails :: Parser a b -fails s = [] - --- to get parse results - -parseResults :: Parser a b -> [a] -> [b] -parseResults p s = [x | (x,r) <- p s, null r] - - --- * List utilities - --- | Replace all occurences of a value by another value -replace :: Eq a => - a -- ^ Value to replace - -> a -- ^ Value to replace it with - -> [a] -> [a] -replace x y xs = [ if z == x then y else z | z <- xs] - --- | Split a list on the first occurence of a value. --- Does not include the value that was split on in either --- of the returned lists. -split :: Eq a => a -> [a] -> ([a],[a]) -split x xs = let (ys, zs) = break (==x) xs - in (ys, drop 1 zs) - --- | Split a list on every occurence of a value. --- If the value does not occur in the list, --- the result is the singleton list containing the input list. --- Thus the returned list is never the empty list. -splitAll :: Eq a => a -> [a] -> [[a]] -splitAll _ [] = [[]] -splitAll x xs = let (ys, zs) = break (==x) xs - in ys : case zs of - [] -> [] - _:zs' -> splitAll x zs' - --- * File utilities - --- | Ensure that a directory exists. -prepareDir :: FilePath -> IO () -prepareDir = mapM_ createDirectoryIfNotExists . pathInits - --- | Ensure that a directory exists. All parent directories --- must already exist. -createDirectoryIfNotExists :: FilePath -> IO () -createDirectoryIfNotExists d = do - exists <- doesDirectoryExist d - unless exists (createDirectory d) - -pathSep :: Char -pathSep = '/' - --- | Like the prelude function 'inits' but for path names. --- For example: --- > pathInits "foo/bar" = ["foo","foo/bar"] --- > pathInits "foo/bar/baz.hs" = ["foo","foo/bar","foo/bar/baz.hs"] -pathInits :: String -> [String] -pathInits "" = [] -pathInits xs = let (ys,zs) = split pathSep xs - in ys : map ((ys ++ [pathSep]) ++) (pathInits zs) - --- | Like basename(1), remove all leading directories from a path name. -basename :: String -> String -basename = last . splitAll pathSep diff --git a/dist/build/autogen/Paths_BNFC.hs b/dist/build/autogen/Paths_BNFC.hs deleted file mode 100644 --- a/dist/build/autogen/Paths_BNFC.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Paths_BNFC ( - version, - getBinDir, getLibDir, getDataDir, getLibexecDir, - getDataFileName - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -catchIO = Exception.catch - - -version :: Version -version = Version {versionBranch = [2,4,2,1], versionTags = []} -bindir, libdir, datadir, libexecdir :: FilePath - -bindir = "/home/abel/.cabal/bin" -libdir = "/home/abel/.cabal/lib/BNFC-2.4.2.1/ghc-7.4.1" -datadir = "/home/abel/.cabal/share/BNFC-2.4.2.1" -libexecdir = "/home/abel/.cabal/libexec" - -getBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath -getBinDir = catchIO (getEnv "BNFC_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "BNFC_libdir") (\_ -> return libdir) -getDataDir = catchIO (getEnv "BNFC_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "BNFC_libexecdir") (\_ -> return libexecdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/dist/build/autogen/cabal_macros.h b/dist/build/autogen/cabal_macros.h deleted file mode 100644 --- a/dist/build/autogen/cabal_macros.h +++ /dev/null @@ -1,37 +0,0 @@ -/* DO NOT EDIT: This file is automatically generated by Cabal */ - -/* package array-0.4.0.0 */ -#define VERSION_array "0.4.0.0" -#define MIN_VERSION_array(major1,major2,minor) (\ - (major1) < 0 || \ - (major1) == 0 && (major2) < 4 || \ - (major1) == 0 && (major2) == 4 && (minor) <= 0) - -/* package base-4.5.0.0 */ -#define VERSION_base "4.5.0.0" -#define MIN_VERSION_base(major1,major2,minor) (\ - (major1) < 4 || \ - (major1) == 4 && (major2) < 5 || \ - (major1) == 4 && (major2) == 5 && (minor) <= 0) - -/* package directory-1.1.0.2 */ -#define VERSION_directory "1.1.0.2" -#define MIN_VERSION_directory(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 1 || \ - (major1) == 1 && (major2) == 1 && (minor) <= 0) - -/* package mtl-2.0.1.0 */ -#define VERSION_mtl "2.0.1.0" -#define MIN_VERSION_mtl(major1,major2,minor) (\ - (major1) < 2 || \ - (major1) == 2 && (major2) < 0 || \ - (major1) == 2 && (major2) == 0 && (minor) <= 1) - -/* package process-1.1.0.1 */ -#define VERSION_process "1.1.0.1" -#define MIN_VERSION_process(major1,major2,minor) (\ - (major1) < 1 || \ - (major1) == 1 && (major2) < 1 || \ - (major1) == 1 && (major2) == 1 && (minor) <= 0) - diff --git a/dist/build/bnfc/bnfc b/dist/build/bnfc/bnfc deleted file mode 100644 # file too large to diff: dist/build/bnfc/bnfc diff --git a/dist/build/bnfc/bnfc-tmp/AbsBNF.hi b/dist/build/bnfc/bnfc-tmp/AbsBNF.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/AbsBNF.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/AbsBNF.o b/dist/build/bnfc/bnfc-tmp/AbsBNF.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/AbsBNF.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CAbstoCSharpAbs.hi b/dist/build/bnfc/bnfc-tmp/CAbstoCSharpAbs.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CAbstoCSharpAbs.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CAbstoCSharpAbs.o b/dist/build/bnfc/bnfc-tmp/CAbstoCSharpAbs.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CAbstoCSharpAbs.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CAbstoCSharpAbstractVisitSkeleton.hi b/dist/build/bnfc/bnfc-tmp/CAbstoCSharpAbstractVisitSkeleton.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CAbstoCSharpAbstractVisitSkeleton.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CAbstoCSharpAbstractVisitSkeleton.o b/dist/build/bnfc/bnfc-tmp/CAbstoCSharpAbstractVisitSkeleton.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CAbstoCSharpAbstractVisitSkeleton.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CAbstoCSharpVisitSkeleton.hi b/dist/build/bnfc/bnfc-tmp/CAbstoCSharpVisitSkeleton.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CAbstoCSharpVisitSkeleton.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CAbstoCSharpVisitSkeleton.o b/dist/build/bnfc/bnfc-tmp/CAbstoCSharpVisitSkeleton.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CAbstoCSharpVisitSkeleton.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CF.hi b/dist/build/bnfc/bnfc-tmp/CF.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CF.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CF.o b/dist/build/bnfc/bnfc-tmp/CF.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CF.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoAbstract.hi b/dist/build/bnfc/bnfc-tmp/CFtoAbstract.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoAbstract.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoAbstract.o b/dist/build/bnfc/bnfc-tmp/CFtoAbstract.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoAbstract.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoAbstractGADT.hi b/dist/build/bnfc/bnfc-tmp/CFtoAbstractGADT.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoAbstractGADT.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoAbstractGADT.o b/dist/build/bnfc/bnfc-tmp/CFtoAbstractGADT.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoAbstractGADT.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoAbstractVisitor.hi b/dist/build/bnfc/bnfc-tmp/CFtoAbstractVisitor.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoAbstractVisitor.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoAbstractVisitor.o b/dist/build/bnfc/bnfc-tmp/CFtoAbstractVisitor.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoAbstractVisitor.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoAlex.hi b/dist/build/bnfc/bnfc-tmp/CFtoAlex.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoAlex.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoAlex.o b/dist/build/bnfc/bnfc-tmp/CFtoAlex.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoAlex.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoAlex2.hi b/dist/build/bnfc/bnfc-tmp/CFtoAlex2.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoAlex2.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoAlex2.o b/dist/build/bnfc/bnfc-tmp/CFtoAlex2.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoAlex2.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoAllVisitor.hi b/dist/build/bnfc/bnfc-tmp/CFtoAllVisitor.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoAllVisitor.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoAllVisitor.o b/dist/build/bnfc/bnfc-tmp/CFtoAllVisitor.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoAllVisitor.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoBison.hi b/dist/build/bnfc/bnfc-tmp/CFtoBison.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoBison.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoBison.o b/dist/build/bnfc/bnfc-tmp/CFtoBison.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoBison.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoBisonC.hi b/dist/build/bnfc/bnfc-tmp/CFtoBisonC.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoBisonC.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoBisonC.o b/dist/build/bnfc/bnfc-tmp/CFtoBisonC.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoBisonC.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoBisonSTL.hi b/dist/build/bnfc/bnfc-tmp/CFtoBisonSTL.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoBisonSTL.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoBisonSTL.o b/dist/build/bnfc/bnfc-tmp/CFtoBisonSTL.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoBisonSTL.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCAbs.hi b/dist/build/bnfc/bnfc-tmp/CFtoCAbs.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCAbs.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCAbs.o b/dist/build/bnfc/bnfc-tmp/CFtoCAbs.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCAbs.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCPPAbs.hi b/dist/build/bnfc/bnfc-tmp/CFtoCPPAbs.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCPPAbs.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCPPAbs.o b/dist/build/bnfc/bnfc-tmp/CFtoCPPAbs.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCPPAbs.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCPPPrinter.hi b/dist/build/bnfc/bnfc-tmp/CFtoCPPPrinter.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCPPPrinter.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCPPPrinter.o b/dist/build/bnfc/bnfc-tmp/CFtoCPPPrinter.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCPPPrinter.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCPrinter.hi b/dist/build/bnfc/bnfc-tmp/CFtoCPrinter.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCPrinter.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCPrinter.o b/dist/build/bnfc/bnfc-tmp/CFtoCPrinter.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCPrinter.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCSharpPrinter.hi b/dist/build/bnfc/bnfc-tmp/CFtoCSharpPrinter.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCSharpPrinter.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCSharpPrinter.o b/dist/build/bnfc/bnfc-tmp/CFtoCSharpPrinter.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCSharpPrinter.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCSkel.hi b/dist/build/bnfc/bnfc-tmp/CFtoCSkel.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCSkel.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCSkel.o b/dist/build/bnfc/bnfc-tmp/CFtoCSkel.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCSkel.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCVisitSkel.hi b/dist/build/bnfc/bnfc-tmp/CFtoCVisitSkel.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCVisitSkel.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCVisitSkel.o b/dist/build/bnfc/bnfc-tmp/CFtoCVisitSkel.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCVisitSkel.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCVisitSkelSTL.hi b/dist/build/bnfc/bnfc-tmp/CFtoCVisitSkelSTL.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCVisitSkelSTL.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCVisitSkelSTL.o b/dist/build/bnfc/bnfc-tmp/CFtoCVisitSkelSTL.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCVisitSkelSTL.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoComposVisitor.hi b/dist/build/bnfc/bnfc-tmp/CFtoComposVisitor.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoComposVisitor.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoComposVisitor.o b/dist/build/bnfc/bnfc-tmp/CFtoComposVisitor.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoComposVisitor.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCup.hi b/dist/build/bnfc/bnfc-tmp/CFtoCup.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCup.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCup.o b/dist/build/bnfc/bnfc-tmp/CFtoCup.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCup.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCup15.hi b/dist/build/bnfc/bnfc-tmp/CFtoCup15.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCup15.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoCup15.o b/dist/build/bnfc/bnfc-tmp/CFtoCup15.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoCup15.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoFlex.hi b/dist/build/bnfc/bnfc-tmp/CFtoFlex.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoFlex.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoFlex.o b/dist/build/bnfc/bnfc-tmp/CFtoFlex.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoFlex.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoFlexC.hi b/dist/build/bnfc/bnfc-tmp/CFtoFlexC.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoFlexC.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoFlexC.o b/dist/build/bnfc/bnfc-tmp/CFtoFlexC.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoFlexC.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoFoldVisitor.hi b/dist/build/bnfc/bnfc-tmp/CFtoFoldVisitor.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoFoldVisitor.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoFoldVisitor.o b/dist/build/bnfc/bnfc-tmp/CFtoFoldVisitor.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoFoldVisitor.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoGPLEX.hi b/dist/build/bnfc/bnfc-tmp/CFtoGPLEX.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoGPLEX.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoGPLEX.o b/dist/build/bnfc/bnfc-tmp/CFtoGPLEX.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoGPLEX.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoGPPG.hi b/dist/build/bnfc/bnfc-tmp/CFtoGPPG.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoGPPG.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoGPPG.o b/dist/build/bnfc/bnfc-tmp/CFtoGPPG.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoGPPG.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoHappy.hi b/dist/build/bnfc/bnfc-tmp/CFtoHappy.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoHappy.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoHappy.o b/dist/build/bnfc/bnfc-tmp/CFtoHappy.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoHappy.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoHappyProfile.hi b/dist/build/bnfc/bnfc-tmp/CFtoHappyProfile.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoHappyProfile.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoHappyProfile.o b/dist/build/bnfc/bnfc-tmp/CFtoHappyProfile.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoHappyProfile.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJLex.hi b/dist/build/bnfc/bnfc-tmp/CFtoJLex.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJLex.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJLex.o b/dist/build/bnfc/bnfc-tmp/CFtoJLex.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJLex.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJLex15.hi b/dist/build/bnfc/bnfc-tmp/CFtoJLex15.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJLex15.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJLex15.o b/dist/build/bnfc/bnfc-tmp/CFtoJLex15.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJLex15.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJavaAbs.hi b/dist/build/bnfc/bnfc-tmp/CFtoJavaAbs.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJavaAbs.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJavaAbs.o b/dist/build/bnfc/bnfc-tmp/CFtoJavaAbs.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJavaAbs.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJavaAbs15.hi b/dist/build/bnfc/bnfc-tmp/CFtoJavaAbs15.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJavaAbs15.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJavaAbs15.o b/dist/build/bnfc/bnfc-tmp/CFtoJavaAbs15.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJavaAbs15.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJavaPrinter.hi b/dist/build/bnfc/bnfc-tmp/CFtoJavaPrinter.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJavaPrinter.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJavaPrinter.o b/dist/build/bnfc/bnfc-tmp/CFtoJavaPrinter.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJavaPrinter.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJavaPrinter15.hi b/dist/build/bnfc/bnfc-tmp/CFtoJavaPrinter15.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJavaPrinter15.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJavaPrinter15.o b/dist/build/bnfc/bnfc-tmp/CFtoJavaPrinter15.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJavaPrinter15.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJavaSkeleton.hi b/dist/build/bnfc/bnfc-tmp/CFtoJavaSkeleton.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJavaSkeleton.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoJavaSkeleton.o b/dist/build/bnfc/bnfc-tmp/CFtoJavaSkeleton.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoJavaSkeleton.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoLatex.hi b/dist/build/bnfc/bnfc-tmp/CFtoLatex.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoLatex.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoLatex.o b/dist/build/bnfc/bnfc-tmp/CFtoLatex.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoLatex.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoLayout.hi b/dist/build/bnfc/bnfc-tmp/CFtoLayout.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoLayout.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoLayout.o b/dist/build/bnfc/bnfc-tmp/CFtoLayout.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoLayout.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlAbs.hi b/dist/build/bnfc/bnfc-tmp/CFtoOCamlAbs.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlAbs.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlAbs.o b/dist/build/bnfc/bnfc-tmp/CFtoOCamlAbs.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlAbs.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlLex.hi b/dist/build/bnfc/bnfc-tmp/CFtoOCamlLex.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlLex.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlLex.o b/dist/build/bnfc/bnfc-tmp/CFtoOCamlLex.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlLex.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlPrinter.hi b/dist/build/bnfc/bnfc-tmp/CFtoOCamlPrinter.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlPrinter.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlPrinter.o b/dist/build/bnfc/bnfc-tmp/CFtoOCamlPrinter.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlPrinter.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlShow.hi b/dist/build/bnfc/bnfc-tmp/CFtoOCamlShow.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlShow.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlShow.o b/dist/build/bnfc/bnfc-tmp/CFtoOCamlShow.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlShow.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlTemplate.hi b/dist/build/bnfc/bnfc-tmp/CFtoOCamlTemplate.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlTemplate.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlTemplate.o b/dist/build/bnfc/bnfc-tmp/CFtoOCamlTemplate.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlTemplate.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlTest.hi b/dist/build/bnfc/bnfc-tmp/CFtoOCamlTest.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlTest.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlTest.o b/dist/build/bnfc/bnfc-tmp/CFtoOCamlTest.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlTest.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlYacc.hi b/dist/build/bnfc/bnfc-tmp/CFtoOCamlYacc.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlYacc.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoOCamlYacc.o b/dist/build/bnfc/bnfc-tmp/CFtoOCamlYacc.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoOCamlYacc.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoPrinter.hi b/dist/build/bnfc/bnfc-tmp/CFtoPrinter.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoPrinter.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoPrinter.o b/dist/build/bnfc/bnfc-tmp/CFtoPrinter.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoPrinter.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoPrinterGADT.hi b/dist/build/bnfc/bnfc-tmp/CFtoPrinterGADT.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoPrinterGADT.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoPrinterGADT.o b/dist/build/bnfc/bnfc-tmp/CFtoPrinterGADT.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoPrinterGADT.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoSTLAbs.hi b/dist/build/bnfc/bnfc-tmp/CFtoSTLAbs.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoSTLAbs.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoSTLAbs.o b/dist/build/bnfc/bnfc-tmp/CFtoSTLAbs.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoSTLAbs.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoSTLPrinter.hi b/dist/build/bnfc/bnfc-tmp/CFtoSTLPrinter.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoSTLPrinter.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoSTLPrinter.o b/dist/build/bnfc/bnfc-tmp/CFtoSTLPrinter.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoSTLPrinter.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoTemplate.hi b/dist/build/bnfc/bnfc-tmp/CFtoTemplate.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoTemplate.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoTemplate.o b/dist/build/bnfc/bnfc-tmp/CFtoTemplate.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoTemplate.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoTemplateGADT.hi b/dist/build/bnfc/bnfc-tmp/CFtoTemplateGADT.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoTemplateGADT.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoTemplateGADT.o b/dist/build/bnfc/bnfc-tmp/CFtoTemplateGADT.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoTemplateGADT.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoTxt.hi b/dist/build/bnfc/bnfc-tmp/CFtoTxt.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoTxt.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoTxt.o b/dist/build/bnfc/bnfc-tmp/CFtoTxt.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoTxt.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoVisitSkel.hi b/dist/build/bnfc/bnfc-tmp/CFtoVisitSkel.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoVisitSkel.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoVisitSkel.o b/dist/build/bnfc/bnfc-tmp/CFtoVisitSkel.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoVisitSkel.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoVisitSkel15.hi b/dist/build/bnfc/bnfc-tmp/CFtoVisitSkel15.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoVisitSkel15.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoVisitSkel15.o b/dist/build/bnfc/bnfc-tmp/CFtoVisitSkel15.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoVisitSkel15.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoXML.hi b/dist/build/bnfc/bnfc-tmp/CFtoXML.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoXML.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CFtoXML.o b/dist/build/bnfc/bnfc-tmp/CFtoXML.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CFtoXML.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CPPTop.hi b/dist/build/bnfc/bnfc-tmp/CPPTop.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CPPTop.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CPPTop.o b/dist/build/bnfc/bnfc-tmp/CPPTop.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CPPTop.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CSharpTop.hi b/dist/build/bnfc/bnfc-tmp/CSharpTop.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CSharpTop.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CSharpTop.o b/dist/build/bnfc/bnfc-tmp/CSharpTop.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CSharpTop.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CSharpUtils.hi b/dist/build/bnfc/bnfc-tmp/CSharpUtils.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CSharpUtils.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CSharpUtils.o b/dist/build/bnfc/bnfc-tmp/CSharpUtils.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CSharpUtils.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CTop.hi b/dist/build/bnfc/bnfc-tmp/CTop.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CTop.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/CTop.o b/dist/build/bnfc/bnfc-tmp/CTop.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/CTop.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/ErrM.hi b/dist/build/bnfc/bnfc-tmp/ErrM.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/ErrM.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/ErrM.o b/dist/build/bnfc/bnfc-tmp/ErrM.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/ErrM.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/FSharpTop.hi b/dist/build/bnfc/bnfc-tmp/FSharpTop.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/FSharpTop.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/FSharpTop.o b/dist/build/bnfc/bnfc-tmp/FSharpTop.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/FSharpTop.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/GetCF.hi b/dist/build/bnfc/bnfc-tmp/GetCF.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/GetCF.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/GetCF.o b/dist/build/bnfc/bnfc-tmp/GetCF.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/GetCF.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/HaskellGADTCommon.hi b/dist/build/bnfc/bnfc-tmp/HaskellGADTCommon.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/HaskellGADTCommon.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/HaskellGADTCommon.o b/dist/build/bnfc/bnfc-tmp/HaskellGADTCommon.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/HaskellGADTCommon.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/HaskellTop.hi b/dist/build/bnfc/bnfc-tmp/HaskellTop.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/HaskellTop.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/HaskellTop.o b/dist/build/bnfc/bnfc-tmp/HaskellTop.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/HaskellTop.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/HaskellTopGADT.hi b/dist/build/bnfc/bnfc-tmp/HaskellTopGADT.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/HaskellTopGADT.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/HaskellTopGADT.o b/dist/build/bnfc/bnfc-tmp/HaskellTopGADT.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/HaskellTopGADT.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/JavaTop.hi b/dist/build/bnfc/bnfc-tmp/JavaTop.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/JavaTop.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/JavaTop.o b/dist/build/bnfc/bnfc-tmp/JavaTop.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/JavaTop.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/JavaTop15.hi b/dist/build/bnfc/bnfc-tmp/JavaTop15.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/JavaTop15.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/JavaTop15.o b/dist/build/bnfc/bnfc-tmp/JavaTop15.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/JavaTop15.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/LexBNF.hi b/dist/build/bnfc/bnfc-tmp/LexBNF.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/LexBNF.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/LexBNF.hs b/dist/build/bnfc/bnfc-tmp/LexBNF.hs --- a/dist/build/bnfc/bnfc-tmp/LexBNF.hs +++ b/dist/build/bnfc/bnfc-tmp/LexBNF.hs @@ -1,11 +1,15 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 3 "LexBNF.x" #-} +{-# LANGUAGE CPP,MagicHash #-} +{-# LINE 3 "src/LexBNF.x" #-} {-# OPTIONS -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -w #-} module LexBNF where +import qualified Data.Bits +import Data.Word (Word8) + #if __GLASGOW_HASKELL__ >= 603 #include "ghcconfig.h" #elif defined(__GLASGOW_HASKELL__) @@ -17,7 +21,7 @@ import Data.Array.Base (unsafeAt) #else import Array -import Data.Char (ord) +import Char (ord) #endif #if __GLASGOW_HASKELL__ >= 503 import GHC.Exts @@ -25,19 +29,19 @@ 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\x16\x00\x00\x00\x14\x00\x00\x00\x9c\x00\x00\x00\x6c\x01\x00\x00\x00\x00\x00\x00\x17\x01\x00\x00\xe7\x01\x00\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x9d\x00\x00\x00\xd3\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_base = AlexA# "\xf8\xff\xff\xff\x49\x00\x00\x00\x1c\x01\x00\x00\xc9\xff\xff\xff\xe0\xff\xff\xff\x9c\x01\x00\x00\x6f\x02\x00\x00\x2d\x00\x00\x00\xef\x02\x00\x00\xef\x03\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x00\x00\xe0\x04\x00\x00\xdd\x01\x00\x00\x60\x05\x00\x00\x24\x06\x00\x00\x82\x06\x00\x00\x20\x05\x00\x00\x00\x00\x00\x00\x38\x06\x00\x00\xdb\xff\xff\xff\x47\x00\x00\x00\x5a\x00\x00\x00\x38\x07\x00\x00\x39\x07\x00\x00\xfc\x07\x00\x00\xbc\x07\x00\x00\x00\x00\x00\x00\xb2\x08\x00\x00\x85\x09\x00\x00\x00\x00\x00\x00\x78\x00\x00\x00\xdc\xff\xff\xff\xdd\xff\xff\xff\x00\x00\x00\x00\xdf\xff\xff\xff\x5e\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x7a\x06\x00\x00\x7c\x00\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\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x05\x00\x0e\x00\xff\xff\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x0f\x00\x0e\x00\xff\xff\x0e\x00\xff\xff\x0e\x00\xff\xff\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\x10\x00\x0e\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\xff\xff\x0e\x00\xff\xff\x0e\x00\xff\xff\x0d\x00\x1e\x00\x00\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\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\x12\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x15\x00\xff\xff\x1a\x00\x18\x00\x12\x00\x15\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\xff\xff\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x15\x00\x00\x00\x00\x00\x1f\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x16\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\xff\xff\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\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\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x16\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +alex_table = AlexA# "\x00\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x23\x00\x27\x00\x17\x00\x1d\x00\x06\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x20\x00\x03\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x21\x00\x23\x00\x00\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x24\x00\x23\x00\x00\x00\x23\x00\x00\x00\x23\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x23\x00\x04\x00\x23\x00\x00\x00\x23\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x22\x00\x23\x00\x23\x00\x02\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x00\x00\x00\x00\x00\x00\x04\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x04\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\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\x00\x00\x1f\x00\x00\x00\x00\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\x09\x00\x0a\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\x01\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\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\x09\x00\x0a\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\x1a\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x01\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x09\x00\x0a\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\x05\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x07\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\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\x00\x00\x00\x00\x0d\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x1b\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\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\x26\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\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\x11\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\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x10\x00\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x1a\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1b\x00\x05\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x14\x00\x08\x00\x0b\x00\x0b\x00\x0b\x00\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x09\x00\x0a\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\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\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\x3a\x00\x3d\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x27\x00\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\x5c\x00\x27\x00\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5c\x00\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\x6e\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x74\x00\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\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3d\x00\x27\x00\x2d\x00\x2d\x00\x2d\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\x20\x00\x3a\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\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\x3a\x00\x3b\x00\xff\xff\x3d\x00\xff\xff\x3f\x00\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\x5b\x00\x27\x00\x5d\x00\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\x7b\x00\x7c\x00\x7d\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x5c\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\x20\x00\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x74\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\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\xff\xff\xff\xff\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\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\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\x7d\x00\xff\xff\xff\xff\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\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\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\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\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\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\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\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\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\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\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\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\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\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\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\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\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\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\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\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\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\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\xff\xff\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\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\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\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\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xc2\x00\xc3\x00\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\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\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\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\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x65\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\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xbf\x00\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\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\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\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\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\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\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\xff\xff\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\xff\xff\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc2\x00\xc3\x00\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\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\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\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\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\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\xd7\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\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\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\xff\xff\xff\xff\xff\xff\xc3\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"# alex_deflt :: AlexAddr -alex_deflt = AlexA# "\x11\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\x18\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +alex_deflt = AlexA# "\xff\xff\x06\x00\x06\x00\xff\xff\xff\xff\xff\xff\x06\x00\xff\xff\xff\xff\x06\x00\x06\x00\x13\x00\x13\x00\x04\x00\x04\x00\xff\xff\x18\x00\xff\xff\x18\x00\x1c\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x06\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"# -alex_accept = listArray (0::Int,32) [[],[],[(AlexAccSkip)],[(AlexAccSkip)],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[],[],[],[(AlexAcc (alex_action_6))],[],[],[],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_8))],[],[],[]] -{-# LINE 34 "LexBNF.x" #-} +alex_accept = listArray (0::Int,42) [[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(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_6))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_8))]] +{-# LINE 38 "src/LexBNF.x" #-} tok f p s = f p s @@ -46,12 +50,12 @@ 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 + TS !String !Int -- 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) @@ -64,17 +68,20 @@ tokenPos (Err (Pn _ l _) :_) = "line " ++ show l tokenPos _ = "end of file" +tokenPosn (PT p _) = p +tokenPosn (Err p) = p +tokenLineCol = posLineCol . tokenPosn posLineCol (Pn _ l c) = (l,c) mkPosToken t@(PT p _) = (posLineCol p, prToken t) prToken t = case t of - PT _ (TS s) -> s - PT _ (TI s) -> s - PT _ (TV s) -> s - PT _ (TD s) -> s - PT _ (TC s) -> s + PT _ (TS s _) -> s + PT _ (TL 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) @@ -86,11 +93,12 @@ | s > a = treeFind right | s == a = t -resWords = b "lower" (b "entrypoints" (b "comment" (b "coercions" (b "char" N N) N) (b "digit" (b "define" N N) N)) (b "layout" (b "internal" (b "eps" N N) N) (b "letter" N N))) (b "terminator" (b "rules" (b "position" (b "nonempty" N N) N) (b "stop" (b "separator" N N) N)) (b "upper" (b "toplevel" (b "token" N N) N) (b "views" N N))) - where b s = B s (TS s) +resWords = b "digit" 21 (b "=" 11 (b "-" 6 (b "*" 3 (b ")" 2 (b "(" 1 N N) N) (b "," 5 (b "+" 4 N N) N)) (b "::=" 9 (b ":" 8 (b "." 7 N N) N) (b ";" 10 N N))) (b "char" 16 (b "]" 14 (b "[" 13 (b "?" 12 N N) N) (b "_" 15 N N)) (b "define" 19 (b "comment" 18 (b "coercions" 17 N N) N) (b "delimiters" 20 N N)))) (b "separator" 31 (b "letter" 26 (b "internal" 24 (b "eps" 23 (b "entrypoints" 22 N N) N) (b "layout" 25 N N)) (b "position" 29 (b "nonempty" 28 (b "lower" 27 N N) N) (b "rules" 30 N N))) (b "upper" 36 (b "token" 34 (b "terminator" 33 (b "stop" 32 N N) N) (b "toplevel" 35 N N)) (b "|" 39 (b "{" 38 (b "views" 37 N N) N) (b "}" 40 N N)))) + where b s n = let bs = id s + in B bs (TS bs n) unescapeInitTail :: String -> String -unescapeInitTail = unesc . tail where +unescapeInitTail = id . unesc . tail . id where unesc s = case s of '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs '\\':'n':cs -> '\n' : unesc cs @@ -115,31 +123,59 @@ 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 +type Byte = Word8 +type AlexInput = (Posn, -- current position, + Char, -- previous char + [Byte], -- pending bytes on the current char + String) -- current input string + tokens :: String -> [Token] -tokens str = go (alexStartPos, '\n', str) +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') + 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 (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)) +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s)) +alexGetByte (p, _, [], s) = + case s of + [] -> Nothing + (c:s) -> + let p' = alexMove p c + (b:bs) = utf8Encode c + in p' `seq` Just (b, (p', c, bs, s)) alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (p, c, s) = c +alexInputPrevChar (p, c, bs, s) = c -alex_action_3 = tok (\p s -> PT p (TS $ share s)) + -- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +utf8Encode :: Char -> [Word8] +utf8Encode = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) + , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + +alex_action_3 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) alex_action_4 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) alex_action_5 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) alex_action_6 = tok (\p s -> PT p (TC $ share s)) @@ -147,8 +183,7 @@ alex_action_8 = tok (\p s -> PT p (TD $ share s)) {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} +{-# LINE 1 "" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- ----------------------------------------------------------------------------- -- ALEX TEMPLATE @@ -159,9 +194,9 @@ -- ----------------------------------------------------------------------------- -- INTERNALS and main scanner engine -{-# LINE 35 "templates/GenericTemplate.hs" #-} +{-# LINE 37 "templates/GenericTemplate.hs" #-} -{-# LINE 45 "templates/GenericTemplate.hs" #-} +{-# LINE 47 "templates/GenericTemplate.hs" #-} data AlexAddr = AlexA# Addr# @@ -175,10 +210,10 @@ #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# + 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 @@ -192,14 +227,14 @@ #ifdef WORDS_BIGENDIAN narrow32Int# i where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + !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# + !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 @@ -234,7 +269,7 @@ alexScanUser user input (I# (sc)) = case alex_scan_tkn user input 0# input sc AlexNone of (AlexNone, input') -> - case alexGetChar input of + case alexGetByte input of Nothing -> @@ -246,17 +281,17 @@ AlexError input' - (AlexLastSkip input len, _) -> + (AlexLastSkip input'' len, _) -> - AlexSkip input len + AlexSkip input'' len - (AlexLastAcc k input len, _) -> + (AlexLastAcc k input''' len, _) -> - AlexToken input len k + AlexToken input''' len k -- Push the input through the DFA, remembering the most recent accepting @@ -265,22 +300,22 @@ 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))) + new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) in new_acc `seq` - case alexGetChar input of + case alexGetByte 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 + (base) = alexIndexInt32OffAddr alex_base s + ((I# (ord_c))) = fromIntegral c + (offset) = (base +# ord_c) + (check) = alexIndexInt16OffAddr alex_check offset - new_s = if (offset >=# 0#) && (check ==# ord_c) + (new_s) = if (offset >=# 0#) && (check ==# ord_c) then alexIndexInt16OffAddr alex_table offset else alexIndexInt16OffAddr alex_deflt s in @@ -288,18 +323,19 @@ -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#) + _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) 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 + check_accs (AlexAccPred a predx : rest) + | predx user orig_input (I# (len)) input = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkipPred pred : rest) - | pred user orig_input (I# (len)) input + check_accs (AlexAccSkipPred predx : rest) + | predx user orig_input (I# (len)) input = AlexLastSkip input (I# (len)) check_accs (_ : rest) = check_accs rest @@ -308,6 +344,11 @@ | AlexLastAcc a !AlexInput !Int | AlexLastSkip !AlexInput !Int +instance Functor AlexLastAcc where + fmap f AlexNone = AlexNone + fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z + fmap f (AlexLastSkip x y) = AlexLastSkip x y + data AlexAcc a user = AlexAcc a | AlexAccSkip @@ -324,6 +365,8 @@ --alexPrevCharIsPred :: Char -> AlexAccPred _ alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +alexPrevCharMatches f _ input _ _ = f (alexInputPrevChar input) --alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input diff --git a/dist/build/bnfc/bnfc-tmp/LexBNF.o b/dist/build/bnfc/bnfc-tmp/LexBNF.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/LexBNF.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/Main.hi b/dist/build/bnfc/bnfc-tmp/Main.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/Main.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/Main.o b/dist/build/bnfc/bnfc-tmp/Main.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/Main.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/MkErrM.hi b/dist/build/bnfc/bnfc-tmp/MkErrM.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/MkErrM.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/MkErrM.o b/dist/build/bnfc/bnfc-tmp/MkErrM.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/MkErrM.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/MkSharedString.hi b/dist/build/bnfc/bnfc-tmp/MkSharedString.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/MkSharedString.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/MkSharedString.o b/dist/build/bnfc/bnfc-tmp/MkSharedString.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/MkSharedString.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/MultiView.hi b/dist/build/bnfc/bnfc-tmp/MultiView.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/MultiView.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/MultiView.o b/dist/build/bnfc/bnfc-tmp/MultiView.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/MultiView.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/NamedVariables.hi b/dist/build/bnfc/bnfc-tmp/NamedVariables.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/NamedVariables.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/NamedVariables.o b/dist/build/bnfc/bnfc-tmp/NamedVariables.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/NamedVariables.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/OCamlTop.hi b/dist/build/bnfc/bnfc-tmp/OCamlTop.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/OCamlTop.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/OCamlTop.o b/dist/build/bnfc/bnfc-tmp/OCamlTop.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/OCamlTop.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/OCamlUtil.hi b/dist/build/bnfc/bnfc-tmp/OCamlUtil.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/OCamlUtil.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/OCamlUtil.o b/dist/build/bnfc/bnfc-tmp/OCamlUtil.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/OCamlUtil.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/OOAbstract.hi b/dist/build/bnfc/bnfc-tmp/OOAbstract.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/OOAbstract.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/OOAbstract.o b/dist/build/bnfc/bnfc-tmp/OOAbstract.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/OOAbstract.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/ParBNF.hi b/dist/build/bnfc/bnfc-tmp/ParBNF.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/ParBNF.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/ParBNF.hs b/dist/build/bnfc/bnfc-tmp/ParBNF.hs new file mode 100644 --- /dev/null +++ b/dist/build/bnfc/bnfc-tmp/ParBNF.hs @@ -0,0 +1,1705 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} +module ParBNF where +import AbsBNF +import LexBNF +import ErrM +import qualified Data.Array as Happy_Data_Array +import qualified GHC.Exts as Happy_GHC_Exts + +-- parser produced by Happy Version 1.18.10 + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +happyIn36 :: (String) -> (HappyAbsSyn ) +happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn36 #-} +happyOut36 :: (HappyAbsSyn ) -> (String) +happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut36 #-} +happyIn37 :: (Ident) -> (HappyAbsSyn ) +happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn37 #-} +happyOut37 :: (HappyAbsSyn ) -> (Ident) +happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut37 #-} +happyIn38 :: (Integer) -> (HappyAbsSyn ) +happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn38 #-} +happyOut38 :: (HappyAbsSyn ) -> (Integer) +happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut38 #-} +happyIn39 :: (Char) -> (HappyAbsSyn ) +happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn39 #-} +happyOut39 :: (HappyAbsSyn ) -> (Char) +happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut39 #-} +happyIn40 :: (Double) -> (HappyAbsSyn ) +happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn40 #-} +happyOut40 :: (HappyAbsSyn ) -> (Double) +happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut40 #-} +happyIn41 :: (LGrammar) -> (HappyAbsSyn ) +happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn41 #-} +happyOut41 :: (HappyAbsSyn ) -> (LGrammar) +happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut41 #-} +happyIn42 :: (LDef) -> (HappyAbsSyn ) +happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn42 #-} +happyOut42 :: (HappyAbsSyn ) -> (LDef) +happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut42 #-} +happyIn43 :: ([LDef]) -> (HappyAbsSyn ) +happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn43 #-} +happyOut43 :: (HappyAbsSyn ) -> ([LDef]) +happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut43 #-} +happyIn44 :: (Grammar) -> (HappyAbsSyn ) +happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn44 #-} +happyOut44 :: (HappyAbsSyn ) -> (Grammar) +happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut44 #-} +happyIn45 :: ([Def]) -> (HappyAbsSyn ) +happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn45 #-} +happyOut45 :: (HappyAbsSyn ) -> ([Def]) +happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut45 #-} +happyIn46 :: ([Item]) -> (HappyAbsSyn ) +happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn46 #-} +happyOut46 :: (HappyAbsSyn ) -> ([Item]) +happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut46 #-} +happyIn47 :: (Def) -> (HappyAbsSyn ) +happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn47 #-} +happyOut47 :: (HappyAbsSyn ) -> (Def) +happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut47 #-} +happyIn48 :: (Item) -> (HappyAbsSyn ) +happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn48 #-} +happyOut48 :: (HappyAbsSyn ) -> (Item) +happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut48 #-} +happyIn49 :: (Cat) -> (HappyAbsSyn ) +happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn49 #-} +happyOut49 :: (HappyAbsSyn ) -> (Cat) +happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut49 #-} +happyIn50 :: (Label) -> (HappyAbsSyn ) +happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn50 #-} +happyOut50 :: (HappyAbsSyn ) -> (Label) +happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut50 #-} +happyIn51 :: (LabelId) -> (HappyAbsSyn ) +happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn51 #-} +happyOut51 :: (HappyAbsSyn ) -> (LabelId) +happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut51 #-} +happyIn52 :: (ProfItem) -> (HappyAbsSyn ) +happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn52 #-} +happyOut52 :: (HappyAbsSyn ) -> (ProfItem) +happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut52 #-} +happyIn53 :: (IntList) -> (HappyAbsSyn ) +happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn53 #-} +happyOut53 :: (HappyAbsSyn ) -> (IntList) +happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut53 #-} +happyIn54 :: ([Integer]) -> (HappyAbsSyn ) +happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn54 #-} +happyOut54 :: (HappyAbsSyn ) -> ([Integer]) +happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut54 #-} +happyIn55 :: ([IntList]) -> (HappyAbsSyn ) +happyIn55 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn55 #-} +happyOut55 :: (HappyAbsSyn ) -> ([IntList]) +happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut55 #-} +happyIn56 :: ([ProfItem]) -> (HappyAbsSyn ) +happyIn56 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn56 #-} +happyOut56 :: (HappyAbsSyn ) -> ([ProfItem]) +happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut56 #-} +happyIn57 :: (Separation) -> (HappyAbsSyn ) +happyIn57 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn57 #-} +happyOut57 :: (HappyAbsSyn ) -> (Separation) +happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut57 #-} +happyIn58 :: (Arg) -> (HappyAbsSyn ) +happyIn58 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn58 #-} +happyOut58 :: (HappyAbsSyn ) -> (Arg) +happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut58 #-} +happyIn59 :: ([Arg]) -> (HappyAbsSyn ) +happyIn59 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn59 #-} +happyOut59 :: (HappyAbsSyn ) -> ([Arg]) +happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut59 #-} +happyIn60 :: (Exp) -> (HappyAbsSyn ) +happyIn60 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn60 #-} +happyOut60 :: (HappyAbsSyn ) -> (Exp) +happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut60 #-} +happyIn61 :: (Exp) -> (HappyAbsSyn ) +happyIn61 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn61 #-} +happyOut61 :: (HappyAbsSyn ) -> (Exp) +happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut61 #-} +happyIn62 :: (Exp) -> (HappyAbsSyn ) +happyIn62 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn62 #-} +happyOut62 :: (HappyAbsSyn ) -> (Exp) +happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut62 #-} +happyIn63 :: ([Exp]) -> (HappyAbsSyn ) +happyIn63 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn63 #-} +happyOut63 :: (HappyAbsSyn ) -> ([Exp]) +happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut63 #-} +happyIn64 :: ([Exp]) -> (HappyAbsSyn ) +happyIn64 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn64 #-} +happyOut64 :: (HappyAbsSyn ) -> ([Exp]) +happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut64 #-} +happyIn65 :: ([String]) -> (HappyAbsSyn ) +happyIn65 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn65 #-} +happyOut65 :: (HappyAbsSyn ) -> ([String]) +happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut65 #-} +happyIn66 :: ([RHS]) -> (HappyAbsSyn ) +happyIn66 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn66 #-} +happyOut66 :: (HappyAbsSyn ) -> ([RHS]) +happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut66 #-} +happyIn67 :: (RHS) -> (HappyAbsSyn ) +happyIn67 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn67 #-} +happyOut67 :: (HappyAbsSyn ) -> (RHS) +happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut67 #-} +happyIn68 :: (MinimumSize) -> (HappyAbsSyn ) +happyIn68 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn68 #-} +happyOut68 :: (HappyAbsSyn ) -> (MinimumSize) +happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut68 #-} +happyIn69 :: (Reg) -> (HappyAbsSyn ) +happyIn69 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn69 #-} +happyOut69 :: (HappyAbsSyn ) -> (Reg) +happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut69 #-} +happyIn70 :: (Reg) -> (HappyAbsSyn ) +happyIn70 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn70 #-} +happyOut70 :: (HappyAbsSyn ) -> (Reg) +happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut70 #-} +happyIn71 :: (Reg) -> (HappyAbsSyn ) +happyIn71 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn71 #-} +happyOut71 :: (HappyAbsSyn ) -> (Reg) +happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut71 #-} +happyIn72 :: (Reg) -> (HappyAbsSyn ) +happyIn72 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn72 #-} +happyOut72 :: (HappyAbsSyn ) -> (Reg) +happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut72 #-} +happyIn73 :: ([Ident]) -> (HappyAbsSyn ) +happyIn73 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn73 #-} +happyOut73 :: (HappyAbsSyn ) -> ([Ident]) +happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut73 #-} +happyInTok :: (Token) -> (HappyAbsSyn ) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> (Token) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x62\x00\x62\x00\x62\x00\x7c\x00\x7c\x00\x00\x00\x7c\x00\x5c\x00\x89\x00\x3d\x00\x3d\x00\xdd\x01\xd7\x01\xdc\x01\xd3\x01\xdb\x01\xbe\x00\xda\x01\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\xd9\x01\x00\x00\x00\x00\xd8\x01\x46\x00\x46\x00\x46\x00\x46\x00\xd6\x01\xd4\x01\x00\x00\xd5\x01\xd2\x01\x00\x00\x00\x00\x36\x00\xd1\x01\x8d\x01\xcf\x01\x46\x00\xce\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x01\x00\x00\x07\x00\xe1\xff\x01\x00\xcd\x01\x00\x00\x5c\x00\xcd\x01\xcd\x01\xcb\x01\xd0\x01\xca\x01\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\xc9\x01\xcc\x01\x00\x00\xc6\x01\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x08\x00\xc6\x01\xc6\x01\xc6\x01\xc6\x01\xfe\x00\x00\x00\xc6\x01\xc6\x01\xc7\x01\xc7\x01\xc8\x01\xc4\x01\xc5\x01\xc3\x01\xc0\x01\xc2\x01\xc1\x01\xbc\x01\xbc\x01\xbc\x01\x00\x00\xbc\x01\xbf\x01\xbd\x01\x00\x00\xb9\x01\x1f\x00\x00\x00\xb9\x01\x89\x00\x00\x00\xb9\x01\x00\x00\xb9\x01\xbe\x01\xbb\x01\xba\x01\xb8\x01\x89\x00\xb8\x01\x05\x00\x6f\x01\xae\x01\xb5\x01\xb7\x01\xb7\x01\xb3\x01\xf4\xff\xac\x01\xb6\x01\xaa\x01\x00\x00\x50\x00\xb2\x01\xa9\x01\x00\x00\xb1\x01\xa7\x01\x9b\x01\x9b\x01\x00\x00\x00\x00\x7c\x00\x62\x00\x9a\x01\x7c\x00\x00\x00\x46\x00\x89\x00\x89\x00\xaf\x01\x99\x01\x00\x00\x98\x01\x00\x00\xb0\x01\x00\x00\x96\x01\x00\x00\x96\x01\x92\x01\x89\x00\xa8\x01\xb4\x01\x00\x00\x64\x01\x00\x00\x9a\x00\x90\x01\xa4\x01\xa6\x01\xa6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x01\xad\x01\x08\x00\x08\x00\x00\x00\x8b\x01\x00\x00\x26\x01\x46\x00\x00\x00\x00\x00\x00\x00\x88\x01\xa0\x01\xab\x01\x46\x00\x46\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x01\x00\x00\x00\x00\xa2\x01\x00\x00\x00\x00\xf8\xff\x80\x01\x89\x00\x00\x00\x46\x00\x00\x00\x80\x01\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x01\xbe\x00\x08\x00\x00\x00\xa5\x01\xa1\x01\x97\x01\x00\x00\x5c\x00\x00\x00\x86\x01\x00\x00\x5c\x00\x00\x00\x7a\x01\x95\x01\x9d\x01\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x9e\x00\xbb\x00\xb9\x00\x65\x01\x75\x01\x93\x01\x77\x01\x89\x01\x7e\x01\x79\x01\xcc\x00\x91\x01\x8f\x01\xa0\x00\xe5\x00\x8a\x01\x87\x01\x92\x00\x84\x01\x3b\x01\x40\x01\x45\x01\x11\x01\xeb\x00\x91\x00\x44\x01\x78\x00\x6d\x01\x5b\x00\x17\x00\x42\x00\xb6\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x94\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x01\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x4f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x01\xe6\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x8c\x01\x7b\x01\x83\x01\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x01\x00\x00\x00\x00\x74\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x01\x68\x01\x57\x01\x51\x01\x06\x00\xbd\x00\x6d\x00\x00\x00\x56\x01\x17\x01\xe9\x00\x05\x01\x4f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\xa9\x00\x03\x00\x6e\x01\x00\x00\xae\x00\x24\x01\xfb\x00\x00\x00\x9f\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\xf7\x00\xc5\x00\xab\x00\xc3\x00\xf4\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\xaa\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x01\xe1\x00\x00\x00\x0d\x00\x42\x01\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x21\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\xa1\x00\xb5\x00\x00\x00\x1e\x00\x2c\x01\x57\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x16\x01\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x01\x00\x00\xef\xff\x02\x00\x4f\x01\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xd5\xff\x00\x00\xd5\xff\xd1\xff\xd1\xff\xce\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\xff\xaa\xff\x00\x00\xa5\xff\x00\x00\xa1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x92\xff\x00\x00\xce\xff\xce\xff\x89\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xff\x75\xff\x00\x00\xdd\xff\x7f\xff\x84\xff\x76\xff\x87\xff\x00\x00\x00\x00\x00\x00\x78\xff\x7c\xff\x80\xff\x7b\xff\x79\xff\x7a\xff\x00\x00\xdb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8a\xff\x8b\xff\x00\x00\x00\x00\x8d\xff\x8f\xff\x00\x00\x98\xff\x9b\xff\x9a\xff\x99\xff\x97\xff\x91\xff\x9e\xff\x9c\xff\x00\x00\x00\x00\x92\xff\xdc\xff\xda\xff\x9b\xff\x94\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa7\xff\x00\x00\x00\x00\xa9\xff\x00\x00\xad\xff\xac\xff\x00\x00\x00\x00\x00\x00\xb4\xff\x00\x00\x00\x00\x00\x00\xb3\xff\x00\x00\xb8\xff\xb9\xff\x00\x00\x00\x00\xbc\xff\x00\x00\xbb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\xff\x89\xff\x00\x00\x00\x00\x00\x00\xd0\xff\x00\x00\xd2\xff\xb4\xff\xd4\xff\x00\x00\xd8\xff\x00\x00\x00\x00\x00\x00\x00\x00\xd9\xff\xd6\xff\x00\x00\xd5\xff\x00\x00\xd1\xff\xcd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xff\x00\x00\xbd\xff\x00\x00\xc6\xff\x00\x00\xa1\xff\xcb\xff\x00\x00\x00\x00\x00\x00\xb5\xff\xb7\xff\x00\x00\xb2\xff\x00\x00\xad\xff\x00\x00\xaa\xff\xaa\xff\xa6\xff\xa4\xff\xa3\xff\xa0\xff\x93\xff\x00\x00\x00\x00\x00\x00\x92\xff\x9d\xff\x00\x00\xce\xff\x88\xff\x00\x00\x83\xff\x82\xff\x81\xff\x00\x00\x00\x00\x00\x00\x00\x00\x85\xff\x77\xff\x7e\xff\x7d\xff\x86\xff\x8c\xff\x8e\xff\x90\xff\x9f\xff\x95\xff\x96\xff\x00\x00\xa8\xff\xae\xff\xab\xff\xb1\xff\x00\x00\xb6\xff\xba\xff\x00\x00\xc2\xff\xca\xff\x00\x00\x00\x00\x00\x00\xbe\xff\x00\x00\xce\xff\x00\x00\x00\x00\xc8\xff\xcf\xff\x74\xff\xd3\xff\xd7\xff\xc4\xff\xc5\xff\xc1\xff\xc7\xff\x00\x00\xa5\xff\x00\x00\xce\xff\x00\x00\x00\x00\x00\x00\xb0\xff\xcc\xff\xc0\xff\x89\xff\xce\xff\xc9\xff\xc3\xff\xad\xff\x00\x00\x00\x00\xaf\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x0d\x00\x01\x00\x0b\x00\x01\x00\x01\x00\x01\x00\x01\x00\x27\x00\x01\x00\x03\x00\x04\x00\x0a\x00\x00\x00\x0d\x00\x20\x00\x2f\x00\x10\x00\x0d\x00\x0c\x00\x0f\x00\x0d\x00\x15\x00\x01\x00\x17\x00\x0a\x00\x03\x00\x1a\x00\x1b\x00\x29\x00\x2a\x00\x15\x00\x01\x00\x03\x00\x2a\x00\x2f\x00\x03\x00\x24\x00\x00\x00\x26\x00\x25\x00\x25\x00\x1d\x00\x25\x00\x0d\x00\x2c\x00\x0f\x00\x2a\x00\x2f\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2f\x00\x01\x00\x21\x00\x22\x00\x23\x00\x25\x00\x06\x00\x01\x00\x01\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0d\x00\x23\x00\x03\x00\x10\x00\x01\x00\x03\x00\x2a\x00\x0d\x00\x15\x00\x0f\x00\x17\x00\x00\x00\x02\x00\x1a\x00\x1b\x00\x16\x00\x0d\x00\x02\x00\x05\x00\x10\x00\x00\x00\x08\x00\x03\x00\x24\x00\x15\x00\x26\x00\x17\x00\x03\x00\x12\x00\x1a\x00\x1b\x00\x2c\x00\x01\x00\x12\x00\x23\x00\x21\x00\x2a\x00\x23\x00\x0d\x00\x24\x00\x1d\x00\x26\x00\x00\x00\x11\x00\x0d\x00\x13\x00\x0f\x00\x2c\x00\x11\x00\x12\x00\x13\x00\x14\x00\x21\x00\x16\x00\x23\x00\x18\x00\x19\x00\x21\x00\x01\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x0a\x00\x21\x00\x22\x00\x29\x00\x2a\x00\x25\x00\x02\x00\x0d\x00\x1d\x00\x0f\x00\x2a\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x16\x00\x01\x00\x18\x00\x19\x00\x0d\x00\x1f\x00\x12\x00\x1d\x00\x1e\x00\x1f\x00\x02\x00\x21\x00\x22\x00\x01\x00\x01\x00\x00\x00\x02\x00\x05\x00\x06\x00\x07\x00\x2a\x00\x0d\x00\x16\x00\x0b\x00\x01\x00\x00\x00\x0e\x00\x0f\x00\x1d\x00\x06\x00\x07\x00\x03\x00\x12\x00\x2a\x00\x0b\x00\x03\x00\x01\x00\x0e\x00\x0f\x00\x03\x00\x01\x00\x11\x00\x01\x00\x13\x00\x01\x00\x06\x00\x07\x00\x06\x00\x0d\x00\x25\x00\x0b\x00\x02\x00\x0b\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x01\x00\x25\x00\x21\x00\x22\x00\x23\x00\x24\x00\x21\x00\x22\x00\x23\x00\x24\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0f\x00\x17\x00\x1f\x00\x25\x00\x21\x00\x25\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x01\x00\x11\x00\x00\x00\x13\x00\x18\x00\x19\x00\x1a\x00\x01\x00\x1c\x00\x18\x00\x19\x00\x1a\x00\x0d\x00\x1c\x00\x18\x00\x19\x00\x1a\x00\x01\x00\x1c\x00\x0d\x00\x20\x00\x1a\x00\x1b\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x01\x00\x1a\x00\x1b\x00\x2a\x00\x03\x00\x04\x00\x1a\x00\x1b\x00\x2f\x00\x18\x00\x19\x00\x1a\x00\x0d\x00\x0c\x00\x18\x00\x19\x00\x1a\x00\x0a\x00\x20\x00\x18\x00\x19\x00\x1a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x1e\x00\x1f\x00\x0a\x00\x10\x00\x0a\x00\x00\x00\x01\x00\x14\x00\x01\x00\x18\x00\x19\x00\x1a\x00\x01\x00\x01\x00\x01\x00\x19\x00\x1a\x00\x0c\x00\x0d\x00\x01\x00\x0d\x00\x1a\x00\x1e\x00\x1f\x00\x1e\x00\x1f\x00\x0f\x00\x10\x00\x01\x00\x0b\x00\x00\x00\x14\x00\x0e\x00\x0f\x00\x08\x00\x08\x00\x09\x00\x01\x00\x0b\x00\x0d\x00\x01\x00\x0e\x00\x0f\x00\x01\x00\x01\x00\x09\x00\x01\x00\x0b\x00\x01\x00\x00\x00\x0e\x00\x0f\x00\x09\x00\x01\x00\x0b\x00\x0d\x00\x0b\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x00\x00\x01\x00\x0d\x00\x00\x00\x20\x00\x00\x00\x20\x00\x03\x00\x04\x00\x23\x00\x10\x00\x00\x00\x0c\x00\x0d\x00\x14\x00\x29\x00\x0c\x00\x10\x00\x17\x00\x15\x00\x0a\x00\x14\x00\x02\x00\x11\x00\x10\x00\x1c\x00\x0e\x00\x0d\x00\x2b\x00\x05\x00\x02\x00\x09\x00\x29\x00\x0e\x00\x09\x00\x0e\x00\x02\x00\x0e\x00\x02\x00\x28\x00\x0e\x00\x0e\x00\x0d\x00\x29\x00\x01\x00\x0e\x00\x07\x00\x09\x00\x08\x00\xff\xff\x2b\x00\x0a\x00\x2b\x00\xff\xff\x29\x00\x0a\x00\x29\x00\xff\xff\x2a\x00\x2a\x00\x07\x00\x05\x00\x08\x00\x05\x00\x01\x00\x2f\x00\x0e\x00\xff\xff\xff\xff\x05\x00\xff\xff\x22\x00\x2a\x00\x0d\x00\x1c\x00\x08\x00\x05\x00\xff\xff\xff\xff\x2f\x00\x2f\x00\x05\x00\x2f\x00\x01\x00\x2a\x00\x01\x00\x2a\x00\x0d\x00\xff\xff\x2a\x00\x29\x00\x0d\x00\x2a\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\x2f\x00\xff\xff\x2b\x00\xff\xff\x2f\x00\x29\x00\xff\xff\x27\x00\x2f\x00\x1c\x00\x2f\x00\xff\xff\x29\x00\x27\x00\x2f\x00\xff\xff\xff\xff\x2f\x00\x29\x00\x2f\x00\xff\xff\x2a\x00\x2f\x00\x29\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2b\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"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x6d\x00\x2c\x00\xea\x00\x23\x00\x23\x00\x66\x00\x23\x00\xb9\x00\x4a\x00\xba\x00\xbb\x00\xf3\x00\x3e\x00\x2d\x00\xf4\x00\xff\xff\x2e\x00\x67\x00\xbc\x00\x68\x00\x4b\x00\x2f\x00\x23\x00\x30\x00\xef\x00\x26\x00\x31\x00\x32\x00\x23\x00\x26\x00\xf1\x00\xa5\x00\x26\x00\x26\x00\xff\xff\x26\x00\x33\x00\xe3\x00\x34\x00\xe0\x00\x8c\x00\xc6\x00\x9b\x00\x67\x00\x35\x00\x68\x00\x26\x00\xff\xff\x23\x00\x26\x00\x4c\x00\x35\x00\x4d\x00\xff\xff\x2c\x00\x27\x00\x36\x00\x29\x00\x24\x00\xc0\x00\x54\x00\x66\x00\x27\x00\x28\x00\x29\x00\xe6\x00\x2d\x00\xb7\x00\x26\x00\x2e\x00\x2c\x00\x26\x00\x26\x00\x67\x00\x2f\x00\x68\x00\x30\x00\x3e\x00\x5f\x00\x31\x00\x32\x00\xae\x00\x2d\x00\x5f\x00\x90\x00\x2e\x00\xe4\x00\x75\xff\x26\x00\x33\x00\x2f\x00\x34\x00\x30\x00\x26\x00\xf6\x00\x31\x00\x32\x00\x35\x00\x66\x00\xce\x00\x35\x00\xc0\x00\x26\x00\x29\x00\x6d\x00\x33\x00\xd9\x00\x34\x00\x3e\x00\x5c\x00\x67\x00\xcb\x00\x68\x00\x35\x00\x73\x00\x74\x00\x75\x00\x76\x00\xc4\x00\x77\x00\x29\x00\x78\x00\x79\x00\x37\x00\x66\x00\x29\x00\x7a\x00\x7b\x00\x7c\x00\x3a\x00\x7d\x00\x7e\x00\x23\x00\x26\x00\x89\x00\x5f\x00\x67\x00\x97\x00\x68\x00\x26\x00\x73\x00\x74\x00\x75\x00\x76\x00\x3e\x00\x77\x00\x54\x00\x78\x00\x79\x00\x6d\x00\x3b\x00\xa8\x00\x7a\x00\x7b\x00\x7c\x00\xd0\x00\x7d\x00\x7e\x00\x83\x00\xda\x00\xe8\x00\x5f\x00\x8a\x00\x84\x00\x8b\x00\x26\x00\xd1\x00\x55\x00\x86\x00\x83\x00\xd5\x00\x71\x00\x69\x00\x3f\x00\x84\x00\xe1\x00\x26\x00\x60\x00\x26\x00\x86\x00\x26\x00\x6a\x00\x71\x00\x69\x00\x26\x00\x83\x00\x5c\x00\x83\x00\xcc\x00\x63\x00\x84\x00\x85\x00\x89\x00\xe7\x00\x87\x00\x86\x00\xd4\x00\x86\x00\x71\x00\x69\x00\x71\x00\x69\x00\x9a\x00\x69\x00\x63\x00\x87\x00\x27\x00\x28\x00\x29\x00\xde\x00\x27\x00\x28\x00\x29\x00\xbe\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x64\x00\xd6\x00\x58\x00\x87\x00\x59\x00\x87\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x4d\x00\x42\x00\x43\x00\x44\x00\x6a\x00\x5c\x00\xd7\x00\x5d\x00\x45\x00\x46\x00\x47\x00\x6a\x00\xc7\x00\x45\x00\x46\x00\x47\x00\xd3\x00\xb0\x00\x45\x00\x46\x00\x47\x00\x92\x00\x48\x00\xdc\x00\x93\x00\x4e\x00\xaf\x00\x40\x00\x4d\x00\x42\x00\x43\x00\x44\x00\x40\x00\x4d\x00\x42\x00\x43\x00\x44\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x6a\x00\x4e\x00\xb4\x00\x26\x00\xba\x00\xbb\x00\x4e\x00\x4f\x00\xff\xff\xf0\x00\x46\x00\x47\x00\xdd\x00\xbc\x00\xc8\x00\x46\x00\x47\x00\x3a\x00\x94\x00\xb1\x00\x46\x00\x47\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x4d\x00\x42\x00\x43\x00\x44\x00\xe5\x00\x3d\x00\x3a\x00\x59\x00\x3a\x00\x6d\x00\x6a\x00\xd1\x00\x6a\x00\x52\x00\x46\x00\x47\x00\x63\x00\x95\x00\x9d\x00\x51\x00\x47\x00\x91\x00\x6f\x00\x63\x00\x9c\x00\x50\x00\xc5\x00\x3d\x00\x3c\x00\x3d\x00\xa2\x00\x59\x00\x63\x00\xe2\x00\x9e\x00\xa3\x00\x71\x00\x69\x00\xa7\x00\x81\x00\x82\x00\x63\x00\x80\x00\xab\x00\x9f\x00\x71\x00\x69\x00\x6a\x00\x63\x00\xdf\x00\x63\x00\x80\x00\x63\x00\xac\x00\x71\x00\x69\x00\x7f\x00\x6a\x00\x80\x00\xa1\x00\x70\x00\x71\x00\x69\x00\x71\x00\x69\x00\x68\x00\x69\x00\x6d\x00\x6a\x00\x6b\x00\xad\x00\x38\x00\xbc\x00\x99\x00\xba\x00\xbb\x00\x9a\x00\x59\x00\xbd\x00\x6e\x00\x6f\x00\xab\x00\x23\x00\xbc\x00\x59\x00\x53\x00\x56\x00\x7e\x00\x5a\x00\xf9\x00\x61\x00\x62\x00\x3a\x00\xf8\x00\xf6\x00\x4c\x00\xee\x00\xef\x00\xf3\x00\x23\x00\xec\x00\xeb\x00\xed\x00\xc2\x00\xc3\x00\xca\x00\xc4\x00\xcb\x00\xce\x00\x5f\x00\x23\x00\x5c\x00\xd3\x00\xd9\x00\xdc\x00\x8e\x00\x00\x00\x4c\x00\x8f\x00\x4c\x00\x00\x00\x23\x00\x91\x00\x23\x00\x00\x00\x26\x00\x26\x00\xa1\x00\xa8\x00\xa7\x00\xaa\x00\x5c\x00\xff\xff\xa6\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x97\x00\x26\x00\xab\x00\x3a\x00\xb3\x00\xb6\x00\x00\x00\x00\x00\xff\xff\xff\xff\x90\x00\xff\xff\x5c\x00\x26\x00\x5c\x00\x26\x00\x5f\x00\x00\x00\x26\x00\x23\x00\x5f\x00\x26\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x4c\x00\x00\x00\xff\xff\x23\x00\x00\x00\xb7\x00\xff\xff\x3a\x00\xff\xff\x00\x00\x23\x00\xb9\x00\xff\xff\x00\x00\x00\x00\xff\xff\x23\x00\xff\xff\x00\x00\x26\x00\xff\xff\x23\x00\x00\x00\x26\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (33, 139) [ + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68), + (69 , happyReduce_69), + (70 , happyReduce_70), + (71 , happyReduce_71), + (72 , happyReduce_72), + (73 , happyReduce_73), + (74 , happyReduce_74), + (75 , happyReduce_75), + (76 , happyReduce_76), + (77 , happyReduce_77), + (78 , happyReduce_78), + (79 , happyReduce_79), + (80 , happyReduce_80), + (81 , happyReduce_81), + (82 , happyReduce_82), + (83 , happyReduce_83), + (84 , happyReduce_84), + (85 , happyReduce_85), + (86 , happyReduce_86), + (87 , happyReduce_87), + (88 , happyReduce_88), + (89 , happyReduce_89), + (90 , happyReduce_90), + (91 , happyReduce_91), + (92 , happyReduce_92), + (93 , happyReduce_93), + (94 , happyReduce_94), + (95 , happyReduce_95), + (96 , happyReduce_96), + (97 , happyReduce_97), + (98 , happyReduce_98), + (99 , happyReduce_99), + (100 , happyReduce_100), + (101 , happyReduce_101), + (102 , happyReduce_102), + (103 , happyReduce_103), + (104 , happyReduce_104), + (105 , happyReduce_105), + (106 , happyReduce_106), + (107 , happyReduce_107), + (108 , happyReduce_108), + (109 , happyReduce_109), + (110 , happyReduce_110), + (111 , happyReduce_111), + (112 , happyReduce_112), + (113 , happyReduce_113), + (114 , happyReduce_114), + (115 , happyReduce_115), + (116 , happyReduce_116), + (117 , happyReduce_117), + (118 , happyReduce_118), + (119 , happyReduce_119), + (120 , happyReduce_120), + (121 , happyReduce_121), + (122 , happyReduce_122), + (123 , happyReduce_123), + (124 , happyReduce_124), + (125 , happyReduce_125), + (126 , happyReduce_126), + (127 , happyReduce_127), + (128 , happyReduce_128), + (129 , happyReduce_129), + (130 , happyReduce_130), + (131 , happyReduce_131), + (132 , happyReduce_132), + (133 , happyReduce_133), + (134 , happyReduce_134), + (135 , happyReduce_135), + (136 , happyReduce_136), + (137 , happyReduce_137), + (138 , happyReduce_138), + (139 , happyReduce_139) + ] + +happy_n_terms = 48 :: Int +happy_n_nonterms = 38 :: Int + +happyReduce_33 = happySpecReduce_1 0# happyReduction_33 +happyReduction_33 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> + happyIn36 + (happy_var_1 + )} + +happyReduce_34 = happySpecReduce_1 1# happyReduction_34 +happyReduction_34 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) -> + happyIn37 + (Ident happy_var_1 + )} + +happyReduce_35 = happySpecReduce_1 2# happyReduction_35 +happyReduction_35 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> + happyIn38 + ((read ( happy_var_1)) :: Integer + )} + +happyReduce_36 = happySpecReduce_1 3# happyReduction_36 +happyReduction_36 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TC happy_var_1)) -> + happyIn39 + ((read ( happy_var_1)) :: Char + )} + +happyReduce_37 = happySpecReduce_1 4# happyReduction_37 +happyReduction_37 happy_x_1 + = case happyOutTok happy_x_1 of { (PT _ (TD happy_var_1)) -> + happyIn40 + ((read ( happy_var_1)) :: Double + )} + +happyReduce_38 = happySpecReduce_1 5# happyReduction_38 +happyReduction_38 happy_x_1 + = case happyOut43 happy_x_1 of { happy_var_1 -> + happyIn41 + (LGr happy_var_1 + )} + +happyReduce_39 = happySpecReduce_1 6# happyReduction_39 +happyReduction_39 happy_x_1 + = case happyOut47 happy_x_1 of { happy_var_1 -> + happyIn42 + (DefAll happy_var_1 + )} + +happyReduce_40 = happySpecReduce_3 6# happyReduction_40 +happyReduction_40 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut73 happy_x_1 of { happy_var_1 -> + case happyOut47 happy_x_3 of { happy_var_3 -> + happyIn42 + (DefSome happy_var_1 happy_var_3 + )}} + +happyReduce_41 = happySpecReduce_2 6# happyReduction_41 +happyReduction_41 happy_x_2 + happy_x_1 + = case happyOut73 happy_x_2 of { happy_var_2 -> + happyIn42 + (LDefView happy_var_2 + )} + +happyReduce_42 = happySpecReduce_0 7# happyReduction_42 +happyReduction_42 = happyIn43 + ([] + ) + +happyReduce_43 = happySpecReduce_1 7# happyReduction_43 +happyReduction_43 happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + happyIn43 + ((:[]) happy_var_1 + )} + +happyReduce_44 = happySpecReduce_3 7# happyReduction_44 +happyReduction_44 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + case happyOut43 happy_x_3 of { happy_var_3 -> + happyIn43 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_45 = happySpecReduce_1 8# happyReduction_45 +happyReduction_45 happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + happyIn44 + (Grammar happy_var_1 + )} + +happyReduce_46 = happySpecReduce_0 9# happyReduction_46 +happyReduction_46 = happyIn45 + ([] + ) + +happyReduce_47 = happySpecReduce_1 9# happyReduction_47 +happyReduction_47 happy_x_1 + = case happyOut47 happy_x_1 of { happy_var_1 -> + happyIn45 + ((:[]) happy_var_1 + )} + +happyReduce_48 = happySpecReduce_3 9# happyReduction_48 +happyReduction_48 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut47 happy_x_1 of { happy_var_1 -> + case happyOut45 happy_x_3 of { happy_var_3 -> + happyIn45 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_49 = happySpecReduce_0 10# happyReduction_49 +happyReduction_49 = happyIn46 + ([] + ) + +happyReduce_50 = happySpecReduce_2 10# happyReduction_50 +happyReduction_50 happy_x_2 + happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_2 of { happy_var_2 -> + happyIn46 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_51 = happyReduce 5# 11# happyReduction_51 +happyReduction_51 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut50 happy_x_1 of { happy_var_1 -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOut46 happy_x_5 of { happy_var_5 -> + happyIn47 + (Rule happy_var_1 happy_var_3 (reverse happy_var_5) + ) `HappyStk` happyRest}}} + +happyReduce_52 = happySpecReduce_2 11# happyReduction_52 +happyReduction_52 happy_x_2 + happy_x_1 + = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn47 + (Comment happy_var_2 + )} + +happyReduce_53 = happySpecReduce_3 11# happyReduction_53 +happyReduction_53 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut36 happy_x_2 of { happy_var_2 -> + case happyOut36 happy_x_3 of { happy_var_3 -> + happyIn47 + (Comments happy_var_2 happy_var_3 + )}} + +happyReduce_54 = happyReduce 6# 11# happyReduction_54 +happyReduction_54 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut50 happy_x_2 of { happy_var_2 -> + case happyOut49 happy_x_4 of { happy_var_4 -> + case happyOut46 happy_x_6 of { happy_var_6 -> + happyIn47 + (Internal happy_var_2 happy_var_4 (reverse happy_var_6) + ) `HappyStk` happyRest}}} + +happyReduce_55 = happySpecReduce_3 11# happyReduction_55 +happyReduction_55 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut37 happy_x_2 of { happy_var_2 -> + case happyOut72 happy_x_3 of { happy_var_3 -> + happyIn47 + (Token happy_var_2 happy_var_3 + )}} + +happyReduce_56 = happyReduce 4# 11# happyReduction_56 +happyReduction_56 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut37 happy_x_3 of { happy_var_3 -> + case happyOut72 happy_x_4 of { happy_var_4 -> + happyIn47 + (PosToken happy_var_3 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_57 = happySpecReduce_2 11# happyReduction_57 +happyReduction_57 happy_x_2 + happy_x_1 + = case happyOut73 happy_x_2 of { happy_var_2 -> + happyIn47 + (Entryp happy_var_2 + )} + +happyReduce_58 = happyReduce 4# 11# happyReduction_58 +happyReduction_58 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut68 happy_x_2 of { happy_var_2 -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOut36 happy_x_4 of { happy_var_4 -> + happyIn47 + (Separator happy_var_2 happy_var_3 happy_var_4 + ) `HappyStk` happyRest}}} + +happyReduce_59 = happyReduce 4# 11# happyReduction_59 +happyReduction_59 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut68 happy_x_2 of { happy_var_2 -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOut36 happy_x_4 of { happy_var_4 -> + happyIn47 + (Terminator happy_var_2 happy_var_3 happy_var_4 + ) `HappyStk` happyRest}}} + +happyReduce_60 = happyReduce 6# 11# happyReduction_60 +happyReduction_60 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut49 happy_x_2 of { happy_var_2 -> + case happyOut36 happy_x_3 of { happy_var_3 -> + case happyOut36 happy_x_4 of { happy_var_4 -> + case happyOut57 happy_x_5 of { happy_var_5 -> + case happyOut68 happy_x_6 of { happy_var_6 -> + happyIn47 + (Delimiters happy_var_2 happy_var_3 happy_var_4 happy_var_5 happy_var_6 + ) `HappyStk` happyRest}}}}} + +happyReduce_61 = happySpecReduce_3 11# happyReduction_61 +happyReduction_61 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut37 happy_x_2 of { happy_var_2 -> + case happyOut38 happy_x_3 of { happy_var_3 -> + happyIn47 + (Coercions happy_var_2 happy_var_3 + )}} + +happyReduce_62 = happyReduce 4# 11# happyReduction_62 +happyReduction_62 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut37 happy_x_2 of { happy_var_2 -> + case happyOut66 happy_x_4 of { happy_var_4 -> + happyIn47 + (Rules happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_63 = happyReduce 5# 11# happyReduction_63 +happyReduction_63 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut37 happy_x_2 of { happy_var_2 -> + case happyOut59 happy_x_3 of { happy_var_3 -> + case happyOut60 happy_x_5 of { happy_var_5 -> + happyIn47 + (Function happy_var_2 (reverse happy_var_3) happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_64 = happySpecReduce_2 11# happyReduction_64 +happyReduction_64 happy_x_2 + happy_x_1 + = case happyOut65 happy_x_2 of { happy_var_2 -> + happyIn47 + (Layout happy_var_2 + )} + +happyReduce_65 = happySpecReduce_3 11# happyReduction_65 +happyReduction_65 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut65 happy_x_3 of { happy_var_3 -> + happyIn47 + (LayoutStop happy_var_3 + )} + +happyReduce_66 = happySpecReduce_2 11# happyReduction_66 +happyReduction_66 happy_x_2 + happy_x_1 + = happyIn47 + (LayoutTop + ) + +happyReduce_67 = happySpecReduce_1 12# happyReduction_67 +happyReduction_67 happy_x_1 + = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn48 + (Terminal happy_var_1 + )} + +happyReduce_68 = happySpecReduce_1 12# happyReduction_68 +happyReduction_68 happy_x_1 + = case happyOut49 happy_x_1 of { happy_var_1 -> + happyIn48 + (NTerminal happy_var_1 + )} + +happyReduce_69 = happySpecReduce_3 13# happyReduction_69 +happyReduction_69 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut49 happy_x_2 of { happy_var_2 -> + happyIn49 + (ListCat happy_var_2 + )} + +happyReduce_70 = happySpecReduce_1 13# happyReduction_70 +happyReduction_70 happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn49 + (IdCat happy_var_1 + )} + +happyReduce_71 = happySpecReduce_1 14# happyReduction_71 +happyReduction_71 happy_x_1 + = case happyOut51 happy_x_1 of { happy_var_1 -> + happyIn50 + (LabNoP happy_var_1 + )} + +happyReduce_72 = happySpecReduce_2 14# happyReduction_72 +happyReduction_72 happy_x_2 + happy_x_1 + = case happyOut51 happy_x_1 of { happy_var_1 -> + case happyOut56 happy_x_2 of { happy_var_2 -> + happyIn50 + (LabP happy_var_1 happy_var_2 + )}} + +happyReduce_73 = happySpecReduce_3 14# happyReduction_73 +happyReduction_73 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut51 happy_x_1 of { happy_var_1 -> + case happyOut51 happy_x_2 of { happy_var_2 -> + case happyOut56 happy_x_3 of { happy_var_3 -> + happyIn50 + (LabPF happy_var_1 happy_var_2 happy_var_3 + )}}} + +happyReduce_74 = happySpecReduce_2 14# happyReduction_74 +happyReduction_74 happy_x_2 + happy_x_1 + = case happyOut51 happy_x_1 of { happy_var_1 -> + case happyOut51 happy_x_2 of { happy_var_2 -> + happyIn50 + (LabF happy_var_1 happy_var_2 + )}} + +happyReduce_75 = happySpecReduce_1 15# happyReduction_75 +happyReduction_75 happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn51 + (Id happy_var_1 + )} + +happyReduce_76 = happySpecReduce_1 15# happyReduction_76 +happyReduction_76 happy_x_1 + = happyIn51 + (Wild + ) + +happyReduce_77 = happySpecReduce_2 15# happyReduction_77 +happyReduction_77 happy_x_2 + happy_x_1 + = happyIn51 + (ListE + ) + +happyReduce_78 = happySpecReduce_3 15# happyReduction_78 +happyReduction_78 happy_x_3 + happy_x_2 + happy_x_1 + = happyIn51 + (ListCons + ) + +happyReduce_79 = happyReduce 5# 15# happyReduction_79 +happyReduction_79 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = happyIn51 + (ListOne + ) `HappyStk` happyRest + +happyReduce_80 = happyReduce 9# 16# happyReduction_80 +happyReduction_80 (happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut55 happy_x_3 of { happy_var_3 -> + case happyOut54 happy_x_7 of { happy_var_7 -> + happyIn52 + (ProfIt happy_var_3 happy_var_7 + ) `HappyStk` happyRest}} + +happyReduce_81 = happySpecReduce_3 17# happyReduction_81 +happyReduction_81 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut54 happy_x_2 of { happy_var_2 -> + happyIn53 + (Ints happy_var_2 + )} + +happyReduce_82 = happySpecReduce_0 18# happyReduction_82 +happyReduction_82 = happyIn54 + ([] + ) + +happyReduce_83 = happySpecReduce_1 18# happyReduction_83 +happyReduction_83 happy_x_1 + = case happyOut38 happy_x_1 of { happy_var_1 -> + happyIn54 + ((:[]) happy_var_1 + )} + +happyReduce_84 = happySpecReduce_3 18# happyReduction_84 +happyReduction_84 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut38 happy_x_1 of { happy_var_1 -> + case happyOut54 happy_x_3 of { happy_var_3 -> + happyIn54 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_85 = happySpecReduce_0 19# happyReduction_85 +happyReduction_85 = happyIn55 + ([] + ) + +happyReduce_86 = happySpecReduce_1 19# happyReduction_86 +happyReduction_86 happy_x_1 + = case happyOut53 happy_x_1 of { happy_var_1 -> + happyIn55 + ((:[]) happy_var_1 + )} + +happyReduce_87 = happySpecReduce_3 19# happyReduction_87 +happyReduction_87 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut53 happy_x_1 of { happy_var_1 -> + case happyOut55 happy_x_3 of { happy_var_3 -> + happyIn55 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_88 = happySpecReduce_1 20# happyReduction_88 +happyReduction_88 happy_x_1 + = case happyOut52 happy_x_1 of { happy_var_1 -> + happyIn56 + ((:[]) happy_var_1 + )} + +happyReduce_89 = happySpecReduce_2 20# happyReduction_89 +happyReduction_89 happy_x_2 + happy_x_1 + = case happyOut52 happy_x_1 of { happy_var_1 -> + case happyOut56 happy_x_2 of { happy_var_2 -> + happyIn56 + ((:) happy_var_1 happy_var_2 + )}} + +happyReduce_90 = happySpecReduce_0 21# happyReduction_90 +happyReduction_90 = happyIn57 + (SepNone + ) + +happyReduce_91 = happySpecReduce_2 21# happyReduction_91 +happyReduction_91 happy_x_2 + happy_x_1 + = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn57 + (SepTerm happy_var_2 + )} + +happyReduce_92 = happySpecReduce_2 21# happyReduction_92 +happyReduction_92 happy_x_2 + happy_x_1 + = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn57 + (SepSepar happy_var_2 + )} + +happyReduce_93 = happySpecReduce_1 22# happyReduction_93 +happyReduction_93 happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn58 + (Arg happy_var_1 + )} + +happyReduce_94 = happySpecReduce_0 23# happyReduction_94 +happyReduction_94 = happyIn59 + ([] + ) + +happyReduce_95 = happySpecReduce_2 23# happyReduction_95 +happyReduction_95 happy_x_2 + happy_x_1 + = case happyOut59 happy_x_1 of { happy_var_1 -> + case happyOut58 happy_x_2 of { happy_var_2 -> + happyIn59 + (flip (:) happy_var_1 happy_var_2 + )}} + +happyReduce_96 = happySpecReduce_3 24# happyReduction_96 +happyReduction_96 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut61 happy_x_1 of { happy_var_1 -> + case happyOut60 happy_x_3 of { happy_var_3 -> + happyIn60 + (Cons happy_var_1 happy_var_3 + )}} + +happyReduce_97 = happySpecReduce_1 24# happyReduction_97 +happyReduction_97 happy_x_1 + = case happyOut61 happy_x_1 of { happy_var_1 -> + happyIn60 + (happy_var_1 + )} + +happyReduce_98 = happySpecReduce_2 25# happyReduction_98 +happyReduction_98 happy_x_2 + happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + case happyOut63 happy_x_2 of { happy_var_2 -> + happyIn61 + (App happy_var_1 happy_var_2 + )}} + +happyReduce_99 = happySpecReduce_1 25# happyReduction_99 +happyReduction_99 happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + happyIn61 + (happy_var_1 + )} + +happyReduce_100 = happySpecReduce_1 26# happyReduction_100 +happyReduction_100 happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn62 + (Var happy_var_1 + )} + +happyReduce_101 = happySpecReduce_1 26# happyReduction_101 +happyReduction_101 happy_x_1 + = case happyOut38 happy_x_1 of { happy_var_1 -> + happyIn62 + (LitInt happy_var_1 + )} + +happyReduce_102 = happySpecReduce_1 26# happyReduction_102 +happyReduction_102 happy_x_1 + = case happyOut39 happy_x_1 of { happy_var_1 -> + happyIn62 + (LitChar happy_var_1 + )} + +happyReduce_103 = happySpecReduce_1 26# happyReduction_103 +happyReduction_103 happy_x_1 + = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn62 + (LitString happy_var_1 + )} + +happyReduce_104 = happySpecReduce_1 26# happyReduction_104 +happyReduction_104 happy_x_1 + = case happyOut40 happy_x_1 of { happy_var_1 -> + happyIn62 + (LitDouble happy_var_1 + )} + +happyReduce_105 = happySpecReduce_3 26# happyReduction_105 +happyReduction_105 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut64 happy_x_2 of { happy_var_2 -> + happyIn62 + (List happy_var_2 + )} + +happyReduce_106 = happySpecReduce_3 26# happyReduction_106 +happyReduction_106 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut60 happy_x_2 of { happy_var_2 -> + happyIn62 + (happy_var_2 + )} + +happyReduce_107 = happySpecReduce_1 27# happyReduction_107 +happyReduction_107 happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + happyIn63 + ((:[]) happy_var_1 + )} + +happyReduce_108 = happySpecReduce_2 27# happyReduction_108 +happyReduction_108 happy_x_2 + happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOut63 happy_x_2 of { happy_var_2 -> + happyIn63 + ((:) happy_var_1 happy_var_2 + )}} + +happyReduce_109 = happySpecReduce_0 28# happyReduction_109 +happyReduction_109 = happyIn64 + ([] + ) + +happyReduce_110 = happySpecReduce_1 28# happyReduction_110 +happyReduction_110 happy_x_1 + = case happyOut60 happy_x_1 of { happy_var_1 -> + happyIn64 + ((:[]) happy_var_1 + )} + +happyReduce_111 = happySpecReduce_3 28# happyReduction_111 +happyReduction_111 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut60 happy_x_1 of { happy_var_1 -> + case happyOut64 happy_x_3 of { happy_var_3 -> + happyIn64 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_112 = happySpecReduce_1 29# happyReduction_112 +happyReduction_112 happy_x_1 + = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn65 + ((:[]) happy_var_1 + )} + +happyReduce_113 = happySpecReduce_3 29# happyReduction_113 +happyReduction_113 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut36 happy_x_1 of { happy_var_1 -> + case happyOut65 happy_x_3 of { happy_var_3 -> + happyIn65 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_114 = happySpecReduce_1 30# happyReduction_114 +happyReduction_114 happy_x_1 + = case happyOut67 happy_x_1 of { happy_var_1 -> + happyIn66 + ((:[]) happy_var_1 + )} + +happyReduce_115 = happySpecReduce_3 30# happyReduction_115 +happyReduction_115 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut67 happy_x_1 of { happy_var_1 -> + case happyOut66 happy_x_3 of { happy_var_3 -> + happyIn66 + ((:) happy_var_1 happy_var_3 + )}} + +happyReduce_116 = happySpecReduce_1 31# happyReduction_116 +happyReduction_116 happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + happyIn67 + (RHS (reverse happy_var_1) + )} + +happyReduce_117 = happySpecReduce_1 32# happyReduction_117 +happyReduction_117 happy_x_1 + = happyIn68 + (MNonempty + ) + +happyReduce_118 = happySpecReduce_0 32# happyReduction_118 +happyReduction_118 = happyIn68 + (MEmpty + ) + +happyReduce_119 = happySpecReduce_2 33# happyReduction_119 +happyReduction_119 happy_x_2 + happy_x_1 + = case happyOut69 happy_x_1 of { happy_var_1 -> + case happyOut71 happy_x_2 of { happy_var_2 -> + happyIn69 + (RSeq happy_var_1 happy_var_2 + )}} + +happyReduce_120 = happySpecReduce_1 33# happyReduction_120 +happyReduction_120 happy_x_1 + = case happyOut71 happy_x_1 of { happy_var_1 -> + happyIn69 + (happy_var_1 + )} + +happyReduce_121 = happySpecReduce_3 34# happyReduction_121 +happyReduction_121 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut70 happy_x_1 of { happy_var_1 -> + case happyOut69 happy_x_3 of { happy_var_3 -> + happyIn70 + (RAlt happy_var_1 happy_var_3 + )}} + +happyReduce_122 = happySpecReduce_3 34# happyReduction_122 +happyReduction_122 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut69 happy_x_1 of { happy_var_1 -> + case happyOut69 happy_x_3 of { happy_var_3 -> + happyIn70 + (RMinus happy_var_1 happy_var_3 + )}} + +happyReduce_123 = happySpecReduce_1 34# happyReduction_123 +happyReduction_123 happy_x_1 + = case happyOut69 happy_x_1 of { happy_var_1 -> + happyIn70 + (happy_var_1 + )} + +happyReduce_124 = happySpecReduce_2 35# happyReduction_124 +happyReduction_124 happy_x_2 + happy_x_1 + = case happyOut71 happy_x_1 of { happy_var_1 -> + happyIn71 + (RStar happy_var_1 + )} + +happyReduce_125 = happySpecReduce_2 35# happyReduction_125 +happyReduction_125 happy_x_2 + happy_x_1 + = case happyOut71 happy_x_1 of { happy_var_1 -> + happyIn71 + (RPlus happy_var_1 + )} + +happyReduce_126 = happySpecReduce_2 35# happyReduction_126 +happyReduction_126 happy_x_2 + happy_x_1 + = case happyOut71 happy_x_1 of { happy_var_1 -> + happyIn71 + (ROpt happy_var_1 + )} + +happyReduce_127 = happySpecReduce_1 35# happyReduction_127 +happyReduction_127 happy_x_1 + = happyIn71 + (REps + ) + +happyReduce_128 = happySpecReduce_1 35# happyReduction_128 +happyReduction_128 happy_x_1 + = case happyOut39 happy_x_1 of { happy_var_1 -> + happyIn71 + (RChar happy_var_1 + )} + +happyReduce_129 = happySpecReduce_3 35# happyReduction_129 +happyReduction_129 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn71 + (RAlts happy_var_2 + )} + +happyReduce_130 = happySpecReduce_3 35# happyReduction_130 +happyReduction_130 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn71 + (RSeqs happy_var_2 + )} + +happyReduce_131 = happySpecReduce_1 35# happyReduction_131 +happyReduction_131 happy_x_1 + = happyIn71 + (RDigit + ) + +happyReduce_132 = happySpecReduce_1 35# happyReduction_132 +happyReduction_132 happy_x_1 + = happyIn71 + (RLetter + ) + +happyReduce_133 = happySpecReduce_1 35# happyReduction_133 +happyReduction_133 happy_x_1 + = happyIn71 + (RUpper + ) + +happyReduce_134 = happySpecReduce_1 35# happyReduction_134 +happyReduction_134 happy_x_1 + = happyIn71 + (RLower + ) + +happyReduce_135 = happySpecReduce_1 35# happyReduction_135 +happyReduction_135 happy_x_1 + = happyIn71 + (RAny + ) + +happyReduce_136 = happySpecReduce_3 35# happyReduction_136 +happyReduction_136 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut72 happy_x_2 of { happy_var_2 -> + happyIn71 + (happy_var_2 + )} + +happyReduce_137 = happySpecReduce_1 36# happyReduction_137 +happyReduction_137 happy_x_1 + = case happyOut70 happy_x_1 of { happy_var_1 -> + happyIn72 + (happy_var_1 + )} + +happyReduce_138 = happySpecReduce_1 37# happyReduction_138 +happyReduction_138 happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn73 + ((:[]) happy_var_1 + )} + +happyReduce_139 = happySpecReduce_3 37# happyReduction_139 +happyReduction_139 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + case happyOut73 happy_x_3 of { happy_var_3 -> + happyIn73 + ((:) happy_var_1 happy_var_3 + )}} + +happyNewToken action sts stk [] = + happyDoAction 47# notHappyAtAll action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + PT _ (TS _ 1) -> cont 1#; + PT _ (TS _ 2) -> cont 2#; + PT _ (TS _ 3) -> cont 3#; + PT _ (TS _ 4) -> cont 4#; + PT _ (TS _ 5) -> cont 5#; + PT _ (TS _ 6) -> cont 6#; + PT _ (TS _ 7) -> cont 7#; + PT _ (TS _ 8) -> cont 8#; + PT _ (TS _ 9) -> cont 9#; + PT _ (TS _ 10) -> cont 10#; + PT _ (TS _ 11) -> cont 11#; + PT _ (TS _ 12) -> cont 12#; + PT _ (TS _ 13) -> cont 13#; + PT _ (TS _ 14) -> cont 14#; + PT _ (TS _ 15) -> cont 15#; + PT _ (TS _ 16) -> cont 16#; + PT _ (TS _ 17) -> cont 17#; + PT _ (TS _ 18) -> cont 18#; + PT _ (TS _ 19) -> cont 19#; + PT _ (TS _ 20) -> cont 20#; + PT _ (TS _ 21) -> cont 21#; + PT _ (TS _ 22) -> cont 22#; + PT _ (TS _ 23) -> cont 23#; + PT _ (TS _ 24) -> cont 24#; + PT _ (TS _ 25) -> cont 25#; + PT _ (TS _ 26) -> cont 26#; + PT _ (TS _ 27) -> cont 27#; + PT _ (TS _ 28) -> cont 28#; + PT _ (TS _ 29) -> cont 29#; + PT _ (TS _ 30) -> cont 30#; + PT _ (TS _ 31) -> cont 31#; + PT _ (TS _ 32) -> cont 32#; + PT _ (TS _ 33) -> cont 33#; + PT _ (TS _ 34) -> cont 34#; + PT _ (TS _ 35) -> cont 35#; + PT _ (TS _ 36) -> cont 36#; + PT _ (TS _ 37) -> cont 37#; + PT _ (TS _ 38) -> cont 38#; + PT _ (TS _ 39) -> cont 39#; + PT _ (TS _ 40) -> cont 40#; + PT _ (TL happy_dollar_dollar) -> cont 41#; + PT _ (TV happy_dollar_dollar) -> cont 42#; + PT _ (TI happy_dollar_dollar) -> cont 43#; + PT _ (TC happy_dollar_dollar) -> cont 44#; + PT _ (TD happy_dollar_dollar) -> cont 45#; + _ -> cont 46#; + _ -> happyError' (tk:tks) + } + +happyError_ 47# tk tks = happyError' 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 + +pLGrammar tks = happySomeParser where + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut41 x)) + +pLDef tks = happySomeParser where + happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut42 x)) + +pListLDef tks = happySomeParser where + happySomeParser = happyThen (happyParse 2# tks) (\x -> happyReturn (happyOut43 x)) + +pGrammar tks = happySomeParser where + happySomeParser = happyThen (happyParse 3# tks) (\x -> happyReturn (happyOut44 x)) + +pListDef tks = happySomeParser where + happySomeParser = happyThen (happyParse 4# tks) (\x -> happyReturn (happyOut45 x)) + +pListItem tks = happySomeParser where + happySomeParser = happyThen (happyParse 5# tks) (\x -> happyReturn (happyOut46 x)) + +pDef tks = happySomeParser where + happySomeParser = happyThen (happyParse 6# tks) (\x -> happyReturn (happyOut47 x)) + +pItem tks = happySomeParser where + happySomeParser = happyThen (happyParse 7# tks) (\x -> happyReturn (happyOut48 x)) + +pCat tks = happySomeParser where + happySomeParser = happyThen (happyParse 8# tks) (\x -> happyReturn (happyOut49 x)) + +pLabel tks = happySomeParser where + happySomeParser = happyThen (happyParse 9# tks) (\x -> happyReturn (happyOut50 x)) + +pLabelId tks = happySomeParser where + happySomeParser = happyThen (happyParse 10# tks) (\x -> happyReturn (happyOut51 x)) + +pProfItem tks = happySomeParser where + happySomeParser = happyThen (happyParse 11# tks) (\x -> happyReturn (happyOut52 x)) + +pIntList tks = happySomeParser where + happySomeParser = happyThen (happyParse 12# tks) (\x -> happyReturn (happyOut53 x)) + +pListInteger tks = happySomeParser where + happySomeParser = happyThen (happyParse 13# tks) (\x -> happyReturn (happyOut54 x)) + +pListIntList tks = happySomeParser where + happySomeParser = happyThen (happyParse 14# tks) (\x -> happyReturn (happyOut55 x)) + +pListProfItem tks = happySomeParser where + happySomeParser = happyThen (happyParse 15# tks) (\x -> happyReturn (happyOut56 x)) + +pSeparation tks = happySomeParser where + happySomeParser = happyThen (happyParse 16# tks) (\x -> happyReturn (happyOut57 x)) + +pArg tks = happySomeParser where + happySomeParser = happyThen (happyParse 17# tks) (\x -> happyReturn (happyOut58 x)) + +pListArg tks = happySomeParser where + happySomeParser = happyThen (happyParse 18# tks) (\x -> happyReturn (happyOut59 x)) + +pExp tks = happySomeParser where + happySomeParser = happyThen (happyParse 19# tks) (\x -> happyReturn (happyOut60 x)) + +pExp1 tks = happySomeParser where + happySomeParser = happyThen (happyParse 20# tks) (\x -> happyReturn (happyOut61 x)) + +pExp2 tks = happySomeParser where + happySomeParser = happyThen (happyParse 21# tks) (\x -> happyReturn (happyOut62 x)) + +pListExp2 tks = happySomeParser where + happySomeParser = happyThen (happyParse 22# tks) (\x -> happyReturn (happyOut63 x)) + +pListExp tks = happySomeParser where + happySomeParser = happyThen (happyParse 23# tks) (\x -> happyReturn (happyOut64 x)) + +pListString tks = happySomeParser where + happySomeParser = happyThen (happyParse 24# tks) (\x -> happyReturn (happyOut65 x)) + +pListRHS tks = happySomeParser where + happySomeParser = happyThen (happyParse 25# tks) (\x -> happyReturn (happyOut66 x)) + +pRHS tks = happySomeParser where + happySomeParser = happyThen (happyParse 26# tks) (\x -> happyReturn (happyOut67 x)) + +pMinimumSize tks = happySomeParser where + happySomeParser = happyThen (happyParse 27# tks) (\x -> happyReturn (happyOut68 x)) + +pReg2 tks = happySomeParser where + happySomeParser = happyThen (happyParse 28# tks) (\x -> happyReturn (happyOut69 x)) + +pReg1 tks = happySomeParser where + happySomeParser = happyThen (happyParse 29# tks) (\x -> happyReturn (happyOut70 x)) + +pReg3 tks = happySomeParser where + happySomeParser = happyThen (happyParse 30# tks) (\x -> happyReturn (happyOut71 x)) + +pReg tks = happySomeParser where + happySomeParser = happyThen (happyParse 31# tks) (\x -> happyReturn (happyOut72 x)) + +pListIdent tks = happySomeParser where + happySomeParser = happyThen (happyParse 32# tks) (\x -> happyReturn (happyOut73 x)) + +happySeq = happyDontSeq + + +returnM :: a -> Err a +returnM = return + +thenM :: Err a -> (a -> Err b) -> Err b +thenM = (>>=) + +happyError :: [Token] -> Err a +happyError ts = + Bad $ "syntax error at " ++ tokenPos ts ++ + case ts of + [] -> [] + [Err _] -> " due to lexer error" + _ -> " before " ++ unwords (map (id . prToken) (take 4 ts)) + +myLexer = tokens +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 30 "templates/GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList + + + + + +{-# LINE 51 "templates/GenericTemplate.hs" #-} + +{-# LINE 61 "templates/GenericTemplate.hs" #-} + +{-# LINE 70 "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 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where (new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where (off) = indexShortOffAddr happyActOffsets st + (off_i) = (off Happy_GHC_Exts.+# i) + check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) + then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) + else False + (action) + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + +{-# LINE 130 "templates/GenericTemplate.hs" #-} + + +indexShortOffAddr (HappyA# arr) off = + Happy_GHC_Exts.narrow16Int# i + where + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# + + + + + +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 163 "templates/GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + + (off) = indexShortOffAddr happyGotoOffsets st1 + (off_i) = (off Happy_GHC_Exts.+# nt) + (new_state) = indexShortOffAddr happyTable off_i + + + + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where (off) = indexShortOffAddr happyGotoOffsets st + (off_i) = (off Happy_GHC_Exts.+# nt) + (new_state) = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk@(x `HappyStk` _) = + let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "failing" $ + happyError_ i tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/dist/build/bnfc/bnfc-tmp/ParBNF.o b/dist/build/bnfc/bnfc-tmp/ParBNF.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/ParBNF.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/PrintBNF.hi b/dist/build/bnfc/bnfc-tmp/PrintBNF.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/PrintBNF.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/PrintBNF.o b/dist/build/bnfc/bnfc-tmp/PrintBNF.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/PrintBNF.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/ProfileTop.hi b/dist/build/bnfc/bnfc-tmp/ProfileTop.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/ProfileTop.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/ProfileTop.o b/dist/build/bnfc/bnfc-tmp/ProfileTop.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/ProfileTop.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/RegToAlex.hi b/dist/build/bnfc/bnfc-tmp/RegToAlex.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/RegToAlex.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/RegToAlex.o b/dist/build/bnfc/bnfc-tmp/RegToAlex.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/RegToAlex.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/RegToFlex.hi b/dist/build/bnfc/bnfc-tmp/RegToFlex.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/RegToFlex.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/RegToFlex.o b/dist/build/bnfc/bnfc-tmp/RegToFlex.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/RegToFlex.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/RegToGPLEX.hi b/dist/build/bnfc/bnfc-tmp/RegToGPLEX.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/RegToGPLEX.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/RegToGPLEX.o b/dist/build/bnfc/bnfc-tmp/RegToGPLEX.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/RegToGPLEX.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/RegToJLex.hi b/dist/build/bnfc/bnfc-tmp/RegToJLex.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/RegToJLex.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/RegToJLex.o b/dist/build/bnfc/bnfc-tmp/RegToJLex.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/RegToJLex.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/STLTop.hi b/dist/build/bnfc/bnfc-tmp/STLTop.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/STLTop.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/STLTop.o b/dist/build/bnfc/bnfc-tmp/STLTop.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/STLTop.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/STLUtils.hi b/dist/build/bnfc/bnfc-tmp/STLUtils.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/STLUtils.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/STLUtils.o b/dist/build/bnfc/bnfc-tmp/STLUtils.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/STLUtils.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/TypeChecker.hi b/dist/build/bnfc/bnfc-tmp/TypeChecker.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/TypeChecker.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/TypeChecker.o b/dist/build/bnfc/bnfc-tmp/TypeChecker.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/TypeChecker.o and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/Utils.hi b/dist/build/bnfc/bnfc-tmp/Utils.hi deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/Utils.hi and /dev/null differ diff --git a/dist/build/bnfc/bnfc-tmp/Utils.o b/dist/build/bnfc/bnfc-tmp/Utils.o deleted file mode 100644 Binary files a/dist/build/bnfc/bnfc-tmp/Utils.o and /dev/null differ diff --git a/dist/package.conf.inplace b/dist/package.conf.inplace deleted file mode 100644 --- a/dist/package.conf.inplace +++ /dev/null @@ -1,1 +0,0 @@ -[] diff --git a/dist/setup-config b/dist/setup-config deleted file mode 100644 --- a/dist/setup-config +++ /dev/null @@ -1,2 +0,0 @@ -Saved package config for BNFC-2.4.2.1 written by Cabal-1.14.0 using ghc-7.4 -LocalBuildInfo {configFlags = ConfigFlags {configPrograms = [], configProgramPaths = [], configProgramArgs = [], configHcFlavor = Flag GHC, configHcPath = NoFlag, configHcPkg = NoFlag, configVanillaLib = Flag True, configProfLib = Flag False, configSharedLib = Flag False, configDynExe = Flag False, configProfExe = Flag False, configConfigureArgs = [], configOptimization = Flag NormalOptimisation, configProgPrefix = Flag "", configProgSuffix = Flag "", configInstallDirs = InstallDirs {prefix = Flag "/home/abel/.cabal", bindir = NoFlag, libdir = NoFlag, libsubdir = NoFlag, dynlibdir = NoFlag, libexecdir = NoFlag, progdir = NoFlag, includedir = NoFlag, datadir = NoFlag, datasubdir = NoFlag, docdir = NoFlag, mandir = NoFlag, htmldir = NoFlag, haddockdir = NoFlag}, configScratchDir = NoFlag, configExtraLibDirs = [], configExtraIncludeDirs = [], configDistPref = Flag "dist", configVerbosity = Flag Normal, configUserInstall = Flag True, configPackageDB = NoFlag, configGHCiLib = Flag True, configSplitObjs = Flag False, configStripExes = Flag True, configConstraints = [Dependency (PackageName "process") (ThisVersion (Version {versionBranch = [1,1,0,1], versionTags = []})),Dependency (PackageName "mtl") (ThisVersion (Version {versionBranch = [2,0,1,0], versionTags = []})),Dependency (PackageName "directory") (ThisVersion (Version {versionBranch = [1,1,0,2], versionTags = []})),Dependency (PackageName "base") (ThisVersion (Version {versionBranch = [4,5,0,0], versionTags = []})),Dependency (PackageName "array") (ThisVersion (Version {versionBranch = [0,4,0,0], versionTags = []}))], configConfigurationsFlags = [], configTests = Flag False, configBenchmarks = Flag False, configLibCoverage = Flag False}, extraConfigArgs = [], installDirTemplates = InstallDirs {prefix = "/home/abel/.cabal", bindir = "$prefix/bin", libdir = "$prefix/lib", libsubdir = "$pkgid/$compiler", dynlibdir = "$libdir", libexecdir = "$prefix/libexec", progdir = "$libdir/hugs/programs", includedir = "$libdir/$libsubdir/include", datadir = "$prefix/share", datasubdir = "$pkgid", docdir = "$datadir/doc/$pkgid", mandir = "$datadir/man", htmldir = "$docdir/html", haddockdir = "$htmldir"}, compiler = Compiler {compilerId = CompilerId GHC (Version {versionBranch = [7,4,1], versionTags = []}), compilerLanguages = [(Haskell98,"-XHaskell98"),(Haskell2010,"-XHaskell2010")], compilerExtensions = [(UnknownExtension "Haskell98","-XHaskell98"),(UnknownExtension "Haskell2010","-XHaskell2010"),(UnknownExtension "Unsafe","-XUnsafe"),(EnableExtension Trustworthy,"-XTrustworthy"),(EnableExtension Safe,"-XSafe"),(EnableExtension CPP,"-XCPP"),(DisableExtension CPP,"-XNoCPP"),(EnableExtension PostfixOperators,"-XPostfixOperators"),(DisableExtension PostfixOperators,"-XNoPostfixOperators"),(EnableExtension TupleSections,"-XTupleSections"),(DisableExtension TupleSections,"-XNoTupleSections"),(EnableExtension PatternGuards,"-XPatternGuards"),(DisableExtension PatternGuards,"-XNoPatternGuards"),(EnableExtension UnicodeSyntax,"-XUnicodeSyntax"),(DisableExtension UnicodeSyntax,"-XNoUnicodeSyntax"),(EnableExtension MagicHash,"-XMagicHash"),(DisableExtension MagicHash,"-XNoMagicHash"),(EnableExtension PolymorphicComponents,"-XPolymorphicComponents"),(DisableExtension PolymorphicComponents,"-XNoPolymorphicComponents"),(EnableExtension ExistentialQuantification,"-XExistentialQuantification"),(DisableExtension ExistentialQuantification,"-XNoExistentialQuantification"),(EnableExtension KindSignatures,"-XKindSignatures"),(DisableExtension KindSignatures,"-XNoKindSignatures"),(EnableExtension EmptyDataDecls,"-XEmptyDataDecls"),(DisableExtension EmptyDataDecls,"-XNoEmptyDataDecls"),(EnableExtension ParallelListComp,"-XParallelListComp"),(DisableExtension ParallelListComp,"-XNoParallelListComp"),(EnableExtension TransformListComp,"-XTransformListComp"),(DisableExtension TransformListComp,"-XNoTransformListComp"),(UnknownExtension "MonadComprehensions","-XMonadComprehensions"),(UnknownExtension "NoMonadComprehensions","-XNoMonadComprehensions"),(EnableExtension ForeignFunctionInterface,"-XForeignFunctionInterface"),(DisableExtension ForeignFunctionInterface,"-XNoForeignFunctionInterface"),(EnableExtension UnliftedFFITypes,"-XUnliftedFFITypes"),(DisableExtension UnliftedFFITypes,"-XNoUnliftedFFITypes"),(UnknownExtension "InterruptibleFFI","-XInterruptibleFFI"),(UnknownExtension "NoInterruptibleFFI","-XNoInterruptibleFFI"),(UnknownExtension "CApiFFI","-XCApiFFI"),(UnknownExtension "NoCApiFFI","-XNoCApiFFI"),(EnableExtension GHCForeignImportPrim,"-XGHCForeignImportPrim"),(DisableExtension GHCForeignImportPrim,"-XNoGHCForeignImportPrim"),(EnableExtension LiberalTypeSynonyms,"-XLiberalTypeSynonyms"),(DisableExtension LiberalTypeSynonyms,"-XNoLiberalTypeSynonyms"),(EnableExtension Rank2Types,"-XRank2Types"),(DisableExtension Rank2Types,"-XNoRank2Types"),(EnableExtension RankNTypes,"-XRankNTypes"),(DisableExtension RankNTypes,"-XNoRankNTypes"),(EnableExtension ImpredicativeTypes,"-XImpredicativeTypes"),(DisableExtension ImpredicativeTypes,"-XNoImpredicativeTypes"),(EnableExtension TypeOperators,"-XTypeOperators"),(DisableExtension TypeOperators,"-XNoTypeOperators"),(EnableExtension RecursiveDo,"-XRecursiveDo"),(DisableExtension RecursiveDo,"-XNoRecursiveDo"),(EnableExtension DoRec,"-XDoRec"),(DisableExtension DoRec,"-XNoDoRec"),(EnableExtension Arrows,"-XArrows"),(DisableExtension Arrows,"-XNoArrows"),(UnknownExtension "ParallelArrays","-XParallelArrays"),(UnknownExtension "NoParallelArrays","-XNoParallelArrays"),(EnableExtension TemplateHaskell,"-XTemplateHaskell"),(DisableExtension TemplateHaskell,"-XNoTemplateHaskell"),(EnableExtension QuasiQuotes,"-XQuasiQuotes"),(DisableExtension QuasiQuotes,"-XNoQuasiQuotes"),(EnableExtension ImplicitPrelude,"-XImplicitPrelude"),(DisableExtension ImplicitPrelude,"-XNoImplicitPrelude"),(EnableExtension RecordWildCards,"-XRecordWildCards"),(DisableExtension RecordWildCards,"-XNoRecordWildCards"),(EnableExtension NamedFieldPuns,"-XNamedFieldPuns"),(DisableExtension NamedFieldPuns,"-XNoNamedFieldPuns"),(EnableExtension RecordPuns,"-XRecordPuns"),(DisableExtension RecordPuns,"-XNoRecordPuns"),(EnableExtension DisambiguateRecordFields,"-XDisambiguateRecordFields"),(DisableExtension DisambiguateRecordFields,"-XNoDisambiguateRecordFields"),(EnableExtension OverloadedStrings,"-XOverloadedStrings"),(DisableExtension OverloadedStrings,"-XNoOverloadedStrings"),(EnableExtension GADTs,"-XGADTs"),(DisableExtension GADTs,"-XNoGADTs"),(EnableExtension GADTSyntax,"-XGADTSyntax"),(DisableExtension GADTSyntax,"-XNoGADTSyntax"),(EnableExtension ViewPatterns,"-XViewPatterns"),(DisableExtension ViewPatterns,"-XNoViewPatterns"),(EnableExtension TypeFamilies,"-XTypeFamilies"),(DisableExtension TypeFamilies,"-XNoTypeFamilies"),(EnableExtension BangPatterns,"-XBangPatterns"),(DisableExtension BangPatterns,"-XNoBangPatterns"),(EnableExtension MonomorphismRestriction,"-XMonomorphismRestriction"),(DisableExtension MonomorphismRestriction,"-XNoMonomorphismRestriction"),(EnableExtension NPlusKPatterns,"-XNPlusKPatterns"),(DisableExtension NPlusKPatterns,"-XNoNPlusKPatterns"),(EnableExtension DoAndIfThenElse,"-XDoAndIfThenElse"),(DisableExtension DoAndIfThenElse,"-XNoDoAndIfThenElse"),(EnableExtension RebindableSyntax,"-XRebindableSyntax"),(DisableExtension RebindableSyntax,"-XNoRebindableSyntax"),(EnableExtension ConstraintKinds,"-XConstraintKinds"),(DisableExtension ConstraintKinds,"-XNoConstraintKinds"),(UnknownExtension "PolyKinds","-XPolyKinds"),(UnknownExtension "NoPolyKinds","-XNoPolyKinds"),(UnknownExtension "DataKinds","-XDataKinds"),(UnknownExtension "NoDataKinds","-XNoDataKinds"),(EnableExtension MonoPatBinds,"-XMonoPatBinds"),(DisableExtension MonoPatBinds,"-XNoMonoPatBinds"),(EnableExtension ExplicitForAll,"-XExplicitForAll"),(DisableExtension ExplicitForAll,"-XNoExplicitForAll"),(UnknownExtension "AlternativeLayoutRule","-XAlternativeLayoutRule"),(UnknownExtension "NoAlternativeLayoutRule","-XNoAlternativeLayoutRule"),(UnknownExtension "AlternativeLayoutRuleTransitional","-XAlternativeLayoutRuleTransitional"),(UnknownExtension "NoAlternativeLayoutRuleTransitional","-XNoAlternativeLayoutRuleTransitional"),(EnableExtension DatatypeContexts,"-XDatatypeContexts"),(DisableExtension DatatypeContexts,"-XNoDatatypeContexts"),(EnableExtension NondecreasingIndentation,"-XNondecreasingIndentation"),(DisableExtension NondecreasingIndentation,"-XNoNondecreasingIndentation"),(UnknownExtension "RelaxedLayout","-XRelaxedLayout"),(UnknownExtension "NoRelaxedLayout","-XNoRelaxedLayout"),(UnknownExtension "TraditionalRecordSyntax","-XTraditionalRecordSyntax"),(UnknownExtension "NoTraditionalRecordSyntax","-XNoTraditionalRecordSyntax"),(EnableExtension MonoLocalBinds,"-XMonoLocalBinds"),(DisableExtension MonoLocalBinds,"-XNoMonoLocalBinds"),(EnableExtension RelaxedPolyRec,"-XRelaxedPolyRec"),(DisableExtension RelaxedPolyRec,"-XNoRelaxedPolyRec"),(EnableExtension ExtendedDefaultRules,"-XExtendedDefaultRules"),(DisableExtension ExtendedDefaultRules,"-XNoExtendedDefaultRules"),(EnableExtension ImplicitParams,"-XImplicitParams"),(DisableExtension ImplicitParams,"-XNoImplicitParams"),(EnableExtension ScopedTypeVariables,"-XScopedTypeVariables"),(DisableExtension ScopedTypeVariables,"-XNoScopedTypeVariables"),(EnableExtension PatternSignatures,"-XPatternSignatures"),(DisableExtension PatternSignatures,"-XNoPatternSignatures"),(EnableExtension UnboxedTuples,"-XUnboxedTuples"),(DisableExtension UnboxedTuples,"-XNoUnboxedTuples"),(EnableExtension StandaloneDeriving,"-XStandaloneDeriving"),(DisableExtension StandaloneDeriving,"-XNoStandaloneDeriving"),(EnableExtension DeriveDataTypeable,"-XDeriveDataTypeable"),(DisableExtension DeriveDataTypeable,"-XNoDeriveDataTypeable"),(EnableExtension DeriveFunctor,"-XDeriveFunctor"),(DisableExtension DeriveFunctor,"-XNoDeriveFunctor"),(EnableExtension DeriveTraversable,"-XDeriveTraversable"),(DisableExtension DeriveTraversable,"-XNoDeriveTraversable"),(EnableExtension DeriveFoldable,"-XDeriveFoldable"),(DisableExtension DeriveFoldable,"-XNoDeriveFoldable"),(UnknownExtension "DeriveGeneric","-XDeriveGeneric"),(UnknownExtension "NoDeriveGeneric","-XNoDeriveGeneric"),(UnknownExtension "DefaultSignatures","-XDefaultSignatures"),(UnknownExtension "NoDefaultSignatures","-XNoDefaultSignatures"),(EnableExtension TypeSynonymInstances,"-XTypeSynonymInstances"),(DisableExtension TypeSynonymInstances,"-XNoTypeSynonymInstances"),(EnableExtension FlexibleContexts,"-XFlexibleContexts"),(DisableExtension FlexibleContexts,"-XNoFlexibleContexts"),(EnableExtension FlexibleInstances,"-XFlexibleInstances"),(DisableExtension FlexibleInstances,"-XNoFlexibleInstances"),(EnableExtension ConstrainedClassMethods,"-XConstrainedClassMethods"),(DisableExtension ConstrainedClassMethods,"-XNoConstrainedClassMethods"),(EnableExtension MultiParamTypeClasses,"-XMultiParamTypeClasses"),(DisableExtension MultiParamTypeClasses,"-XNoMultiParamTypeClasses"),(EnableExtension FunctionalDependencies,"-XFunctionalDependencies"),(DisableExtension FunctionalDependencies,"-XNoFunctionalDependencies"),(EnableExtension GeneralizedNewtypeDeriving,"-XGeneralizedNewtypeDeriving"),(DisableExtension GeneralizedNewtypeDeriving,"-XNoGeneralizedNewtypeDeriving"),(EnableExtension OverlappingInstances,"-XOverlappingInstances"),(DisableExtension OverlappingInstances,"-XNoOverlappingInstances"),(EnableExtension UndecidableInstances,"-XUndecidableInstances"),(DisableExtension UndecidableInstances,"-XNoUndecidableInstances"),(EnableExtension IncoherentInstances,"-XIncoherentInstances"),(DisableExtension IncoherentInstances,"-XNoIncoherentInstances"),(EnableExtension PackageImports,"-XPackageImports"),(DisableExtension PackageImports,"-XNoPackageImports")]}, buildDir = "dist/build", scratchDir = "dist/scratch", libraryConfig = Nothing, executableConfigs = [("bnfc",ComponentLocalBuildInfo {componentPackageDeps = [(InstalledPackageId "array-0.4.0.0-59d1cc0e7979167b002f021942d60f46",PackageIdentifier {pkgName = PackageName "array", pkgVersion = Version {versionBranch = [0,4,0,0], versionTags = []}}),(InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",PackageIdentifier {pkgName = PackageName "base", pkgVersion = Version {versionBranch = [4,5,0,0], versionTags = []}}),(InstalledPackageId "directory-1.1.0.2-ebacad9b5233212b1abbebce9b7e6524",PackageIdentifier {pkgName = PackageName "directory", pkgVersion = Version {versionBranch = [1,1,0,2], versionTags = []}}),(InstalledPackageId "mtl-2.0.1.0-db19dd8a7700e3d3adda8aa8fe5bf53d",PackageIdentifier {pkgName = PackageName "mtl", pkgVersion = Version {versionBranch = [2,0,1,0], versionTags = []}}),(InstalledPackageId "process-1.1.0.1-18dadd8ad5fc640f55a7afdc7aace500",PackageIdentifier {pkgName = PackageName "process", pkgVersion = Version {versionBranch = [1,1,0,1], versionTags = []}})]})], compBuildOrder = [CExeName "bnfc"], testSuiteConfigs = [], benchmarkConfigs = [], installedPkgs = PackageIndex (fromList [(InstalledPackageId "array-0.4.0.0-59d1cc0e7979167b002f021942d60f46",InstalledPackageInfo {installedPackageId = InstalledPackageId "array-0.4.0.0-59d1cc0e7979167b002f021942d60f46", sourcePackageId = PackageIdentifier {pkgName = PackageName "array", pkgVersion = Version {versionBranch = [0,4,0,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "Mutable and immutable arrays", description = "This package defines the classes @IArray@ of immutable arrays and\n@MArray@ of arrays mutable within appropriate monads, as well as\nsome instances of these classes.", category = "Data Structures", exposed = True, exposedModules = [ModuleName ["Data","Array","Base"],ModuleName ["Data","Array","IArray"],ModuleName ["Data","Array","IO"],ModuleName ["Data","Array","IO","Safe"],ModuleName ["Data","Array","IO","Internals"],ModuleName ["Data","Array","MArray"],ModuleName ["Data","Array","MArray","Safe"],ModuleName ["Data","Array","ST"],ModuleName ["Data","Array","ST","Safe"],ModuleName ["Data","Array","Storable"],ModuleName ["Data","Array","Storable","Safe"],ModuleName ["Data","Array","Storable","Internals"],ModuleName ["Data","Array","Unboxed"],ModuleName ["Data","Array","Unsafe"],ModuleName ["Data","Array"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/array-0.4.0.0"], libraryDirs = ["/usr/lib/ghc/array-0.4.0.0"], hsLibraries = ["HSarray-0.4.0.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/array-0.4.0.0/array.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/array-0.4.0.0"]}),(InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageInfo {installedPackageId = InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702", sourcePackageId = PackageIdentifier {pkgName = PackageName "base", pkgVersion = Version {versionBranch = [4,5,0,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "Basic libraries", description = "This package contains the Prelude and its support libraries,\nand a large collection of useful libraries ranging from data\nstructures to parsing combinators and debugging utilities.", category = "", exposed = True, exposedModules = [ModuleName ["Foreign","Concurrent"],ModuleName ["GHC","Arr"],ModuleName ["GHC","Base"],ModuleName ["GHC","Conc"],ModuleName ["GHC","Conc","IO"],ModuleName ["GHC","Conc","Signal"],ModuleName ["GHC","Conc","Sync"],ModuleName ["GHC","ConsoleHandler"],ModuleName ["GHC","Constants"],ModuleName ["GHC","Desugar"],ModuleName ["GHC","Enum"],ModuleName ["GHC","Environment"],ModuleName ["GHC","Err"],ModuleName ["GHC","Exception"],ModuleName ["GHC","Exts"],ModuleName ["GHC","Fingerprint"],ModuleName ["GHC","Fingerprint","Type"],ModuleName ["GHC","Float"],ModuleName ["GHC","Float","ConversionUtils"],ModuleName ["GHC","Float","RealFracMethods"],ModuleName ["GHC","Foreign"],ModuleName ["GHC","ForeignPtr"],ModuleName ["GHC","Handle"],ModuleName ["GHC","IO"],ModuleName ["GHC","IO","Buffer"],ModuleName ["GHC","IO","BufferedIO"],ModuleName ["GHC","IO","Device"],ModuleName ["GHC","IO","Encoding"],ModuleName ["GHC","IO","Encoding","CodePage"],ModuleName ["GHC","IO","Encoding","Failure"],ModuleName ["GHC","IO","Encoding","Iconv"],ModuleName ["GHC","IO","Encoding","Latin1"],ModuleName ["GHC","IO","Encoding","Types"],ModuleName ["GHC","IO","Encoding","UTF16"],ModuleName ["GHC","IO","Encoding","UTF32"],ModuleName ["GHC","IO","Encoding","UTF8"],ModuleName ["GHC","IO","Exception"],ModuleName ["GHC","IO","FD"],ModuleName ["GHC","IO","Handle"],ModuleName ["GHC","IO","Handle","FD"],ModuleName ["GHC","IO","Handle","Internals"],ModuleName ["GHC","IO","Handle","Text"],ModuleName ["GHC","IO","Handle","Types"],ModuleName ["GHC","IO","IOMode"],ModuleName ["GHC","IOArray"],ModuleName ["GHC","IOBase"],ModuleName ["GHC","IORef"],ModuleName ["GHC","Int"],ModuleName ["GHC","List"],ModuleName ["GHC","MVar"],ModuleName ["GHC","Num"],ModuleName ["GHC","PArr"],ModuleName ["GHC","Pack"],ModuleName ["GHC","Ptr"],ModuleName ["GHC","Read"],ModuleName ["GHC","Real"],ModuleName ["GHC","ST"],ModuleName ["GHC","Stack"],ModuleName ["GHC","Stats"],ModuleName ["GHC","Show"],ModuleName ["GHC","Stable"],ModuleName ["GHC","Storable"],ModuleName ["GHC","STRef"],ModuleName ["GHC","TopHandler"],ModuleName ["GHC","Unicode"],ModuleName ["GHC","Weak"],ModuleName ["GHC","Word"],ModuleName ["System","Timeout"],ModuleName ["GHC","Event"],ModuleName ["Control","Applicative"],ModuleName ["Control","Arrow"],ModuleName ["Control","Category"],ModuleName ["Control","Concurrent"],ModuleName ["Control","Concurrent","Chan"],ModuleName ["Control","Concurrent","MVar"],ModuleName ["Control","Concurrent","QSem"],ModuleName ["Control","Concurrent","QSemN"],ModuleName ["Control","Concurrent","SampleVar"],ModuleName ["Control","Exception"],ModuleName ["Control","Exception","Base"],ModuleName ["Control","OldException"],ModuleName ["Control","Monad"],ModuleName ["Control","Monad","Fix"],ModuleName ["Control","Monad","Instances"],ModuleName ["Control","Monad","ST"],ModuleName ["Control","Monad","ST","Safe"],ModuleName ["Control","Monad","ST","Unsafe"],ModuleName ["Control","Monad","ST","Lazy"],ModuleName ["Control","Monad","ST","Lazy","Safe"],ModuleName ["Control","Monad","ST","Lazy","Unsafe"],ModuleName ["Control","Monad","ST","Strict"],ModuleName ["Control","Monad","Zip"],ModuleName ["Data","Bits"],ModuleName ["Data","Bool"],ModuleName ["Data","Char"],ModuleName ["Data","Complex"],ModuleName ["Data","Dynamic"],ModuleName ["Data","Either"],ModuleName ["Data","Eq"],ModuleName ["Data","Data"],ModuleName ["Data","Fixed"],ModuleName ["Data","Foldable"],ModuleName ["Data","Function"],ModuleName ["Data","Functor"],ModuleName ["Data","HashTable"],ModuleName ["Data","IORef"],ModuleName ["Data","Int"],ModuleName ["Data","Ix"],ModuleName ["Data","List"],ModuleName ["Data","Maybe"],ModuleName ["Data","Monoid"],ModuleName ["Data","Ord"],ModuleName ["Data","Ratio"],ModuleName ["Data","STRef"],ModuleName ["Data","STRef","Lazy"],ModuleName ["Data","STRef","Strict"],ModuleName ["Data","String"],ModuleName ["Data","Traversable"],ModuleName ["Data","Tuple"],ModuleName ["Data","Typeable"],ModuleName ["Data","Typeable","Internal"],ModuleName ["Data","Unique"],ModuleName ["Data","Version"],ModuleName ["Data","Word"],ModuleName ["Debug","Trace"],ModuleName ["Foreign"],ModuleName ["Foreign","C"],ModuleName ["Foreign","C","Error"],ModuleName ["Foreign","C","String"],ModuleName ["Foreign","C","Types"],ModuleName ["Foreign","ForeignPtr"],ModuleName ["Foreign","ForeignPtr","Safe"],ModuleName ["Foreign","ForeignPtr","Unsafe"],ModuleName ["Foreign","Marshal"],ModuleName ["Foreign","Marshal","Alloc"],ModuleName ["Foreign","Marshal","Array"],ModuleName ["Foreign","Marshal","Error"],ModuleName ["Foreign","Marshal","Pool"],ModuleName ["Foreign","Marshal","Safe"],ModuleName ["Foreign","Marshal","Utils"],ModuleName ["Foreign","Marshal","Unsafe"],ModuleName ["Foreign","Ptr"],ModuleName ["Foreign","Safe"],ModuleName ["Foreign","StablePtr"],ModuleName ["Foreign","Storable"],ModuleName ["Numeric"],ModuleName ["Prelude"],ModuleName ["System","Console","GetOpt"],ModuleName ["System","CPUTime"],ModuleName ["System","Environment"],ModuleName ["System","Exit"],ModuleName ["System","IO"],ModuleName ["System","IO","Error"],ModuleName ["System","IO","Unsafe"],ModuleName ["System","Info"],ModuleName ["System","Mem"],ModuleName ["System","Mem","StableName"],ModuleName ["System","Mem","Weak"],ModuleName ["System","Posix","Internals"],ModuleName ["System","Posix","Types"],ModuleName ["Text","ParserCombinators","ReadP"],ModuleName ["Text","ParserCombinators","ReadPrec"],ModuleName ["Text","Printf"],ModuleName ["Text","Read"],ModuleName ["Text","Read","Lex"],ModuleName ["Text","Show"],ModuleName ["Text","Show","Functions"],ModuleName ["Unsafe","Coerce"]], hiddenModules = [ModuleName ["GHC","Event","Array"],ModuleName ["GHC","Event","Clock"],ModuleName ["GHC","Event","Control"],ModuleName ["GHC","Event","EPoll"],ModuleName ["GHC","Event","IntMap"],ModuleName ["GHC","Event","Internal"],ModuleName ["GHC","Event","KQueue"],ModuleName ["GHC","Event","Manager"],ModuleName ["GHC","Event","PSQ"],ModuleName ["GHC","Event","Poll"],ModuleName ["GHC","Event","Thread"],ModuleName ["GHC","Event","Unique"],ModuleName ["Control","Monad","ST","Imp"],ModuleName ["Control","Monad","ST","Lazy","Imp"],ModuleName ["Foreign","ForeignPtr","Imp"]], trusted = False, importDirs = ["/usr/lib/ghc/base-4.5.0.0"], libraryDirs = ["/usr/lib/ghc/base-4.5.0.0"], hsLibraries = ["HSbase-4.5.0.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/base-4.5.0.0/include"], includes = ["HsBase.h"], depends = [InstalledPackageId "ghc-prim-0.2.0.0-c2ff696e5b8ec4d4b2bc2e42085fe471",InstalledPackageId "integer-gmp-0.4.0.0-3cccac07aef8e27023f605c1f45bdf74",InstalledPackageId "builtin_rts"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/base-4.5.0.0/base.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/base-4.5.0.0"]}),(InstalledPackageId "builtin_rts",InstalledPackageInfo {installedPackageId = InstalledPackageId "builtin_rts", sourcePackageId = PackageIdentifier {pkgName = PackageName "rts", pkgVersion = Version {versionBranch = [1,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "glasgow-haskell-users@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "", description = "", category = "", exposed = True, exposedModules = [], hiddenModules = [], trusted = False, importDirs = [], libraryDirs = ["/usr/lib/ghc"], hsLibraries = ["HSrts"], extraLibraries = ["ffi","m","rt","dl"], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/include"], includes = ["Stg.h"], depends = [], hugsOptions = [], ccOptions = [], ldOptions = ["-u","ghczmprim_GHCziTypes_Izh_static_info","-u","ghczmprim_GHCziTypes_Czh_static_info","-u","ghczmprim_GHCziTypes_Fzh_static_info","-u","ghczmprim_GHCziTypes_Dzh_static_info","-u","base_GHCziPtr_Ptr_static_info","-u","base_GHCziWord_Wzh_static_info","-u","base_GHCziInt_I8zh_static_info","-u","base_GHCziInt_I16zh_static_info","-u","base_GHCziInt_I32zh_static_info","-u","base_GHCziInt_I64zh_static_info","-u","base_GHCziWord_W8zh_static_info","-u","base_GHCziWord_W16zh_static_info","-u","base_GHCziWord_W32zh_static_info","-u","base_GHCziWord_W64zh_static_info","-u","base_GHCziStable_StablePtr_static_info","-u","ghczmprim_GHCziTypes_Izh_con_info","-u","ghczmprim_GHCziTypes_Czh_con_info","-u","ghczmprim_GHCziTypes_Fzh_con_info","-u","ghczmprim_GHCziTypes_Dzh_con_info","-u","base_GHCziPtr_Ptr_con_info","-u","base_GHCziPtr_FunPtr_con_info","-u","base_GHCziStable_StablePtr_con_info","-u","ghczmprim_GHCziTypes_False_closure","-u","ghczmprim_GHCziTypes_True_closure","-u","base_GHCziPack_unpackCString_closure","-u","base_GHCziIOziException_stackOverflow_closure","-u","base_GHCziIOziException_heapOverflow_closure","-u","base_ControlziExceptionziBase_nonTermination_closure","-u","base_GHCziIOziException_blockedIndefinitelyOnMVar_closure","-u","base_GHCziIOziException_blockedIndefinitelyOnSTM_closure","-u","base_ControlziExceptionziBase_nestedAtomically_closure","-u","base_GHCziWeak_runFinalizzerBatch_closure","-u","base_GHCziTopHandler_flushStdHandles_closure","-u","base_GHCziTopHandler_runIO_closure","-u","base_GHCziTopHandler_runNonIO_closure","-u","base_GHCziConcziIO_ensureIOManagerIsRunning_closure","-u","base_GHCziConcziSync_runSparks_closure","-u","base_GHCziConcziSignal_runHandlers_closure"], frameworkDirs = [], frameworks = [], haddockInterfaces = [], haddockHTMLs = []}),(InstalledPackageId "bytestring-0.9.2.1-18f26186028d7c0e92e78edc9071d376",InstalledPackageInfo {installedPackageId = InstalledPackageId "bytestring-0.9.2.1-18f26186028d7c0e92e78edc9071d376", sourcePackageId = PackageIdentifier {pkgName = PackageName "bytestring", pkgVersion = Version {versionBranch = [0,9,2,1], versionTags = []}}, license = BSD3, copyright = "Copyright (c) Don Stewart 2005-2009,\n(c) Duncan Coutts 2006-2009,\n(c) David Roundy 2003-2005.", maintainer = "dons00@gmail.com, duncan@community.haskell.org", author = "Don Stewart, Duncan Coutts", stability = "", homepage = "http://www.cse.unsw.edu.au/~dons/fps.html", pkgUrl = "", synopsis = "Fast, packed, strict and lazy byte arrays with a list interface", description = "A time and space-efficient implementation of byte vectors using\npacked Word8 arrays, suitable for high performance use, both in terms\nof large data quantities, or high speed requirements. Byte vectors\nare encoded as strict 'Word8' arrays of bytes, and lazy lists of\nstrict chunks, held in a 'ForeignPtr', and can be passed between C\nand Haskell with little effort.\n\nTest coverage data for this library is available at:\n", category = "Data", exposed = True, exposedModules = [ModuleName ["Data","ByteString"],ModuleName ["Data","ByteString","Char8"],ModuleName ["Data","ByteString","Unsafe"],ModuleName ["Data","ByteString","Internal"],ModuleName ["Data","ByteString","Lazy"],ModuleName ["Data","ByteString","Lazy","Char8"],ModuleName ["Data","ByteString","Lazy","Internal"],ModuleName ["Data","ByteString","Fusion"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/bytestring-0.9.2.1"], libraryDirs = ["/usr/lib/ghc/bytestring-0.9.2.1"], hsLibraries = ["HSbytestring-0.9.2.1"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/bytestring-0.9.2.1/include"], includes = ["fpstring.h"], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageId "ghc-prim-0.2.0.0-c2ff696e5b8ec4d4b2bc2e42085fe471"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/bytestring-0.9.2.1/bytestring.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/bytestring-0.9.2.1"]}),(InstalledPackageId "directory-1.1.0.2-ebacad9b5233212b1abbebce9b7e6524",InstalledPackageInfo {installedPackageId = InstalledPackageId "directory-1.1.0.2-ebacad9b5233212b1abbebce9b7e6524", sourcePackageId = PackageIdentifier {pkgName = PackageName "directory", pkgVersion = Version {versionBranch = [1,1,0,2], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "library for directory handling", description = "This package provides a library for handling directories.", category = "System", exposed = True, exposedModules = [ModuleName ["System","Directory"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/directory-1.1.0.2"], libraryDirs = ["/usr/lib/ghc/directory-1.1.0.2"], hsLibraries = ["HSdirectory-1.1.0.2"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/directory-1.1.0.2/include"], includes = ["HsDirectory.h"], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageId "filepath-1.3.0.0-973f5e9fbed93e25cbe66dfeb6b99ad9",InstalledPackageId "old-time-1.1.0.0-b77788a065c86ada9ba279afa5e04576",InstalledPackageId "unix-2.5.1.0-b7c7408f284e3570d0d4dbd1f423845f"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/directory-1.1.0.2/directory.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/directory-1.1.0.2"]}),(InstalledPackageId "filepath-1.3.0.0-973f5e9fbed93e25cbe66dfeb6b99ad9",InstalledPackageInfo {installedPackageId = InstalledPackageId "filepath-1.3.0.0-973f5e9fbed93e25cbe66dfeb6b99ad9", sourcePackageId = PackageIdentifier {pkgName = PackageName "filepath", pkgVersion = Version {versionBranch = [1,3,0,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "", author = "Neil Mitchell", stability = "", homepage = "http://www-users.cs.york.ac.uk/~ndm/filepath/", pkgUrl = "", synopsis = "Library for manipulating FilePaths in a cross platform way.", description = "", category = "System", exposed = True, exposedModules = [ModuleName ["System","FilePath"],ModuleName ["System","FilePath","Posix"],ModuleName ["System","FilePath","Windows"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/filepath-1.3.0.0"], libraryDirs = ["/usr/lib/ghc/filepath-1.3.0.0"], hsLibraries = ["HSfilepath-1.3.0.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/filepath-1.3.0.0/filepath.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/filepath-1.3.0.0"]}),(InstalledPackageId "ghc-prim-0.2.0.0-c2ff696e5b8ec4d4b2bc2e42085fe471",InstalledPackageInfo {installedPackageId = InstalledPackageId "ghc-prim-0.2.0.0-c2ff696e5b8ec4d4b2bc2e42085fe471", sourcePackageId = PackageIdentifier {pkgName = PackageName "ghc-prim", pkgVersion = Version {versionBranch = [0,2,0,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "GHC primitives", description = "GHC primitives.", category = "", exposed = True, exposedModules = [ModuleName ["GHC","Prim"],ModuleName ["GHC","Classes"],ModuleName ["GHC","CString"],ModuleName ["GHC","Debug"],ModuleName ["GHC","Generics"],ModuleName ["GHC","Magic"],ModuleName ["GHC","PrimopWrappers"],ModuleName ["GHC","IntWord64"],ModuleName ["GHC","Tuple"],ModuleName ["GHC","Types"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/ghc-prim-0.2.0.0"], libraryDirs = ["/usr/lib/ghc/ghc-prim-0.2.0.0"], hsLibraries = ["HSghc-prim-0.2.0.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "builtin_rts"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/ghc-prim-0.2.0.0/ghc-prim.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/ghc-prim-0.2.0.0"]}),(InstalledPackageId "integer-gmp-0.4.0.0-3cccac07aef8e27023f605c1f45bdf74",InstalledPackageInfo {installedPackageId = InstalledPackageId "integer-gmp-0.4.0.0-3cccac07aef8e27023f605c1f45bdf74", sourcePackageId = PackageIdentifier {pkgName = PackageName "integer-gmp", pkgVersion = Version {versionBranch = [0,4,0,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "Integer library based on GMP", description = "This package contains an Integer library based on GMP.", category = "", exposed = True, exposedModules = [ModuleName ["GHC","Integer"],ModuleName ["GHC","Integer","GMP","Internals"],ModuleName ["GHC","Integer","GMP","Prim"],ModuleName ["GHC","Integer","Logarithms"],ModuleName ["GHC","Integer","Logarithms","Internals"]], hiddenModules = [ModuleName ["GHC","Integer","Type"]], trusted = False, importDirs = ["/usr/lib/ghc/integer-gmp-0.4.0.0"], libraryDirs = ["/usr/lib/ghc/integer-gmp-0.4.0.0"], hsLibraries = ["HSinteger-gmp-0.4.0.0"], extraLibraries = ["gmp"], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "ghc-prim-0.2.0.0-c2ff696e5b8ec4d4b2bc2e42085fe471"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/integer-gmp-0.4.0.0/integer-gmp.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/integer-gmp-0.4.0.0"]}),(InstalledPackageId "mtl-2.0.1.0-db19dd8a7700e3d3adda8aa8fe5bf53d",InstalledPackageInfo {installedPackageId = InstalledPackageId "mtl-2.0.1.0-db19dd8a7700e3d3adda8aa8fe5bf53d", sourcePackageId = PackageIdentifier {pkgName = PackageName "mtl", pkgVersion = Version {versionBranch = [2,0,1,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "Andy Gill", stability = "", homepage = "", pkgUrl = "", synopsis = "Monad classes, using functional dependencies", description = "Monad classes using functional dependencies, with instances\nfor various monad transformers, inspired by the paper\n/Functional Programming with Overloading and Higher-Order Polymorphism/,\nby Mark P Jones, in /Advanced School of Functional Programming/, 1995\n().", category = "Control", exposed = True, exposedModules = [ModuleName ["Control","Monad","Cont"],ModuleName ["Control","Monad","Cont","Class"],ModuleName ["Control","Monad","Error"],ModuleName ["Control","Monad","Error","Class"],ModuleName ["Control","Monad","Identity"],ModuleName ["Control","Monad","List"],ModuleName ["Control","Monad","RWS"],ModuleName ["Control","Monad","RWS","Class"],ModuleName ["Control","Monad","RWS","Lazy"],ModuleName ["Control","Monad","RWS","Strict"],ModuleName ["Control","Monad","Reader"],ModuleName ["Control","Monad","Reader","Class"],ModuleName ["Control","Monad","State"],ModuleName ["Control","Monad","State","Class"],ModuleName ["Control","Monad","State","Lazy"],ModuleName ["Control","Monad","State","Strict"],ModuleName ["Control","Monad","Trans"],ModuleName ["Control","Monad","Writer"],ModuleName ["Control","Monad","Writer","Class"],ModuleName ["Control","Monad","Writer","Lazy"],ModuleName ["Control","Monad","Writer","Strict"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/haskell-packages/ghc/lib/mtl-2.0.1.0/ghc-7.4.1"], libraryDirs = ["/usr/lib/haskell-packages/ghc/lib/mtl-2.0.1.0/ghc-7.4.1"], hsLibraries = ["HSmtl-2.0.1.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageId "transformers-0.2.2.0-367ec8196a45fab9903c082ddf1e964e"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/mtl-2.0.1.0/mtl.haddock"], haddockHTMLs = ["/usr/share/doc/libghc-mtl-doc/html/"]}),(InstalledPackageId "old-locale-1.0.0.4-a2c3d942f886fb70df8171795fdc2e5a",InstalledPackageInfo {installedPackageId = InstalledPackageId "old-locale-1.0.0.4-a2c3d942f886fb70df8171795fdc2e5a", sourcePackageId = PackageIdentifier {pkgName = PackageName "old-locale", pkgVersion = Version {versionBranch = [1,0,0,4], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "locale library", description = "This package provides the old locale library.\nFor new code, the new locale library is recommended.", category = "System", exposed = True, exposedModules = [ModuleName ["System","Locale"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/old-locale-1.0.0.4"], libraryDirs = ["/usr/lib/ghc/old-locale-1.0.0.4"], hsLibraries = ["HSold-locale-1.0.0.4"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/old-locale-1.0.0.4/old-locale.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/old-locale-1.0.0.4"]}),(InstalledPackageId "old-time-1.1.0.0-b77788a065c86ada9ba279afa5e04576",InstalledPackageInfo {installedPackageId = InstalledPackageId "old-time-1.1.0.0-b77788a065c86ada9ba279afa5e04576", sourcePackageId = PackageIdentifier {pkgName = PackageName "old-time", pkgVersion = Version {versionBranch = [1,1,0,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "Time library", description = "This package provides the old time library.\nFor new code, the new time library is recommended.", category = "System", exposed = True, exposedModules = [ModuleName ["System","Time"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/old-time-1.1.0.0"], libraryDirs = ["/usr/lib/ghc/old-time-1.1.0.0"], hsLibraries = ["HSold-time-1.1.0.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/old-time-1.1.0.0/include"], includes = ["HsTime.h"], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageId "old-locale-1.0.0.4-a2c3d942f886fb70df8171795fdc2e5a"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/old-time-1.1.0.0/old-time.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/old-time-1.1.0.0"]}),(InstalledPackageId "process-1.1.0.1-18dadd8ad5fc640f55a7afdc7aace500",InstalledPackageInfo {installedPackageId = InstalledPackageId "process-1.1.0.1-18dadd8ad5fc640f55a7afdc7aace500", sourcePackageId = PackageIdentifier {pkgName = PackageName "process", pkgVersion = Version {versionBranch = [1,1,0,1], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "Process libraries", description = "This package contains libraries for dealing with system processes.", category = "System", exposed = True, exposedModules = [ModuleName ["System","Process","Internals"],ModuleName ["System","Process"],ModuleName ["System","Cmd"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/process-1.1.0.1"], libraryDirs = ["/usr/lib/ghc/process-1.1.0.1"], hsLibraries = ["HSprocess-1.1.0.1"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/process-1.1.0.1/include"], includes = ["runProcess.h"], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageId "directory-1.1.0.2-ebacad9b5233212b1abbebce9b7e6524",InstalledPackageId "filepath-1.3.0.0-973f5e9fbed93e25cbe66dfeb6b99ad9",InstalledPackageId "unix-2.5.1.0-b7c7408f284e3570d0d4dbd1f423845f"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/process-1.1.0.1/process.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/process-1.1.0.1"]}),(InstalledPackageId "transformers-0.2.2.0-367ec8196a45fab9903c082ddf1e964e",InstalledPackageInfo {installedPackageId = InstalledPackageId "transformers-0.2.2.0-367ec8196a45fab9903c082ddf1e964e", sourcePackageId = PackageIdentifier {pkgName = PackageName "transformers", pkgVersion = Version {versionBranch = [0,2,2,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "Ross Paterson ", author = "Andy Gill, Ross Paterson", stability = "", homepage = "", pkgUrl = "", synopsis = "Concrete functor and monad transformers", description = "Haskell 98 part of a monad transformer library, inspired by the paper\n\\\"Functional Programming with Overloading and Higher-Order Polymorphism\\\",\nby Mark P Jones, in /Advanced School of Functional Programming/, 1995\n().\n\nThis part contains the monad transformer class, the concrete monad\ntransformers, operations and liftings. It can be used on its own\nin Haskell 98 code, or with the monad classes in the @monads-fd@ or\n@monads-tf@ packages, which automatically lift operations introduced\nby monad transformers through other transformers.", category = "Control", exposed = True, exposedModules = [ModuleName ["Control","Monad","IO","Class"],ModuleName ["Control","Monad","Trans","Class"],ModuleName ["Control","Monad","Trans","Cont"],ModuleName ["Control","Monad","Trans","Error"],ModuleName ["Control","Monad","Trans","Identity"],ModuleName ["Control","Monad","Trans","List"],ModuleName ["Control","Monad","Trans","Maybe"],ModuleName ["Control","Monad","Trans","Reader"],ModuleName ["Control","Monad","Trans","RWS"],ModuleName ["Control","Monad","Trans","RWS","Lazy"],ModuleName ["Control","Monad","Trans","RWS","Strict"],ModuleName ["Control","Monad","Trans","State"],ModuleName ["Control","Monad","Trans","State","Lazy"],ModuleName ["Control","Monad","Trans","State","Strict"],ModuleName ["Control","Monad","Trans","Writer"],ModuleName ["Control","Monad","Trans","Writer","Lazy"],ModuleName ["Control","Monad","Trans","Writer","Strict"],ModuleName ["Data","Functor","Compose"],ModuleName ["Data","Functor","Constant"],ModuleName ["Data","Functor","Identity"],ModuleName ["Data","Functor","Product"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/haskell-packages/ghc/lib/transformers-0.2.2.0/ghc-7.4.1"], libraryDirs = ["/usr/lib/haskell-packages/ghc/lib/transformers-0.2.2.0/ghc-7.4.1"], hsLibraries = ["HStransformers-0.2.2.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/transformers-0.2.2.0/transformers.haddock"], haddockHTMLs = ["/usr/share/doc/libghc-transformers-doc/html/"]}),(InstalledPackageId "unix-2.5.1.0-b7c7408f284e3570d0d4dbd1f423845f",InstalledPackageInfo {installedPackageId = InstalledPackageId "unix-2.5.1.0-b7c7408f284e3570d0d4dbd1f423845f", sourcePackageId = PackageIdentifier {pkgName = PackageName "unix", pkgVersion = Version {versionBranch = [2,5,1,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "POSIX functionality", description = "This package gives you access to the set of operating system\nservices standardised by POSIX 1003.1b (or the IEEE Portable\nOperating System Interface for Computing Environments -\nIEEE Std. 1003.1).\n\nThe package is not supported under Windows (except under Cygwin).", category = "System", exposed = True, exposedModules = [ModuleName ["System","Posix"],ModuleName ["System","Posix","ByteString"],ModuleName ["System","Posix","Error"],ModuleName ["System","Posix","Resource"],ModuleName ["System","Posix","Time"],ModuleName ["System","Posix","Unistd"],ModuleName ["System","Posix","User"],ModuleName ["System","Posix","Signals"],ModuleName ["System","Posix","Signals","Exts"],ModuleName ["System","Posix","Semaphore"],ModuleName ["System","Posix","SharedMem"],ModuleName ["System","Posix","ByteString","FilePath"],ModuleName ["System","Posix","Directory"],ModuleName ["System","Posix","Directory","ByteString"],ModuleName ["System","Posix","DynamicLinker","Module"],ModuleName ["System","Posix","DynamicLinker","Module","ByteString"],ModuleName ["System","Posix","DynamicLinker","Prim"],ModuleName ["System","Posix","DynamicLinker","ByteString"],ModuleName ["System","Posix","DynamicLinker"],ModuleName ["System","Posix","Files"],ModuleName ["System","Posix","Files","ByteString"],ModuleName ["System","Posix","IO"],ModuleName ["System","Posix","IO","ByteString"],ModuleName ["System","Posix","Env"],ModuleName ["System","Posix","Env","ByteString"],ModuleName ["System","Posix","Process"],ModuleName ["System","Posix","Process","Internals"],ModuleName ["System","Posix","Process","ByteString"],ModuleName ["System","Posix","Temp"],ModuleName ["System","Posix","Temp","ByteString"],ModuleName ["System","Posix","Terminal"],ModuleName ["System","Posix","Terminal","ByteString"]], hiddenModules = [ModuleName ["System","Posix","Directory","Common"],ModuleName ["System","Posix","DynamicLinker","Common"],ModuleName ["System","Posix","Files","Common"],ModuleName ["System","Posix","IO","Common"],ModuleName ["System","Posix","Process","Common"],ModuleName ["System","Posix","Terminal","Common"]], trusted = False, importDirs = ["/usr/lib/ghc/unix-2.5.1.0"], libraryDirs = ["/usr/lib/ghc/unix-2.5.1.0"], hsLibraries = ["HSunix-2.5.1.0"], extraLibraries = ["rt","util","dl","pthread"], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/unix-2.5.1.0/include"], includes = ["HsUnix.h","execvpe.h"], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageId "bytestring-0.9.2.1-18f26186028d7c0e92e78edc9071d376"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/unix-2.5.1.0/unix.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/unix-2.5.1.0"]})]) (fromList [(PackageName "array",fromList [(Version {versionBranch = [0,4,0,0], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "array-0.4.0.0-59d1cc0e7979167b002f021942d60f46", sourcePackageId = PackageIdentifier {pkgName = PackageName "array", pkgVersion = Version {versionBranch = [0,4,0,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "Mutable and immutable arrays", description = "This package defines the classes @IArray@ of immutable arrays and\n@MArray@ of arrays mutable within appropriate monads, as well as\nsome instances of these classes.", category = "Data Structures", exposed = True, exposedModules = [ModuleName ["Data","Array","Base"],ModuleName ["Data","Array","IArray"],ModuleName ["Data","Array","IO"],ModuleName ["Data","Array","IO","Safe"],ModuleName ["Data","Array","IO","Internals"],ModuleName ["Data","Array","MArray"],ModuleName ["Data","Array","MArray","Safe"],ModuleName ["Data","Array","ST"],ModuleName ["Data","Array","ST","Safe"],ModuleName ["Data","Array","Storable"],ModuleName ["Data","Array","Storable","Safe"],ModuleName ["Data","Array","Storable","Internals"],ModuleName ["Data","Array","Unboxed"],ModuleName ["Data","Array","Unsafe"],ModuleName ["Data","Array"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/array-0.4.0.0"], libraryDirs = ["/usr/lib/ghc/array-0.4.0.0"], hsLibraries = ["HSarray-0.4.0.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/array-0.4.0.0/array.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/array-0.4.0.0"]}])]),(PackageName "base",fromList [(Version {versionBranch = [4,5,0,0], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702", sourcePackageId = PackageIdentifier {pkgName = PackageName "base", pkgVersion = Version {versionBranch = [4,5,0,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "Basic libraries", description = "This package contains the Prelude and its support libraries,\nand a large collection of useful libraries ranging from data\nstructures to parsing combinators and debugging utilities.", category = "", exposed = True, exposedModules = [ModuleName ["Foreign","Concurrent"],ModuleName ["GHC","Arr"],ModuleName ["GHC","Base"],ModuleName ["GHC","Conc"],ModuleName ["GHC","Conc","IO"],ModuleName ["GHC","Conc","Signal"],ModuleName ["GHC","Conc","Sync"],ModuleName ["GHC","ConsoleHandler"],ModuleName ["GHC","Constants"],ModuleName ["GHC","Desugar"],ModuleName ["GHC","Enum"],ModuleName ["GHC","Environment"],ModuleName ["GHC","Err"],ModuleName ["GHC","Exception"],ModuleName ["GHC","Exts"],ModuleName ["GHC","Fingerprint"],ModuleName ["GHC","Fingerprint","Type"],ModuleName ["GHC","Float"],ModuleName ["GHC","Float","ConversionUtils"],ModuleName ["GHC","Float","RealFracMethods"],ModuleName ["GHC","Foreign"],ModuleName ["GHC","ForeignPtr"],ModuleName ["GHC","Handle"],ModuleName ["GHC","IO"],ModuleName ["GHC","IO","Buffer"],ModuleName ["GHC","IO","BufferedIO"],ModuleName ["GHC","IO","Device"],ModuleName ["GHC","IO","Encoding"],ModuleName ["GHC","IO","Encoding","CodePage"],ModuleName ["GHC","IO","Encoding","Failure"],ModuleName ["GHC","IO","Encoding","Iconv"],ModuleName ["GHC","IO","Encoding","Latin1"],ModuleName ["GHC","IO","Encoding","Types"],ModuleName ["GHC","IO","Encoding","UTF16"],ModuleName ["GHC","IO","Encoding","UTF32"],ModuleName ["GHC","IO","Encoding","UTF8"],ModuleName ["GHC","IO","Exception"],ModuleName ["GHC","IO","FD"],ModuleName ["GHC","IO","Handle"],ModuleName ["GHC","IO","Handle","FD"],ModuleName ["GHC","IO","Handle","Internals"],ModuleName ["GHC","IO","Handle","Text"],ModuleName ["GHC","IO","Handle","Types"],ModuleName ["GHC","IO","IOMode"],ModuleName ["GHC","IOArray"],ModuleName ["GHC","IOBase"],ModuleName ["GHC","IORef"],ModuleName ["GHC","Int"],ModuleName ["GHC","List"],ModuleName ["GHC","MVar"],ModuleName ["GHC","Num"],ModuleName ["GHC","PArr"],ModuleName ["GHC","Pack"],ModuleName ["GHC","Ptr"],ModuleName ["GHC","Read"],ModuleName ["GHC","Real"],ModuleName ["GHC","ST"],ModuleName ["GHC","Stack"],ModuleName ["GHC","Stats"],ModuleName ["GHC","Show"],ModuleName ["GHC","Stable"],ModuleName ["GHC","Storable"],ModuleName ["GHC","STRef"],ModuleName ["GHC","TopHandler"],ModuleName ["GHC","Unicode"],ModuleName ["GHC","Weak"],ModuleName ["GHC","Word"],ModuleName ["System","Timeout"],ModuleName ["GHC","Event"],ModuleName ["Control","Applicative"],ModuleName ["Control","Arrow"],ModuleName ["Control","Category"],ModuleName ["Control","Concurrent"],ModuleName ["Control","Concurrent","Chan"],ModuleName ["Control","Concurrent","MVar"],ModuleName ["Control","Concurrent","QSem"],ModuleName ["Control","Concurrent","QSemN"],ModuleName ["Control","Concurrent","SampleVar"],ModuleName ["Control","Exception"],ModuleName ["Control","Exception","Base"],ModuleName ["Control","OldException"],ModuleName ["Control","Monad"],ModuleName ["Control","Monad","Fix"],ModuleName ["Control","Monad","Instances"],ModuleName ["Control","Monad","ST"],ModuleName ["Control","Monad","ST","Safe"],ModuleName ["Control","Monad","ST","Unsafe"],ModuleName ["Control","Monad","ST","Lazy"],ModuleName ["Control","Monad","ST","Lazy","Safe"],ModuleName ["Control","Monad","ST","Lazy","Unsafe"],ModuleName ["Control","Monad","ST","Strict"],ModuleName ["Control","Monad","Zip"],ModuleName ["Data","Bits"],ModuleName ["Data","Bool"],ModuleName ["Data","Char"],ModuleName ["Data","Complex"],ModuleName ["Data","Dynamic"],ModuleName ["Data","Either"],ModuleName ["Data","Eq"],ModuleName ["Data","Data"],ModuleName ["Data","Fixed"],ModuleName ["Data","Foldable"],ModuleName ["Data","Function"],ModuleName ["Data","Functor"],ModuleName ["Data","HashTable"],ModuleName ["Data","IORef"],ModuleName ["Data","Int"],ModuleName ["Data","Ix"],ModuleName ["Data","List"],ModuleName ["Data","Maybe"],ModuleName ["Data","Monoid"],ModuleName ["Data","Ord"],ModuleName ["Data","Ratio"],ModuleName ["Data","STRef"],ModuleName ["Data","STRef","Lazy"],ModuleName ["Data","STRef","Strict"],ModuleName ["Data","String"],ModuleName ["Data","Traversable"],ModuleName ["Data","Tuple"],ModuleName ["Data","Typeable"],ModuleName ["Data","Typeable","Internal"],ModuleName ["Data","Unique"],ModuleName ["Data","Version"],ModuleName ["Data","Word"],ModuleName ["Debug","Trace"],ModuleName ["Foreign"],ModuleName ["Foreign","C"],ModuleName ["Foreign","C","Error"],ModuleName ["Foreign","C","String"],ModuleName ["Foreign","C","Types"],ModuleName ["Foreign","ForeignPtr"],ModuleName ["Foreign","ForeignPtr","Safe"],ModuleName ["Foreign","ForeignPtr","Unsafe"],ModuleName ["Foreign","Marshal"],ModuleName ["Foreign","Marshal","Alloc"],ModuleName ["Foreign","Marshal","Array"],ModuleName ["Foreign","Marshal","Error"],ModuleName ["Foreign","Marshal","Pool"],ModuleName ["Foreign","Marshal","Safe"],ModuleName ["Foreign","Marshal","Utils"],ModuleName ["Foreign","Marshal","Unsafe"],ModuleName ["Foreign","Ptr"],ModuleName ["Foreign","Safe"],ModuleName ["Foreign","StablePtr"],ModuleName ["Foreign","Storable"],ModuleName ["Numeric"],ModuleName ["Prelude"],ModuleName ["System","Console","GetOpt"],ModuleName ["System","CPUTime"],ModuleName ["System","Environment"],ModuleName ["System","Exit"],ModuleName ["System","IO"],ModuleName ["System","IO","Error"],ModuleName ["System","IO","Unsafe"],ModuleName ["System","Info"],ModuleName ["System","Mem"],ModuleName ["System","Mem","StableName"],ModuleName ["System","Mem","Weak"],ModuleName ["System","Posix","Internals"],ModuleName ["System","Posix","Types"],ModuleName ["Text","ParserCombinators","ReadP"],ModuleName ["Text","ParserCombinators","ReadPrec"],ModuleName ["Text","Printf"],ModuleName ["Text","Read"],ModuleName ["Text","Read","Lex"],ModuleName ["Text","Show"],ModuleName ["Text","Show","Functions"],ModuleName ["Unsafe","Coerce"]], hiddenModules = [ModuleName ["GHC","Event","Array"],ModuleName ["GHC","Event","Clock"],ModuleName ["GHC","Event","Control"],ModuleName ["GHC","Event","EPoll"],ModuleName ["GHC","Event","IntMap"],ModuleName ["GHC","Event","Internal"],ModuleName ["GHC","Event","KQueue"],ModuleName ["GHC","Event","Manager"],ModuleName ["GHC","Event","PSQ"],ModuleName ["GHC","Event","Poll"],ModuleName ["GHC","Event","Thread"],ModuleName ["GHC","Event","Unique"],ModuleName ["Control","Monad","ST","Imp"],ModuleName ["Control","Monad","ST","Lazy","Imp"],ModuleName ["Foreign","ForeignPtr","Imp"]], trusted = False, importDirs = ["/usr/lib/ghc/base-4.5.0.0"], libraryDirs = ["/usr/lib/ghc/base-4.5.0.0"], hsLibraries = ["HSbase-4.5.0.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/base-4.5.0.0/include"], includes = ["HsBase.h"], depends = [InstalledPackageId "ghc-prim-0.2.0.0-c2ff696e5b8ec4d4b2bc2e42085fe471",InstalledPackageId "integer-gmp-0.4.0.0-3cccac07aef8e27023f605c1f45bdf74",InstalledPackageId "builtin_rts"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/base-4.5.0.0/base.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/base-4.5.0.0"]}])]),(PackageName "bytestring",fromList [(Version {versionBranch = [0,9,2,1], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "bytestring-0.9.2.1-18f26186028d7c0e92e78edc9071d376", sourcePackageId = PackageIdentifier {pkgName = PackageName "bytestring", pkgVersion = Version {versionBranch = [0,9,2,1], versionTags = []}}, license = BSD3, copyright = "Copyright (c) Don Stewart 2005-2009,\n(c) Duncan Coutts 2006-2009,\n(c) David Roundy 2003-2005.", maintainer = "dons00@gmail.com, duncan@community.haskell.org", author = "Don Stewart, Duncan Coutts", stability = "", homepage = "http://www.cse.unsw.edu.au/~dons/fps.html", pkgUrl = "", synopsis = "Fast, packed, strict and lazy byte arrays with a list interface", description = "A time and space-efficient implementation of byte vectors using\npacked Word8 arrays, suitable for high performance use, both in terms\nof large data quantities, or high speed requirements. Byte vectors\nare encoded as strict 'Word8' arrays of bytes, and lazy lists of\nstrict chunks, held in a 'ForeignPtr', and can be passed between C\nand Haskell with little effort.\n\nTest coverage data for this library is available at:\n", category = "Data", exposed = True, exposedModules = [ModuleName ["Data","ByteString"],ModuleName ["Data","ByteString","Char8"],ModuleName ["Data","ByteString","Unsafe"],ModuleName ["Data","ByteString","Internal"],ModuleName ["Data","ByteString","Lazy"],ModuleName ["Data","ByteString","Lazy","Char8"],ModuleName ["Data","ByteString","Lazy","Internal"],ModuleName ["Data","ByteString","Fusion"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/bytestring-0.9.2.1"], libraryDirs = ["/usr/lib/ghc/bytestring-0.9.2.1"], hsLibraries = ["HSbytestring-0.9.2.1"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/bytestring-0.9.2.1/include"], includes = ["fpstring.h"], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageId "ghc-prim-0.2.0.0-c2ff696e5b8ec4d4b2bc2e42085fe471"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/bytestring-0.9.2.1/bytestring.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/bytestring-0.9.2.1"]}])]),(PackageName "directory",fromList [(Version {versionBranch = [1,1,0,2], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "directory-1.1.0.2-ebacad9b5233212b1abbebce9b7e6524", sourcePackageId = PackageIdentifier {pkgName = PackageName "directory", pkgVersion = Version {versionBranch = [1,1,0,2], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "library for directory handling", description = "This package provides a library for handling directories.", category = "System", exposed = True, exposedModules = [ModuleName ["System","Directory"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/directory-1.1.0.2"], libraryDirs = ["/usr/lib/ghc/directory-1.1.0.2"], hsLibraries = ["HSdirectory-1.1.0.2"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/directory-1.1.0.2/include"], includes = ["HsDirectory.h"], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageId "filepath-1.3.0.0-973f5e9fbed93e25cbe66dfeb6b99ad9",InstalledPackageId "old-time-1.1.0.0-b77788a065c86ada9ba279afa5e04576",InstalledPackageId "unix-2.5.1.0-b7c7408f284e3570d0d4dbd1f423845f"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/directory-1.1.0.2/directory.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/directory-1.1.0.2"]}])]),(PackageName "filepath",fromList [(Version {versionBranch = [1,3,0,0], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "filepath-1.3.0.0-973f5e9fbed93e25cbe66dfeb6b99ad9", sourcePackageId = PackageIdentifier {pkgName = PackageName "filepath", pkgVersion = Version {versionBranch = [1,3,0,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "", author = "Neil Mitchell", stability = "", homepage = "http://www-users.cs.york.ac.uk/~ndm/filepath/", pkgUrl = "", synopsis = "Library for manipulating FilePaths in a cross platform way.", description = "", category = "System", exposed = True, exposedModules = [ModuleName ["System","FilePath"],ModuleName ["System","FilePath","Posix"],ModuleName ["System","FilePath","Windows"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/filepath-1.3.0.0"], libraryDirs = ["/usr/lib/ghc/filepath-1.3.0.0"], hsLibraries = ["HSfilepath-1.3.0.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/filepath-1.3.0.0/filepath.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/filepath-1.3.0.0"]}])]),(PackageName "ghc-prim",fromList [(Version {versionBranch = [0,2,0,0], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "ghc-prim-0.2.0.0-c2ff696e5b8ec4d4b2bc2e42085fe471", sourcePackageId = PackageIdentifier {pkgName = PackageName "ghc-prim", pkgVersion = Version {versionBranch = [0,2,0,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "GHC primitives", description = "GHC primitives.", category = "", exposed = True, exposedModules = [ModuleName ["GHC","Prim"],ModuleName ["GHC","Classes"],ModuleName ["GHC","CString"],ModuleName ["GHC","Debug"],ModuleName ["GHC","Generics"],ModuleName ["GHC","Magic"],ModuleName ["GHC","PrimopWrappers"],ModuleName ["GHC","IntWord64"],ModuleName ["GHC","Tuple"],ModuleName ["GHC","Types"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/ghc-prim-0.2.0.0"], libraryDirs = ["/usr/lib/ghc/ghc-prim-0.2.0.0"], hsLibraries = ["HSghc-prim-0.2.0.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "builtin_rts"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/ghc-prim-0.2.0.0/ghc-prim.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/ghc-prim-0.2.0.0"]}])]),(PackageName "integer-gmp",fromList [(Version {versionBranch = [0,4,0,0], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "integer-gmp-0.4.0.0-3cccac07aef8e27023f605c1f45bdf74", sourcePackageId = PackageIdentifier {pkgName = PackageName "integer-gmp", pkgVersion = Version {versionBranch = [0,4,0,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "Integer library based on GMP", description = "This package contains an Integer library based on GMP.", category = "", exposed = True, exposedModules = [ModuleName ["GHC","Integer"],ModuleName ["GHC","Integer","GMP","Internals"],ModuleName ["GHC","Integer","GMP","Prim"],ModuleName ["GHC","Integer","Logarithms"],ModuleName ["GHC","Integer","Logarithms","Internals"]], hiddenModules = [ModuleName ["GHC","Integer","Type"]], trusted = False, importDirs = ["/usr/lib/ghc/integer-gmp-0.4.0.0"], libraryDirs = ["/usr/lib/ghc/integer-gmp-0.4.0.0"], hsLibraries = ["HSinteger-gmp-0.4.0.0"], extraLibraries = ["gmp"], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "ghc-prim-0.2.0.0-c2ff696e5b8ec4d4b2bc2e42085fe471"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/integer-gmp-0.4.0.0/integer-gmp.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/integer-gmp-0.4.0.0"]}])]),(PackageName "mtl",fromList [(Version {versionBranch = [2,0,1,0], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "mtl-2.0.1.0-db19dd8a7700e3d3adda8aa8fe5bf53d", sourcePackageId = PackageIdentifier {pkgName = PackageName "mtl", pkgVersion = Version {versionBranch = [2,0,1,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "Andy Gill", stability = "", homepage = "", pkgUrl = "", synopsis = "Monad classes, using functional dependencies", description = "Monad classes using functional dependencies, with instances\nfor various monad transformers, inspired by the paper\n/Functional Programming with Overloading and Higher-Order Polymorphism/,\nby Mark P Jones, in /Advanced School of Functional Programming/, 1995\n().", category = "Control", exposed = True, exposedModules = [ModuleName ["Control","Monad","Cont"],ModuleName ["Control","Monad","Cont","Class"],ModuleName ["Control","Monad","Error"],ModuleName ["Control","Monad","Error","Class"],ModuleName ["Control","Monad","Identity"],ModuleName ["Control","Monad","List"],ModuleName ["Control","Monad","RWS"],ModuleName ["Control","Monad","RWS","Class"],ModuleName ["Control","Monad","RWS","Lazy"],ModuleName ["Control","Monad","RWS","Strict"],ModuleName ["Control","Monad","Reader"],ModuleName ["Control","Monad","Reader","Class"],ModuleName ["Control","Monad","State"],ModuleName ["Control","Monad","State","Class"],ModuleName ["Control","Monad","State","Lazy"],ModuleName ["Control","Monad","State","Strict"],ModuleName ["Control","Monad","Trans"],ModuleName ["Control","Monad","Writer"],ModuleName ["Control","Monad","Writer","Class"],ModuleName ["Control","Monad","Writer","Lazy"],ModuleName ["Control","Monad","Writer","Strict"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/haskell-packages/ghc/lib/mtl-2.0.1.0/ghc-7.4.1"], libraryDirs = ["/usr/lib/haskell-packages/ghc/lib/mtl-2.0.1.0/ghc-7.4.1"], hsLibraries = ["HSmtl-2.0.1.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageId "transformers-0.2.2.0-367ec8196a45fab9903c082ddf1e964e"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/mtl-2.0.1.0/mtl.haddock"], haddockHTMLs = ["/usr/share/doc/libghc-mtl-doc/html/"]}])]),(PackageName "old-locale",fromList [(Version {versionBranch = [1,0,0,4], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "old-locale-1.0.0.4-a2c3d942f886fb70df8171795fdc2e5a", sourcePackageId = PackageIdentifier {pkgName = PackageName "old-locale", pkgVersion = Version {versionBranch = [1,0,0,4], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "locale library", description = "This package provides the old locale library.\nFor new code, the new locale library is recommended.", category = "System", exposed = True, exposedModules = [ModuleName ["System","Locale"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/old-locale-1.0.0.4"], libraryDirs = ["/usr/lib/ghc/old-locale-1.0.0.4"], hsLibraries = ["HSold-locale-1.0.0.4"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/old-locale-1.0.0.4/old-locale.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/old-locale-1.0.0.4"]}])]),(PackageName "old-time",fromList [(Version {versionBranch = [1,1,0,0], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "old-time-1.1.0.0-b77788a065c86ada9ba279afa5e04576", sourcePackageId = PackageIdentifier {pkgName = PackageName "old-time", pkgVersion = Version {versionBranch = [1,1,0,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "Time library", description = "This package provides the old time library.\nFor new code, the new time library is recommended.", category = "System", exposed = True, exposedModules = [ModuleName ["System","Time"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/old-time-1.1.0.0"], libraryDirs = ["/usr/lib/ghc/old-time-1.1.0.0"], hsLibraries = ["HSold-time-1.1.0.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/old-time-1.1.0.0/include"], includes = ["HsTime.h"], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageId "old-locale-1.0.0.4-a2c3d942f886fb70df8171795fdc2e5a"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/old-time-1.1.0.0/old-time.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/old-time-1.1.0.0"]}])]),(PackageName "process",fromList [(Version {versionBranch = [1,1,0,1], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "process-1.1.0.1-18dadd8ad5fc640f55a7afdc7aace500", sourcePackageId = PackageIdentifier {pkgName = PackageName "process", pkgVersion = Version {versionBranch = [1,1,0,1], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "Process libraries", description = "This package contains libraries for dealing with system processes.", category = "System", exposed = True, exposedModules = [ModuleName ["System","Process","Internals"],ModuleName ["System","Process"],ModuleName ["System","Cmd"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/ghc/process-1.1.0.1"], libraryDirs = ["/usr/lib/ghc/process-1.1.0.1"], hsLibraries = ["HSprocess-1.1.0.1"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/process-1.1.0.1/include"], includes = ["runProcess.h"], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageId "directory-1.1.0.2-ebacad9b5233212b1abbebce9b7e6524",InstalledPackageId "filepath-1.3.0.0-973f5e9fbed93e25cbe66dfeb6b99ad9",InstalledPackageId "unix-2.5.1.0-b7c7408f284e3570d0d4dbd1f423845f"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/process-1.1.0.1/process.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/process-1.1.0.1"]}])]),(PackageName "rts",fromList [(Version {versionBranch = [1,0], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "builtin_rts", sourcePackageId = PackageIdentifier {pkgName = PackageName "rts", pkgVersion = Version {versionBranch = [1,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "glasgow-haskell-users@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "", description = "", category = "", exposed = True, exposedModules = [], hiddenModules = [], trusted = False, importDirs = [], libraryDirs = ["/usr/lib/ghc"], hsLibraries = ["HSrts"], extraLibraries = ["ffi","m","rt","dl"], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/include"], includes = ["Stg.h"], depends = [], hugsOptions = [], ccOptions = [], ldOptions = ["-u","ghczmprim_GHCziTypes_Izh_static_info","-u","ghczmprim_GHCziTypes_Czh_static_info","-u","ghczmprim_GHCziTypes_Fzh_static_info","-u","ghczmprim_GHCziTypes_Dzh_static_info","-u","base_GHCziPtr_Ptr_static_info","-u","base_GHCziWord_Wzh_static_info","-u","base_GHCziInt_I8zh_static_info","-u","base_GHCziInt_I16zh_static_info","-u","base_GHCziInt_I32zh_static_info","-u","base_GHCziInt_I64zh_static_info","-u","base_GHCziWord_W8zh_static_info","-u","base_GHCziWord_W16zh_static_info","-u","base_GHCziWord_W32zh_static_info","-u","base_GHCziWord_W64zh_static_info","-u","base_GHCziStable_StablePtr_static_info","-u","ghczmprim_GHCziTypes_Izh_con_info","-u","ghczmprim_GHCziTypes_Czh_con_info","-u","ghczmprim_GHCziTypes_Fzh_con_info","-u","ghczmprim_GHCziTypes_Dzh_con_info","-u","base_GHCziPtr_Ptr_con_info","-u","base_GHCziPtr_FunPtr_con_info","-u","base_GHCziStable_StablePtr_con_info","-u","ghczmprim_GHCziTypes_False_closure","-u","ghczmprim_GHCziTypes_True_closure","-u","base_GHCziPack_unpackCString_closure","-u","base_GHCziIOziException_stackOverflow_closure","-u","base_GHCziIOziException_heapOverflow_closure","-u","base_ControlziExceptionziBase_nonTermination_closure","-u","base_GHCziIOziException_blockedIndefinitelyOnMVar_closure","-u","base_GHCziIOziException_blockedIndefinitelyOnSTM_closure","-u","base_ControlziExceptionziBase_nestedAtomically_closure","-u","base_GHCziWeak_runFinalizzerBatch_closure","-u","base_GHCziTopHandler_flushStdHandles_closure","-u","base_GHCziTopHandler_runIO_closure","-u","base_GHCziTopHandler_runNonIO_closure","-u","base_GHCziConcziIO_ensureIOManagerIsRunning_closure","-u","base_GHCziConcziSync_runSparks_closure","-u","base_GHCziConcziSignal_runHandlers_closure"], frameworkDirs = [], frameworks = [], haddockInterfaces = [], haddockHTMLs = []}])]),(PackageName "transformers",fromList [(Version {versionBranch = [0,2,2,0], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "transformers-0.2.2.0-367ec8196a45fab9903c082ddf1e964e", sourcePackageId = PackageIdentifier {pkgName = PackageName "transformers", pkgVersion = Version {versionBranch = [0,2,2,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "Ross Paterson ", author = "Andy Gill, Ross Paterson", stability = "", homepage = "", pkgUrl = "", synopsis = "Concrete functor and monad transformers", description = "Haskell 98 part of a monad transformer library, inspired by the paper\n\\\"Functional Programming with Overloading and Higher-Order Polymorphism\\\",\nby Mark P Jones, in /Advanced School of Functional Programming/, 1995\n().\n\nThis part contains the monad transformer class, the concrete monad\ntransformers, operations and liftings. It can be used on its own\nin Haskell 98 code, or with the monad classes in the @monads-fd@ or\n@monads-tf@ packages, which automatically lift operations introduced\nby monad transformers through other transformers.", category = "Control", exposed = True, exposedModules = [ModuleName ["Control","Monad","IO","Class"],ModuleName ["Control","Monad","Trans","Class"],ModuleName ["Control","Monad","Trans","Cont"],ModuleName ["Control","Monad","Trans","Error"],ModuleName ["Control","Monad","Trans","Identity"],ModuleName ["Control","Monad","Trans","List"],ModuleName ["Control","Monad","Trans","Maybe"],ModuleName ["Control","Monad","Trans","Reader"],ModuleName ["Control","Monad","Trans","RWS"],ModuleName ["Control","Monad","Trans","RWS","Lazy"],ModuleName ["Control","Monad","Trans","RWS","Strict"],ModuleName ["Control","Monad","Trans","State"],ModuleName ["Control","Monad","Trans","State","Lazy"],ModuleName ["Control","Monad","Trans","State","Strict"],ModuleName ["Control","Monad","Trans","Writer"],ModuleName ["Control","Monad","Trans","Writer","Lazy"],ModuleName ["Control","Monad","Trans","Writer","Strict"],ModuleName ["Data","Functor","Compose"],ModuleName ["Data","Functor","Constant"],ModuleName ["Data","Functor","Identity"],ModuleName ["Data","Functor","Product"]], hiddenModules = [], trusted = False, importDirs = ["/usr/lib/haskell-packages/ghc/lib/transformers-0.2.2.0/ghc-7.4.1"], libraryDirs = ["/usr/lib/haskell-packages/ghc/lib/transformers-0.2.2.0/ghc-7.4.1"], hsLibraries = ["HStransformers-0.2.2.0"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/transformers-0.2.2.0/transformers.haddock"], haddockHTMLs = ["/usr/share/doc/libghc-transformers-doc/html/"]}])]),(PackageName "unix",fromList [(Version {versionBranch = [2,5,1,0], versionTags = []},[InstalledPackageInfo {installedPackageId = InstalledPackageId "unix-2.5.1.0-b7c7408f284e3570d0d4dbd1f423845f", sourcePackageId = PackageIdentifier {pkgName = PackageName "unix", pkgVersion = Version {versionBranch = [2,5,1,0], versionTags = []}}, license = BSD3, copyright = "", maintainer = "libraries@haskell.org", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "POSIX functionality", description = "This package gives you access to the set of operating system\nservices standardised by POSIX 1003.1b (or the IEEE Portable\nOperating System Interface for Computing Environments -\nIEEE Std. 1003.1).\n\nThe package is not supported under Windows (except under Cygwin).", category = "System", exposed = True, exposedModules = [ModuleName ["System","Posix"],ModuleName ["System","Posix","ByteString"],ModuleName ["System","Posix","Error"],ModuleName ["System","Posix","Resource"],ModuleName ["System","Posix","Time"],ModuleName ["System","Posix","Unistd"],ModuleName ["System","Posix","User"],ModuleName ["System","Posix","Signals"],ModuleName ["System","Posix","Signals","Exts"],ModuleName ["System","Posix","Semaphore"],ModuleName ["System","Posix","SharedMem"],ModuleName ["System","Posix","ByteString","FilePath"],ModuleName ["System","Posix","Directory"],ModuleName ["System","Posix","Directory","ByteString"],ModuleName ["System","Posix","DynamicLinker","Module"],ModuleName ["System","Posix","DynamicLinker","Module","ByteString"],ModuleName ["System","Posix","DynamicLinker","Prim"],ModuleName ["System","Posix","DynamicLinker","ByteString"],ModuleName ["System","Posix","DynamicLinker"],ModuleName ["System","Posix","Files"],ModuleName ["System","Posix","Files","ByteString"],ModuleName ["System","Posix","IO"],ModuleName ["System","Posix","IO","ByteString"],ModuleName ["System","Posix","Env"],ModuleName ["System","Posix","Env","ByteString"],ModuleName ["System","Posix","Process"],ModuleName ["System","Posix","Process","Internals"],ModuleName ["System","Posix","Process","ByteString"],ModuleName ["System","Posix","Temp"],ModuleName ["System","Posix","Temp","ByteString"],ModuleName ["System","Posix","Terminal"],ModuleName ["System","Posix","Terminal","ByteString"]], hiddenModules = [ModuleName ["System","Posix","Directory","Common"],ModuleName ["System","Posix","DynamicLinker","Common"],ModuleName ["System","Posix","Files","Common"],ModuleName ["System","Posix","IO","Common"],ModuleName ["System","Posix","Process","Common"],ModuleName ["System","Posix","Terminal","Common"]], trusted = False, importDirs = ["/usr/lib/ghc/unix-2.5.1.0"], libraryDirs = ["/usr/lib/ghc/unix-2.5.1.0"], hsLibraries = ["HSunix-2.5.1.0"], extraLibraries = ["rt","util","dl","pthread"], extraGHCiLibraries = [], includeDirs = ["/usr/lib/ghc/unix-2.5.1.0/include"], includes = ["HsUnix.h","execvpe.h"], depends = [InstalledPackageId "base-4.5.0.0-40b99d05fae6a4eea95ea69e6e0c9702",InstalledPackageId "bytestring-0.9.2.1-18f26186028d7c0e92e78edc9071d376"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/usr/lib/ghc-doc/haddock/unix-2.5.1.0/unix.haddock"], haddockHTMLs = ["/usr/share/doc/ghc-doc/html/libraries/unix-2.5.1.0"]}])])]), pkgDescrFile = Just "./BNFC.cabal", localPkgDescr = PackageDescription {package = PackageIdentifier {pkgName = PackageName "BNFC", pkgVersion = Version {versionBranch = [2,4,2,1], versionTags = []}}, license = GPL Nothing, licenseFile = "COPYING", copyright = "(c) Krasimir Angelov, Bjorn Bringert, Johan Broberg, Paul Callaghan, Markus Forsberg, Ola Frid, Peter Gammie, Patrik Jansson, Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell, Michael Pellauer and Aarne Ranta 2002 - 2010. Free software under GNU General Public License (GPL).", maintainer = "Markus Forsberg Aarne Ranta ", author = "", stability = "", testedWith = [(GHC,ThisVersion (Version {versionBranch = [7,4,1], versionTags = []}))], homepage = "http://www.cse.chalmers.se/research/group/Language-technology/BNFC/", pkgUrl = "", bugReports = "", sourceRepos = [], synopsis = "A compiler front-end generator.", description = "The BNF Converter is a compiler construction tool generating a compiler front-end\nfrom a Labelled BNF grammar. It was originally written to generate Haskell,\nbut starting from Version 2.0, it can also be used for generating Java, C++, and C.\n\nGiven a Labelled BNF grammar the tool produces:\nan abstract syntax as a Haskell/C++/C module or Java directory,\na case skeleton for the abstract syntax in the same language,\nan Alex, JLex, or Flex lexer generator file,\na Happy, CUP, or Bison parser generator file,\na pretty-printer as a Haskell/Java/C++/C module,\na Latex file containing a readable specification of the language.\n\nThis version only works with Alex version < 3, e.g. alex-2.3.5.", category = "Development", customFieldsPD = [], buildDepends = [Dependency (PackageName "array") (IntersectVersionRanges AnyVersion (ThisVersion (Version {versionBranch = [0,4,0,0], versionTags = []}))),Dependency (PackageName "base") (IntersectVersionRanges (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4], versionTags = []})) (LaterVersion (Version {versionBranch = [4], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))) (ThisVersion (Version {versionBranch = [4,5,0,0], versionTags = []}))),Dependency (PackageName "directory") (IntersectVersionRanges AnyVersion (ThisVersion (Version {versionBranch = [1,1,0,2], versionTags = []}))),Dependency (PackageName "mtl") (IntersectVersionRanges AnyVersion (ThisVersion (Version {versionBranch = [2,0,1,0], versionTags = []}))),Dependency (PackageName "process") (IntersectVersionRanges AnyVersion (ThisVersion (Version {versionBranch = [1,1,0,1], versionTags = []})))], specVersionRaw = Right (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,2], versionTags = []})) (LaterVersion (Version {versionBranch = [1,2], versionTags = []}))), buildType = Just Simple, library = Nothing, executables = [Executable {exeName = "bnfc", modulePath = "Main.hs", buildInfo = BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [".","formats","formats/haskell2","formats/haskell-gadt","formats/xml","formats/profile","formats/java","formats/java1.5","formats/cpp","formats/c","formats/ocaml","formats/cpp_stl","formats/c-sharp","formats/f-sharp"], otherModules = [ModuleName ["LexBNF"],ModuleName ["ParBNF"],ModuleName ["AbsBNF"],ModuleName ["PrintBNF"],ModuleName ["Utils"],ModuleName ["CF"],ModuleName ["ErrM"],ModuleName ["MultiView"],ModuleName ["TypeChecker"],ModuleName ["GetCF"],ModuleName ["NamedVariables"],ModuleName ["OOAbstract"],ModuleName ["CFtoLatex"],ModuleName ["CFtoXML"],ModuleName ["CFtoTxt"],ModuleName ["HaskellTop"],ModuleName ["RegToAlex"],ModuleName ["CFtoTemplate"],ModuleName ["CFtoAlex2"],ModuleName ["CFtoAlex"],ModuleName ["CFtoHappy"],ModuleName ["CFtoPrinter"],ModuleName ["CFtoAbstract"],ModuleName ["CFtoLayout"],ModuleName ["MkErrM"],ModuleName ["MkSharedString"],ModuleName ["ProfileTop"],ModuleName ["CFtoHappyProfile"],ModuleName ["HaskellTopGADT"],ModuleName ["HaskellGADTCommon"],ModuleName ["CFtoPrinterGADT"],ModuleName ["CFtoTemplateGADT"],ModuleName ["CFtoAbstractGADT"],ModuleName ["OCamlTop"],ModuleName ["OCamlUtil"],ModuleName ["CFtoOCamlTest"],ModuleName ["CFtoOCamlShow"],ModuleName ["CFtoOCamlPrinter"],ModuleName ["CFtoOCamlTemplate"],ModuleName ["CFtoOCamlAbs"],ModuleName ["CFtoOCamlYacc"],ModuleName ["CFtoOCamlLex"],ModuleName ["CTop"],ModuleName ["CFtoCPrinter"],ModuleName ["CFtoCSkel"],ModuleName ["CFtoBisonC"],ModuleName ["CFtoFlexC"],ModuleName ["CFtoCAbs"],ModuleName ["CFtoCVisitSkel"],ModuleName ["CPPTop"],ModuleName ["RegToFlex"],ModuleName ["CFtoFlex"],ModuleName ["CFtoBison"],ModuleName ["CFtoCPPPrinter"],ModuleName ["CFtoCPPAbs"],ModuleName ["CFtoBisonSTL"],ModuleName ["CFtoSTLAbs"],ModuleName ["STLUtils"],ModuleName ["CFtoCVisitSkelSTL"],ModuleName ["CFtoSTLPrinter"],ModuleName ["STLTop"],ModuleName ["CSharpTop"],ModuleName ["RegToGPLEX"],ModuleName ["CFtoGPLEX"],ModuleName ["CSharpUtils"],ModuleName ["CFtoCSharpPrinter"],ModuleName ["CAbstoCSharpAbs"],ModuleName ["CAbstoCSharpAbstractVisitSkeleton"],ModuleName ["CAbstoCSharpVisitSkeleton"],ModuleName ["CFtoGPPG"],ModuleName ["JavaTop"],ModuleName ["RegToJLex"],ModuleName ["CFtoCup"],ModuleName ["CFtoVisitSkel"],ModuleName ["CFtoJavaSkeleton"],ModuleName ["CFtoJavaPrinter"],ModuleName ["CFtoJavaAbs"],ModuleName ["CFtoJLex"],ModuleName ["JavaTop15"],ModuleName ["CFtoJavaAbs15"],ModuleName ["CFtoAllVisitor"],ModuleName ["CFtoFoldVisitor"],ModuleName ["CFtoAbstractVisitor"],ModuleName ["CFtoComposVisitor"],ModuleName ["CFtoVisitSkel15"],ModuleName ["CFtoJavaPrinter15"],ModuleName ["CFtoJLex15"],ModuleName ["CFtoCup15"],ModuleName ["FSharpTop"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName "array") (IntersectVersionRanges AnyVersion (ThisVersion (Version {versionBranch = [0,4,0,0], versionTags = []}))),Dependency (PackageName "base") (IntersectVersionRanges (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4], versionTags = []})) (LaterVersion (Version {versionBranch = [4], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))) (ThisVersion (Version {versionBranch = [4,5,0,0], versionTags = []}))),Dependency (PackageName "directory") (IntersectVersionRanges AnyVersion (ThisVersion (Version {versionBranch = [1,1,0,2], versionTags = []}))),Dependency (PackageName "mtl") (IntersectVersionRanges AnyVersion (ThisVersion (Version {versionBranch = [2,0,1,0], versionTags = []}))),Dependency (PackageName "process") (IntersectVersionRanges AnyVersion (ThisVersion (Version {versionBranch = [1,1,0,1], versionTags = []})))]}}], testSuites = [], benchmarks = [], dataFiles = [], dataDir = "", extraSrcFiles = ["BNF.cf"], extraTmpFiles = []}, withPrograms = [("alex",ConfiguredProgram {programId = "alex", programVersion = Just (Version {versionBranch = [2,3,5], versionTags = []}), programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/home/abel/.cabal/bin/alex"}}),("ar",ConfiguredProgram {programId = "ar", programVersion = Nothing, programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/ar"}}),("cpphs",ConfiguredProgram {programId = "cpphs", programVersion = Just (Version {versionBranch = [1,12], versionTags = []}), programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/home/abel/.cabal/bin/cpphs"}}),("ffihugs",ConfiguredProgram {programId = "ffihugs", programVersion = Nothing, programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/ffihugs"}}),("gcc",ConfiguredProgram {programId = "gcc", programVersion = Just (Version {versionBranch = [4,6], versionTags = []}), programDefaultArgs = ["-Wl,--hash-size=31","-Wl,--reduce-memory-overheads"], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/gcc"}}),("ghc",ConfiguredProgram {programId = "ghc", programVersion = Just (Version {versionBranch = [7,4,1], versionTags = []}), programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/ghc"}}),("ghc-pkg",ConfiguredProgram {programId = "ghc-pkg", programVersion = Just (Version {versionBranch = [7,4,1], versionTags = []}), programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/ghc-pkg"}}),("haddock",ConfiguredProgram {programId = "haddock", programVersion = Just (Version {versionBranch = [2,10,0], versionTags = []}), programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/haddock"}}),("happy",ConfiguredProgram {programId = "happy", programVersion = Just (Version {versionBranch = [1,18,9], versionTags = []}), programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/happy"}}),("hpc",ConfiguredProgram {programId = "hpc", programVersion = Just (Version {versionBranch = [0,6], versionTags = []}), programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/hpc"}}),("hsc2hs",ConfiguredProgram {programId = "hsc2hs", programVersion = Just (Version {versionBranch = [0,67], versionTags = []}), programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/hsc2hs"}}),("hugs",ConfiguredProgram {programId = "hugs", programVersion = Nothing, programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/hugs"}}),("ld",ConfiguredProgram {programId = "ld", programVersion = Nothing, programDefaultArgs = ["-x","--hash-size=31","--reduce-memory-overheads"], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/ld"}}),("pkg-config",ConfiguredProgram {programId = "pkg-config", programVersion = Just (Version {versionBranch = [0,26], versionTags = []}), programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/pkg-config"}}),("ranlib",ConfiguredProgram {programId = "ranlib", programVersion = Nothing, programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/ranlib"}}),("strip",ConfiguredProgram {programId = "strip", programVersion = Nothing, programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/usr/bin/strip"}}),("tar",ConfiguredProgram {programId = "tar", programVersion = Nothing, programDefaultArgs = [], programOverrideArgs = [], programLocation = FoundOnSystem {locationPath = "/bin/tar"}})], withPackageDB = [GlobalPackageDB,UserPackageDB], withVanillaLib = True, withProfLib = False, withSharedLib = False, withDynExe = False, withProfExe = False, withOptimization = NormalOptimisation, withGHCiLib = True, splitObjs = False, stripExes = True, progPrefix = "", progSuffix = ""} diff --git a/formats/CFtoLatex.hs b/formats/CFtoLatex.hs deleted file mode 100644 --- a/formats/CFtoLatex.hs +++ /dev/null @@ -1,276 +0,0 @@ -{- - BNF Converter: Latex Generator - Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoLatex (cfToLatex)where - -import CF -import AbsBNF (Reg (..)) -import Utils -import Data.List (nub,intersperse) - -cfToLatex :: String -> CF -> String -cfToLatex name cf = unlines [ - "\\batchmode", - beginDocument name, - macros, - introduction, - prtTerminals name cf, - prtBNF name cf, - endDocument - ] - -introduction :: String -introduction = concat - [ - "\nThis document was automatically generated by ", - "the {\\em BNF-Converter}.", - " It was generated together with the lexer, the parser, and the", - " abstract syntax module, which guarantees that the document", - " matches with the implementation of the language (provided no", - " hand-hacking has taken place).\n" - ] - -prtTerminals :: String -> CF -> String -prtTerminals name cf = unlines [ - "\\section*{The lexical structure of " ++ name ++ "}", - identSection cf, - "\\subsection*{Literals}", - prtLiterals name cf, - unlines (map prtOwnToken (tokenPragmas cf)), - "\\subsection*{Reserved words and symbols}", - prtReserved name cf, - prtSymb name cf, - "\\subsection*{Comments}", - prtComments $ comments cf - ] - -identSection cf = if not (hasIdent cf) then [] else - unlines [ - "\\subsection*{Identifiers}", - prtIdentifiers - ] - -prtIdentifiers :: String -prtIdentifiers = unlines - [ - "Identifiers \\nonterminal{Ident} are unquoted strings beginning with a letter,", - "followed by any combination of letters, digits, and the characters {\\tt \\_ '},", - "reserved words excluded." - ] - -prtLiterals :: String -> CF -> String -prtLiterals name cf = - unlines $ map stringLit $ - filter (`notElem` ["Ident"]) $ - literals cf - -stringLit :: String -> String -stringLit cat = unlines $ case cat of - "Char" -> ["Character literals \\nonterminal{Char}\\ have the form", - "\\terminal{'}$c$\\terminal{'}, where $c$ is any single character.", - "" - ] - "String" -> ["String literals \\nonterminal{String}\\ have the form", - "\\terminal{\"}$x$\\terminal{\"}, where $x$ is any sequence of any characters", - "except \\terminal{\"}\\ unless preceded by \\verb6\\6.", - ""] - "Integer" -> ["Integer literals \\nonterminal{Int}\\ are nonempty sequences of digits.", - ""] - "Double" -> ["Double-precision float literals \\nonterminal{Double}\\ have the structure", - "indicated by the regular expression" +++ - "$\\nonterminal{digit}+ \\mbox{{\\it `.'}} \\nonterminal{digit}+ (\\mbox{{\\it `e'}} \\mbox{{\\it `-'}}? \\nonterminal{digit}+)?$ i.e.\\", - "two sequences of digits separated by a decimal point, optionally", - "followed by an unsigned or negative exponent.", - ""] - _ -> [] - -prtOwnToken (name,reg) = unlines - [name +++ "literals are recognized by the regular expression", - "\\(" ++ - latexRegExp reg ++ - "\\)" - ] - -prtComments :: ([(String,String)],[String]) -> String -prtComments (xs,ys) = concat - [ - if (null ys) then - "There are no single-line comments in the grammar. \\\\" - else - "Single-line comments begin with " ++ sing ++". \\\\", - if (null xs) then - "There are no multiple-line comments in the grammar." - else - "Multiple-line comments are enclosed with " ++ mult ++"." - ] - where - sing = concat $ intersperse ", " $ map (symbol.prt) ys - mult = concat $ intersperse ", " $ - map (\(x,y) -> (symbol (prt x)) - ++ " and " ++ - (symbol (prt y))) xs - -prtSymb :: String -> CF -> String -prtSymb name cf = case symbols cf of - [] -> "\nThere are no symbols in " ++ name ++ ".\\\\\n" - xs -> "The symbols used in " ++ name ++ " are the following: \\\\\n" - ++ - (tabular 3 $ three $ map (symbol.prt) xs) - -prtReserved :: String -> CF -> String -prtReserved name cf = case reservedWords cf of - [] -> stringRes name ++ - "\nThere are no reserved words in " ++ name ++ ".\\\\\n" - xs -> stringRes name ++ - (tabular 3 $ three $ map (reserved.prt) xs) - -stringRes :: String -> String -stringRes name = concat - ["The set of reserved words is the set of terminals ", - "appearing in the grammar. Those reserved words ", - "that consist of non-letter characters are called symbols, and ", - "they are treated in a different way from those that ", - "are similar to identifiers. The lexer ", - "follows rules familiar from languages ", - "like Haskell, C, and Java, including longest match ", - "and spacing conventions.", - "\n\n", - "The reserved words used in " ++ name ++ " are the following: \\\\\n"] - -three :: [String] -> [[String]] -three [] = [] -three [x] = [[x,[],[]]] -three [x,y] = [[x,y,[]]] -three (x:y:z:xs) = [x,y,z] : three xs - -prtBNF :: String -> CF -> String -prtBNF name cf = unlines [ - "\\section*{The syntactic structure of " ++ name ++"}", - "Non-terminals are enclosed between $\\langle$ and $\\rangle$. ", - "The symbols " ++ arrow ++ " (production), " ++ - delimiter ++" (union) ", - "and " ++ empty ++ " (empty rule) belong to the BNF notation. ", - "All other symbols are terminals.\\\\", - prtRules (ruleGroups cf) - ] - -prtRules :: [(Cat,[Rule])] -> String -prtRules [] = [] -prtRules ((c,[]):xs) - = tabular 3 [[nonterminal c,arrow,[]]] ++ prtRules xs -prtRules ((c,(r:rs)):xs) - = tabular 3 ([[nonterminal c,arrow,prtSymbols $ rhsRule r]] ++ - [[[],delimiter,prtSymbols (rhsRule y)] | y <- rs]) ++ - prtRules xs - -prtSymbols :: [Either Cat String] -> String -prtSymbols [] = empty -prtSymbols xs = foldr (+++) [] (map p xs) - where p (Left r) = nonterminal r --- (prt r) - p (Right r) = terminal (prt r) - -prt :: String -> String -prt [] = [] -prt (c:xs) - | elem c "$&%#_{}^" = "\\" ++ [c] ++ prt xs - | elem c "+=|<>-" = "{$" ++ [c] ++ "$}" ++ prt xs - | c == '\\' = "$\\backslash$" - | c == '~' = "\\~{}" - | otherwise = c : prt xs - -macros :: String -macros = - "\\newcommand{\\emptyP}{\\mbox{$\\epsilon$}}" ++++ - "\\newcommand{\\terminal}[1]{\\mbox{{\\texttt {#1}}}}" ++++ - "\\newcommand{\\nonterminal}[1]{\\mbox{$\\langle \\mbox{{\\sl #1 }} \\! \\rangle$}}" ++++ - "\\newcommand{\\arrow}{\\mbox{::=}}" ++++ - "\\newcommand{\\delimit}{\\mbox{$|$}}" ++++ - "\\newcommand{\\reserved}[1]{\\mbox{{\\texttt {#1}}}}" ++++ - "\\newcommand{\\literal}[1]{\\mbox{{\\texttt {#1}}}}" ++++ - "\\newcommand{\\symb}[1]{\\mbox{{\\texttt {#1}}}}" - -reserved :: String -> String -reserved s = "{\\reserved{" ++ s ++ "}}" - -literal :: String -> String -literal s = "{\\literal{" ++ s ++ "}}" - -empty :: String -empty = "{\\emptyP}" - -symbol :: String -> String -symbol s = "{\\symb{" ++ s ++ "}}" - -tabular :: Int -> [[String]] -> String -tabular n xs = "\n\\begin{tabular}{" ++ concat (replicate n "l") ++ "}\n" ++ - concat (map (\(a:as) -> foldr (+++) "\\\\\n" (a:(map ('&':) as))) xs) ++ - "\\end{tabular}\\\\\n" - -terminal :: String -> String -terminal s = "{\\terminal{" ++ s ++ "}}" - -nonterminal :: String -> String -nonterminal s = "{\\nonterminal{" ++ identCat (mkId s) ++ "}}" where - mkId = map mk - mk c = case c of - '_' -> '-' --- - _ -> c - - -arrow :: String -arrow = " {\\arrow} " - -delimiter :: String -delimiter = " {\\delimit} " - -beginDocument :: String -> String -beginDocument name = - "%This Latex file is machine-generated by the BNF-converter\n" ++++ - "\\documentclass[a4paper,11pt]{article}" ++++ - "\\author{BNF-converter}" ++++ - "\\title{The Language " ++ name ++ "}" ++++ - -- "\\usepackage{isolatin1}" ++++ - "\\setlength{\\parindent}{0mm}" ++++ - "\\setlength{\\parskip}{1mm}" ++++ - "\\begin{document}\n" ++++ - "\\maketitle\n" - -endDocument :: String -endDocument = - "\n\\end{document}\n" - -latexRegExp :: Reg -> String -latexRegExp = rex (0 :: Int) where - rex i e = case e of - RSeq reg0 reg -> ifPar i 2 $ rex 2 reg0 +++ rex 2 reg - RAlt reg0 reg -> ifPar i 1 $ rex 1 reg0 +++ "\\mid" +++ rex 1 reg - RMinus reg0 reg -> ifPar i 1 $ rex 2 reg0 +++ "-" +++ rex 2 reg - RStar reg -> rex 3 reg ++ "*" - RPlus reg -> rex 3 reg ++ "+" - ROpt reg -> rex 3 reg ++ "?" - REps -> "\\epsilon" - RChar c -> "\\mbox{`" ++ prt [c] ++ "'}" - RAlts str -> "[" ++ "\\mbox{``" ++ prt str ++ "''}" ++ "]" - RSeqs str -> "\\{" ++ "\\mbox{``" ++ prt str ++ "''}" ++ "\\}" - RDigit -> "{\\nonterminal{digit}}" - RLetter -> "{\\nonterminal{letter}}" - RUpper -> "{\\nonterminal{upper}}" - RLower -> "{\\nonterminal{lower}}" - RAny -> "{\\nonterminal{anychar}}" - ifPar i j s = if i > j then "(" ++ s ++ ")" else s diff --git a/formats/CFtoTxt.hs b/formats/CFtoTxt.hs deleted file mode 100644 --- a/formats/CFtoTxt.hs +++ /dev/null @@ -1,249 +0,0 @@ -{- - BNF Converter: Latex Generator - Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoTxt (cfToTxt)where - -import CF -import AbsBNF (Reg (..)) -import Utils -import Data.List (nub,intersperse) - -cfToTxt :: String -> CF -> String -cfToTxt name cf = unlines [ - beginDocument name, - introduction, - prtTerminals name cf, - prtBNF name cf - ] - -introduction :: String -introduction = concat - [ - "\nThis document was automatically generated by ", - "the //BNF-Converter//.", - " It was generated together with the lexer, the parser, and the", - " abstract syntax module, which guarantees that the document", - " matches with the implementation of the language (provided no", - " hand-hacking has taken place).\n" - ] - -prtTerminals :: String -> CF -> String -prtTerminals name cf = unlines [ - "==The lexical structure of " ++ name ++ "==", - identSection cf, - "===Literals===", - prtLiterals name cf, - unlines (map prtOwnToken (tokenPragmas cf)), - "===Reserved words and symbols===", - prtReserved name cf, - prtSymb name cf, - "===Comments===", - prtComments $ comments cf - ] - -identSection cf = if not (hasIdent cf) then [] else - unlines [ - "===Identifiers===", - prtIdentifiers - ] - -prtIdentifiers :: String -prtIdentifiers = unlines - [ - "Identifiers //Ident// are unquoted strings beginning with a letter,", - "followed by any combination of letters, digits, and the characters ``_ '``", - "reserved words excluded." - ] - -prtLiterals :: String -> CF -> String -prtLiterals name cf = - unlines $ map stringLit $ - filter (`notElem` ["Ident"]) $ - literals cf - -stringLit :: String -> String -stringLit cat = unlines $ case cat of - "Char" -> ["Character literals //Char// have the form", - "``'``//c//``'``, where //c// is any single character.", - "" - ] - "String" -> ["String literals //String// have the form", - "``\"``//x//``\"``}, where //x// is any sequence of any characters", - "except ``\"`` unless preceded by ``\\``.", - ""] - "Integer" -> ["Integer literals //Integer// are nonempty sequences of digits.", - ""] - "Double" -> ["Double-precision float literals //Double// have the structure", - "indicated by the regular expression" +++ - "``digit+ '.' digit+ ('e' ('-')? digit+)?`` i.e.\\", - "two sequences of digits separated by a decimal point, optionally", - "followed by an unsigned or negative exponent.", - ""] - _ -> [] - -prtOwnToken (name,reg) = unlines - [name +++ "literals are recognized by the regular expression", - "```" ++ - latexRegExp reg ++ - "```" - ] - -prtComments :: ([(String,String)],[String]) -> String -prtComments (xs,ys) = concat - [ - if (null ys) then - "There are no single-line comments in the grammar." - else - "Single-line comments begin with " ++ sing ++".", - if (null xs) then - "There are no multiple-line comments in the grammar." - else - "Multiple-line comments are enclosed with " ++ mult ++"." - ] - where - sing = concat $ intersperse ", " $ map (symbol.prt) ys - mult = concat $ intersperse ", " $ - map (\(x,y) -> (symbol (prt x)) - ++ " and " ++ - (symbol (prt y))) xs - -prtSymb :: String -> CF -> String -prtSymb name cf = case symbols cf of - [] -> "\nThere are no symbols in " ++ name ++ ".\n" - xs -> "The symbols used in " ++ name ++ " are the following:\n" - ++ - (tabular 4 $ three $ map (symbol.prt) xs) - -prtReserved :: String -> CF -> String -prtReserved name cf = case reservedWords cf of - [] -> stringRes name ++ - "\nThere are no reserved words in " ++ name ++ ".\n" - xs -> stringRes name ++ - (tabular 4 $ three $ map quote xs) - -stringRes :: String -> String -stringRes name = concat - ["The set of reserved words is the set of terminals ", - "appearing in the grammar. Those reserved words ", - "that consist of non-letter characters are called symbols, and ", - "they are treated in a different way from those that ", - "are similar to identifiers. The lexer ", - "follows rules familiar from languages ", - "like Haskell, C, and Java, including longest match ", - "and spacing conventions.", - "\n\n", - "The reserved words used in " ++ name ++ " are the following:\n"] - -three :: [String] -> [[String]] -three [] = [] -three [x] = [[x,[],[],[]]] -three [x,y] = [[x,y,[],[]]] -three [x,y,z] = [[x,y,z,[]]] -three (x:y:z:u:xs) = [x,y,z,u] : three xs - -prtBNF :: String -> CF -> String -prtBNF name cf = unlines [ - "==The syntactic structure of " ++ name ++"==", - "Non-terminals are enclosed between < and >. ", - "The symbols " ++ arrow ++ " (production), " ++ - delimiter ++" (union) ", - "and " ++ empty ++ " (empty rule) belong to the BNF notation. ", - "All other symbols are terminals.", - "", - prtRules (ruleGroups cf) - ] - -prtRules :: [(Cat,[Rule])] -> String -prtRules [] = [] -prtRules ((c,[]):xs) - = tabular 3 [[nonterminal c,arrow,[]]] ++ prtRules xs -prtRules ((c,(r:rs)):xs) - = tabular 3 ([[nonterminal c,arrow,prtSymbols $ rhsRule r]] ++ - [[[],delimiter,prtSymbols (rhsRule y)] | y <- rs]) ++ - --- "\n\n" ++ --- with empty lines good for latex, bad for html - prtRules xs - -prtSymbols :: [Either Cat String] -> String -prtSymbols [] = empty -prtSymbols xs = foldr (+++) [] (map p xs) - where p (Left r) = nonterminal r - p (Right r) = terminal r - -prt :: String -> String -prt s = s - -reserved :: String -> String -reserved s = "{\\reserved{" ++ s ++ "}}" - -literal :: String -> String -literal s = "{\\literal{" ++ s ++ "}}" - -empty :: String -empty = "**eps**" - -symbol :: String -> String -symbol s = s - -tabular :: Int -> [[String]] -> String -tabular n xs = unlines [unwords (intersperse "|" (" " : x)) | x <- xs] - -terminal :: String -> String -terminal s = "``" ++ s ++ "``" - -nonterminal :: String -> String -nonterminal s = "//" ++ s ++ "//" - -arrow :: String -arrow = "->" - -delimiter :: String -delimiter = " **|** " - -beginDocument :: String -> String -beginDocument name = unlines [ - "The Language " ++ name, - "BNF Converter", - "", - "", - "%This txt2tags file is machine-generated by the BNF-converter", - "%Process by txt2tags to generate html or latex", - "" - ] - -latexRegExp :: Reg -> String -latexRegExp = quote . rex (0 :: Int) where - rex i e = case e of - RSeq reg0 reg -> ifPar i 2 $ rex 2 reg0 +++ rex 2 reg - RAlt reg0 reg -> ifPar i 1 $ rex 1 reg0 +++ "|" +++ rex 1 reg - RMinus reg0 reg -> ifPar i 1 $ rex 2 reg0 +++ "-" +++ rex 2 reg - RStar reg -> rex 3 reg ++ "*" - RPlus reg -> rex 3 reg ++ "+" - ROpt reg -> rex 3 reg ++ "?" - REps -> "eps" - RChar c -> "'" ++ [c] ++ "'" - RAlts str -> "[\"" ++ str ++ "\"]" - RSeqs str -> "{\"" ++ str ++ "\"}" - RDigit -> "digit" - RLetter -> "letter" - RUpper -> "upper" - RLower -> "lower" - RAny -> "char" - ifPar i j s = if i > j then "(" ++ s ++ ")" else s - -quote s = "``" ++ s ++ "``" diff --git a/formats/NamedVariables.hs b/formats/NamedVariables.hs deleted file mode 100644 --- a/formats/NamedVariables.hs +++ /dev/null @@ -1,109 +0,0 @@ - -{- - BNF Converter: Named instance variables - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - - -{- - ************************************************************** - BNF Converter Module - - Description : This module provides support for languages which need - named instance variables. (IE Java, C, C++) It provides - a data type to represent the name mapping and utility - functions to work with it. - - Variables are grouped and numbered in a nice way. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - ************************************************************** --} - -module NamedVariables where - -import CF -import Data.Char (toLower) -import Data.List (nub) - -type IVar = (String, Int) ---The type of an instance variable ---and a # unique to that type - -type UserDef = String --user-defined types - - ---A symbol-mapping environment. -type SymEnv = [(String, String)] - ---Converts a list of categories into their types to be used as instance variables. -getVars :: [Cat] -> [IVar] -getVars [] = [] -getVars cs = foldl addVar [] (map identCat cs) - where - addVar vs c = addVar' vs 0 c - addVar' [] n c = [(c, n)] - addVar' (i@(t,x):is) n c = - if c == t - then if x == 0 - then (t, 1) : (addVar' is 2 c) - else i : (addVar' is (x+1) c) - else i : (addVar' is n c) - ---Given a rule's definition, it goes through and nicely the variables by type. -numVars :: [(String, Int)] -> [Either String b] -> [Either String b] -numVars _env [] = [] -numVars env ((Right f) : fs) = (Right f) : (numVars env fs) -numVars env ((Left f) : fs) = - case lookup f' env of - Nothing -> (Left f') : (numVars ((f',1):env) fs) - Just n -> (Left $ f' ++ (show $ n + 1)) : (numVars ((f',n+1):env) fs) - where - f' = varName (normCat (identCat f)) - ---This makes numbers a little nicer. ---If there's only one variable of a type we drop the redundant _1 label. ---(Actually here we add _1 labels to variables that need it, but the effect --- is the same.) -fixOnes [] = [] -fixOnes ((Right f): fs) = (Right f) : (fixOnes fs) -fixOnes ((Left f) : fs) = - if elem (Left (f ++ "2")) fs - then (Left (f ++ "1")) : (fixOnes fs) - else (Left f) : (fixOnes fs) - ---This fixes the problem with coercions. -fixCoercions :: [(Cat, [Rule])] -> [(Cat, [Rule])] -fixCoercions rs = nub (fixAll rs rs) - where - fixCoercion :: Cat -> [(Cat, [Rule])] -> [Rule] - fixCoercion _ [] = [] - fixCoercion cat ((c,rules):cats) = if (normCat c) == (normCat cat) - then rules ++ (fixCoercion cat cats) - else fixCoercion cat cats - fixAll :: [(Cat, [Rule])] -> [(Cat, [Rule])] -> [(Cat, [Rule])] - fixAll _ [] = [] - fixAll top ((cat,rules):cats) = if isCoercion cat - then fixAll top cats - else (normCat cat, fixCoercion cat top) : (fixAll top cats) - ---A generic variable name for C-like languages. -varName c = (map toLower c) ++ "_" - ---this makes var names a little cleaner. -showNum n = if n == 0 then [] else (show n) diff --git a/formats/OOAbstract.hs b/formats/OOAbstract.hs deleted file mode 100644 --- a/formats/OOAbstract.hs +++ /dev/null @@ -1,129 +0,0 @@ -{- - BNF Converter: Datastructure for object-oriented abstract syntax generators - Copyright (C) 2006 Author: Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module defines a data structure that is - used for generating abstract syntax in cpp_stl. - It should be used in other STL modules as well, - and could be used for object-oriented languages - in general, to avoid duplicated work. - - Author : Aarne Ranta (aarne@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 29 August, 2006 - - Modified : 29 August, 2006 / Aarne Ranta - - - ************************************************************** --} - -module OOAbstract where - -import CF -import Utils((+++),(++++)) -import NamedVariables -import Data.List -import Data.Char(toLower) - --- A datastructure more appropriate than CF - -data CAbs = CAbs { - tokentypes :: [Cat], -- user non-position token types - listtypes :: [(Cat,Bool)], -- list types used, whether of classes - absclasses :: [Cat], -- grammar-def cats, normalized names - conclasses :: [Fun], -- constructors, except list ones - signatures :: [(Cat,[CAbsRule])], -- rules for each class, incl. pos tokens - postokens :: [Cat], -- position token types - defineds :: [Fun] -- defined (non-)constructors - } - --- (valcat,(constr,args)), True = is class (not basic), class variable stored -type CAbsRule = (Fun,[(Cat,Bool,String)]) - --- all those names that denote classes in C++ -allClasses :: CAbs -> [Cat] -allClasses ca = - absclasses ca ++ conclasses ca ++ map fst (listtypes ca) ++ postokens ca - --- all those names that denote non-class types in C++ -allNonClasses :: CAbs -> [Cat] -allNonClasses ca = - map fst basetypes ++ tokentypes ca - -cf2cabs :: CF -> CAbs -cf2cabs cf@((pragmas,_),_) = CAbs { - tokentypes = toks, - listtypes = [(c, snd (status (drop 4 c))) | -- remove "List" from "ListC" - c <- map (normCat . identCat) lists], - absclasses = nub $ map normCat cats, - conclasses = [f | Just f <- map testRule (rulesOfCF cf)], - signatures = posdata ++ map normSig (cf2data cf), - postokens = pos, - defineds = defs - } - where - (pos,base) = partition (isPositionCat cf) $ fst (unzip (tokenPragmas cf)) - (lists,cats) = partition isList $ allCats cf - toks = map normCat base - testRule (f, (c, r)) - | isList c = Nothing - | f == "_" = Nothing - | otherwise = Just f - normSig (c,fcs) = - (identCat c,[(f, classVars (map (status . identCat) cs)) | (f,cs) <- fcs]) - posdata = - [("Visitable", -- to give superclass - [(c,[("String",False,"string_"),("Integer",False,"integer_")])]) | c<-pos] - status cat = (cat, notElem cat (map fst basetypes ++ toks)) - defs = [f | FunDef f _ _ <- pragmas] - - classVars :: [(Cat,Bool)] -> [(Cat,Bool,String)] - classVars cs = - [(c,b,s) | ((c,b),s) <- zip cs (vars [] (map (classVar . fst) cs))] - --- creating new names is quadratic, but parameter lists are short - --- this should conform with Michael's naming - vars seen vv = case vv of - [] -> vv - v:vs -> case length (filter (==v) seen) of - 0 | elem v vs -> (v ++ "1"): vars (v:seen) vs - 0 -> v : vars (v:seen) vs - n -> (v ++ show (n+1)) : vars (v:seen) vs - -basetypes = [ - ("Integer","int"), - ("Char", "char"), - ("Double", "double"), - ("String", "std::string"), - ("Ident", "std::string") - ] - -isBaseType :: CAbs -> Cat -> Bool -isBaseType cf c = elem c $ tokentypes cf ++ map fst basetypes - -classVar :: Cat -> String -classVar c = map toLower c ++ "_" - -pointerIf :: Bool -> String -> String -pointerIf b v = if b then "*" ++ v else v diff --git a/formats/c-sharp/CAbstoCSharpAbs.hs b/formats/c-sharp/CAbstoCSharpAbs.hs deleted file mode 100644 --- a/formats/c-sharp/CAbstoCSharpAbs.hs +++ /dev/null @@ -1,277 +0,0 @@ -{- - BNF Converter: C# Abstract Syntax Generator - Copyright (C) 2006-2007 Author: Johan Broberg - - Modified from CFtoSTLAbs - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the C# Abstract Syntax - tree classes. It uses the Visitor design - pattern. - - Author : Johan Broberg (johan@pontemonti.com) - - License : GPL (GNU General Public License) - - Created : 22 November, 2006 - - Modified : 21 January, 2007 by Johan Broberg - - ************************************************************** --} - -module CAbstoCSharpAbs (cabs2csharpabs) where - -import OOAbstract -import CF -import Utils((+++),(++++)) -import NamedVariables -import Data.List -import Data.Char(toLower) -import Data.Maybe -import CSharpUtils - ---The result is one file (.cs) - -cabs2csharpabs :: Namespace -> CAbs -> Bool -> String -cabs2csharpabs namespace cabs useWCF = unlinesInline [ - "//C# Abstract Syntax Interface generated by the BNF Converter.", - -- imports - "using System;", - if useWCF then "using System.Runtime.Serialization;" else "", - "using System.Collections.Generic;", - "namespace " ++ namespace ++ ".Absyn", - "{", - " #region Token Classes", - prTokenBaseType useWCF, - unlinesInlineMap (prToken namespace useWCF) (tokentypes cabs), - " #endregion", - " ", - " #region Abstract Syntax Classes", - unlinesInlineMap (prAbs namespace useWCF) abstractclasses, - " ", - unlinesInlineMap (prCon namespace useWCF) (flattenSignatures cabs), - " ", - " #region Lists", - unlinesInlineMap (prList namespace) (listtypes cabs), - " #endregion", - " #endregion", - "}" - ] - where - -- an abstract class is a category which does not contain rules - abstractclasses = [ (cat, (map fst cabsrules)) | (cat, cabsrules) <- signatures cabs, cat `notElem` (map fst cabsrules) ] - --- auxiliaries - -prDataContract :: Bool -> [Cat] -> String -prDataContract False _ = "" -prDataContract True [] = " [DataContract]" -prDataContract True funs = unlinesInline [ - prDataContract True [], - unlinesInline $ map prDataContract' funs - ] - where - prDataContract' :: Cat -> String - prDataContract' fun = " [KnownType(typeof(" ++ fun ++ "))]" - -prDataMember :: Bool -> String -prDataMember False = "" -prDataMember True = " [DataMember]" - -prTokenBaseType :: Bool -> String -prTokenBaseType useWCF = unlinesInline [ - prDataContract useWCF [], - " public class TokenBaseType", - " {", - prDataMember useWCF, - " private string str;", - " ", - " public TokenBaseType(string str)", - " {", - " this.str = str;", - " }", - " ", - " public override string ToString()", - " {", - " return this.str;", - " }", - " }", - " " - ] - -prToken :: Namespace -> Bool -> Cat -> String -prToken namespace useWCF name = unlinesInline [ - prDataContract useWCF [], - " public class " ++ name ++ " : " ++ identifier namespace "TokenBaseType", - " {", - " public " ++ name ++ "(string str) : base(str)", - " {", - " }", - prAccept namespace name Nothing, - prVisitor namespace [name], - prEquals namespace name ["ToString()"], - prHashCode namespace name ["ToString()"], - " }" - ] - -prAbs :: Namespace -> Bool -> (Cat, [Cat]) -> String -prAbs namespace useWCF (cat, funs) = unlinesInline [ - prDataContract useWCF funs, - " public abstract class " ++ cat, - " {", - " public abstract R Accept(" ++ identifier namespace cat ++ ".Visitor v, A arg);", - prVisitor namespace funs, - " }" - ] - -prVisitor :: Namespace -> [Cat] -> String -prVisitor namespace funs = unlinesInline [ - " ", - " public interface Visitor", - " {", - unlinesInline (map prVisitFun funs), - " }" - ] - where - prVisitFun f = " R Visit(" ++ identifier namespace f ++ " p, A arg);" - -prCon :: Namespace -> Bool -> (Cat,CSharpAbsRule) -> String -prCon namespace useWCF (c,(f,cs)) = unlinesInline [ - prDataContract useWCF [], - " public class " ++ f ++ ext, - " {", - -- Instance variables - unlines [prInstVar typ var | (typ,_,var,_) <- cs], - prConstructor namespace (f,cs), - unlinesInline [prProperty typ var prop | (typ,_,var,prop) <- cs], - prEquals namespace f propnames, - prHashCode namespace f propnames, - -- print Accept method, override keyword needed for classes inheriting an abstract class - prAccept namespace c (if isAlsoCategory f c then Nothing else (Just " override")), - -- if this label is also a category, we need to print the Visitor interface - -- (if not, it was already printed in the abstract class) - if isAlsoCategory f c then prVisitor namespace [c] else "", - " }" - ] - where - -- This handles the case where a LBNF label is the same as the category. - ext = if isAlsoCategory f c then "" else " : " ++ identifier namespace (identCat c) - propnames = [prop | (_, _, _, prop) <- cs] - prInstVar typ var = unlinesInline [ - " private " ++ identifier namespace (typename typ) +++ var ++ ";" - ] - prProperty typ var prop = unlinesInline [ - " ", - prDataMember useWCF, - " public " ++ identifier namespace (typename typ) +++ prop, - " {", - " get", - " {", - " return this." ++ var ++ ";", - " }", - " set", - " {", - " this." ++ var ++ " = value;", - " }", - " }" - ] - --- Creates the Equals() methods -prEquals :: Namespace -> Fun -> [String] -> String -prEquals namespace c vars = unlinesInline [ - " ", - " public override bool Equals(Object obj)", - " {", - " if(this == obj)", - " {", - " return true;", - " }", - " if(obj is " ++ identifier namespace c ++ ")", - " {", - " return this.Equals((" ++ identifier namespace c ++ ")obj);", - " }", - " return base.Equals(obj);", - " }", - " ", - " public bool Equals(" ++ identifier namespace c ++ " obj)", - " {", - " if(this == obj)", - " {", - " return true;", - " }", - " return " ++ prEqualsVars vars ++ ";", - " }" - ] - where - prEqualsVars [] = "true" - prEqualsVars vs = concat $ intersperse " && " $ map equalVar vs - equalVar v = "this." ++ v ++ ".Equals(obj." ++ v ++ ")" - --- Creates the GetHashCode() method. -prHashCode :: Namespace -> Fun -> [String] -> String -prHashCode namespace c vars = unlinesInline [ - " ", - " public override int GetHashCode()", - " {", - " return " ++ prHashVars vars ++ ";", - " }" - ] - where - aPrime = 37 - prHashVars [] = show aPrime - prHashVars (v:vs) = prHashVars' (hashVar v) vs - prHashVars' r [] = r - prHashVars' r (v:vs) = prHashVars' (show aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashVar v) vs - hashVar var = "this." ++ var ++ ".GetHashCode()" - -prList :: Namespace -> (Cat,Bool) -> String -prList namespace (c,_) = unlinesInline [ - " public class " ++ c ++ " : List<" ++ identifier namespace (typename bas) ++ ">", - " {", - " }" - ] - where - bas = drop 4 c -- drop List - --- The standard Accept method for the Visitor pattern -prAccept :: Namespace -> Cat -> Maybe String -> String -prAccept namespace cat maybeOverride = unlinesInline [ - " ", - " public" ++ fromMaybe "" maybeOverride ++ " R Accept(" ++ identifier namespace cat ++ ".Visitor visitor, A arg)", - " {", - " return visitor.Visit(this, arg);", - " }" - ] - --- The constructor assigns the parameters to the corresponding instance variables. -prConstructor :: Namespace -> CSharpAbsRule -> String -prConstructor namespace (f,cs) = unlinesInline [ - " public " ++ f ++ "(" ++ conargs ++ ")", - " {", - unlinesInline [" " ++ c ++ " = " ++ p ++ ";" | (c,p) <- zip cvs pvs], - " }" - ] - where - cvs = [c | (_,_,c,_) <- cs] - pvs = ["p" ++ show i | ((x,st,_,_),i) <- zip cs [1..]] - conargs = concat $ intersperse ", " - [identifier namespace (typename x) +++ v | ((x,_,_,_),v) <- zip cs pvs] diff --git a/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs b/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs deleted file mode 100644 --- a/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs +++ /dev/null @@ -1,97 +0,0 @@ -{- - BNF Converter: C# Abstract Visit Skeleton Generator - - Copyright (C) 2006 Author: Johan Broberg - - Modified from CAbstoCSharpVisitSkeleton - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates an Abstract Visit Skeleton for C#. - This can be useful if you often make changes to your - grammar and want to keep your own changes (not having to - merge with the new visit skeleton each time), while still - getting compile errors if your code is no longer correct. - The generated file uses the Visitor design pattern. - - This could have been generated from within - CAbstoVisitSkeleton, but that would have made it more - difficult to actually use it (and the visit skeleton). - - Author : Johan Broberg (johan@pontemonti.com) - - License : GPL (GNU General Public License) - - Created : 19 December, 2006 - - Modified : 19 December, 2006 by Johan Broberg - - ************************************************************** --} - -module CAbstoCSharpAbstractVisitSkeleton (cabs2csharpAbstractVisitSkeleton) where - -import CF -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import OOAbstract hiding (basetypes) -import CSharpUtils -import CAbstoCSharpAbs - ---Produces .cs file -cabs2csharpAbstractVisitSkeleton :: Namespace -> CAbs -> String -cabs2csharpAbstractVisitSkeleton namespace cabs = unlines [ - "/*** BNFC-Generated Abstract Visitor Design Pattern Skeleton. ***/", - "/* This implements the common visitor design pattern.", - " Replace the R and A parameters with the desired return", - " and context types.*/", - "", - "namespace " ++ namespace ++ ".VisitSkeleton", - "{", - " #region Classes", - unlinesInlineMap (prCon namespace) (signatures cabs), - " #endregion", - " ", - " #region Token types", - unlinesInlineMap (prBasic namespace) (tokentypes cabs), - " #endregion", - "}" - ] - -prBasic namespace c = unlinesInline [ - " public abstract class Abstract" ++ c ++ "Visitor : " ++ identifier namespace c ++ ".Visitor", - " {", - " public abstract R Visit(" ++ identifier namespace (typename c) +++ varname c ++ ", A arg);", - " }" - ] - -prCon :: Namespace -> (Cat, [CAbsRule]) -> String -prCon namespace (c,fs) = unlinesInline [ - " public abstract class Abstract" ++ c ++ "Visitor : " ++ identifier namespace c ++ ".Visitor", - " {", - unlinesInlineMap (prVisit namespace) fs, - " }" - ] - -prVisit :: Namespace -> (Fun, [(Cat, Bool, String)]) -> String -prVisit namespace (f,cs) = unlinesInline [ - " public abstract R Visit(" ++ identifier namespace f +++ varname f ++ ", A arg);" - ] diff --git a/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs b/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs deleted file mode 100644 --- a/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs +++ /dev/null @@ -1,118 +0,0 @@ -{- - BNF Converter: C# Visit Skeleton Generator - - Copyright (C) 2006 Author: Johan Broberg - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the C# Visit Skeleton. - The generated file uses the Visitor design pattern. - - Author : Johan Broberg (johan@pontemonti.com) - - License : GPL (GNU General Public License) - - Created : 30 November, 2006 - - Modified : 21 January, 2007 by Johan Broberg - - ************************************************************** --} - -module CAbstoCSharpVisitSkeleton (cabs2csharpvisitskeleton) where - -import CF -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import OOAbstract hiding (basetypes) -import CSharpUtils -import CAbstoCSharpAbs - ---Produces .cs file -cabs2csharpvisitskeleton :: Namespace -> CAbs -> String -cabs2csharpvisitskeleton namespace cabs = unlines [ - "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/", - "/* This implements the common visitor design pattern. To make sure that", - " compile errors occur when code in the Visitor don't match the abstract", - " syntaxt, the \"abstract visit skeleton\" is used.", - " ", - " Replace the R and A parameters with the desired return", - " and context types.*/", - "", - "namespace " ++ namespace ++ ".VisitSkeleton", - "{", - " #region Classes", - unlinesInlineMap (prCon namespace) (signatures cabs), - " #endregion", - " ", - " #region Token types", - unlinesInlineMap (prBasic namespace) (tokentypes cabs), - " #endregion", - "}" - ] - -prBasic namespace c = unlinesInline [ - " public class " ++ c ++ "Visitor : Abstract" ++ c ++ "Visitor", - " {", - " public override R Visit(" ++ identifier namespace (typename c) +++ varname c ++ ", A arg)", - " {", - " /* Code for " ++ c ++ " Goes Here */", - " return default(R);", - " }", - " }" - ] - -prCon :: Namespace -> (Cat, [CAbsRule]) -> String -prCon namespace (c,fs) = unlinesInline [ - " public class " ++ c ++ "Visitor : Abstract" ++ c ++ "Visitor", - " {", - unlinesInlineMap (prVisit namespace) (map cabsrule2csharpabsrule fs), - " }" - ] - - -prVisit :: Namespace -> CSharpAbsRule -> String -prVisit namespace (f,cs) = unlinesInline [ - " public override R Visit(" ++ identifier namespace f +++ varname f ++ ", A arg)", - " {", - " /* Code For " ++ f ++ " Goes Here */", - unlinesInline $ map (prVisitArg namespace (varname f)) cs, - " return default(R);", - " }" - ] - -prVisitArg :: Namespace -> String -> (Cat, Bool, VariableName, PropertyName) -> String -prVisitArg namespace vname (cat, isPt, var, prop) - | cat `elem` (map fst basetypes) = " // " ++ vname ++ "." ++ prop - -- var /= "list_" is a dummy fix to make sure that a category named "List" doesn't get interpreted as a List. - -- this isn't very good though, and should be fixed somehow. - | "list" `isPrefixOf` var && var /= "list_" = listAccept - | otherwise = " " ++ vname ++ "." ++ prop ++ ".Accept(new " ++ cat ++ "Visitor(), arg);" - where - listtype = typename (drop 4 cat) - listAccept = unlinesInline [ - " foreach(" ++ identifier namespace listtype ++ " x in " ++ vname ++ "." ++ prop ++ ")", - " {", - if listtype `notElem` (map snd basetypes) - then " x.Accept(new " ++ listtype ++ "Visitor(), arg);" - else " // x", - " }" - ] diff --git a/formats/c-sharp/CFtoCSharpPrinter.hs b/formats/c-sharp/CFtoCSharpPrinter.hs deleted file mode 100644 --- a/formats/c-sharp/CFtoCSharpPrinter.hs +++ /dev/null @@ -1,472 +0,0 @@ -{- - BNF Converter: C# Pretty Printer Generator - Copyright (C) 2006 Author: Johan Broberg - - Modified from CFtoSTLPrinter - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the C# Pretty Printer. - It also generates the "show" method for - printing an abstract syntax tree. - - Author : Johan Broberg (johan@pontemonti.com) - - License : GPL (GNU General Public License) - - Created : 26 November, 2006 - - Modified : 21 January, 2007 by Johan Broberg - - ************************************************************** --} - -module CFtoCSharpPrinter (cf2csharpprinter) where - -import CF -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower, toUpper, isSpace) -import Data.Maybe -import CSharpUtils - ---Produces .cs file -cf2csharpprinter :: Namespace -> CF -> String -cf2csharpprinter namespace cf = unlinesInline [ - header namespace cf, - " ", - entrypoints namespace cf, - " ", - " #region (Internal) Print Methods", - unlinesInlineMap (prData namespace user) groups, - " #endregion", - " ", - " #region (Internal) Show Methods", - unlinesInlineMap (shData namespace user) groups, - " #endregion", - " }", - " #endregion", - "}" - ] - where - groups = fixCoercions (ruleGroupsInternals cf) - user = [n | (n,_) <- tokenPragmas cf] - -header :: Namespace -> CF -> String -header namespace cf = unlinesInline [ - "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/", - " ", - -- imports - "using System;", - "using System.Text; // for StringBuilder", - "using " ++ namespace ++ ".Absyn;", - " ", - "namespace " ++ namespace, - "{", - " #region Pretty-printer class", - " public class PrettyPrinter", - " {", - " #region Misc rendering functions", - " // You may wish to change these:", - " private const int BUFFER_INITIAL_CAPACITY = 2000;", - " private const string LEFT_PARENTHESIS = \"(\";", - " private const string RIGHT_PARENTHESIS = \")\";", - " private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;", - " ", - " private static int _n_ = 0;", - " private static StringBuilder buffer = new StringBuilder(BUFFER_INITIAL_CAPACITY);", - " ", - " //You may wish to change render", - " private static void Render(String s)", - " {", - " if(s == \"{\")", - " {", - " buffer.Append(\"\\n\");", - " Indent();", - " buffer.Append(s);", - " _n_ = _n_ + 2;", - " buffer.Append(\"\\n\");", - " Indent();", - " }", - " else if(s == \"(\" || s == \"[\")", - " buffer.Append(s);", - " else if(s == \")\" || s == \"]\")", - " {", - " Backup();", - " buffer.Append(s);", - " buffer.Append(\" \");", - " }", - " else if(s == \"}\")", - " {", - " _n_ = _n_ - 2;", - " Backup();", - " Backup();", - " buffer.Append(s);", - " buffer.Append(\"\\n\");", - " Indent();", - " }", - " else if(s == \",\")", - " {", - " Backup();", - " buffer.Append(s);", - " buffer.Append(\" \");", - " }", - " else if(s == \";\")", - " {", - " Backup();", - " buffer.Append(s);", - " buffer.Append(\"\\n\");", - " Indent();", - " }", - " else if(s == \"\") return;", - " else", - " {", - " // Make sure escaped characters are printed properly!", - " if(s.StartsWith(\"\\\"\") && s.EndsWith(\"\\\"\"))", - " {", - " buffer.Append('\"');", - " StringBuilder sb = new StringBuilder(s);", - " // Remove enclosing citation marks", - " sb.Remove(0,1);", - " sb.Remove(sb.Length-1,1);", - " // Note: we have to replace backslashes first! (otherwise it will \"double-escape\" the other escapes)", - " sb.Replace(\"\\\\\", \"\\\\\\\\\");", - " sb.Replace(\"\\n\", \"\\\\n\");", - " sb.Replace(\"\\t\", \"\\\\t\");", - " sb.Replace(\"\\\"\", \"\\\\\\\"\");", - " buffer.Append(sb.ToString());", - " buffer.Append('\"');", - " }", - " else", - " {", - " buffer.Append(s);", - " }", - " buffer.Append(\" \");", - " }", - " }", - " ", - " private static void PrintInternal(int n, int _i_)", - " {", - " buffer.Append(n.ToString(InvariantFormatInfo));", - " buffer.Append(' ');", - " }", - " ", - " private static void PrintInternal(double d, int _i_)", - " {", - " buffer.Append(d.ToString(InvariantFormatInfo));", - " buffer.Append(' ');", - " }", - " ", - " private static void PrintInternal(string s, int _i_)", - " {", - " Render(s);", - " }", - " ", - " private static void PrintInternal(char c, int _i_)", - " {", - " PrintQuoted(c);", - " }", - " ", - unlinesInlineMap (prToken namespace) (tokenNames cf), - " ", - " private static void ShowInternal(int n)", - " {", - " Render(n.ToString(InvariantFormatInfo));", - " }", - " ", - " private static void ShowInternal(double d)", - " {", - " Render(d.ToString(InvariantFormatInfo));", - " }", - " ", - " private static void ShowInternal(char c)", - " {", - " PrintQuoted(c);", - " }", - " ", - " private static void ShowInternal(string s)", - " {", - " PrintQuoted(s);", - " }", - " ", - unlinesInlineMap (shToken namespace) (tokenNames cf), - " ", - " private static void PrintQuoted(string s)", - " {", - " Render(\"\\\"\" + s + \"\\\"\");", - " }", - " ", - " private static void PrintQuoted(char c)", - " {", - " // Makes sure the character is escaped properly before printing it.", - " string str = c.ToString();", - " if(c == '\\n') str = \"\\\\n\";", - " if(c == '\\t') str = \"\\\\t\";", - " Render(\"'\" + str + \"'\");", - " }", - " ", - " private static void Indent()", - " {", - " int n = _n_;", - " while (n > 0)", - " {", - " buffer.Append(' ');", - " n--;", - " }", - " }", - " ", - " private static void Backup()", - " {", - " if(buffer[buffer.Length - 1] == ' ')", - " {", - " buffer.Length = buffer.Length - 1;", - " }", - " }", - " ", - " private static void Trim()", - " {", - " while(buffer.Length > 0 && buffer[0] == ' ')", - " buffer.Remove(0, 1); ", - " while(buffer.Length > 0 && buffer[buffer.Length-1] == ' ')", - " buffer.Remove(buffer.Length-1, 1);", - " }", - " ", - " private static string GetAndReset()", - " {", - " Trim();", - " string strReturn = buffer.ToString();", - " Reset();", - " return strReturn;", - " }", - " ", - " private static void Reset()", - " {", - " buffer.Remove(0, buffer.Length);", - " }", - " #endregion" - ] - -prToken :: Namespace -> Cat -> String -prToken namespace token = unlinesInline [ - " private static void PrintInternal(" ++ identifier namespace token ++ " token, int _i_)", - " {", - " buffer.Append('\\\"');", - " buffer.Append(token.ToString());", - " buffer.Append('\\\"');", - " }" - ] - -shToken :: Namespace -> Cat -> String -shToken namespace token = unlinesInline [ - " private static void ShowInternal(" ++ identifier namespace token ++ " token)", - " {", - " Render(token.ToString());", - " }" - ] - -entrypoints :: Namespace -> CF -> String -entrypoints namespace cf = unlinesInline [ - " #region Print Entry Points", - unlinesInlineMap prEntryPoint (allCats cf), - " #endregion", - " ", - " #region Show Entry Points", - unlinesInlineMap shEntryPoint (allCats cf), - " #endregion" - ] - where - prEntryPoint cat | (normCat cat) == cat = unlinesInline [ - " public static string Print(" ++ identifier namespace (identCat cat) ++ " cat)", - " {", - " PrintInternal(cat, 0);", - " return GetAndReset();", - " }" - ] - prEntryPoint _ = "" - shEntryPoint cat | (normCat cat) == cat = unlinesInline [ - " public static String Show(" ++ identifier namespace (identCat cat) ++ " cat)", - " {", - " ShowInternal(cat);", - " return GetAndReset();", - " }" - ] - shEntryPoint _ = "" - -prData :: Namespace -> [UserDef] -> (Cat, [Rule]) -> String -prData namespace user (cat, rules) - -- list - | isList cat = unlinesInline [ - " private static void PrintInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p, int _i_)", - " {", - (prList user cat rules), - " }" - ] - -- not a list - | otherwise = unlinesInline [ - " private static void PrintInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p, int _i_)", - " {", - -- first rule starts with "if", the rest of them start with "else if". - -- this isn't very pretty, but does the job and produces nice code. - prRule namespace Nothing firstRule, - unlinesInline $ map (prRule namespace (Just "else ")) otherRules, - " }" - ] - where - -- Removes the rules at the beginning of the list which won't be used by the prRule function. - rules' = dropWhile (\(fun, _) -> isCoercion fun || isDefinedRule fun) rules - firstRule = head rules' - otherRules = tail rules' - -prRule :: Namespace -> Maybe String -> Rule -> String -prRule namespace maybeElse r@(fun, (_c, cats)) - | not (isCoercion fun || isDefinedRule fun) = unlinesInline [ - " " ++ fromMaybe "" maybeElse ++ "if(p is " ++ identifier namespace fun ++ ")", - " {", - " " ++ identifier namespace fun +++ fnm ++ " = (" ++ identifier namespace fun ++ ")p;", - " if(_i_ > " ++ (show p) ++ ") Render(LEFT_PARENTHESIS);", - cats', - " if(_i_ > " ++ (show p) ++ ") Render(RIGHT_PARENTHESIS);", - " }" - ] - where - p = precRule r - cats' = case cats of - [] -> "" - _ -> unlinesInline $ map (prCat fnm) (zip (fixOnes (numProps [] cats)) (map getPrec cats)) - fnm = '_' : map toLower fun - - getPrec (Right {}) = 0 - getPrec (Left c) = precCat c -prRule _nm _ (_fun, _cats) = "" - -prList :: [UserDef] -> Cat -> [Rule] -> String -prList user c rules = unlinesInline [ - " for(int i=0; i < p.Count; i++)", - " {", - " PrintInternal(p[i], 0);", - " if(i < p.Count - 1)", - " {", - " Render(\"" ++ escapeChars sep ++ "\");", - " }", - " else", - " {", - " Render(\"" ++ optsep ++ "\");", - " }", - " }" - ] - where - et = typename (normCatOfList c) - sep = getCons rules - optsep = if hasOneFunc rules then "" else escapeChars sep - -getCons :: [Rule] -> String -getCons ((f, (_c, cats)):rs) = - if isConsFun f - then seper cats - else getCons rs - where - seper [] = [] - seper ((Right x):_xs) = x - seper ((Left {}):xs) = seper xs - -hasOneFunc :: [Rule] -> Bool -hasOneFunc [] = False -hasOneFunc ((f, (_, _cats)):rs) = - if (isOneFun f) - then True - else hasOneFunc rs - -prCat fnm (c, p) = - case c of - Right t -> " Render(\"" ++ escapeChars t ++ "\");" - Left nt - | "string" `isPrefixOf` nt -> " PrintQuoted(" ++ fnm ++ "." ++ nt ++ ");" - | isInternalVar nt -> "" - | otherwise -> " PrintInternal(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");" - - ---The following methods generate the Show function. - -shData :: Namespace -> [UserDef] -> (Cat, [Rule]) -> String -shData namespace user (cat, rules) - | isList cat = unlinesInline [ - " private static void ShowInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p)", - " {", - (shList user cat rules), - " }" - ] - | otherwise = unlinesInline [ - " private static void ShowInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p)", - " {", - unlinesInline $ map (shRule namespace) rules, - " }" - ] - -shRule :: Namespace -> Rule -> String -shRule namespace (fun, (_c, cats)) - | not (isCoercion fun || isDefinedRule fun) = unlinesInline [ - " if(p is " ++ identifier namespace fun ++ ")", - " {", - " " ++ identifier namespace fun +++ fnm ++ " = (" ++ identifier namespace fun ++ ")p;", - lparen, - " Render(\"" ++ (escapeChars fun) ++ "\");", - cats', - rparen, - " }" - ] - where - cats' | allTerms cats = "" - | otherwise = unlinesInline $ map (shCat fnm) (fixOnes (numProps [] cats)) - lparen | allTerms cats = "" - | otherwise = " Render(\"(\");" - rparen | allTerms cats = "" - | otherwise = " Render(\")\");" - allTerms [] = True - allTerms ((Left {}):_) = False - allTerms (_:zs) = allTerms zs - fnm = '_' : map toLower fun -shRule _nm (_fun, _cats) = "" - -shList :: [UserDef] -> Cat -> [Rule] -> String -shList user c _rules = unlinesInline [ - " for(int i=0; i < p.Count; i++)", - " {", - " ShowInternal(p[i]);", - " if(i < p.Count - 1)", - " Render(\",\");", - " }" - ] - where - et = typename (normCatOfList c) - -shCat fnm c = - case c of - Right {} -> "" - Left nt - | "list" `isPrefixOf` nt -> unlinesInline [ - " Render(\"[\");", - " ShowInternal(" ++ fnm ++ "." ++ nt ++ ");", - " Render(\"]\");" - ] - | isInternalVar nt -> "" - | otherwise -> " ShowInternal(" ++ fnm ++ "." ++ nt ++ ");" - -isInternalVar x = x == internalCat ++ "_" diff --git a/formats/c-sharp/CFtoGPLEX.hs b/formats/c-sharp/CFtoGPLEX.hs deleted file mode 100644 --- a/formats/c-sharp/CFtoGPLEX.hs +++ /dev/null @@ -1,221 +0,0 @@ -{- - BNF Converter: C# GPLEX Generator - Copyright (C) 2006 Author: Johan Broberg - - Modified from CFtoFlex - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the GPLEX file. - - Author : Johan Broberg (johan@pontemonti.com) - - License : GPL (GNU General Public License) - - Created : 23 November, 2006 - - Modified : 17 December, 2006 by Johan Broberg - - ************************************************************** --} - -module CFtoGPLEX (cf2gplex) where - -import CF -import RegToGPLEX -import Utils((+++), (++++)) -import NamedVariables -import Data.List -import CSharpUtils - ---The environment must be returned for the parser to use. -cf2gplex :: Namespace -> CF -> (String, SymEnv) -cf2gplex namespace cf = (unlines [ - prelude namespace, - cMacros, - prettyprinter $ (lexSymbols env) ++ (gplex namespace cf env'), - "%%" - ], env') - where - env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) - env' = env ++ (makeSymEnv (fst (unzip (tokenPragmas cf))) (length env)) - -- GPPG doesn't seem to like tokens beginning with an underscore, so they (the underscores, nothing else) have been removed. - makeSymEnv [] _ = [] - makeSymEnv (s:symbs) n = (s, "SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) - -prelude :: Namespace -> String -prelude namespace = unlines [ - "/* This GPLex file was machine-generated by the BNF converter */", - "", - "%namespace " ++ namespace, - "", - "%{", - " /// ", - " /// Buffer for escaped characters in strings.", - " /// ", - " private System.Text.StringBuilder strBuffer = new System.Text.StringBuilder();", - "", - " /// ", - " /// Change to enable output - useful for debugging purposes", - " /// ", - " public bool Trace = false;", - "", - " /// ", - " /// Culture-independent IFormatProvider for numbers. ", - " /// This is just a \"wrapper\" for System.Globalization.NumberFormatInfo.InvariantInfo.", - " /// ", - " /// ", - " /// This should be used when parsing numbers. Otherwise the parser might fail: ", - " /// culture en-US uses a dot as decimal separator, while for example sv-SE uses a comma. ", - " /// BNFC uses dot as decimal separator for Double values, so if your culture is sv-SE ", - " /// the parse will fail if this InvariantInfo isn't used.", - " /// ", - " private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;", - "", - " /// ", - " /// Convenience method to create scanner AND initialize it correctly.", - " /// As long as you don't want to enable trace output, this is all you ", - " /// need to call and give to the parser to be able to parse.", - " /// ", - " public static Scanner CreateScanner(Stream stream)", - " {", - " Scanner scanner = new Scanner(stream);", - " scanner.Begin();", - " return scanner;", - " }", - "", - " /// ", - " /// Sets the scanner to the correct initial state (YYINITIAL). ", - " /// You should call this method prior to calling parser.Parse().", - " /// ", - " public void Begin()", - " {", - " BEGIN(YYINITIAL);", - " }", - "", - " /// ", - " /// Convenience method to \"reset\" the buffer for escaped characters in strings.", - " /// ", - " private void BufferReset()", - " {", - " this.strBuffer = new System.Text.StringBuilder();", - " }", - "", - "%}", - "" - ] - ---For now all categories are included. ---Optimally only the ones that are used should be generated. -cMacros :: String -cMacros = unlines - [ - "alpha [a-zA-Z]", - "alphaCapital [A-Z]", - "alphaSmall [a-z]", - "digit [0-9]", - "ident [a-zA-Z0-9'_]", - -- start states, must be defined one at a time - "%s YYINITIAL", - "%s COMMENT", - "%s CHAR", - "%s CHARESC", - "%s CHAREND", - "%s STRING", - "%s ESCAPED", - "%%" - ] - -lexSymbols :: SymEnv -> [(String, String)] -lexSymbols ss = map transSym ss - where - transSym (s,r) = - ("\"" ++ s' ++ "\"" , "if(Trace) System.Console.Error.WriteLine(yytext); return (int)Tokens." ++ r ++ ";") - where - s' = escapeChars s - -gplex :: Namespace -> CF -> SymEnv -> [(String, String)] -gplex namespace cf env = concat [ - lexComments (comments cf), - userDefTokens, - ifC "String" strStates, - ifC "Char" charStates, - ifC "Double" [("{digit}+\".\"{digit}+(\"e\"(\\-)?{digit}+)?" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.double_ = Double.Parse(yytext, InvariantFormatInfo); return (int)Tokens.DOUBLE_;")], - ifC "Integer" [("{digit}+" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.int_ = Int32.Parse(yytext, InvariantFormatInfo); return (int)Tokens.INTEGER_;")], - ifC "Ident" [("{alpha}{ident}*" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.string_ = yytext; return (int)Tokens.IDENT_;")], - [("[ \\t\\r\\n\\f]" , "/* ignore white space. */;")], - [("." , "return (int)Tokens.error;")] - ] - where - ifC cat s = if isUsedCat cf cat then s else [] - userDefTokens = map tokenline (tokenPragmas cf) - where - tokenline (name, exp) = ("" ++ printRegGPLEX exp , action name) - action n = "if(Trace) System.Console.Error.WriteLine(yytext); yylval." ++ varName (normCat n) ++ " = new " ++ identifier namespace n ++ "(yytext); return (int)Tokens." ++ sName n ++ ";" - sName n = case lookup n env of - Just x -> x - Nothing -> n - -- These handle escaped characters in Strings. - strStates = [ - ("\"\\\"\"" , "BEGIN(STRING);"), - ("\\\\" , "BEGIN(ESCAPED);"), - ("\\\"" , "yylval.string_ = this.strBuffer.ToString(); BufferReset(); BEGIN(YYINITIAL); return (int)Tokens.STRING_;"), - ("." , "this.strBuffer.Append(yytext);"), - ("n" , "this.strBuffer.Append(\"\\n\"); BEGIN(STRING);"), - ("\\\"" , "this.strBuffer.Append(\"\\\"\"); BEGIN(STRING);"), - ("\\\\" , "this.strBuffer.Append(\"\\\\\"); BEGIN(STRING);"), - ("t" , "this.strBuffer.Append(\"\\t\"); BEGIN(STRING);"), - ("." , "this.strBuffer.Append(yytext); BEGIN(STRING);") - ] - -- These handle escaped characters in Chars. - charStates = [ - ("\"'\"" , "BEGIN(CHAR);"), - ("\\\\" , "BEGIN(CHARESC);"), - ("[^']" , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"), - ("n" , "BEGIN(CHAREND); yylval.char_ = '\\n'; return (int)Tokens.CHAR_;"), - ("t" , "BEGIN(CHAREND); yylval.char_ = '\\t'; return (int)Tokens.CHAR_;"), - ("." , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"), - ("\"'\"" , "BEGIN(YYINITIAL);") - ] - -lexComments :: ([(String, String)], [String]) -> [(String, String)] -lexComments (m,s) = (map lexSingleComment s) ++ (concatMap lexMultiComment m) - -lexSingleComment :: String -> (String, String) -lexSingleComment c = - ("\"" ++ c ++ "\"[^\\n]*\\n" , "/* BNFC single-line comment */;") - ---There might be a possible bug here if a language includes 2 multi-line comments. ---They could possibly start a comment with one character and end it with another. ---However this seems rare. -lexMultiComment :: (String, String) -> [(String, String)] -lexMultiComment (b,e) = [ - ("\"" ++ b ++ "\"" , "BEGIN(COMMENT);"), - ("\"" ++ e ++ "\"" , "BEGIN(YYINITIAL);"), - ("." , "/* BNFC multi-line comment */;"), - ("[\\n]" , "/* BNFC multi-line comment */;") - ] - --- Used to print the lexer rules; makes sure that all rules are equally indented, to make the GPLEX file a little more readable. -prettyprinter :: [(String, String)] -> String -prettyprinter xs = unlines $ map prettyprinter' xs - where - padlength = 1 + (last $ sort $ map length $ map fst xs) - prettyprinter' (x, y) = x ++ replicate (padlength - length x) ' ' ++ y diff --git a/formats/c-sharp/CFtoGPPG.hs b/formats/c-sharp/CFtoGPPG.hs deleted file mode 100644 --- a/formats/c-sharp/CFtoGPPG.hs +++ /dev/null @@ -1,275 +0,0 @@ -{- - BNF Converter: C# GPPG Generator - Copyright (C) 2006 Author: Johan Broberg - - Modified from CFtoBisonSTL. - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the GPPG input file. - - Author : Johan Broberg (johan@pontemonti.com) - - License : GPL (GNU General Public License) - - Created : 24 November, 2006 - - Modified : 17 December, 2006 by Johan Broberg - - ************************************************************** --} - -module CFtoGPPG (cf2gppg) where - -import CF -import Data.List (intersperse, isPrefixOf) -import NamedVariables hiding (varName) -import Data.Char (toLower,isUpper,isDigit) -import Utils ((+++), (++++)) -import TypeChecker -import ErrM -import OOAbstract hiding (basetypes) -import CSharpUtils - ---This follows the basic structure of CFtoHappy. - --- Type declarations -type Rules = [(NonTerminal,[(Pattern,Action)])] -type NonTerminal = String -type Pattern = String -type Action = String -type MetaVar = String - ---The environment comes from the CFtoGPLEX -cf2gppg :: Namespace -> CF -> SymEnv -> String -cf2gppg namespace cf env = unlines [ - header namespace cf, - union namespace (positionCats cf ++ allCats cf ++ tokentypes (cf2cabs cf)), - tokens user env, - declarations cf, - "", - specialToks cf, - "", - "%%", - prRules (rulesForGPPG namespace cf env) - ] - where - user = fst (unzip (tokenPragmas cf)) - -positionCats cf = filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf)) - -header :: Namespace -> CF -> String -header namespace cf = unlines [ - "/* This GPPG file was machine-generated by BNFC */", - "", - "%namespace " ++ namespace, - "%{", - definedRules namespace cf, - unlinesInline $ map (parseMethod namespace) (allCatsIdNorm cf ++ positionCats cf), - "%}" - ] - -definedRules :: Namespace -> CF -> String -definedRules namespace cf@((pr,_),_) = unlinesInline [ - if null [ rule f xs e | FunDef f xs e <- pr ] - then "" - else error "Defined rules are not yet available in C# mode!" - ] - where - ctx = buildContext cf - - list = LC (const "[]") (\t -> "List" ++ unBase t) - where - unBase (ListT t) = unBase t - unBase (BaseT x) = normCat x - - rule f xs e = - case checkDefinition' list ctx f xs e of - Bad err -> error $ "Panic! This should have been caught already:\n" ++ err - Ok (args,(e',t)) -> unlinesInline [ - "Defined Rule goes here" - ] - ---This generates a parser method for each entry point. -parseMethod :: Namespace -> Cat -> String -parseMethod namespace cat = unlinesInline [ - " " ++ returntype +++ returnvar ++ " = null;", - " public " ++ returntype ++ " Parse" ++ cat' ++ "()", - " {", - " if(this.Parse())", - " {", - " return " ++ returnvar ++ ";", - " }", - " else", - " {", - " throw new Exception(\"Could not parse input stream!\");", - " }", - " }", - " " - ] - where - cat' = identCat (normCat cat) - returntype = identifier namespace cat' - returnvar = resultName cat' - ---The union declaration is special to GPPG/GPLEX and gives the type of yylval. ---For efficiency, we may want to only include used categories here. -union :: Namespace -> [Cat] -> String -union namespace cats = unlines $ filter (\x -> x /= "\n") [ - "%union", - "{", - " public int int_;", - " public char char_;", - " public double double_;", - " public string string_;", - unlinesInline $ map catline cats, - "}" - ] - where --This is a little weird because people can make [Exp2] etc. - catline cat | (identCat cat /= cat) || (normCat cat == cat) = - " public " ++ identifier namespace (identCat (normCat cat)) +++ (varName (normCat cat)) ++ ";" - catline cat = "" - ---declares non-terminal types. -declarations :: CF -> String -declarations cf = unlinesInline $ map (typeNT cf) (positionCats cf ++ allCats cf) - where --don't define internal rules - typeNT cf nt | (isPositionCat cf nt || rulesForCat cf nt /= []) = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) - typeNT cf nt = "" - ---declares terminal types. -tokens :: [UserDef] -> SymEnv -> String -tokens user ts = concatMap (declTok user) ts - where - declTok u (s,r) = if elem s u - then "%token<" ++ varName (normCat s) ++ "> " ++ r ++ " // " ++ s ++ "\n" - else "%token " ++ r ++ " // " ++ s ++ "\n" - -specialToks :: CF -> String -specialToks cf = unlinesInline [ - ifC "String" "%token STRING_", - ifC "Char" "%token CHAR_", - ifC "Integer" "%token INTEGER_", - ifC "Double" "%token DOUBLE_", - ifC "Ident" "%token IDENT_" - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - ---The following functions are a (relatively) straightforward translation ---of the ones in CFtoHappy.hs -rulesForGPPG :: Namespace -> CF -> SymEnv -> Rules -rulesForGPPG namespace cf env = (map mkOne $ ruleGroups cf) ++ posRules where - mkOne (cat,rules) = constructRule namespace cf env rules cat - posRules = map mkPos $ positionCats cf - mkPos cat = (cat, [(maybe cat id (lookup cat env), - "$$ = new " ++ cat ++ "($1);")]) - --- For every non-terminal, we construct a set of rules. -constructRule :: Namespace -> - CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) -constructRule namespace cf env rules nt = - (nt,[(p,(generateAction namespace nt (ruleName r) b m) +++ result) | - r0 <- rules, - let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0), - let (p,m) = generatePatterns cf env r b]) - where - ruleName r = case funRule r of - ---- "(:)" -> identCat nt - ---- "(:[])" -> identCat nt - z -> z - revs = reversibleCats cf - eps = allEntryPoints cf - isEntry nt = if elem nt eps then True else False - result = if isEntry nt then (resultName (normCat (identCat nt))) ++ "= $$;" else "" - --- Generates a string containing the semantic action. --- This was copied from CFtoCup15, with only a few small modifications -generateAction :: Namespace -> NonTerminal -> Fun -> Bool -> [(MetaVar, Bool)] - -> Action -generateAction namespace nt f rev mbs - | isNilFun f = "$$ = new " ++ identifier namespace c ++ "();" - | isOneFun f = "$$ = new " ++ identifier namespace c ++ "(); $$.Add(" ++ p_1 ++ ");" - | isConsFun f && not rev = "$$ = " ++ p_2 ++ "; " ++ p_2 ++ ".Insert(0, " ++ p_1 ++ ");" - | isConsFun f && rev = "$$ = " ++ p_1 ++ "; " ++ p_1 ++ ".Add(" ++ p_2 ++ ");" - | isCoercion f = "$$ = " ++ p_1 ++ ";" - | isDefinedRule f = "$$ = " ++ f ++ "_" ++ "(" ++ concat (intersperse "," ms) ++ ");" - | otherwise = "$$ = new " ++ identifier namespace c ++ "(" ++ concat (intersperse "," ms) ++ ");" - where - c = if isNilFun f || isOneFun f || isConsFun f - then identCat (normCat nt) else f - ms = map fst mbs - p_1 = ms!!0 - p_2 = ms!!1 - - --- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal -generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)]) -generatePatterns cf env r revv = case rhsRule r of - [] -> ("/* empty */",[]) - its -> (unwords (map mkIt its), metas its) - where - mkIt i = case i of - Left c -> case lookup c env of - -- This used to be x, but that didn't work if we had a symbol "String" in env, and tried to use a normal String - it would use the symbol... - Just x | not (isPositionCat cf c) && c `notElem` (map fst basetypes) -> x - _ -> typeName (identCat c) - Right s -> case lookup s env of - Just x -> x - Nothing -> s - metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its] - - -- notice: reversibility with push_back vectors is the opposite - -- of right-recursive lists! - revert c = (head c == '[') && - not (isConsFun (funRule r)) && notElem c revs - revs = reversibleCats cf - --- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string. - -prRules :: Rules -> String -prRules [] = [] -prRules ((nt, []):rs) = prRules rs --internal rule -prRules ((nt,((p,a):ls)):rs) = - (unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs - where - nt' = identCat nt - pr [] = [] - pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ ", a , "}"])]) ++ pr ls - ---Some helper functions. -resultName :: String -> String -resultName s = "YY_RESULT_" ++ s ++ "_" - ---slightly stronger than the NamedVariable version. -varName :: String -> String -varName s = (map toLower (identCat s)) ++ "_" - -typeName :: String -> String -typeName "Ident" = "IDENT_" -typeName "String" = "STRING_" -typeName "Char" = "CHAR_" -typeName "Integer" = "INTEGER_" -typeName "Double" = "DOUBLE_" -typeName x = x diff --git a/formats/c-sharp/CSharpTop.hs b/formats/c-sharp/CSharpTop.hs deleted file mode 100644 --- a/formats/c-sharp/CSharpTop.hs +++ /dev/null @@ -1,367 +0,0 @@ -{- - BNF Converter: C# Main file - Copyright (C) 2006-2007 Author: Johan Broberg - - Modified from STLTop 2006. - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} -{- - ************************************************************** - BNF Converter Module - - Description : C# Main file - - Author : Johan Broberg (johan@pontemonti.com) - - License : GPL (GNU General Public License) - - Created : 20 November, 2006 - - Modified : 8 January, 2007 by Johan Broberg - - ************************************************************** --} - -module CSharpTop (makeCSharp) where - -import Utils -import CF -import OOAbstract -import CAbstoCSharpAbs -import CFtoGPLEX -import CFtoGPPG -import CAbstoCSharpVisitSkeleton -import CAbstoCSharpAbstractVisitSkeleton -import CFtoCSharpPrinter -import CFtoLatex -import CSharpUtils -import GetCF -import Data.Char -import System.IO -import System.Directory -import System.Exit -import System.Environment -import System.Process -import Data.Maybe -import Data.Char -import Control.Monad.ST - --- Control.Monad.State - -makeCSharp :: Bool -- Makefile - -> Bool -- Visual Studio files - -> Bool -- Windows Communication Foundation support - -> Maybe Namespace -- C# namespace to use - -> FilePath - -> IO () -makeCSharp make vsfiles wcfSupport maybenamespace file = do - (cf, isOK) <- tryReadCF file - if isOK - then do - let namespace = fromMaybe (filepathtonamespace file) maybenamespace - cabs = cf2cabs cf - absyn = cabs2csharpabs namespace cabs wcfSupport - (gplex, env) = cf2gplex namespace cf - gppg = cf2gppg namespace cf env - skeleton = cabs2csharpvisitskeleton namespace cabs - absSkeleton = cabs2csharpAbstractVisitSkeleton namespace cabs - printer = cf2csharpprinter namespace cf - latex = cfToLatex namespace cf - writeFileRep "Absyn.cs" absyn - writeFileRep (namespace ++ ".l") gplex - putStrLn " (Tested with GPLEX RC1)" - writeFileRep (namespace ++ ".y") gppg - putStrLn " (Tested with GPPG 1.0)" - writeFileRep "AbstractVisitSkeleton.cs" absSkeleton - writeFileRep "VisitSkeleton.cs" skeleton - writeFileRep "Printer.cs" printer - writeFileRep "Test.cs" (csharptest namespace cf) - writeFileRep (namespace ++ ".tex") latex - if vsfiles then (writeVisualStudioFiles namespace) else return () - if make then (writeMakefile namespace) else return () - putStrLn "Done!" - else do - putStrLn "Failed" - exitFailure - -writeMakefile :: Namespace -> IO () -writeMakefile namespace = do - writeFileRep "Makefile" makefile - putStrLn "" - putStrLn "-----------------------------------------------------------------------------" - putStrLn "Generated Makefile, which uses mono. You may want to modify the paths to" - putStrLn "GPLEX and GPPG - unless you are sure that they are globally accessible (the" - putStrLn "default commands are \"mono gplex.exe\" and \"mono gppg.exe\", respectively." - putStrLn "The Makefile assumes that ShiftReduceParser.dll is located in ./bin and that" - putStrLn "is also where test.exe will be generated." - putStrLn "-----------------------------------------------------------------------------" - putStrLn "" - where - makefile = unlines [ - "MONO = mono", - "MONOC = gmcs", - "MONOCFLAGS = -optimize -reference:${PARSERREF}", - "GPLEX = ${MONO} gplex.exe", - "GPPG = ${MONO} gppg.exe", - "LATEX = latex", - "DVIPS = dvips", - "PARSERREF = bin/ShiftReduceParser.dll", - -- Apparently GPLEX outputs filenames in lowercase, so scanner.cs is supposed to be like that! - "CSFILES = Absyn.cs Parser.cs Printer.cs scanner.cs Test.cs VisitSkeleton.cs", - "", - "all: test " ++ namespace ++ ".ps", - "", - "clean:", - -- peteg: don't nuke what we generated - move that to the "vclean" target. - "\trm -f " ++ namespace ++ ".dvi " ++ namespace ++ ".aux " ++ namespace ++ ".log " ++ namespace ++ ".ps test", - "", - "distclean:", - "\trm -f ${CSFILES} " ++ namespace ++ ".l " ++ namespace ++ ".y " ++ namespace ++ ".tex " ++ namespace ++ ".dvi " ++ namespace ++ ".aux " ++ namespace ++ ".log " ++ namespace ++ ".ps test Makefile", - "", - "test: Parser.cs Scanner.cs", - "\t@echo \"Compiling test...\"", - "\t${MONOC} ${MONOCFLAGS} -out:bin/test.exe ${CSFILES}", - "", - "Scanner.cs: " ++ namespace ++ ".l", - "\t${GPLEX} /out:Scanner.cs " ++ namespace ++ ".l", - "", - "Parser.cs: " ++ namespace ++ ".y", - "\t${GPPG} /gplex " ++ namespace ++ ".y > Parser.cs", - "", - "" ++ namespace ++ ".dvi: " ++ namespace ++ ".tex", - "\t${LATEX} " ++ namespace ++ ".tex", - "", - "" ++ namespace ++ ".ps: " ++ namespace ++ ".dvi", - "\t${DVIPS} " ++ namespace ++ ".dvi -o " ++ namespace ++ ".ps", - "" - ] - -writeVisualStudioFiles :: Namespace -> IO () -writeVisualStudioFiles namespace = do - guid <- projectguid - writeFileRep (namespace ++ ".csproj") (csproj guid) - writeFileRep (namespace ++ ".sln") (sln guid) - writeFileRep "run-gp.bat" batchfile - putStrLn "" - putStrLn "-----------------------------------------------------------------------------" - putStrLn "Visual Studio solution (.sln) and project (.csproj) files were written." - putStrLn "The project file has a reference to GPLEX/GPPG's ShiftReduceParser. You will" - putStrLn "have to either copy this file to bin\\ShiftReduceParser.dll or change the" - putStrLn "reference so that it points to the right location (you can do this from" - putStrLn "within Visual Studio)." - putStrLn "Additionally, the project includes Parser.cs and Scanner.cs. These have not" - putStrLn "been generated yet. You can use the run-gp.bat file to generate them, but" - putStrLn "note that it requires gppg and gplex to be in your PATH." - putStrLn "-----------------------------------------------------------------------------" - putStrLn "" - where - batchfile = unlines [ - "@echo off", - "gppg /gplex " ++ namespace ++ ".y > Parser.cs", - "gplex /verbose /out:Scanner.cs " ++ namespace ++ ".l" - ] - sln guid = unlines [ - "Microsoft Visual Studio Solution File, Format Version 9.00", - "# Visual Studio 2005", - "Project(\"{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}\") = \"" ++ namespace ++ "\", \"" ++ namespace ++ ".csproj\", \"" ++ guid ++ "\"", - "EndProject", - "Global", - " GlobalSection(SolutionConfigurationPlatforms) = preSolution", - " Debug|Any CPU = Debug|Any CPU", - " Release|Any CPU = Release|Any CPU", - " EndGlobalSection", - " GlobalSection(ProjectConfigurationPlatforms) = postSolution", - " " ++ guid ++ ".Debug|Any CPU.ActiveCfg = Debug|Any CPU", - " " ++ guid ++ ".Debug|Any CPU.Build.0 = Debug|Any CPU", - " " ++ guid ++ ".Release|Any CPU.ActiveCfg = Release|Any CPU", - " " ++ guid ++ ".Release|Any CPU.Build.0 = Release|Any CPU", - " EndGlobalSection", - " GlobalSection(SolutionProperties) = preSolution", - " HideSolutionNode = FALSE", - " EndGlobalSection", - "EndGlobal" - ] - csproj guid = unlines [ - "", - "", - " ", - " Debug", - " AnyCPU", - " 8.0.50727", - " 2.0", - " " ++ guid ++ "", - " Library", - " Properties", - " " ++ namespace ++ "", - " " ++ namespace ++ "", - " ", - " ", - " ", - " ", - " true", - " full", - " false", - " bin\\Debug\\", - " DEBUG;TRACE", - " prompt", - " 4", - " ", - " ", - " pdbonly", - " true", - " bin\\Release\\", - " TRACE", - " prompt", - " 4", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " False", - " bin\\ShiftReduceParser.dll", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - "" - ] - -csharptest :: Namespace -> CF -> String -csharptest namespace cf = unlines [ - "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", - "/* */", - "/* This test will parse a file, print the abstract syntax tree, and then */", - "/* pretty-print the result. */", - "/* */", - "/****************************************************************************/", - "using System;", - "using System.IO;", - "using " ++ namespace ++ ".Absyn;", - "", - "namespace " ++ namespace, - "{", - " public class Test", - " {", - " public static void Main(string[] args)", - " {", - " if (args.Length > 0)", - " {", - " Stream stream = File.OpenRead(args[0]);", - " /* The default entry point is used. For other options see class Parser */", - " Parser parser = new Parser();", - " Scanner scanner = Scanner.CreateScanner(stream);", - " // Uncomment to enable trace information:", - " // parser.Trace shows what the parser is doing", - " // parser.Trace = true;", - " // scanner.Trace prints the tokens as they are parsed, one token per line", - " // scanner.Trace = true;", - " parser.scanner = scanner;", - " try", - " {", - " " ++ def ++ " parse_tree = parser.Parse" ++ def ++ "();", - " if (parse_tree != null)", - " {", - " Console.Out.WriteLine(\"Parse Successful!\");", - " Console.Out.WriteLine(\"\");", - " Console.Out.WriteLine(\"[Abstract Syntax]\");", - " Console.Out.WriteLine(\"{0}\", PrettyPrinter.Show(parse_tree));", - " Console.Out.WriteLine(\"\");", - " Console.Out.WriteLine(\"[Linearized Tree]\");", - " Console.Out.WriteLine(\"{0}\", PrettyPrinter.Print(parse_tree));", - " }", - " else", - " {", - " Console.Out.WriteLine(\"Parse NOT Successful!\");", - " }", - " }", - " catch(Exception e)", - " {", - " Console.Out.WriteLine(\"Parse NOT Successful:\");", - " Console.Out.WriteLine(e.Message);", - " Console.Out.WriteLine(\"\");", - " Console.Out.WriteLine(\"Stack Trace:\");", - " Console.Out.WriteLine(e.StackTrace);", - " }", - " }", - " else", - " {", - " Console.Out.WriteLine(\"You must specify a filename!\");", - " }", - " }", - " }", - "}" - ] - where - def = head (allEntryPoints cf) - -filepathtonamespace :: FilePath -> Namespace -filepathtonamespace file = take (length file - 3) (basename file) - -projectguid :: IO String -projectguid = do - maybeFilePath <- findDirectory - guid <- maybe getBadGUID getGoodGUID maybeFilePath - return guid - where - getBadGUID :: IO String - getBadGUID = do - putStrLn "-----------------------------------------------------------------------------" - putStrLn "Could not find Visual Studio tool uuidgen.exe to generate project GUID!" - putStrLn "You might want to put this tool in your PATH." - putStrLn "-----------------------------------------------------------------------------" - return "{00000000-0000-0000-0000-000000000000}" - getGoodGUID :: FilePath -> IO String - getGoodGUID filepath = do - let filepath' = "\"" ++ filepath ++ "\"" - (hIn, hOut, hErr, processHandle) <- runInteractiveCommand filepath' - guid <- hGetLine hOut - return ('{' : init guid ++ "}") - findDirectory :: IO (Maybe FilePath) - findDirectory = do - -- This works with Visual Studio 2005. - -- We will probably have to be modify this to include another environment variable name for Orcas. - -- I doubt there is any need to support VS2003? (I doubt they have patched it up to have 2.0 support?) - toolpath <- catch (getEnv "VS80COMNTOOLS") (\_ -> return "C:\\Program Files\\Microsoft Visual Studio 8\\Common7\\Tools") - exists <- doesDirectoryExist toolpath - if exists - then return (Just (toolpath ++ "\\uuidgen.exe")) - -- this handles the case when the user was clever enough to add the directory to his/her PATH - else findExecutable "uuidgen.exe" diff --git a/formats/c-sharp/CSharpTop.hs~ b/formats/c-sharp/CSharpTop.hs~ deleted file mode 100644 --- a/formats/c-sharp/CSharpTop.hs~ +++ /dev/null @@ -1,367 +0,0 @@ -{- - BNF Converter: C# Main file - Copyright (C) 2006-2007 Author: Johan Broberg - - Modified from STLTop 2006. - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} -{- - ************************************************************** - BNF Converter Module - - Description : C# Main file - - Author : Johan Broberg (johan@pontemonti.com) - - License : GPL (GNU General Public License) - - Created : 20 November, 2006 - - Modified : 8 January, 2007 by Johan Broberg - - ************************************************************** --} - -module CSharpTop (makeCSharp) where - -import Utils -import CF -import OOAbstract -import CAbstoCSharpAbs -import CFtoGPLEX -import CFtoGPPG -import CAbstoCSharpVisitSkeleton -import CAbstoCSharpAbstractVisitSkeleton -import CFtoCSharpPrinter -import CFtoLatex -import CSharpUtils -import System.IO -import GetCF -import Data.Char -import System.IO -import System.Directory -import System.IO -import System.Process -import Data.Maybe -import Data.Char -import Control.Monad.ST - --- Control.Monad.State - -makeCSharp :: Bool -- Makefile - -> Bool -- Visual Studio files - -> Bool -- Windows Communication Foundation support - -> Maybe Namespace -- C# namespace to use - -> FilePath - -> IO () -makeCSharp make vsfiles wcfSupport maybenamespace file = do - (cf, isOK) <- tryReadCF file - if isOK - then do - let namespace = fromMaybe (filepathtonamespace file) maybenamespace - cabs = cf2cabs cf - absyn = cabs2csharpabs namespace cabs wcfSupport - (gplex, env) = cf2gplex namespace cf - gppg = cf2gppg namespace cf env - skeleton = cabs2csharpvisitskeleton namespace cabs - absSkeleton = cabs2csharpAbstractVisitSkeleton namespace cabs - printer = cf2csharpprinter namespace cf - latex = cfToLatex namespace cf - writeFileRep "Absyn.cs" absyn - writeFileRep (namespace ++ ".l") gplex - putStrLn " (Tested with GPLEX RC1)" - writeFileRep (namespace ++ ".y") gppg - putStrLn " (Tested with GPPG 1.0)" - writeFileRep "AbstractVisitSkeleton.cs" absSkeleton - writeFileRep "VisitSkeleton.cs" skeleton - writeFileRep "Printer.cs" printer - writeFileRep "Test.cs" (csharptest namespace cf) - writeFileRep (namespace ++ ".tex") latex - if vsfiles then (writeVisualStudioFiles namespace) else return () - if make then (writeMakefile namespace) else return () - putStrLn "Done!" - else do - putStrLn "Failed" - exitFailure - -writeMakefile :: Namespace -> IO () -writeMakefile namespace = do - writeFileRep "Makefile" makefile - putStrLn "" - putStrLn "-----------------------------------------------------------------------------" - putStrLn "Generated Makefile, which uses mono. You may want to modify the paths to" - putStrLn "GPLEX and GPPG - unless you are sure that they are globally accessible (the" - putStrLn "default commands are \"mono gplex.exe\" and \"mono gppg.exe\", respectively." - putStrLn "The Makefile assumes that ShiftReduceParser.dll is located in ./bin and that" - putStrLn "is also where test.exe will be generated." - putStrLn "-----------------------------------------------------------------------------" - putStrLn "" - where - makefile = unlines [ - "MONO = mono", - "MONOC = gmcs", - "MONOCFLAGS = -optimize -reference:${PARSERREF}", - "GPLEX = ${MONO} gplex.exe", - "GPPG = ${MONO} gppg.exe", - "LATEX = latex", - "DVIPS = dvips", - "PARSERREF = bin/ShiftReduceParser.dll", - -- Apparently GPLEX outputs filenames in lowercase, so scanner.cs is supposed to be like that! - "CSFILES = Absyn.cs Parser.cs Printer.cs scanner.cs Test.cs VisitSkeleton.cs", - "", - "all: test " ++ namespace ++ ".ps", - "", - "clean:", - -- peteg: don't nuke what we generated - move that to the "vclean" target. - "\trm -f " ++ namespace ++ ".dvi " ++ namespace ++ ".aux " ++ namespace ++ ".log " ++ namespace ++ ".ps test", - "", - "distclean:", - "\trm -f ${CSFILES} " ++ namespace ++ ".l " ++ namespace ++ ".y " ++ namespace ++ ".tex " ++ namespace ++ ".dvi " ++ namespace ++ ".aux " ++ namespace ++ ".log " ++ namespace ++ ".ps test Makefile", - "", - "test: Parser.cs Scanner.cs", - "\t@echo \"Compiling test...\"", - "\t${MONOC} ${MONOCFLAGS} -out:bin/test.exe ${CSFILES}", - "", - "Scanner.cs: " ++ namespace ++ ".l", - "\t${GPLEX} /out:Scanner.cs " ++ namespace ++ ".l", - "", - "Parser.cs: " ++ namespace ++ ".y", - "\t${GPPG} /gplex " ++ namespace ++ ".y > Parser.cs", - "", - "" ++ namespace ++ ".dvi: " ++ namespace ++ ".tex", - "\t${LATEX} " ++ namespace ++ ".tex", - "", - "" ++ namespace ++ ".ps: " ++ namespace ++ ".dvi", - "\t${DVIPS} " ++ namespace ++ ".dvi -o " ++ namespace ++ ".ps", - "" - ] - -writeVisualStudioFiles :: Namespace -> IO () -writeVisualStudioFiles namespace = do - guid <- projectguid - writeFileRep (namespace ++ ".csproj") (csproj guid) - writeFileRep (namespace ++ ".sln") (sln guid) - writeFileRep "run-gp.bat" batchfile - putStrLn "" - putStrLn "-----------------------------------------------------------------------------" - putStrLn "Visual Studio solution (.sln) and project (.csproj) files were written." - putStrLn "The project file has a reference to GPLEX/GPPG's ShiftReduceParser. You will" - putStrLn "have to either copy this file to bin\\ShiftReduceParser.dll or change the" - putStrLn "reference so that it points to the right location (you can do this from" - putStrLn "within Visual Studio)." - putStrLn "Additionally, the project includes Parser.cs and Scanner.cs. These have not" - putStrLn "been generated yet. You can use the run-gp.bat file to generate them, but" - putStrLn "note that it requires gppg and gplex to be in your PATH." - putStrLn "-----------------------------------------------------------------------------" - putStrLn "" - where - batchfile = unlines [ - "@echo off", - "gppg /gplex " ++ namespace ++ ".y > Parser.cs", - "gplex /verbose /out:Scanner.cs " ++ namespace ++ ".l" - ] - sln guid = unlines [ - "Microsoft Visual Studio Solution File, Format Version 9.00", - "# Visual Studio 2005", - "Project(\"{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}\") = \"" ++ namespace ++ "\", \"" ++ namespace ++ ".csproj\", \"" ++ guid ++ "\"", - "EndProject", - "Global", - " GlobalSection(SolutionConfigurationPlatforms) = preSolution", - " Debug|Any CPU = Debug|Any CPU", - " Release|Any CPU = Release|Any CPU", - " EndGlobalSection", - " GlobalSection(ProjectConfigurationPlatforms) = postSolution", - " " ++ guid ++ ".Debug|Any CPU.ActiveCfg = Debug|Any CPU", - " " ++ guid ++ ".Debug|Any CPU.Build.0 = Debug|Any CPU", - " " ++ guid ++ ".Release|Any CPU.ActiveCfg = Release|Any CPU", - " " ++ guid ++ ".Release|Any CPU.Build.0 = Release|Any CPU", - " EndGlobalSection", - " GlobalSection(SolutionProperties) = preSolution", - " HideSolutionNode = FALSE", - " EndGlobalSection", - "EndGlobal" - ] - csproj guid = unlines [ - "", - "", - " ", - " Debug", - " AnyCPU", - " 8.0.50727", - " 2.0", - " " ++ guid ++ "", - " Library", - " Properties", - " " ++ namespace ++ "", - " " ++ namespace ++ "", - " ", - " ", - " ", - " ", - " true", - " full", - " false", - " bin\\Debug\\", - " DEBUG;TRACE", - " prompt", - " 4", - " ", - " ", - " pdbonly", - " true", - " bin\\Release\\", - " TRACE", - " prompt", - " 4", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " False", - " bin\\ShiftReduceParser.dll", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - "" - ] - -csharptest :: Namespace -> CF -> String -csharptest namespace cf = unlines [ - "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", - "/* */", - "/* This test will parse a file, print the abstract syntax tree, and then */", - "/* pretty-print the result. */", - "/* */", - "/****************************************************************************/", - "using System;", - "using System.IO;", - "using " ++ namespace ++ ".Absyn;", - "", - "namespace " ++ namespace, - "{", - " public class Test", - " {", - " public static void Main(string[] args)", - " {", - " if (args.Length > 0)", - " {", - " Stream stream = File.OpenRead(args[0]);", - " /* The default entry point is used. For other options see class Parser */", - " Parser parser = new Parser();", - " Scanner scanner = Scanner.CreateScanner(stream);", - " // Uncomment to enable trace information:", - " // parser.Trace shows what the parser is doing", - " // parser.Trace = true;", - " // scanner.Trace prints the tokens as they are parsed, one token per line", - " // scanner.Trace = true;", - " parser.scanner = scanner;", - " try", - " {", - " " ++ def ++ " parse_tree = parser.Parse" ++ def ++ "();", - " if (parse_tree != null)", - " {", - " Console.Out.WriteLine(\"Parse Successful!\");", - " Console.Out.WriteLine(\"\");", - " Console.Out.WriteLine(\"[Abstract Syntax]\");", - " Console.Out.WriteLine(\"{0}\", PrettyPrinter.Show(parse_tree));", - " Console.Out.WriteLine(\"\");", - " Console.Out.WriteLine(\"[Linearized Tree]\");", - " Console.Out.WriteLine(\"{0}\", PrettyPrinter.Print(parse_tree));", - " }", - " else", - " {", - " Console.Out.WriteLine(\"Parse NOT Successful!\");", - " }", - " }", - " catch(Exception e)", - " {", - " Console.Out.WriteLine(\"Parse NOT Successful:\");", - " Console.Out.WriteLine(e.Message);", - " Console.Out.WriteLine(\"\");", - " Console.Out.WriteLine(\"Stack Trace:\");", - " Console.Out.WriteLine(e.StackTrace);", - " }", - " }", - " else", - " {", - " Console.Out.WriteLine(\"You must specify a filename!\");", - " }", - " }", - " }", - "}" - ] - where - def = head (allEntryPoints cf) - -filepathtonamespace :: FilePath -> Namespace -filepathtonamespace file = take (length file - 3) (basename file) - -projectguid :: IO String -projectguid = do - maybeFilePath <- findDirectory - guid <- maybe getBadGUID getGoodGUID maybeFilePath - return guid - where - getBadGUID :: IO String - getBadGUID = do - putStrLn "-----------------------------------------------------------------------------" - putStrLn "Could not find Visual Studio tool uuidgen.exe to generate project GUID!" - putStrLn "You might want to put this tool in your PATH." - putStrLn "-----------------------------------------------------------------------------" - return "{00000000-0000-0000-0000-000000000000}" - getGoodGUID :: FilePath -> IO String - getGoodGUID filepath = do - let filepath' = "\"" ++ filepath ++ "\"" - (hIn, hOut, hErr, processHandle) <- runInteractiveCommand filepath' - guid <- hGetLine hOut - return ('{' : init guid ++ "}") - findDirectory :: IO (Maybe FilePath) - findDirectory = do - -- This works with Visual Studio 2005. - -- We will probably have to be modify this to include another environment variable name for Orcas. - -- I doubt there is any need to support VS2003? (I doubt they have patched it up to have 2.0 support?) - toolpath <- catch (getEnv "VS80COMNTOOLS") (\_ -> return "C:\\Program Files\\Microsoft Visual Studio 8\\Common7\\Tools") - exists <- doesDirectoryExist toolpath - if exists - then return (Just (toolpath ++ "\\uuidgen.exe")) - -- this handles the case when the user was clever enough to add the directory to his/her PATH - else findExecutable "uuidgen.exe" diff --git a/formats/c-sharp/CSharpUtils.hs b/formats/c-sharp/CSharpUtils.hs deleted file mode 100644 --- a/formats/c-sharp/CSharpUtils.hs +++ /dev/null @@ -1,154 +0,0 @@ -{- - BNF Converter: Utility Functions for C# - Copyright (C) 2006 Author: Johan Broberg - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module provides utility functions for the - C# format. - - Author : Johan Broberg (johan@pontemonti.com) - - License : GPL (GNU General Public License) - - Created : 23 November, 2006 - - Modified : 21 January, 2007 by Johan Broberg - - ************************************************************** --} - -module CSharpUtils where - -import CF -import Control.Monad.ST --- Control.Monad.State -import Data.Char (toLower) -import Data.Maybe -import Data.List -import OOAbstract hiding (basetypes) - -type Namespace = String - ---The visit-function name of a basic type -visitFunName :: String -> String -visitFunName v = - if "integer_" `isPrefixOf` v then "Integer" - else if "char_" `isPrefixOf` v then "Char" - else if "string_" `isPrefixOf` v then "String" - else if "double_" `isPrefixOf` v then "Double" - else if "ident_" `isPrefixOf` v then "Ident" - else "Ident" --User-defined type - -isUserDefined :: String -> Bool -isUserDefined v = v `notElem` (map classVar (map fst basetypes)) - -basetypes = [ - ("Integer","int"), - ("Char", "char"), - ("Double", "double"), - ("String", "string"), - ("Ident", "string") - ] - -typename :: String -> String -typename name - | name == "Char" = "char" - | name == "Double" = "double" - | name == "Ident" = "string" - | name == "Integer" = "int" - | name == "String" = "string" - | otherwise = name - --- Creates a variable name. --- To make sure that no reserved keyword is generated, an underscore is added at the end. Not very pretty, but effective. -varname :: String -> String -varname name = (map toLower name) ++ "_" - --- Given a variable name (in an abstract syntax class), returns ".ToString()" if the name doesn't match one of the basetypes. -toString :: String -> String -toString v = if isUserDefined v then ".ToString()" else "" - --- Prepends namespace ".Absyn." to typ unless it is one of the basetypes -identifier :: Namespace -> String -> String -identifier namespace typ - | typ `elem` (map snd basetypes) = typ - | otherwise = namespace ++ ".Absyn." ++ typ - --- Removes empty lines, and removes the line-break at the end. --- This can be useful if you want to use unlines "inside" unlines and don't want a whole lot of "useless" line-breaks. -unlinesInline :: [String] -> String -unlinesInline xs = concat $ intersperse "\n" $ filter (\x -> x /= "") xs - -unlinesInlineMap :: (a -> String) -> [a] -> String -unlinesInlineMap fun xs = unlinesInline $ intersperse " " $ filter (\x -> x /= "") $ map fun xs - ---Helper function that escapes characters in strings -escapeChars :: String -> String -escapeChars [] = [] -escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) -escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) -escapeChars (x:xs) = x : (escapeChars xs) - -isAlsoCategory :: Fun -> Cat -> Bool -isAlsoCategory f c = f == c - -flattenSignatures :: CAbs -> [(Cat, CSharpAbsRule)] -flattenSignatures cabs = [(c,r) | (c,rs) <- signatures cabs, r <- map cabsrule2csharpabsrule rs] - -type VariableName = String -type PropertyName = String - --- Just like CAbsRule in OOAbstract, except this also has PropertyName. --- (valcat,(constr,args)), True = is class (not basic), class variable stored -type CSharpAbsRule = (Fun,[(Cat,Bool,VariableName,PropertyName)]) - -cabsrule2csharpabsrule :: CAbsRule -> CSharpAbsRule -cabsrule2csharpabsrule (f, cabsrule) = (f, addPropertyNames cabsrule) - --- This generates names for properties. It's done the same way as generation of variable names in OOAbstract->cf2cabs --- A property name uses the same casing as its category, but has an underscore at the end -addPropertyNames :: [(Cat, Bool, String)] -> [(Cat, Bool, VariableName, PropertyName)] -addPropertyNames cs = [(c,b,v,p) | ((c,b,v),p) <- zip cs (properties [] (map propertyName [c | (c,_,_) <- cs]))] - --- creating new names is quadratic, but parameter lists are short - --- this should conform with Michael's naming - where - properties seen vv = case vv of - [] -> vv - v:vs -> case length (filter (==v) seen) of - 0 | elem v vs -> (v ++ "1"): properties (v:seen) vs - 0 -> v : properties (v:seen) vs - n -> (v ++ show (n+1)) : properties (v:seen) vs - -propertyName :: Cat -> PropertyName -propertyName c = c ++ "_" - --- Given a rule's definition, it goes through and nicely the properties by type. --- Does the same thing as numVars in NamedVariables, except the varName part -numProps :: [(String, Int)] -> [Either String b] -> [Either String b] -numProps _env [] = [] -numProps env ((Right f) : fs) = (Right f) : (numProps env fs) -numProps env ((Left f) : fs) = - case lookup f' env of - Nothing -> (Left f') : (numProps ((f',1):env) fs) - Just n -> (Left $ f' ++ (show $ n + 1)) : (numProps ((f',n+1):env) fs) - where - f' = propertyName (normCat (identCat f)) - diff --git a/formats/c-sharp/RegToGPLEX.hs b/formats/c-sharp/RegToGPLEX.hs deleted file mode 100644 --- a/formats/c-sharp/RegToGPLEX.hs +++ /dev/null @@ -1,73 +0,0 @@ -module RegToGPLEX (printRegGPLEX) where - --- modified from RegToFlex - -import AbsBNF -import Data.Char - --- the top-level printing method -printRegGPLEX :: Reg -> String -printRegGPLEX = render . prt 0 - --- you may want to change render and parenth - -render :: [String] -> String -render = rend (0::Int) where - rend i ss = case ss of - "[" :ts -> cons "[" $ rend i ts - "(" :ts -> cons "(" $ rend i ts - t : "," :ts -> cons t $ space "," $ rend i ts - t : ")" :ts -> cons t $ cons ")" $ rend i ts - t : "]" :ts -> cons t $ cons "]" $ rend i ts - t :ts -> space t $ rend i ts - _ -> "" - cons s t = s ++ t - new i s = s - space t s = if null s then t else t ++ s - -parenth :: [String] -> [String] -parenth ss = ["("] ++ ss ++ [")"] - --- the printer class does the job -class Print a where - prt :: Int -> a -> [String] - prtList :: [a] -> [String] - prtList = concat . map (prt 0) - -instance Print a => Print [a] where - prt _ = prtList - -instance Print Char where - prt _ c = [[c]] - prtList s = map (concat . prt 0) s - -prPrec :: Int -> Int -> [String] -> [String] -prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) - RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) - RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) - RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) - RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) - ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) - REps -> prPrec i 3 (["[^.]"]) - RChar c -> prPrec i 3 (prt 0 [mkEsc [c]]) - RAlts str -> prPrec i 3 (concat [["["], prt 0 $ mkEsc str, ["]"]]) - RSeqs str -> prPrec i 2 (concat (map (prt 0) $ mkEsc str)) - RDigit -> prPrec i 3 (concat [["{digit}"]]) - RLetter -> prPrec i 3 (concat [["{alpha}"]]) - RUpper -> prPrec i 3 (concat [["{alphaCapital}"]]) - RLower -> prPrec i 3 (concat [["{alphaSmall}"]]) - RAny -> prPrec i 3 (concat [["."]]) - --- Handle special characters in regular expressions. -mkEsc :: String -> String -mkEsc = concatMap escChar - where escChar c - | c `elem` "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" = '\\':[c] - | otherwise = [c] diff --git a/formats/c/CFtoBisonC.hs b/formats/c/CFtoBisonC.hs deleted file mode 100644 --- a/formats/c/CFtoBisonC.hs +++ /dev/null @@ -1,275 +0,0 @@ -{- - BNF Converter: C Bison generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the Bison input file. - Note that because of the way bison stores results - the programmer can increase performance by limiting - the number of entry points in their grammar. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 6 August, 2003 - - Modified : 6 August, 2003 - - - ************************************************************** --} - - -module CFtoBisonC (cf2Bison) where - -import CF -import Data.List (intersperse, isPrefixOf) -import NamedVariables hiding (varName) -import Data.Char (toLower) -import Utils ((+++), (++++)) - ---This follows the basic structure of CFtoHappy. - --- Type declarations -type Rules = [(NonTerminal,[(Pattern,Action)])] -type NonTerminal = String -type Pattern = String -type Action = String -type MetaVar = String - ---The environment comes from the CFtoFlex -cf2Bison :: String -> CF -> SymEnv -> String -cf2Bison name cf env - = unlines - [header name cf, - union (allCats cf), - "%token _ERROR_", - tokens user env, - declarations cf, - specialToks cf, - "%%", - prRules (rulesForBison name cf env) - ] - where - user = fst (unzip (tokenPragmas cf)) - -header :: String -> CF -> String -header name cf = unlines - ["/* This Bison file was machine-generated by BNFC */", - "%{", - "#include ", - "#include ", - "#include ", - "#include \"Absyn.h\"", - "#define initialize_lexer " ++ name ++ "_initialize_lexer", - "extern int yyparse(void);", - "extern int yylex(void);", - "extern int initialize_lexer(FILE * inp);", - "void yyerror(const char *str)", - "{", - " fprintf(stderr,\"error: %s\\n\",str);", - "}", - "", - -- M.F. 2004-09-17 changed allEntryPoints to allCatsIdNorm. Seems to fix the [Ty2] bug. - unlines $ map (parseMethod name) (allCatsIdNorm cf), -- (allEntryPoints cf), - concatMap reverseList (filter isList (allCats cf)), - "%}" - ] - ---This generates a parser method for each entry point. -parseMethod :: String -> Cat -> String -parseMethod name cat = --- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm --- then "" --- else - unlines - [ - cat' +++ (resultName cat') +++ "= 0;", - cat' ++ " p" ++ cat' ++ "(FILE *inp)", - "{", - " initialize_lexer(inp);", - " if (yyparse())", - " { /* Failure */", - " return 0;", - " }", - " else", - " { /* Success */", - " return" +++ (resultName cat') ++ ";", - " }", - "}" - ] - where - cat' = identCat (normCat cat) - ---This method generates list reversal functions for each list type. -reverseList :: Cat -> String -reverseList c = unlines - [ - c' ++ " reverse" ++ c' ++ "(" ++ c' +++ "l)", - "{", - " " ++ c' +++"prev = 0;", - " " ++ c' +++"tmp = 0;", - " while (l)", - " {", - " tmp = l->" ++ v ++ ";", - " l->" ++ v +++ "= prev;", - " prev = l;", - " l = tmp;", - " }", - " return prev;", - "}" - ] - where - c' = identCat (normCat c) - v = (map toLower c') ++ "_" - ---The union declaration is special to Bison/Yacc and gives the type of yylval. ---For efficiency, we may want to only include used categories here. -union :: [Cat] -> String -union cats = unlines - [ - "%union", - "{", - " int int_;", - " char char_;", - " double double_;", - " char* string_;", - concatMap mkPointer cats, - "}" - ] - where --This is a little weird because people can make [Exp2] etc. - mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion. - " " ++ (identCat (normCat s)) +++ (varName (normCat s)) ++ ";\n" - mkPointer s | normCat s == s = --normal cat - " " ++ (identCat (normCat s)) +++ (varName (normCat s)) ++ ";\n" - mkPointer s = "" - ---declares non-terminal types. -declarations :: CF -> String -declarations cf = concatMap (typeNT cf) (allCats cf) - where --don't define internal rules - typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n" - typeNT cf nt = "" - ---declares terminal types. -tokens :: [UserDef] -> SymEnv -> String -tokens user ts = concatMap (declTok user) ts - where - declTok u (s,r) = if elem s u - then "%token " ++ r ++ " /* " ++ s ++ " */\n" - else "%token " ++ r ++ " /* " ++ s ++ " */\n" - -specialToks :: CF -> String -specialToks cf = concat [ - ifC "String" "%token _STRING_\n", - ifC "Char" "%token _CHAR_\n", - ifC "Integer" "%token _INTEGER_\n", - ifC "Double" "%token _DOUBLE_\n", - ifC "Ident" "%token _IDENT_\n" - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - ---The following functions are a (relatively) straightforward translation ---of the ones in CFtoHappy.hs -rulesForBison :: String -> CF -> SymEnv -> Rules -rulesForBison name cf env = map mkOne $ ruleGroups cf where - mkOne (cat,rules) = constructRule cf env rules cat - --- For every non-terminal, we construct a set of rules. -constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) -constructRule cf env rules nt = (nt,[(p,(generateAction (normCat (identCat nt)) (ruleName r) b m) +++ result) | - r0 <- rules, - let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0), - let (p,m) = generatePatterns cf env r]) - where - ruleName r = case funRule r of - "(:)" -> identCat nt - z -> z - revs = reversibleCats cf - eps = allEntryPoints cf - isEntry nt = if elem nt eps then True else False - result = if isEntry nt then (resultName (normCat (identCat nt))) ++ "= $$;" else "" - --- Generates a string containing the semantic action. -generateAction :: NonTerminal -> Fun -> Bool -> [MetaVar] -> Action -generateAction nt f b ms = - if isCoercion f - then (unwords ms) ++ ";" - else if isNilFun f - then "0;" - else if isOneFun f - then concat ["make_", nt, "(", (concat (intersperse ", " ms')), ", 0);"] - else concat ["make_", normCat f, "(", (concat (intersperse ", " ms')), ");"] - where - ms' = if b then reverse ms else ms - --- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal -generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar]) -generatePatterns cf env r = case rhsRule r of - [] -> ("/* empty */",[]) - its -> (unwords (map mkIt its), metas its) - where - mkIt i = case i of - Left c -> case lookup c env of - Just x -> x - Nothing -> typeName (identCat c) - Right s -> case lookup s env of - Just x -> x - Nothing -> s - metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its] - revIf c m = if (not (isConsFun (funRule r)) && elem c revs) - then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")") - else m -- no reversal in the left-recursive Cons rule itself - revs = reversibleCats cf - --- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string. - -prRules :: Rules -> String -prRules [] = [] -prRules ((nt, []):rs) = prRules rs --internal rule -prRules ((nt,((p,a):ls)):rs) = - (unwords [nt', ":" , p, "{ $$ =", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs - where - nt' = identCat nt - pr [] = [] - pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ $$ =", a , "}"])]) ++ pr ls - ---Some helper functions. -resultName :: String -> String -resultName s = "YY_RESULT_" ++ s ++ "_" - ---slightly stronger than the NamedVariable version. -varName :: String -> String -varName s = (map toLower (identCat s)) ++ "_" - -typeName :: String -> String -typeName "Ident" = "_IDENT_" -typeName "String" = "_STRING_" -typeName "Char" = "_CHAR_" -typeName "Integer" = "_INTEGER_" -typeName "Double" = "_DOUBLE_" -typeName x = x diff --git a/formats/c/CFtoCAbs.hs b/formats/c/CFtoCAbs.hs deleted file mode 100644 --- a/formats/c/CFtoCAbs.hs +++ /dev/null @@ -1,329 +0,0 @@ -{- - BNF Converter: C Abstract syntax - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the C Abstract Syntax - tree classes. It generates both a Header file - and an Implementation file, and Appel's C - method. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 15 September, 2003 - - Modified : 15 September, 2003 - - - ************************************************************** --} - -module CFtoCAbs (cf2CAbs) where - -import CF -import Utils((+++),(++++)) -import NamedVariables -import Data.List -import Data.Char(toLower) - - ---The result is two files (.H file, .C file) -cf2CAbs :: String -> CF -> (String, String) -cf2CAbs name cf = (mkHFile cf, mkCFile cf) - - -{- **** Header (.H) File Functions **** -} - ---Makes the Header file. -mkHFile :: CF -> String -mkHFile cf = unlines - [ - "#ifndef ABSYN_HEADER", - "#define ABSYN_HEADER", - "", - header, - prTypeDefs user, - "/******************** Forward Declarations ********************/\n", - concatMap prForward classes, - "", - "/******************** Abstract Syntax Classes ********************/\n", - concatMap (prDataH user) (cf2dataLists cf), - "", - "#endif" - ] - where - user = fst (unzip (tokenPragmas cf)) - header = "/* C++ Abstract Syntax Interface generated by the BNF Converter.*/\n" - rules = getRules cf - classes = rules ++ getClasses (allCats cf) - prForward s | not (isCoercion s) = unlines - [ - "struct " ++ s' ++ "_;", - "typedef struct " ++ s' ++ "_ *" ++ s' ++ ";" - ] - where - s' = normCat s - prForward s = "" - getRules cf = (map testRule (rulesOfCF cf)) - getClasses [] = [] - getClasses (c:cs) = - if identCat (normCat c) /= c - then getClasses cs - else if elem c rules - then getClasses cs - else c : (getClasses cs) - - testRule (f, (c, r)) = - if isList c - then if isConsFun f - then identCat c - else "_" --ignore this - else "_" - ---Prints struct definitions for all categories. -prDataH :: [UserDef] -> Data -> String -prDataH user (cat, rules) = - if isList cat - then unlines - [ - "struct " ++ c' ++ "_", - "{", - " " ++ mem +++ (varName mem) ++ ";", - " " ++ c' +++ (varName c') ++ ";", - "};", - "", - c' ++ " make_" ++ c' ++ "(" ++ mem ++ " p1, " ++ c' ++ " p2);" - ] - else unlines - [ - "struct " ++ cat ++ "_", - "{", - " enum { " ++ (concat (intersperse ", " (map prKind rules))) ++ " } kind;", - " union", - " {", - concatMap (prUnion user) rules ++ " } u;", - "};", - "", - concatMap (prRuleH user cat) rules - ] - where - c' = identCat (normCat cat) - mem = identCat (normCatOfList cat) - prKind (fun, cats) = "is_" ++ (normCat fun) - prMember user (fun, []) = "" - prMember user (fun, cats) = " " ++ (prInstVars user (getVars cats)) - prUnion user (fun, []) = "" - prUnion user (fun, cats) = " struct { " ++ (prInstVars user (getVars cats)) ++ " } " ++ (memName fun) ++ ";\n" - - ---Interface definitions for rules vary on the type of rule. -prRuleH :: [UserDef] -> String -> (Fun, [Cat]) -> String -prRuleH user c (fun, cats) = - if isNilFun fun || isOneFun fun || isConsFun fun - then "" --these are not represented in the AbSyn - else --a standard rule - c ++ " make_" ++ fun' ++ "(" ++ (prParamsH 0 (getVars cats)) ++ ");\n" - where - fun' = identCat (normCat fun) - prParamsH :: Int -> [(String, a)] -> String - prParamsH _ [] = "" - prParamsH n ((t,_):[]) = t ++ " p" ++ (show n) - prParamsH n ((t,_):vs) = (t ++ " p" ++ (show n) ++ ", ") ++ (prParamsH (n+1) vs) - ---typedefs in the Header make generation much nicer. -prTypeDefs user = unlines - [ - "/******************** TypeDef Section ********************/", - "typedef int Integer;", - "typedef char Char;", - "typedef double Double;", - "typedef char* String;", - "typedef char* Ident;", - concatMap prUserDef user - ] - where - prUserDef s = "typedef char* " ++ s ++ ";\n" - ---A class's instance variables. -prInstVars :: [UserDef] -> [IVar] -> String -prInstVars _ [] = [] -prInstVars user vars@((t,n):[]) = - t +++ uniques - where - (uniques, vs') = prUniques t vars -prInstVars user vars@((t,n):vs) = - t +++ uniques ++ - (prInstVars user vs') - where - (uniques, vs') = prUniques t vars - ---these functions group the types together nicely -prUniques :: String -> [IVar] -> (String, [IVar]) -prUniques t vs = (prVars (findIndices (\x -> case x of (y,_) -> y == t) vs) vs, remType t vs) - where - remType :: String -> [IVar] -> [IVar] - remType _ [] = [] - remType t ((t2,n):ts) = if t == t2 - then (remType t ts) - else (t2,n) : (remType t ts) - prVars (x:[]) vs = case vs !! x of - (t,n) -> (varName t) ++ (showNum n) ++ ";" - prVars (x:xs) vs = case vs !! x of - (t,n) -> (varName t) ++ (showNum n) ++ ", " ++ - (prVars xs vs) - - -{- **** Implementation (.C) File Functions **** -} - ---Makes the .C file -mkCFile :: CF -> String -mkCFile cf = unlines - [ - header, - concatMap (prDataC user) (cf2dataLists cf) - ] - where - user = fst (unzip (tokenPragmas cf)) - header = unlines - [ - "/* C Abstract Syntax Implementation generated by the BNF Converter. */", - "", - "#include ", - "#include ", - "#include \"Absyn.h\"", - "" - ] - ---This is not represented in the implementation. ---This is not represented in the implementation. -prDataC :: [UserDef] -> Data -> String -prDataC user (cat, rules) = concatMap (prRuleC user cat) rules - ---Classes for rules vary based on the type of rule. -prRuleC user c (fun, cats) = - if isNilFun fun || isOneFun fun - then "" --these are not represented in the AbSyn - else if isConsFun fun - then --this is the linked list case. - unlines - [ - "/******************** " ++ c' ++ " ********************/", - prListFuncs user c', - "" - ] - else --a standard rule - unlines - [ - "/******************** " ++ fun' ++ " ********************/", - prConstructorC user c fun' vs cats, - "" - ] - where - vs = getVars cats - fun' = identCat (normCat fun) - c' = identCat (normCat c) - ---These are all built-in list functions. ---Later we could include things like lookup,insert,delete,etc. -prListFuncs :: [UserDef] -> String -> String -prListFuncs user c = unlines - [ - c ++ " make_" ++ c ++"(" ++ m ++ " p1" ++ ", " ++ c ++ " p2)", - "{", - " " ++ c ++ " tmp = (" ++ c ++ ") malloc(sizeof(*tmp));", - " if (!tmp)", - " {", - " fprintf(stderr, \"Error: out of memory when allocating " ++ c ++ "!\\n\");", - " exit(1);", - " }", - " tmp->" ++ m' ++ " = " ++ "p1;", - " tmp->" ++ v ++ " = " ++ "p2;", - " return tmp;", - "}" - ] - where - v = (map toLower c) ++ "_" - m = drop 4 c - m' = drop 4 v - ---The constructor just assigns the parameters to the corresponding instance variables. -prConstructorC :: [UserDef] -> String -> String -> [IVar] -> [Cat] -> String -prConstructorC user cat c vs cats = - unlines - [ - cat' ++ " make_" ++ c ++"(" ++ (interleave types params) ++ ")", - "{", - " " ++ cat' ++ " tmp = (" ++ cat' ++ ") malloc(sizeof(*tmp));", - " if (!tmp)", - " {", - " fprintf(stderr, \"Error: out of memory when allocating " ++ c ++ "!\\n\");", - " exit(1);", - " }", - " tmp->kind = is_" ++ c ++ ";", - prAssigns c vs params, - " return tmp;", - "}" - ] - where - cat' = identCat (normCat cat) - (types, params) = unzip (prParams cats (length cats) ((length cats)+1)) - interleave _ [] = [] - interleave (x:[]) (y:[]) = x +++ y - interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys) - ---Prints the constructor's parameters. -prParams :: [Cat] -> Int -> Int -> [(String,String)] -prParams [] _ _ = [] -prParams (c:cs) n m = (identCat c,"p" ++ (show (m-n))) - : (prParams cs (n-1) m) - ---Prints the assignments of parameters to instance variables. ---This algorithm peeks ahead in the list so we don't use map or fold -prAssigns :: String -> [IVar] -> [String] -> String -prAssigns _ [] _ = [] -prAssigns _ _ [] = [] -prAssigns c ((t,n):vs) (p:ps) = - if n == 1 then - case findIndices (\x -> case x of (l,r) -> l == t) vs of - [] -> " tmp->u." ++ c' ++ "_." ++ (varName t) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps) - z -> " tmp->u." ++ c' ++ "_." ++ ((varName t) ++ (showNum n)) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps) - else " tmp->u." ++ c' ++ "_." ++ ((varName t) ++ (showNum n)) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps) - where - c' = map toLower c - -{- **** Helper Functions **** -} - ---Checks if something is a basic or user-defined type. -isBasic :: [UserDef] -> String -> Bool -isBasic user x = - if elem x user - then True - else case x of - "Integer" -> True - "Char" -> True - "String" -> True - "Double" -> True - "Ident" -> True - _ -> False - -memName s = (map toLower s) ++ "_" diff --git a/formats/c/CFtoCPrinter.hs b/formats/c/CFtoCPrinter.hs deleted file mode 100644 --- a/formats/c/CFtoCPrinter.hs +++ /dev/null @@ -1,648 +0,0 @@ -{- - BNF Converter: C Pretty Printer printer - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the C Pretty Printer. - It also generates the "show" method for - printing an abstract syntax tree. - - The generated files use the Visitor design pattern. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 10 August, 2003 - - Modified : 3 September, 2003 - * Added resizable buffers - - ************************************************************** --} - -module CFtoCPrinter (cf2CPrinter) where - -import CF -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower, toUpper) - ---Produces (.h file, .c file) -cf2CPrinter :: CF -> (String, String) -cf2CPrinter cf = (mkHFile cf groups, mkCFile cf groups) - where - groups = (fixCoercions (ruleGroupsInternals cf)) - -{- **** Header (.h) File Methods **** -} - ---An extremely large function to make the Header File -mkHFile :: CF -> [(Cat,[Rule])] -> String -mkHFile cf groups = unlines - [ - header, - concatMap prPrints eps, - concatMap prPrintDataH groups, - concatMap prShows eps, - concatMap prShowDataH groups, - footer - ] - where - eps = allEntryPoints cf - prPrints s | normCat s == s = "char* print" ++ s' ++ "(" ++ s' ++ " p);\n" - where - s' = identCat s - prPrints _ = "" - prShows s | normCat s == s = "char* show" ++ s' ++ "(" ++ s' ++ " p);\n" - where - s' = identCat s - prShows _ = "" - header = unlines - [ - "#ifndef PRINTER_HEADER", - "#define PRINTER_HEADER", - "", - "#include \"Absyn.h\"", - "", - "/* Certain applications may improve performance by changing the buffer size */", - "#define BUFFER_INITIAL 2000", - "/* You may wish to change _L_PAREN or _R_PAREN */", - "#define _L_PAREN '('", - "#define _R_PAREN ')'", - "", - "/* The following are simple heuristics for rendering terminals */", - "/* You may wish to change them */", - "void renderCC(Char c);", - "void renderCS(String s);", - "void indent(void);", - "void backup(void);", - "" - ] - footer = unlines - [ - "void ppInteger(Integer n, int i);", - "void ppDouble(Double d, int i);", - "void ppChar(Char c, int i);", - "void ppString(String s, int i);", - "void ppIdent(String s, int i);", - "void shInteger(Integer n);", - "void shDouble(Double d);", - "void shChar(Char c);", - "void shString(String s);", - "void shIdent(String s);", - "void bufAppendS(const char* s);", - "void bufAppendC(const char c);", - "void bufReset(void);", - "void resizeBuffer(void);", - "", - "#endif" - ] - ---Prints all the required method names and their parameters. -prPrintDataH :: (Cat, [Rule]) -> String -prPrintDataH (cat, rules) = concat ["void pp", cl, "(", cl, " p, int i);\n"] - where - cl = identCat (normCat cat) - ---Prints all the required method names and their parameters. -prShowDataH :: (Cat, [Rule]) -> String -prShowDataH (cat, rules) = concat ["void sh", cl, "(", cl, " p);\n"] - where - cl = identCat (normCat cat) - -{- **** Implementation (.C) File Methods **** -} - ---This makes the .C file by a similar method. -mkCFile :: CF -> [(Cat,[Rule])] -> String -mkCFile cf groups = concat - [ - header, - prRender, - concatMap prPrintFun eps, - concatMap prShowFun eps, - concatMap (prPrintData user) groups, - printBasics, - concatMap (prShowData user) groups, - showBasics, - footer - ] - where - eps = allEntryPoints cf - user = fst (unzip (tokenPragmas cf)) - header = unlines - [ - "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/", - "", - "#include \"Printer.h\"", - "#include ", - "#include ", - "#include ", - "", - "int _n_;", - "char* buf_;", - "int cur_;", - "int buf_size;", - "" - ] - printBasics = unlines - [ - "void ppInteger(Integer n, int i)", - "{", - " char tmp[16];", - " sprintf(tmp, \"%d\", n);", - " bufAppendS(tmp);", - "}", - "void ppDouble(Double d, int i)", - "{", - " char tmp[16];", - " sprintf(tmp, \"%g\", d);", - " bufAppendS(tmp);", - "}", - "void ppChar(Char c, int i)", - "{", - " bufAppendC('\\'');", - " bufAppendC(c);", - " bufAppendC('\\'');", - "}", - "void ppString(String s, int i)", - "{", - " bufAppendC('\\\"');", - " bufAppendS(s);", - " bufAppendC('\\\"');", - "}", - "void ppIdent(String s, int i)", - "{", - " renderS(s);", - "}", - "" - ] - showBasics = unlines - [ - "void shInteger(Integer i)", - "{", - " char tmp[16];", - " sprintf(tmp, \"%d\", i);", - " bufAppendS(tmp);", - "}", - "void shDouble(Double d)", - "{", - " char tmp[16];", - " sprintf(tmp, \"%g\", d);", - " bufAppendS(tmp);", - "}", - "void shChar(Char c)", - "{", - " bufAppendC('\\'');", - " bufAppendC(c);", - " bufAppendC('\\'');", - "}", - "void shString(String s)", - "{", - " bufAppendC('\\\"');", - " bufAppendS(s);", - " bufAppendC('\\\"');", - "}", - "void shIdent(String s)", - "{", - " bufAppendC('\\\"');", - " bufAppendS(s);", - " bufAppendC('\\\"');", - "}", - "" - ] - footer = unlines - [ - "void bufAppendS(const char* s)", - "{", - " int len = strlen(s);", - " int n;", - " while (cur_ + len > buf_size)", - " {", - " buf_size *= 2; /* Double the buffer size */", - " resizeBuffer();", - " }", - " for(n = 0; n < len; n++)", - " {", - " buf_[cur_ + n] = s[n];", - " }", - " cur_ += len;", - " buf_[cur_] = 0;", - "}", - "void bufAppendC(const char c)", - "{", - " if (cur_ == buf_size)", - " {", - " buf_size *= 2; /* Double the buffer size */", - " resizeBuffer();", - " }", - " buf_[cur_] = c;", - " cur_++;", - " buf_[cur_] = 0;", - "}", - "void bufReset(void)", - "{", - " cur_ = 0;", - " buf_size = BUFFER_INITIAL;", - " resizeBuffer();", - " memset(buf_, 0, buf_size);", - "}", - "void resizeBuffer(void)", - "{", - " char* temp = (char*) malloc(buf_size);", - " if (!temp)", - " {", - " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");", - " exit(1);", - " }", - " if (buf_)", - " {", - " strncpy(temp, buf_, buf_size); /* peteg: strlcpy is safer, but not POSIX/ISO C. */", - " free(buf_);", - " }", - " buf_ = temp;", - "}", - "char *buf_;", - "int cur_, buf_size;", - "" - ] - - -{- **** Pretty Printer Methods **** -} - ---An entry point to begin printing -prPrintFun :: Cat -> String -prPrintFun ep | normCat ep == ep = unlines - [ - "char* print" ++ ep' ++ "(" ++ ep' ++ " p)", - "{", - " _n_ = 0;", - " bufReset();", - " pp" ++ ep' ++ "(p, 0);", - " return buf_;", - "}" - ] - where - ep' = identCat ep -prPrintFun _ = "" - ---Generates methods for the Pretty Printer -prPrintData :: [UserDef] -> (Cat, [Rule]) -> String -prPrintData user (cat, rules) = - if isList cat - then unlines - [ - "void pp" ++ cl ++ "("++ cl +++ vname ++ ", int i)", - "{", - " while(" ++ vname ++ "!= 0)", - " {", - " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)", - " {", - visitMember, - optsep, - " " ++ vname +++ "= 0;", - " }", - " else", - " {", - visitMember, - " render" ++ sc ++ "(" ++ sep ++ ");", - " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", - " }", - " }", - "}", - "" - ] --Not a list: - else unlines - [ - "void pp" ++ cl ++ "(" ++ cl ++ " _p_, int _i_)", - "{", - " switch(_p_->kind)", - " {", - concatMap (prPrintRule user) rules, - " default:", - " fprintf(stderr, \"Error: bad kind field when printing " ++ cat ++ "!\\n\");", - " exit(1);", - " }", - "}\n" - ] - where - cl = identCat (normCat cat) - ecl = identCat (normCatOfList cat) - vname = map toLower cl - member = map toLower ecl - visitMember = " pp" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_, 0);" - (sc, sep) = if length sep' == 1 - then ("C", "'" ++ escapeChars sep' ++ "'") - else ("S", "\"" ++ escapeChars sep' ++ "\"") - sep' = getCons rules - optsep = if hasOneFunc rules then "" else (" render" ++ sc ++ "(" ++ sep ++ ");") - ---Pretty Printer methods for a rule. -prPrintRule :: [UserDef] -> Rule -> String -prPrintRule user r@(fun, (c, cats)) | not (isCoercion fun) = unlines - [ - " case is_" ++ fun ++ ":", - lparen, - cats', - rparen, - " break;\n" - ] - where - p = precRule r - (lparen, rparen) = - (" if (_i_ > " ++ (show p) ++ ") renderC(_L_PAREN);", - " if (_i_ > " ++ (show p) ++ ") renderC(_R_PAREN);") - cats' = (concatMap (prPrintCat user fun) (zip3 (fixOnes (numVars [] cats)) cats (map getPrec cats))) - getPrec (Right s) = (0 :: Int) - getPrec (Left c) = precCat c -prPrintRule _ (fun, cats) = "" - ---This goes on to recurse to the instance variables. -prPrintCat :: [UserDef] -> String -> (Either Cat String, Either Cat String, Int) -> String -prPrintCat user fnm (c,o,p) = case c of - (Right t) -> " render" ++ sc ++ "(" ++ t' ++ ");\n" - where - (sc,t') = if length t == 1 - then ("C", "'" ++ (escapeChars t) ++ "'") - else ("S", "\"" ++ (escapeChars t) ++ "\"") - (Left nt) -> if isBasic user nt - then " pp" ++ (basicFunName nt) ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ", " ++ (show p) ++ ");\n" - else if nt == "#_" --Internal category - then " /* Internal Category */\n" - else " pp" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ", " ++ (show p) ++ ");\n" - where - v = map toLower (identCat (normCat fnm)) - o' = case o of - Right x -> x - Left x -> normCat (identCat x) - -{- **** Abstract Syntax Tree Printer **** -} - ---An entry point to begin printing -prShowFun :: Cat -> String -prShowFun ep | normCat ep == ep = unlines - [ - "char* show" ++ ep' ++ "(" ++ ep' ++ " p)", - "{", - " _n_ = 0;", - " bufReset();", - " sh" ++ ep' ++ "(p);", - " return buf_;", - "}" - ] - where - ep' = identCat ep -prShowFun _ = "" - ---This prints the functions for Abstract Syntax tree printing. -prShowData :: [UserDef] -> (Cat, [Rule]) -> String -prShowData user (cat, rules) = - if isList cat - then unlines - [ - "void sh" ++ cl ++ "("++ cl +++ vname ++ ")", - "{", - " while(" ++ vname ++ "!= 0)", - " {", - " if (" ++ vname ++ "->" ++ vname ++ "_)", - " {", - visitMember, - " bufAppendS(\", \");", - " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", - " }", - " else", - " {", - visitMember, - " " ++ vname ++ " = 0;", - " }", - " }", - "}", - "" - ] --Not a list: - else unlines - [ - "void sh" ++ cl ++ "(" ++ cl ++ " _p_)", - "{", - " switch(_p_->kind)", - " {", - concatMap (prShowRule user) rules, - " default:", - " fprintf(stderr, \"Error: bad kind field when showing " ++ cat ++ "!\\n\");", - " exit(1);", - " }", - "}\n" - ] - where - cl = identCat (normCat cat) - ecl = identCat (normCatOfList cat) - vname = map toLower cl - member = map toLower ecl - visitMember = " sh" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);" - ---Pretty Printer methods for a rule. -prShowRule :: [UserDef] -> Rule -> String -prShowRule user r@(fun, (c, cats)) | not (isCoercion fun) = unlines - [ - " case is_" ++ fun ++ ":", - lparen, - " bufAppendS(\"" ++ fun ++ "\");\n", - optspace, - cats', - rparen, - " break;\n" - ] - where - (optspace, lparen, rparen) = if allTerms cats - then ("","","") - else (" bufAppendC(' ');\n", " bufAppendC('(');\n"," bufAppendC(')');\n") - cats' = if allTerms cats - then "" - else concat (insertSpaces (map (prShowCat user fun) (zip (fixOnes (numVars [] cats)) cats))) - insertSpaces [] = [] - insertSpaces (x:[]) = [x] - insertSpaces (x:xs) = if x == "" - then insertSpaces xs - else (x : [" bufAppendC(' ');\n"]) ++ (insertSpaces xs) - allTerms [] = True - allTerms ((Left z):zs) = False - allTerms (z:zs) = allTerms zs -prShowRule _ (fun, cats) = "" - ---This goes on to recurse to the instance variables. -prShowCat :: [UserDef] -> String -> (Either Cat String, Either Cat String) -> String -prShowCat user fnm (c,o) = case c of - (Right t) -> "" - (Left nt) -> if isBasic user nt - then " sh" ++ (basicFunName nt) ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n" - else if nt == "#_" --Internal category - then " /* Internal Category */\n" - else if ((normCat nt) /= nt) - then " sh" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n" - else concat - [ - " bufAppendC('[');\n", - " sh" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n", - " bufAppendC(']');\n" - ] - where - v = map toLower (identCat (normCat fnm)) - o' = case o of - Right x -> x - Left x -> normCat (identCat x) - -{- **** Helper Functions Section **** -} - - ---Just checks if something is a basic or user-defined type. ---This is because you don't -> a basic non-pointer type. -isBasic :: [UserDef] -> String -> Bool -isBasic user v = - if elem (init v) user' - then True - else if "integer_" `isPrefixOf` v then True - else if "char_" `isPrefixOf` v then True - else if "string_" `isPrefixOf` v then True - else if "double_" `isPrefixOf` v then True - else if "ident_" `isPrefixOf` v then True - else False - where - user' = map (map toLower) user - ---The visit-function name of a basic type -basicFunName :: String -> String -basicFunName v = - if "integer_" `isPrefixOf` v then "Integer" - else if "char_" `isPrefixOf` v then "Char" - else if "string_" `isPrefixOf` v then "String" - else if "double_" `isPrefixOf` v then "Double" - else if "ident_" `isPrefixOf` v then "Ident" - else "Ident" --User-defined type - ---Just sets the coercion level for parentheses in the Pretty Printer. -setI :: Int -> String -setI n = "_i_ = " ++ (show n) ++ "; " - ---Gets the separator for a list. -getCons :: [Rule] -> String -getCons [] = error $ "FIXME: CFtoCPrinter/getCons: No separator for a list." -getCons ((f, (c, cats)):rs) = - if isConsFun f - then seper cats - else getCons rs - where - seper [] = [] - seper ((Right x):xs) = x - seper ((Left x):xs) = seper xs - ---Checks if the list has a non-empty rule. -hasOneFunc :: [Rule] -> Bool -hasOneFunc [] = False -hasOneFunc ((f, (c, cats)):rs) = - if (isOneFun f) - then True - else hasOneFunc rs - ---Helper function that escapes characters in strings -escapeChars :: String -> String -escapeChars [] = [] -escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) -escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) -escapeChars (x:xs) = x : (escapeChars xs) - ---An extremely simple renderCer for terminals. -prRender :: String -prRender = unlines - [ - "/* You may wish to change the renderC functions */", - "void renderC(Char c)", - "{", - " if (c == '{')", - " {", - " bufAppendC('\\n');", - " indent();", - " bufAppendC(c);", - " _n_ = _n_ + 2;", - " bufAppendC('\\n');", - " indent();", - " }", - " else if (c == '(' || c == '[')", - " bufAppendC(c);", - " else if (c == ')' || c == ']')", - " {", - " backup();", - " bufAppendC(c);", - " bufAppendC(' ');", - " }", - " else if (c == '}')", - " {", - " _n_ = _n_ - 2;", - " backup();", - " backup();", - " bufAppendC(c);", - " bufAppendC('\\n\');", - " indent();", - " }", - " else if (c == ',')", - " {", - " backup();", - " bufAppendC(c);", - " bufAppendC(' ');", - " }", - " else if (c == ';')", - " {", - " backup();", - " bufAppendC(c);", - " bufAppendC('\\n');", - " indent();", - " }", - " else if (c == 0) return;", - " else", - " {", - " bufAppendC(c);", - " bufAppendC(' ');", - " }", - "}", - "void renderS(String s)", - "{", - " if(strlen(s) > 0)", - " {", - " bufAppendS(s);", - " bufAppendC(' ');", - " }", - "}", - "void indent(void)", - "{", - " int n = _n_;", - " while (n > 0)", - " {", - " bufAppendC(' ');", - " n--;", - " }", - "}", - "void backup(void)", - "{", - " if (buf_[cur_ - 1] == ' ')", - " {", - " buf_[cur_ - 1] = 0;", - " cur_--;", - " }", - "}" - ] diff --git a/formats/c/CFtoCSkel.hs b/formats/c/CFtoCSkel.hs deleted file mode 100644 --- a/formats/c/CFtoCSkel.hs +++ /dev/null @@ -1,240 +0,0 @@ -{- - BNF Converter: C Skeleton generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the C Skeleton functions. - - The generated files follow Appel's case method. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 9 August, 2003 - - Modified : 12 August, 2003 - - - ************************************************************** --} - -module CFtoCSkel (cf2CSkel) where - -import CF -import Utils ( (+++) ) -import NamedVariables -import Data.List ( isPrefixOf ) -import Data.Char ( toLower, toUpper ) - ---Produces (.H file, .C file) -cf2CSkel :: CF -> (String, String) -cf2CSkel cf = (mkHFile cf groups, mkCFile cf groups) - where - groups = (fixCoercions (ruleGroups cf)) - - -{- **** Header (.H) File Functions **** -} - ---Generates the Header File -mkHFile :: CF -> [(Cat,[Rule])] -> String -mkHFile cf groups = unlines - [ - header, - concatMap prDataH groups, - concatMap prUserH user, - footer - ] - where - user = fst (unzip (tokenPragmas cf)) - header = unlines - [ - "#ifndef SKELETON_HEADER", - "#define SKELETON_HEADER", - "/* You might want to change the above name. */", - "", - "#include \"Absyn.h\"", - "" - ] - prUserH u = "void visit" ++ u' ++ "(" ++ u ++ " p);" - where - u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem. - footer = unlines - [ - "void visitIdent(Ident i);", - "void visitInteger(Integer i);", - "void visitDouble(Double d);", - "void visitChar(Char c);", - "void visitString(String s);", - "", - "#endif" - ] - ---Prints out visit functions for a category -prDataH :: (Cat, [Rule]) -> String -prDataH (cat, _rules) = - if isList cat - then concat ["void visit", cl, "(", cl, " p);\n"] - else "void visit" ++ cl ++ "(" ++ cl ++ " p);\n" - where cl = identCat $ normCat cat - -{- **** Implementation (.C) File Functions **** -} - ---Makes the .C File -mkCFile :: CF -> [(Cat,[Rule])] -> String -mkCFile cf groups = concat - [ - header, - concatMap (prData user) groups, - concatMap prUser user, - footer - ] - where - user = fst (unzip (tokenPragmas cf)) - header = unlines [ - "/*** BNFC-Generated Visitor Traversal Skeleton. ***/", - "/* This traverses the abstract syntax tree.", - " To use, copy Skeleton.h and Skeleton.c to", - " new files. */", - "", - "#include \"Skeleton.h\"", - "" - ] - prUser u = unlines - [ - "void visit" ++ u' ++ "(" ++ u ++ " p)", - "{", - " /* Code for " ++ u ++ " Goes Here */", - "}" - ] - where - u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem. - footer = unlines - [ - "void visitIdent(Ident i)", - "{", - " /* Code for Ident Goes Here */", - "}", - "void visitInteger(Integer i)", - "{", - " /* Code for Integer Goes Here */", - "}", - "void visitDouble(Double d)", - "{", - " /* Code for Double Goes Here */", - "}", - "void visitChar(Char c)", - "{", - " /* Code for Char Goes Here */", - "}", - "void visitString(String s)", - "{", - " /* Code for String Goes Here */", - "}", - "" - ] - ---Visit functions for a category. -prData :: [UserDef] -> (Cat, [Rule]) -> String -prData user (cat, rules) = - if isList cat - then unlines - [ - "void visit" ++ cl ++ "("++ cl +++ vname ++ ")", - "{", - " while(" ++ vname ++ " != 0)", - " {", - " /* Code For " ++ cl ++ " Goes Here */", - " visit" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);", - " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", - " }", - "}", - "" - ] - -- Not a list: - else unlines - [ - "void visit" ++ cl ++ "(" ++ cl ++ " _p_)", - "{", - " switch(_p_->kind)", - " {", - concatMap (prPrintRule user) rules, - " default:", - " fprintf(stderr, \"Error: bad kind field when printing " ++ cl ++ "!\\n\");", - " exit(1);", - " }", - "}\n" - ] - where cl = identCat $ normCat cat - ecl = identCat $ normCatOfList cat - vname = map toLower cl - member = map toLower ecl - --- Visits all the instance variables of a category. -prPrintRule :: [UserDef] -> Rule -> String -prPrintRule user (fun, (_c, cats)) | not (isCoercion fun) = unlines - [ - " case is_" ++ fun ++ ":", - " /* Code for " ++ fun ++ " Goes Here */", - cats' ++ " break;" - ] - where - cats' = concatMap (prCat user fun) (zip (fixOnes (numVars [] cats)) cats) -prPrintRule _user (_fun, _cats) = "" - --- Prints the actual instance-variable visiting. -prCat :: [UserDef] -> String -> (Either Cat Cat, Either Cat Cat) -> String -prCat user fnm (c, o) = - case c of - Right {} -> "" - Left nt -> - if isBasic user nt - then " visit" ++ basicFunName nt ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n" - else " visit" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n" - where v = map toLower $ identCat $ normCat fnm - o' = case o of - Right x -> x - Left x -> normCat $ identCat x - ---Just checks if something is a basic or user-defined type. ---This is because you don't -> a basic non-pointer type. -isBasic :: [UserDef] -> String -> Bool -isBasic user v = - if elem (init v) user' - then True - else if "integer_" `isPrefixOf` v then True - else if "char_" `isPrefixOf` v then True - else if "string_" `isPrefixOf` v then True - else if "double_" `isPrefixOf` v then True - else if "ident_" `isPrefixOf` v then True - else False - where - user' = map (map toLower) user - ---The visit-function name of a basic type -basicFunName :: String -> String -basicFunName v = - if "integer_" `isPrefixOf` v then "Integer" - else if "char_" `isPrefixOf` v then "Char" - else if "string_" `isPrefixOf` v then "String" - else if "double_" `isPrefixOf` v then "Double" - else if "ident_" `isPrefixOf` v then "Ident" - else (toUpper (head v)) : (init (tail v)) --User-defined type diff --git a/formats/c/CFtoFlexC.hs b/formats/c/CFtoFlexC.hs deleted file mode 100644 --- a/formats/c/CFtoFlexC.hs +++ /dev/null @@ -1,189 +0,0 @@ -{- - BNF Converter: C flex generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the Flex file. It is - similar to JLex but with a few peculiarities. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 5 August, 2003 - - Modified : 10 August, 2003 - - - ************************************************************** --} -module CFtoFlexC (cf2flex) where - -import CF -import RegToFlex --- import Utils((+++), (++++)) -import NamedVariables -import Data.List - ---The environment must be returned for the parser to use. -cf2flex :: String -> CF -> (String, SymEnv) -cf2flex name cf = (unlines - [ - prelude name, - cMacros, - lexSymbols env, - restOfFlex cf env' - ], env') - where - env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) - env' = env ++ (makeSymEnv (fst (unzip (tokenPragmas cf))) (length env)) - makeSymEnv [] _ = [] - makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) - -prelude :: String -> String -prelude name = unlines - [ - "/* -*- c -*- This FLex file was machine-generated by the BNF converter */", - "%option noyywrap", - "%{", - "#define yylval " ++ name ++ "lval", - "#define YY_BUFFER_APPEND " ++ name ++ "_BUFFER_APPEND", - "#define YY_BUFFER_RESET " ++ name ++ "_BUFFER_RESET", - "#define initialize_lexer " ++ name ++ "_initialize_lexer", - "#include ", - "#include \"Parser.h\"", - "#define YY_BUFFER_LENGTH 4096", - "char YY_PARSED_STRING[YY_BUFFER_LENGTH];", - "void YY_BUFFER_APPEND(char *s)", - "{", - " strcat(YY_PARSED_STRING, s); //Do something better here!", - "}", - "void YY_BUFFER_RESET(void)", - "{", - " int x;", - " for(x = 0; x < YY_BUFFER_LENGTH; x++)", - " YY_PARSED_STRING[x] = 0;", - "}", - "", - "%}" - ] - ---For now all categories are included. ---Optimally only the ones that are used should be generated. -cMacros :: String -cMacros = unlines - [ - "LETTER [a-zA-Z]", - "CAPITAL [A-Z]", - "SMALL [a-z]", - "DIGIT [0-9]", - "IDENT [a-zA-Z0-9'_]", - "%START YYINITIAL COMMENT CHAR CHARESC CHAREND STRING ESCAPED", - "%%" - ] - -lexSymbols :: SymEnv -> String -lexSymbols ss = concatMap transSym ss - where - transSym (s,r) = - "\"" ++ s' ++ "\" \t return " ++ r ++ ";\n" - where - s' = escapeChars s - -restOfFlex :: CF -> SymEnv -> String -restOfFlex cf env = concat - [ - lexComments (comments cf), - userDefTokens, - ifC "String" strStates, - ifC "Char" chStates, - ifC "Double" "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t yylval.double_ = atof(yytext); return _DOUBLE_;\n", - ifC "Integer" "{DIGIT}+ \t yylval.int_ = atoi(yytext); return _INTEGER_;\n", - ifC "Ident" "{LETTER}{IDENT}* \t yylval.string_ = strdup(yytext); return _IDENT_;\n" - , "[ \\t\\r\\n\\f] \t /* ignore white space. */;\n", - ". \t return _ERROR_;\n", - "%%\n", - footer - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - userDefTokens = unlines $ - ["" ++ printRegFlex exp ++ - " \t yylval.string_ = strdup(yytext); return " ++ sName name ++ ";" - | (name, exp) <- tokenPragmas cf] - where - sName n = case lookup n env of - Just x -> x - Nothing -> n - strStates = unlines --These handle escaped characters in Strings. - [ - "\"\\\"\" \t BEGIN STRING;", - "\\\\ \t BEGIN ESCAPED;", - "\\\" \t yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return _STRING_;", - ". \t YY_BUFFER_APPEND(yytext);", - "n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;", - "\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;", - "\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;", - "t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;", - ". \t YY_BUFFER_APPEND(yytext); BEGIN STRING;" - ] - chStates = unlines --These handle escaped characters in Chars. - [ - "\"'\" \tBEGIN CHAR;", - "\\\\ \t BEGIN CHARESC;", - "[^'] \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;", - "n \t BEGIN CHAREND; yylval.char_ = '\\n'; return _CHAR_;", - "t \t BEGIN CHAREND; yylval.char_ = '\\t'; return _CHAR_;", - ". \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;", - "\"'\" \t BEGIN YYINITIAL;" - ] - footer = "void initialize_lexer(FILE *inp) { yyin = inp; BEGIN YYINITIAL; }" - -lexComments :: ([(String, String)], [String]) -> String -lexComments (m,s) = - (unlines (map lexSingleComment s)) - ++ (unlines (map lexMultiComment m)) - -lexSingleComment :: String -> String -lexSingleComment c = - "\"" ++ c ++ "\"[^\\n]*\\n \t /* BNFC single-line comment */;" - ---There might be a possible bug here if a language includes 2 multi-line comments. ---They could possibly start a comment with one character and end it with another. ---However this seems rare. -lexMultiComment :: (String, String) -> String -lexMultiComment (b,e) = unlines [ - "\"" ++ b ++ "\" \t BEGIN COMMENT;", - "\"" ++ e ++ "\" \t BEGIN YYINITIAL;", - ". \t /* BNFC multi-line comment */;", - "[\\n] \t /* BNFC multi-line comment */;" - ] - -lexReserved :: String -> String -lexReserved s = "\"" ++ s ++ "\" \t yylval.string_ = strdup(yytext); return TS;" - - ---Helper function that escapes characters in strings -escapeChars :: String -> String -escapeChars [] = [] -escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) -escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) -escapeChars (x:xs) = x : (escapeChars xs) diff --git a/formats/c/CTop.hs b/formats/c/CTop.hs deleted file mode 100644 --- a/formats/c/CTop.hs +++ /dev/null @@ -1,218 +0,0 @@ -{- - BNF Converter: C Main file - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} -module CTop (makeC) where - -import Utils -import CF -import CFtoCAbs -import CFtoFlexC -import CFtoBisonC -import CFtoCSkel -import CFtoCPrinter -import CFtoLatex --- import System.IO -import GetCF -import Data.Char -import System.IO -import System.Exit - -makeC :: Bool -> String -> FilePath -> IO () -makeC make name file = do - (cf, isOK) <- tryReadCF file - if isOK then do - let (hfile, cfile) = cf2CAbs name cf - writeFileRep "Absyn.h" hfile - writeFileRep "Absyn.c" cfile - let (flex, env) = cf2flex name cf - writeFileRep (name ++ ".l") flex - putStrLn " (Tested with flex 2.5.31)" - let bison = cf2Bison name cf env - writeFileRep (name ++ ".y") bison - putStrLn " (Tested with bison 1.875a)" - let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env - writeFileRep "Parser.h" header - let (skelH, skelC) = cf2CSkel cf - writeFileRep "Skeleton.h" skelH - writeFileRep "Skeleton.c" skelC - let (prinH, prinC) = cf2CPrinter cf - writeFileRep "Printer.h" prinH - writeFileRep "Printer.c" prinC - writeFileRep "Test.c" (ctest cf) - let latex = cfToLatex name cf - writeFileRep (name ++ ".tex") latex - if make then (writeFileRep "Makefile" $ makefile name) else return () - putStrLn "Done!" - else do putStrLn $ "Failed" - exitFailure - -makefile :: String -> String -makefile name = unlines - [ - "CC = gcc", - "CCFLAGS = -g -W -Wall", - "", - "FLEX = flex", - "FLEX_OPTS = -P" ++ name, - "", - "BISON = bison", - "BISON_OPTS = -t -p" ++ name, - "", - "LATEX = latex", - "DVIPS = dvips", - "", - "all: test" ++ name ++ " " ++ name ++ ".ps", - "", - ".PHONY: clean distclean", - "", - "clean:", - -- peteg: don't nuke what we generated - move that to the "vclean" target. - "\trm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps test" ++ name, - "", - "distclean: clean", -- FIXME - "\trm -f *.o Absyn.c Absyn.h Test.c Parser.c Parser.h Lexer.c Skeleton.c Skeleton.h Printer.c Printer.h " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps test" ++ name ++ " Makefile", - "", - "test" ++ name ++ ": Absyn.o Lexer.o Parser.o Printer.o Test.o", - "\t@echo \"Linking test" ++ name ++ "...\"", - "\t${CC} ${CCFLAGS} *.o -o test" ++ name ++ "", - "", - "Absyn.o: Absyn.c Absyn.h", - "\t${CC} ${CCFLAGS} -c Absyn.c", - "", - "Lexer.c: " ++ name ++ ".l", - "\t${FLEX} ${FLEX_OPTS} -oLexer.c " ++ name ++ ".l", - "", - "Parser.c: " ++ name ++ ".y", - "\t${BISON} ${BISON_OPTS} " ++ name ++ ".y -o Parser.c", - "", - "Lexer.o: Lexer.c Parser.h", - "\t${CC} ${CCFLAGS} -c Lexer.c ", - "", - "Parser.o: Parser.c Absyn.h", - "\t${CC} ${CCFLAGS} -c Parser.c", - "", - "Printer.o: Printer.c Printer.h Absyn.h", - "\t${CC} ${CCFLAGS} -c Printer.c", - "", - "Test.o: Test.c Parser.h Printer.h Absyn.h", - "\t${CC} ${CCFLAGS} -c Test.c", - "", - "" ++ name ++ ".dvi: " ++ name ++ ".tex", - "\t${LATEX} " ++ name ++ ".tex", - "", - "" ++ name ++ ".ps: " ++ name ++ ".dvi", - "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps", - "" - ] - -ctest :: CF -> String -ctest cf = - unlines - [ - "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", - "/* */", - "/* This test will parse a file, print the abstract syntax tree, and then */", - "/* pretty-print the result. */", - "/* */", - "/****************************************************************************/", - "", - "#include ", - "#include ", - "", - "#include \"Parser.h\"", - "#include \"Printer.h\"", - "#include \"Absyn.h\"", - "", - "int main(int argc, char ** argv)", - "{", - " FILE *input;", - " " ++ def ++ " parse_tree;", - " if (argc > 1) ", - " {", - " input = fopen(argv[1], \"r\");", - " if (!input)", - " {", - " fprintf(stderr, \"Error opening input file.\\n\");", - " exit(1);", - " }", - " }", - " else input = stdin;", - " /* The default entry point is used. For other options see Parser.h */", - " parse_tree = p" ++ def ++ "(input);", - " if (parse_tree)", - " {", - " printf(\"\\nParse Succesful!\\n\");", - " printf(\"\\n[Abstract Syntax]\\n\");", - " printf(\"%s\\n\\n\", show" ++ def ++ "(parse_tree));", - " printf(\"[Linearized Tree]\\n\");", - " printf(\"%s\\n\\n\", print" ++ def ++ "(parse_tree));", - " return 0;", - " }", - " return 1;", - "}", - "" - ] - where - def = head (allEntryPoints cf) - -mkHeaderFile :: CF -> [Cat] -> [Cat] -> [(a, String)] -> String -mkHeaderFile cf cats eps env = unlines - [ - "#ifndef PARSER_HEADER_FILE", - "#define PARSER_HEADER_FILE", - "", - "#include \"Absyn.h\"", - "", - "typedef union", - "{", - " int int_;", - " char char_;", - " double double_;", - " char* string_;", - (concatMap mkVar cats) ++ "} YYSTYPE;", - "", - "#define _ERROR_ 258", - mkDefines (259::Int) env, - "extern YYSTYPE yylval;", - concatMap mkFunc eps, - "", - "#endif" - ] - where - mkVar s | (normCat s == s) = " " ++ (identCat s) +++ (map toLower (identCat s)) ++ "_;\n" - mkVar _ = "" - mkDefines n [] = mkString n - mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) - mkString n = if isUsedCat cf "String" - then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) - else mkChar n - mkChar n = if isUsedCat cf "Char" - then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1) - else mkInteger n - mkInteger n = if isUsedCat cf "Integer" - then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1) - else mkDouble n - mkDouble n = if isUsedCat cf "Double" - then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1) - else mkIdent n - mkIdent n = if isUsedCat cf "Ident" - then ("#define _IDENT_ " ++ show n ++ "\n") - else "" - mkFunc s | (normCat s == s) = (identCat s) ++ " p" ++ (identCat s) ++ "(FILE *inp);\n" - mkFunc _ = "" - diff --git a/formats/c/CTop.hs~ b/formats/c/CTop.hs~ deleted file mode 100644 --- a/formats/c/CTop.hs~ +++ /dev/null @@ -1,217 +0,0 @@ -{- - BNF Converter: C Main file - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} -module CTop (makeC) where - -import Utils -import CF -import CFtoCAbs -import CFtoFlexC -import CFtoBisonC -import CFtoCSkel -import CFtoCPrinter -import CFtoLatex --- import System.IO -import GetCF -import Data.Char -import System.IO - -makeC :: Bool -> String -> FilePath -> IO () -makeC make name file = do - (cf, isOK) <- tryReadCF file - if isOK then do - let (hfile, cfile) = cf2CAbs name cf - writeFileRep "Absyn.h" hfile - writeFileRep "Absyn.c" cfile - let (flex, env) = cf2flex name cf - writeFileRep (name ++ ".l") flex - putStrLn " (Tested with flex 2.5.31)" - let bison = cf2Bison name cf env - writeFileRep (name ++ ".y") bison - putStrLn " (Tested with bison 1.875a)" - let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env - writeFileRep "Parser.h" header - let (skelH, skelC) = cf2CSkel cf - writeFileRep "Skeleton.h" skelH - writeFileRep "Skeleton.c" skelC - let (prinH, prinC) = cf2CPrinter cf - writeFileRep "Printer.h" prinH - writeFileRep "Printer.c" prinC - writeFileRep "Test.c" (ctest cf) - let latex = cfToLatex name cf - writeFileRep (name ++ ".tex") latex - if make then (writeFileRep "Makefile" $ makefile name) else return () - putStrLn "Done!" - else do putStrLn $ "Failed" - exitFailure - -makefile :: String -> String -makefile name = unlines - [ - "CC = gcc", - "CCFLAGS = -g -W -Wall", - "", - "FLEX = flex", - "FLEX_OPTS = -P" ++ name, - "", - "BISON = bison", - "BISON_OPTS = -t -p" ++ name, - "", - "LATEX = latex", - "DVIPS = dvips", - "", - "all: test" ++ name ++ " " ++ name ++ ".ps", - "", - ".PHONY: clean distclean", - "", - "clean:", - -- peteg: don't nuke what we generated - move that to the "vclean" target. - "\trm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps test" ++ name, - "", - "distclean: clean", -- FIXME - "\trm -f *.o Absyn.c Absyn.h Test.c Parser.c Parser.h Lexer.c Skeleton.c Skeleton.h Printer.c Printer.h " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps test" ++ name ++ " Makefile", - "", - "test" ++ name ++ ": Absyn.o Lexer.o Parser.o Printer.o Test.o", - "\t@echo \"Linking test" ++ name ++ "...\"", - "\t${CC} ${CCFLAGS} *.o -o test" ++ name ++ "", - "", - "Absyn.o: Absyn.c Absyn.h", - "\t${CC} ${CCFLAGS} -c Absyn.c", - "", - "Lexer.c: " ++ name ++ ".l", - "\t${FLEX} ${FLEX_OPTS} -oLexer.c " ++ name ++ ".l", - "", - "Parser.c: " ++ name ++ ".y", - "\t${BISON} ${BISON_OPTS} " ++ name ++ ".y -o Parser.c", - "", - "Lexer.o: Lexer.c Parser.h", - "\t${CC} ${CCFLAGS} -c Lexer.c ", - "", - "Parser.o: Parser.c Absyn.h", - "\t${CC} ${CCFLAGS} -c Parser.c", - "", - "Printer.o: Printer.c Printer.h Absyn.h", - "\t${CC} ${CCFLAGS} -c Printer.c", - "", - "Test.o: Test.c Parser.h Printer.h Absyn.h", - "\t${CC} ${CCFLAGS} -c Test.c", - "", - "" ++ name ++ ".dvi: " ++ name ++ ".tex", - "\t${LATEX} " ++ name ++ ".tex", - "", - "" ++ name ++ ".ps: " ++ name ++ ".dvi", - "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps", - "" - ] - -ctest :: CF -> String -ctest cf = - unlines - [ - "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", - "/* */", - "/* This test will parse a file, print the abstract syntax tree, and then */", - "/* pretty-print the result. */", - "/* */", - "/****************************************************************************/", - "", - "#include ", - "#include ", - "", - "#include \"Parser.h\"", - "#include \"Printer.h\"", - "#include \"Absyn.h\"", - "", - "int main(int argc, char ** argv)", - "{", - " FILE *input;", - " " ++ def ++ " parse_tree;", - " if (argc > 1) ", - " {", - " input = fopen(argv[1], \"r\");", - " if (!input)", - " {", - " fprintf(stderr, \"Error opening input file.\\n\");", - " exit(1);", - " }", - " }", - " else input = stdin;", - " /* The default entry point is used. For other options see Parser.h */", - " parse_tree = p" ++ def ++ "(input);", - " if (parse_tree)", - " {", - " printf(\"\\nParse Succesful!\\n\");", - " printf(\"\\n[Abstract Syntax]\\n\");", - " printf(\"%s\\n\\n\", show" ++ def ++ "(parse_tree));", - " printf(\"[Linearized Tree]\\n\");", - " printf(\"%s\\n\\n\", print" ++ def ++ "(parse_tree));", - " return 0;", - " }", - " return 1;", - "}", - "" - ] - where - def = head (allEntryPoints cf) - -mkHeaderFile :: CF -> [Cat] -> [Cat] -> [(a, String)] -> String -mkHeaderFile cf cats eps env = unlines - [ - "#ifndef PARSER_HEADER_FILE", - "#define PARSER_HEADER_FILE", - "", - "#include \"Absyn.h\"", - "", - "typedef union", - "{", - " int int_;", - " char char_;", - " double double_;", - " char* string_;", - (concatMap mkVar cats) ++ "} YYSTYPE;", - "", - "#define _ERROR_ 258", - mkDefines (259::Int) env, - "extern YYSTYPE yylval;", - concatMap mkFunc eps, - "", - "#endif" - ] - where - mkVar s | (normCat s == s) = " " ++ (identCat s) +++ (map toLower (identCat s)) ++ "_;\n" - mkVar _ = "" - mkDefines n [] = mkString n - mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) - mkString n = if isUsedCat cf "String" - then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) - else mkChar n - mkChar n = if isUsedCat cf "Char" - then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1) - else mkInteger n - mkInteger n = if isUsedCat cf "Integer" - then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1) - else mkDouble n - mkDouble n = if isUsedCat cf "Double" - then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1) - else mkIdent n - mkIdent n = if isUsedCat cf "Ident" - then ("#define _IDENT_ " ++ show n ++ "\n") - else "" - mkFunc s | (normCat s == s) = (identCat s) ++ " p" ++ (identCat s) ++ "(FILE *inp);\n" - mkFunc _ = "" - diff --git a/formats/cpp/CFtoBison.hs b/formats/cpp/CFtoBison.hs deleted file mode 100644 --- a/formats/cpp/CFtoBison.hs +++ /dev/null @@ -1,352 +0,0 @@ -{- - BNF Converter: Bison generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - BNF Converter: C++ Bison generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the Bison input file. - Note that because of the way bison stores results - the programmer can increase performance by limiting - the number of entry points in their grammar. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 6 August, 2003 - - Modified : 6 August, 2003 - - - ************************************************************** --} - - -module CFtoBison (cf2Bison) where - -import CF -import Data.List (intersperse, isPrefixOf) -import NamedVariables hiding (varName) -import Data.Char (toLower,isUpper) -import Utils ((+++), (++++)) -import TypeChecker -import ErrM - ---This follows the basic structure of CFtoHappy. - --- Type declarations -type Rules = [(NonTerminal,[(Pattern,Action)])] -type NonTerminal = String -type Pattern = String -type Action = String -type MetaVar = String - ---The environment comes from the CFtoFlex -cf2Bison :: String -> CF -> SymEnv -> String -cf2Bison name cf env - = unlines - [header name cf, - union (allCats cf), - "%token _ERROR_", - tokens user env, - declarations cf, - specialToks cf, - "%%", - prRules (rulesForBison name cf env) - ] - where - user = fst (unzip (tokenPragmas cf)) - -header :: String -> CF -> String -header name cf = unlines - ["/* This Bison file was machine-generated by BNFC */", - "%{", - "#include ", - "#include ", - "#include ", - "#include ", - "#include \"Absyn.H\"", - "int yyparse(void);", - "int yylex(void);", - "int yy_mylinenumber;", --- hack to get line number. AR 2006 - "int initialize_lexer(FILE * inp);", - "int yywrap(void)", - "{", - " return 1;", - "}", - "void yyerror(const char *str)", - "{", - " std::cout << \"line \" << yy_mylinenumber + 1 << std::endl ;", - " fprintf(stderr,\"error: %s\\n\",str);", - "}", - "", - definedRules cf, - unlines $ map (parseMethod name) (allCatsIdNorm cf), -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug. - concatMap reverseList (filter isList (allCats cf)), - "%}" - ] - -definedRules :: CF -> String -definedRules cf@((pr,_),_) = - unlines [ rule f xs e | FunDef f xs e <- pr ] - where - ctx = buildContext cf - - list = LC (const "[]") (\t -> "List" ++ unBase t) - where - unBase (ListT t) = unBase t - unBase (BaseT x) = normCat x - - rule f xs e = - case checkDefinition' list ctx f xs e of - Bad err -> error $ "Panic! This should have been caught already:\n" ++ err - Ok (args,(e',t)) -> unlines - [ cppType t ++ " " ++ f ++ "_ (" ++ - concat (intersperse ", " $ map cppArg args) ++ ") {" - , " return " ++ cppExp e' ++ ";" - , "}" - ] - where - - cppType :: Base -> String - cppType (ListT (BaseT x)) = "List" ++ normCat x ++ " *" - cppType (ListT t) = cppType t ++ " *" - cppType (BaseT x) - | isToken x ctx = "String" - | otherwise = normCat x ++ " *" - - cppArg :: (String, Base) -> String - cppArg (x,t) = cppType t ++ " " ++ x ++ "_" - - cppExp :: Exp -> String - cppExp (App "[]" []) = "0" - cppExp (App x []) - | elem x xs = x ++ "_" -- argument - cppExp (App t [e]) - | isToken t ctx = cppExp e - cppExp (App x es) - | isUpper (head x) = call ("new " ++ x) es - | otherwise = call (x ++ "_") es - cppExp (LitInt n) = show n - cppExp (LitDouble x) = show x - cppExp (LitChar c) = show c - cppExp (LitString s) = show s - - call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")" - - ---This generates a parser method for each entry point. -parseMethod :: String -> Cat -> String -parseMethod name cat = - -- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm - -- then "" - -- else - unlines - [ - cat' ++ "*" +++ (resultName cat') +++ "= 0;", - cat' ++"* p" ++ cat' ++ "(FILE *inp)", - "{", - " initialize_lexer(inp);", - " if (yyparse())", - " { /* Failure */", - " return 0;", - " }", - " else", - " { /* Success */", - " return" +++ (resultName cat') ++ ";", - " }", - "}" - ] - where - cat' = identCat (normCat cat) - ---This method generates list reversal functions for each list type. -reverseList :: Cat -> String -reverseList c = unlines - [ - c' ++ "* reverse" ++ c' ++ "(" ++ c' +++ "*l)", - "{", - " " ++ c' +++"*prev = 0;", - " " ++ c' +++"*tmp = 0;", - " while (l)", - " {", - " tmp = l->" ++ v ++ ";", - " l->" ++ v +++ "= prev;", - " prev = l;", - " l = tmp;", - " }", - " return prev;", - "}" - ] - where - c' = identCat (normCat c) - v = (map toLower c') ++ "_" - ---The union declaration is special to Bison/Yacc and gives the type of yylval. ---For efficiency, we may want to only include used categories here. -union :: [Cat] -> String -union cats = unlines - [ - "%union", - "{", - " int int_;", - " char char_;", - " double double_;", - " char* string_;", - concatMap mkPointer cats, - "}" - ] - where --This is a little weird because people can make [Exp2] etc. - mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion. - " " ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n" - mkPointer s | normCat s == s = --normal cat - " " ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n" - mkPointer s = "" - ---declares non-terminal types. -declarations :: CF -> String -declarations cf = concatMap (typeNT cf) (allCats cf) - where --don't define internal rules - typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n" - typeNT cf nt = "" - ---declares terminal types. -tokens :: [UserDef] -> SymEnv -> String -tokens user ts = concatMap (declTok user) ts - where - declTok u (s,r) = if elem s u - then "%token " ++ r ++ " // " ++ s ++ "\n" - else "%token " ++ r ++ " // " ++ s ++ "\n" - -specialToks :: CF -> String -specialToks cf = concat [ - ifC "String" "%token _STRING_\n", - ifC "Char" "%token _CHAR_\n", - ifC "Integer" "%token _INTEGER_\n", - ifC "Double" "%token _DOUBLE_\n", - ifC "Ident" "%token _IDENT_\n" - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - ---The following functions are a (relatively) straightforward translation ---of the ones in CFtoHappy.hs -rulesForBison :: String -> CF -> SymEnv -> Rules -rulesForBison name cf env = map mkOne $ ruleGroups cf where - mkOne (cat,rules) = constructRule cf env rules cat - --- For every non-terminal, we construct a set of rules. -constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) -constructRule cf env rules nt = (nt,[(p,(generateAction (ruleName r) b m) +++ result) | - r0 <- rules, - let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0), - let (p,m) = generatePatterns cf env r]) - where - ruleName r = case funRule r of - "(:)" -> identCat nt - "(:[])" -> identCat nt - z -> z - revs = reversibleCats cf - eps = allEntryPoints cf - isEntry nt = if elem nt eps then True else False - result = if isEntry nt then (resultName (normCat (identCat nt))) ++ "= $$;" else "" - --- Generates a string containing the semantic action. -generateAction :: Fun -> Bool -> [MetaVar] -> Action -generateAction f b ms = - if isCoercion f - then (unwords ms) ++ ";" - else if f == "[]" - then "0;" - else if isDefinedRule f - then concat [ f, "_", "(", concat $ intersperse ", " ms', ");" ] - else concat ["new ", normCat f, "(", (concat (intersperse ", " ms')), ");"] - where - ms' = if b then reverse ms else ms - --- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal -generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar]) -generatePatterns cf env r = case rhsRule r of - [] -> ("/* empty */",[]) - its -> (unwords (map mkIt its), metas its) - where - mkIt i = case i of - Left c -> case lookup c env of - Just x -> x - Nothing -> typeName (identCat c) - Right s -> case lookup s env of - Just x -> x - Nothing -> s - metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its] - revIf c m = if (not (isConsFun (funRule r)) && elem c revs) - then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")") - else m -- no reversal in the left-recursive Cons rule itself - revs = reversibleCats cf - --- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string. - -prRules :: Rules -> String -prRules [] = [] -prRules ((nt, []):rs) = prRules rs --internal rule -prRules ((nt,((p,a):ls)):rs) = - (unwords [nt', ":" , p, "{ $$ =", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs - where - nt' = identCat nt - pr [] = [] - pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ $$ =", a , "}"])]) ++ pr ls - ---Some helper functions. -resultName :: String -> String -resultName s = "YY_RESULT_" ++ s ++ "_" - ---slightly stronger than the NamedVariable version. -varName :: String -> String -varName s = (map toLower (identCat s)) ++ "_" - -typeName :: String -> String -typeName "Ident" = "_IDENT_" -typeName "String" = "_STRING_" -typeName "Char" = "_CHAR_" -typeName "Integer" = "_INTEGER_" -typeName "Double" = "_DOUBLE_" -typeName x = x diff --git a/formats/cpp/CFtoCPPAbs.hs b/formats/cpp/CFtoCPPAbs.hs deleted file mode 100644 --- a/formats/cpp/CFtoCPPAbs.hs +++ /dev/null @@ -1,443 +0,0 @@ -{- - BNF Converter: C++ abstract syntax generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the C++ Abstract Syntax - tree classes. It generates both a Header file - and an Implementation file, and uses the Visitor - design pattern. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 4 August, 2003 - - Modified : 22 May, 2004 / Antti-Juhani Kaijanaho - - - ************************************************************** --} - -module CFtoCPPAbs (cf2CPPAbs) where - -import CF -import Utils((+++),(++++)) -import NamedVariables -import Data.List -import Data.Char(toLower) - - ---The result is two files (.H file, .C file) -cf2CPPAbs :: String -> CF -> (String, String) -cf2CPPAbs name cf = (mkHFile cf, mkCFile cf) - - -{- **** Header (.H) File Functions **** -} - ---Makes the Header file. -mkHFile :: CF -> String -mkHFile cf = unlines - [ - "#ifndef ABSYN_HEADER", - "#define ABSYN_HEADER", - "", - header, - prTypeDefs user, - "/******************** Forward Declarations ********************/\n", - concatMap prForward classes, - "", - prVisitor classes, - prVisitable, - "", - "/******************** Abstract Syntax Classes ********************/\n", - concatMap (prDataH user) (cf2dataLists cf), - "", - "#endif" - ] - where - user = fst (unzip (tokenPragmas cf)) - header = "//C++ Abstract Syntax Interface generated by the BNF Converter.\n" - rules = getRules cf - classes = rules ++ (getClasses (allCats cf)) - prForward s | isProperLabel s = "class " ++ (normCat s) ++ ";\n" - prForward s = "" - getRules cf = (map testRule (rulesOfCF cf)) - getClasses [] = [] - getClasses (c:cs) = - if identCat (normCat c) /= c - then getClasses cs - else if elem c rules - then getClasses cs - else c : (getClasses cs) - - testRule (f, (c, r)) = - if isList c - then if isConsFun f - then identCat c - else "_" --ignore this - else f - ---Prints interface classes for all categories. -prDataH :: [UserDef] -> Data -> String -prDataH user (cat, rules) = - case lookup cat rules of - Just x -> concatMap (prRuleH user cat) rules - Nothing -> if isList cat - then concatMap (prRuleH user cat) rules - else unlines - [ - "class" +++ (identCat cat) +++ ": public Visitable {", - "public:", - " virtual" +++ (identCat cat) +++ "*clone() const = 0;", - "};\n", - concatMap (prRuleH user cat) rules - ] - ---Interface definitions for rules vary on the type of rule. -prRuleH :: [UserDef] -> String -> (Fun, [Cat]) -> String -prRuleH user c (fun, cats) = - if isNilFun fun || isOneFun fun - then "" --these are not represented in the AbSyn - else if isConsFun fun - then --this is the linked list case. - unlines - [ - "class" +++ c' +++ ": public Visitable", - "{", - " public:", - prInstVars user vs, - " " ++ c' ++ "(const" +++ c' +++ "&);", - " " ++ c' ++ " &operator=(const" +++ c' +++ "&);", - " " ++ c' ++ "(" ++ (prConstructorH 1 vs) ++ ");", - " " ++ c' ++ "(" ++ mem +++ memstar ++ "p);", - prDestructorH c', - " " ++ c' ++ "* reverse();", - " " ++ c' ++ "* reverse(" ++ c' ++ " *l);", - " virtual void accept(Visitor *v);", - " virtual " ++ c' ++ " *clone() const;", - " void swap(" ++ c' +++ "&);", - "};" - ] - else --a standard rule - unlines - [ - "class" +++ fun' +++ ": public" +++ super, - "{", - " public:", - prInstVars user vs, - " " ++ fun' ++ "(const" +++ fun' +++ "&);", - " " ++ fun' ++ " &operator=(const" +++ fun' +++ "&);", - " " ++ fun' ++ "(" ++ (prConstructorH 1 vs) ++ ");", - prDestructorH fun', - " virtual void accept(Visitor *v);", - " virtual " +++ fun' +++ " *clone() const;", - " void swap(" ++ fun' +++ "&);", - "};\n" - ] - where - vs = getVars cats - fun' = identCat (normCat fun) - c' = identCat (normCat c); - mem = drop 4 c' - memstar = if isBasic user mem then "" else "*" - super = if c == fun then "Visitable" else (identCat c) - prConstructorH :: Int -> [(String, b)] -> String - prConstructorH _ [] = "" - prConstructorH n ((t,_):[]) = t +++ (optstar t) ++ "p" ++ (show n) - prConstructorH n ((t,_):vs) =( t +++ (optstar t) ++ "p" ++ (show n) ++ ", ") ++ (prConstructorH (n+1) vs) - prDestructorH n = " ~" ++ n ++ "();" - optstar x = if isBasic user x - then "" - else "*" - -prVisitable :: String -prVisitable = unlines - [ - "class Visitable", - "{", - " public:", - -- all classes with virtual methods require a virtual destructor - " virtual ~Visitable() {}", - " virtual void accept(Visitor *v) = 0;", - "};\n" - ] - -prVisitor :: [String] -> String -prVisitor fs = unlines - [ - "/******************** Visitor Interfaces ********************/", - "", - "class Visitor", - "{", - " public:", - " virtual ~Visitor() {}", - (concatMap (prVisitFun) fs), - footer - ] - where - footer = unlines - [ --later only include used categories - " virtual void visitInteger(Integer i) = 0;", - " virtual void visitDouble(Double d) = 0;", - " virtual void visitChar(Char c) = 0;", - " virtual void visitString(String s) = 0;", - "};" - ] - prVisitFun f | isProperLabel f = - " virtual void visit" ++ f' ++ "(" ++ f' ++ " *p) = 0;\n" - where - f' = identCat (normCat f) - prVisitFun _ = "" - ---typedefs in the Header make generation much nicer. -prTypeDefs user = unlines - [ - "/******************** TypeDef Section ********************/", - "typedef int Integer;", - "typedef char Char;", - "typedef double Double;", - "typedef char* String;", - "typedef char* Ident;", - concatMap prUserDef user - ] - where - prUserDef s = "typedef char* " ++ s ++ ";\n" - ---A class's instance variables. -prInstVars :: [UserDef] -> [IVar] -> String -prInstVars _ [] = [] -prInstVars user vars@((t,n):vs) = - " " ++ t +++ uniques ++ ";" ++++ - (prInstVars user vs') - where - (uniques, vs') = prUniques t vars - --these functions group the types together nicely - prUniques :: String -> [IVar] -> (String, [IVar]) - prUniques t vs = (prVars (findIndices (\x -> case x of (y,_) -> y == t) vs) vs, remType t vs) - prVars (x:[]) vs = case vs !! x of - (t,n) -> ((varLinkName t) ++ (showNum n)) - prVars (x:xs) vs = case vs !! x of - (t,n) -> ((varLinkName t) ++ (showNum n)) ++ "," +++ - (prVars xs vs) - varLinkName z = if isBasic user z - then (map toLower z) ++ "_" - else "*" ++ (map toLower z) ++ "_" - remType :: String -> [IVar] -> [IVar] - remType _ [] = [] - remType t ((t2,n):ts) = if t == t2 - then (remType t ts) - else (t2,n) : (remType t ts) - - -{- **** Implementation (.C) File Functions **** -} - ---Makes the .C file -mkCFile :: CF -> String -mkCFile cf = unlines - [ - header, - concatMap (prDataC user) (cf2dataLists cf) - ] - where - user = fst (unzip (tokenPragmas cf)) - header = unlines - [ - "//C++ Abstract Syntax Implementation generated by the BNF Converter.", - "#include ", - "#include \"Absyn.H\"" - ] - ---This is not represented in the implementation. -prDataC :: [UserDef] -> Data -> String -prDataC user (cat, rules) = concatMap (prRuleC user cat) rules - ---Classes for rules vary based on the type of rule. -prRuleC user c (fun, cats) = - if isNilFun fun || isOneFun fun - then "" --these are not represented in the AbSyn - else if isConsFun fun - then --this is the linked list case. - unlines - [ - "/******************** " ++ c' ++ " ********************/", - prConstructorC user c' vs cats, - prCopyC user c' vs, - prDestructorC user c' vs, - prListFuncs user c', - prAcceptC c', - prCloneC user c' vs, - "" - ] - else --a standard rule - unlines - [ - "/******************** " ++ fun' ++ " ********************/", - prConstructorC user fun' vs cats, - prCopyC user fun' vs, - prDestructorC user fun' vs, - prAcceptC fun, - prCloneC user fun' vs, - "" - ] - where - vs = getVars cats - fun' = identCat (normCat fun) - c' = identCat (normCat c) - ---These are all built-in list functions. ---Later we could include things like lookup,insert,delete,etc. -prListFuncs :: [UserDef] -> String -> String -prListFuncs user c = unlines - [ - c ++ "::" ++ c ++ "(" ++ m +++ mstar ++ "p)", - "{", - " " ++ m' ++ " = p;", - " " ++ v ++ "= 0;", - "}", - c ++ "*" +++ c ++ "::" ++ "reverse()", - "{", - " if (" ++ v +++ "== 0) return this;", - " else", - " {", - " " ++ c ++ " *tmp =" +++ v ++ "->reverse(this);", - " " ++ v +++ "= 0;", - " return tmp;", - " }", - "}", - "", - c ++ "*" +++ c ++ "::" ++ "reverse(" ++ c ++ "* prev)", - "{", - " if (" ++ v +++ "== 0)", - " {", - " " ++ v +++ "= prev;", - " return this;", - " }", - " else", - " {", - " " ++ c +++ "*tmp =" +++ v ++ "->reverse(this);", - " " ++ v +++ "= prev;", - " return tmp;", - " }", - "}" - ] - where - v = (map toLower c) ++ "_" - m = drop 4 c - mstar = if isBasic user m then "" else "*" - m' = drop 4 v - ---The standard accept function for the Visitor pattern -prAcceptC :: String -> String -prAcceptC ty = - "\nvoid " ++ ty ++ "::accept(Visitor *v) { v->visit" ++ ty ++ "(this); }" - ---The constructor just assigns the parameters to the corresponding instance variables. -prConstructorC :: [UserDef] -> String -> [IVar] -> [Cat] -> String -prConstructorC user c vs cats = - c ++ "::" ++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" +++ - prAssigns vs params ++ "}" - where - (types, params) = unzip (prParams cats (length cats) ((length cats)+1)) - interleave _ [] = [] - interleave (x:[]) (y:[]) = x +++ (optstar x) ++ y - interleave (x:xs) (y:ys) = x +++ (optstar x) ++ y ++ "," +++ (interleave xs ys) - optstar x = if isBasic user x - then "" - else "*" - ---Print copy constructor and copy assignment -prCopyC :: [UserDef] -> String -> [IVar] -> String -prCopyC user c vs = - c ++ "::" ++ c ++ "(const" +++ c +++ "& other) {" +++ - concatMap doV vs ++++ - "}" ++++ - c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other) {" ++++ - " " ++ c +++ "tmp(other);" ++++ - " swap(tmp);" ++++ - " return *this;" ++++ - "}" ++++ - "void" +++ c ++ "::swap(" ++ c +++ "& other) {" ++++ - concatMap swapV vs ++++ - "}\n" - where doV :: IVar -> String - doV v@(t, _) - | isBasic user t = " " ++ vn v ++ " = other." ++ vn v ++ ";\n" - | otherwise = " " ++ vn v ++ " = other." ++ vn v ++ "->clone();\n" - vn :: IVar -> String - vn (t, 0) = varName t - vn (t, n) = varName t ++ show n - swapV :: IVar -> String - swapV v = " std::swap(" ++ vn v ++ ", other." ++ vn v ++ ");\n" - ---The cloner makes a new deep copy of the object -prCloneC :: [UserDef] -> String -> [IVar] -> String -prCloneC user c vs = - c +++ "*" ++ c ++ "::clone() const {" ++++ - " return new" +++ c ++ "(*this);\n}" - ---The destructor deletes all a class's members. -prDestructorC :: [UserDef] -> String -> [IVar] -> String -prDestructorC user c vs = - c ++ "::~" ++ c ++"()" +++ "{" +++ - (concatMap prDeletes vs) ++ "}" - where - prDeletes :: (String, Int) -> String - prDeletes (t, n) = if isBasic user t - then "" - else if n == 0 - then "delete(" ++ (varName t) ++ "); " - else "delete(" ++ (varName t) ++ (show n) ++ "); " - ---Prints the constructor's parameters. -prParams :: [Cat] -> Int -> Int -> [(String,String)] -prParams [] _ _ = [] -prParams (c:cs) n m = (identCat c,"p" ++ (show (m-n))) - : (prParams cs (n-1) m) - ---Prints the assignments of parameters to instance variables. ---This algorithm peeks ahead in the list so we don't use map or fold -prAssigns :: [IVar] -> [String] -> String -prAssigns [] _ = [] -prAssigns _ [] = [] -prAssigns ((t,n):vs) (p:ps) = - if n == 1 then - case findIndices (\x -> case x of (l,r) -> l == t) vs of - [] -> (varName t) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) - z -> ((varName t) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) - else ((varName t) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) - - -{- **** Helper Functions **** -} - ---Checks if something is a basic or user-defined type. -isBasic :: [UserDef] -> String -> Bool -isBasic user x = - if elem x user - then True - else case x of - "Integer" -> True - "Char" -> True - "String" -> True - "Double" -> True - "Ident" -> True - _ -> False diff --git a/formats/cpp/CFtoCPPPrinter.hs b/formats/cpp/CFtoCPPPrinter.hs deleted file mode 100644 --- a/formats/cpp/CFtoCPPPrinter.hs +++ /dev/null @@ -1,625 +0,0 @@ -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the C++ Pretty Printer. - It also generates the "show" method for - printing an abstract syntax tree. - - The generated files use the Visitor design pattern. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 10 August, 2003 - - Modified : 3 September, 2003 - * Added resizable buffers - - ************************************************************** --} - -module CFtoCPPPrinter (cf2CPPPrinter) where - -import CF -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower, toUpper) - ---Produces (.H file, .C file) -cf2CPPPrinter :: CF -> (String, String) -cf2CPPPrinter cf = (mkHFile cf groups, mkCFile cf groups) - where - groups = (fixCoercions (ruleGroupsInternals cf)) - -{- **** Header (.H) File Methods **** -} - ---An extremely large function to make the Header File -mkHFile :: CF -> [(Cat,[Rule])] -> String -mkHFile cf groups = unlines - [ - printHeader, - concatMap prDataH groups, - classFooter, - showHeader, - concatMap prDataH groups, - classFooter, - footer - ] - where - printHeader = unlines - [ - "#ifndef PRINTER_HEADER", - "#define PRINTER_HEADER", - "", - "#include \"Absyn.H\"", - "#include ", - "#include ", - "#include ", - "", - "/* Certain applications may improve performance by changing the buffer size */", - "#define BUFFER_INITIAL 2000", - "/* You may wish to change _L_PAREN or _R_PAREN */", - "#define _L_PAREN '('", - "#define _R_PAREN ')'", - "", - "class PrintAbsyn : public Visitor", - "{", - " protected:", - " int _n_, _i_;", - " /* The following are simple heuristics for rendering terminals */", - " /* You may wish to change them */", - " void render(Char c);", - " void render(String s);", - " void indent(void);", - " void backup(void);", - " public:", - " PrintAbsyn(void);", - " ~PrintAbsyn(void);", - " char* print(Visitable* v);" - ] - classFooter = unlines - [ - " void visitInteger(Integer i);", - " void visitDouble(Double d);", - " void visitChar(Char c);", - " void visitString(String s);", - " void visitIdent(String s);", - " protected:", - " void inline bufAppend(const char* s)", - " {", - " int len = strlen(s);", - " while (cur_ + len > buf_size)", - " {", - " buf_size *= 2; /* Double the buffer size */", - " resizeBuffer();", - " }", - " for(int n = 0; n < len; n++)", - " {", - " buf_[cur_ + n] = s[n];", - " }", - " cur_ += len;", - " buf_[cur_] = 0;", - " }", - " void inline bufAppend(const char c)", - " {", - " if (cur_ == buf_size)", - " {", - " buf_size *= 2; /* Double the buffer size */", - " resizeBuffer();", - " }", - " buf_[cur_] = c;", - " cur_++;", - " buf_[cur_] = 0;", - " }", - " void inline bufReset(void)", - " {", - " cur_ = 0;", - " buf_size = BUFFER_INITIAL;", - " resizeBuffer();", - " memset(buf_, 0, buf_size);", - " }", - " void inline resizeBuffer(void)", - " {", - " char* temp = (char*) malloc(buf_size);", - " if (!temp)", - " {", - " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");", - " exit(1);", - " }", - " if (buf_)", - " {", - " strcpy(temp, buf_);", - " free(buf_);", - " }", - " buf_ = temp;", - " }", - " char *buf_;", - " int cur_, buf_size;", - "};", - "" - ] - showHeader = unlines - [ - "", - "class ShowAbsyn : public Visitor", - "{", - " public:", - " ShowAbsyn(void);", - " ~ShowAbsyn(void);", - " char* show(Visitable* v);" - ] - footer = unlines - [ - "", - "#endif" - ] - ---Prints all the required method names and their parameters. -prDataH :: (Cat, [Rule]) -> String -prDataH (cat, rules) = - if "List" `isPrefixOf` (identCat cat) - then concat [" void visit", cl, "(", cl, "* p);\n"] - else abstract ++ (concatMap prRuleH rules) - where - cl = identCat (normCat cat) - abstract = case lookup cat rules of - Just x -> "" - Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n" - ---Prints all the methods to visit a rule. -prRuleH :: Rule -> String -prRuleH (fun, (c, cats)) | isProperLabel fun = concat - [" void visit", fun, "(", fun, " *p);\n"] -prRuleH (fun, cats) = "" - -{- **** Implementation (.C) File Methods **** -} - ---This makes the .C file by a similar method. -mkCFile :: CF -> [(Cat,[Rule])] -> String -mkCFile cf groups = concat - [ - header, - prRender, - printEntries, - concatMap (prPrintData user) groups, - printBasics, - showEntries, - concatMap (prShowData user) groups, - showBasics - ] - where - user = fst (unzip (tokenPragmas cf)) - header = unlines - [ - "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/", - "", - "#include \"Printer.H\"", - "" - ] - printEntries = unlines - [ - "PrintAbsyn::PrintAbsyn(void)", - "{", - " _i_ = 0; _n_ = 0;", - " buf_ = 0;", - " bufReset();", - "}", - "", - "PrintAbsyn::~PrintAbsyn(void)", - "{", - "}", - "", - "char* PrintAbsyn::print(Visitable *v)", - "{", - " _i_ = 0; _n_ = 0;", - " bufReset();", - " v->accept(this);", - " return buf_;", - "}" - ] - showEntries = unlines - [ - "ShowAbsyn::ShowAbsyn(void)", - "{", - " buf_ = 0;", - " bufReset();", - "}", - "", - "ShowAbsyn::~ShowAbsyn(void)", - "{", - "}", - "", - "char* ShowAbsyn::show(Visitable *v)", - "{", - " bufReset();", - " v->accept(this);", - " return buf_;", - "}" - ] - printBasics = unlines - [ - "void PrintAbsyn::visitInteger(Integer i)", - "{", - " char tmp[16];", - " sprintf(tmp, \"%d\", i);", - " bufAppend(tmp);", - "}", - "void PrintAbsyn::visitDouble(Double d)", - "{", - " char tmp[16];", - " sprintf(tmp, \"%g\", d);", - " bufAppend(tmp);", - "}", - "void PrintAbsyn::visitChar(Char c)", - "{", - " bufAppend('\\'');", - " bufAppend(c);", - " bufAppend('\\'');", - "}", - "void PrintAbsyn::visitString(String s)", - "{", - " bufAppend('\\\"');", - " bufAppend(s);", - " bufAppend('\\\"');", - "}", - "void PrintAbsyn::visitIdent(String s)", - "{", - " render(s);", - "}", - "" - ] - showBasics = unlines - [ - "void ShowAbsyn::visitInteger(Integer i)", - "{", - " char tmp[16];", - " sprintf(tmp, \"%d\", i);", - " bufAppend(tmp);", - "}", - "void ShowAbsyn::visitDouble(Double d)", - "{", - " char tmp[16];", - " sprintf(tmp, \"%g\", d);", - " bufAppend(tmp);", - "}", - "void ShowAbsyn::visitChar(Char c)", - "{", - " bufAppend('\\'');", - " bufAppend(c);", - " bufAppend('\\'');", - "}", - "void ShowAbsyn::visitString(String s)", - "{", - " bufAppend('\\\"');", - " bufAppend(s);", - " bufAppend('\\\"');", - "}", - "void ShowAbsyn::visitIdent(String s)", - "{", - " bufAppend('\\\"');", - " bufAppend(s);", - " bufAppend('\\\"');", - "}", - "" - ] - -{- **** Pretty Printer Methods **** -} - ---Generates methods for the Pretty Printer -prPrintData :: [UserDef] -> (Cat, [Rule]) -> String -prPrintData user (cat, rules) = - if "List" `isPrefixOf` (identCat cat) - then unlines - [ - "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")", - "{", - " while(" ++ vname ++ "!= 0)", - " {", - " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)", - " {", - visitMember, - optsep, - " " ++ vname +++ "= 0;", - " }", - " else", - " {", - visitMember, - " render(" ++ sep ++ ");", - " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", - " }", - " }", - "}", - "" - ] --Not a list: - else abstract ++ (concatMap (prPrintRule user) rules) - where - cl = identCat (normCat cat) - ecl = identCat (normCatOfList cat) - vname = map toLower cl - member = map toLower ecl ++ "_" - visitMember = if isBasic user member - then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" - else " " ++ vname ++ "->" ++ member ++ "->accept(this);" - sep = if (length sep') == 1 - then "'" ++ (escapeChars sep') ++ "'" - else "\"" ++ (escapeChars sep') ++ "\"" - sep' = getCons rules - optsep = if hasOneFunc rules then "" else (" render(" ++ sep ++ ");") - abstract = case lookup cat rules of - Just x -> "" - Nothing -> "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl ++ "*p) {} //abstract class\n\n" - ---Pretty Printer methods for a rule. -prPrintRule :: [UserDef] -> Rule -> String -prPrintRule user r@(fun, (c, cats)) | isProperLabel fun = unlines - [ - "void PrintAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")", - "{", - " int oldi = _i_;", - lparen, - cats', - rparen, - " _i_ = oldi;", - "}\n" - ] - where - p = precRule r - (lparen, rparen) = - (" if (oldi > " ++ (show p) ++ ") render(_L_PAREN);\n", - " if (oldi > " ++ (show p) ++ ") render(_R_PAREN);\n") - cats' = (concatMap (prPrintCat user fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats))) - fnm = "p" --old names could cause conflicts - getPrec (Right s) = 0 - getPrec (Left c) = precCat c -prPrintRule _ (fun, cats) = "" - ---This goes on to recurse to the instance variables. -prPrintCat :: [UserDef] -> String -> (Either Cat String, Int) -> String -prPrintCat user fnm (c,p) = case c of - (Right t) -> " render(" ++ t' ++ ");\n" - where - t' = if length t == 1 - then "'" ++ (escapeChars t) ++ "'" - else "\"" ++ (escapeChars t) ++ "\"" - (Left nt) -> if isBasic user nt - then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" - else if "list" `isPrefixOf` nt - then " if(" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}" - else " " ++ accept ++ "\n" - where - accept = if nt == "#_" --Internal category - then "/* Internal Category */\n" - else (setI p) ++ fnm ++ "->" ++ nt ++ "->accept(this);" - -{- **** Abstract Syntax Tree Printer **** -} - ---This prints the functions for Abstract Syntax tree printing. -prShowData :: [UserDef] -> (Cat, [Rule]) -> String -prShowData user (cat, rules) = - if "List" `isPrefixOf` (identCat cat) - then unlines - [ - "void ShowAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")", - "{", - " while(" ++ vname ++ "!= 0)", - " {", - " if (" ++ vname ++ "->" ++ vname ++ "_)", - " {", - visitMember, - " bufAppend(\", \");", - " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", - " }", - " else", - " {", - visitMember, - " " ++ vname ++ " = 0;", - " }", - " }", - "}", - "" - ] --Not a list: - else abstract ++ (concatMap (prShowRule user) rules) - where - cl = identCat (normCat cat) - ecl = identCat (normCatOfList cat) - vname = map toLower cl - member = map toLower ecl ++ "_" - visitMember = if isBasic user member - then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" - else " " ++ vname ++ "->" ++ member ++ "->accept(this);" - abstract = case lookup cat rules of - Just x -> "" - Nothing -> "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ "* p) {} //abstract class\n\n" - ---This prints all the methods for Abstract Syntax tree rules. -prShowRule :: [UserDef] -> Rule -> String -prShowRule user (fun, (c, cats)) | isProperLabel fun = concat - [ - "void ShowAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")\n", - "{\n", - lparen, - " bufAppend(\"" ++ fun ++ "\");\n", - optspace, - cats', - rparen, - "}\n" - ] - where - (optspace, lparen, rparen) = if allTerms cats - then ("","","") - else (" bufAppend(' ');\n", " bufAppend('(');\n"," bufAppend(')');\n") - cats' = if allTerms cats - then "" - else concat (insertSpaces (map (prShowCat user fnm) (fixOnes (numVars [] cats)))) - insertSpaces [] = [] - insertSpaces (x:[]) = [x] - insertSpaces (x:xs) = if x == "" - then insertSpaces xs - else (x : [" bufAppend(' ');\n"]) ++ (insertSpaces xs) - allTerms [] = True - allTerms ((Left z):zs) = False - allTerms (z:zs) = allTerms zs - fnm = "p" --other names could cause conflicts -prShowRule _ (fun, cats) = "" - ---This recurses to the instance variables of a class. -prShowCat :: [UserDef] -> String -> Either Cat String -> String -prShowCat user fnm c = - case c of - (Right t) -> "" - (Left nt) -> - if isBasic user nt - then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" - else if nt == "#_" --internal category - then "/* Internal Category */\n" - else if ((normCat nt) /= nt) - then accept - else concat - [ - " bufAppend('[');\n", - " if (" ++ fnm ++ "->" ++ nt ++ ")" ++ accept, - " bufAppend(']');\n" - ] - where - accept = " " ++ fnm ++ "->" ++ nt ++ "->accept(this);\n" - -{- **** Helper Functions Section **** -} - - ---Just checks if something is a basic or user-defined type. ---This is because you don't -> a basic non-pointer type. -isBasic :: [UserDef] -> String -> Bool -isBasic user v = - if elem (init v) user' - then True - else if "integer_" `isPrefixOf` v then True - else if "char_" `isPrefixOf` v then True - else if "string_" `isPrefixOf` v then True - else if "double_" `isPrefixOf` v then True - else if "ident_" `isPrefixOf` v then True - else False - where - user' = map (map toLower) user - ---The visit-function name of a basic type -funName :: String -> String -funName v = - if "integer_" `isPrefixOf` v then "Integer" - else if "char_" `isPrefixOf` v then "Char" - else if "string_" `isPrefixOf` v then "String" - else if "double_" `isPrefixOf` v then "Double" - else if "ident_" `isPrefixOf` v then "Ident" - else "Ident" --User-defined type - ---Just sets the coercion level for parentheses in the Pretty Printer. -setI :: Int -> String -setI n = "_i_ = " ++ (show n) ++ "; " - ---Gets the separator for a list. -getCons :: [Rule] -> String -getCons ((f, (c, cats)):rs) = - if isConsFun f - then seper cats - else getCons rs - where - seper [] = [] - seper ((Right x):xs) = x - seper ((Left x):xs) = seper xs - ---Checks if the list has a non-empty rule. -hasOneFunc :: [Rule] -> Bool -hasOneFunc [] = False -hasOneFunc ((f, (c, cats)):rs) = - if (isOneFun f) - then True - else hasOneFunc rs - ---Helper function that escapes characters in strings -escapeChars :: String -> String -escapeChars [] = [] -escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) -escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) -escapeChars (x:xs) = x : (escapeChars xs) - ---An extremely simple renderer for terminals. -prRender :: String -prRender = unlines - [ - "//You may wish to change render", - "void PrintAbsyn::render(Char c)", - "{", - " if (c == '{')", - " {", - " bufAppend('\\n');", - " indent();", - " bufAppend(c);", - " _n_ = _n_ + 2;", - " bufAppend('\\n');", - " indent();", - " }", - " else if (c == '(' || c == '[')", - " bufAppend(c);", - " else if (c == ')' || c == ']')", - " {", - " backup();", - " bufAppend(c);", - " bufAppend(' ');", - " }", - " else if (c == '}')", - " {", - " _n_ = _n_ - 2;", - " backup();", - " backup();", - " bufAppend(c);", - " bufAppend('\\n\');", - " indent();", - " }", - " else if (c == ',')", - " {", - " backup();", - " bufAppend(c);", - " bufAppend(' ');", - " }", - " else if (c == ';')", - " {", - " backup();", - " bufAppend(c);", - " bufAppend('\\n');", - " indent();", - " }", - " else if (c == 0) return;", - " else", - " {", - " bufAppend(c);", - " bufAppend(' ');", - " }", - "}", - "void PrintAbsyn::render(String s)", - "{", - " if(strlen(s) > 0)", - " {", - " bufAppend(s);", - " bufAppend(' ');", - " }", - "}", - "void PrintAbsyn::indent()", - "{", - " int n = _n_;", - " while (n > 0)", - " {", - " bufAppend(' ');", - " n--;", - " }", - "}", - "void PrintAbsyn::backup()", - "{", - " if (buf_[cur_ - 1] == ' ')", - " {", - " buf_[cur_ - 1] = 0;", - " cur_--;", - " }", - "}" - ] diff --git a/formats/cpp/CFtoCVisitSkel.hs b/formats/cpp/CFtoCVisitSkel.hs deleted file mode 100644 --- a/formats/cpp/CFtoCVisitSkel.hs +++ /dev/null @@ -1,259 +0,0 @@ -{- - BNF Converter: C++ Skeleton generation - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the C++ Skeleton functions. - - The generated files use the Visitor design pattern. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 9 August, 2003 - - Modified : 12 August, 2003 - - - ************************************************************** --} - -module CFtoCVisitSkel (cf2CVisitSkel) where - -import CF -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower, toUpper) - ---Produces (.H file, .C file) -cf2CVisitSkel :: CF -> (String, String) -cf2CVisitSkel cf = (mkHFile cf groups, mkCFile cf groups) - where - groups = (fixCoercions (ruleGroups cf)) - - -{- **** Header (.H) File Functions **** -} - ---Generates the Header File -mkHFile :: CF -> [(Cat,[Rule])] -> String -mkHFile cf groups = unlines - [ - header, - concatMap prDataH groups, - concatMap prUserH user, - footer - ] - where - user = fst (unzip (tokenPragmas cf)) - header = unlines - [ - "#ifndef SKELETON_HEADER", - "#define SKELETON_HEADER", - "/* You might want to change the above name. */", - "", - "#include \"Absyn.H\"", - "", - "class Skeleton : public Visitor", - "{", - " public:" - ] - prUserH u = " void visit" ++ u' ++ "(" ++ u ++ " p);" - where - u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem. - footer = unlines - [ - " void visitIdent(String s);", - " void visitInteger(Integer i);", - " void visitDouble(Double d);", - " void visitChar(Char c);", - " void visitString(String s);", - "};", - "", - "#endif" - ] - ---Prints out visit functions for a category -prDataH :: (Cat, [Rule]) -> String -prDataH (cat, rules) = - if "List" `isPrefixOf` (identCat cat) - then concat [" void visit", cl, "(", cl, "* ", vname, ");"] - else abstract ++ (concatMap prRuleH rules) - where - cl = identCat (normCat cat) - vname = map toLower cl - abstract = case lookup cat rules of - Just x -> "" - Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ "*" +++ vname ++ "); /* abstract class */\n" - ---Visit functions for a rule. -prRuleH :: Rule -> String -prRuleH (fun, (c, cats)) | not (isCoercion fun) = concat - [" void visit", fun, "(", fun, "* ", fnm, ");\n"] - where - fnm = map toLower fun -prRuleH (fun, cats) = "" - - -{- **** Implementation (.C) File Functions **** -} - ---Makes the .C File -mkCFile :: CF -> [(Cat,[Rule])] -> String -mkCFile cf groups = concat - [ - header, - concatMap (prData user) groups, - concatMap prUser user, - footer - ] - where - user = fst (unzip (tokenPragmas cf)) - header = unlines [ - "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/", - "/* This implements the common visitor design pattern.", - " Note that this method uses Visitor-traversal of lists, so", - " List->accept() does NOT traverse the list. This allows different", - " algorithms to use context information differently. */", - "", - "#include \"Skeleton.H\"", - "" - ] - prUser x = unlines - [ - "void Skeleton::visit" ++ x' ++ "(" ++ x ++ " p)", - "{", - " /* Code for " ++ x ++ " Goes Here */", - "}" - ] - where - x' = ((toUpper (head x)) : (map toLower (tail x))) --this is a hack to fix a potential capitalization problem. - footer = unlines - [ - "void Skeleton::visitIdent(Ident i)", - "{", - " /* Code for Ident Goes Here */", - "}", - "void Skeleton::visitInteger(Integer i)", - "{", - " /* Code for Integers Goes Here */", - "}", - "void Skeleton::visitDouble(Double d)", - "{", - " /* Code for Doubles Goes Here */", - "}", - "void Skeleton::visitChar(Char c)", - "{", - " /* Code for Chars Goes Here */", - "}", - "void Skeleton::visitString(String s)", - "{", - " /* Code for Strings Goes Here */", - "}", - "" - ] - ---Visit functions for a category. -prData :: [UserDef] -> (Cat, [Rule]) -> String -prData user (cat, rules) = - if "List" `isPrefixOf` (identCat cat) - then unlines - [ - "void Skeleton::visit" ++ cl ++ "("++ cl ++ "*" +++ vname ++ ")", - "{", - " while(" ++ vname ++ "!= 0)", - " {", - " /* Code For " ++ cl ++ " Goes Here */", - visitMember, - " " ++ vname ++ " = " ++ vname ++ "->" ++ vname ++ "_;", - " }", - "}", - "" - ] --Not a list: - else abstract ++ (concatMap (prRule user) rules) - where - cl = identCat (normCat cat) - vname = map toLower cl - ecl = identCat (normCatOfList cat) - member = map toLower ecl ++ "_" - visitMember = if isBasic user member - then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" - else " " ++ vname ++ "->" ++ member ++ "->accept(this);" - abstract = case lookup cat rules of - Just x -> "" - Nothing -> "void Skeleton::visit" ++ cl ++ "(" ++ cl ++ "*" +++ vname ++ ") {} //abstract class\n\n" - ---Visits all the instance variables of a category. -prRule :: [UserDef] -> Rule -> String -prRule user (fun, (c, cats)) | not (isCoercion fun) = unlines - [ - "void Skeleton::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")", - "{", - " /* Code For " ++ fun ++ " Goes Here */", - "", - cats' ++ "}\n" - ] - where - cats' = if allTerms cats - then "" - else (concatMap (prCat user fnm) (fixOnes (numVars [] cats))) - allTerms [] = True - allTerms ((Left z):zs) = False - allTerms (z:zs) = allTerms zs - fnm = map toLower fun -prRule user (fun, cats) = "" - ---Prints the actual instance-variable visiting. -prCat user fnm c = - case c of - (Right t) -> "" - (Left nt) -> if isBasic user nt - then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" - else if "list" `isPrefixOf` nt - then " if (" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}\n" - else " " ++ accept ++ "\n" - where - accept = fnm ++ "->" ++ nt ++ "->accept(this);" - ---Just checks if something is a basic or user-defined type. ---This is because you don't -> a basic non-pointer type. -isBasic :: [UserDef] -> String -> Bool -isBasic user v = - if elem (init v) user' - then True - else if "integer_" `isPrefixOf` v then True - else if "char_" `isPrefixOf` v then True - else if "string_" `isPrefixOf` v then True - else if "double_" `isPrefixOf` v then True - else if "ident_" `isPrefixOf` v then True - else False - where - user' = map (map toLower) user - ---The visit-function name of a basic type -funName :: String -> String -funName v = - if "integer_" `isPrefixOf` v then "Integer" - else if "char_" `isPrefixOf` v then "Char" - else if "string_" `isPrefixOf` v then "String" - else if "double_" `isPrefixOf` v then "Double" - else if "ident_" `isPrefixOf` v then "Ident" - else (toUpper (head v)) : (init (tail v)) --User-defined type diff --git a/formats/cpp/CFtoFlex.hs b/formats/cpp/CFtoFlex.hs deleted file mode 100644 --- a/formats/cpp/CFtoFlex.hs +++ /dev/null @@ -1,191 +0,0 @@ -{- - BNF Converter: Flex generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the Flex file. It is - similar to JLex but with a few peculiarities. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 5 August, 2003 - - Modified : 22 August, 2006 by Aarne Ranta - - - ************************************************************** --} -module CFtoFlex (cf2flex) where - -import CF -import RegToFlex -import Utils((+++), (++++)) -import NamedVariables -import Data.List -import STLUtils - ---The environment must be returned for the parser to use. -cf2flex :: Maybe String -> String -> CF -> (String, SymEnv) -cf2flex inPackage name cf = (unlines - [ - prelude inPackage name, - cMacros, - lexSymbols env, - restOfFlex inPackage cf env' - ], env') - where - env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) - env' = env ++ (makeSymEnv (fst (unzip (tokenPragmas cf))) (length env)) - makeSymEnv [] _ = [] - makeSymEnv (s:symbs) n = (s, nsDefine inPackage "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) - -prelude :: Maybe String -> String -> String -prelude inPackage name = unlines - [ - maybe "" (\ns -> "%option prefix=\"" ++ ns ++ "yy\"") inPackage, - "/* This FLex file was machine-generated by the BNF converter */", - "%{", - "#include ", - "#include \"Parser.H\"", - "#define YY_BUFFER_LENGTH 4096", - "extern int " ++ nsString inPackage ++ "yy_mylinenumber ;", --- hack to get line number. AR 2006 - "static char YY_PARSED_STRING[YY_BUFFER_LENGTH];", - "static void YY_BUFFER_APPEND(char *s)", - "{", - " strcat(YY_PARSED_STRING, s); //Do something better here!", - "}", - "static void YY_BUFFER_RESET(void)", - "{", - " for(int x = 0; x < YY_BUFFER_LENGTH; x++)", - " YY_PARSED_STRING[x] = 0;", - "}", - "", - "%}" - ] - ---For now all categories are included. ---Optimally only the ones that are used should be generated. -cMacros :: String -cMacros = unlines - [ - "LETTER [a-zA-Z]", - "CAPITAL [A-Z]", - "SMALL [a-z]", - "DIGIT [0-9]", - "IDENT [a-zA-Z0-9'_]", - "%START YYINITIAL COMMENT CHAR CHARESC CHAREND STRING ESCAPED", - "%%" - ] - -lexSymbols :: SymEnv -> String -lexSymbols ss = concatMap transSym ss - where - transSym (s,r) = - "\"" ++ s' ++ "\" \t return " ++ r ++ ";\n" - where - s' = escapeChars s - -restOfFlex :: Maybe String -> CF -> SymEnv -> String -restOfFlex inPackage cf env = concat - [ - lexComments inPackage (comments cf), - userDefTokens, - ifC "String" strStates, - ifC "Char" chStates, - ifC "Double" ("{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t " ++ ns ++ "yylval.double_ = atof(yytext); return " ++ nsDefine inPackage "_DOUBLE_" ++ ";\n"), - ifC "Integer" ("{DIGIT}+ \t " ++ ns ++ "yylval.int_ = atoi(yytext); return " ++ nsDefine inPackage "_INTEGER_" ++ ";\n"), - ifC "Ident" ("{LETTER}{IDENT}* \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ nsDefine inPackage "_IDENT_" ++ ";\n"), - "\\n ++" ++ ns ++ "yy_mylinenumber ;\n", - "[ \\t\\r\\n\\f] \t /* ignore white space. */;\n", - ". \t return " ++ nsDefine inPackage "_ERROR_" ++ ";\n", - "%%\n", - footer - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - ns = nsString inPackage - userDefTokens = unlines $ - ["" ++ printRegFlex exp ++ - " \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ sName name ++ ";" - | (name, exp) <- tokenPragmas cf] - where - sName n = case lookup n env of - Just x -> x - Nothing -> n - strStates = unlines --These handle escaped characters in Strings. - [ - "\"\\\"\" \t BEGIN STRING;", - "\\\\ \t BEGIN ESCAPED;", - "\\\" \t " ++ ns ++ "yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return " ++ nsDefine inPackage "_STRING_" ++ ";", - ". \t YY_BUFFER_APPEND(yytext);", - "n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;", - "\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;", - "\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;", - "t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;", - ". \t YY_BUFFER_APPEND(yytext); BEGIN STRING;" - ] - chStates = unlines --These handle escaped characters in Chars. - [ - "\"'\" \tBEGIN CHAR;", - "\\\\ \t BEGIN CHARESC;", - "[^'] \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";", - "n \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\n'; return " ++ nsDefine inPackage "_CHAR_" ++ ";", - "t \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\t'; return " ++ nsDefine inPackage "_CHAR_" ++ ";", - ". \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";", - "\"'\" \t BEGIN YYINITIAL;" - ] - footer = unlines - [ - "int " ++ ns ++ "initialize_lexer(FILE *inp) { yyin = inp; BEGIN YYINITIAL; }", - "int yywrap(void) { return 1; }" - ] - - -lexComments :: Maybe String -> ([(String, String)], [String]) -> String -lexComments inPackage (m,s) = - (unlines (map (lexSingleComment inPackage) s)) - ++ (unlines (map (lexMultiComment inPackage) m)) - -lexSingleComment :: Maybe String -> String -> String -lexSingleComment inPackage c = - "\"" ++ c ++ "\"[^\\n]*\\n ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC single-line comment */;" - ---There might be a possible bug here if a language includes 2 multi-line comments. ---They could possibly start a comment with one character and end it with another. ---However this seems rare. -lexMultiComment :: Maybe String -> (String, String) -> String -lexMultiComment inPackage (b,e) = unlines [ - "\"" ++ b ++ "\" \t BEGIN COMMENT;", - "\"" ++ e ++ "\" \t BEGIN YYINITIAL;", - ". \t /* BNFC multi-line comment */;", - "[\\n] ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC multi-line comment */;" - ---- "\\n ++yy_mylinenumber ;" - ] - - ---Helper function that escapes characters in strings -escapeChars :: String -> String -escapeChars [] = [] -escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) -escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) -escapeChars (x:xs) = x : (escapeChars xs) diff --git a/formats/cpp/CPPTop.hs b/formats/cpp/CPPTop.hs deleted file mode 100644 --- a/formats/cpp/CPPTop.hs +++ /dev/null @@ -1,209 +0,0 @@ -{- - BNF Converter: C++ Main file - Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CPPTop (makeCPP) where - -import Utils -import CF -import CFtoCPPAbs -import CFtoFlex -import CFtoBison -import CFtoCVisitSkel -import CFtoCPPPrinter -import CFtoLatex -import System.IO -import GetCF -import Data.Char -import System.IO -import System.Exit - -makeCPP :: Bool -> String -> FilePath -> IO () -makeCPP make name file = do - (cf, isOK) <- tryReadCF file - if isOK then do - let (hfile, cfile) = cf2CPPAbs name cf - writeFileRep "Absyn.H" hfile - writeFileRep "Absyn.C" cfile - let (flex, env) = cf2flex Nothing name cf - writeFileRep (name ++ ".l") flex - putStrLn " (Tested with flex 2.5.31)" - let bison = cf2Bison name cf env - writeFileRep (name ++ ".y") bison - putStrLn " (Tested with bison 1.875a)" - let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env - writeFileRep "Parser.H" header - let (skelH, skelC) = cf2CVisitSkel cf - writeFileRep "Skeleton.H" skelH - writeFileRep "Skeleton.C" skelC - let (prinH, prinC) = cf2CPPPrinter cf - writeFileRep "Printer.H" prinH - writeFileRep "Printer.C" prinC - writeFileRep "Test.C" (cpptest cf) - let latex = cfToLatex name cf - writeFileRep (name ++ ".tex") latex - if make then (writeFileRep "Makefile" $ makefile name) else return () - putStrLn "Done!" - else do putStrLn $ "Failed" - exitFailure - -makefile :: String -> String -makefile name = unlines - [ - "CC = g++", - "CCFLAGS = -g", - "FLEX = flex", - "BISON = bison", - "LATEX = latex", - "DVIPS = dvips", - "", - "all: test" ++ name ++ " " ++ name ++ ".ps", - "", - "clean:", - -- peteg: don't nuke what we generated - move that to the "vclean" target. - "\trm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps test" ++ name, - "", - "distclean:", - "\t rm -f *.o Absyn.C Absyn.H Test.C Parser.C Parser.H Lexer.C Skeleton.C Skeleton.H Printer.C Printer.H " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps test" ++ name ++ " Makefile", - "", - "test" ++ name ++ ": Absyn.o Lexer.o Parser.o Printer.o Test.o", - "\t@echo \"Linking test" ++ name ++ "...\"", - "\t${CC} ${CCFLAGS} *.o -o test" ++ name ++ "", - " ", - "Absyn.o: Absyn.C Absyn.H", - "\t${CC} ${CCFLAGS} -c Absyn.C", - "", - "Lexer.C: " ++ name ++ ".l", - "\t${FLEX} -oLexer.C " ++ name ++ ".l", - "", - "Parser.C: " ++ name ++ ".y", - "\t${BISON} " ++ name ++ ".y -o Parser.C", - "", - "Lexer.o: Lexer.C Parser.H", - "\t${CC} ${CCFLAGS} -c Lexer.C ", - "", - "Parser.o: Parser.C Absyn.H", - "\t${CC} ${CCFLAGS} -c Parser.C", - "", - "Printer.o: Printer.C Printer.H Absyn.H", - "\t${CC} ${CCFLAGS} -c Printer.C", - "", - "Test.o: Test.C Parser.H Printer.H Absyn.H", - "\t${CC} ${CCFLAGS} -c Test.C", - "", - "" ++ name ++ ".dvi: " ++ name ++ ".tex", - "\t${LATEX} " ++ name ++ ".tex", - "", - "" ++ name ++ ".ps: " ++ name ++ ".dvi", - "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps", - "" - ] - -cpptest :: CF -> String -cpptest cf = - unlines - [ - "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", - "/* */", - "/* This test will parse a file, print the abstract syntax tree, and then */", - "/* pretty-print the result. */", - "/* */", - "/****************************************************************************/", - "#include ", - "#include \"Parser.H\"", - "#include \"Printer.H\"", - "#include \"Absyn.H\"", - "", - "int main(int argc, char ** argv)", - "{", - " FILE *input;", - " if (argc > 1) ", - " {", - " input = fopen(argv[1], \"r\");", - " if (!input)", - " {", - " fprintf(stderr, \"Error opening input file.\\n\");", - " exit(1);", - " }", - " }", - " else input = stdin;", - " /* The default entry point is used. For other options see Parser.H */", - " " ++ def ++ " *parse_tree = p" ++ def ++ "(input);", - " if (parse_tree)", - " {", - " printf(\"\\nParse Succesful!\\n\");", - " printf(\"\\n[Abstract Syntax]\\n\");", - " ShowAbsyn *s = new ShowAbsyn();", - " printf(\"%s\\n\\n\", s->show(parse_tree));", - " printf(\"[Linearized Tree]\\n\");", - " PrintAbsyn *p = new PrintAbsyn();", - " printf(\"%s\\n\\n\", p->print(parse_tree));", - " return 0;", - " }", - " return 1;", - "}", - "" - ] - where - def = head (allEntryPoints cf) - -mkHeaderFile cf cats eps env = unlines - [ - "#ifndef PARSER_HEADER_FILE", - "#define PARSER_HEADER_FILE", - "", - concatMap mkForwardDec cats, - "typedef union", - "{", - " int int_;", - " char char_;", - " double double_;", - " char* string_;", - (concatMap mkVar cats) ++ "} YYSTYPE;", - "", - "#define _ERROR_ 258", - mkDefines (259 :: Int) env, - "extern YYSTYPE yylval;", - concatMap mkFunc eps, - "", - "#endif" - ] - where - mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n" - mkForwardDec _ = "" - mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n" - mkVar _ = "" - mkDefines n [] = mkString n - mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) - mkString n = if isUsedCat cf "String" - then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) - else mkChar n - mkChar n = if isUsedCat cf "Char" - then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1) - else mkInteger n - mkInteger n = if isUsedCat cf "Integer" - then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1) - else mkDouble n - mkDouble n = if isUsedCat cf "Double" - then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1) - else mkIdent n - mkIdent n = if isUsedCat cf "Ident" - then ("#define _IDENT_ " ++ show n ++ "\n") - else "" - mkFunc s | (normCat s == s) = (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(FILE *inp);\n" - mkFunc _ = "" diff --git a/formats/cpp/CPPTop.hs~ b/formats/cpp/CPPTop.hs~ deleted file mode 100644 --- a/formats/cpp/CPPTop.hs~ +++ /dev/null @@ -1,208 +0,0 @@ -{- - BNF Converter: C++ Main file - Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CPPTop (makeCPP) where - -import Utils -import CF -import CFtoCPPAbs -import CFtoFlex -import CFtoBison -import CFtoCVisitSkel -import CFtoCPPPrinter -import CFtoLatex -import System.IO -import GetCF -import Data.Char -import System.IO - -makeCPP :: Bool -> String -> FilePath -> IO () -makeCPP make name file = do - (cf, isOK) <- tryReadCF file - if isOK then do - let (hfile, cfile) = cf2CPPAbs name cf - writeFileRep "Absyn.H" hfile - writeFileRep "Absyn.C" cfile - let (flex, env) = cf2flex Nothing name cf - writeFileRep (name ++ ".l") flex - putStrLn " (Tested with flex 2.5.31)" - let bison = cf2Bison name cf env - writeFileRep (name ++ ".y") bison - putStrLn " (Tested with bison 1.875a)" - let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env - writeFileRep "Parser.H" header - let (skelH, skelC) = cf2CVisitSkel cf - writeFileRep "Skeleton.H" skelH - writeFileRep "Skeleton.C" skelC - let (prinH, prinC) = cf2CPPPrinter cf - writeFileRep "Printer.H" prinH - writeFileRep "Printer.C" prinC - writeFileRep "Test.C" (cpptest cf) - let latex = cfToLatex name cf - writeFileRep (name ++ ".tex") latex - if make then (writeFileRep "Makefile" $ makefile name) else return () - putStrLn "Done!" - else do putStrLn $ "Failed" - exitFailure - -makefile :: String -> String -makefile name = unlines - [ - "CC = g++", - "CCFLAGS = -g", - "FLEX = flex", - "BISON = bison", - "LATEX = latex", - "DVIPS = dvips", - "", - "all: test" ++ name ++ " " ++ name ++ ".ps", - "", - "clean:", - -- peteg: don't nuke what we generated - move that to the "vclean" target. - "\trm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps test" ++ name, - "", - "distclean:", - "\t rm -f *.o Absyn.C Absyn.H Test.C Parser.C Parser.H Lexer.C Skeleton.C Skeleton.H Printer.C Printer.H " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps test" ++ name ++ " Makefile", - "", - "test" ++ name ++ ": Absyn.o Lexer.o Parser.o Printer.o Test.o", - "\t@echo \"Linking test" ++ name ++ "...\"", - "\t${CC} ${CCFLAGS} *.o -o test" ++ name ++ "", - " ", - "Absyn.o: Absyn.C Absyn.H", - "\t${CC} ${CCFLAGS} -c Absyn.C", - "", - "Lexer.C: " ++ name ++ ".l", - "\t${FLEX} -oLexer.C " ++ name ++ ".l", - "", - "Parser.C: " ++ name ++ ".y", - "\t${BISON} " ++ name ++ ".y -o Parser.C", - "", - "Lexer.o: Lexer.C Parser.H", - "\t${CC} ${CCFLAGS} -c Lexer.C ", - "", - "Parser.o: Parser.C Absyn.H", - "\t${CC} ${CCFLAGS} -c Parser.C", - "", - "Printer.o: Printer.C Printer.H Absyn.H", - "\t${CC} ${CCFLAGS} -c Printer.C", - "", - "Test.o: Test.C Parser.H Printer.H Absyn.H", - "\t${CC} ${CCFLAGS} -c Test.C", - "", - "" ++ name ++ ".dvi: " ++ name ++ ".tex", - "\t${LATEX} " ++ name ++ ".tex", - "", - "" ++ name ++ ".ps: " ++ name ++ ".dvi", - "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps", - "" - ] - -cpptest :: CF -> String -cpptest cf = - unlines - [ - "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", - "/* */", - "/* This test will parse a file, print the abstract syntax tree, and then */", - "/* pretty-print the result. */", - "/* */", - "/****************************************************************************/", - "#include ", - "#include \"Parser.H\"", - "#include \"Printer.H\"", - "#include \"Absyn.H\"", - "", - "int main(int argc, char ** argv)", - "{", - " FILE *input;", - " if (argc > 1) ", - " {", - " input = fopen(argv[1], \"r\");", - " if (!input)", - " {", - " fprintf(stderr, \"Error opening input file.\\n\");", - " exit(1);", - " }", - " }", - " else input = stdin;", - " /* The default entry point is used. For other options see Parser.H */", - " " ++ def ++ " *parse_tree = p" ++ def ++ "(input);", - " if (parse_tree)", - " {", - " printf(\"\\nParse Succesful!\\n\");", - " printf(\"\\n[Abstract Syntax]\\n\");", - " ShowAbsyn *s = new ShowAbsyn();", - " printf(\"%s\\n\\n\", s->show(parse_tree));", - " printf(\"[Linearized Tree]\\n\");", - " PrintAbsyn *p = new PrintAbsyn();", - " printf(\"%s\\n\\n\", p->print(parse_tree));", - " return 0;", - " }", - " return 1;", - "}", - "" - ] - where - def = head (allEntryPoints cf) - -mkHeaderFile cf cats eps env = unlines - [ - "#ifndef PARSER_HEADER_FILE", - "#define PARSER_HEADER_FILE", - "", - concatMap mkForwardDec cats, - "typedef union", - "{", - " int int_;", - " char char_;", - " double double_;", - " char* string_;", - (concatMap mkVar cats) ++ "} YYSTYPE;", - "", - "#define _ERROR_ 258", - mkDefines (259 :: Int) env, - "extern YYSTYPE yylval;", - concatMap mkFunc eps, - "", - "#endif" - ] - where - mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n" - mkForwardDec _ = "" - mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n" - mkVar _ = "" - mkDefines n [] = mkString n - mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) - mkString n = if isUsedCat cf "String" - then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) - else mkChar n - mkChar n = if isUsedCat cf "Char" - then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1) - else mkInteger n - mkInteger n = if isUsedCat cf "Integer" - then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1) - else mkDouble n - mkDouble n = if isUsedCat cf "Double" - then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1) - else mkIdent n - mkIdent n = if isUsedCat cf "Ident" - then ("#define _IDENT_ " ++ show n ++ "\n") - else "" - mkFunc s | (normCat s == s) = (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(FILE *inp);\n" - mkFunc _ = "" diff --git a/formats/cpp/RegToFlex.hs b/formats/cpp/RegToFlex.hs deleted file mode 100644 --- a/formats/cpp/RegToFlex.hs +++ /dev/null @@ -1,73 +0,0 @@ -module RegToFlex (printRegFlex) where - --- modified from pretty-printer generated by the BNF converter - -import AbsBNF -import Data.Char - --- the top-level printing method -printRegFlex :: Reg -> String -printRegFlex = render . prt 0 - --- you may want to change render and parenth - -render :: [String] -> String -render = rend (0::Int) where - rend i ss = case ss of - "[" :ts -> cons "[" $ rend i ts - "(" :ts -> cons "(" $ rend i ts - t : "," :ts -> cons t $ space "," $ rend i ts - t : ")" :ts -> cons t $ cons ")" $ rend i ts - t : "]" :ts -> cons t $ cons "]" $ rend i ts - t :ts -> space t $ rend i ts - _ -> "" - cons s t = s ++ t - new i s = s - space t s = if null s then t else t ++ s - -parenth :: [String] -> [String] -parenth ss = ["("] ++ ss ++ [")"] - --- the printer class does the job -class Print a where - prt :: Int -> a -> [String] - prtList :: [a] -> [String] - prtList = concat . map (prt 0) - -instance Print a => Print [a] where - prt _ = prtList - -instance Print Char where - prt _ c = [[c]] - prtList s = map (concat . prt 0) s - -prPrec :: Int -> Int -> [String] -> [String] -prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) - RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) - RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) - RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) - RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) - ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) - REps -> prPrec i 3 (["[^.]"]) - RChar c -> prPrec i 3 (prt 0 [mkEsc [c]]) - RAlts str -> prPrec i 3 (concat [["["], prt 0 $ mkEsc str, ["]"]]) - RSeqs str -> prPrec i 2 (concat (map (prt 0) $ mkEsc str)) - RDigit -> prPrec i 3 (concat [["{DIGIT}"]]) - RLetter -> prPrec i 3 (concat [["{LETTER}"]]) - RUpper -> prPrec i 3 (concat [["{CAPITAL}"]]) - RLower -> prPrec i 3 (concat [["{SMALL}"]]) - RAny -> prPrec i 3 (concat [["."]]) - --- Handle special characters in regular expressions. -mkEsc :: String -> String -mkEsc = concatMap escChar - where escChar c - | c `elem` "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" = '\\':[c] - | otherwise = [c] diff --git a/formats/cpp_stl/CFtoBisonSTL.hs b/formats/cpp_stl/CFtoBisonSTL.hs deleted file mode 100644 --- a/formats/cpp_stl/CFtoBisonSTL.hs +++ /dev/null @@ -1,373 +0,0 @@ -{- - BNF Converter: C++ Bison generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the Bison input file using - STL. The main difference to CFtoBison is in handling - lists: by using std::vector and push_back, our rules - for reverting lists are the opposite to linked lists. - Note that because of the way bison stores results - the programmer can increase performance by limiting - the number of entry points in their grammar. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 6 August, 2003 - - Modified : 19 August, 2006, by Aarne Ranta (aarne@cs.chalmers.se) - - - ************************************************************** --} - - -module CFtoBisonSTL (cf2Bison) where - -import CF -import Data.List (intersperse, isPrefixOf) -import NamedVariables hiding (varName) -import Data.Char (toLower,isUpper,isDigit) -import Utils ((+++), (++++)) -import TypeChecker -import ErrM -import STLUtils - ---This follows the basic structure of CFtoHappy. - --- Type declarations -type Rules = [(NonTerminal,[(Pattern,Action)])] -type NonTerminal = String -type Pattern = String -type Action = String -type MetaVar = String - ---The environment comes from the CFtoFlex -cf2Bison :: Bool -> Maybe String -> String -> CF -> SymEnv -> String -cf2Bison ln inPackage name cf env - = unlines - [header inPackage name cf, - union inPackage (positionCats cf ++ allCats cf), - maybe "" (\ns -> "%name-prefix=\"" ++ ns ++ "yy\"") inPackage, - "%token _ERROR_", - tokens user env, - declarations cf, - specialToks cf, - "%%", - prRules (rulesForBison ln inPackage name cf env) - ] - where - user = fst (unzip (tokenPragmas cf)) - - -positionCats cf = filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf)) - -header :: Maybe String -> String -> CF -> String -header inPackage name cf = unlines - ["/* This Bison file was machine-generated by BNFC */", - "%{", - "#include ", - "#include ", - "#include ", - "#include ", - "#include \"Absyn.H\"", - "typedef struct yy_buffer_state *YY_BUFFER_STATE;", - "int yyparse(void);", - "int yylex(void);", - "YY_BUFFER_STATE " ++ ns ++ "yy_scan_string(const char *str);", - "void " ++ ns ++ "yy_delete_buffer(YY_BUFFER_STATE buf);", - "int " ++ ns ++ "yy_mylinenumber;", --- hack to get line number. AR 2006 - "int " ++ ns ++ "initialize_lexer(FILE * inp);", - "int " ++ ns ++ "yywrap(void)", - "{", - " return 1;", - "}", - "void " ++ ns ++ "yyerror(const char *str)", - "{", - " std::cout << \"line \" << " ++ ns ++ "yy_mylinenumber << std::endl ;", - " fprintf(stderr,\"error: %s\\n\",str);", - "}", - "", - definedRules cf, - nsStart inPackage, - unlines $ map (parseMethod inPackage name) (allCatsIdNorm cf ++ positionCats cf), -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug. - nsEnd inPackage, - "%}" - ] - where - ns = nsString inPackage - -definedRules :: CF -> String -definedRules cf@((pr,_),_) = - unlines [ rule f xs e | FunDef f xs e <- pr ] - where - ctx = buildContext cf - - list = LC (const "[]") (\t -> "List" ++ unBase t) - where - unBase (ListT t) = unBase t - unBase (BaseT x) = normCat x - - rule f xs e = - case checkDefinition' list ctx f xs e of - Bad err -> error $ "Panic! This should have been caught already:\n" ++ err - Ok (args,(e',t)) -> unlines - [ cppType t ++ " " ++ f ++ "_ (" ++ - concat (intersperse ", " $ map cppArg args) ++ ") {" - , " return " ++ cppExp e' ++ ";" - , "}" - ] - where - - cppType :: Base -> String - cppType (ListT (BaseT x)) = "List" ++ normCat x ++ " *" - cppType (ListT t) = cppType t ++ " *" - cppType (BaseT x) - | isToken x ctx = "String" - | otherwise = normCat x ++ " *" - - cppArg :: (String, Base) -> String - cppArg (x,t) = cppType t ++ " " ++ x ++ "_" - - cppExp :: Exp -> String - cppExp (App "[]" []) = "0" - cppExp (App x []) - | elem x xs = x ++ "_" -- argument - cppExp (App t [e]) - | isToken t ctx = cppExp e - cppExp (App x es) - | isUpper (head x) = call ("new " ++ x) es - | otherwise = call (x ++ "_") es - cppExp (LitInt n) = show n - cppExp (LitDouble x) = show x - cppExp (LitChar c) = show c - cppExp (LitString s) = show s - - call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")" - - ---This generates a parser method for each entry point. -parseMethod :: Maybe String -> String -> Cat -> String -parseMethod inPackage name cat = - -- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm - -- then "" - -- else - unlines - [ - "static " ++ cat' ++ "*" +++ (resultName cat') +++ "= 0;", - cat' ++"* p" ++ cat' ++ "(FILE *inp)", - "{", - " " ++ ns ++ "yy_mylinenumber = 1;", -- O.F. - " " ++ ns ++ "initialize_lexer(inp);", - " if (yyparse())", - " { /* Failure */", - " return 0;", - " }", - " else", - " { /* Success */", - " return" +++ (resultName cat') ++ ";", - " }", - "}", - cat' ++"* p" ++ cat' ++ "(const char *str)", - "{", - " YY_BUFFER_STATE buf;", - " int result;", - " " ++ ns ++ "yy_mylinenumber = 1;", - " " ++ ns ++ "initialize_lexer(0);", - " buf = " ++ ns ++ "yy_scan_string(str);", - " result = yyparse();", - " " ++ ns ++ "yy_delete_buffer(buf);", - " if (result)", - " { /* Failure */", - " return 0;", - " }", - " else", - " { /* Success */", - " return" +++ (resultName cat') ++ ";", - " }", - "}" - ] - where - cat' = identCat (normCat cat) - ns = nsString inPackage - - ---The union declaration is special to Bison/Yacc and gives the type of yylval. ---For efficiency, we may want to only include used categories here. -union :: Maybe String -> [Cat] -> String -union inPackage cats = unlines - [ - "%union", - "{", - " int int_;", - " char char_;", - " double double_;", - " char* string_;", - concatMap mkPointer cats, - "}" - ] - where --This is a little weird because people can make [Exp2] etc. - mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion. - " " ++ scope ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n" - mkPointer s | normCat s == s = --normal cat - " " ++ scope ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n" - mkPointer s = "" - scope = nsScope inPackage - ---declares non-terminal types. -declarations :: CF -> String -declarations cf = concatMap (typeNT cf) (positionCats cf ++ allCats cf) - where --don't define internal rules - typeNT cf nt | (isPositionCat cf nt || rulesForCat cf nt /= []) = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n" - typeNT cf nt = "" - ---declares terminal types. -tokens :: [UserDef] -> SymEnv -> String -tokens user ts = concatMap (declTok user) ts - where - declTok u (s,r) = if elem s u - then "%token " ++ r ++ " // " ++ s ++ "\n" - else "%token " ++ r ++ " // " ++ s ++ "\n" - -specialToks :: CF -> String -specialToks cf = concat [ - ifC "String" "%token _STRING_\n", - ifC "Char" "%token _CHAR_\n", - ifC "Integer" "%token _INTEGER_\n", - ifC "Double" "%token _DOUBLE_\n", - ifC "Ident" "%token _IDENT_\n" - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - ---The following functions are a (relatively) straightforward translation ---of the ones in CFtoHappy.hs -rulesForBison :: Bool -> Maybe String -> String -> CF -> SymEnv -> Rules -rulesForBison ln inPackage name cf env = (map mkOne $ ruleGroups cf) ++ posRules where - mkOne (cat,rules) = constructRule ln inPackage cf env rules cat - posRules = map mkPos $ positionCats cf - mkPos cat = (cat, [(maybe cat id (lookup cat env), - "$$ = new " ++ cat ++ "($1," ++ nsString inPackage ++ "yy_mylinenumber) ; YY_RESULT_" ++ - cat ++ "_= $$ ;")]) - --- For every non-terminal, we construct a set of rules. -constructRule :: - Bool -> Maybe String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) -constructRule ln inPackage cf env rules nt = - (nt,[(p,(generateAction ln inPackage nt (ruleName r) b m) +++ result) | - r0 <- rules, - let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0), - let (p,m) = generatePatterns cf env r b]) - where - ruleName r = case funRule r of - ---- "(:)" -> identCat nt - ---- "(:[])" -> identCat nt - z -> z - revs = reversibleCats cf - eps = allEntryPoints cf - isEntry nt = if elem nt eps then True else False - result = if isEntry nt then (nsScope inPackage ++ resultName (normCat (identCat nt))) ++ "= $$;" else "" - --- Generates a string containing the semantic action. -generateAction :: Bool -> Maybe String -> NonTerminal -> Fun -> Bool -> [(MetaVar,Bool)] -> Action -generateAction ln inPackage cat f b mbs = - reverses ++ - if isCoercion f - then "$$ = " ++ (unwords ms) ++ ";" - else if (f == "[]") - then concat ["$$ = ","new ", scope, identCatV cat, "();"] - else if (f == "(:[])") - then concat ["$$ = ","new ", scope, identCatV cat, "() ; $$->push_back($1);"] - else if (f == "(:)" && b) - then "$1->push_back("++ lastms ++ ") ; $$ = $1 ;" - else if (f == "(:)") - then lastms ++ "->push_back($1) ; $$ = " ++ lastms ++ " ;" ---- not left rec - else if isDefinedRule f - then concat ["$$ = ", scope, f, "_", "(", concat $ intersperse ", " ms', ");" ] - else concat - ["$$ = ", "new ", scope, f, "(", (concat (intersperse ", " ms')), ");" ++ addLn ln] - where - ms = map fst mbs - ms' = ms - addLn ln = if ln then " $$->line_number = " ++ nsString inPackage ++ "yy_mylinenumber;" else "" -- O.F. - lastms = last ms - identCatV cat = reverse $ dropWhile isDigit $ reverse $ identCat cat - reverses = unwords [ - "std::reverse(" ++ m ++"->begin(),"++m++"->end()) ;" | - (m,True) <- mbs] - scope = nsScope inPackage - --- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal -generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)]) -generatePatterns cf env r revv = case rhsRule r of - [] -> ("/* empty */",[]) - its -> (unwords (map mkIt its), metas its) - where - mkIt i = case i of - Left c -> case lookup c env of - Just x | not (isPositionCat cf c) -> x - _ -> typeName (identCat c) - Right s -> case lookup s env of - Just x -> x - Nothing -> s - metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its] - - -- notice: reversibility with push_back vectors is the opposite - -- of right-recursive lists! - revert c = (head c == '[') && - not (isConsFun (funRule r)) && notElem c revs - revs = reversibleCats cf - --- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string. - -prRules :: Rules -> String -prRules [] = [] -prRules ((nt, []):rs) = prRules rs --internal rule -prRules ((nt,((p,a):ls)):rs) = - (unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs - where - nt' = identCat nt - pr [] = [] - pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ ", a , "}"])]) ++ pr ls - ---Some helper functions. -resultName :: String -> String -resultName s = "YY_RESULT_" ++ s ++ "_" - ---slightly stronger than the NamedVariable version. -varName :: String -> String -varName s = (map toLower (identCat s)) ++ "_" - -typeName :: String -> String -typeName "Ident" = "_IDENT_" -typeName "String" = "_STRING_" -typeName "Char" = "_CHAR_" -typeName "Integer" = "_INTEGER_" -typeName "Double" = "_DOUBLE_" -typeName x = x - - diff --git a/formats/cpp_stl/CFtoCVisitSkelSTL.hs b/formats/cpp_stl/CFtoCVisitSkelSTL.hs deleted file mode 100644 --- a/formats/cpp_stl/CFtoCVisitSkelSTL.hs +++ /dev/null @@ -1,148 +0,0 @@ -{- - BNF Converter: C++ Skeleton generation - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the C++ Skeleton functions. - - The generated files use the Visitor design pattern. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 9 August, 2003 - - Modified : 29 August, 2006 Aarne Ranta - - - ************************************************************** --} - -module CFtoCVisitSkelSTL (cf2CVisitSkel) where - -import CF -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower, toUpper) -import OOAbstract -import STLUtils - ---Produces (.H file, .C file) -cf2CVisitSkel :: Maybe String -> CF -> (String, String) -cf2CVisitSkel inPackage cf = (mkHFile inPackage cab, mkCFile inPackage cab) - where - cab = cf2cabs cf - --- **** Header (.H) File Functions **** - ---Generates the Header File -mkHFile :: Maybe String -> CAbs -> String -mkHFile inPackage cf = unlines [ - "#ifndef " ++ hdef, - "#define " ++ hdef, - "/* You might want to change the above name. */", - "", - "#include \"Absyn.H\"", - "", - nsStart inPackage, - "class Skeleton : public Visitor", - "{", - "public:", - unlines [" void visit" ++ b ++ "(" ++ b ++ "* p);" | - b <- classes, notElem b (defineds cf)], - unlines [" void visit" ++ b ++ "(" ++ b ++ " x);" | b <- basics], - "};", - nsEnd inPackage, - "", - "#endif" - ] - where - hdef = nsDefine inPackage "SKELETON_HEADER" - classes = allClasses cf - basics = tokentypes cf ++ map fst basetypes - - --- **** Implementation (.C) File Functions **** - ---Makes the .C File -mkCFile :: Maybe String -> CAbs -> String -mkCFile inPackage cf = unlines [ - headerC, - nsStart inPackage, - unlines [ - "void Skeleton::visit" ++ t ++ "(" ++ - t ++ "* t) {} //abstract class" | t <- absclasses cf], - unlines [prCon r | (_,rs) <- signatures cf, r <- rs], - unlines [prList cb | cb <- listtypes cf], - unlines [prBasic b | b <- tokentypes cf ++ map fst basetypes], - nsEnd inPackage - ] - -headerC = unlines [ - "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/", - "/* This implements the common visitor design pattern.", - " Note that this method uses Visitor-traversal of lists, so", - " List->accept() does NOT traverse the list. This allows different", - " algorithms to use context information differently. */", - "", - "#include \"Skeleton.H\"", - "" - ] - -prBasic c = unlines [ - "void Skeleton::visit" ++ c ++ "(" ++ c ++ " x)", - "{", - " /* Code for " ++ c ++ " Goes Here */", - "}" - ] - -prList (cl,b) = unlines [ - "void Skeleton::visit" ++ cl ++ "("++ cl ++ "*" +++ vname ++ ")", - "{", - " for ("++ cl ++"::iterator i = " ++ - vname++"->begin() ; i != " ++vname ++"->end() ; ++i)", - " {", - if b - then " (*i)->accept(this);" - else " visit" ++ drop 4 cl ++ "(*i) ;", - " }", - "}" - ] - where - vname = map toLower cl - -prCon fcs@(f,cs) = unlines [ - "void Skeleton::visit" ++ f ++ "(" ++ f ++ " *" ++ v ++ ")", - "{", - " /* Code For " ++ f ++ " Goes Here */", - "", - unlines [" " ++ visitArg c | c <- cs], - "}" - ] - where - v = map toLower f - visitArg (cat,isPt,var) = - if isPt - then (v ++ "->" ++ var ++ "->accept(this);") - else ("visit" ++ cat ++ "(" ++ v ++ "->" ++ var ++ ");") - diff --git a/formats/cpp_stl/CFtoSTLAbs.hs b/formats/cpp_stl/CFtoSTLAbs.hs deleted file mode 100644 --- a/formats/cpp_stl/CFtoSTLAbs.hs +++ /dev/null @@ -1,275 +0,0 @@ -{- - BNF Converter: C++ abstract syntax generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the C++ Abstract Syntax - tree classes. It generates both a Header file - and an Implementation file, and uses the Visitor - design pattern. It uses STL (Standard Template Library). - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 4 August, 2003 - - Modified : 22 May, 2004 / Antti-Juhani Kaijanaho - 29 August, 2006 / Aarne Ranta - - ************************************************************** --} - -module CFtoSTLAbs (cf2CPPAbs) where - -import OOAbstract -import CF -import Utils((+++),(++++)) -import NamedVariables -import Data.List -import Data.Char(toLower) -import STLUtils - ---The result is two files (.H file, .C file) - -cf2CPPAbs :: Bool -> Maybe String -> String -> CF -> (String, String) -cf2CPPAbs ln inPackage name cf = (mkHFile ln inPackage cab, mkCFile inPackage cab) - where - cab = cf2cabs cf - - --- **** Header (.H) File Functions **** -- - ---Makes the Header file. -mkHFile :: Bool -> Maybe String -> CAbs -> String -mkHFile ln inPackage cf = unlines - [ - "#ifndef " ++ hdef, - "#define " ++ hdef, - "", - "#include", - "#include", - "", - "//C++ Abstract Syntax Interface generated by the BNF Converter.", - nsStart inPackage, - "/******************** TypeDef Section ********************/", - "", - unlines ["typedef " ++ d ++ " " ++ c ++ ";" | (c,d) <- basetypes], - "", - unlines ["typedef std::string " ++ s ++ ";" | s <- tokentypes cf], - "", - "/******************** Forward Declarations ********************/", - "", - unlines ["class " ++ c ++ ";" | c <- classes, notElem c (defineds cf)], - "", - "/******************** Visitor Interfaces ********************/", - prVisitor cf, - "", - prVisitable, - "", - "/******************** Abstract Syntax Classes ********************/", - "", - unlines [prAbs ln c | c <- absclasses cf], - "", - unlines [prCon (c,r) | (c,rs) <- signatures cf, r <- rs], - "", - unlines [prList c | c <- listtypes cf], - nsEnd inPackage, - "#endif" - ] - where - classes = allClasses cf - hdef = nsDefine inPackage "ABSYN_HEADER" - --- auxiliaries - -prVisitable :: String -prVisitable = unlines [ - "class Visitable", - "{", - " public:", - -- all classes with virtual methods require a virtual destructor - " virtual ~Visitable() {}", - " virtual void accept(Visitor *v) = 0;", - "};" - ] - -prVisitor :: CAbs -> String -prVisitor cf = unlines [ - "class Visitor", - "{", - "public:", - " virtual ~Visitor() {}", - unlines - [" virtual void visit"++c++"("++c++" *p) = 0;" | c <- allClasses cf, - notElem c (defineds cf)], - "", - unlines - [" virtual void visit"++c++"(" ++c++" x) = 0;" | c <- allNonClasses cf], - "};" - ] - -prAbs :: Bool -> Cat -> String -prAbs ln c = unlines [ - "class " ++c++ " : public Visitable", - "{", - "public:", - " virtual " ++ c ++ " *clone() const = 0;", - if ln then " int line_number;" else "", - "};" - ] - -prCon :: (Cat,CAbsRule) -> String -prCon (c,(f,cs)) = unlines [ - "class " ++f++ " : public " ++ c, - "{", - "public:", - unlines - [" "++ typ +++ pointerIf st var ++ ";" | (typ,st,var) <- cs], - " " ++ f ++ "(const " ++ f ++ " &);", - " " ++ f ++ " &operator=(const " ++f++ " &);", - " " ++ f ++ "(" ++ conargs ++ ");", - -- Typ *p1, PIdent *p2, ListStm *p3); - " ~" ++f ++ "();", - " virtual void accept(Visitor *v);", - " virtual " ++f++ " *clone() const;", - " void swap(" ++f++ " &);", - "};" - ] - where - conargs = concat $ intersperse ", " - [x +++ pointerIf st ("p" ++ show i) | ((x,st,_),i) <- zip cs [1..]] - -prList :: (Cat,Bool) -> String -prList (c,b) = unlines [ - "class " ++c++ " : public Visitable, public std::vector<" ++bas++ ">", - "{", - "public:", - " virtual void accept(Visitor *v);", - " virtual " ++ c ++ " *clone() const;", - "};" - ] - where - bas = drop 4 c ++ -- drop List - if b then "*" else "" - - --- **** Implementation (.C) File Functions **** -- - -mkCFile :: Maybe String -> CAbs -> String -mkCFile inPackage cf = unlines $ [ - "//C++ Abstract Syntax Implementation generated by the BNF Converter.", - "#include ", - "#include ", - "#include ", - "#include ", - "#include \"Absyn.H\"", - nsStart inPackage, - unlines [prConC r | (_,rs) <- signatures cf, r <- rs], - unlines [prListC c | (c,_) <- listtypes cf], - nsEnd inPackage - ] - -prConC :: CAbsRule -> String -prConC fcs@(f,cs) = unlines [ - "/******************** " ++ f ++ " ********************/", - prConstructorC fcs, - prCopyC fcs, - prDestructorC fcs, - prAcceptC f, - prCloneC f, - "" - ] - -prListC :: Cat -> String -prListC c = unlines [ - "/******************** " ++ c ++ " ********************/", - "", - prAcceptC c, - "", - prCloneC c - ] - - ---The standard accept function for the Visitor pattern -prAcceptC :: Cat -> String -prAcceptC ty = unlines [ - "void " ++ ty ++ "::accept(Visitor *v)", - "{", - " v->visit" ++ ty ++ "(this);", - "}" - ] - ---The cloner makes a new deep copy of the object -prCloneC :: Cat -> String -prCloneC c = unlines [ - c +++ "*" ++ c ++ "::clone() const", - "{", - " return new" +++ c ++ "(*this);", - "}" - ] - ---The constructor assigns the parameters to the corresponding instance variables. -prConstructorC :: CAbsRule -> String -prConstructorC (f,cs) = unlines [ - f ++ "::" ++ f ++ "(" ++ conargs ++ ")", - "{", - unlines [" " ++ c ++ " = " ++ p ++ ";" | (c,p) <- zip cvs pvs], - "}" - ] - where - cvs = [c | (_,_,c) <- cs] - pvs = ["p" ++ show i | ((x,st,_),i) <- zip cs [1..]] - conargs = concat $ intersperse ", " - [x +++ pointerIf st v | ((x,st,_),v) <- zip cs pvs] - - ---Copy constructor and copy assignment -prCopyC :: CAbsRule -> String -prCopyC (c,cs) = unlines [ - c ++ "::" ++ c ++ "(const" +++ c +++ "& other)", - "{", - unlines [" " ++ cv ++ " = other." ++ cloneIf st cv ++ ";" | (_,st,cv) <- cs], - "}", - "", - c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other)", - "{", - " " ++ c +++ "tmp(other);", - " swap(tmp);", - " return *this;", - "}", - "", - "void" +++ c ++ "::swap(" ++ c +++ "& other)", - "{", - unlines [" std::swap(" ++ cv ++ ", other." ++ cv ++ ");" | (_,_,cv) <- cs], - "}" - ] - where - cloneIf st cv = if st then (cv ++ "->clone()") else cv - ---The destructor deletes all a class's members. -prDestructorC :: CAbsRule -> String -prDestructorC (c,cs) = unlines [ - c ++ "::~" ++ c ++"()", - "{", - unlines [" delete(" ++ cv ++ ");" | (_,isPointer,cv) <- cs, isPointer], - "}" - ] diff --git a/formats/cpp_stl/CFtoSTLPrinter.hs b/formats/cpp_stl/CFtoSTLPrinter.hs deleted file mode 100644 --- a/formats/cpp_stl/CFtoSTLPrinter.hs +++ /dev/null @@ -1,676 +0,0 @@ -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the C++ Pretty Printer. - It also generates the "show" method for - printing an abstract syntax tree. - - The generated files use the Visitor design pattern. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 10 August, 2003 - - Modified : 3 September, 2003 - * Added resizable buffers - - ************************************************************** --} - -module CFtoSTLPrinter (cf2CPPPrinter) where - -import CF -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower, toUpper) -import STLUtils - ---Produces (.H file, .C file) -cf2CPPPrinter :: Maybe String -> CF -> (String, String) -cf2CPPPrinter inPackage cf = (mkHFile inPackage cf groups, mkCFile inPackage cf groups) - where - groups = positionRules cf ++ (fixCoercions (ruleGroupsInternals cf)) - -positionRules cf = - [(cat,[(cat,(cat,[Left "String", Left "Integer"]))]) | - cat <- filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))] - -{- **** Header (.H) File Methods **** -} - ---An extremely large function to make the Header File -mkHFile :: Maybe String -> CF -> [(Cat,[Rule])] -> String -mkHFile inPackage cf groups = unlines - [ - printHeader, - concatMap prDataH groups, - classFooter, - showHeader, - concatMap prDataH groups, - classFooter, - footer - ] - where - printHeader = unlines - [ - "#ifndef " ++ hdef, - "#define " ++ hdef, - "", - "#include \"Absyn.H\"", - "#include ", - "#include ", - "#include ", - "", - nsStart inPackage, - "/* Certain applications may improve performance by changing the buffer size */", - "#define " ++ nsDefine inPackage "BUFFER_INITIAL" ++ " 2000", - "/* You may wish to change _L_PAREN or _R_PAREN */", - "#define " ++ nsDefine inPackage "_L_PAREN" ++ " '('", - "#define " ++ nsDefine inPackage "_R_PAREN" ++ " ')'", - "", - "class PrintAbsyn : public Visitor", - "{", - " protected:", - " int _n_, _i_;", - " /* The following are simple heuristics for rendering terminals */", - " /* You may wish to change them */", - " void render(Char c);", - " void render(String s);", - " void indent(void);", - " void backup(void);", - " public:", - " PrintAbsyn(void);", - " ~PrintAbsyn(void);", - " char* print(Visitable* v);" - ] - hdef = nsDefine inPackage "PRINTER_HEADER" - classFooter = unlines $ - [ - " void visitInteger(Integer i);", - " void visitDouble(Double d);", - " void visitChar(Char c);", - " void visitString(String s);", - " void visitIdent(String s);" - ] ++ [" void visit" ++ t ++ "(String s);" | t <- tokenNames cf] ++ - [ - " protected:", - " void inline bufAppend(const char* s)", - " {", - " int len = strlen(s);", - " while (cur_ + len > buf_size)", - " {", - " buf_size *= 2; /* Double the buffer size */", - " resizeBuffer();", - " }", - " for(int n = 0; n < len; n++)", - " {", - " buf_[cur_ + n] = s[n];", - " }", - " cur_ += len;", - " buf_[cur_] = 0;", - " }", - " void inline bufAppend(const char c)", - " {", - " if (cur_ == buf_size)", - " {", - " buf_size *= 2; /* Double the buffer size */", - " resizeBuffer();", - " }", - " buf_[cur_] = c;", - " cur_++;", - " buf_[cur_] = 0;", - " }", - " void inline bufReset(void)", - " {", - " cur_ = 0;", - " buf_size = " ++ nsDefine inPackage "BUFFER_INITIAL" ++ ";", - " resizeBuffer();", - " memset(buf_, 0, buf_size);", - " }", - " void inline resizeBuffer(void)", - " {", - " char* temp = (char*) malloc(buf_size);", - " if (!temp)", - " {", - " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");", - " exit(1);", - " }", - " if (buf_)", - " {", - " strcpy(temp, buf_);", - " free(buf_);", - " }", - " buf_ = temp;", - " }", - " char *buf_;", - " int cur_, buf_size;", - "};", - "" - ] - showHeader = unlines - [ - "", - "class ShowAbsyn : public Visitor", - "{", - " public:", - " ShowAbsyn(void);", - " ~ShowAbsyn(void);", - " char* show(Visitable* v);" - ] - footer = unlines - [ - nsEnd inPackage, - "", - "#endif" - ] - ---Prints all the required method names and their parameters. -prDataH :: (Cat, [Rule]) -> String -prDataH (cat, rules) = - if "List" `isPrefixOf` (identCat cat) - then concat [" void visit", cl, "(", cl, "* p);\n"] - else abstract ++ (concatMap prRuleH rules) - where - cl = identCat (normCat cat) - abstract = case lookup cat rules of - Just x -> "" - Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n" - ---Prints all the methods to visit a rule. -prRuleH :: Rule -> String -prRuleH (fun, (c, cats)) | isProperLabel fun = concat - [" void visit", fun, "(", fun, " *p);\n"] -prRuleH (fun, cats) = "" - -{- **** Implementation (.C) File Methods **** -} - ---This makes the .C file by a similar method. -mkCFile :: Maybe String -> CF -> [(Cat,[Rule])] -> String -mkCFile inPackage cf groups = concat - [ - header, - nsStart inPackage ++ "\n", - prRender, - printEntries, - concatMap (prPrintData inPackage cf user) groups, - printBasics, - printTokens, - showEntries, - concatMap (prShowData user) groups, - showBasics, - showTokens, - nsEnd inPackage ++ "\n" - ] - where - user0 = fst (unzip (tokenPragmas cf)) - (userPos,user) = partition (isPositionCat cf) user0 - header = unlines - [ - "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/", - "", - "#include ", - "#include \"Printer.H\"", - "" - ] - printEntries = unlines - [ - "PrintAbsyn::PrintAbsyn(void)", - "{", - " _i_ = 0; _n_ = 0;", - " buf_ = 0;", - " bufReset();", - "}", - "", - "PrintAbsyn::~PrintAbsyn(void)", - "{", - "}", - "", - "char* PrintAbsyn::print(Visitable *v)", - "{", - " _i_ = 0; _n_ = 0;", - " bufReset();", - " v->accept(this);", - " return buf_;", - "}" - ] - showEntries = unlines - [ - "ShowAbsyn::ShowAbsyn(void)", - "{", - " buf_ = 0;", - " bufReset();", - "}", - "", - "ShowAbsyn::~ShowAbsyn(void)", - "{", - "}", - "", - "char* ShowAbsyn::show(Visitable *v)", - "{", - " bufReset();", - " v->accept(this);", - " return buf_;", - "}" - ] - printBasics = unlines - [ - "void PrintAbsyn::visitInteger(Integer i)", - "{", - " char tmp[16];", - " sprintf(tmp, \"%d\", i);", - " bufAppend(tmp);", - "}", - "void PrintAbsyn::visitDouble(Double d)", - "{", - " char tmp[16];", - " sprintf(tmp, \"%g\", d);", - " bufAppend(tmp);", - "}", - "void PrintAbsyn::visitChar(Char c)", - "{", - " bufAppend('\\'');", - " bufAppend(c);", - " bufAppend('\\'');", - "}", - "void PrintAbsyn::visitString(String s_)", - "{", - " const char *s = s_.c_str() ;", - " bufAppend('\\\"');", - " bufAppend(s);", - " bufAppend('\\\"');", - "}", - "void PrintAbsyn::visitIdent(String s_)", - "{", - " const char *s = s_.c_str() ;", - " render(s);", - "}", - "" - ] - - printTokens = unlines - [unlines [ - "void PrintAbsyn::visit" ++ t ++ "(String s_)", - "{", - " const char *s = s_.c_str() ;", - " render(s);", - "}", - "" - ] | t <- tokenNames cf - ] - - showBasics = unlines - [ - "void ShowAbsyn::visitInteger(Integer i)", - "{", - " char tmp[16];", - " sprintf(tmp, \"%d\", i);", - " bufAppend(tmp);", - "}", - "void ShowAbsyn::visitDouble(Double d)", - "{", - " char tmp[16];", - " sprintf(tmp, \"%g\", d);", - " bufAppend(tmp);", - "}", - "void ShowAbsyn::visitChar(Char c)", - "{", - " bufAppend('\\'');", - " bufAppend(c);", - " bufAppend('\\'');", - "}", - "void ShowAbsyn::visitString(String s_)", - "{", - " const char *s = s_.c_str() ;", - " bufAppend('\\\"');", - " bufAppend(s);", - " bufAppend('\\\"');", - "}", - "void ShowAbsyn::visitIdent(String s_)", - "{", - " const char *s = s_.c_str() ;", - " bufAppend('\\\"');", - " bufAppend(s);", - " bufAppend('\\\"');", - "}", - "" - ] - - showTokens = unlines - [unlines [ - "void ShowAbsyn::visit" ++ t ++ "(String s_)", - "{", - " const char *s = s_.c_str() ;", - " bufAppend('\\\"');", - " bufAppend(s);", - " bufAppend('\\\"');", - "}", - "" - ] | t <- tokenNames cf - ] - - -{- **** Pretty Printer Methods **** -} - ---Generates methods for the Pretty Printer -prPrintData :: Maybe String -> CF -> [UserDef] -> (Cat, [Rule]) -> String -prPrintData inPackage cf user (cat, rules) = - if "List" `isPrefixOf` (identCat cat) - then unlines - [ - "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")", - "{", - " for ("++ cl ++"::const_iterator i = " ++ - vname++"->begin() ; i != " ++vname ++"->end() ; ++i)", - " {", - if isBase user vname - then " visit" ++ baseName cl ++ "(*i) ;" - else " (*i)->accept(this);", - optsep, - " }", - "}", - "" - ] --Not a list: - -- a position token - else if isPositionCat cf cat then unlines [ - "void PrintAbsyn::visit" ++ cat ++ "(" ++ cat ++ "* p)", - "{", - " visitIdent(p->string_);", - "}" - ] - else abstract ++ (concatMap (prPrintRule inPackage user) rules) - where - cl = identCat (normCat cat) - ecl = identCat (normCatOfList cat) - vname = map toLower cl - member = map toLower ecl ++ "_" - visitMember = if isBasic user member - then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" - else " " ++ vname ++ "->" ++ member ++ "->accept(this);" - sep = if (length sep') == 1 - then "'" ++ (escapeChars sep') ++ "'" - else "\"" ++ (escapeChars sep') ++ "\"" - sep' = getCons rules - optsep = - (if hasOneFunc rules - then " if (i != " ++ vname ++ "->end() - 1) " - else " " - ) ++ "render(" ++ sep ++ ");" - abstract = case lookup cat rules of - Just x -> "" - Nothing -> "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl ++ "*p) {} //abstract class\n\n" - ---Pretty Printer methods for a rule. -prPrintRule :: Maybe String -> [UserDef] -> Rule -> String -prPrintRule inPackage user r@(fun, (c, cats)) | isProperLabel fun = unlines - [ - "void PrintAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")", - "{", - " int oldi = _i_;", - lparen, - cats', - rparen, - " _i_ = oldi;", - "}\n" - ] - where - p = precRule r - (lparen, rparen) = - (" if (oldi > " ++ (show p) ++ ") render(" ++ nsDefine inPackage "_L_PAREN" ++ ");\n", - " if (oldi > " ++ (show p) ++ ") render(" ++ nsDefine inPackage "_R_PAREN" ++ ");\n") - cats' = (concatMap (prPrintCat user fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats))) - fnm = "p" --old names could cause conflicts - getPrec (Right s) = 0 - getPrec (Left c) = precCat c -prPrintRule _ _ (fun, cats) = "" - ---This goes on to recurse to the instance variables. -prPrintCat :: [UserDef] -> String -> (Either Cat String, Int) -> String -prPrintCat user fnm (c,p) = case c of - (Right t) -> " render(" ++ t' ++ ");\n" - where - t' = if length t == 1 - then "'" ++ (escapeChars t) ++ "'" - else "\"" ++ (escapeChars t) ++ "\"" - (Left nt) -> if isBasic user nt - then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" - else if "list" `isPrefixOf` nt - then " if(" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}" - else " " ++ accept ++ "\n" - where - accept = if nt == "#_" --Internal category - then "/* Internal Category */\n" - else (setI p) ++ fnm ++ "->" ++ nt ++ "->accept(this);" - -{- **** Abstract Syntax Tree Printer **** -} - ---This prints the functions for Abstract Syntax tree printing. -prShowData :: [UserDef] -> (Cat, [Rule]) -> String -prShowData user (cat, rules) = - if "List" `isPrefixOf` (identCat cat) - then unlines - [ - "void ShowAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")", - "{", - " for ("++ cl ++"::const_iterator i = " ++ - vname++"->begin() ; i != " ++vname ++"->end() ; ++i)", - " {", - if isBase user vname - then " visit" ++ baseName cl ++ "(*i) ;" - else " (*i)->accept(this);", - " if (i != " ++ vname ++ "->end() - 1) bufAppend(\", \");", - " }", - "}", - "" - ] --Not a list: - else abstract ++ (concatMap (prShowRule user) rules) - where - cl = identCat (normCat cat) - ecl = identCat (normCatOfList cat) - vname = map toLower cl - member = map toLower ecl ++ "_" - visitMember = if isBasic user member - then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" - else " " ++ vname ++ "->" ++ member ++ "->accept(this);" - abstract = case lookup cat rules of - Just x -> "" - Nothing -> "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ "* p) {} //abstract class\n\n" - ---This prints all the methods for Abstract Syntax tree rules. -prShowRule :: [UserDef] -> Rule -> String -prShowRule user (fun, (c, cats)) | isProperLabel fun = concat - [ - "void ShowAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")\n", - "{\n", - lparen, - " bufAppend(\"" ++ fun ++ "\");\n", - optspace, - cats', - rparen, - "}\n" - ] - where - (optspace, lparen, rparen) = if allTerms cats - then ("","","") - else (" bufAppend(' ');\n", " bufAppend('(');\n"," bufAppend(')');\n") - cats' = if allTerms cats - then "" - else concat (insertSpaces (map (prShowCat user fnm) (fixOnes (numVars [] cats)))) - insertSpaces [] = [] - insertSpaces (x:[]) = [x] - insertSpaces (x:xs) = if x == "" - then insertSpaces xs - else (x : [" bufAppend(' ');\n"]) ++ (insertSpaces xs) - allTerms [] = True - allTerms ((Left z):zs) = False - allTerms (z:zs) = allTerms zs - fnm = "p" --other names could cause conflicts -prShowRule _ (fun, cats) = "" - ---This recurses to the instance variables of a class. -prShowCat :: [UserDef] -> String -> Either Cat String -> String -prShowCat user fnm c = - case c of - (Right t) -> "" - (Left nt) -> - if isBasic user nt - then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" - else if nt == "#_" --internal category - then "/* Internal Category */\n" - else if ((normCat nt) /= nt) - then accept - else concat - [ - " bufAppend('[');\n", - " if (" ++ fnm ++ "->" ++ nt ++ ")" ++ accept, - " bufAppend(']');\n" - ] - where - accept = " " ++ fnm ++ "->" ++ nt ++ "->accept(this);\n" - -{- **** Helper Functions Section **** -} - - ---Just checks if something is a basic or user-defined type. ---This is because you don't -> a basic non-pointer type. -isBasic :: [UserDef] -> String -> Bool -isBasic user v = - if elem (init v) user' - then True - else if "integer_" `isPrefixOf` v then True - else if "char_" `isPrefixOf` v then True - else if "string_" `isPrefixOf` v then True - else if "double_" `isPrefixOf` v then True - else if "ident_" `isPrefixOf` v then True - else False - where - user' = map (map toLower) user - --- from listident to ident_ -isBase user vn = isBasic user (baseName vn ++ "_") --- from ListIdent to Ident -baseName cl = drop 4 cl - - ---The visit-function name of a basic type -funName :: String -> String -funName v = - if "integer_" `isPrefixOf` v then "Integer" - else if "char_" `isPrefixOf` v then "Char" - else if "string_" `isPrefixOf` v then "String" - else if "double_" `isPrefixOf` v then "Double" - else if "ident_" `isPrefixOf` v then "Ident" - else "Ident" --User-defined type - ---Just sets the coercion level for parentheses in the Pretty Printer. -setI :: Int -> String -setI n = "_i_ = " ++ (show n) ++ "; " - ---Gets the separator for a list. -getCons :: [Rule] -> String -getCons ((f, (c, cats)):rs) = - if isConsFun f - then seper cats - else getCons rs - where - seper [] = [] - seper ((Right x):xs) = x - seper ((Left x):xs) = seper xs - ---Checks if the list has a non-empty rule. -hasOneFunc :: [Rule] -> Bool -hasOneFunc [] = False -hasOneFunc ((f, (c, cats)):rs) = - if (isOneFun f) - then True - else hasOneFunc rs - ---Helper function that escapes characters in strings -escapeChars :: String -> String -escapeChars [] = [] -escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) -escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) -escapeChars (x:xs) = x : (escapeChars xs) - ---An extremely simple renderer for terminals. -prRender :: String -prRender = unlines - [ - "//You may wish to change render", - "void PrintAbsyn::render(Char c)", - "{", - " if (c == '{')", - " {", - " bufAppend('\\n');", - " indent();", - " bufAppend(c);", - " _n_ = _n_ + 2;", - " bufAppend('\\n');", - " indent();", - " }", - " else if (c == '(' || c == '[')", - " bufAppend(c);", - " else if (c == ')' || c == ']')", - " {", - " backup();", - " bufAppend(c);", - " bufAppend(' ');", - " }", - " else if (c == '}')", - " {", - " _n_ = _n_ - 2;", - " backup();", - " backup();", - " bufAppend(c);", - " bufAppend('\\n\');", - " indent();", - " }", - " else if (c == ',')", - " {", - " backup();", - " bufAppend(c);", - " bufAppend(' ');", - " }", - " else if (c == ';')", - " {", - " backup();", - " bufAppend(c);", - " bufAppend('\\n');", - " indent();", - " }", - " else if (c == 0) return;", - " else", - " {", - " bufAppend(c);", - " bufAppend(' ');", - " }", - "}", - "void PrintAbsyn::render(String s_)", - "{", - " const char *s = s_.c_str() ;", - " if(strlen(s) > 0)", - " {", - " bufAppend(s);", - " bufAppend(' ');", - " }", - "}", - "void PrintAbsyn::indent()", - "{", - " int n = _n_;", - " while (n > 0)", - " {", - " bufAppend(' ');", - " n--;", - " }", - "}", - "void PrintAbsyn::backup()", - "{", - " if (buf_[cur_ - 1] == ' ')", - " {", - " buf_[cur_ - 1] = 0;", - " cur_--;", - " }", - "}" - ] diff --git a/formats/cpp_stl/STLTop.hs b/formats/cpp_stl/STLTop.hs deleted file mode 100644 --- a/formats/cpp_stl/STLTop.hs +++ /dev/null @@ -1,224 +0,0 @@ -{- - BNF Converter: C++ Main file - Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer - - Modified from CPPTop to STLTop 2006 by Aarne Ranta. - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module STLTop (makeSTL) where - -import Utils -import CF -import CFtoSTLAbs -import CFtoFlex -import CFtoBisonSTL -import CFtoCVisitSkelSTL -import CFtoSTLPrinter -import CFtoLatex -import System.IO -import GetCF -import Data.Char -import System.IO -import System.Exit -import STLUtils - -makeSTL :: Bool -> Bool -> Maybe String -> String -> FilePath -> IO () -makeSTL make linenumbers inPackage name file = do - (cf, isOK) <- tryReadCF file - if isOK then do - let (hfile, cfile) = cf2CPPAbs linenumbers inPackage name cf - writeFileRep "Absyn.H" hfile - writeFileRep "Absyn.C" cfile - let (flex, env) = cf2flex inPackage name cf - writeFileRep (name ++ ".l") flex - putStrLn " (Tested with flex 2.5.31)" - let bison = cf2Bison linenumbers inPackage name cf env - writeFileRep (name ++ ".y") bison - putStrLn " (Tested with bison 1.875a)" - let header = mkHeaderFile inPackage cf (allCats cf) (allEntryPoints cf) env - writeFileRep "Parser.H" header - let (skelH, skelC) = cf2CVisitSkel inPackage cf - writeFileRep "Skeleton.H" skelH - writeFileRep "Skeleton.C" skelC - let (prinH, prinC) = cf2CPPPrinter inPackage cf - writeFileRep "Printer.H" prinH - writeFileRep "Printer.C" prinC - writeFileRep "Test.C" (cpptest inPackage cf) - let latex = cfToLatex name cf - writeFileRep (name ++ ".tex") latex - if make then (writeFileRep "Makefile" $ makefile name) else return () - putStrLn "Done!" - else do putStrLn $ "Failed" - exitFailure - -makefile :: String -> String -makefile name = unlines - [ - "CC = g++", - "CCFLAGS = -g", - "FLEX = flex", - "BISON = bison", - "LATEX = latex", - "DVIPS = dvips", - "", - "all: test" ++ name ++ " " ++ name ++ ".ps", - "", - "clean:", - -- peteg: don't nuke what we generated - move that to the "vclean" target. - "\trm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps test" ++ name, - "", - "distclean:", - "\t rm -f *.o Absyn.C Absyn.H Test.C Parser.C Parser.H Lexer.C Skeleton.C Skeleton.H Printer.C Printer.H " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps test" ++ name ++ " Makefile", - "", - "test" ++ name ++ ": Absyn.o Lexer.o Parser.o Printer.o Test.o", - "\t@echo \"Linking test" ++ name ++ "...\"", - "\t${CC} ${CCFLAGS} *.o -o test" ++ name ++ "", - " ", - "Absyn.o: Absyn.C Absyn.H", - "\t${CC} ${CCFLAGS} -c Absyn.C", - "", - "Lexer.C: " ++ name ++ ".l", - "\t${FLEX} -oLexer.C " ++ name ++ ".l", - "", - "Parser.C: " ++ name ++ ".y", - "\t${BISON} " ++ name ++ ".y -o Parser.C", - "", - "Lexer.o: Lexer.C Parser.H", - "\t${CC} ${CCFLAGS} -c Lexer.C ", - "", - "Parser.o: Parser.C Absyn.H", - "\t${CC} ${CCFLAGS} -c Parser.C", - "", - "Printer.o: Printer.C Printer.H Absyn.H", - "\t${CC} ${CCFLAGS} -c Printer.C", - "", - "Skeleton.o: Skeleton.C Skeleton.H Absyn.H", - "\t${CC} ${CCFLAGS} -c Skeleton.C", - "", - "Test.o: Test.C Parser.H Printer.H Absyn.H", - "\t${CC} ${CCFLAGS} -c Test.C", - "", - "" ++ name ++ ".dvi: " ++ name ++ ".tex", - "\t${LATEX} " ++ name ++ ".tex", - "", - "" ++ name ++ ".ps: " ++ name ++ ".dvi", - "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps", - "" - ] - -cpptest :: Maybe String -> CF -> String -cpptest inPackage cf = - unlines - [ - "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", - "/* */", - "/* This test will parse a file, print the abstract syntax tree, and then */", - "/* pretty-print the result. */", - "/* */", - "/****************************************************************************/", - "#include ", - "#include \"Parser.H\"", - "#include \"Printer.H\"", - "#include \"Absyn.H\"", - "", - "int main(int argc, char ** argv)", - "{", - " FILE *input;", - " if (argc > 1) ", - " {", - " input = fopen(argv[1], \"r\");", - " if (!input)", - " {", - " fprintf(stderr, \"Error opening input file.\\n\");", - " exit(1);", - " }", - " }", - " else input = stdin;", - " /* The default entry point is used. For other options see Parser.H */", - " " ++ scope ++ def ++ " *parse_tree = " ++ scope ++ "p" ++ def ++ "(input);", - " if (parse_tree)", - " {", - " printf(\"\\nParse Succesful!\\n\");", - " printf(\"\\n[Abstract Syntax]\\n\");", - " " ++ scope ++ "ShowAbsyn *s = new " ++ scope ++ "ShowAbsyn();", - " printf(\"%s\\n\\n\", s->show(parse_tree));", - " printf(\"[Linearized Tree]\\n\");", - " " ++ scope ++ "PrintAbsyn *p = new " ++ scope ++ "PrintAbsyn();", - " printf(\"%s\\n\\n\", p->print(parse_tree));", - " return 0;", - " }", - " return 1;", - "}", - "" - ] - where - def = head (allEntryPoints cf) - scope = nsScope inPackage - -mkHeaderFile inPackage cf cats eps env = unlines - [ - "#ifndef " ++ hdef, - "#define " ++ hdef, - "", - "#include", - "#include", - "", - nsStart inPackage, - concatMap mkForwardDec cats, - "typedef union", - "{", - " int int_;", - " char char_;", - " double double_;", - " char* string_;", - (concatMap mkVar cats) ++ "} YYSTYPE;", - "", - concatMap mkFuncs eps, - nsEnd inPackage, - "", - "#define " ++ nsDefine inPackage "_ERROR_" ++ " 258", - mkDefines (259 :: Int) env, - "extern " ++ nsScope inPackage ++ "YYSTYPE " ++ nsString inPackage ++ "yylval;", - "", - "#endif" - ] - where - hdef = nsDefine inPackage "PARSER_HEADER_FILE" - mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n" - mkForwardDec _ = "" - mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n" - mkVar _ = "" - mkDefines n [] = mkString n - mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) -- "nsDefine inPackage s" not needed (see cf2flex::makeSymEnv) - mkString n = if isUsedCat cf "String" - then ("#define " ++ nsDefine inPackage "_STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) - else mkChar n - mkChar n = if isUsedCat cf "Char" - then ("#define " ++ nsDefine inPackage "_CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1) - else mkInteger n - mkInteger n = if isUsedCat cf "Integer" - then ("#define " ++ nsDefine inPackage "_INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1) - else mkDouble n - mkDouble n = if isUsedCat cf "Double" - then ("#define " ++ nsDefine inPackage "_DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1) - else mkIdent n - mkIdent n = if isUsedCat cf "Ident" - then ("#define " ++ nsDefine inPackage "_IDENT_ " ++ show n ++ "\n") - else "" - mkFuncs s | (normCat s == s) = (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(FILE *inp);\n" ++ - (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(const char *str);\n" - mkFuncs _ = "" diff --git a/formats/cpp_stl/STLTop.hs~ b/formats/cpp_stl/STLTop.hs~ deleted file mode 100644 --- a/formats/cpp_stl/STLTop.hs~ +++ /dev/null @@ -1,223 +0,0 @@ -{- - BNF Converter: C++ Main file - Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer - - Modified from CPPTop to STLTop 2006 by Aarne Ranta. - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module STLTop (makeSTL) where - -import Utils -import CF -import CFtoSTLAbs -import CFtoFlex -import CFtoBisonSTL -import CFtoCVisitSkelSTL -import CFtoSTLPrinter -import CFtoLatex -import System.IO -import GetCF -import Data.Char -import System.IO -import STLUtils - -makeSTL :: Bool -> Bool -> Maybe String -> String -> FilePath -> IO () -makeSTL make linenumbers inPackage name file = do - (cf, isOK) <- tryReadCF file - if isOK then do - let (hfile, cfile) = cf2CPPAbs linenumbers inPackage name cf - writeFileRep "Absyn.H" hfile - writeFileRep "Absyn.C" cfile - let (flex, env) = cf2flex inPackage name cf - writeFileRep (name ++ ".l") flex - putStrLn " (Tested with flex 2.5.31)" - let bison = cf2Bison linenumbers inPackage name cf env - writeFileRep (name ++ ".y") bison - putStrLn " (Tested with bison 1.875a)" - let header = mkHeaderFile inPackage cf (allCats cf) (allEntryPoints cf) env - writeFileRep "Parser.H" header - let (skelH, skelC) = cf2CVisitSkel inPackage cf - writeFileRep "Skeleton.H" skelH - writeFileRep "Skeleton.C" skelC - let (prinH, prinC) = cf2CPPPrinter inPackage cf - writeFileRep "Printer.H" prinH - writeFileRep "Printer.C" prinC - writeFileRep "Test.C" (cpptest inPackage cf) - let latex = cfToLatex name cf - writeFileRep (name ++ ".tex") latex - if make then (writeFileRep "Makefile" $ makefile name) else return () - putStrLn "Done!" - else do putStrLn $ "Failed" - exitFailure - -makefile :: String -> String -makefile name = unlines - [ - "CC = g++", - "CCFLAGS = -g", - "FLEX = flex", - "BISON = bison", - "LATEX = latex", - "DVIPS = dvips", - "", - "all: test" ++ name ++ " " ++ name ++ ".ps", - "", - "clean:", - -- peteg: don't nuke what we generated - move that to the "vclean" target. - "\trm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps test" ++ name, - "", - "distclean:", - "\t rm -f *.o Absyn.C Absyn.H Test.C Parser.C Parser.H Lexer.C Skeleton.C Skeleton.H Printer.C Printer.H " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps test" ++ name ++ " Makefile", - "", - "test" ++ name ++ ": Absyn.o Lexer.o Parser.o Printer.o Test.o", - "\t@echo \"Linking test" ++ name ++ "...\"", - "\t${CC} ${CCFLAGS} *.o -o test" ++ name ++ "", - " ", - "Absyn.o: Absyn.C Absyn.H", - "\t${CC} ${CCFLAGS} -c Absyn.C", - "", - "Lexer.C: " ++ name ++ ".l", - "\t${FLEX} -oLexer.C " ++ name ++ ".l", - "", - "Parser.C: " ++ name ++ ".y", - "\t${BISON} " ++ name ++ ".y -o Parser.C", - "", - "Lexer.o: Lexer.C Parser.H", - "\t${CC} ${CCFLAGS} -c Lexer.C ", - "", - "Parser.o: Parser.C Absyn.H", - "\t${CC} ${CCFLAGS} -c Parser.C", - "", - "Printer.o: Printer.C Printer.H Absyn.H", - "\t${CC} ${CCFLAGS} -c Printer.C", - "", - "Skeleton.o: Skeleton.C Skeleton.H Absyn.H", - "\t${CC} ${CCFLAGS} -c Skeleton.C", - "", - "Test.o: Test.C Parser.H Printer.H Absyn.H", - "\t${CC} ${CCFLAGS} -c Test.C", - "", - "" ++ name ++ ".dvi: " ++ name ++ ".tex", - "\t${LATEX} " ++ name ++ ".tex", - "", - "" ++ name ++ ".ps: " ++ name ++ ".dvi", - "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps", - "" - ] - -cpptest :: Maybe String -> CF -> String -cpptest inPackage cf = - unlines - [ - "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", - "/* */", - "/* This test will parse a file, print the abstract syntax tree, and then */", - "/* pretty-print the result. */", - "/* */", - "/****************************************************************************/", - "#include ", - "#include \"Parser.H\"", - "#include \"Printer.H\"", - "#include \"Absyn.H\"", - "", - "int main(int argc, char ** argv)", - "{", - " FILE *input;", - " if (argc > 1) ", - " {", - " input = fopen(argv[1], \"r\");", - " if (!input)", - " {", - " fprintf(stderr, \"Error opening input file.\\n\");", - " exit(1);", - " }", - " }", - " else input = stdin;", - " /* The default entry point is used. For other options see Parser.H */", - " " ++ scope ++ def ++ " *parse_tree = " ++ scope ++ "p" ++ def ++ "(input);", - " if (parse_tree)", - " {", - " printf(\"\\nParse Succesful!\\n\");", - " printf(\"\\n[Abstract Syntax]\\n\");", - " " ++ scope ++ "ShowAbsyn *s = new " ++ scope ++ "ShowAbsyn();", - " printf(\"%s\\n\\n\", s->show(parse_tree));", - " printf(\"[Linearized Tree]\\n\");", - " " ++ scope ++ "PrintAbsyn *p = new " ++ scope ++ "PrintAbsyn();", - " printf(\"%s\\n\\n\", p->print(parse_tree));", - " return 0;", - " }", - " return 1;", - "}", - "" - ] - where - def = head (allEntryPoints cf) - scope = nsScope inPackage - -mkHeaderFile inPackage cf cats eps env = unlines - [ - "#ifndef " ++ hdef, - "#define " ++ hdef, - "", - "#include", - "#include", - "", - nsStart inPackage, - concatMap mkForwardDec cats, - "typedef union", - "{", - " int int_;", - " char char_;", - " double double_;", - " char* string_;", - (concatMap mkVar cats) ++ "} YYSTYPE;", - "", - concatMap mkFuncs eps, - nsEnd inPackage, - "", - "#define " ++ nsDefine inPackage "_ERROR_" ++ " 258", - mkDefines (259 :: Int) env, - "extern " ++ nsScope inPackage ++ "YYSTYPE " ++ nsString inPackage ++ "yylval;", - "", - "#endif" - ] - where - hdef = nsDefine inPackage "PARSER_HEADER_FILE" - mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n" - mkForwardDec _ = "" - mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n" - mkVar _ = "" - mkDefines n [] = mkString n - mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) -- "nsDefine inPackage s" not needed (see cf2flex::makeSymEnv) - mkString n = if isUsedCat cf "String" - then ("#define " ++ nsDefine inPackage "_STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) - else mkChar n - mkChar n = if isUsedCat cf "Char" - then ("#define " ++ nsDefine inPackage "_CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1) - else mkInteger n - mkInteger n = if isUsedCat cf "Integer" - then ("#define " ++ nsDefine inPackage "_INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1) - else mkDouble n - mkDouble n = if isUsedCat cf "Double" - then ("#define " ++ nsDefine inPackage "_DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1) - else mkIdent n - mkIdent n = if isUsedCat cf "Ident" - then ("#define " ++ nsDefine inPackage "_IDENT_ " ++ show n ++ "\n") - else "" - mkFuncs s | (normCat s == s) = (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(FILE *inp);\n" ++ - (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(const char *str);\n" - mkFuncs _ = "" diff --git a/formats/cpp_stl/STLUtils.hs b/formats/cpp_stl/STLUtils.hs deleted file mode 100644 --- a/formats/cpp_stl/STLUtils.hs +++ /dev/null @@ -1,37 +0,0 @@ -{- - BNF Converter: C++ common functions - Copyright (C) 2008 Author: Martin Ejdestig - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module STLUtils where - -import Data.Char - -nsDefine :: Maybe String -> String -> String -nsDefine inPackage h = maybe h (\ns -> map toUpper ns ++ "_" ++ h) inPackage - -nsStart :: Maybe String -> String -nsStart inPackage = maybe "" (\ns -> "namespace " ++ ns ++ "\n{") inPackage - -nsEnd :: Maybe String -> String -nsEnd inPackage = maybe "" (\ns -> "}") inPackage - -nsScope :: Maybe String -> String -nsScope inPackage = maybe "" (\ns -> ns ++ "::") inPackage - -nsString :: Maybe String -> String -nsString inPackage = maybe "" id inPackage diff --git a/formats/f-sharp/FSharpTop.hs b/formats/f-sharp/FSharpTop.hs deleted file mode 100644 --- a/formats/f-sharp/FSharpTop.hs +++ /dev/null @@ -1,209 +0,0 @@ -{- - BNF Converter: F# main file - Copyright (C) 2005 Author: Kristofer Johannisson - Copyright (C) 2007 Author: Bjorn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - --- based on BNFC O'Caml backend - - -module FSharpTop (makeFSharp) where - -import CF -import CFtoOCamlYacc -import CFtoOCamlLex -import CFtoLatex -import CFtoOCamlAbs -import CFtoOCamlTemplate -import CFtoOCamlPrinter -import CFtoOCamlShow -import CFtoOCamlTest -import CFtoXML -import GetCF -import Utils - -import Data.Char -import Data.Maybe (fromMaybe,maybe) -import System.IO -import System.Exit -import Control.Monad(when) - --- naming conventions - -noLang :: Options -> String -> String -noLang _ name = name - -withLang :: Options -> String -> String -withLang opts name = name ++ lang opts - -mkMod :: (Options -> String -> String) -> String -> Options -> String -mkMod addLang name opts = - pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name - where pref = maybe "" (++".") (inPackage opts) - -mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath -mkFile addLang name ext opts = - pref ++ if inDir opts - then lang opts ++ [pathSep] ++ name ++ ext' - else addLang opts name ++ if null ext then "" else ext' - where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts) - ext' = if null ext then "" else "." ++ ext - -absFile, absFileM, ocamllexFile, ocamllexFileM, dviFile, - ocamlyaccFile, ocamlyaccFileM, - latexFile, utilFile, utilFileM, - templateFile, templateFileM, - printerFile, printerFileM, - psFile, tFile, tFileM :: Options -> String -absFile = mkFile withLang "Abs" "ml" -absFileM = mkMod withLang "Abs" -ocamllexFile = mkFile withLang "Lex" "mll" -ocamllexFileM = mkMod withLang "Lex" -ocamlyaccFile = mkFile withLang "Par" "mly" -ocamlyaccFileM = mkMod withLang "Par" -latexFile = mkFile withLang "Doc" "tex" -templateFile = mkFile withLang "Skel" "ml" -templateFileM = mkMod withLang "Skel" -printerFile = mkFile withLang "Print" "ml" -printerFileM = mkMod withLang "Print" -showFile = mkFile withLang "Show" "ml" -showFileM = mkMod withLang "Show" -dviFile = mkFile withLang "Doc" "dvi" -psFile = mkFile withLang "Doc" "ps" -tFile = mkFile withLang "Test" "ml" -tFileM = mkMod withLang "Test" -utilFile = mkFile noLang "BNFC_Util" "ml" -utilFileM = mkMod noLang "BNFC_Util" -xmlFileM = mkMod withLang "XML" - -data Options = Options - { - make :: Bool, - alex1 :: Bool, - inDir :: Bool, - shareStrings :: Bool, - xml :: Int, - inPackage :: Maybe String, - lang :: String - } - --- FIXME: we probably don't need all these arguments -makeFSharp :: Bool -> Bool -> Bool -> Bool -> Bool -> Int - -> Maybe String -- ^ The hierarchical package to put the modules - -- in, or Nothing. - -> String -> FilePath -> IO () -makeFSharp m a1 d ss g x p n file = do - let opts = Options { make = m, alex1 = a1, inDir = d, shareStrings = ss, - xml = x, inPackage = p, lang = n } - - absMod = absFileM opts - lexMod = ocamllexFileM opts - parMod = ocamlyaccFileM opts - prMod = printerFileM opts - showMod = showFileM opts --- layMod = layoutFileM opts - utilMod = utilFileM opts - (cf, isOK) <- tryReadCF file - if isOK then do - let dir = codeDir opts - when (not (null dir)) $ do - putStrLn $ "Creating directory " ++ dir - prepareDir dir - writeFileRep (absFile opts) $ cf2Abstract absMod cf - writeFileRep (ocamllexFile opts) $ cf2ocamllex lexMod parMod cf - writeFileRep (ocamlyaccFile opts) $ - cf2ocamlyacc parMod absMod lexMod cf - writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf - writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod cf - writeFileRep (printerFile opts) $ cf2Printer prMod absMod cf - writeFileRep (showFile opts) $ cf2show showMod absMod cf - writeFileRep (tFile opts) $ ocamlTestfile absMod lexMod parMod prMod showMod cf - writeFileRep (utilFile opts) $ utilM - when (make opts) $ writeFileRep "Makefile" $ makefile opts - case xml opts of - 2 -> makeXML (lang opts) True cf - 1 -> makeXML (lang opts) False cf - _ -> return () - putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -pkgToDir :: String -> FilePath -pkgToDir s = replace '.' pathSep s - -codeDir :: Options -> FilePath -codeDir opts = let pref = maybe "" pkgToDir (inPackage opts) - dir = if inDir opts then lang opts else "" - sep = if null pref || null dir then "" else [pathSep] - in pref ++ sep ++ dir - -makefile :: Options -> String -makefile opts = makeA where - dir = let d = codeDir opts in if null d then "" else d ++ [pathSep] - cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")" - makeA = unlines - [ - "all:", - "\tfsyacc " ++ ocamlyaccFile opts, - "\tfslex " ++ ocamllexFile opts, - "\t" ++ cd ("latex " ++ basename (latexFile opts) - ++ "; " ++ "dvips " ++ basename (dviFile opts) - ++ " -o " ++ basename (psFile opts)), - "\tfsc -o " ++ mkFile withLang "Test" "exe" opts +++ - utilFile opts +++ - absFile opts +++ templateFile opts +++ - showFile opts +++ printerFile opts +++ - mkFile withLang "Par" "mli" opts +++ - mkFile withLang "Par" "ml" opts +++ - mkFile withLang "Lex" "fs" opts +++ - tFile opts, - "", - "clean:", - "\t-rm -f " ++ unwords (map (dir++) [ - "*.log", "*.aux", "*.cmi", - "*.cmo", "*.o", "*.dvi" - ]), - "\t-rm -f " ++ psFile opts, - "", - "distclean: clean", - "\t-rm -f " ++ unwords [ - mkFile withLang "Doc" "*" opts, - mkFile withLang "Lex" "*" opts, - mkFile withLang "Par" "*" opts, - mkFile withLang "Layout" "*" opts, - mkFile withLang "Skel" "*" opts, - mkFile withLang "Print" "*" opts, - mkFile withLang "Show" "*" opts, - mkFile withLang "Test" "*" opts, - mkFile withLang "Abs" "*" opts, - mkFile withLang "Test" "" opts, - utilFile opts, - "Makefile*" - ] - ] - - -utilM :: String -utilM = unlines - ["(* automatically generated by BNFC *)", - "", - "open Lexing", - "", - "(* this should really be in the parser, but ocamlyacc won't put it in the .mli *)", - "exception Parse_error of Lexing.position * Lexing.position" - ] - diff --git a/formats/f-sharp/FSharpTop.hs~ b/formats/f-sharp/FSharpTop.hs~ deleted file mode 100644 --- a/formats/f-sharp/FSharpTop.hs~ +++ /dev/null @@ -1,208 +0,0 @@ -{- - BNF Converter: F# main file - Copyright (C) 2005 Author: Kristofer Johannisson - Copyright (C) 2007 Author: Bjorn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - --- based on BNFC O'Caml backend - - -module FSharpTop (makeFSharp) where - -import CF -import CFtoOCamlYacc -import CFtoOCamlLex -import CFtoLatex -import CFtoOCamlAbs -import CFtoOCamlTemplate -import CFtoOCamlPrinter -import CFtoOCamlShow -import CFtoOCamlTest -import CFtoXML -import GetCF -import Utils - -import Data.Char -import Data.Maybe (fromMaybe,maybe) -import System.IO -import Control.Monad(when) - --- naming conventions - -noLang :: Options -> String -> String -noLang _ name = name - -withLang :: Options -> String -> String -withLang opts name = name ++ lang opts - -mkMod :: (Options -> String -> String) -> String -> Options -> String -mkMod addLang name opts = - pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name - where pref = maybe "" (++".") (inPackage opts) - -mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath -mkFile addLang name ext opts = - pref ++ if inDir opts - then lang opts ++ [pathSep] ++ name ++ ext' - else addLang opts name ++ if null ext then "" else ext' - where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts) - ext' = if null ext then "" else "." ++ ext - -absFile, absFileM, ocamllexFile, ocamllexFileM, dviFile, - ocamlyaccFile, ocamlyaccFileM, - latexFile, utilFile, utilFileM, - templateFile, templateFileM, - printerFile, printerFileM, - psFile, tFile, tFileM :: Options -> String -absFile = mkFile withLang "Abs" "ml" -absFileM = mkMod withLang "Abs" -ocamllexFile = mkFile withLang "Lex" "mll" -ocamllexFileM = mkMod withLang "Lex" -ocamlyaccFile = mkFile withLang "Par" "mly" -ocamlyaccFileM = mkMod withLang "Par" -latexFile = mkFile withLang "Doc" "tex" -templateFile = mkFile withLang "Skel" "ml" -templateFileM = mkMod withLang "Skel" -printerFile = mkFile withLang "Print" "ml" -printerFileM = mkMod withLang "Print" -showFile = mkFile withLang "Show" "ml" -showFileM = mkMod withLang "Show" -dviFile = mkFile withLang "Doc" "dvi" -psFile = mkFile withLang "Doc" "ps" -tFile = mkFile withLang "Test" "ml" -tFileM = mkMod withLang "Test" -utilFile = mkFile noLang "BNFC_Util" "ml" -utilFileM = mkMod noLang "BNFC_Util" -xmlFileM = mkMod withLang "XML" - -data Options = Options - { - make :: Bool, - alex1 :: Bool, - inDir :: Bool, - shareStrings :: Bool, - xml :: Int, - inPackage :: Maybe String, - lang :: String - } - --- FIXME: we probably don't need all these arguments -makeFSharp :: Bool -> Bool -> Bool -> Bool -> Bool -> Int - -> Maybe String -- ^ The hierarchical package to put the modules - -- in, or Nothing. - -> String -> FilePath -> IO () -makeFSharp m a1 d ss g x p n file = do - let opts = Options { make = m, alex1 = a1, inDir = d, shareStrings = ss, - xml = x, inPackage = p, lang = n } - - absMod = absFileM opts - lexMod = ocamllexFileM opts - parMod = ocamlyaccFileM opts - prMod = printerFileM opts - showMod = showFileM opts --- layMod = layoutFileM opts - utilMod = utilFileM opts - (cf, isOK) <- tryReadCF file - if isOK then do - let dir = codeDir opts - when (not (null dir)) $ do - putStrLn $ "Creating directory " ++ dir - prepareDir dir - writeFileRep (absFile opts) $ cf2Abstract absMod cf - writeFileRep (ocamllexFile opts) $ cf2ocamllex lexMod parMod cf - writeFileRep (ocamlyaccFile opts) $ - cf2ocamlyacc parMod absMod lexMod cf - writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf - writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod cf - writeFileRep (printerFile opts) $ cf2Printer prMod absMod cf - writeFileRep (showFile opts) $ cf2show showMod absMod cf - writeFileRep (tFile opts) $ ocamlTestfile absMod lexMod parMod prMod showMod cf - writeFileRep (utilFile opts) $ utilM - when (make opts) $ writeFileRep "Makefile" $ makefile opts - case xml opts of - 2 -> makeXML (lang opts) True cf - 1 -> makeXML (lang opts) False cf - _ -> return () - putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -pkgToDir :: String -> FilePath -pkgToDir s = replace '.' pathSep s - -codeDir :: Options -> FilePath -codeDir opts = let pref = maybe "" pkgToDir (inPackage opts) - dir = if inDir opts then lang opts else "" - sep = if null pref || null dir then "" else [pathSep] - in pref ++ sep ++ dir - -makefile :: Options -> String -makefile opts = makeA where - dir = let d = codeDir opts in if null d then "" else d ++ [pathSep] - cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")" - makeA = unlines - [ - "all:", - "\tfsyacc " ++ ocamlyaccFile opts, - "\tfslex " ++ ocamllexFile opts, - "\t" ++ cd ("latex " ++ basename (latexFile opts) - ++ "; " ++ "dvips " ++ basename (dviFile opts) - ++ " -o " ++ basename (psFile opts)), - "\tfsc -o " ++ mkFile withLang "Test" "exe" opts +++ - utilFile opts +++ - absFile opts +++ templateFile opts +++ - showFile opts +++ printerFile opts +++ - mkFile withLang "Par" "mli" opts +++ - mkFile withLang "Par" "ml" opts +++ - mkFile withLang "Lex" "fs" opts +++ - tFile opts, - "", - "clean:", - "\t-rm -f " ++ unwords (map (dir++) [ - "*.log", "*.aux", "*.cmi", - "*.cmo", "*.o", "*.dvi" - ]), - "\t-rm -f " ++ psFile opts, - "", - "distclean: clean", - "\t-rm -f " ++ unwords [ - mkFile withLang "Doc" "*" opts, - mkFile withLang "Lex" "*" opts, - mkFile withLang "Par" "*" opts, - mkFile withLang "Layout" "*" opts, - mkFile withLang "Skel" "*" opts, - mkFile withLang "Print" "*" opts, - mkFile withLang "Show" "*" opts, - mkFile withLang "Test" "*" opts, - mkFile withLang "Abs" "*" opts, - mkFile withLang "Test" "" opts, - utilFile opts, - "Makefile*" - ] - ] - - -utilM :: String -utilM = unlines - ["(* automatically generated by BNFC *)", - "", - "open Lexing", - "", - "(* this should really be in the parser, but ocamlyacc won't put it in the .mli *)", - "exception Parse_error of Lexing.position * Lexing.position" - ] - diff --git a/formats/haskell-gadt/CFtoAbstractGADT.hs b/formats/haskell-gadt/CFtoAbstractGADT.hs deleted file mode 100644 --- a/formats/haskell-gadt/CFtoAbstractGADT.hs +++ /dev/null @@ -1,147 +0,0 @@ -{- - BNF Converter: GADT Abstract syntax Generator - Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoAbstractGADT (cf2Abstract) where - -import CF -import Utils((+++),(++++)) -import Data.List(intersperse,nub) - -import HaskellGADTCommon - -import Data.Maybe (catMaybes) - --- to produce a Haskell module -cf2Abstract :: Bool -> String -> CF -> String -> String -cf2Abstract byteStrings name cf composOpMod = unlines $ [ - "{-# OPTIONS_GHC -fglasgow-exts #-}", - "module" +++ name +++ "(" ++ concat (intersperse ", " exports) ++ ")" +++ "where", - "", - "import " ++ composOpMod, - "", - "import Data.Monoid", - (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""), - "", - "-- Haskell module generated by the BNF converter", - ""] - ++ prDummyTypes cf - ++ [""] - ++ prTreeType byteStrings cf - ++ [""] - ++ prCompos cf - ++ [""] - ++ prShow cf - ++ [""] - ++ prEq cf - ++ [""] - ++ prOrd cf - where exports = ["Tree(..)"] - ++ getTreeCats cf - ++ ["johnMajorEq"] - ++ ["module " ++ composOpMod] - -getTreeCats :: CF -> [String] -getTreeCats cf = nub $ filter (not . isList) $ map consCat $ cf2cons cf - -prDummyTypes :: CF -> [String] -prDummyTypes cf = concatMap prDummyType $ getTreeCats cf - where - prDummyType cat = ["data" +++ t, "type" +++ cat +++ "= Tree" +++ t ] - where t = mkRealType cat - -mkRealType :: Cat -> String -mkRealType cat = cat ++ "_" -- FIXME: make sure that there is no such category already - -prTreeType :: Bool -> CF -> [String] -prTreeType byteStrings cf = ["data Tree :: * -> * where"] ++ map ((" "++) . prTreeCons) (cf2cons cf) - where - prTreeCons c - | isPositionCat cf cat = fun +++ ":: ((Int,Int),"++stringType++") -> Tree" +++ mkRealType cat - | otherwise = fun +++ "::" +++ concat [c +++ "-> " | (c,_) <- consVars c] ++ "Tree" +++ mkRealType cat - where (cat,fun) = (consCat c, consFun c) - stringType - | byteStrings = "BS.ByteString" - | otherwise = "String" - -prCompos :: CF -> [String] -prCompos cf = - ["instance Compos Tree where", - " compos r a f t = case t of"] - ++ map (" "++) (concatMap prComposCons cs - ++ if not (all isRecursive cs) then ["_ -> r t"] else []) - where - cs = cf2cons cf - prComposCons c - | isRecursive c = [consFun c +++ unwords (map snd (consVars c)) +++ "->" +++ rhs c] - | otherwise = [] - isRecursive c = any (isTreeType cf) (map fst (consVars c)) - rhs c = "r" +++ consFun c +++ unwords (map prRec (consVars c)) - where prRec (cat,var) | not (isTreeType cf cat) = "`a`" +++ "r" +++ var - | isList cat = "`a` foldr (a . a (r (:)) . f) (r [])" +++ var - | otherwise = "`a`" +++ "f" +++ var - -prShow :: CF -> [String] -prShow cf = ["instance Show (Tree c) where", - " showsPrec n t = case t of"] - ++ map (" "++) (map prShowCons cs) - ++ [" where opar n = if n > 0 then showChar '(' else id", - " cpar n = if n > 0 then showChar ')' else id"] - where - cs = cf2cons cf - prShowCons c | null vars = fun +++ "->" +++ "showString" +++ show fun - | otherwise = fun +++ unwords (map snd vars) +++ "->" - +++ "opar n . showString" +++ show fun - +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | (_,x) <- vars] - +++ ". cpar n" - where (fun, vars) = (consFun c, consVars c) - -prEq :: CF -> [String] -prEq cf = ["instance Eq (Tree c) where (==) = johnMajorEq", - "", - "johnMajorEq :: Tree a -> Tree b -> Bool"] - ++ map (prEqCons) (cf2cons cf) - ++ ["johnMajorEq _ _ = False"] - where prEqCons c - | null vars = "johnMajorEq" +++ fun +++ fun +++ "=" +++ "True" - | otherwise = "johnMajorEq" +++ "(" ++ fun +++ unwords vars ++ ")" - +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "=" - +++ (concat $ intersperse " && " $ zipWith (\x y -> x +++ "==" +++ y) vars vars') - where (fun, vars) = (consFun c, map snd (consVars c)) - vars' = map (++"_") vars - -prOrd :: CF -> [String] -prOrd cf = ["instance Ord (Tree c) where", - " compare x y = compare (index x) (index y) `mappend` compareSame x y"] ++ - ["index :: Tree c -> Int"] ++ - zipWith (\ c i -> mkIndex c i) cs [0..] ++ - ["compareSame :: Tree c -> Tree c -> Ordering"] ++ - map mkCompareSame cs ++ - ["compareSame x y = error \"BNFC error:\" compareSame"] - where cs = cf2cons cf - mkCompareSame c - | null vars = "compareSame" +++ fun +++ fun +++ "=" +++ "EQ" - | otherwise = "compareSame" +++ "(" ++ fun +++ unwords vars ++ ")" - +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "=" - +++ foldr1 (\x y -> "mappend (" ++ x ++") ("++y++")") cc - where (fun, vars) = (consFun c, map snd (consVars c)) - vars' = map (++"_") vars - cc = zipWith (\x y -> "compare"+++x+++y) vars vars' - mkIndex c i = "index" +++ "(" ++ consFun c - +++ unwords (replicate (length (consVars c)) "_") ++ ")" - +++ "=" +++ show i diff --git a/formats/haskell-gadt/CFtoPrinterGADT.hs b/formats/haskell-gadt/CFtoPrinterGADT.hs deleted file mode 100644 --- a/formats/haskell-gadt/CFtoPrinterGADT.hs +++ /dev/null @@ -1,167 +0,0 @@ -{- - BNF Converter: GADT Pretty-printer generator - Copyright (C) 2004-2005 Author: Aarne Ranta, Björn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoPrinterGADT (cf2Printer) where - -import CF -import Utils -import CFtoTemplate -import Data.List (intersperse) -import Data.Char(toLower) - -import HaskellGADTCommon - --- derive pretty-printer from a BNF grammar. AR 15/2/2002 -cf2Printer :: String -> String -> CF -> String -cf2Printer name absMod cf = unlines $ [ - prologue name absMod, - integerRule cf, - doubleRule cf] - ++ prPrt cf - ++ [""] - ++ concatMap (prPrtList cf) (filter isList (allCats cf)) - -prologue :: String -> String -> String -prologue name absMod = unlines [ - "{-# OPTIONS_GHC -fglasgow-exts #-}", - "module " ++ name +++ "where\n", - "-- pretty-printer generated by the BNF converter\n", - "import " ++ absMod, - "import Data.Char", - "import Data.List (intersperse)", - "", - "-- 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", - "", - "unwordsD :: [Doc] -> Doc", - "unwordsD = concatD . intersperse (doc (showChar ' '))", - "", - "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", - "", - "instance Print Char where", - " prt _ s = doc (showChar '\\'' . mkEsc '\\'' s . showChar '\\'')", - "", - "instance Print String where", - " prt _ 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 Cat -> [String] -ifList cf cat = prPrtList cf ("["++cat++"]") -- FIXME: hackish - -prPrt :: CF -> [String] -prPrt cf = ["instance Print (Tree c) where", - " prt _i e = case e of" - ] ++ map prPrtCons (cf2cons cf) - where - prPrtCons c = " " ++ consFun c +++ unwords (vars c) +++ "->" +++ - "prPrec _i" +++ show (consPrec c) +++ rhs - -- for token rules, just print the string argument unquoted - where rhs | isToken c = let [v] = vars c in "(doc (showString " ++ v ++ "))" - | otherwise = mkRhs (vars c) (consRhs c) - vars = map snd . consVars - isToken c = consCat c `elem` specialCats cf - -prPrtList :: CF -> Cat -> [String] -prPrtList cf cat = mkListRule (nil ++ one ++ cons) - where - nil = [" [] -> " ++ mkRhs [] its | - (f,(_,its)) <- rules, isNilFun f] - one = [" [x] -> " ++ mkRhs ["x"] its | - (f,(_,its)) <- rules, isOneFun f] - cons = [" x:xs -> " ++ mkRhs ["x","xs"] its | - (f,(_,its)) <- rules, isConsFun f] - mkListRule [] = [] - mkListRule rs = ["instance Print" +++ cat +++ "where", - " prt _" +++ "es = case es of"] ++ rs - rules = rulesForCat cf cat - -mkRhs :: [String] -> [Either Cat String] -> String -mkRhs args its = - "(concatD [" ++ unwords (intersperse "," (mk args its)) ++ "])" - where - mk args (Left "#" : items) = mk args items - mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items - mk args (Right s : items) = ("doc (showString" +++ show s ++ ")") : mk args items - mk _ _ = [] - prt c = "prt" +++ show (precCat c) - diff --git a/formats/haskell-gadt/CFtoTemplateGADT.hs b/formats/haskell-gadt/CFtoTemplateGADT.hs deleted file mode 100644 --- a/formats/haskell-gadt/CFtoTemplateGADT.hs +++ /dev/null @@ -1,65 +0,0 @@ -{- - BNF Converter: GADT Template Generator - Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - - -module CFtoTemplateGADT ( - cf2Template - ) where - -import CF -import Utils((+++)) -import Data.List (delete,groupBy) - -import HaskellGADTCommon - -type ModuleName = String - -cf2Template :: ModuleName -> ModuleName -> ModuleName -> CF -> String -cf2Template skelName absName errName cf = unlines $ - [ - "module "++ skelName ++ " where", - "", - "-- Haskell module generated by the BNF converter", - "", - "import " ++ absName, - "import " ++ errName, - "type Result = Err String\n", - "failure :: Show a => a -> Result", - "failure x = Bad $ \"Undefined case: \" ++ show x", - "", - "transTree :: Tree c -> Result", - "transTree t = case t of"] - ++ map prConsCase (cf2cons cf) - ++ [""] - ++ concatMap ((++[""]) . uncurry prCatTrans) (catCons cf) - -prConsCase :: Constructor -> String -prConsCase c = - " " ++ consFun c +++ unwords (map snd (consVars c)) +++ "-> failure t" - -catCons :: CF -> [(Cat,[Constructor])] -catCons cf = [ (consCat (head cs),cs) | cs <- groupBy catEq $ cf2cons cf] - -catEq :: Constructor -> Constructor -> Bool -catEq c1 c2 = consCat c1 == consCat c2 - -prCatTrans :: Cat -> [Constructor] -> [String] -prCatTrans cat cs = ["trans" ++ cat +++ "::" +++ cat +++ "-> Result", - "trans" ++ cat +++ "t = case t of"] - ++ map prConsCase cs diff --git a/formats/haskell-gadt/HaskellGADTCommon.hs b/formats/haskell-gadt/HaskellGADTCommon.hs deleted file mode 100644 --- a/formats/haskell-gadt/HaskellGADTCommon.hs +++ /dev/null @@ -1,83 +0,0 @@ -{- - BNF Converter: Haskell GADT back-end common stuff - Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module HaskellGADTCommon (Constructor(..), cf2cons, isTreeType) where - -import CF - -import Data.Char - -data Constructor = Constructor { - consCat :: Cat, - consFun :: Fun, - consPrec :: Int, - consVars :: [(Cat,String)], - consRhs :: [Either Cat String] - } - --- | Get category, function, and rhs categories paired with variable names. -cf2cons :: CF -> [Constructor] -cf2cons cf = [ Constructor { consCat = cat, - consFun = fun, - consPrec = precFun cf fun, - consVars = zip cats (mkVars cats), - consRhs = rhsFun cf fun} - | (cat,rules) <- cf2data cf, (fun,cats) <- rules] - ++ [ Constructor { consCat = cat, - consFun = cat, - consPrec = 0, - consVars = [("String","str")], - consRhs = [Left "String"]} - | cat <- specialCats cf] - where mkVars cats = mkUnique (map catToVar cats) (0 :: Int) - mkUnique [] _ = [] - mkUnique (x:xs) n | elem x xs || n > 0 = (x ++ show n) : mkUnique xs (n+1) - | otherwise = x : mkUnique xs n - --- | Make a variable name for a category. -catToVar :: Cat -> String -catToVar = checkRes . var - where var cat | isList cat = var (normCatOfList cat) ++ "s" - var "Ident" = "i" - var "Integer" = "n" - var "String" = "str" - var "Char" = "c" - var "Double" = "d" - var xs = map toLower xs - checkRes s | elem s reservedHaskell = s ++ "'" - | otherwise = s - reservedHaskell = ["case","class","data","default","deriving","do","else","if", - "import","in","infix","infixl","infixr","instance","let","module", - "newtype","of","then","type","where","as","qualified","hiding"] - --- | Get the rule for a function. -ruleFun :: CF -> Fun -> Rule -ruleFun cf f = head $ filter (\r -> funRule r == f) $ rulesOfCF cf - --- | Get the precedence of a function. -precFun :: CF -> Fun -> Int -precFun cf f = precRule $ ruleFun cf f - --- | Get the RHS of a function -rhsFun :: CF -> Fun -> [Either Cat String] -rhsFun cf f = rhsRule $ ruleFun cf f - -isTreeType :: CF -> Cat -> Bool -isTreeType cf c | isList c = isTreeType cf (catOfList c) - | otherwise = c `elem` (allCats cf ++ specialCats cf) diff --git a/formats/haskell-gadt/HaskellTopGADT.hs b/formats/haskell-gadt/HaskellTopGADT.hs deleted file mode 100644 --- a/formats/haskell-gadt/HaskellTopGADT.hs +++ /dev/null @@ -1,388 +0,0 @@ -{- - BNF Converter: Haskell main file - Copyright (C) 2004-2005 Author: Markus Forberg, Peter Gammie, - Aarne Ranta, Björn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module HaskellTopGADT (makeAllGADT) where - - - --- import Utils -import CF -import CFtoHappy -import CFtoAlex -import CFtoAlex2 -import CFtoLatex -import CFtoAbstractGADT -import CFtoTemplateGADT -import CFtoPrinterGADT -import CFtoLayout -import CFtoXML -import MkErrM -import MkSharedString --- import CFtoGF ( cf2AbsGF, cf2ConcGF ) --- import System.IO -import GetCF -import Utils - -import Data.Char -import Data.Maybe (fromMaybe,maybe) -import System.IO -import System.Exit -import Control.Monad(when) - --- naming conventions - -noLang :: Options -> String -> String -noLang _ name = name - -withLang :: Options -> String -> String -withLang opts name = name ++ lang opts - -mkMod :: (Options -> String -> String) -> String -> Options -> String -mkMod addLang name opts = - pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name - where pref = maybe "" (++".") (inPackage opts) - -mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath -mkFile addLang name ext opts = - pref ++ if inDir opts - then lang opts ++ [pathSep] ++ name ++ ext' - else addLang opts name ++ if null ext then "" else ext' - where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts) - ext' = if null ext then "" else "." ++ ext - -absFile, absFileM, alexFile, alexFileM, dviFile, - composOpFile, composOpFileM, - gfAbs, gfConc, - happyFile, happyFileM, - latexFile, errFile, errFileM, - templateFile, templateFileM, - printerFile, printerFileM, - layoutFile, layoutFileM, - psFile, tFile, tFileM :: Options -> String -absFile = mkFile withLang "Abs" "hs" -absFileM = mkMod withLang "Abs" -alexFile = mkFile withLang "Lex" "x" -alexFileM = mkMod withLang "Lex" -composOpFile = mkFile noLang "ComposOp" "hs" -composOpFileM = mkMod noLang "ComposOp" -happyFile = mkFile withLang "Par" "y" -happyFileM = mkMod withLang "Par" -latexFile = mkFile withLang "Doc" "tex" -templateFile = mkFile withLang "Skel" "hs" -templateFileM = mkMod withLang "Skel" -printerFile = mkFile withLang "Print" "hs" -printerFileM = mkMod withLang "Print" -dviFile = mkFile withLang "Doc" "dvi" -psFile = mkFile withLang "Doc" "ps" -gfAbs = mkFile withLang "" "Abs.gf" -gfConc = mkFile withLang "" "Conc.gf" -tFile = mkFile withLang "Test" "hs" -tFileM = mkMod withLang "Test" -errFile = mkFile noLang "ErrM" "hs" -errFileM = mkMod noLang "ErrM" -shareFile = mkFile noLang "SharedString" "hs" -shareFileM = mkMod noLang "SharedString" -layoutFileM = mkMod withLang "Layout" -xmlFileM = mkMod withLang "XML" -layoutFile = mkFile withLang "Layout" "hs" - -data Options = Options - { - make :: Bool, - alex1 :: Bool, - inDir :: Bool, - shareStrings :: Bool, - byteStrings :: Bool, - glr :: HappyMode, - xml :: Int, - inPackage :: Maybe String, - lang :: String - } - -makeAllGADT :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int - -> Maybe String -- ^ The hierarchical package to put the modules - -- in, or Nothing. - -> String -> FilePath -> IO () -makeAllGADT m a1 d ss bs g x p n file = do - let opts = Options { make = m, alex1 = a1, inDir = d, shareStrings = ss, byteStrings = bs, - glr = if g then GLR else Standard, xml = x, - inPackage = p, lang = n } - - absMod = absFileM opts - composOpMod = composOpFileM opts - lexMod = alexFileM opts - parMod = happyFileM opts - prMod = printerFileM opts - layMod = layoutFileM opts - errMod = errFileM opts - shareMod = shareFileM opts - (cf, isOK) <- tryReadCF file - if isOK then do - let dir = codeDir opts - when (not (null dir)) $ do - putStrLn $ "Creating directory " ++ dir - prepareDir dir - writeFileRep (absFile opts) $ cf2Abstract (byteStrings opts) absMod cf composOpMod - writeFileRep (composOpFile opts) $ composOp composOpMod - if alex1 opts then do - writeFileRep (alexFile opts) $ cf2alex lexMod errMod cf - putStrLn " (Use Alex 1.1 to compile.)" - else do - writeFileRep (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf - putStrLn " (Use Alex 2.0 to compile.)" - writeFileRep (happyFile opts) $ - cf2HappyS parMod absMod lexMod errMod (glr opts) (byteStrings opts) cf - putStrLn " (Tested with Happy 1.15)" - writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf - writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod cf - writeFileRep (printerFile opts) $ cf2Printer prMod absMod cf - when (hasLayout cf) $ writeFileRep (layoutFile opts) $ cf2Layout (alex1 opts) (inDir opts) layMod lexMod cf - writeFileRep (tFile opts) $ testfile opts cf - writeFileRep (errFile opts) $ errM errMod cf - when (shareStrings opts) $ writeFileRep (shareFile opts) $ sharedString shareMod (byteStrings opts) cf - when (make opts) $ writeFileRep "Makefile" $ makefile opts - case xml opts of - 2 -> makeXML (lang opts) True cf - 1 -> makeXML (lang opts) False cf - _ -> return () - putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -pkgToDir :: String -> FilePath -pkgToDir s = replace '.' pathSep s - -codeDir :: Options -> FilePath -codeDir opts = let pref = maybe "" pkgToDir (inPackage opts) - dir = if inDir opts then lang opts else "" - sep = if null pref || null dir then "" else [pathSep] - in pref ++ sep ++ dir - -makefile :: Options -> String -makefile opts = makeA where - glr_params = if glr opts == GLR then "--glr --decode " else "" - dir = let d = codeDir opts in if null d then "" else d ++ [pathSep] - cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")" - makeA = unlines - [ - "all:", - "\thappy -gca " ++ glr_params ++ happyFile opts, - "\talex -g " ++ alexFile opts, - "\t" ++ cd ("latex " ++ basename (latexFile opts) - ++ "; " ++ "dvips " ++ basename (dviFile opts) - ++ " -o " ++ basename (psFile opts)), - "\tghc --make " ++ tFile opts ++ " -o " ++ mkFile withLang "Test" "" opts, - "clean:", - "\t-rm -f " ++ unwords (map (dir++) [ - "*.log", "*.aux", "*.hi", - "*.o", "*.dvi" - ]), - "\t-rm -f " ++ psFile opts, - - "distclean: clean", - "\t-rm -f " ++ unwords [ - mkFile withLang "Doc" "*" opts, - mkFile withLang "Lex" "*" opts, - mkFile withLang "Par" "*" opts, - mkFile withLang "Layout" "*" opts, - mkFile withLang "Skel" "*" opts, - mkFile withLang "Print" "*" opts, - mkFile withLang "Test" "*" opts, - mkFile withLang "Abs" "*" opts, - mkFile withLang "ComposOp" "*" opts, - mkFile withLang "Test" "" opts, - mkFile noLang "ErrM" "*" opts, - mkFile noLang "SharedString" "*" opts, - dir ++ lang opts ++ ".dtd", - mkFile withLang "XML" "*" opts, - "Makefile*" - ], - if null dir then "" else "\t-rmdir -p " ++ dir - ] - - -testfile :: Options -> CF -> String -testfile opts cf - = let lay = hasLayout cf - use_xml = xml opts > 0 - xpr = if use_xml then "XPrint a, " else "" - use_glr = glr opts == GLR - if_glr s = if use_glr then s else "" - firstParser = if use_glr then "the_parser" else parserName - parserName = 'p' : topType - topType = firstEntry cf - in unlines - ["-- automatically generated by BNF Converter", - "module Main where\n", - "", - "import System.IO ( stdin, hGetContents )", - "import System.IO ( getArgs, getProgName )", - "", - "import " ++ alexFileM opts, - "import " ++ happyFileM opts, - "import " ++ templateFileM opts, - "import " ++ printerFileM opts, - "import " ++ absFileM opts, - if lay then ("import " ++ layoutFileM opts) else "", - if use_xml then ("import " ++ xmlFileM opts) else "", - if_glr "import Data.FiniteMap(FiniteMap, lookupFM, fmToList)", - if_glr "import Data.Maybe(fromJust)", - "import " ++ errFileM opts, - "", - if use_glr - then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))" - else "type ParseFun a = [Token] -> Err a", - "", - "myLLexer = " ++ if lay then "resolveLayout True . myLexer" - else "myLexer", - "", - "type Verbosity = Int", - "", - "putStrV :: Verbosity -> String -> IO ()", - "putStrV v s = if v > 1 then putStrLn s else return ()", - "", - "runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()", - "runFile v p f = putStrLn f >> readFile f >>= run v p", - "", - "run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()", - if use_glr then run_glr else run_std use_xml, - "", - "showTree :: (Show a, Print a) => Int -> a -> IO ()", - "showTree v tree", - " = do", - " putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree", - " putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree", - "", - "main :: IO ()", - "main = do args <- getArgs", - " case args of", - " [] -> hGetContents stdin >>= run 2 " ++ firstParser, - " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs", - " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs", - "", - if_glr $ "the_parser :: ParseFun " ++ topType, - if_glr $ "the_parser = lift_parser " ++ parserName, - if_glr $ "", - if_glr $ lift_parser - ] - -run_std xml - = unlines - [ "run v p s = let ts = myLLexer s in case p ts of" - , " Bad s -> do putStrLn \"\\nParse Failed...\\n\"" - , " putStrV v \"Tokens:\"" - , " putStrV v $ show ts" - , " putStrLn s" - , " Ok tree -> do putStrLn \"\\nParse Successful!\"" - , " showTree v tree" - , if xml then - " putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree" - else "" - ] - -run_glr - = unlines - [ "run v p s" - , " = let ts = map (:[]) $ myLLexer s" - , " (raw_output, simple_output) = p ts in" - , " case simple_output of" - , " GLR_Fail major minor -> do" - , " putStrLn major" - , " putStrV v minor" - , " GLR_Result df trees -> do" - , " putStrLn \"\\nParse Successful!\"" - , " case trees of" - , " [] -> error \"No results but parse succeeded?\"" - , " [Ok x] -> showTree v x" - , " xs@(_:_) -> showSeveralTrees v xs" - , " where" - , " showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()" - , " showSeveralTrees v trees" - , " = sequence_ " - , " [ do putStrV v (replicate 40 '-')" - , " putStrV v $ \"Parse number: \" ++ show n" - , " showTree v t" - , " | (Ok t,n) <- zip trees [1..]" - , " ]" - ] - - -lift_parser - = unlines - [ "type Forest = FiniteMap ForestId [Branch] -- omitted in ParX export." - , "data GLR_Output a" - , " = GLR_Result { pruned_decode :: (Forest -> Forest) -> [a]" - , " , semantic_result :: [a]" - , " }" - , " | GLR_Fail { main_message :: String" - , " , extra_info :: String" - , " }" - , "" - , "lift_parser" - , " :: (TreeDecode a, Show a, Print a)" - , " => ([[Token]] -> GLRResult) -> ParseFun a" - , "lift_parser parser ts" - , " = let result = parser ts in" - , " (\\o -> (result, o)) $" - , " case result of" - , " ParseError ts f -> GLR_Fail \"Parse failed, unexpected token(s)\\n\"" - , " (\"Tokens: \" ++ show ts)" - , " ParseEOF f -> GLR_Fail \"Parse failed, unexpected EOF\\n\"" - , " (\"Partial forest:\\n\"" - , " ++ unlines (map show $ fmToList f))" - , " ParseOK r f -> let find f = fromJust . lookupFM f" - , " dec_fn f = decode (find f) r" - , " in GLR_Result (\\ff -> dec_fn $ ff f) (dec_fn f)" - ] - -composOp :: String -> String -composOp composOpMod = unlines - [ - "{-# OPTIONS_GHC -fglasgow-exts #-}", - "module " ++ composOpMod ++ " (Compos(..),composOp,composOpM,composOpM_,composOpMonoid,", - " composOpMPlus,composOpFold) where", - "", - "import Control.Monad.Identity", - "import Data.Monoid", - "", - "class Compos t where", - " compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)", - " -> (forall a. t a -> m (t a)) -> t c -> m (t c)", - "", - "composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c", - "composOp f = runIdentity . composOpM (Identity . f)", - "", - "composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)", - "composOpM = compos return ap", - "", - "composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()", - "composOpM_ = composOpFold (return ()) (>>)", - "", - "composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m", - "composOpMonoid = composOpFold mempty mappend", - "", - "composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b", - "composOpMPlus = composOpFold mzero mplus", - "", - "composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b", - "composOpFold z c f = unC . compos (\\_ -> C z) (\\(C x) (C y) -> C (c x y)) (C . f)", - "", - "newtype C b a = C { unC :: b }" - ] diff --git a/formats/haskell-gadt/HaskellTopGADT.hs~ b/formats/haskell-gadt/HaskellTopGADT.hs~ deleted file mode 100644 --- a/formats/haskell-gadt/HaskellTopGADT.hs~ +++ /dev/null @@ -1,387 +0,0 @@ -{- - BNF Converter: Haskell main file - Copyright (C) 2004-2005 Author: Markus Forberg, Peter Gammie, - Aarne Ranta, Björn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module HaskellTopGADT (makeAllGADT) where - - - --- import Utils -import CF -import CFtoHappy -import CFtoAlex -import CFtoAlex2 -import CFtoLatex -import CFtoAbstractGADT -import CFtoTemplateGADT -import CFtoPrinterGADT -import CFtoLayout -import CFtoXML -import MkErrM -import MkSharedString --- import CFtoGF ( cf2AbsGF, cf2ConcGF ) --- import System.IO -import GetCF -import Utils - -import Data.Char -import Data.Maybe (fromMaybe,maybe) -import System.IO -import Control.Monad(when) - --- naming conventions - -noLang :: Options -> String -> String -noLang _ name = name - -withLang :: Options -> String -> String -withLang opts name = name ++ lang opts - -mkMod :: (Options -> String -> String) -> String -> Options -> String -mkMod addLang name opts = - pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name - where pref = maybe "" (++".") (inPackage opts) - -mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath -mkFile addLang name ext opts = - pref ++ if inDir opts - then lang opts ++ [pathSep] ++ name ++ ext' - else addLang opts name ++ if null ext then "" else ext' - where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts) - ext' = if null ext then "" else "." ++ ext - -absFile, absFileM, alexFile, alexFileM, dviFile, - composOpFile, composOpFileM, - gfAbs, gfConc, - happyFile, happyFileM, - latexFile, errFile, errFileM, - templateFile, templateFileM, - printerFile, printerFileM, - layoutFile, layoutFileM, - psFile, tFile, tFileM :: Options -> String -absFile = mkFile withLang "Abs" "hs" -absFileM = mkMod withLang "Abs" -alexFile = mkFile withLang "Lex" "x" -alexFileM = mkMod withLang "Lex" -composOpFile = mkFile noLang "ComposOp" "hs" -composOpFileM = mkMod noLang "ComposOp" -happyFile = mkFile withLang "Par" "y" -happyFileM = mkMod withLang "Par" -latexFile = mkFile withLang "Doc" "tex" -templateFile = mkFile withLang "Skel" "hs" -templateFileM = mkMod withLang "Skel" -printerFile = mkFile withLang "Print" "hs" -printerFileM = mkMod withLang "Print" -dviFile = mkFile withLang "Doc" "dvi" -psFile = mkFile withLang "Doc" "ps" -gfAbs = mkFile withLang "" "Abs.gf" -gfConc = mkFile withLang "" "Conc.gf" -tFile = mkFile withLang "Test" "hs" -tFileM = mkMod withLang "Test" -errFile = mkFile noLang "ErrM" "hs" -errFileM = mkMod noLang "ErrM" -shareFile = mkFile noLang "SharedString" "hs" -shareFileM = mkMod noLang "SharedString" -layoutFileM = mkMod withLang "Layout" -xmlFileM = mkMod withLang "XML" -layoutFile = mkFile withLang "Layout" "hs" - -data Options = Options - { - make :: Bool, - alex1 :: Bool, - inDir :: Bool, - shareStrings :: Bool, - byteStrings :: Bool, - glr :: HappyMode, - xml :: Int, - inPackage :: Maybe String, - lang :: String - } - -makeAllGADT :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int - -> Maybe String -- ^ The hierarchical package to put the modules - -- in, or Nothing. - -> String -> FilePath -> IO () -makeAllGADT m a1 d ss bs g x p n file = do - let opts = Options { make = m, alex1 = a1, inDir = d, shareStrings = ss, byteStrings = bs, - glr = if g then GLR else Standard, xml = x, - inPackage = p, lang = n } - - absMod = absFileM opts - composOpMod = composOpFileM opts - lexMod = alexFileM opts - parMod = happyFileM opts - prMod = printerFileM opts - layMod = layoutFileM opts - errMod = errFileM opts - shareMod = shareFileM opts - (cf, isOK) <- tryReadCF file - if isOK then do - let dir = codeDir opts - when (not (null dir)) $ do - putStrLn $ "Creating directory " ++ dir - prepareDir dir - writeFileRep (absFile opts) $ cf2Abstract (byteStrings opts) absMod cf composOpMod - writeFileRep (composOpFile opts) $ composOp composOpMod - if alex1 opts then do - writeFileRep (alexFile opts) $ cf2alex lexMod errMod cf - putStrLn " (Use Alex 1.1 to compile.)" - else do - writeFileRep (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf - putStrLn " (Use Alex 2.0 to compile.)" - writeFileRep (happyFile opts) $ - cf2HappyS parMod absMod lexMod errMod (glr opts) (byteStrings opts) cf - putStrLn " (Tested with Happy 1.15)" - writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf - writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod cf - writeFileRep (printerFile opts) $ cf2Printer prMod absMod cf - when (hasLayout cf) $ writeFileRep (layoutFile opts) $ cf2Layout (alex1 opts) (inDir opts) layMod lexMod cf - writeFileRep (tFile opts) $ testfile opts cf - writeFileRep (errFile opts) $ errM errMod cf - when (shareStrings opts) $ writeFileRep (shareFile opts) $ sharedString shareMod (byteStrings opts) cf - when (make opts) $ writeFileRep "Makefile" $ makefile opts - case xml opts of - 2 -> makeXML (lang opts) True cf - 1 -> makeXML (lang opts) False cf - _ -> return () - putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -pkgToDir :: String -> FilePath -pkgToDir s = replace '.' pathSep s - -codeDir :: Options -> FilePath -codeDir opts = let pref = maybe "" pkgToDir (inPackage opts) - dir = if inDir opts then lang opts else "" - sep = if null pref || null dir then "" else [pathSep] - in pref ++ sep ++ dir - -makefile :: Options -> String -makefile opts = makeA where - glr_params = if glr opts == GLR then "--glr --decode " else "" - dir = let d = codeDir opts in if null d then "" else d ++ [pathSep] - cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")" - makeA = unlines - [ - "all:", - "\thappy -gca " ++ glr_params ++ happyFile opts, - "\talex -g " ++ alexFile opts, - "\t" ++ cd ("latex " ++ basename (latexFile opts) - ++ "; " ++ "dvips " ++ basename (dviFile opts) - ++ " -o " ++ basename (psFile opts)), - "\tghc --make " ++ tFile opts ++ " -o " ++ mkFile withLang "Test" "" opts, - "clean:", - "\t-rm -f " ++ unwords (map (dir++) [ - "*.log", "*.aux", "*.hi", - "*.o", "*.dvi" - ]), - "\t-rm -f " ++ psFile opts, - - "distclean: clean", - "\t-rm -f " ++ unwords [ - mkFile withLang "Doc" "*" opts, - mkFile withLang "Lex" "*" opts, - mkFile withLang "Par" "*" opts, - mkFile withLang "Layout" "*" opts, - mkFile withLang "Skel" "*" opts, - mkFile withLang "Print" "*" opts, - mkFile withLang "Test" "*" opts, - mkFile withLang "Abs" "*" opts, - mkFile withLang "ComposOp" "*" opts, - mkFile withLang "Test" "" opts, - mkFile noLang "ErrM" "*" opts, - mkFile noLang "SharedString" "*" opts, - dir ++ lang opts ++ ".dtd", - mkFile withLang "XML" "*" opts, - "Makefile*" - ], - if null dir then "" else "\t-rmdir -p " ++ dir - ] - - -testfile :: Options -> CF -> String -testfile opts cf - = let lay = hasLayout cf - use_xml = xml opts > 0 - xpr = if use_xml then "XPrint a, " else "" - use_glr = glr opts == GLR - if_glr s = if use_glr then s else "" - firstParser = if use_glr then "the_parser" else parserName - parserName = 'p' : topType - topType = firstEntry cf - in unlines - ["-- automatically generated by BNF Converter", - "module Main where\n", - "", - "import System.IO ( stdin, hGetContents )", - "import System.IO ( getArgs, getProgName )", - "", - "import " ++ alexFileM opts, - "import " ++ happyFileM opts, - "import " ++ templateFileM opts, - "import " ++ printerFileM opts, - "import " ++ absFileM opts, - if lay then ("import " ++ layoutFileM opts) else "", - if use_xml then ("import " ++ xmlFileM opts) else "", - if_glr "import Data.FiniteMap(FiniteMap, lookupFM, fmToList)", - if_glr "import Data.Maybe(fromJust)", - "import " ++ errFileM opts, - "", - if use_glr - then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))" - else "type ParseFun a = [Token] -> Err a", - "", - "myLLexer = " ++ if lay then "resolveLayout True . myLexer" - else "myLexer", - "", - "type Verbosity = Int", - "", - "putStrV :: Verbosity -> String -> IO ()", - "putStrV v s = if v > 1 then putStrLn s else return ()", - "", - "runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()", - "runFile v p f = putStrLn f >> readFile f >>= run v p", - "", - "run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()", - if use_glr then run_glr else run_std use_xml, - "", - "showTree :: (Show a, Print a) => Int -> a -> IO ()", - "showTree v tree", - " = do", - " putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree", - " putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree", - "", - "main :: IO ()", - "main = do args <- getArgs", - " case args of", - " [] -> hGetContents stdin >>= run 2 " ++ firstParser, - " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs", - " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs", - "", - if_glr $ "the_parser :: ParseFun " ++ topType, - if_glr $ "the_parser = lift_parser " ++ parserName, - if_glr $ "", - if_glr $ lift_parser - ] - -run_std xml - = unlines - [ "run v p s = let ts = myLLexer s in case p ts of" - , " Bad s -> do putStrLn \"\\nParse Failed...\\n\"" - , " putStrV v \"Tokens:\"" - , " putStrV v $ show ts" - , " putStrLn s" - , " Ok tree -> do putStrLn \"\\nParse Successful!\"" - , " showTree v tree" - , if xml then - " putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree" - else "" - ] - -run_glr - = unlines - [ "run v p s" - , " = let ts = map (:[]) $ myLLexer s" - , " (raw_output, simple_output) = p ts in" - , " case simple_output of" - , " GLR_Fail major minor -> do" - , " putStrLn major" - , " putStrV v minor" - , " GLR_Result df trees -> do" - , " putStrLn \"\\nParse Successful!\"" - , " case trees of" - , " [] -> error \"No results but parse succeeded?\"" - , " [Ok x] -> showTree v x" - , " xs@(_:_) -> showSeveralTrees v xs" - , " where" - , " showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()" - , " showSeveralTrees v trees" - , " = sequence_ " - , " [ do putStrV v (replicate 40 '-')" - , " putStrV v $ \"Parse number: \" ++ show n" - , " showTree v t" - , " | (Ok t,n) <- zip trees [1..]" - , " ]" - ] - - -lift_parser - = unlines - [ "type Forest = FiniteMap ForestId [Branch] -- omitted in ParX export." - , "data GLR_Output a" - , " = GLR_Result { pruned_decode :: (Forest -> Forest) -> [a]" - , " , semantic_result :: [a]" - , " }" - , " | GLR_Fail { main_message :: String" - , " , extra_info :: String" - , " }" - , "" - , "lift_parser" - , " :: (TreeDecode a, Show a, Print a)" - , " => ([[Token]] -> GLRResult) -> ParseFun a" - , "lift_parser parser ts" - , " = let result = parser ts in" - , " (\\o -> (result, o)) $" - , " case result of" - , " ParseError ts f -> GLR_Fail \"Parse failed, unexpected token(s)\\n\"" - , " (\"Tokens: \" ++ show ts)" - , " ParseEOF f -> GLR_Fail \"Parse failed, unexpected EOF\\n\"" - , " (\"Partial forest:\\n\"" - , " ++ unlines (map show $ fmToList f))" - , " ParseOK r f -> let find f = fromJust . lookupFM f" - , " dec_fn f = decode (find f) r" - , " in GLR_Result (\\ff -> dec_fn $ ff f) (dec_fn f)" - ] - -composOp :: String -> String -composOp composOpMod = unlines - [ - "{-# OPTIONS_GHC -fglasgow-exts #-}", - "module " ++ composOpMod ++ " (Compos(..),composOp,composOpM,composOpM_,composOpMonoid,", - " composOpMPlus,composOpFold) where", - "", - "import Control.Monad.Identity", - "import Data.Monoid", - "", - "class Compos t where", - " compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)", - " -> (forall a. t a -> m (t a)) -> t c -> m (t c)", - "", - "composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c", - "composOp f = runIdentity . composOpM (Identity . f)", - "", - "composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)", - "composOpM = compos return ap", - "", - "composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()", - "composOpM_ = composOpFold (return ()) (>>)", - "", - "composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m", - "composOpMonoid = composOpFold mempty mappend", - "", - "composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b", - "composOpMPlus = composOpFold mzero mplus", - "", - "composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b", - "composOpFold z c f = unC . compos (\\_ -> C z) (\\(C x) (C y) -> C (c x y)) (C . f)", - "", - "newtype C b a = C { unC :: b }" - ] diff --git a/formats/haskell2/CFtoAbstract.hs b/formats/haskell2/CFtoAbstract.hs deleted file mode 100644 --- a/formats/haskell2/CFtoAbstract.hs +++ /dev/null @@ -1,51 +0,0 @@ -{- - BNF Converter: Abstract syntax Generator - Copyright (C) 2004 Author: Markus Forberg - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoAbstract (cf2Abstract) where - -import CF -import Utils((+++),(++++)) -import Data.List(intersperse) - --- to produce a Haskell module -cf2Abstract :: Bool -> String -> CF -> String -cf2Abstract byteStrings name cf = unlines $ - ("module "++name +++ "where\n") : - "-- Haskell module generated by the BNF converter\n" : - (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "") : - (map (prSpecialData byteStrings cf) (specialCats cf) ++ map prData (cf2data cf)) - -prData :: Data -> String -prData (cat,rules) = - "data" +++ cat +++ "=\n " ++ - concat (intersperse "\n | " (map prRule rules)) ++++ - " deriving (Eq,Ord,Show)\n" - where - prRule (fun,cats) = unwords (fun:cats) - -prSpecialData :: Bool -> CF -> Cat -> String -prSpecialData byteStrings cf cat = - unwords ["newtype",cat,"=",cat,contentSpec byteStrings cf cat,"deriving (Eq,Ord,Show)"] - -contentSpec :: Bool -> CF -> Cat -> String -contentSpec byteStrings cf cat = if isPositionCat cf cat then "((Int,Int),"++stringType++")" else stringType - where - stringType - | byteStrings = "BS.ByteString" - | otherwise = "String" diff --git a/formats/haskell2/CFtoAlex.hs b/formats/haskell2/CFtoAlex.hs deleted file mode 100644 --- a/formats/haskell2/CFtoAlex.hs +++ /dev/null @@ -1,230 +0,0 @@ -{- - BNF Converter: Alex 1.1 Generator - Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - - -module CFtoAlex (cf2alex) where - -import CF -import RegToAlex -import Data.List - -cf2alex :: String -> String -> CF -> String -cf2alex name errMod cf = unlines $ concat $ intersperse [""] [ - prelude name errMod, - cMacros, - rMacros cf, - restOfAlex cf - ] - -prelude :: String -> String -> [String] -prelude name errMod = [ - "-- This Alex file was machine-generated by the BNF converter", - "%{", - "module " ++ name ++ " where", - "", - "import Alex", - "import " ++ errMod, - "%}" - ] -{- ---- -cf2alex :: String -> CF -> String -cf2alex name cf = unlines $ concat $ intersperse [""] [ - prelude name, - cMacros, - rMacros cf, - restOfAlex cf - ] - -prelude :: String -> [String] -prelude name = [ - "-- This Alex file was machine-generated by the BNF converter", - "%{", - "module Lex" ++ name ++ " where", - "", - "import Alex", - "import ErrM", - "%}" - ] --} -cMacros :: [String] -cMacros = [ - "{ ^l = [a-zA-Z^192-^255] # [^215 ^247]} -- isolatin1 letter", - "{ ^c = [A-Z^192-^221] # [^215]} -- capital isolatin1 letter", - "{ ^s = [a-z^222-^255] # [^247]} -- small isolatin1 letter", - "{ ^d = [0-9] } -- digit", - "{ ^i = [^l^d^'^_] } -- identifier character", - "{ ^u = [^0-^255] } -- universal: any character" - ] - -rMacros :: CF -> [String] -rMacros cf = - let symbs = symbols cf - in - (if null symbs then [] else [ - "{ %s = -- reserved words consisting of special symbols", - " " ++ unwords (intersperse "|" (map mkEsc symbs)), - "}" - ]) - where - mkEsc = unwords . map ( f . (:[])) - f s = if all isSpec s then '^':s else s - isSpec = flip elem "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" - -restOfAlex :: CF -> [String] -restOfAlex cf = [ - "\"tokens_lx\"/\"tokens_acts\":-", - lexComments (comments cf), - "<> ::= ^w+", - pTSpec (symbols cf,[]), -- modif Markus 12/02 - 2002 - - userDefTokenTypes, - identAndRes, - - ifC "String" " ::= ^\" ([^u # [^\"^\\^n]] | (^\\ (^\" | ^\\ | ^' | n | t)))* ^\"" ++ - "%{ string p = PT p . TL . unescapeInitTail %}", - ifC "Char" " ::= ^\' (^u # [^\'^\\] | ^\\ [^\\ ^\' n t]) ^' %{ char p = PT p . TC %}", - ifC "Integer" " ::= ^d+ %{ int p = PT p . TI %}", - ifC "Double" - " ::= ^d+ ^. ^d+ (e (^-)? ^d+)? %{ double p = PT p . TD %}", - "", - "%{ ", - "", - "data Tok =", - " TS String -- reserved words", - " | TL String -- string literals", - " | TI String -- integer literals", - " | TV String -- identifiers", - " | TD String -- double precision float literals", - " | TC String -- character literals", - userDefTokenConstrs, - " deriving (Eq,Show)", - "", - "data Token = ", - " PT Posn Tok", - " | Err Posn", - " deriving Show", - "", - "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", - userDefTokenPrint, - " _ -> show t", - "", - "tokens:: String -> [Token]", - "tokens inp = scan tokens_scan inp", - "", - "tokens_scan:: Scan Token", - "tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx", - " where", - " stop_act p \"\" = []", - " stop_act p inp = [Err p]", - "", - "eitherResIdent :: (String -> Tok) -> String -> Tok", - "eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where", - " isResWord s = isInTree s $", - " " ++ (show $ sorted2tree $ sort resws), - "", - "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", - "", - "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", - " _ -> []", - "%}" - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - lexComments ([],[]) = [] - lexComments (xs,s1:ys) = "<> ::= " ++ ('^':intersperse '^' s1) ++ " [.]* ^n\n" ++ lexComments (xs,ys) - lexComments (([l1,l2],[r1,r2]):xs,[]) = concat $ - [ - "<> ::= ", - ('^':l1:' ':'^':l2:" ([^u # ^"), - (l2:"] | ^"), - (r1:" [^u # ^"), - (r2:"])* (^"), - (r1:")+ ^"), - (r2:"\n"), - lexComments (xs,[]) - ] - lexComments ((_:xs),[]) = lexComments (xs,[]) ---- lexComments (xs,(_:ys)) = lexComments (xs,ys) - pTSpec ([],[]) = "" - pTSpec xp = - " ::= " ++ aux xp ++ "%{ pTSpec p = PT p . TS %}" - aux (xs,[]) = " %s " - aux ([],ys) = " %r " - aux (xs,ys) = " %s | %r " - resWs = - "[" ++ concat (intersperse "," [show s | s <- resws]) ++ "]" - --- show s can be strange for isolatin1 characters - --- precompile to search tree! - - userDefTokenTypes = unlines $ - [" ::= " ++ printRegAlex exp ++ - "%{ mk_" ++ name ++ " p = PT p . eitherResIdent T_" ++ name ++ " %}" - | (name,exp) <- tokenPragmas cf] - userDefTokenConstrs = unlines $ - [" | T_" ++ name ++ " String" | (name,_) <- tokenPragmas cf] - userDefTokenPrint = unlines $ - [" PT _ (T_" ++ name ++ " s) -> s" | (name,_) <- tokenPragmas cf] - - identAndRes = --This has to be there for Reserved Words. Michael - " ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" - --ifC "Ident" " ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" - - resws = reservedWords cf - -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 - -sorted2tree :: [String] -> BTree -sorted2tree [] = N -sorted2tree xs = B x (sorted2tree t1) (sorted2tree t2) where - (t1,(x:t2)) = splitAt (length xs `div` 2) xs diff --git a/formats/haskell2/CFtoAlex2.hs b/formats/haskell2/CFtoAlex2.hs deleted file mode 100644 --- a/formats/haskell2/CFtoAlex2.hs +++ /dev/null @@ -1,338 +0,0 @@ -{- - BNF Converter: Alex 2.0 Generator - Copyright (C) 2004 Author: Peter Gammie - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -------------------------------------------------------------------- --- | --- Module : CFtoAlex2 --- Copyright : (C)opyright 2003, {aarne,markus,peteg} at cs dot chalmers dot se --- License : GPL (see COPYING for details) --- --- Maintainer : {markus,aarne} at cs dot chalmers dot se --- Stability : alpha --- Portability : Haskell98 --- --- Hacked version of @CFtoAlex@ to cope with Alex2. --- -------------------------------------------------------------------- -module CFtoAlex2 (cf2alex2) where - -import CF -import Data.List - --- For RegToAlex, see below. -import AbsBNF -import Data.Char - -cf2alex2 :: String -> String -> String -> Bool -> Bool -> CF -> String -cf2alex2 name errMod shareMod shareStrings byteStrings cf = - unlines $ concat $ intersperse [""] [ - prelude name errMod shareMod shareStrings byteStrings, - cMacros, - rMacros cf, - restOfAlex shareMod shareStrings byteStrings cf - ] - -prelude :: String -> String -> String -> Bool -> Bool -> [String] -prelude name errMod shareMod shareStrings byteStrings = [ - "-- -*- haskell -*-", - "-- This Alex file was machine-generated by the BNF converter", - "{", - "{-# OPTIONS -fno-warn-incomplete-patterns #-}", - "module " ++ name ++ " where", - "", - -- "import " ++ errMod, - if shareStrings then "import " ++ shareMod else "", - if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "", - "}", - "" - ] - -cMacros :: [String] -cMacros = [ - "$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" - ] - -rMacros :: CF -> [String] -rMacros cf = - let symbs = symbols cf - in - (if null symbs then [] else [ - "@rsyms = -- symbols and non-identifier-like reserved words", - " " ++ unwords (intersperse "|" (map mkEsc symbs)) - ]) - where - mkEsc = unwords . esc - esc s = if null a then rest else show a : rest - where (a,r) = span isAlphaNum s - rest = case r of - [] -> [] - (c:xs) -> s : esc xs - where s = if isPrint c then ['\\',c] - else '\\':show (ord c) - -restOfAlex :: String -> Bool -> Bool -> CF -> [String] -restOfAlex shareMod shareStrings byteStrings cf = [ - ":-", - lexComments (comments cf), - "$white+ ;", - pTSpec (symbols cf), - - userDefTokenTypes, - ident, - - ifC "String" ("\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t)))* \\\"" ++ - "{ tok (\\p s -> PT p (TL $ share $ unescapeInitTail s)) }"), - ifC "Char" "\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t]) \\' { tok (\\p s -> PT p (TC $ share s)) }", - ifC "Integer" "$d+ { tok (\\p s -> PT p (TI $ share s)) }", - ifC "Double" "$d+ \\. $d+ (e (\\-)? $d+)? { tok (\\p s -> PT p (TD $ share s)) }", - "", - "{", - "", - "tok f p s = f p s", - "", - "share :: "++stringType++" -> "++stringType, - "share = " ++ if shareStrings then "shareString" else "id", - "", - "data Tok =", - " TS !"++stringType++" !Int -- reserved words and symbols", - " | TL !"++stringType++" -- string literals", - " | TI !"++stringType++" -- integer literals", - " | TV !"++stringType++" -- identifiers", - " | TD !"++stringType++" -- double precision float literals", - " | TC !"++stringType++" -- character literals", - userDefTokenConstrs, - " 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", - userDefTokenPrint, - "", - "data BTree = N | B "++stringType++" Tok BTree BTree deriving (Show)", - "", - "eitherResIdent :: ("++stringType++" -> Tok) -> "++stringType++" -> 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 = " ++ (show $ sorted2tree $ zip (sort resws) [1..]), - " where b s n = let bs = "++stringPack++" s", - " in B bs (TS bs n)", - "", - "unescapeInitTail :: "++stringType++" -> "++stringType++"", - "unescapeInitTail = "++stringPack++" . unesc . tail . "++stringUnpack++" 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", - " "++stringType++") -- current input string", - "", - "tokens :: "++stringType++" -> [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 ("++stringTake++" len str) : (go inp')", - "", - "alexGetChar :: AlexInput -> Maybe (Char,AlexInput)", - "alexGetChar (p, _, s) =", - " case "++stringUncons++" s of", - " "++stringNilP++" -> Nothing", - " "++stringConsP++" ->", - " let p' = alexMove p c", - " in p' `seq` Just (c, (p', c, s))", - "", - "alexInputPrevChar :: AlexInput -> Char", - "alexInputPrevChar (p, c, s) = c", - "}" - ] - where - (stringType,stringTake,stringUncons,stringPack,stringUnpack,stringNilP,stringConsP) - | byteStrings = ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)") - | otherwise = ("String", "take", "", "id", "id", "[]", "(c:s)" ) - - ifC cat s = if isUsedCat cf cat then s else "" - lexComments ([],[]) = [] - lexComments (xs,s1:ys) = '\"' : s1 ++ "\"" ++ " [.]* ; -- Toss single line comments\n" ++ lexComments (xs, ys) - lexComments (([l1,l2],[r1,r2]):xs,[]) = concat $ - [ - ('\"':l1:l2:"\" ([$u # \\"), -- FIXME quotes or escape? - (l2:"] | \\"), - (r1:" [$u # \\"), - (r2:"])* (\""), - (r1:"\")+ \""), - (r2:"\" ; \n"), - lexComments (xs, []) - ] - lexComments ((_:xs),[]) = lexComments (xs,[]) ---- lexComments (xs,(_:ys)) = lexComments (xs,ys) - - -- tokens consisting of special symbols - pTSpec [] = "" - pTSpec _ = "@rsyms { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }" - - userDefTokenTypes = unlines $ - [printRegAlex exp ++ - " { tok (\\p s -> PT p (eitherResIdent (T_" ++ name ++ " . share) s)) }" - | (name,exp) <- tokenPragmas cf] - userDefTokenConstrs = unlines $ - [" | T_" ++ name ++ " !"++stringType | (name,_) <- tokenPragmas cf] - userDefTokenPrint = unlines $ - [" PT _ (T_" ++ name ++ " s) -> s" | (name,_) <- tokenPragmas cf] - - ident = - "$l $i* { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }" - --ifC "Ident" " ::= ^l ^i* { ident p = PT p . eitherResIdent TV }" - - resws = reservedWords cf ++ symbols cf - - -data BTree = N | B String Int BTree BTree - -instance Show BTree where - showsPrec _ N = showString "N" - showsPrec n (B s k l r) = wrap (showString "b " . shows s . showChar ' '. shows k . showChar ' ' - . showsPrec 1 l . showChar ' ' - . showsPrec 1 r) - where wrap f = if n > 0 then showChar '(' . f . showChar ')' else f - -sorted2tree :: [(String,Int)] -> BTree -sorted2tree [] = N -sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2) where - (t1,((x,n):t2)) = splitAt (length xs `div` 2) xs - - -------------------------------------------------------------------- --- Inlined version of @RegToAlex@. --- Syntax has changed... -------------------------------------------------------------------- - --- modified from pretty-printer generated by the BNF converter - --- the top-level printing method -printRegAlex :: Reg -> String -printRegAlex = render . prt 0 - --- you may want to change render and parenth - -render :: [String] -> String -render = rend 0 - where rend :: Int -> [String] -> String - rend i ss = case ss of - "[" :ts -> cons "[" $ rend i ts - "(" :ts -> cons "(" $ rend i ts - t : "," :ts -> cons t $ space "," $ rend i ts - t : ")" :ts -> cons t $ cons ")" $ rend i ts - t : "]" :ts -> cons t $ cons "]" $ rend i ts - t :ts -> space t $ rend i ts - _ -> "" - - cons s t = s ++ t - new i s = s - space t s = if null s then t else t ++ " " ++ s - -parenth :: [String] -> [String] -parenth ss = ["("] ++ ss ++ [")"] - --- the printer class does the job -class Print a where - prt :: Int -> a -> [String] - prtList :: [a] -> [String] - prtList = concat . map (prt 0) - -instance Print a => Print [a] where - prt _ = prtList - -instance Print Char where - prt _ c = if isAlphaNum c then [[c]] else ['\\':[c]] - prtList s = map (concat . prt 0) s - -prPrec :: Int -> Int -> [String] -> [String] -prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) - RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) - RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) - RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) - RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) - ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) - REps -> prPrec i 3 (["$"]) - RChar c -> prPrec i 3 (concat [prt 0 c]) - RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]]) - RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) - RDigit -> prPrec i 3 (concat [["$d"]]) - RLetter -> prPrec i 3 (concat [["$l"]]) - RUpper -> prPrec i 3 (concat [["$c"]]) - RLower -> prPrec i 3 (concat [["$s"]]) - RAny -> prPrec i 3 (concat [["$u"]]) diff --git a/formats/haskell2/CFtoHappy.hs b/formats/haskell2/CFtoHappy.hs deleted file mode 100644 --- a/formats/haskell2/CFtoHappy.hs +++ /dev/null @@ -1,280 +0,0 @@ -{- - BNF Converter: Happy Generator - Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoHappy - ( - cf2HappyS -- cf2HappyS :: CF -> CFCat -> String - ,HappyMode(..) - ) - where - -import CF ---import Lexer -import Data.List (intersperse, sort) -import Data.Char - --- Type declarations - -type Rules = [(NonTerminal,[(Pattern,Action)])] -type NonTerminal = String -type Pattern = String -type Action = String -type MetaVar = String - --- default naming - -moduleName = "HappyParser" -tokenName = "Token" - --- Happy mode - -data HappyMode = Standard | GLR deriving Eq - - -cf2HappyS :: String -> String -> String -> String -> HappyMode -> Bool -> CF -> String ----- cf2HappyS :: String -> CF -> String -cf2HappyS = cf2Happy - --- The main function, that given a CF and a CFCat to parse according to, --- generates a happy module. -cf2Happy name absName lexName errName mode byteStrings cf - = unlines - [header name absName lexName errName mode byteStrings, - declarations mode (allEntryPoints cf), - tokens (symbols cf ++ reservedWords cf), - specialToks cf, - delimiter, - specialRules byteStrings cf, - prRules (rulesForHappy cf), - finalize byteStrings cf] - --- construct the header. -header :: String -> String -> String -> String -> HappyMode -> Bool -> String -header modName absName lexName errName mode byteStrings = unlines - ["-- This Happy file was machine-generated by the BNF converter", - "{", - "{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}", - case mode of - Standard -> "module " ++ modName ++ " where" - GLR -> "-- module name filled in by Happy", - "import " ++ absName, - "import " ++ lexName, - "import " ++ errName, - if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "", - "}" - ] - -{- ---- -cf2Happy :: String -> CF -> String -cf2Happy name cf - = unlines - [header name, - declarations (allEntryPoints cf), - tokens (symbols cf ++ reservedWords cf), - specialToks cf, - delimiter, - specialRules cf, - prRules (rulesForHappy cf), - finalize cf] - --- construct the header. -header :: String -> String -header name = unlines - ["-- This Happy file was machine-generated by the BNF converter", - "{", - "module Par" ++ name ++ " where", - "import Abs"++name, - "import Lex"++name, - "import ErrM", - "}" - ] --} - --- The declarations of a happy file. -declarations :: HappyMode -> [NonTerminal] -> String -declarations mode ns = unlines - [generateP ns, - case mode of - Standard -> "-- no lexer declaration" - GLR -> "%lexer { myLexer } { Err _ }", - "%monad { Err } { thenM } { returnM }", - "%tokentype { " ++ tokenName ++ " }"] - where generateP [] = [] - generateP (n:ns) = concat ["%name p",n'," ",n',"\n",generateP ns] - where n' = identCat n - --- The useless delimiter symbol. -delimiter :: String -delimiter = "\n%%\n" - --- Generate the list of tokens and their identifiers. -tokens :: [String] -> String -tokens toks = "%token \n" ++ prTokens (zip (sort toks) [1..]) - where prTokens [] = [] - prTokens ((t,k):tk) = " " ++ (convert t) ++ - " { " ++ oneTok t k ++ " }\n" ++ - prTokens tk - oneTok t k = "PT _ (TS _ " ++ show k ++ ")" - --- Happy doesn't allow characters such as åäö to occur in the happy file. This --- is however not a restriction, just a naming paradigm in the happy source file. -convert :: String -> String -convert "\\" = concat ['\'':"\\\\","\'"] -convert xs = concat ['\'':(escape xs),"\'"] - where escape [] = [] - escape ('\'':xs) = '\\':'\'':escape xs - escape (x:xs) = x:escape xs - -rulesForHappy :: CF -> Rules -rulesForHappy cf = map mkOne $ ruleGroups cf where - mkOne (cat,rules) = constructRule cf rules cat - --- For every non-terminal, we construct a set of rules. A rule is a sequence of --- terminals and non-terminals, and an action to be performed --- As an optimization, a pair of list rules [C] ::= "" | C k [C] --- is left-recursivized into [C] ::= "" | [C] C k. --- This could be generalized to cover other forms of list rules. -constructRule :: CF -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) -constructRule cf rules nt = (nt,[(p,generateAction nt (revF b r) m) | - r0 <- rules, - let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0), - let (p,m) = generatePatterns cf r]) - where - revF b r = if b then ("flip " ++ funRule r) else (underscore $ funRule r) - revs = reversibleCats cf - underscore f | isDefinedRule f = f ++ "_" - | otherwise = f - --- Generates a string containing the semantic action. --- An action can for example be: Sum $1 $2, that is, construct an AST --- with the constructor Sum applied to the two metavariables $1 and $2. -generateAction :: NonTerminal -> Fun -> [MetaVar] -> Action -generateAction nt f ms = unwords $ (if isCoercion f then [] else [f]) ++ ms - --- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal - -generatePatterns :: CF -> Rule -> (Pattern,[MetaVar]) -generatePatterns cf r = case rhsRule r of - [] -> ("{- empty -}",[]) - its -> (unwords (map mkIt its), metas its) - where - mkIt i = case i of - Left c -> identCat c - Right s -> convert s - metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its] - revIf c m = if (not (isConsFun (funRule r)) && elem c revs) - then ("(reverse " ++ m ++ ")") - else m -- no reversal in the left-recursive Cons rule itself - revs = reversibleCats cf - --- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string. - -prRules :: Rules -> String -prRules = unlines . map prOne - where - prOne (nt,[]) = [] -- nt has only internal use - prOne (nt,((p,a):ls)) = - unwords [nt', "::", "{", normCat nt, "}\n" ++ - nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ "\n" - where - nt' = identCat nt - pr [] = [] - pr ((p,a):ls) = - unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls - --- Finally, some haskell code. - -finalize :: Bool -> CF -> String -finalize byteStrings cf = unlines $ - [ - "{", - "\nreturnM :: a -> Err a", - "returnM = return", - "\nthenM :: Err a -> (a -> Err b) -> Err b", - "thenM = (>>=)", - "\nhappyError :: [" ++ tokenName ++ "] -> Err a", - "happyError ts =", - " Bad $ \"syntax error at \" ++ tokenPos ts ++ ", - " case ts of", - " [] -> []", - " [Err _] -> \" due to lexer error\"", - " _ -> \" before \" ++ unwords (map ("++stringUnpack++" . prToken) (take 4 ts))", - "", - "myLexer = tokens" - ] ++ definedRules cf ++ [ "}" ] - where - stringUnpack - | byteStrings = "BS.unpack" - | otherwise = "id" - - -definedRules ((ps,_),_) = [ mkDef f xs e | FunDef f xs e <- ps ] - where - mkDef f xs e = unwords $ (f ++ "_") : xs' ++ ["=", show e'] - where - xs' = map (++"_") xs - e' = underscore e - underscore (App x es) - | isLower $ head x = App (x ++ "_") $ map underscore es - | otherwise = App x $ map underscore es - underscore e = e - --- aarne's modifs 8/1/2002: --- Markus's modifs 11/02/2002 - --- GF literals -specialToks :: CF -> String -specialToks cf = unlines $ - (map aux (literals cf)) - ++ ["L_err { _ }"] - where aux cat = - case cat of - "Ident" -> "L_ident { PT _ (TV $$) }" - "String" -> "L_quoted { PT _ (TL $$) }" - "Integer" -> "L_integ { PT _ (TI $$) }" - "Double" -> "L_doubl { PT _ (TD $$) }" - "Char" -> "L_charac { PT _ (TC $$) }" - own -> "L_" ++ own ++ " { PT _ (T_" ++ own ++ " " ++ posn ++ ") }" - where - posn = if isPositionCat cf cat then "_" else "$$" - -specialRules :: Bool -> CF -> String -specialRules byteStrings cf = unlines $ - map aux (literals cf) - where - aux cat = - case cat of - "Ident" -> "Ident :: { Ident } : L_ident { Ident $1 }" - "String" -> "String :: { String } : L_quoted { "++stringUnpack++" $1 }" - "Integer" -> "Integer :: { Integer } : L_integ { (read ("++stringUnpack++" $1)) :: Integer }" - "Double" -> "Double :: { Double } : L_doubl { (read ("++stringUnpack++" $1)) :: Double }" - "Char" -> "Char :: { Char } : L_charac { (read ("++stringUnpack++" $1)) :: Char }" - own -> own ++ " :: { " ++ own ++ "} : L_" ++ own ++ " { " ++ own ++ " ("++ posn ++ "$1)}" - -- PCC: take "own" as type name? (manual says newtype) - where - posn = if isPositionCat cf cat then "mkPosToken " else "" - - stringUnpack - | byteStrings = "BS.unpack" - | otherwise = "" - diff --git a/formats/haskell2/CFtoLayout.hs b/formats/haskell2/CFtoLayout.hs deleted file mode 100644 --- a/formats/haskell2/CFtoLayout.hs +++ /dev/null @@ -1,270 +0,0 @@ -{- - BNF Converter: Layout handling Generator - Copyright (C) 2004 Author: Aarne Ranta - Copyright (C) 2005 Bjorn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoLayout where - -import Data.List (sort) -import CF - -layoutOpen = "{" -layoutClose = "}" -layoutSep = ";" - -cf2Layout :: Bool -> Bool -> String -> String -> CF -> String -cf2Layout alex1 inDir layName lexName cf = - let - (top,lay,stop) = layoutPragmas cf - in unlines $ [ - "module " ++ layName ++ " where", - "", - "import " ++ lexName, - if alex1 then "import Alex" else "", - "", - "import Data.Maybe (isNothing, fromJust)", - "", - "-- Generated by the BNF Converter", - "", - "-- local parameters", - "", - "topLayout = " ++ show top, - "layoutWords = " ++ show lay, - "layoutStopWords = " ++ show stop, - "", - "-- layout separators", - "", - "layoutOpen = " ++ show layoutOpen, - "layoutClose = " ++ show layoutClose, - "layoutSep = " ++ show layoutSep, - "", - "-- | Replace layout syntax with explicit layout tokens.", - "resolveLayout :: Bool -- ^ Whether to use top-level layout.", - " -> [Token] -> [Token]", - "resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]", - " where", - " -- Do top-level layout if the function parameter and the grammar say so.", - " tl = tp && topLayout", - "", - " res :: Maybe Token -- ^ The previous token, if any.", - " -> [Block] -- ^ A stack of layout blocks.", - " -> [Token] -> [Token]", - "", - " -- The stack should never be empty.", - " res _ [] ts = error $ \"Layout error: stack empty. Tokens: \" ++ show ts", - "", - " res _ st (t0:ts)", - " -- We found an open brace in the input,", - " -- put an explicit layout block on the stack.", - " -- This is done even if there was no layout word,", - " -- to keep opening and closing braces.", - " | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts", - "", - " res _ st (t0:ts)", - " -- Start a new layout block if the first token is a layout word", - " | isLayout t0 =", - " case ts of", - " -- Explicit layout, just move on. The case above", - " -- will push an explicit layout block.", - " t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts", - " -- at end of file, the start column doesn't matter", - " _ -> let col = if null ts then column t0 else column (head ts)", - " -- insert an open brace after the layout word", - " b:ts' = addToken (nextPos t0) layoutOpen ts", - " -- save the start column", - " st' = Implicit col:st ", - " in moveAlong st' [t0,b] ts'", - "", - " -- If we encounter a closing brace, exit the first explicit layout block.", - " | isLayoutClose t0 = ", - " let st' = drop 1 (dropWhile isImplicit st)", - " in if null st' ", - " then error $ \"Layout error: Found \" ++ layoutClose ++ \" at (\" ", - " ++ show (line t0) ++ \",\" ++ show (column t0) ", - " ++ \") without an explicit layout block.\"", - " else moveAlong st' [t0] ts", - "", - " -- We are in an implicit layout block", - " res pt st@(Implicit n:ns) (t0:ts)", - "", - " -- End of implicit block by a layout stop word", - " | isStop t0 = ", - " -- Exit the current block and all implicit blocks ", - " -- more indented than the current token", - " let (ebs,ns') = span (`moreIndent` column t0) ns", - " moreIndent (Implicit x) y = x > y", - " moreIndent Explicit _ = False", - " -- the number of blocks exited", - " b = 1 + length ebs", - " bs = replicate b layoutClose", - " -- Insert closing braces after the previous token.", - " (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)", - " in moveAlong ns' ts1 ts2", - "", - " -- End of an implicit layout block", - " | newLine && column t0 < n = ", - " -- Insert a closing brace after the previous token.", - " let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)", - " -- Repeat, with the current block removed from the stack", - " in moveAlong ns [b] (t0':ts')", - "", - " -- Encounted a new line in an implicit layout block.", - " | newLine && column t0 == n = ", - " -- Insert a semicolon after the previous token.", - " -- unless we are the beginning of the file,", - " -- or the previous token is a semicolon or open brace.", - " if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt) ", - " then moveAlong st [t0] ts", - " else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts)", - " in moveAlong st [b,t0'] ts'", - " where newLine = case pt of", - " Nothing -> True", - " Just t -> line t /= line t0", - "", - " -- Nothing to see here, move along.", - " res _ st (t:ts) = moveAlong st [t] ts", - "", - " -- At EOF: skip explicit blocks.", - " res (Just t) (Explicit:bs) [] | null bs = []", - " | otherwise = res (Just t) bs []", - "", - " -- If we are using top-level layout, insert a semicolon after", - " -- the last token, if there isn't one already", - " res (Just t) [Implicit n] []", - " | isTokenIn [layoutSep] t = []", - " | otherwise = addToken (nextPos t) layoutSep []", - "", - " -- At EOF in an implicit, non-top-level block: close the block", - " res (Just t) (Implicit n:bs) [] =", - " let c = addToken (nextPos t) layoutClose []", - " in moveAlong bs c []", - "", - " -- This should only happen if the input is empty.", - " res Nothing st [] = []", - "", - " -- | Move on to the next token.", - " moveAlong :: [Block] -- ^ The layout stack.", - " -> [Token] -- ^ Any tokens just processed.", - " -> [Token] -- ^ the rest of the tokens.", - " -> [Token]", - " moveAlong st [] ts = error $ \"Layout error: moveAlong got [] as old tokens\"", - " moveAlong st ot ts = ot ++ res (Just $ last ot) st ts", - "", - "data Block = Implicit Int -- ^ An implicit layout block with its start column.", - " | Explicit ", - " deriving Show", - "", - "type Position = Posn", - "", - "-- | Check if s block is implicit.", - "isImplicit :: Block -> Bool", - "isImplicit (Implicit _) = True", - "isImplicit _ = False", - "", - "-- | Insert a number of tokens at the begninning of a list of tokens.", - "addTokens :: Position -- ^ Position of the first new token.", - " -> [String] -- ^ Token symbols.", - " -> [Token] -- ^ The rest of the tokens. These will have their", - " -- positions updated to make room for the new tokens .", - " -> [Token] ", - "addTokens p ss ts = foldr (addToken p) ts ss", - "", - "-- | Insert a new symbol token at the begninning of a list of tokens.", - "addToken :: Position -- ^ Position of the new token.", - " -> String -- ^ Symbol in the new token.", - " -> [Token] -- ^ The rest of the tokens. These will have their", - " -- positions updated to make room for the new token.", " -> [Token]", - "addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts", - "", - "-- | Get the position immediately to the right of the given token.", - "-- If no token is given, gets the first position in the file.", - "afterPrev :: Maybe Token -> Position", - "afterPrev = maybe (Pn 0 1 1) nextPos", - "", - "-- | Get the position immediately to the right of the given token.", - "nextPos :: Token -> Position ", - "nextPos t = Pn (g + s) l (c + s + 1) ", - " where Pn g l c = position t", - " s = tokenLength t", - "", - "-- | Add to the global and column positions of a token.", - "-- The column position is only changed if the token is on", - "-- the same line as the given position.", - "incrGlobal :: Position -- ^ If the token is on the same line", - " -- as this position, update the column position.", - " -> Int -- ^ Number of characters to add to the position.", - " -> Token -> Token", - "incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) =", - " if l /= l0 then PT (Pn (g + i) l c) t", - " else PT (Pn (g + i) l (c + i)) t", - "incrGlobal _ _ p = error $ \"cannot add token at \" ++ show p", - "", - "-- | Create a symbol token.", - "sToken :: Position -> String -> Token", - "sToken p s = PT p (TS s i)", - " where", - " i = case s of"] ++ - [ " " ++ show s ++ " -> " ++ show i - | (s, i) <- zip resws [1..] - ] ++ - [" _ -> error $ \"not a reserved word: \" ++ show s", - "", - "-- | Get the position of a token.", - "position :: Token -> Position", - "position t = case t of", - " PT p _ -> p", - " Err p -> p", - "", - "-- | Get the line number of a token.", - "line :: Token -> Int", - "line t = case position t of Pn _ l _ -> l", - "", - "-- | Get the column number of a token.", - "column :: Token -> Int", - "column t = case position t of Pn _ _ c -> c", - "", - "-- | Check if a token is one of the given symbols.", - "isTokenIn :: [String] -> Token -> Bool", - "isTokenIn ts t = case t of", - " PT _ (TS r _) | elem r ts -> True", - " _ -> False", - "", - "-- | Check if a word is a layout start token.", - "isLayout :: Token -> Bool", - "isLayout = isTokenIn layoutWords", - "", - "-- | Check if a token is a layout stop token.", - "isStop :: Token -> Bool", - "isStop = isTokenIn layoutStopWords", - "", - "-- | Check if a token is the layout open token.", - "isLayoutOpen :: Token -> Bool", - "isLayoutOpen = isTokenIn [layoutOpen]", - "", - "-- | Check if a token is the layout close token.", - "isLayoutClose :: Token -> Bool", - "isLayoutClose = isTokenIn [layoutClose]", - "", - "-- | Get the number of characters in the token.", - "tokenLength :: Token -> Int", - "tokenLength t = length $ prToken t", - - "" - ] - where - resws = sort (reservedWords cf ++ symbols cf) diff --git a/formats/haskell2/CFtoPrinter.hs b/formats/haskell2/CFtoPrinter.hs deleted file mode 100644 --- a/formats/haskell2/CFtoPrinter.hs +++ /dev/null @@ -1,189 +0,0 @@ -{- - BNF Converter: Pretty-printer generator - Copyright (C) 2004 Author: Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoPrinter (cf2Printer) where - -import CF -import Utils -import CFtoTemplate -import Data.List (intersperse) -import Data.Char(toLower) - --- derive pretty-printer from a BNF grammar. AR 15/2/2002 -cf2Printer :: Bool -> String -> String -> CF -> String -cf2Printer byteStrings name absMod cf = unlines [ - prologue byteStrings name absMod, - integerRule cf, - doubleRule cf, - if hasIdent cf then identRule byteStrings cf else "", - unlines [ownPrintRule byteStrings cf own | (own,_) <- tokenPragmas cf], - rules cf - ] - - -prologue :: Bool -> String -> String -> String -prologue byteStrings name absMod = unlines [ - "{-# OPTIONS -fno-warn-incomplete-patterns #-}", - "module " ++ name +++ "where\n", - "-- pretty-printer generated by the BNF converter\n", - "import " ++ absMod, - "import Data.Char", - (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""), - "", - "-- 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 String -rules cf = unlines $ - map (\(s,xs) -> case_fun s (map toArgs xs) ++ ifList cf s) $ cf2data cf - where - toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons) - names [] _ = [] - names (x:xs) n - | elem x xs = (x ++ show n) : names xs (n+1) - | otherwise = x : names xs n - var ('[':xs) = var (init xs) ++ "s" - var "Ident" = "id" - var "Integer" = "n" - var "String" = "str" - var "Char" = "c" - var "Double" = "d" - var xs = map toLower xs - checkRes s - | elem s reservedHaskell = s ++ "'" - | otherwise = s - reservedHaskell = ["case","class","data","default","deriving","do","else","if", - "import","in","infix","infixl","infixr","instance","let","module", - "newtype","of","then","type","where","as","qualified","hiding"] - ruleOf s = maybe undefined id $ lookup s (rulesOfCF cf) - ---- case_fun :: Cat -> [(Constructor,Rule)] -> String -case_fun cat xs = unlines [ - "instance Print" +++ cat +++ "where", - " prt i" +++ "e = case e of", - unlines $ map (\ ((c,xx),r) -> - " " ++ c +++ unwords xx +++ "->" +++ - "prPrec i" +++ show (precCat (fst r)) +++ mkRhs xx (snd r)) xs - ] - -ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where - nil cat = [" [] -> " ++ mkRhs [] its | - (f,(c,its)) <- rulesOfCF cf, isNilFun f , normCatOfList c == cat] - one cat = [" [x] -> " ++ mkRhs ["x"] its | - (f,(c,its)) <- rulesOfCF cf, isOneFun f , normCatOfList c == cat] - cons cat = [" x:xs -> " ++ mkRhs ["x","xs"] its | - (f,(c,its)) <- rulesOfCF cf, isConsFun f , normCatOfList c == cat] - mkListRule [] = "" - mkListRule rs = unlines $ (" prtList" +++ "es = case es of"):rs - - -mkRhs args its = - "(concatD [" ++ unwords (intersperse "," (mk args its)) ++ "])" - where - mk args (Left "#" : items) = mk args items - mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items - mk args (Right s : items) = ("doc (showString" +++ show s ++ ")") : mk args items - mk _ _ = [] - prt c = "prt" +++ show (precCat c) - diff --git a/formats/haskell2/CFtoTemplate.hs b/formats/haskell2/CFtoTemplate.hs deleted file mode 100644 --- a/formats/haskell2/CFtoTemplate.hs +++ /dev/null @@ -1,106 +0,0 @@ -{- - BNF Converter: Template Generator - Copyright (C) 2004 Author: Markus Forberg - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - - -module CFtoTemplate ( - cf2Template - ) where - -import CF -import Data.Char -import Data.List (delete) - -type ModuleName = String -type Constructor = String - -cf2Template :: ModuleName -> ModuleName -> ModuleName -> CF -> String -cf2Template skelName absName errName cf = unlines - [ - "module "++ skelName ++ " where\n", - "-- Haskell module generated by the BNF converter\n", - "import " ++ absName, - "import " ++ errName, - "type Result = Err String\n", - "failure :: Show a => a -> Result", - "failure x = Bad $ \"Undefined case: \" ++ show x\n", - unlines $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf - ] - where toArgs [] = [] - toArgs ((cons,args):xs) - = (cons ++ " " ++ names (map (checkRes . var) args) (0 :: Int)) : toArgs xs - names [] _ = [] - names (x:xs) n - | elem x xs = (x ++ show n) ++ " " ++ names xs (n+1) - | otherwise = x ++ " " ++ names xs n - var ('[':xs) = var (init xs) ++ "s" - var "Ident" = "id" - var "Integer" = "n" - var "String" = "str" - var "Char" = "c" - var "Double" = "d" - var xs = map toLower xs - checkRes s - | elem s reservedHaskell = s ++ "'" - | otherwise = s - reservedHaskell = ["case","class","data","default","deriving","do","else","if", - "import","in","infix","infixl","infixr","instance","let","module", - "newtype","of","then","type","where","as","qualified","hiding"] - -{- ---- -cf2Template :: ModuleName -> CF -> String -cf2Template name cf = unlines - [ - "module Skel"++ name ++ " where\n", - "-- Haskell module generated by the BNF converter\n", - "import Abs" ++ name, - "import ErrM", - "type Result = Err String\n", - "failure :: Show a => a -> Result", - "failure x = Bad $ \"Undefined case: \" ++ show x\n", - unlines $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf - ] - where toArgs [] = [] - toArgs ((cons,args):xs) - = (cons ++ " " ++ names (map (checkRes . var) args) (0 :: Int)) : toArgs xs - names [] _ = [] - names (x:xs) n - | elem x xs = (x ++ show n) ++ " " ++ names xs (n+1) - | otherwise = x ++ " " ++ names xs n - var ('[':xs) = var (init xs) ++ "s" - var "Ident" = "id" - var "Integer" = "n" - var "String" = "str" - var "Char" = "c" - var "Double" = "d" - var xs = map toLower xs - checkRes s - | elem s reservedHaskell = s ++ "'" - | otherwise = s - reservedHaskell = ["case","class","data","default","deriving","do","else","if", - "import","in","infix","infixl","infixr","instance","let","module", - "newtype","of","then","type","where","as","qualified","hiding"] --} - -case_fun :: Cat -> [Constructor] -> String -case_fun cat xs = - unlines $ - ["trans" ++ cat ++ " :: " ++ cat ++ " -> Result", - "trans" ++ cat ++ " x = case x of", - unlines $ map (\s -> " " ++ s ++ " -> " ++ "failure x") xs] - diff --git a/formats/haskell2/HaskellTop.hs b/formats/haskell2/HaskellTop.hs deleted file mode 100644 --- a/formats/haskell2/HaskellTop.hs +++ /dev/null @@ -1,357 +0,0 @@ -{- - BNF Converter: Haskell main file - Copyright (C) 2004 Author: Markus Forberg, Peter Gammie, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module HaskellTop (makeAll) where - - - --- import Utils -import CF -import CFtoHappy -import CFtoAlex -import CFtoAlex2 -import CFtoLatex -import CFtoTxt -import CFtoAbstract -import CFtoTemplate -import CFtoPrinter -import CFtoLayout -import CFtoXML -import MkErrM -import MkSharedString --- import CFtoGF ( cf2AbsGF, cf2ConcGF ) --- import System.IO -import GetCF -import Utils - -import Data.Char -import Data.Maybe (fromMaybe,maybe) -import System.IO -import System.Exit -import Control.Monad(when) - --- naming conventions - -noLang :: Options -> String -> String -noLang _ name = name - -withLang :: Options -> String -> String -withLang opts name = name ++ lang opts - -withLangAbs :: Options -> String -> String -withLangAbs opts name = postp $ name ++ lang opts - where - postp nam = if multi opts - then takeWhile (/='_') nam - else nam - -mkMod :: (Options -> String -> String) -> String -> Options -> String -mkMod addLang name opts = - pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name - where pref = maybe "" (++".") (inPackage opts) - -mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath -mkFile addLang name ext opts = - pref ++ if inDir opts - then lang opts ++ [pathSep] ++ name ++ ext' - else addLang opts name ++ if null ext then "" else ext' - where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts) - ext' = if null ext then "" else "." ++ ext - -absFile, absFileM, alexFile, alexFileM, dviFile, - gfAbs, gfConc, - happyFile, happyFileM, - latexFile, errFile, errFileM, - templateFile, templateFileM, - printerFile, printerFileM, - layoutFile, layoutFileM, - psFile, tFile, tFileM :: Options -> String -absFile = mkFile withLangAbs "Abs" "hs" -absFileM = mkMod withLangAbs "Abs" -alexFile = mkFile withLang "Lex" "x" -alexFileM = mkMod withLang "Lex" -happyFile = mkFile withLang "Par" "y" -happyFileM = mkMod withLang "Par" -latexFile = mkFile withLang "Doc" "tex" -txtFile = mkFile withLang "Doc" "txt" -templateFile = mkFile withLang "Skel" "hs" -templateFileM = mkMod withLang "Skel" -printerFile = mkFile withLang "Print" "hs" -printerFileM = mkMod withLang "Print" -dviFile = mkFile withLang "Doc" "dvi" -psFile = mkFile withLang "Doc" "ps" -gfAbs = mkFile withLangAbs "" "Abs.gf" -gfConc = mkFile withLang "" "Conc.gf" -tFile = mkFile withLang "Test" "hs" -tFileM = mkMod withLang "Test" -errFile = mkFile noLang "ErrM" "hs" -errFileM = mkMod noLang "ErrM" -shareFile = mkFile noLang "SharedString" "hs" -shareFileM = mkMod noLang "SharedString" -layoutFileM = mkMod withLang "Layout" -xmlFileM = mkMod withLang "XML" -layoutFile = mkFile withLang "Layout" "hs" - -data Options = Options - { - make :: Bool, - alex1 :: Bool, - inDir :: Bool, - shareStrings :: Bool, - byteStrings :: Bool, - glr :: HappyMode, - xml :: Int, - inPackage :: Maybe String, - lang :: String, - multi :: Bool - } - -makeAll :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int - -> Maybe String -- ^ The hierarchical package to put the modules - -- in, or Nothing. - -> String -> Bool -> FilePath -> IO () -makeAll m a1 d ss bs g x p n mu file = do - let opts = Options { make = m, alex1 = a1, inDir = d, shareStrings = ss, byteStrings=bs, - glr = if g then GLR else Standard, xml = x, - inPackage = p, lang = n, multi = mu} - - absMod = absFileM opts - lexMod = alexFileM opts - parMod = happyFileM opts - prMod = printerFileM opts - layMod = layoutFileM opts - errMod = errFileM opts - shareMod = shareFileM opts - (cf, isOK) <- tryReadCF file - if isOK then do - let dir = codeDir opts - when (not (null dir)) $ do - putStrLn $ "Creating directory " ++ dir - prepareDir dir - writeFileRep (absFile opts) $ cf2Abstract (byteStrings opts) absMod cf - if alex1 opts then do - writeFileRep (alexFile opts) $ cf2alex lexMod errMod cf - putStrLn " (Use Alex 1.1 to compile.)" - else do - writeFileRep (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf - putStrLn " (Use Alex 2.0 to compile.)" - writeFileRep (happyFile opts) $ - cf2HappyS parMod absMod lexMod errMod (glr opts) (byteStrings opts) cf - putStrLn " (Tested with Happy 1.15)" - writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf - writeFileRep (txtFile opts) $ cfToTxt (lang opts) cf - writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod cf - writeFileRep (printerFile opts) $ cf2Printer (byteStrings opts) prMod absMod cf - when (hasLayout cf) $ writeFileRep (layoutFile opts) $ cf2Layout (alex1 opts) (inDir opts) layMod lexMod cf - writeFileRep (tFile opts) $ testfile opts cf - writeFileRep (errFile opts) $ errM errMod cf - when (shareStrings opts) $ writeFileRep (shareFile opts) $ sharedString shareMod (byteStrings opts) cf - when (make opts) $ writeFileRep "Makefile" $ makefile opts - case xml opts of - 2 -> makeXML (lang opts) True cf - 1 -> makeXML (lang opts) False cf - _ -> return () - putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -pkgToDir :: String -> FilePath -pkgToDir s = replace '.' pathSep s - -codeDir :: Options -> FilePath -codeDir opts = let pref = maybe "" pkgToDir (inPackage opts) - dir = if inDir opts then lang opts else "" - sep = if null pref || null dir then "" else [pathSep] - in pref ++ sep ++ dir - -makefile :: Options -> String -makefile opts = makeA where - glr_params = if glr opts == GLR then "--glr --decode " else "" - dir = let d = codeDir opts in if null d then "" else d ++ [pathSep] - cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")" - makeA = unlines - [ - "all:", - "\thappy -gca " ++ glr_params ++ happyFile opts, - "\talex -g " ++ alexFile opts, - "\t" ++ cd ("latex " ++ basename (latexFile opts) - ++ "; " ++ "dvips " ++ basename (dviFile opts) - ++ " -o " ++ basename (psFile opts)), - "\tghc --make " ++ tFile opts ++ " -o " ++ mkFile withLang "Test" "" opts, - "clean:", - "\t-rm -f " ++ unwords (map (dir++) [ - "*.log", "*.aux", "*.hi", - "*.o", "*.dvi" - ]), - "\t-rm -f " ++ psFile opts, - - "distclean: clean", - "\t-rm -f " ++ unwords [ - mkFile withLang "Doc" "*" opts, - mkFile withLang "Lex" "*" opts, - mkFile withLang "Par" "*" opts, - mkFile withLang "Layout" "*" opts, - mkFile withLang "Skel" "*" opts, - mkFile withLang "Print" "*" opts, - mkFile withLang "Test" "*" opts, - mkFile withLang "Abs" "*" opts, - mkFile withLang "Test" "" opts, - mkFile noLang "ErrM" "*" opts, - mkFile noLang "SharedString" "*" opts, - dir ++ lang opts ++ ".dtd", - mkFile withLang "XML" "*" opts, - "Makefile*" - ], - if null dir then "" else "\t-rmdir -p " ++ dir - ] - - -testfile :: Options -> CF -> String -testfile opts cf - = let lay = hasLayout cf - use_xml = xml opts > 0 - xpr = if use_xml then "XPrint a, " else "" - use_glr = glr opts == GLR - if_glr s = if use_glr then s else "" - firstParser = if use_glr then "the_parser" else parserName - parserName = 'p' : topType - topType = firstEntry cf - in unlines - ["-- automatically generated by BNF Converter", - "module Main where\n", - "", - "import System.IO ( stdin, hGetContents )", - "import System.IO ( getArgs, getProgName )", - "", - "import " ++ alexFileM opts, - "import " ++ happyFileM opts, - "import " ++ templateFileM opts, - "import " ++ printerFileM opts, - "import " ++ absFileM opts, - if lay then ("import " ++ layoutFileM opts) else "", - if use_xml then ("import " ++ xmlFileM opts) else "", - if_glr "import Data.FiniteMap(FiniteMap, lookupFM, fmToList)", - if_glr "import Data.Maybe(fromJust)", - "import " ++ errFileM opts, - "", - if use_glr - then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))" - else "type ParseFun a = [Token] -> Err a", - "", - "myLLexer = " ++ if lay then "resolveLayout True . myLexer" - else "myLexer", - "", - "type Verbosity = Int", - "", - "putStrV :: Verbosity -> String -> IO ()", - "putStrV v s = if v > 1 then putStrLn s else return ()", - "", - "runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()", - "runFile v p f = putStrLn f >> readFile f >>= run v p", - "", - "run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()", - if use_glr then run_glr else run_std use_xml, - "", - "showTree :: (Show a, Print a) => Int -> a -> IO ()", - "showTree v tree", - " = do", - " putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree", - " putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree", - "", - "main :: IO ()", - "main = do args <- getArgs", - " case args of", - " [] -> hGetContents stdin >>= run 2 " ++ firstParser, - " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs", - " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs", - "", - if_glr $ "the_parser :: ParseFun " ++ topType, - if_glr $ "the_parser = lift_parser " ++ parserName, - if_glr $ "", - if_glr $ lift_parser - ] - -run_std xml - = unlines - [ "run v p s = let ts = myLLexer s in case p ts of" - , " Bad s -> do putStrLn \"\\nParse Failed...\\n\"" - , " putStrV v \"Tokens:\"" - , " putStrV v $ show ts" - , " putStrLn s" - , " Ok tree -> do putStrLn \"\\nParse Successful!\"" - , " showTree v tree" - , if xml then - " putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree" - else "" - ] - -run_glr - = unlines - [ "run v p s" - , " = let ts = map (:[]) $ myLLexer s" - , " (raw_output, simple_output) = p ts in" - , " case simple_output of" - , " GLR_Fail major minor -> do" - , " putStrLn major" - , " putStrV v minor" - , " GLR_Result df trees -> do" - , " putStrLn \"\\nParse Successful!\"" - , " case trees of" - , " [] -> error \"No results but parse succeeded?\"" - , " [Ok x] -> showTree v x" - , " xs@(_:_) -> showSeveralTrees v xs" - , " where" - , " showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()" - , " showSeveralTrees v trees" - , " = sequence_ " - , " [ do putStrV v (replicate 40 '-')" - , " putStrV v $ \"Parse number: \" ++ show n" - , " showTree v t" - , " | (Ok t,n) <- zip trees [1..]" - , " ]" - ] - - -lift_parser - = unlines - [ "type Forest = FiniteMap ForestId [Branch] -- omitted in ParX export." - , "data GLR_Output a" - , " = GLR_Result { pruned_decode :: (Forest -> Forest) -> [a]" - , " , semantic_result :: [a]" - , " }" - , " | GLR_Fail { main_message :: String" - , " , extra_info :: String" - , " }" - , "" - , "lift_parser" - , " :: (TreeDecode a, Show a, Print a)" - , " => ([[Token]] -> GLRResult) -> ParseFun a" - , "lift_parser parser ts" - , " = let result = parser ts in" - , " (\\o -> (result, o)) $" - , " case result of" - , " ParseError ts f -> GLR_Fail \"Parse failed, unexpected token(s)\\n\"" - , " (\"Tokens: \" ++ show ts)" - , " ParseEOF f -> GLR_Fail \"Parse failed, unexpected EOF\\n\"" - , " (\"Partial forest:\\n\"" - , " ++ unlines (map show $ fmToList f))" - , " ParseOK r f -> let find f = fromJust . lookupFM f" - , " dec_fn f = decode (find f) r" - , " in GLR_Result (\\ff -> dec_fn $ ff f) (dec_fn f)" - ] diff --git a/formats/haskell2/HaskellTop.hs~ b/formats/haskell2/HaskellTop.hs~ deleted file mode 100644 --- a/formats/haskell2/HaskellTop.hs~ +++ /dev/null @@ -1,356 +0,0 @@ -{- - BNF Converter: Haskell main file - Copyright (C) 2004 Author: Markus Forberg, Peter Gammie, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module HaskellTop (makeAll) where - - - --- import Utils -import CF -import CFtoHappy -import CFtoAlex -import CFtoAlex2 -import CFtoLatex -import CFtoTxt -import CFtoAbstract -import CFtoTemplate -import CFtoPrinter -import CFtoLayout -import CFtoXML -import MkErrM -import MkSharedString --- import CFtoGF ( cf2AbsGF, cf2ConcGF ) --- import System.IO -import GetCF -import Utils - -import Data.Char -import Data.Maybe (fromMaybe,maybe) -import System.IO -import Control.Monad(when) - --- naming conventions - -noLang :: Options -> String -> String -noLang _ name = name - -withLang :: Options -> String -> String -withLang opts name = name ++ lang opts - -withLangAbs :: Options -> String -> String -withLangAbs opts name = postp $ name ++ lang opts - where - postp nam = if multi opts - then takeWhile (/='_') nam - else nam - -mkMod :: (Options -> String -> String) -> String -> Options -> String -mkMod addLang name opts = - pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name - where pref = maybe "" (++".") (inPackage opts) - -mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath -mkFile addLang name ext opts = - pref ++ if inDir opts - then lang opts ++ [pathSep] ++ name ++ ext' - else addLang opts name ++ if null ext then "" else ext' - where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts) - ext' = if null ext then "" else "." ++ ext - -absFile, absFileM, alexFile, alexFileM, dviFile, - gfAbs, gfConc, - happyFile, happyFileM, - latexFile, errFile, errFileM, - templateFile, templateFileM, - printerFile, printerFileM, - layoutFile, layoutFileM, - psFile, tFile, tFileM :: Options -> String -absFile = mkFile withLangAbs "Abs" "hs" -absFileM = mkMod withLangAbs "Abs" -alexFile = mkFile withLang "Lex" "x" -alexFileM = mkMod withLang "Lex" -happyFile = mkFile withLang "Par" "y" -happyFileM = mkMod withLang "Par" -latexFile = mkFile withLang "Doc" "tex" -txtFile = mkFile withLang "Doc" "txt" -templateFile = mkFile withLang "Skel" "hs" -templateFileM = mkMod withLang "Skel" -printerFile = mkFile withLang "Print" "hs" -printerFileM = mkMod withLang "Print" -dviFile = mkFile withLang "Doc" "dvi" -psFile = mkFile withLang "Doc" "ps" -gfAbs = mkFile withLangAbs "" "Abs.gf" -gfConc = mkFile withLang "" "Conc.gf" -tFile = mkFile withLang "Test" "hs" -tFileM = mkMod withLang "Test" -errFile = mkFile noLang "ErrM" "hs" -errFileM = mkMod noLang "ErrM" -shareFile = mkFile noLang "SharedString" "hs" -shareFileM = mkMod noLang "SharedString" -layoutFileM = mkMod withLang "Layout" -xmlFileM = mkMod withLang "XML" -layoutFile = mkFile withLang "Layout" "hs" - -data Options = Options - { - make :: Bool, - alex1 :: Bool, - inDir :: Bool, - shareStrings :: Bool, - byteStrings :: Bool, - glr :: HappyMode, - xml :: Int, - inPackage :: Maybe String, - lang :: String, - multi :: Bool - } - -makeAll :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int - -> Maybe String -- ^ The hierarchical package to put the modules - -- in, or Nothing. - -> String -> Bool -> FilePath -> IO () -makeAll m a1 d ss bs g x p n mu file = do - let opts = Options { make = m, alex1 = a1, inDir = d, shareStrings = ss, byteStrings=bs, - glr = if g then GLR else Standard, xml = x, - inPackage = p, lang = n, multi = mu} - - absMod = absFileM opts - lexMod = alexFileM opts - parMod = happyFileM opts - prMod = printerFileM opts - layMod = layoutFileM opts - errMod = errFileM opts - shareMod = shareFileM opts - (cf, isOK) <- tryReadCF file - if isOK then do - let dir = codeDir opts - when (not (null dir)) $ do - putStrLn $ "Creating directory " ++ dir - prepareDir dir - writeFileRep (absFile opts) $ cf2Abstract (byteStrings opts) absMod cf - if alex1 opts then do - writeFileRep (alexFile opts) $ cf2alex lexMod errMod cf - putStrLn " (Use Alex 1.1 to compile.)" - else do - writeFileRep (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf - putStrLn " (Use Alex 2.0 to compile.)" - writeFileRep (happyFile opts) $ - cf2HappyS parMod absMod lexMod errMod (glr opts) (byteStrings opts) cf - putStrLn " (Tested with Happy 1.15)" - writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf - writeFileRep (txtFile opts) $ cfToTxt (lang opts) cf - writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod cf - writeFileRep (printerFile opts) $ cf2Printer (byteStrings opts) prMod absMod cf - when (hasLayout cf) $ writeFileRep (layoutFile opts) $ cf2Layout (alex1 opts) (inDir opts) layMod lexMod cf - writeFileRep (tFile opts) $ testfile opts cf - writeFileRep (errFile opts) $ errM errMod cf - when (shareStrings opts) $ writeFileRep (shareFile opts) $ sharedString shareMod (byteStrings opts) cf - when (make opts) $ writeFileRep "Makefile" $ makefile opts - case xml opts of - 2 -> makeXML (lang opts) True cf - 1 -> makeXML (lang opts) False cf - _ -> return () - putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -pkgToDir :: String -> FilePath -pkgToDir s = replace '.' pathSep s - -codeDir :: Options -> FilePath -codeDir opts = let pref = maybe "" pkgToDir (inPackage opts) - dir = if inDir opts then lang opts else "" - sep = if null pref || null dir then "" else [pathSep] - in pref ++ sep ++ dir - -makefile :: Options -> String -makefile opts = makeA where - glr_params = if glr opts == GLR then "--glr --decode " else "" - dir = let d = codeDir opts in if null d then "" else d ++ [pathSep] - cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")" - makeA = unlines - [ - "all:", - "\thappy -gca " ++ glr_params ++ happyFile opts, - "\talex -g " ++ alexFile opts, - "\t" ++ cd ("latex " ++ basename (latexFile opts) - ++ "; " ++ "dvips " ++ basename (dviFile opts) - ++ " -o " ++ basename (psFile opts)), - "\tghc --make " ++ tFile opts ++ " -o " ++ mkFile withLang "Test" "" opts, - "clean:", - "\t-rm -f " ++ unwords (map (dir++) [ - "*.log", "*.aux", "*.hi", - "*.o", "*.dvi" - ]), - "\t-rm -f " ++ psFile opts, - - "distclean: clean", - "\t-rm -f " ++ unwords [ - mkFile withLang "Doc" "*" opts, - mkFile withLang "Lex" "*" opts, - mkFile withLang "Par" "*" opts, - mkFile withLang "Layout" "*" opts, - mkFile withLang "Skel" "*" opts, - mkFile withLang "Print" "*" opts, - mkFile withLang "Test" "*" opts, - mkFile withLang "Abs" "*" opts, - mkFile withLang "Test" "" opts, - mkFile noLang "ErrM" "*" opts, - mkFile noLang "SharedString" "*" opts, - dir ++ lang opts ++ ".dtd", - mkFile withLang "XML" "*" opts, - "Makefile*" - ], - if null dir then "" else "\t-rmdir -p " ++ dir - ] - - -testfile :: Options -> CF -> String -testfile opts cf - = let lay = hasLayout cf - use_xml = xml opts > 0 - xpr = if use_xml then "XPrint a, " else "" - use_glr = glr opts == GLR - if_glr s = if use_glr then s else "" - firstParser = if use_glr then "the_parser" else parserName - parserName = 'p' : topType - topType = firstEntry cf - in unlines - ["-- automatically generated by BNF Converter", - "module Main where\n", - "", - "import System.IO ( stdin, hGetContents )", - "import System.IO ( getArgs, getProgName )", - "", - "import " ++ alexFileM opts, - "import " ++ happyFileM opts, - "import " ++ templateFileM opts, - "import " ++ printerFileM opts, - "import " ++ absFileM opts, - if lay then ("import " ++ layoutFileM opts) else "", - if use_xml then ("import " ++ xmlFileM opts) else "", - if_glr "import Data.FiniteMap(FiniteMap, lookupFM, fmToList)", - if_glr "import Data.Maybe(fromJust)", - "import " ++ errFileM opts, - "", - if use_glr - then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))" - else "type ParseFun a = [Token] -> Err a", - "", - "myLLexer = " ++ if lay then "resolveLayout True . myLexer" - else "myLexer", - "", - "type Verbosity = Int", - "", - "putStrV :: Verbosity -> String -> IO ()", - "putStrV v s = if v > 1 then putStrLn s else return ()", - "", - "runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()", - "runFile v p f = putStrLn f >> readFile f >>= run v p", - "", - "run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()", - if use_glr then run_glr else run_std use_xml, - "", - "showTree :: (Show a, Print a) => Int -> a -> IO ()", - "showTree v tree", - " = do", - " putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree", - " putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree", - "", - "main :: IO ()", - "main = do args <- getArgs", - " case args of", - " [] -> hGetContents stdin >>= run 2 " ++ firstParser, - " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs", - " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs", - "", - if_glr $ "the_parser :: ParseFun " ++ topType, - if_glr $ "the_parser = lift_parser " ++ parserName, - if_glr $ "", - if_glr $ lift_parser - ] - -run_std xml - = unlines - [ "run v p s = let ts = myLLexer s in case p ts of" - , " Bad s -> do putStrLn \"\\nParse Failed...\\n\"" - , " putStrV v \"Tokens:\"" - , " putStrV v $ show ts" - , " putStrLn s" - , " Ok tree -> do putStrLn \"\\nParse Successful!\"" - , " showTree v tree" - , if xml then - " putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree" - else "" - ] - -run_glr - = unlines - [ "run v p s" - , " = let ts = map (:[]) $ myLLexer s" - , " (raw_output, simple_output) = p ts in" - , " case simple_output of" - , " GLR_Fail major minor -> do" - , " putStrLn major" - , " putStrV v minor" - , " GLR_Result df trees -> do" - , " putStrLn \"\\nParse Successful!\"" - , " case trees of" - , " [] -> error \"No results but parse succeeded?\"" - , " [Ok x] -> showTree v x" - , " xs@(_:_) -> showSeveralTrees v xs" - , " where" - , " showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()" - , " showSeveralTrees v trees" - , " = sequence_ " - , " [ do putStrV v (replicate 40 '-')" - , " putStrV v $ \"Parse number: \" ++ show n" - , " showTree v t" - , " | (Ok t,n) <- zip trees [1..]" - , " ]" - ] - - -lift_parser - = unlines - [ "type Forest = FiniteMap ForestId [Branch] -- omitted in ParX export." - , "data GLR_Output a" - , " = GLR_Result { pruned_decode :: (Forest -> Forest) -> [a]" - , " , semantic_result :: [a]" - , " }" - , " | GLR_Fail { main_message :: String" - , " , extra_info :: String" - , " }" - , "" - , "lift_parser" - , " :: (TreeDecode a, Show a, Print a)" - , " => ([[Token]] -> GLRResult) -> ParseFun a" - , "lift_parser parser ts" - , " = let result = parser ts in" - , " (\\o -> (result, o)) $" - , " case result of" - , " ParseError ts f -> GLR_Fail \"Parse failed, unexpected token(s)\\n\"" - , " (\"Tokens: \" ++ show ts)" - , " ParseEOF f -> GLR_Fail \"Parse failed, unexpected EOF\\n\"" - , " (\"Partial forest:\\n\"" - , " ++ unlines (map show $ fmToList f))" - , " ParseOK r f -> let find f = fromJust . lookupFM f" - , " dec_fn f = decode (find f) r" - , " in GLR_Result (\\ff -> dec_fn $ ff f) (dec_fn f)" - ] diff --git a/formats/haskell2/MkErrM.hs b/formats/haskell2/MkErrM.hs deleted file mode 100644 --- a/formats/haskell2/MkErrM.hs +++ /dev/null @@ -1,51 +0,0 @@ -{- - BNF Converter: Haskell error monad - Copyright (C) 2004-2007 Author: Markus Forberg, Peter Gammie, - Aarne Ranta, Björn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} -module MkErrM where - -errM :: String -> b -> String -errM errMod _ = unlines - [ - "-- BNF Converter: Error Monad", - "-- Copyright (C) 2004 Author: Aarne Ranta", - "", - "-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.", - "module " ++ errMod ++ " 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/formats/haskell2/MkSharedString.hs b/formats/haskell2/MkSharedString.hs deleted file mode 100644 --- a/formats/haskell2/MkSharedString.hs +++ /dev/null @@ -1,67 +0,0 @@ -{- - BNF Converter: Haskell string sharing - Copyright (C) 2004-2007 Author: Björn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} -module MkSharedString where - -sharedString :: String -> Bool -> b -> String -sharedString shareMod byteString _ = unlines $ - if byteString - then - [ - "module " ++ shareMod ++ " (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'" - ] - else - [ - "module " ++ shareMod ++ " (shareString) where", - "", - "import Data.HashTable as H", - "import System.IO.Unsafe (unsafePerformIO)", - "", - "{-# NOINLINE stringPool #-}", - "stringPool :: HashTable String String", - "stringPool = unsafePerformIO $ new (==) hashString", - "", - "{-# NOINLINE shareString #-}", - "shareString :: String -> String", - "shareString s = unsafePerformIO $ do", - " mv <- H.lookup stringPool s", - " case mv of", - " Just s' -> return s'", - " Nothing -> do", - " H.insert stringPool s s", - " return s" - ] diff --git a/formats/haskell2/RegToAlex.hs b/formats/haskell2/RegToAlex.hs deleted file mode 100644 --- a/formats/haskell2/RegToAlex.hs +++ /dev/null @@ -1,88 +0,0 @@ -{- - BNF Converter: Regular expression pretty printer - Copyright (C) 2004 Author: BNF Converter, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module RegToAlex (printRegAlex) where - --- modified from pretty-printer generated by the BNF converter - -import AbsBNF -import Data.Char - --- the top-level printing method -printRegAlex :: Reg -> String -printRegAlex = render . prt 0 - --- you may want to change render and parenth - -render :: [String] -> String -render = rend (0::Int) where - rend i ss = case ss of - "[" :ts -> cons "[" $ rend i ts - "(" :ts -> cons "(" $ rend i ts - t : "," :ts -> cons t $ space "," $ rend i ts - t : ")" :ts -> cons t $ cons ")" $ rend i ts - t : "]" :ts -> cons t $ cons "]" $ rend i ts - t :ts -> space t $ rend i ts - _ -> "" - cons s t = s ++ t - new i s = s - space t s = if null s then t else t ++ " " ++ s - -parenth :: [String] -> [String] -parenth ss = ["("] ++ ss ++ [")"] - --- the printer class does the job -class Print a where - prt :: Int -> a -> [String] - prtList :: [a] -> [String] - prtList = concat . map (prt 0) - -instance Print a => Print [a] where - prt _ = prtList - -instance Print Char where - prt _ c = if isAlphaNum c then [[c]] else ['^':[c]] - prtList s = map (concat . prt 0) s - -prPrec :: Int -> Int -> [String] -> [String] -prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) - RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) - RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) - RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) - RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) - ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) - REps -> prPrec i 3 (["$"]) - RChar c -> prPrec i 3 (concat [prt 0 c]) - RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]]) - RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) - RDigit -> prPrec i 3 (concat [["^d"]]) - RLetter -> prPrec i 3 (concat [["^l"]]) - RUpper -> prPrec i 3 (concat [["^c"]]) - RLower -> prPrec i 3 (concat [["^s"]]) - RAny -> prPrec i 3 (concat [["^u"]]) - - - diff --git a/formats/java/CFtoCup.hs b/formats/java/CFtoCup.hs deleted file mode 100644 --- a/formats/java/CFtoCup.hs +++ /dev/null @@ -1,282 +0,0 @@ -{- - BNF Converter: Java Cup Generator - Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the CUP input file. It - follows the same basic structure of CFtoHappy. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 26 April, 2003 - - Modified : 2 September, 2003 - - - ************************************************************** --} -module CFtoCup ( cf2Cup ) where - -import CF -import Data.List (intersperse, isPrefixOf) -import Data.Char (isUpper) -import NamedVariables -import TypeChecker -- We need to (re-)typecheck to figure out list instances in - -- defined rules. -import ErrM -import Utils ( (+++) ) - --- Type declarations -type Rules = [(NonTerminal,[(Pattern,Action)])] -type NonTerminal = String -type Pattern = String -type Action = String -type MetaVar = String - ---The environment comes from the CFtoJLex -cf2Cup :: String -> String -> CF -> SymEnv -> String -cf2Cup packageBase packageAbsyn cf env = unlines - [ - header, - declarations packageAbsyn (allCats cf), - tokens env, - specialToks cf, - specialRules cf, - prEntryPoint cf, - prRules (rulesForCup packageAbsyn cf env) - ] - where - header :: String - header = unlines - ["// -*- Java -*- This Cup file was machine-generated by BNFC", - "package" +++ packageBase ++ ";", - "", - "import java_cup.runtime.*;", - "import" +++ packageAbsyn ++ ".*;", - "", - "parser code {:", - parseMethod packageAbsyn (firstEntry cf), - definedRules packageAbsyn cf, - -- unlines $ map (parseMethod packageAbsyn) (allEntryPoints cf), - "public void syntax_error(Symbol cur_token)", - "{", - "\treport_error(\"Syntax Error, trying to recover and continue parse...\", cur_token);", - "}", - "", - "public void unrecovered_syntax_error(Symbol cur_token) throws java.lang.Exception", - "{", - "\tthrow new Exception(\"Unrecoverable Syntax Error\");", - "}", - "", - ":}" - ] - -definedRules :: String -> CF -> String -definedRules packageAbsyn cf@((pr,_),_) = - unlines [ rule f xs e | FunDef f xs e <- pr ] - where - ctx = buildContext cf - - list = LC (const "null") (\t -> "List" ++ unBase t) - where - unBase (ListT t) = unBase t - unBase (BaseT x) = normCat x - - rule f xs e = - case checkDefinition' list ctx f xs e of - Bad err -> error $ "Panic! This should have been caught already:\n" ++ err - Ok (args,(e',t)) -> unlines - [ "public " ++ javaType t ++ " " ++ f ++ "_ (" ++ - concat (intersperse ", " $ map javaArg args) ++ ") {" - , " return " ++ javaExp e' ++ ";" - , "}" - ] - where - - javaType :: Base -> String - javaType (ListT (BaseT x)) = packageAbsyn ++ ".List" ++ normCat x - javaType (ListT t) = javaType t - javaType (BaseT x) - | isToken x ctx = "String" - | otherwise = packageAbsyn ++ "." ++ normCat x - - javaArg :: (String, Base) -> String - javaArg (x,t) = javaType t ++ " " ++ x ++ "_" - - javaExp :: Exp -> String - javaExp (App "null" []) = "null" - javaExp (App x []) - | elem x xs = x ++ "_" -- argument - javaExp (App t [e]) - | isToken t ctx = call ("new String") [e] - javaExp (App x es) - | isUpper (head x) = call ("new " ++ packageAbsyn ++ "." ++ x) es - | otherwise = call (x ++ "_") es - javaExp (LitInt n) = "new Integer(" ++ show n ++ ")" - javaExp (LitDouble x) = "new Double(" ++ show x ++ ")" - javaExp (LitChar c) = "new Character(" ++ show c ++ ")" - javaExp (LitString s) = "new String(" ++ show s ++ ")" - - call x es = x ++ "(" ++ concat (intersperse ", " $ map javaExp es) ++ ")" - --- peteg: FIXME JavaCUP can only cope with one entry point AFAIK. -prEntryPoint :: CF -> String -prEntryPoint cf = unlines ["", "start with " ++ firstEntry cf ++ ";", ""] --- [ep] -> unlines ["", "start with " ++ ep ++ ";", ""] --- eps -> error $ "FIXME multiple entry points." ++ show eps - ---This generates a parser method for each entry point. -parseMethod :: String -> Cat -> String -parseMethod packageAbsyn cat = - if normCat cat /= cat - then "" - else unlines - [ - " public" +++ packageAbsyn ++ "." ++ cat' +++ "p" ++ cat' ++ "()" - ++ " throws Exception", - " {", - "\tSymbol res = parse();", - "\treturn (" ++ packageAbsyn ++ "." ++ cat' ++ ") res.value;", - " }" - ] - where cat' = identCat (normCat cat) - ---non-terminal types -declarations :: String -> [NonTerminal] -> String -declarations packageAbsyn ns = unlines (map (typeNT packageAbsyn) ns) - where - typeNT _nm nt = "nonterminal" +++ packageAbsyn ++ "." - ++ identCat (normCat nt) +++ identCat nt ++ ";" - ---terminal types -tokens :: SymEnv -> String -tokens ts = unlines (map declTok ts) - where - declTok (s,r) = "terminal" +++ r ++ "; // " ++ s - -specialToks :: CF -> String -specialToks cf = unlines [ - ifC "String" "terminal String _STRING_;", - ifC "Char" "terminal Character _CHAR_;", - ifC "Integer" "terminal Integer _INTEGER_;", - ifC "Double" "terminal Double _DOUBLE_;", - ifC "Ident" "terminal String _IDENT_;" - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - --- This handles user defined tokens --- FIXME -specialRules:: CF -> String -specialRules cf = - unlines ["terminal String " ++ name ++ ";" | (name, _) <- tokenPragmas cf] - ---The following functions are a (relatively) straightforward translation ---of the ones in CFtoHappy.hs -rulesForCup :: String -> CF -> SymEnv -> Rules -rulesForCup packageAbsyn cf env = map mkOne $ ruleGroups cf where - mkOne (cat,rules) = constructRule packageAbsyn cf env rules cat - --- For every non-terminal, we construct a set of rules. A rule is a sequence of --- terminals and non-terminals, and an action to be performed. -constructRule :: String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) -constructRule packageAbsyn cf env rules nt = - (nt, [(p,generateAction packageAbsyn nt (funRule r) (revM b m)) - | r0 <- rules, - let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True, revSepListRule r0) - else (False, r0) - (p,m) = generatePatterns cf env r]) - where - --this basically reverses revSepListRule for the parameters - revM False m = m - revM True (h:c:t) = (t ++ [c] ++ [h]) - revs = reversibleCats cf - --- Generates a string containing the semantic action. -generateAction :: String -> NonTerminal -> Fun -> [MetaVar] -> Action -generateAction packageAbsyn nt f ms = - if isNilFun f - then "RESULT = null;" - else if isOneFun f - then "RESULT = new " ++ packageAbsyn ++ "." ++ identCat (normCat nt) ++ - (concat $ ["("] ++ ms ++ [",null);"]) - else - (unwords $ - (if isCoercion f then [unwords revLists, "RESULT = "] - else if isDefinedRule f then [unwords revLists, "RESULT = parser." ++ f ++ "_"] - else [unwords revLists, "RESULT = new " ++ packageAbsyn ++ "." ++ f'] - )) - ++ (concat $ ["("] ++ ms'' ++ [");"]) - where - f' = if isConsFun f then identCat (normCat nt) - else f - (revLists, ms') = revMs [] [] ms - ms'' = reverse ms' - revMs ls ns [] = (ls,ns) - revMs ls ns (m:ms) = if "list_" `isPrefixOf` m - then revMs (("if (" ++ m' ++ " != null) " ++ m' ++ " = " ++ m' ++ ".reverse(); ") : ls) - (m' : ns) ms - else revMs ls (m:ns) ms - where m' = drop 5 m --remove the list marker - --- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal -generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar]) -generatePatterns cf env r = case rhsRule r of - [] -> (" /* empty */ ",[]) - its -> (mkIt env 1 its, metas its) - where - mkIt _env _n [] = [] - mkIt env n (i:is) = case i of - Left c -> c' ++ ":p_" ++ (show (n :: Int)) +++ (mkIt env (n+1) is) - where - c' = case c of - "Ident" -> "_IDENT_" - "Integer" -> "_INTEGER_" - "Char" -> "_CHAR_" - "Double" -> "_DOUBLE_" - "String" -> "_STRING_" - _ -> identCat c - Right s -> case (lookup s env) of - (Just x) -> x +++ (mkIt env (n+1) is) - (Nothing) -> (mkIt env n is) - metas its = intersperse "," [revIf c ("p_" ++ (show i)) | (i,Left c) <- zip [1 :: Int ..] its] - --This is slightly messy, but it marks lists for reversal. - revIf c m = if (not (isConsFun (funRule r)) && elem c revs) - then "list_" ++ m -- ("(reverse " ++ m ++ ")") --not yet! - else m -- no reversal in the left-recursive Cons rule itself - revs = reversibleCats cf - --- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string. -prRules :: Rules -> String -prRules [] = [] -prRules ((nt, []):rs) = prRules rs --internal rule -prRules ((nt,((p,a):ls)):rs) = - (unwords [nt', "::=", p, "{:", a, ":}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs - where - nt' = identCat nt - pr [] = [] - pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{:", a , ":}"])]) ++ pr ls - diff --git a/formats/java/CFtoJLex.hs b/formats/java/CFtoJLex.hs deleted file mode 100644 --- a/formats/java/CFtoJLex.hs +++ /dev/null @@ -1,174 +0,0 @@ -{- - BNF Converter: Java JLex generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the JLex input file. This - file is quite different than Alex or Flex. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 25 April, 2003 - - Modified : 2 September, 2003 - - - ************************************************************** --} - -module CFtoJLex ( cf2jlex ) where - -import CF -import RegToJLex -import Utils ( (+++) ) -import NamedVariables -import Data.List - ---The environment must be returned for the parser to use. -cf2jlex :: String -> String -> CF -> (String, SymEnv) -cf2jlex packageBase packageAbsyn cf = (unlines $ concat $ - [ - prelude packageBase packageAbsyn, - cMacros, - lexSymbols env, - restOfJLex cf - ], env) - where - env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) - makeSymEnv [] _ = [] - makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) - -prelude :: String -> String -> [String] -prelude packageBase packageAbsyn = - [ - "// This JLex file was machine-generated by the BNF converter", - "package" +++ packageBase ++ ";", - "", - "import java_cup.runtime.*;", - "import " ++ packageAbsyn ++ ".*;", - "%%", - "%cup", - "%full", - "%line", - "%{", - " String pstring = new String();", - " public int line_num() { return (yyline+1); }", - " public String buff() { return new String(yy_buffer,yy_buffer_index,10).trim(); }", - "%}" - ] - ---For now all categories are included. ---Optimally only the ones that are used should be generated. -cMacros :: [String] -cMacros = [ - "LETTER = ({CAPITAL}|{SMALL})", - "CAPITAL = [A-Z\\xC0-\\xD6\\xD8-\\xDE]", - "SMALL = [a-z\\xDF-\\xF6\\xF8-\\xFF]", - "DIGIT = [0-9]", - "IDENT = ({LETTER}|{DIGIT}|['_])", - "%state COMMENT", - "%state CHAR", - "%state CHARESC", - "%state CHAREND", - "%state STRING", - "%state ESCAPED", - "%%" - ] - -lexSymbols :: SymEnv -> [String] -lexSymbols ss = map transSym ss - where - transSym (s,r) = - "" ++ (escapeChars s) ++ " { return new Symbol(sym." - ++ r ++ "); }" - -restOfJLex :: CF -> [String] -restOfJLex cf = - [ - lexComments (comments cf), - userDefTokens, - ifC "String" strStates, - ifC "Char" chStates, - ifC "Double" "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }", - ifC "Integer" "{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }", - ifC "Ident" "{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, new String(yytext())); }" - , "[ \\t\\r\\n\\f] { /* ignore white space. */ }" - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - userDefTokens = unlines $ - ["" ++ printRegJLex exp +++ - "{ return new Symbol(sym." ++ name ++ ", yytext()); }" - | (name, exp) <- tokenPragmas cf] - strStates = unlines --These handle escaped characters in Strings. - [ - "\"\\\"\" { yybegin(STRING); }", - "\\\\ { yybegin(ESCAPED); }", - "\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo); }", - ". { pstring += yytext(); }", - "n { pstring += \"\\n\"; yybegin(STRING); }", - "\\\" { pstring += \"\\\"\"; yybegin(STRING); }", - "\\\\ { pstring += \"\\\\\"; yybegin(STRING); }", - "t { pstring += \"\\t\"; yybegin(STRING); }", - ". { pstring += yytext(); yybegin(STRING); }" - ] - chStates = unlines --These handle escaped characters in Chars. - [ - "\"'\" { yybegin(CHAR); }", - "\\\\ { yybegin(CHARESC); }", - "[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", - "n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }", - "t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }", - ". { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", - "\"'\" {yybegin(YYINITIAL);}" - ] - - - - -lexComments :: ([(String, String)], [String]) -> String -lexComments (m,s) = - (unlines (map lexSingleComment s)) - ++ (unlines (map lexMultiComment m)) - -lexSingleComment :: String -> String -lexSingleComment c = - "\"" ++ c ++ "\"[^\\n]*\\n { /* BNFC single-line comment */ }" - ---There might be a possible bug here if a language includes 2 multi-line comments. ---They could possibly start a comment with one character and end it with another. ---However this seems rare. -lexMultiComment :: (String, String) -> String -lexMultiComment (b,e) = unlines [ - "\"" ++ b ++ "\" { yybegin(COMMENT); }", - "\"" ++ e ++ "\" { yybegin(YYINITIAL); }", - ". { }", - "[\\n] { }" - ] - --- lexReserved :: String -> String --- lexReserved s = "\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }" - ---Helper function that escapes characters in strings -escapeChars :: String -> String -escapeChars = concatMap escapeChar diff --git a/formats/java/CFtoJavaAbs.hs b/formats/java/CFtoJavaAbs.hs deleted file mode 100644 --- a/formats/java/CFtoJavaAbs.hs +++ /dev/null @@ -1,238 +0,0 @@ -{- - BNF Converter: Java Abstract Syntax - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the Java Abstract Syntax - It uses the NamedVariables module for variable - naming. It returns a list of file names, and the - contents to be written into that file. (In Java - public classes must go in their own file.) - - The generated classes also support the Visitor - Design Pattern. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 24 April, 2003 - - Modified : 2 September, 2003 - - - ************************************************************** --} - -module CFtoJavaAbs (cf2JavaAbs) where - -import CF -import Utils((+++),(++++)) -import NamedVariables hiding (IVar, getVars, varName) -import Data.List -import Data.Char(toLower) - ---Produces abstract data types in Java. ---These follow Appel's "non-object oriented" version. ---They also allow users to use the Visitor design pattern. - -type IVar = (String, Int, String) ---The type of an instance variable ---a # unique to that type ---and an optional name (handles typedefs). - ---The result is a list of files which must be written to disk. ---The tuple is (FileName, FileContents) -cf2JavaAbs :: String -> String -> CF -> [(FilePath, String)] -cf2JavaAbs packageBase packageAbsyn cf = - concat (map (prData header packageBase user) (cf2dataLists cf)) - where - header = "package " ++ packageAbsyn ++ "; // Java Package generated by the BNF Converter.\n" - user = [n | (n,_) <- tokenPragmas cf] - ---Generates a (possibly abstract) category class, and classes for all its rules. -prData :: String -> String -> [UserDef] -> Data ->[(String, String)] -prData header name user (cat, rules) = - (identCat cat, header ++++ - "public abstract class" +++ (identCat cat) +++ "implements" +++ name ++ ".Visitable {}\n") : - prRules header name user cat rules --don't use map because some will be Nil - where - prRules h n u c [] = [] --this is basically a map which excludes Nil values. - prRules h n u c (f:fs) = case res of - ("","") -> prRules h n u c fs - z -> res : (prRules h n u c fs) - where res = prRule h n u c f - ---Generates classes for a rule, depending on what type of rule it is. -prRule h name user c (fun, cats) = - if isNilFun fun || isOneFun fun - then ("","") --these are not represented in the AbSyn - else if isConsFun fun - then (fun', --this is the linked list case. - unlines - [ - h, - "public class" +++ fun' +++ "implements"+++ name ++ ".Visitable", - "{", - (prInstVars vs), - prConstructor fun' user vs cats, - prListFuncs fun', - prAccept name fun', - "}" - ]) - else (fun, --a standard rule - unlines - [ - h, - "public class" +++ fun +++ ext +++ "implements"+++ name ++ ".Visitable", - "{", - (prInstVars vs), - prConstructor fun user vs cats, - prAccept name fun, - "}\n" - ]) - where - vs = getVars cats user - fun' = identCat (normCat c) - --This handles the case where a LBNF label is the same as the category. - ext = if fun == c then "" else "extends" +++ (identCat c) - ---These are all built-in list functions. ---Later we could include things like lookup,insert,delete,etc. -prListFuncs :: String -> String -prListFuncs c = unlines - [ - " public" +++ c +++ "reverse()", - " {", - " if (" ++ v +++ "== null) return this;", - " else", - " {", - " " ++ c ++ " tmp =" +++ v ++ ".reverse(this);", - " " ++ v +++ "= null;", - " return tmp;", - " }", - " }", - " public" +++ c +++ "reverse(" ++ c +++ "prev)", - " {", - " if (" ++ v +++ "== null)", - " {", - " " ++ v +++ "= prev;", - " return this;", - " }", - " else", - " {", - " " ++ c +++ "tmp =" +++ v ++ ".reverse(this);", - " " ++ v +++ "= prev;", - " return tmp;", - " }", - " }" - ] - where - v = (map toLower c) ++ "_" - ---The standard accept function for the Visitor pattern -prAccept :: String -> String -> String -prAccept pack ty = - "\n public void accept(" ++ pack ++ ".Visitor v) { v.visit" ++ ty ++ "(this); }" - ---A class's instance variables. -prInstVars :: [IVar] -> String -prInstVars [] = [] -prInstVars vars@((t,n,nm):vs) = - " public" +++ t +++ uniques ++ ";" ++++ - (prInstVars vs') - where - (uniques, vs') = prUniques t vars - --these functions group the types together nicely - prUniques :: String -> [IVar] -> (String, [IVar]) - prUniques t vs = (prVars (findIndices (\x -> case x of (y,_,_) -> y == t) vs) vs, remType t vs) - prVars (x:[]) vs = case vs !! x of - (t,n,nm) -> ((varName t nm) ++ (showNum n)) - prVars (x:xs) vs = case vs !! x of - (t,n,nm) -> ((varName t nm) ++ (showNum n)) ++ "," +++ - (prVars xs vs) - remType :: String -> [IVar] -> [IVar] - remType _ [] = [] - remType t ((t2,n,nm):ts) = if t == t2 - then (remType t ts) - else (t2,n,nm) : (remType t ts) - ---The constructor just assigns the parameters to the corresponding instance variables. -prConstructor :: String -> [UserDef] -> [IVar] -> [Cat] -> String -prConstructor c u vs cats = - " public" +++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" +++ - prAssigns vs params ++ "}" - where - (types, params) = unzip (prParams cats u (length cats) ((length cats)+1)) - interleave _ [] = [] - interleave (x:[]) (y:[]) = x +++ y - interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys) - ---Prints the parameters to the constructors. -prParams :: [Cat] -> [UserDef] -> Int -> Int -> [(String,String)] -prParams [] _ _ _ = [] -prParams (c:cs) u n m = (identCat c',"p" ++ (show (m-n))) - : (prParams cs u (n-1) m) - where - c' = typename c u - ---This algorithm peeks ahead in the list so we don't use map or fold -prAssigns :: [IVar] -> [String] -> String -prAssigns [] _ = [] -prAssigns _ [] = [] -prAssigns ((t,n,nm):vs) (p:ps) = - if n == 1 then - case findIndices (\x -> case x of (l,r,_) -> l == t) vs of - [] -> (varName t nm) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) - z -> ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) - else ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) - ---Different than the standard NamedVariables version because of the user-defined ---types. -getVars :: [Cat] -> [UserDef] -> [IVar] -getVars cs user = foldl (addVar user) [] (map identCat cs) - where - addVar user vs c = addVar' vs user 0 c - addVar' [] u n c = [(c', n, nm)] - where - c' = typename c user - nm = if c == c' then "" else c - addVar' (i@(t,x,nm):is) u n c = - if c == t || c == nm - then if x == 0 - then (t, 1, nm) : (addVar' is u 2 c) - else i : (addVar' is u (x+1) c) - else i : (addVar' is u n c) - - -varName c s = (map toLower c') ++ "_" - where - c' = if s == "" then c else s - ---This makes up for the fact that there's no typedef in Java -typename t user = - if t == "Ident" - then "String" - else if t == "Char" - then "Character" - else if elem t user - then "String" - else t diff --git a/formats/java/CFtoJavaPrinter.hs b/formats/java/CFtoJavaPrinter.hs deleted file mode 100644 --- a/formats/java/CFtoJavaPrinter.hs +++ /dev/null @@ -1,384 +0,0 @@ -{- - BNF Converter: Java Pretty Printer generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the Java Pretty Printer - class. In addition, since there's no good way - to display a class heirarchy (toString() doesn't - count) in Java, it generates a method that - displays the Abstract Syntax in a way similar - to Haskell. - - This uses Appel's method and may serve as a - useful example to those who wish to use it. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 24 April, 2003 - - Modified : 2 September, 2003 - - Added string buffer for efficiency (Michael, August 03) - ************************************************************** --} -module CFtoJavaPrinter ( cf2JavaPrinter ) where - -import CF -import NamedVariables -import Utils ( (+++) ) -import Data.List -import Data.Char ( toLower ) - ---Produces the PrettyPrinter class. ---It will generate two methods "print" and "show" ---print is the actual pretty printer for linearization. ---show produces a Haskell-style syntax that can be extremely useful ---especially for testing parser correctness. - -cf2JavaPrinter :: String -> String -> CF -> String -cf2JavaPrinter packageBase packageAbsyn cf = - unlines - [ - header, - prEntryPoints packageAbsyn cf, - unlines (map (prData packageAbsyn) groups), - unlines (map (shData packageAbsyn) groups), - footer - ] - where - groups = (fixCoercions (ruleGroupsInternals cf)) - header = unlines [ - "package" +++ packageBase ++ ";", - "import" +++ packageAbsyn ++ ".*;", - "", - "public class PrettyPrinter", - "{", - " //For certain applications increasing the initial size of the buffer may improve performance.", - " private static final int INITIAL_BUFFER_SIZE = 128;", - " //You may wish to change the parentheses used in precedence.", - " private static final String _L_PAREN = new String(\"(\");", - " private static final String _R_PAREN = new String(\")\");", - prRender - ] - footer = unlines [ --later only include used categories - " private static void pp(Integer n, int _i_) { buf_.append(n); buf_.append(\" \"); }", - " private static void pp(Double d, int _i_) { buf_.append(d); buf_.append(\" \"); }", - " private static void pp(String s, int _i_) { buf_.append(s); buf_.append(\" \"); }", - " private static void pp(Character c, int _i_) { buf_.append(\"'\" + c.toString() + \"'\"); buf_.append(\" \"); }", - " private static void sh(Integer n) { buf_.append(n); }", - " private static void sh(Double d) { buf_.append(d); }", - " private static void sh(Character c) { buf_.append(c); }", - " private static void sh(String s) { printQuoted(s); }", - " private static void printQuoted(String s) { buf_.append(\"\\\"\" + s + \"\\\"\"); }", - " private static void indent()", - " {", - " int n = _n_;", - " while (n > 0)", - " {", - " buf_.append(\" \");", - " n--;", - " }", - " }", - " private static void backup()", - " {", - " String s = buf_.toString();", -- peteg: java 1.1.8 compatibility. - "", - " if (s.substring(buf_.length() - 1, buf_.length()).equals(\" \")) {", - " buf_.setCharAt(buf_.length() - 1, '\\\"');", - " buf_.setLength(buf_.length() - 1);", - " }", - " }", - " private static int _n_ = 0;", - " private static StringBuffer buf_ = new StringBuffer(INITIAL_BUFFER_SIZE);", - "}" - ] - ---An extremely simple renderer for terminals. -prRender :: String -prRender = unlines - [ - " //You may wish to change render", - " private static void render(String s)", - " {", - " if (s.equals(\"{\"))", - " {", - " buf_.append(\"\\n\");", - " indent();", - " buf_.append(s);", - " _n_ = _n_ + 2;", - " buf_.append(\"\\n\");", - " indent();", - " }", - " else if (s.equals(\"(\") || s.equals(\"[\"))", - " buf_.append(s);", - " else if (s.equals(\")\") || s.equals(\"]\"))", - " {", - " backup();", - " buf_.append(s);", - " buf_.append(\" \");", - " }", - " else if (s.equals(\"}\"))", - " {", - " _n_ = _n_ - 2;", - " backup();", - " backup();", - " buf_.append(s);", - " buf_.append(\"\\n\");", - " indent();", - " }", - " else if (s.equals(\",\"))", - " {", - " backup();", - " buf_.append(s);", - " buf_.append(\" \");", - " }", - " else if (s.equals(\";\"))", - " {", - " backup();", - " buf_.append(s);", - " buf_.append(\"\\n\");", - " indent();", - " }", - " else if (s.equals(\"\")) return;", - " else", - " {", - " buf_.append(s);", - " buf_.append(\" \");", - " }", - " }" - ] - -prEntryPoints :: String -> CF -> String -prEntryPoints packageAbsyn cf = - msg ++ concat (map prEntryPoint (allEntryPoints cf)) ++ msg2 - where - msg = " // print and show methods are defined for each Entry Point type.\n" - msg2 = " /*** You shouldn't need to change anything beyond this point. ***/\n" - prEntryPoint cat | (normCat cat) == cat = unlines - [ - " public static String print(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)", - " {", - " pp(foo, 0);", - " String temp = buf_.toString();", - " buf_ = new StringBuffer(INITIAL_BUFFER_SIZE);", - " return temp;", - " }", - " public static String show(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)", - " {", - " sh(foo);", - " String temp = buf_.toString();", - " buf_ = new StringBuffer(INITIAL_BUFFER_SIZE);", - " return temp;", - " }" - ] - where - cat' = identCat cat - prEntryPoint _ = "" - -prData :: String -> (Cat, [Rule]) -> String -prData packageAbsyn (cat, rules) = - if isList cat - then unlines - [ - " private static void pp(" ++ packageAbsyn ++ "." - ++ identCat (normCat cat) +++ "foo, int _i_)", - " {", - (prList cat rules) ++ " }" - ] - else unlines --not a list - [ - " private static void pp(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo, int _i_)", - " {", - (concat (map (prRule packageAbsyn) rules)) ++ " }" - ] - -prRule :: String -> Rule -> String -prRule packageAbsyn r@(fun, (_c, cats)) - | not (isCoercion fun) && not (isDefinedRule fun) = concat - [ - " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")\n", - " {\n", - " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= (" - ++ packageAbsyn ++ "." ++ fun ++ ") foo;\n", - lparen, - cats', - rparen, - " }\n" - ] - where - p = precRule r - (lparen, rparen) = - (" if (_i_ > " ++ (show p) ++ ") render(_L_PAREN);\n", - " if (_i_ > " ++ (show p) ++ ") render(_R_PAREN);\n") - cats' = case cats of - [] -> "" - _ -> concatMap (prCat fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats)) - fnm = '_' : map toLower fun - - getPrec (Right {}) = 0 - getPrec (Left c) = precCat c - -prRule _nm (_fun, _cats) = "" - -prList :: Cat -> [Rule] -> String -prList c rules = unlines - [ - " while (foo != null)", - " {", - " if (foo." ++ c'' ++ "_ == null)", - " {", - " pp(foo." ++ c' ++ "_, 0);", - optsep, - " }", - " else", - " {", - " pp(foo." ++ c' ++ "_, 0);", - " render(\"" ++ (escapeChars sep) ++ "\");", - " }", - " foo = foo." ++ c'' ++ "_;", - " }" - ] - where - c' = map toLower (identCat (normCatOfList c)) - c'' = map toLower (identCat c) - sep = getCons rules - optsep = if hasOneFunc rules then "" else (" render(\"" ++ (escapeChars sep) ++ "\");") - -getCons :: [Rule] -> String -getCons ((f, (_c, cats)):rs) = - if isConsFun f - then seper cats - else getCons rs - where - seper [] = [] - seper ((Right x):_xs) = x - seper ((Left {}):xs) = seper xs - -hasOneFunc :: [Rule] -> Bool -hasOneFunc [] = False -hasOneFunc ((f, (_, _cats)):rs) = - if (isOneFun f) - then True - else hasOneFunc rs - -prCat fnm (c, p) = - case c of - Right t -> " render(\"" ++ escapeChars t ++ "\");\n" - Left nt | "string" `isPrefixOf` nt - -> " printQuoted(" ++ fnm ++ "." ++ nt ++ ");\n" - | isInternalVar nt -> "" - | otherwise - -> " pp(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");\n" - ---The following methods generate the Show function. - -shData :: String -> (Cat, [Rule]) -> String -shData packageAbsyn (cat, rules) = - if isList cat - then unlines - [ - " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)", - " {", - (shList cat rules) ++ " }" - ] - else unlines - [ - " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)", - " {", - (concat (map (shRule packageAbsyn) rules)) ++ " }" - ] - -shRule :: String -> Rule -> String -shRule packageAbsyn (fun, (_c, cats)) - | not (isCoercion fun) && not (isDefinedRule fun) = unlines - [ - " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")", - " {", - " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= (" - ++ packageAbsyn ++ "." ++ fun ++ ") foo;", - members ++ " }" - ] - where - members = concat - [ - lparen, - " render(\"" ++ (escapeChars fun) ++ "\");\n", - cats', - rparen - ] - cats' = if allTerms cats - then "" - else (concat (map (shCat fnm) (fixOnes (numVars [] cats)))) - (lparen, rparen) = - if allTerms cats - then ("","") - else (" render(\"(\");\n"," render(\")\");\n") - allTerms [] = True - allTerms ((Left {}):_) = False - allTerms (_:zs) = allTerms zs - fnm = '_' : map toLower fun -shRule _nm (_fun, _cats) = "" - -shList :: Cat -> [Rule] -> String -shList c _rules = unlines - [ - " while (foo != null)", - " {", - " if (foo." ++ c'' ++ "_ == null)", - " {", - " sh(foo." ++ c' ++ "_);", - " }", - " else", - " {", - " sh(foo." ++ c' ++ "_);", - " render(\",\");", - " }", - " foo = foo." ++ c'' ++ "_;", - " }" - ] - where - c' = map toLower (identCat (normCatOfList c)) - c'' = map toLower (identCat c) - - -shCat fnm c = - case c of - Right {} -> "" - Left nt | "list" `isPrefixOf` nt - -> unlines [" render(\"[\");", - " sh(" ++ fnm ++ "." ++ nt ++ ");", - " render(\"]\");"] - | isInternalVar nt -> "" - | otherwise -> " sh(" ++ fnm ++ "." ++ nt ++ ");\n" - - ---Helper function that escapes characters in strings -escapeChars :: String -> String -escapeChars [] = [] -escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) -escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) -escapeChars (x:xs) = x : (escapeChars xs) - -isInternalVar x = x == internalCat ++ "_" diff --git a/formats/java/CFtoJavaSkeleton.hs b/formats/java/CFtoJavaSkeleton.hs deleted file mode 100644 --- a/formats/java/CFtoJavaSkeleton.hs +++ /dev/null @@ -1,124 +0,0 @@ -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the Skeleton Function - using Appel's method, not the Visitor Pattern. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 29 April, 2003 - - Modified : 2 September, 2003 - - - ************************************************************** --} -module CFtoJavaSkeleton (cf2JavaSkeleton) where - -import CF -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower) - - -cf2JavaSkeleton :: String -> String -> CF -> String -cf2JavaSkeleton packageBase packageAbsyn cf = - unlines [ - header, - unlines (map (prData packageAbsyn) groups), - footer] - where - groups = (fixCoercions (ruleGroups cf)) - header = unlines [ - "package" +++ packageBase ++ ";", - "import" +++ packageAbsyn ++ ".*;", - "/*** BNFC-Generated Skeleton function. ***/", - "/* You will probably want to save this in a new file.", - " Then do two search-and-replaces.", - " First replace \"skel\" with a real funciton name.", - " Then replace Object with a real return type. */", - "", - "public class Skeleton", - "{" - ] - footer = unlines [ --later only include used categories - " public static Object skel(Integer i) { return null; }", - " public static Object skel(Double d) { return null; }", - " public static Object skel(String s) { return null; }", - "}" - ] - ---Traverses a category based on its type. -prData :: String -> (Cat, [Rule]) -> String -prData packageAbsyn (cat, rules) = - if isList cat - then unlines - [ - " public static Object skel(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)", - " {", - prList cat rules, - " }" - ] - else unlines --not a list - [ - " public static Object skel(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)", - " {", - unlines (map (prRule packageAbsyn) rules), - " return null;", - " }" - ] - ---traverses a standard rule -prRule :: String -> Rule -> String -prRule packageAbsyn (fun, (c, cats)) | not (isCoercion fun) = unlines - [ - " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")", - " {", - " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= (" - ++ packageAbsyn ++ "." ++ fun ++ ") foo;", - "", - " /* Code For " ++ fun ++ " Goes Here */", - "", - cats', - " return null;", - " }" - ] - where - cats' = if allTerms cats - then "" - else (unlines (map (prCat fnm) (fixOnes (numVars [] cats)))) - allTerms [] = True - allTerms ((Left z):zs) = False - allTerms (z:zs) = allTerms zs - fnm = map toLower fun -prRule nm (fun, cats) = "" - ---This traverses list rules. -prList :: Cat -> [Rule] -> String -prList c rules = unlines - [ - " if (foo == null)", - " {", - " /* Optional End of List Code Goes Here */", - " return null;", - " }", - " else", - " {", - " /* Optional List Member Code Goes Here */", - " skel(foo." ++ c' ++ "_);", - " skel(foo." ++ c'' ++ "_);", - " return null;", - " }" - ] - where - c' = map toLower (identCat (normCatOfList c)) - c'' = map toLower (identCat c) - ---This traverses a class's instance variables. -prCat fnm c = case c of - (Right t) -> "" - (Left nt) -> " skel(" ++ fnm ++ "." ++ nt ++ ");" diff --git a/formats/java/CFtoVisitSkel.hs b/formats/java/CFtoVisitSkel.hs deleted file mode 100644 --- a/formats/java/CFtoVisitSkel.hs +++ /dev/null @@ -1,173 +0,0 @@ -{- - BNF Converter: Java Vistor skeleton generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates a Skeleton function - which uses the Visitor Design Pattern, which - users may find more familiar than Appel's - method. - - Author : Michael Pellauer (pellauer@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 4 August, 2003 - - Modified : 2 September, 2003 - - - ************************************************************** --} -module CFtoVisitSkel (cf2VisitSkel) where - -import CF -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower, toUpper) - ---Produces a Skeleton using the Visitor Design Pattern. ---Thus the user can choose which Skeleton to use. - -cf2VisitSkel :: String -> String -> CF -> String -cf2VisitSkel packageBase packageAbsyn cf = - concat [ - header, - concatMap (prData packageAbsyn user) groups, - concatMap prUser user, - footer] - where - user = fst (unzip (tokenPragmas cf)) - groups = (fixCoercions (ruleGroups cf)) - header = unlines [ - "package" +++ packageBase ++ ";", - "import" +++ packageAbsyn ++ ".*;", - "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/", - "/* This implements the common visitor design pattern.", - " Tests show it to be slightly less efficient than the", - " instanceof method, but easier to use.", - " Note that this method uses Visitor-traversal of lists, so", - " List.accept() does NOT traverse the list. This allows different", - " algorithms to use context information differently. */", - "", - "public class VisitSkel implements Visitor", - "{" - ] - prUser u = " public void visit" ++ u' ++ "(String p) {}\n" - where - u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem. - footer = unlines - [ --later only include used categories - " public void visitIdent(String i) {}", - " public void visitInteger(Integer i) {}", - " public void visitDouble(Double d) {}", - " public void visitChar(Character c) {}", - " public void visitString(String s) {}", - "}" - ] - ---Traverses a category based on its type. -prData :: String -> [UserDef] -> (Cat, [Rule]) -> String -prData packageAbsyn user (cat, rules) = - if isList cat - then unlines - [ - " public void visit" ++ cl ++ "(" ++ packageAbsyn ++ "." ++ cl +++ vname ++ ")", - " {", - " while(" ++ vname ++ "!= null)", - " {", - " /* Code For" +++ cl +++ "Goes Here */", - visitMember, - " " ++ vname +++ "=" +++ vname ++ "." ++ vname ++ "_;", - " }", - " }" - ] --Not a list: - else abstract ++ (concatMap (prRule packageAbsyn user) rules) - where - cl = identCat (normCat cat) - ecl = identCat (normCatOfList cat) - vname = map toLower cl - member = map toLower ecl ++ "_" - visitMember = if isBasic user member - then " visit" ++ (funName member) ++ "(" ++ vname ++ "." ++ member ++ ");" - else " " ++ vname ++ "." ++ member ++ ".accept(this);" - abstract = case lookup cat rules of - Just x -> "" - Nothing -> " public void visit" ++ cl ++ "(" ++ packageAbsyn ++ "." - ++ cl +++ vname ++ ") {} //abstract class\n" - ---traverses a standard rule. -prRule :: String -> [UserDef] -> Rule -> String -prRule packageAbsyn user (fun, (c, cats)) | not (isCoercion fun) = unlines - [ - " public void visit" ++ fun ++ "(" ++ packageAbsyn ++ "." ++ fun +++ fnm ++ ")", - " {", - " /* Code For " ++ fun ++ " Goes Here */", - "", - cats' ++ " }" - ] - where - cats' = if allTerms cats - then "" - else (concatMap (prCat user fnm) (fixOnes (numVars [] cats))) - allTerms [] = True - allTerms ((Left z):zs) = False - allTerms (z:zs) = allTerms zs - fnm = map toLower fun -prRule user nm (fun, cats) = "" - ---Traverses a class's instance variables. -prCat user fnm c = - case c of - (Right t) -> "" - (Left nt) -> if isBasic user nt - then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "." ++ nt ++ ");\n" - else if "list" `isPrefixOf` nt - then " if (" ++ fnm ++ "." ++ nt ++ " != null) {" ++ accept ++ "}\n" - else " " ++ accept ++ "\n" - where - accept = fnm ++ "." ++ nt ++ ".accept(this);" - ---Just checks if something is a basic or user-defined type. ---This is because you don't -> a basic non-pointer type. -isBasic :: [UserDef] -> String -> Bool -isBasic user v = - if elem (init v) user' - then True - else if "integer_" `isPrefixOf` v then True - else if "char_" `isPrefixOf` v then True - else if "string_" `isPrefixOf` v then True - else if "double_" `isPrefixOf` v then True - else if "ident_" `isPrefixOf` v then True - else False - where - user' = map (map toLower) user - ---The visit-function name of a basic type -funName :: String -> String -funName v = - if "integer_" `isPrefixOf` v then "Integer" - else if "char_" `isPrefixOf` v then "Char" - else if "string_" `isPrefixOf` v then "String" - else if "double_" `isPrefixOf` v then "Double" - else if "ident_" `isPrefixOf` v then "Ident" - else (toUpper (head v)) : (init (tail v)) --User-defined type diff --git a/formats/java/JavaTop.hs b/formats/java/JavaTop.hs deleted file mode 100644 --- a/formats/java/JavaTop.hs +++ /dev/null @@ -1,314 +0,0 @@ -{- - BNF Converter: Java Top File - Copyright (C) 2004 Author: Markus Forsberg, Peter Gammie, Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -------------------------------------------------------------------- --- | --- Module : JavaTop --- Copyright : (C)opyright 2003, {markus, aarne, pellauer, peteg} at cs dot chalmers dot se --- License : GPL (see COPYING for details) --- --- Maintainer : {markus, aarne} at cs dot chalmers dot se --- Stability : alpha --- Portability : Haskell98 --- --- Top-level for the Java back end. --- --- > $Id: JavaTop.hs,v 1.10 2005/09/21 13:06:10 bringert Exp $ -------------------------------------------------------------------- - -module JavaTop ( makeJava ) where - -------------------------------------------------------------------- --- Dependencies. -------------------------------------------------------------------- -import System.Directory ( createDirectory ) -import System.IO.Error ( try, isAlreadyExistsError ) - -import Utils -import CF -import CFtoCup ( cf2Cup ) -import CFtoJLex -import CFtoJavaAbs ( cf2JavaAbs ) -import CFtoJavaPrinter -import CFtoJavaSkeleton -import CFtoVisitSkel -import CFtoLatex -import System.IO -import System.Exit -import GetCF ( tryReadCF, writeFileRep ) -import Data.Char -import Data.List(intersperse) - -------------------------------------------------------------------- --- | Build the Java output. --- FIXME: get everything to put the files in the right places. --- Adapt Makefile to do the business. -------------------------------------------------------------------- -makeJava :: Bool -> String -> FilePath -> IO () -makeJava make name file = - do (cf, isOK) <- tryReadCF file - if isOK - then do mkFiles make name cf - putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -mkFiles :: Bool -> String -> CF -> IO () -mkFiles make name cf = - do -- Create the package directories if necessary. - let packageBase = name - packageAbsyn = packageBase ++ "." ++ "Absyn" - dirBase = pkgToDir packageBase - dirAbsyn = pkgToDir packageAbsyn - chkExists dirBase - chkExists dirAbsyn - let absynFiles = remDups $ cf2JavaAbs packageBase packageAbsyn cf - absynBaseNames = map fst absynFiles - absynFileNames = map (dirAbsyn ++) absynBaseNames - let writeAbsyn (filename, contents) = - writeFileRep (dirAbsyn ++ filename ++ ".java") contents - mapM writeAbsyn absynFiles - writeFileRep (dirBase ++ "PrettyPrinter.java") $ cf2JavaPrinter packageBase packageAbsyn cf - writeFileRep (dirBase ++ "Skeleton.java") $ cf2JavaSkeleton packageBase packageAbsyn cf - writeFileRep (dirBase ++ "Visitable.java") $ prVisitable packageBase - let user = fst $ unzip $ tokenPragmas cf -- FIXME better var name - writeFileRep (dirBase ++ "Visitor.java") $ prVisitor packageBase packageAbsyn absynBaseNames user - writeFileRep (dirBase ++ "VisitSkel.java") $ cf2VisitSkel packageBase packageAbsyn cf - writeFileRep (dirBase ++ "Test.java") $ javaTest packageBase packageAbsyn cf - let (lex, env) = cf2jlex packageBase packageAbsyn cf - writeFileRep (dirBase ++ "Yylex") lex - putStrLn " (Tested with JLex 1.2.6.)" - writeFileRep (dirBase ++ name ++ ".cup") $ cf2Cup packageBase packageAbsyn cf env - -- FIXME: put in a doc directory? - putStrLn $ " (Parser created for category " ++ firstEntry cf ++ ")" - putStrLn " (Tested with CUP 0.10k)" - writeFileRep (name ++ ".tex") $ cfToLatex name cf - if make - then writeFileRep "Makefile" $ makefile name dirBase dirAbsyn absynFileNames - else return () - where - remDups [] = [] - remDups ((a,b):as) = case lookup a as of - Just {} -> remDups as - Nothing -> (a, b) : (remDups as) - - pkgToDir :: String -> FilePath - pkgToDir p = [ if c == '.' then '/' else c | c <- p] ++ "/" - - chkExists :: FilePath -> IO () - chkExists dir = - do eErr <- try $ createDirectory dir - case eErr of - Left ioerr -> if isAlreadyExistsError ioerr - then return () - else fail $ show ioerr - Right () -> putStrLn $ "Created directory: " ++ dir - --- FIXME get filenames right. --- FIXME It's almost certainly better to just feed all the Java source --- files to javac in one go. --- Replace with an ANT script? -makefile :: String -> FilePath -> FilePath -> [String] -> String -makefile name dirBase dirAbsyn absynFileNames = - unlines - [ - "JAVAC = javac", - "JAVAC_FLAGS = -sourcepath .", - "", - "JAVA = java", - "", - "CUP = java_cup.Main", - "CUPFLAGS = -nopositions -expect 100", - "", - "JLEX = JLex.Main", - "", - "LATEX = latex", - "DVIPS = dvips", - "", - "all: test " ++ name ++ ".ps", - "", - "test: absyn " - ++ unwords (map (dirBase ++) ["Visitor.class", - "Visitable.class", - "Test.class"]), - "", - ".PHONE: absyn", - "", - "absyn: " ++ absynJavaClass, - "", - "%.class: " ++ "%.java", - "\t${JAVAC} ${JAVAC_FLAGS} $*.java", - "", - dirBase ++ "Visitable.class: " ++ dirBase ++ "Visitable.java", - "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Visitable.java", - "", - dirBase ++ "Visitor.class: " ++ dirBase ++ "Visitor.java", - "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Visitor.java", - "", - dirBase ++ "Yylex.java: " ++ dirBase ++ "Yylex", - "\t${JAVA} ${JLEX} " ++ dirBase ++ "Yylex", - "", - -- FIXME - dirBase ++ "sym.java" ++ " " ++ dirBase ++ "parser.java: " ++ dirBase ++ name ++ ".cup", - "\t${JAVA} ${CUP} ${CUPFLAGS} " ++ dirBase ++ name ++ ".cup ; mv sym.java parser.java " ++ dirBase, - "", - dirBase ++ "Yylex.class: " ++ dirBase ++ "Yylex.java " - ++ dirBase ++ "sym.java", - "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Yylex.java", - "", - dirBase ++ "Test.class: " - ++ unwords (map (dirBase ++) ["Test.java", - "PrettyPrinter.class", - "Yylex.class", - "parser.class", - "sym.class"]), - "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Test.java", - "", - "" ++ name ++ ".dvi: " ++ name ++ ".tex", - "\t${LATEX} " ++ name ++ ".tex", - "", - "" ++ name ++ ".ps: " ++ name ++ ".dvi", - "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps", --- FIXME - "", - "clean:", - "\t rm -f " ++ absynJavaClass, - "\t rm -f " ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps " ++ " *.class Makefile", - "", - "distclean:", - "\t rm -f " ++ absynJavaSrc ++ " " ++ absynJavaClass, - "\t rmdir " ++ dirAbsyn, - "\t rm -f " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps ", - "\t rm -f " ++ unwords (map (dirBase ++) ["Yylex", - name ++ ".cup", - "Yylex.java", - "sym.java", - "parser.java", - "Visitor.java", - "Visitable.java", - "VisitSkel.java", - "PrettyPrinter.java", - "Skeleton.java", - "Test.java", - "*.class"]), - "\t rmdir " ++ dirBase, - "\t rm -f Makefile", - "" - ] - where absynJavaSrc = unwords (map (++ ".java") absynFileNames) - absynJavaClass = unwords (map (++ ".class") absynFileNames) - -prVisitable :: String -> String -prVisitable packageBase = unlines - [ - "package" +++ packageBase ++ ";\n", - "public interface Visitable", - "{", - " public void accept(" ++ packageBase ++ ".Visitor v);", - "}" - ] - -prVisitor :: String -> String -> [String] -> [String]-> String -prVisitor packageBase packageAbsyn funs user = - unlines - [ - "package" +++ packageBase ++ ";\n", - "public interface Visitor", - "{", - concatMap prVisitFun funs, - concatMap prUser user, - footer - ] - where - prUser u = " public void visit" ++ u' ++ "(String p);\n" - where - u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem. - footer = unlines - [ --later only include used categories - " public void visitIdent(String i);", - " public void visitInteger(Integer i);", - " public void visitDouble(Double d);", - " public void visitChar(Character c);", - " public void visitString(String s);", - "}" - ] - prVisitFun f = " public void visit" ++ f ++ "(" ++ packageAbsyn - ++ "." ++ f ++ " p);\n" - -javaTest :: String -> String -> CF -> String -javaTest packageBase packageAbsyn cf = - unlines - [ - "package" +++ packageBase ++ ";", - "import java_cup.runtime.*;", - "import" +++ packageBase ++ ".*;", - "import" +++ packageAbsyn ++ ".*;", - "import java.io.*;", - "", - "public class Test", - "{", - " public static void main(String args[]) throws Exception", - " {", - " Yylex l = null;", - " parser p;", - " try", - " {", - " if (args.length == 0) l = new Yylex(System.in);", - " else l = new Yylex(new FileReader(args[0]));", - " }", - " catch(FileNotFoundException e)", - " {", - " System.err.println(\"Error: File not found: \" + args[0]);", - " System.exit(1);", - " }", - " p = new parser(l);", - " /* The default parser is the first-defined entry point. */", - " /* You may want to change this. Other options are: */", - " /* " ++ (concat (intersperse ", " (showOpts (tail eps)))) ++ " */", - " try", - " {", - " " ++ packageAbsyn ++ "." ++ def +++ "parse_tree = p.p" - ++ def ++ "();", - " System.out.println();", - " System.out.println(\"Parse Succesful!\");", - " System.out.println();", - " System.out.println(\"[Abstract Syntax]\");", - " System.out.println();", - " System.out.println(PrettyPrinter.show(parse_tree));", - " System.out.println();", - " System.out.println(\"[Linearized Tree]\");", - " System.out.println();", - " System.out.println(PrettyPrinter.print(parse_tree));", - " }", - " catch(Throwable e)", - " {", - " System.err.println(\"At line \" + String.valueOf(l.line_num()) + \", near \\\"\" + l.buff() + \"\\\" :\");", - " System.err.println(\" \" + e.getMessage());", - " System.exit(1);", - " }", - " }", - "}" - ] - where eps = allEntryPoints cf - def = head eps - showOpts [] = [] - - showOpts (x:[]) = if normCat x /= x then [] else ['p' : (identCat x)] - showOpts (x:xs) = if normCat x /= x then (showOpts xs) - else ('p' : (identCat x)) : (showOpts xs) diff --git a/formats/java/JavaTop.hs~ b/formats/java/JavaTop.hs~ deleted file mode 100644 --- a/formats/java/JavaTop.hs~ +++ /dev/null @@ -1,313 +0,0 @@ -{- - BNF Converter: Java Top File - Copyright (C) 2004 Author: Markus Forsberg, Peter Gammie, Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -------------------------------------------------------------------- --- | --- Module : JavaTop --- Copyright : (C)opyright 2003, {markus, aarne, pellauer, peteg} at cs dot chalmers dot se --- License : GPL (see COPYING for details) --- --- Maintainer : {markus, aarne} at cs dot chalmers dot se --- Stability : alpha --- Portability : Haskell98 --- --- Top-level for the Java back end. --- --- > $Id: JavaTop.hs,v 1.10 2005/09/21 13:06:10 bringert Exp $ -------------------------------------------------------------------- - -module JavaTop ( makeJava ) where - -------------------------------------------------------------------- --- Dependencies. -------------------------------------------------------------------- -import System.Directory ( createDirectory ) -import System.IO ( try, isAlreadyExistsError ) - -import Utils -import CF -import CFtoCup ( cf2Cup ) -import CFtoJLex -import CFtoJavaAbs ( cf2JavaAbs ) -import CFtoJavaPrinter -import CFtoJavaSkeleton -import CFtoVisitSkel -import CFtoLatex -import System.IO -import GetCF ( tryReadCF, writeFileRep ) -import Data.Char -import Data.List(intersperse) - -------------------------------------------------------------------- --- | Build the Java output. --- FIXME: get everything to put the files in the right places. --- Adapt Makefile to do the business. -------------------------------------------------------------------- -makeJava :: Bool -> String -> FilePath -> IO () -makeJava make name file = - do (cf, isOK) <- tryReadCF file - if isOK - then do mkFiles make name cf - putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -mkFiles :: Bool -> String -> CF -> IO () -mkFiles make name cf = - do -- Create the package directories if necessary. - let packageBase = name - packageAbsyn = packageBase ++ "." ++ "Absyn" - dirBase = pkgToDir packageBase - dirAbsyn = pkgToDir packageAbsyn - chkExists dirBase - chkExists dirAbsyn - let absynFiles = remDups $ cf2JavaAbs packageBase packageAbsyn cf - absynBaseNames = map fst absynFiles - absynFileNames = map (dirAbsyn ++) absynBaseNames - let writeAbsyn (filename, contents) = - writeFileRep (dirAbsyn ++ filename ++ ".java") contents - mapM writeAbsyn absynFiles - writeFileRep (dirBase ++ "PrettyPrinter.java") $ cf2JavaPrinter packageBase packageAbsyn cf - writeFileRep (dirBase ++ "Skeleton.java") $ cf2JavaSkeleton packageBase packageAbsyn cf - writeFileRep (dirBase ++ "Visitable.java") $ prVisitable packageBase - let user = fst $ unzip $ tokenPragmas cf -- FIXME better var name - writeFileRep (dirBase ++ "Visitor.java") $ prVisitor packageBase packageAbsyn absynBaseNames user - writeFileRep (dirBase ++ "VisitSkel.java") $ cf2VisitSkel packageBase packageAbsyn cf - writeFileRep (dirBase ++ "Test.java") $ javaTest packageBase packageAbsyn cf - let (lex, env) = cf2jlex packageBase packageAbsyn cf - writeFileRep (dirBase ++ "Yylex") lex - putStrLn " (Tested with JLex 1.2.6.)" - writeFileRep (dirBase ++ name ++ ".cup") $ cf2Cup packageBase packageAbsyn cf env - -- FIXME: put in a doc directory? - putStrLn $ " (Parser created for category " ++ firstEntry cf ++ ")" - putStrLn " (Tested with CUP 0.10k)" - writeFileRep (name ++ ".tex") $ cfToLatex name cf - if make - then writeFileRep "Makefile" $ makefile name dirBase dirAbsyn absynFileNames - else return () - where - remDups [] = [] - remDups ((a,b):as) = case lookup a as of - Just {} -> remDups as - Nothing -> (a, b) : (remDups as) - - pkgToDir :: String -> FilePath - pkgToDir p = [ if c == '.' then '/' else c | c <- p] ++ "/" - - chkExists :: FilePath -> IO () - chkExists dir = - do eErr <- try $ createDirectory dir - case eErr of - Left ioerr -> if isAlreadyExistsError ioerr - then return () - else fail $ show ioerr - Right () -> putStrLn $ "Created directory: " ++ dir - --- FIXME get filenames right. --- FIXME It's almost certainly better to just feed all the Java source --- files to javac in one go. --- Replace with an ANT script? -makefile :: String -> FilePath -> FilePath -> [String] -> String -makefile name dirBase dirAbsyn absynFileNames = - unlines - [ - "JAVAC = javac", - "JAVAC_FLAGS = -sourcepath .", - "", - "JAVA = java", - "", - "CUP = java_cup.Main", - "CUPFLAGS = -nopositions -expect 100", - "", - "JLEX = JLex.Main", - "", - "LATEX = latex", - "DVIPS = dvips", - "", - "all: test " ++ name ++ ".ps", - "", - "test: absyn " - ++ unwords (map (dirBase ++) ["Visitor.class", - "Visitable.class", - "Test.class"]), - "", - ".PHONE: absyn", - "", - "absyn: " ++ absynJavaClass, - "", - "%.class: " ++ "%.java", - "\t${JAVAC} ${JAVAC_FLAGS} $*.java", - "", - dirBase ++ "Visitable.class: " ++ dirBase ++ "Visitable.java", - "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Visitable.java", - "", - dirBase ++ "Visitor.class: " ++ dirBase ++ "Visitor.java", - "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Visitor.java", - "", - dirBase ++ "Yylex.java: " ++ dirBase ++ "Yylex", - "\t${JAVA} ${JLEX} " ++ dirBase ++ "Yylex", - "", - -- FIXME - dirBase ++ "sym.java" ++ " " ++ dirBase ++ "parser.java: " ++ dirBase ++ name ++ ".cup", - "\t${JAVA} ${CUP} ${CUPFLAGS} " ++ dirBase ++ name ++ ".cup ; mv sym.java parser.java " ++ dirBase, - "", - dirBase ++ "Yylex.class: " ++ dirBase ++ "Yylex.java " - ++ dirBase ++ "sym.java", - "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Yylex.java", - "", - dirBase ++ "Test.class: " - ++ unwords (map (dirBase ++) ["Test.java", - "PrettyPrinter.class", - "Yylex.class", - "parser.class", - "sym.class"]), - "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Test.java", - "", - "" ++ name ++ ".dvi: " ++ name ++ ".tex", - "\t${LATEX} " ++ name ++ ".tex", - "", - "" ++ name ++ ".ps: " ++ name ++ ".dvi", - "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps", --- FIXME - "", - "clean:", - "\t rm -f " ++ absynJavaClass, - "\t rm -f " ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps " ++ " *.class Makefile", - "", - "distclean:", - "\t rm -f " ++ absynJavaSrc ++ " " ++ absynJavaClass, - "\t rmdir " ++ dirAbsyn, - "\t rm -f " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps ", - "\t rm -f " ++ unwords (map (dirBase ++) ["Yylex", - name ++ ".cup", - "Yylex.java", - "sym.java", - "parser.java", - "Visitor.java", - "Visitable.java", - "VisitSkel.java", - "PrettyPrinter.java", - "Skeleton.java", - "Test.java", - "*.class"]), - "\t rmdir " ++ dirBase, - "\t rm -f Makefile", - "" - ] - where absynJavaSrc = unwords (map (++ ".java") absynFileNames) - absynJavaClass = unwords (map (++ ".class") absynFileNames) - -prVisitable :: String -> String -prVisitable packageBase = unlines - [ - "package" +++ packageBase ++ ";\n", - "public interface Visitable", - "{", - " public void accept(" ++ packageBase ++ ".Visitor v);", - "}" - ] - -prVisitor :: String -> String -> [String] -> [String]-> String -prVisitor packageBase packageAbsyn funs user = - unlines - [ - "package" +++ packageBase ++ ";\n", - "public interface Visitor", - "{", - concatMap prVisitFun funs, - concatMap prUser user, - footer - ] - where - prUser u = " public void visit" ++ u' ++ "(String p);\n" - where - u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem. - footer = unlines - [ --later only include used categories - " public void visitIdent(String i);", - " public void visitInteger(Integer i);", - " public void visitDouble(Double d);", - " public void visitChar(Character c);", - " public void visitString(String s);", - "}" - ] - prVisitFun f = " public void visit" ++ f ++ "(" ++ packageAbsyn - ++ "." ++ f ++ " p);\n" - -javaTest :: String -> String -> CF -> String -javaTest packageBase packageAbsyn cf = - unlines - [ - "package" +++ packageBase ++ ";", - "import java_cup.runtime.*;", - "import" +++ packageBase ++ ".*;", - "import" +++ packageAbsyn ++ ".*;", - "import java.io.*;", - "", - "public class Test", - "{", - " public static void main(String args[]) throws Exception", - " {", - " Yylex l = null;", - " parser p;", - " try", - " {", - " if (args.length == 0) l = new Yylex(System.in);", - " else l = new Yylex(new FileReader(args[0]));", - " }", - " catch(FileNotFoundException e)", - " {", - " System.err.println(\"Error: File not found: \" + args[0]);", - " System.exit(1);", - " }", - " p = new parser(l);", - " /* The default parser is the first-defined entry point. */", - " /* You may want to change this. Other options are: */", - " /* " ++ (concat (intersperse ", " (showOpts (tail eps)))) ++ " */", - " try", - " {", - " " ++ packageAbsyn ++ "." ++ def +++ "parse_tree = p.p" - ++ def ++ "();", - " System.out.println();", - " System.out.println(\"Parse Succesful!\");", - " System.out.println();", - " System.out.println(\"[Abstract Syntax]\");", - " System.out.println();", - " System.out.println(PrettyPrinter.show(parse_tree));", - " System.out.println();", - " System.out.println(\"[Linearized Tree]\");", - " System.out.println();", - " System.out.println(PrettyPrinter.print(parse_tree));", - " }", - " catch(Throwable e)", - " {", - " System.err.println(\"At line \" + String.valueOf(l.line_num()) + \", near \\\"\" + l.buff() + \"\\\" :\");", - " System.err.println(\" \" + e.getMessage());", - " System.exit(1);", - " }", - " }", - "}" - ] - where eps = allEntryPoints cf - def = head eps - showOpts [] = [] - - showOpts (x:[]) = if normCat x /= x then [] else ['p' : (identCat x)] - showOpts (x:xs) = if normCat x /= x then (showOpts xs) - else ('p' : (identCat x)) : (showOpts xs) diff --git a/formats/java/RegToJLex.hs b/formats/java/RegToJLex.hs deleted file mode 100644 --- a/formats/java/RegToJLex.hs +++ /dev/null @@ -1,86 +0,0 @@ -module RegToJLex (printRegJLex, escapeChar) where - --- modified from pretty-printer generated by the BNF converter - -import AbsBNF -import Data.Char - --- the top-level printing method -printRegJLex :: Reg -> String -printRegJLex = render . prt 0 - --- you may want to change render and parenth - -render :: [String] -> String -render = rend (0 :: Int) where - rend i ss = case ss of - "[" :ts -> cons "[" $ rend i ts - "(" :ts -> cons "(" $ rend i ts - t : "," :ts -> cons t $ space "," $ rend i ts - t : ")" :ts -> cons t $ cons ")" $ rend i ts - t : "]" :ts -> cons t $ cons "]" $ rend i ts - t :ts -> space t $ rend i ts - _ -> "" - cons s t = s ++ t - new i s = s - space t s = if null s then t else t ++ s - -parenth :: [String] -> [String] -parenth ss = ["("] ++ ss ++ [")"] - --- the printer class does the job -class Print a where - prt :: Int -> a -> [String] - prtList :: [a] -> [String] - prtList = concat . map (prt 0) - -instance Print a => Print [a] where - prt _ = prtList - -instance Print Char where - prt _ c = [escapeChar c] - prtList s = map (concat . prt 0) s - -escapeChar :: Char -> String -escapeChar '^' = "\\x5E" -- special case, since \^ is a control character escape -escapeChar x | x `elem` jlexReserved = '\\' : [x] -escapeChar x = [x] - --- Characters that must be escaped in JLex regular expressions -jlexReserved :: [Char] -jlexReserved = ['?', '*', '+', '|', '(', ')', '^', '$', '.', '[', ']', '{', '}', '"', '\\'] - -prPrec :: Int -> Int -> [String] -> [String] -prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) - RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) - - -- JLex does not support set difference - --RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) - RMinus reg0 REps -> prt i reg0 -- REps is identity for set difference - RMinus RAny reg@(RChar _) -> prPrec i 3 (concat [["[^"],prt 0 reg,["]"]]) - RMinus RAny (RAlts str) -> prPrec i 3 (concat [["[^"],prt 0 str,["]"]]) - -- FIXME: maybe we could add cases for char - RDigit, RLetter etc. - RMinus reg0 reg -> error $ "JLex does not support general set difference" - - RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) - RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) - ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) - REps -> prPrec i 3 (["[^.]"]) - RChar c -> prPrec i 3 (concat [prt 0 c]) - RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]]) - RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) - RDigit -> prPrec i 3 (concat [["{DIGIT}"]]) - RLetter -> prPrec i 3 (concat [["{LETTER}"]]) - RUpper -> prPrec i 3 (concat [["{CAPITAL}"]]) - RLower -> prPrec i 3 (concat [["{SMALL}"]]) - RAny -> prPrec i 3 (concat [["."]]) - - - diff --git a/formats/java1.5/CFtoAbstractVisitor.hs b/formats/java1.5/CFtoAbstractVisitor.hs deleted file mode 100644 --- a/formats/java1.5/CFtoAbstractVisitor.hs +++ /dev/null @@ -1,60 +0,0 @@ -{- - BNF Converter: Java 1.5 Abstract Vistor generator - Copyright (C) 2006 Bjorn Bringert - Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoAbstractVisitor (cf2AbstractVisitor) where - -import CF -import CFtoJavaAbs15 (typename) -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower, toUpper, isDigit) - -cf2AbstractVisitor :: String -> String -> CF -> String -cf2AbstractVisitor packageBase packageAbsyn cf = - unlines [ - "package" +++ packageBase ++ ";", - "import" +++ packageAbsyn ++ ".*;", - "/** BNFC-Generated Abstract Visitor */", - "public class AbstractVisitor implements AllVisitor {", - concatMap (prData packageAbsyn user) groups, - "}"] - where - user = fst (unzip (tokenPragmas cf)) - groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ] - ---Traverses a category based on its type. -prData :: String -> [UserDef] -> (Cat, [Rule]) -> String -prData packageAbsyn user (cat, rules) = - unlines $ ["/* " ++ identCat cat ++ " */"] - ++ map (prRule packageAbsyn user cat) rules - ++ [" public R visitDefault(" ++ q ++ " p, A arg) {", - " throw new IllegalArgumentException(this.getClass().getName() + \": \" + p);", - " }"] - where q = packageAbsyn ++ "." ++ identCat cat - ---traverses a standard rule. -prRule :: String -> [UserDef] -> Cat -> Rule -> String -prRule packageAbsyn user cat (fun, (_, cats)) - | not (isCoercion fun || isDefinedRule fun) = - " public R visit(" ++ cls ++ " p, A arg) { return visitDefault(p, arg); }" - where cls = packageAbsyn ++ "." ++ fun -prRule _ _ _ _ = "" - diff --git a/formats/java1.5/CFtoAllVisitor.hs b/formats/java1.5/CFtoAllVisitor.hs deleted file mode 100644 --- a/formats/java1.5/CFtoAllVisitor.hs +++ /dev/null @@ -1,51 +0,0 @@ -{- - BNF Converter: Java 1.5 All Visitor generator - Copyright (C) 2006 Bjorn Bringert - Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoAllVisitor (cf2AllVisitor) where - -import CF -import CFtoJavaAbs15 (typename) -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower, toUpper, isDigit) - -cf2AllVisitor :: String -> String -> CF -> String -cf2AllVisitor packageBase packageAbsyn cf = - unlines [ - "package" +++ packageBase ++ ";", - "", - "import" +++ packageAbsyn ++ ".*;", - "", - "/** BNFC-Generated All Visitor */", - "public interface AllVisitor extends", - concat $ intersperse ",\n" $ map (" "++) is, - "{}"] - where - groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ] - is = map (prInterface packageAbsyn) groups - header = unlines [ - - ] - -prInterface :: String -> (Cat, [Rule]) -> String -prInterface packageAbsyn (cat, rules) = - q ++ ".Visitor" - where q = packageAbsyn ++ "." ++ identCat cat diff --git a/formats/java1.5/CFtoComposVisitor.hs b/formats/java1.5/CFtoComposVisitor.hs deleted file mode 100644 --- a/formats/java1.5/CFtoComposVisitor.hs +++ /dev/null @@ -1,117 +0,0 @@ -{- - BNF Converter: Java 1.5 Compositional Vistor generator - Copyright (C) 2006 Bjorn Bringert - Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoComposVisitor (cf2ComposVisitor) where - -import CF -import CFtoJavaAbs15 (typename) -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower, toUpper, isDigit) - -cf2ComposVisitor :: String -> String -> CF -> String -cf2ComposVisitor packageBase packageAbsyn cf = - concat [ - header, - concatMap (prData packageAbsyn user) groups, - "}"] - where - user = fst (unzip (tokenPragmas cf)) - groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ] - is = map (prInterface packageAbsyn) groups - header = unlines [ - "package" +++ packageBase ++ ";", - "import" +++ packageAbsyn ++ ".*;", - "/** BNFC-Generated Composition Visitor", - "*/", - "", - "public class ComposVisitor implements", - concat $ intersperse ",\n" $ map (" "++) is, - "{" - ] - - -prInterface :: String -> (Cat, [Rule]) -> String -prInterface packageAbsyn (cat, rules) = - q ++ ".Visitor<" ++ q ++ ",A>" - where q = packageAbsyn ++ "." ++ identCat cat - -commaList :: [String] -> String -commaList = concat . intersperse ", " - ---Traverses a category based on its type. -prData :: String -> [UserDef] -> (Cat, [Rule]) -> String -prData packageAbsyn user (cat, rules) = - unlines [ - "/* " ++ identCat cat ++ " */", - concatMap (prRule packageAbsyn user cat) rules - ] ---traverses a standard rule. -prRule :: String -> [UserDef] -> Cat -> Rule -> String -prRule packageAbsyn user cat (fun, (_, cats)) - | not (isCoercion fun || isDefinedRule fun) = unlines - [ - " public " ++ identCat cat ++ " visit(" ++ cls ++ " p, A arg)", - " {", - unlines (map (" "++) visitVars), - " return new " ++ cls ++ "(" ++ commaList children ++ ");", - " }" - ] - where - cats' = if allTerms cats - then [] - else [ (c,v) | - (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)), c /= internalCat ] - cls = packageAbsyn ++ "." ++ fun - allTerms [] = True - allTerms ((Left z):zs) = False - allTerms (z:zs) = allTerms zs - children = map snd cats' - visitVars = concatMap (uncurry (prCat user)) cats' -prRule _ _ _ _ = "" - ---Traverses a class's instance variables. -prCat :: [UserDef] - -> Cat -- ^ Variable category - -> String -- ^ Variable name - -> [String] -- ^ Code for visiting the variable -prCat user cat nt - | isBasicType user varType || (isListType varType && isBasicType user et) = [decl var] - | isListType varType = listAccept - | otherwise = [decl (var ++ ".accept(this, arg)")] - where - var = "p." ++ nt - varType = typename (normCat (identCat cat)) user - accept = var ++ ".accept(this, arg);" - et = typename (normCatOfList cat) user - decl v = varType +++ nt +++ "=" +++ v ++ ";" - listAccept = [decl ("new"+++varType++"()"), - "for (" ++ et ++ " x : " ++ var ++ ") {", - " " ++ nt ++ ".add(x.accept(this,arg));", - "}"] - -isListType :: String -> Bool -isListType nt = "List" `isPrefixOf` nt - ---Just checks if something is a basic or user-defined type. -isBasicType :: [UserDef] -> String -> Bool -isBasicType user v = v `elem` (user ++ ["Integer","Character","String","Double"]) - diff --git a/formats/java1.5/CFtoCup15.hs b/formats/java1.5/CFtoCup15.hs deleted file mode 100644 --- a/formats/java1.5/CFtoCup15.hs +++ /dev/null @@ -1,274 +0,0 @@ -{- - BNF Converter: Java 1.5 Cup Generator - Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer, - Bjorn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the CUP input file. It - follows the same basic structure of CFtoHappy. - - Author : Michael Pellauer (pellauer@cs.chalmers.se), - Bjorn Bringert (bringert@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 26 April, 2003 - - Modified : 5 Aug, 2004 - - - ************************************************************** --} -module CFtoCup15 ( cf2Cup ) where - -import CF -import Data.List (intersperse, isPrefixOf) -import NamedVariables -import Utils ( (+++) ) -import TypeChecker -- We need to (re-)typecheck to figure out list instances in - -- defined rules. -import ErrM - -import Data.Char - --- Type declarations -type Rules = [(NonTerminal,[(Pattern,Action)])] -type NonTerminal = String -type Pattern = String -type Action = String -type MetaVar = String - ---The environment comes from the CFtoJLex -cf2Cup :: String -> String -> CF -> SymEnv -> String -cf2Cup packageBase packageAbsyn cf env = unlines - [ - header, - declarations packageAbsyn (allCats cf), - tokens env, - specialToks cf, - specialRules cf, - prEntryPoint cf, - prRules (rulesForCup packageAbsyn cf env) - ] - where - header :: String - header = unlines - ["// -*- Java -*- This Cup file was machine-generated by BNFC", - "package" +++ packageBase ++ ";", - "", - "parser code {:", - parseMethod packageAbsyn (firstEntry cf), - "public > A cons_(B x, A xs) { xs.addFirst(x); return xs; }", - definedRules packageAbsyn cf, - -- unlines $ map (parseMethod packageAbsyn) (allEntryPoints cf), - "public void syntax_error(java_cup.runtime.Symbol cur_token)", - "{", - "\treport_error(\"Syntax Error, trying to recover and continue parse...\", cur_token);", - "}", - "", - "public void unrecovered_syntax_error(java_cup.runtime.Symbol cur_token) throws java.lang.Exception", - "{", - "\tthrow new Exception(\"Unrecoverable Syntax Error\");", - "}", - "", - ":}" - ] - -definedRules :: String -> CF -> String -definedRules packageAbsyn cf@((pr,_),_) = - unlines [ rule f xs e | FunDef f xs e <- pr ] - where - ctx = buildContext cf - - list = LC (\t -> "List" ++ unBase t) (const "cons") - where - unBase (ListT t) = unBase t - unBase (BaseT x) = normCat x - - rule f xs e = - case checkDefinition' list ctx f xs e of - Bad err -> error $ "Panic! This should have been caught already:\n" ++ err - Ok (args,(e',t)) -> unlines - [ "public " ++ javaType t ++ " " ++ f ++ "_ (" ++ - concat (intersperse ", " $ map javaArg args) ++ ") {" - , " return " ++ javaExp e' ++ ";" - , "}" - ] - where - - javaType :: Base -> String - javaType (ListT (BaseT x)) = packageAbsyn ++ ".List" ++ normCat x - javaType (ListT t) = javaType t - javaType (BaseT x) - | isToken x ctx = "String" - | otherwise = packageAbsyn ++ "." ++ normCat x - - javaArg :: (String, Base) -> String - javaArg (x,t) = javaType t ++ " " ++ x ++ "_" - - javaExp :: Exp -> String - javaExp (App "null" []) = "null" - javaExp (App x []) - | elem x xs = x ++ "_" -- argument - javaExp (App t [e]) - | isToken t ctx = call ("new String") [e] - javaExp (App x es) - | isUpper (head x) = call ("new " ++ packageAbsyn ++ "." ++ x) es - | otherwise = call (x ++ "_") es - javaExp (LitInt n) = "new Integer(" ++ show n ++ ")" - javaExp (LitDouble x) = "new Double(" ++ show x ++ ")" - javaExp (LitChar c) = "new Character(" ++ show c ++ ")" - javaExp (LitString s) = "new String(" ++ show s ++ ")" - - call x es = x ++ "(" ++ concat (intersperse ", " $ map javaExp es) ++ ")" - - --- peteg: FIXME JavaCUP can only cope with one entry point AFAIK. -prEntryPoint :: CF -> String -prEntryPoint cf = unlines ["", "start with " ++ firstEntry cf ++ ";", ""] --- [ep] -> unlines ["", "start with " ++ ep ++ ";", ""] --- eps -> error $ "FIXME multiple entry points." ++ show eps - ---This generates a parser method for each entry point. -parseMethod :: String -> Cat -> String -parseMethod packageAbsyn cat = - if normCat cat /= cat - then "" - else unlines - [ - " public" +++ packageAbsyn ++ "." ++ cat' +++ "p" ++ cat' ++ "()" - ++ " throws Exception", - " {", - "\tjava_cup.runtime.Symbol res = parse();", - "\treturn (" ++ packageAbsyn ++ "." ++ cat' ++ ") res.value;", - " }" - ] - where cat' = identCat (normCat cat) - ---non-terminal types -declarations :: String -> [NonTerminal] -> String -declarations packageAbsyn ns = unlines (map (typeNT packageAbsyn) ns) - where - typeNT _nm nt = "nonterminal" +++ packageAbsyn ++ "." - ++ identCat (normCat nt) +++ identCat nt ++ ";" - ---terminal types -tokens :: SymEnv -> String -tokens ts = unlines (map declTok ts) - where - declTok (s,r) = "terminal" +++ r ++ "; // " ++ s - -specialToks :: CF -> String -specialToks cf = unlines [ - ifC "String" "terminal String _STRING_;", - ifC "Char" "terminal Character _CHAR_;", - ifC "Integer" "terminal Integer _INTEGER_;", - ifC "Double" "terminal Double _DOUBLE_;", - ifC "Ident" "terminal String _IDENT_;" - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - --- This handles user defined tokens --- FIXME -specialRules:: CF -> String -specialRules cf = - unlines ["terminal String " ++ name ++ ";" | (name, _) <- tokenPragmas cf] - ---The following functions are a (relatively) straightforward translation ---of the ones in CFtoHappy.hs -rulesForCup :: String -> CF -> SymEnv -> Rules -rulesForCup packageAbsyn cf env = map mkOne $ ruleGroups cf where - mkOne (cat,rules) = constructRule packageAbsyn cf env rules cat - --- For every non-terminal, we construct a set of rules. A rule is a sequence of --- terminals and non-terminals, and an action to be performed. -constructRule :: String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) -constructRule packageAbsyn cf env rules nt = - (nt, [(p,generateAction packageAbsyn nt (funRule r) (revM b m) b) - | r0 <- rules, - let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True, revSepListRule r0) - else (False, r0) - (p,m) = generatePatterns cf env r]) - where - revM False m = m - revM True [h,t] = [t,h] - revs = reversibleCats cf - --- Generates a string containing the semantic action. -generateAction :: String -> NonTerminal -> Fun -> [MetaVar] - -> Bool -- ^ Whether the list should be reversed or not. - -- Only used if this is a list rule. - -> Action -generateAction packageAbsyn nt f ms rev - | isNilFun f = "RESULT = new " ++ c ++ "();" - | isOneFun f = "RESULT = new " ++ c ++ "(); RESULT.addLast(" ++ p_1 ++ ");" - | isConsFun f = "RESULT = " ++ p_2 ++ "; " - ++ p_2 ++ "." ++ add ++ "(" ++ p_1 ++ ");" - | isCoercion f = "RESULT = " ++ p_1 ++ ";" - | isDefinedRule f = "RESULT = parser." ++ f ++ "_" - ++ "(" ++ concat (intersperse "," ms) ++ ");" - | otherwise = "RESULT = new " ++ c - ++ "(" ++ concat (intersperse "," ms) ++ ");" - where - c = packageAbsyn ++ "." ++ - if isNilFun f || isOneFun f || isConsFun f - then identCat (normCat nt) else f - p_1 = ms!!0 - p_2 = ms!!1 - add = if rev then "addLast" else "addFirst" - --- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal -generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar]) -generatePatterns cf env r = case rhsRule r of - [] -> (" /* empty */ ",[]) - its -> (mkIt env 1 its, metas its) - where - mkIt _env _n [] = [] - mkIt env n (i:is) = case i of - Left c -> c' ++ ":p_" ++ (show (n :: Int)) +++ (mkIt env (n+1) is) - where - c' = case c of - "Ident" -> "_IDENT_" - "Integer" -> "_INTEGER_" - "Char" -> "_CHAR_" - "Double" -> "_DOUBLE_" - "String" -> "_STRING_" - _ -> identCat c - Right s -> case (lookup s env) of - (Just x) -> x +++ (mkIt env (n+1) is) - (Nothing) -> (mkIt env n is) - metas its = ["p_" ++ show i | (i,Left c) <- zip [1 :: Int ..] its] - --- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string. -prRules :: Rules -> String -prRules [] = [] -prRules ((nt, []):rs) = prRules rs --internal rule -prRules ((nt,((p,a):ls)):rs) = - (unwords [nt', "::=", p, "{:", a, ":}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs - where - nt' = identCat nt - pr [] = [] - pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{:", a , ":}"])]) ++ pr ls - diff --git a/formats/java1.5/CFtoFoldVisitor.hs b/formats/java1.5/CFtoFoldVisitor.hs deleted file mode 100644 --- a/formats/java1.5/CFtoFoldVisitor.hs +++ /dev/null @@ -1,104 +0,0 @@ -{- - BNF Converter: Java 1.5 Fold Vistor generator - Copyright (C) 2006 Bjorn Bringert - Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoFoldVisitor (cf2FoldVisitor) where - -import CF -import CFtoJavaAbs15 (typename) -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower, toUpper, isDigit) - -cf2FoldVisitor :: String -> String -> CF -> String -cf2FoldVisitor packageBase packageAbsyn cf = - unlines - ["package" +++ packageBase ++ ";", - "", - "import" +++ packageAbsyn ++ ".*;", - "import java.util.Collections;", - "import java.util.List;", - "import java.util.ArrayList;", - "", - "/** BNFC-Generated Fold Visitor */", - "public abstract class FoldVisitor implements AllVisitor {", - " public abstract R leaf(A arg);", - " public abstract R combine(R x, R y, A arg);", - "", - concatMap (prData packageAbsyn user) groups, - "}"] - where - user = fst (unzip (tokenPragmas cf)) - groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ] - ---Traverses a category based on its type. -prData :: String -> [UserDef] -> (Cat, [Rule]) -> String -prData packageAbsyn user (cat, rules) = - unlines [ - "/* " ++ identCat cat ++ " */", - concatMap (prRule packageAbsyn user cat) rules - ] - ---traverses a standard rule. -prRule :: String -> [UserDef] -> Cat -> Rule -> String -prRule packageAbsyn user cat (fun, (_, cats)) - | not (isCoercion fun || isDefinedRule fun) = unlines $ - [" public R visit(" ++ cls ++ " p, A arg) {", - " R r = leaf(arg);"] - ++ map (" "++) visitVars - ++ [" return r;", - " }"] - where - cats' = if allTerms cats - then [] - else [ (c,v) | - (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)), c /= internalCat ] - cls = packageAbsyn ++ "." ++ fun - allTerms [] = True - allTerms ((Left z):zs) = False - allTerms (z:zs) = allTerms zs - children = map snd cats' - visitVars = concatMap (uncurry (prCat user)) cats' -prRule _ _ _ _ = "" - ---Traverses a class's instance variables. -prCat :: [UserDef] - -> Cat -- ^ Variable category - -> String -- ^ Variable name - -> [String] -- ^ Code for visiting the variable -prCat user cat nt - | isBasicType user varType || (isListType varType && isBasicType user et) = [] - | isListType varType = listAccept - | otherwise = ["r = combine(" ++ var ++ ".accept(this, arg), r, arg);"] - where - var = "p." ++ nt - varType = typename (normCat (identCat cat)) user - et = typename (normCatOfList cat) user - listAccept = ["for (" ++ et ++ " x : " ++ var ++ ") {", - " r = combine(x.accept(this,arg), r, arg);", - "}"] - -isListType :: String -> Bool -isListType nt = "List" `isPrefixOf` nt - ---Just checks if something is a basic or user-defined type. -isBasicType :: [UserDef] -> String -> Bool -isBasicType user v = v `elem` (user ++ ["Integer","Character","String","Double"]) - diff --git a/formats/java1.5/CFtoJLex15.hs b/formats/java1.5/CFtoJLex15.hs deleted file mode 100644 --- a/formats/java1.5/CFtoJLex15.hs +++ /dev/null @@ -1,175 +0,0 @@ -{- - BNF Converter: Java JLex generator - Copyright (C) 2004 Author: Michael Pellauer - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the JLex input file. This - file is quite different than Alex or Flex. - - Author : Michael Pellauer (pellauer@cs.chalmers.se), - Bjorn Bringert (bringert@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 25 April, 2003 - - Modified : 4 Nov, 2004 - - - ************************************************************** --} - -module CFtoJLex15 ( cf2jlex ) where - -import CF -import RegToJLex -import Utils ( (+++) ) -import NamedVariables -import Data.List - ---The environment must be returned for the parser to use. -cf2jlex :: String -> String -> CF -> (String, SymEnv) -cf2jlex packageBase packageAbsyn cf = (unlines $ concat $ - [ - prelude packageBase packageAbsyn, - cMacros, - lexSymbols env, - restOfJLex cf - ], env) - where - env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) - makeSymEnv [] _ = [] - makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) - -prelude :: String -> String -> [String] -prelude packageBase packageAbsyn = - [ - "// This JLex file was machine-generated by the BNF converter", - "package" +++ packageBase ++ ";", - "", - "import java_cup.runtime.*;", - "%%", - "%cup", - "%unicode", - "%line", - "%public", - "%{", - " String pstring = new String();", - " public int line_num() { return (yyline+1); }", - " public String buff() { return new String(yy_buffer,yy_buffer_index,10).trim(); }", - "%}" - ] - ---For now all categories are included. ---Optimally only the ones that are used should be generated. -cMacros :: [String] -cMacros = [ - "LETTER = ({CAPITAL}|{SMALL})", - "CAPITAL = [A-Z\\xC0-\\xD6\\xD8-\\xDE]", - "SMALL = [a-z\\xDF-\\xF6\\xF8-\\xFF]", - "DIGIT = [0-9]", - "IDENT = ({LETTER}|{DIGIT}|['_])", - "%state COMMENT", - "%state CHAR", - "%state CHARESC", - "%state CHAREND", - "%state STRING", - "%state ESCAPED", - "%%" - ] - -lexSymbols :: SymEnv -> [String] -lexSymbols ss = map transSym ss - where - transSym (s,r) = - "" ++ (escapeChars s) ++ " { return new Symbol(sym." - ++ r ++ "); }" - -restOfJLex :: CF -> [String] -restOfJLex cf = - [ - lexComments (comments cf), - userDefTokens, - ifC "String" strStates, - ifC "Char" chStates, - ifC "Double" "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }", - ifC "Integer" "{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }", - ifC "Ident" "{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, yytext().intern()); }" - , "[ \\t\\r\\n\\f] { /* ignore white space. */ }" - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - userDefTokens = unlines $ - ["" ++ printRegJLex exp +++ - "{ return new Symbol(sym." ++ name ++ ", yytext().intern()); }" - | (name, exp) <- tokenPragmas cf] - strStates = unlines --These handle escaped characters in Strings. - [ - "\"\\\"\" { yybegin(STRING); }", - "\\\\ { yybegin(ESCAPED); }", - "\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo.intern()); }", - ". { pstring += yytext(); }", - "n { pstring += \"\\n\"; yybegin(STRING); }", - "\\\" { pstring += \"\\\"\"; yybegin(STRING); }", - "\\\\ { pstring += \"\\\\\"; yybegin(STRING); }", - "t { pstring += \"\\t\"; yybegin(STRING); }", - ". { pstring += yytext(); yybegin(STRING); }" - ] - chStates = unlines --These handle escaped characters in Chars. - [ - "\"'\" { yybegin(CHAR); }", - "\\\\ { yybegin(CHARESC); }", - "[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", - "n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }", - "t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }", - ". { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", - "\"'\" {yybegin(YYINITIAL);}" - ] - - - - -lexComments :: ([(String, String)], [String]) -> String -lexComments (m,s) = - (unlines (map lexSingleComment s)) - ++ (unlines (map lexMultiComment m)) - -lexSingleComment :: String -> String -lexSingleComment c = - "\"" ++ c ++ "\"[^\\n]*\\n { /* BNFC single-line comment */ }" - ---There might be a possible bug here if a language includes 2 multi-line comments. ---They could possibly start a comment with one character and end it with another. ---However this seems rare. -lexMultiComment :: (String, String) -> String -lexMultiComment (b,e) = unlines [ - "\"" ++ b ++ "\" { yybegin(COMMENT); }", - "\"" ++ e ++ "\" { yybegin(YYINITIAL); }", - ". { }", - "[\\n] { }" - ] - --- lexReserved :: String -> String --- lexReserved s = "\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }" - ---Helper function that escapes characters in strings -escapeChars :: String -> String -escapeChars = concatMap escapeChar diff --git a/formats/java1.5/CFtoJavaAbs15.hs b/formats/java1.5/CFtoJavaAbs15.hs deleted file mode 100644 --- a/formats/java1.5/CFtoJavaAbs15.hs +++ /dev/null @@ -1,263 +0,0 @@ -{- - BNF Converter: Java 1.5 Abstract Syntax - Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the Java Abstract Syntax - It uses the NamedVariables module for variable - naming. It returns a list of file names, and the - contents to be written into that file. (In Java - public classes must go in their own file.) - - The generated classes also support the Visitor - Design Pattern. - - Author : Michael Pellauer (pellauer@cs.chalmers.se), - Bjorn Bringert (bringert@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 24 April, 2003 - - Modified : 16 June, 2004 - - - ************************************************************** --} - -module CFtoJavaAbs15 (cf2JavaAbs, typename) where - -import CF -import Utils((+++),(++++)) -import NamedVariables hiding (IVar, getVars, varName) -import Data.List -import Data.Char(toLower, isDigit) -import Data.Maybe(catMaybes,fromMaybe) - ---Produces abstract data types in Java. ---These follow Appel's "non-object oriented" version. ---They also allow users to use the Visitor design pattern. - -type IVar = (String, Int, Maybe String) ---The type of an instance variable ---a # unique to that type ---and an optional name (handles typedefs). - ---The result is a list of files which must be written to disk. ---The tuple is (FileName, FileContents) -cf2JavaAbs :: String -> String -> CF -> [(FilePath, String)] -cf2JavaAbs packageBase packageAbsyn cf = - concatMap (prData header packageAbsyn user) rules - where - header = "package " ++ packageAbsyn ++ "; // Java Package generated by the BNF Converter.\n" - user = [n | (n,_) <- tokenPragmas cf] - rules = [ (normCat c,fs) | (c,fs) <- cf2dataLists cf] - ---Generates a (possibly abstract) category class, and classes for all its rules. -prData :: String -> String -> [UserDef] -> Data ->[(String, String)] -prData header packageAbsyn user (cat, rules) = - categoryClass ++ (catMaybes $ map (prRule header packageAbsyn funs user cat) rules) - where - funs = map fst rules - categoryClass - | cat `elem` funs = [] -- the catgory is also a function, skip abstract class - | otherwise = [(identCat cat, header ++++ - unlines [ - "public abstract class" +++ cls - +++ "implements java.io.Serializable {", - " public abstract R accept(" - ++ cls ++ ".Visitor v, A arg);", - prVisitor packageAbsyn funs, - "}" - ])] - where cls = identCat cat - -prVisitor :: String -> [String] -> String -prVisitor packageAbsyn funs = - unlines [ - " public interface Visitor {", - unlines (map prVisitFun funs), - " }" - ] - where - prVisitFun f = " public R visit(" ++ packageAbsyn ++ "." ++ f ++ " p, A arg);" - ---Generates classes for a rule, depending on what type of rule it is. -prRule :: String -- ^ Header - -> String -- ^ Abstract syntax package name - -> [String] -- ^ Names of all constructors in the category - -> [UserDef] -> String -> (Fun, [Cat]) -> Maybe (String, String) -prRule h packageAbsyn funs user c (fun, cats) = - if isNilFun fun || isOneFun fun - then Nothing --these are not represented in the AbSyn - else if isConsFun fun - then Just $ (fun', --this is the linked list case. - unlines - [ - h, - "public class" +++ fun' +++ "extends java.util.LinkedList<"++ et ++"> {", - "}" - ]) - else Just $ (fun, --a standard rule - unlines - [ - h, - "public class" +++ fun ++ ext +++ "{", - (prInstVars vs), - prConstructor fun user vs cats, - prAccept packageAbsyn c fun, - prEquals packageAbsyn fun vs, - prHashCode packageAbsyn fun vs, - if isAlsoCategory then prVisitor packageAbsyn funs else "", - "}" - ]) - where - vs = getVars cats user - fun' = identCat (normCat c) - isAlsoCategory = fun == c - --This handles the case where a LBNF label is the same as the category. - ext = if isAlsoCategory then "" else " extends" +++ (identCat c) - et = typename (normCatOfList c) user - - ---The standard accept function for the Visitor pattern -prAccept :: String -> String -> String -> String -prAccept pack cat _ = "\n public R accept(" ++ pack ++ "." ++ cat - ++ ".Visitor v, A arg) { return v.visit(this, arg); }\n" - --- Creates the equals() method. -prEquals :: String -> String -> [IVar] -> String -prEquals pack fun vs = - unlines $ map (" "++) $ ["public boolean equals(Object o) {", - " if (this == o) return true;", - " if (o instanceof " ++ fqn ++ ") {"] - ++ (if null vs - then [" return true;"] - else [" " ++ fqn +++ "x = ("++fqn++")o;", - " return " ++ checkKids ++ ";"]) ++ - [" }", - " return false;", - "}"] - where - fqn = pack++"."++fun - checkKids = concat $ intersperse " && " $ map checkKid vs - checkKid iv = "this." ++ v ++ ".equals(x." ++ v ++ ")" - where v = iVarName iv - --- Creates the equals() method. -prHashCode :: String -> String -> [IVar] -> String -prHashCode pack fun vs = - unlines $ map (" "++) ["public int hashCode() {", - " return " ++ hashKids vs ++ ";", - "}" - ] - where - aPrime = 37 - hashKids [] = show aPrime - hashKids (v:vs) = hashKids_ (hashKid v) vs - hashKids_ r [] = r - hashKids_ r (v:vs) = hashKids_ (show aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashKid v) vs - hashKid iv = "this." ++ iVarName iv ++ ".hashCode()" - - ---A class's instance variables. -prInstVars :: [IVar] -> String -prInstVars [] = [] -prInstVars vars@((t,n,nm):vs) = - " public" +++ "final" +++ t +++ uniques ++ ";" ++++ - (prInstVars vs') - where - (uniques, vs') = prUniques t vars - --these functions group the types together nicely - prUniques :: String -> [IVar] -> (String, [IVar]) - prUniques t vs = (prVars (findIndices (\x -> case x of (y,_,_) -> y == t) vs) vs, remType t vs) - prVars (x:[]) vs = iVarName (vs!!x) - prVars (x:xs) vs = iVarName (vs!!x) ++ "," +++ prVars xs vs - remType :: String -> [IVar] -> [IVar] - remType _ [] = [] - remType t ((t2,n,nm):ts) = if t == t2 - then (remType t ts) - else (t2,n,nm) : (remType t ts) - -iVarName :: IVar -> String -iVarName (t,n,nm) = varName t nm ++ showNum n - ---The constructor just assigns the parameters to the corresponding instance variables. -prConstructor :: String -> [UserDef] -> [IVar] -> [Cat] -> String -prConstructor c u vs cats = - " public" +++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" +++ - prAssigns vs params ++ "}" - where - (types, params) = unzip (prParams cats u (length cats) ((length cats)+1)) - interleave _ [] = [] - interleave (x:[]) (y:[]) = x +++ y - interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys) - ---Prints the parameters to the constructors. -prParams :: [Cat] -> [UserDef] -> Int -> Int -> [(String,String)] -prParams [] _ _ _ = [] -prParams (c:cs) u n m = (identCat c',"p" ++ (show (m-n))) - : (prParams cs u (n-1) m) - where - c' = typename c u - ---This algorithm peeks ahead in the list so we don't use map or fold -prAssigns :: [IVar] -> [String] -> String -prAssigns [] _ = [] -prAssigns _ [] = [] -prAssigns ((t,n,nm):vs) (p:ps) = - if n == 1 then - case findIndices (\x -> case x of (l,r,_) -> l == t) vs of - [] -> (varName t nm) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) - z -> ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) - else ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) - ---Different than the standard NamedVariables version because of the user-defined ---types. -getVars :: [Cat] -> [UserDef] -> [IVar] -getVars cs user = reverse $ singleToZero $ foldl addVar [] (map identCat cs) - where - addVar is c = (c', n, nm):is - where c' = typename c user - nm = if c == c' then Nothing else Just c - n = maximum (1:[n'+1 | (t,n',_) <- is, t == c']) - singleToZero is = [(t,n',nm) | (t,n,nm) <- is, - let n' = if length (filter (hasType t) is) == 1 - then 0 else n] - hasType t (t',_,_) = t == t' - -varName :: String -- ^ Category - -> Maybe String -- ^ Java type name - -> String -- ^ Variable name -varName c jt = (map toLower c') ++ "_" - where - c' = fromMaybe c jt - ---This makes up for the fact that there's no typedef in Java -typename :: String -> [UserDef] -> String -typename t user = - if t == "Ident" - then "String" - else if t == "Char" - then "Character" - else if elem t user - then "String" - else t diff --git a/formats/java1.5/CFtoJavaPrinter15.hs b/formats/java1.5/CFtoJavaPrinter15.hs deleted file mode 100644 --- a/formats/java1.5/CFtoJavaPrinter15.hs +++ /dev/null @@ -1,379 +0,0 @@ -{- - BNF Converter: Java Pretty Printer generator - Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates the Java Pretty Printer - class. In addition, since there's no good way - to display a class heirarchy (toString() doesn't - count) in Java, it generates a method that - displays the Abstract Syntax in a way similar - to Haskell. - - This uses Appel's method and may serve as a - useful example to those who wish to use it. - - Author : Michael Pellauer (pellauer@cs.chalmers.se), - Bjorn Bringert (bringert@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 24 April, 2003 - - Modified : 9 Aug, 2004 - - Added string buffer for efficiency (Michael, August 03) - ************************************************************** --} -module CFtoJavaPrinter15 ( cf2JavaPrinter ) where - -import CFtoJavaAbs15 - -import CF -import NamedVariables -import Utils ( (+++) ) -import Data.List -import Data.Char ( toLower, isSpace ) - ---Produces the PrettyPrinter class. ---It will generate two methods "print" and "show" ---print is the actual pretty printer for linearization. ---show produces a Haskell-style syntax that can be extremely useful ---especially for testing parser correctness. - -cf2JavaPrinter :: String -> String -> CF -> String -cf2JavaPrinter packageBase packageAbsyn cf = - unlines - [ - header, - prEntryPoints packageAbsyn cf, - unlines (map (prData packageAbsyn user) groups), - unlines (map (shData packageAbsyn user) groups), - footer - ] - where - user = [n | (n,_) <- tokenPragmas cf] - groups = fixCoercions (ruleGroupsInternals cf) - header = unlines [ - "package" +++ packageBase ++ ";", - "import" +++ packageAbsyn ++ ".*;", - "", - "public class PrettyPrinter", - "{", - " //For certain applications increasing the initial size of the buffer may improve performance.", - " private static final int INITIAL_BUFFER_SIZE = 128;", - " //You may wish to change the parentheses used in precedence.", - " private static final String _L_PAREN = new String(\"(\");", - " private static final String _R_PAREN = new String(\")\");", - prRender - ] - footer = unlines [ --later only include used categories - " private static void pp(Integer n, int _i_) { buf_.append(n); buf_.append(\" \"); }", - " private static void pp(Double d, int _i_) { buf_.append(d); buf_.append(\" \"); }", - " private static void pp(String s, int _i_) { buf_.append(s); buf_.append(\" \"); }", - " private static void pp(Character c, int _i_) { buf_.append(\"'\" + c.toString() + \"'\"); buf_.append(\" \"); }", - " private static void sh(Integer n) { render(n.toString()); }", - " private static void sh(Double d) { render(d.toString()); }", - " private static void sh(Character c) { render(c.toString()); }", - " private static void sh(String s) { printQuoted(s); }", - " private static void printQuoted(String s) { render(\"\\\"\" + s + \"\\\"\"); }", - " private static void indent()", - " {", - " int n = _n_;", - " while (n > 0)", - " {", - " buf_.append(\" \");", - " n--;", - " }", - " }", - " private static void backup()", - " {", - " if (buf_.charAt(buf_.length() - 1) == ' ') {", - " buf_.setLength(buf_.length() - 1);", - " }", - " }", - " private static void trim()", - " {", - " while (buf_.length() > 0 && buf_.charAt(0) == ' ')", - " buf_.deleteCharAt(0); ", - " while (buf_.length() > 0 && buf_.charAt(buf_.length()-1) == ' ')", - " buf_.deleteCharAt(buf_.length()-1);", - " }", - " private static int _n_ = 0;", - " private static StringBuilder buf_ = new StringBuilder(INITIAL_BUFFER_SIZE);", - "}" - ] - ---An extremely simple renderer for terminals. -prRender :: String -prRender = unlines - [ - " //You may wish to change render", - " private static void render(String s)", - " {", - " if (s.equals(\"{\"))", - " {", - " buf_.append(\"\\n\");", - " indent();", - " buf_.append(s);", - " _n_ = _n_ + 2;", - " buf_.append(\"\\n\");", - " indent();", - " }", - " else if (s.equals(\"(\") || s.equals(\"[\"))", - " buf_.append(s);", - " else if (s.equals(\")\") || s.equals(\"]\"))", - " {", - " backup();", - " buf_.append(s);", - " buf_.append(\" \");", - " }", - " else if (s.equals(\"}\"))", - " {", - " _n_ = _n_ - 2;", - " backup();", - " backup();", - " buf_.append(s);", - " buf_.append(\"\\n\");", - " indent();", - " }", - " else if (s.equals(\",\"))", - " {", - " backup();", - " buf_.append(s);", - " buf_.append(\" \");", - " }", - " else if (s.equals(\";\"))", - " {", - " backup();", - " buf_.append(s);", - " buf_.append(\"\\n\");", - " indent();", - " }", - " else if (s.equals(\"\")) return;", - " else", - " {", - " buf_.append(s);", - " buf_.append(\" \");", - " }", - " }" - ] - -prEntryPoints :: String -> CF -> String -prEntryPoints packageAbsyn cf = - msg ++ concat (map prEntryPoint (allCats cf)) ++ msg2 - where - msg = " // print and show methods are defined for each category.\n" - msg2 = " /*** You shouldn't need to change anything beyond this point. ***/\n" - prEntryPoint cat | (normCat cat) == cat = unlines - [ - " public static String print(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)", - " {", - " pp(foo, 0);", - " trim();", - " String temp = buf_.toString();", - " buf_.delete(0,buf_.length());", - " return temp;", - " }", - " public static String show(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)", - " {", - " sh(foo);", - " String temp = buf_.toString();", - " buf_.delete(0,buf_.length());", - " return temp;", - " }" - ] - where - cat' = identCat cat - prEntryPoint _ = "" - -prData :: String -> [UserDef] -> (Cat, [Rule]) -> String -prData packageAbsyn user (cat, rules) = - if isList cat - then unlines - [ - " private static void pp(" ++ packageAbsyn ++ "." - ++ identCat (normCat cat) +++ "foo, int _i_)", - " {", - (prList user cat rules) ++ " }" - ] - else unlines --not a list - [ - " private static void pp(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo, int _i_)", - " {", - (concat (addElse $ map (prRule packageAbsyn) rules)) ++ " }" - ] - where addElse = map (" "++). intersperse "else " . filter (not . null) . map (dropWhile isSpace) - -prRule :: String -> Rule -> String -prRule packageAbsyn r@(fun, (_c, cats)) | not (isCoercion fun || isDefinedRule fun) = concat - [ - " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")\n", - " {\n", - " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= (" - ++ packageAbsyn ++ "." ++ fun ++ ") foo;\n", - lparen, - cats', - rparen, - " }\n" - ] - where - p = precRule r - (lparen, rparen) = - (" if (_i_ > " ++ (show p) ++ ") render(_L_PAREN);\n", - " if (_i_ > " ++ (show p) ++ ") render(_R_PAREN);\n") - cats' = case cats of - [] -> "" - _ -> concatMap (prCat fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats)) - fnm = '_' : map toLower fun - - getPrec (Right {}) = 0 - getPrec (Left c) = precCat c - -prRule _nm (_fun, _cats) = "" - -prList :: [UserDef] -> Cat -> [Rule] -> String -prList user c rules = unlines - [ - " for (java.util.Iterator<" ++ et - ++ "> it = foo.iterator(); it.hasNext();)", - " {", - " pp(it.next(), 0);", - " if (it.hasNext()) {", - " render(\"" ++ sep ++ "\");", - " } else {", - " render(\"" ++ optsep ++ "\");", - " }", - " }" - ] - where - et = typename (normCatOfList c) user - sep = maybe "" escapeChars $ getCons rules - optsep = if hasOneFunc rules then "" else sep - -getCons :: [Rule] -> Maybe String -getCons ((f, (_c, cats)):rs) = - if isConsFun f - then Just $ seper cats - else getCons rs - where - seper [] = [] - seper ((Right x):_xs) = x - seper ((Left {}):xs) = seper xs -getCons _ = Nothing - -hasOneFunc :: [Rule] -> Bool -hasOneFunc [] = False -hasOneFunc ((f, (_, _cats)):rs) = - if (isOneFun f) - then True - else hasOneFunc rs - -prCat fnm (c, p) = - case c of - Right t -> " render(\"" ++ escapeChars t ++ "\");\n" - Left nt | "string" `isPrefixOf` nt - -> " printQuoted(" ++ fnm ++ "." ++ nt ++ ");\n" - | isInternalVar nt -> "" - | otherwise - -> " pp(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");\n" - ---The following methods generate the Show function. - -shData :: String -> [UserDef] -> (Cat, [Rule]) -> String -shData packageAbsyn user (cat, rules) = - if isList cat - then unlines - [ - " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)", - " {", - (shList user cat rules) ++ " }" - ] - else unlines - [ - " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)", - " {", - (concat (map (shRule packageAbsyn) rules)) ++ " }" - ] - -shRule :: String -> Rule -> String -shRule packageAbsyn (fun, (_c, cats)) | not (isCoercion fun || isDefinedRule fun) = unlines - [ - " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")", - " {", - " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= (" - ++ packageAbsyn ++ "." ++ fun ++ ") foo;", - members ++ " }" - ] - where - members = concat - [ - lparen, - " render(\"" ++ (escapeChars fun) ++ "\");\n", - cats', - rparen - ] - cats' = if allTerms cats - then "" - else (concat (map (shCat fnm) (fixOnes (numVars [] cats)))) - (lparen, rparen) = - if allTerms cats - then ("","") - else (" render(\"(\");\n"," render(\")\");\n") - allTerms [] = True - allTerms ((Left {}):_) = False - allTerms (_:zs) = allTerms zs - fnm = '_' : map toLower fun -shRule _nm (_fun, _cats) = "" - -shList :: [UserDef] -> Cat -> [Rule] -> String -shList user c _rules = unlines - [ - " for (java.util.Iterator<" ++ et - ++ "> it = foo.iterator(); it.hasNext();)", - " {", - " sh(it.next());", - " if (it.hasNext())", - " render(\",\");", - " }" - ] - where - et = typename (normCatOfList c) user - -shCat fnm c = - case c of - Right {} -> "" - Left nt | "list" `isPrefixOf` nt - -> unlines [" render(\"[\");", - " sh(" ++ fnm ++ "." ++ nt ++ ");", - " render(\"]\");"] - | isInternalVar nt -> "" - | otherwise -> " sh(" ++ fnm ++ "." ++ nt ++ ");\n" - ---Helper function that escapes characters in strings -escapeChars :: String -> String -escapeChars [] = [] -escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) -escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) -escapeChars (x:xs) = x : (escapeChars xs) - -isInternalVar x = x == internalCat ++ "_" diff --git a/formats/java1.5/CFtoVisitSkel15.hs b/formats/java1.5/CFtoVisitSkel15.hs deleted file mode 100644 --- a/formats/java1.5/CFtoVisitSkel15.hs +++ /dev/null @@ -1,141 +0,0 @@ -{- - BNF Converter: Java Vistor skeleton generator - Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- - ************************************************************** - BNF Converter Module - - Description : This module generates a Skeleton function - which uses the Visitor Design Pattern, which - users may find more familiar than Appel's - method. - - Author : Michael Pellauer (pellauer@cs.chalmers.se), - Bjorn Bringert (bringert@cs.chalmers.se) - - License : GPL (GNU General Public License) - - Created : 4 August, 2003 - - Modified : 16 June, 2004 - - - ************************************************************** --} -module CFtoVisitSkel15 (cf2VisitSkel) where - -import CF -import CFtoJavaAbs15 (typename) -import Utils ((+++), (++++)) -import NamedVariables -import Data.List -import Data.Char(toLower, toUpper, isDigit) - ---Produces a Skeleton using the Visitor Design Pattern. ---Thus the user can choose which Skeleton to use. - -cf2VisitSkel :: String -> String -> CF -> String -cf2VisitSkel packageBase packageAbsyn cf = - concat [ - header, --- " // NOT IMPLEMENTED for java1.5\n", - concatMap (prData packageAbsyn user) groups, - "}"] - where - user = fst (unzip (tokenPragmas cf)) - groups = (fixCoercions (ruleGroups cf)) - header = unlines [ - "package" +++ packageBase ++ ";", - "import" +++ packageAbsyn ++ ".*;", - "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/", - "/* This implements the common visitor design pattern.", - " Tests show it to be slightly less efficient than the", - " instanceof method, but easier to use. ", - " Replace the R and A parameters with the desired return", - " and context types.*/", - "", - "public class VisitSkel", - "{" - ] - - ---Traverses a category based on its type. -prData :: String -> [UserDef] -> (Cat, [Rule]) -> String -prData packageAbsyn user (cat, rules) = - if isList cat - then "" - else unlines [" public class " ++ identCat cat ++ "Visitor implements " - ++ identCat cat ++ ".Visitor", - " {", - concatMap (prRule packageAbsyn user) rules, - " }" - ] - ---traverses a standard rule. -prRule :: String -> [UserDef] -> Rule -> String -prRule packageAbsyn user (fun, (c, cats)) | not (isCoercion fun || isDefinedRule fun) = unlines - [ - " public R visit(" ++ packageAbsyn ++ "." ++ fun ++ " p, A arg)", - " {", - " /* Code For " ++ fun ++ " Goes Here */", - "", - concatMap (uncurry (prCat user)) cats', - " return null;", - " }" - ] - where - cats' = if allTerms cats - then [] - else [ (c,v) | - (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)) ] - allTerms [] = True - allTerms ((Left z):zs) = False - allTerms (z:zs) = allTerms zs -prRule user nm (fun, cats) = "" - ---Traverses a class's instance variables. -prCat :: [UserDef] - -> Cat -- ^ Variable category - -> String -- ^ Variable name - -> String -- ^ Code for visiting the variable -prCat user cat nt | isBasic user nt = " //" ++ var ++ ";\n" - | "list" `isPrefixOf` nt = listAccept - | otherwise = " " ++ accept ++ "\n" - where - var = "p." ++ nt - varType = typename (normCat (identCat cat)) user - accept = var ++ ".accept(new " ++ varType ++ "Visitor(), arg);" - et = typename (normCatOfList cat) user - listAccept = unlines [" for (" ++ et ++ " x : " ++ var ++ ") {", - " }"] - ---Just checks if something is a basic or user-defined type. ---This is because you don't -> a basic non-pointer type. -isBasic :: [UserDef] -> String -> Bool -isBasic user v = - if elem (init v) user' - then True - else if "integer_" `isPrefixOf` v then True - else if "char_" `isPrefixOf` v then True - else if "string_" `isPrefixOf` v then True - else if "double_" `isPrefixOf` v then True - else if "ident_" `isPrefixOf` v then True - else False - where - user' = map (map toLower) user diff --git a/formats/java1.5/JavaTop15.hs b/formats/java1.5/JavaTop15.hs deleted file mode 100644 --- a/formats/java1.5/JavaTop15.hs +++ /dev/null @@ -1,285 +0,0 @@ -{- - BNF Converter: Java Top File - Copyright (C) 2004 Author: Markus Forsberg, Peter Gammie, - Michael Pellauer, Bjorn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -------------------------------------------------------------------- --- | --- Module : JavaTop --- Copyright : (C)opyright 2003, {markus, aarne, pellauer, peteg, bringert} at cs dot chalmers dot se --- License : GPL (see COPYING for details) --- --- Maintainer : {markus, aarne} at cs dot chalmers dot se --- Stability : alpha --- Portability : Haskell98 --- --- Top-level for the Java back end. --- --- > $Id: JavaTop15.hs,v 1.12 2007/01/08 18:20:23 aarne Exp $ -------------------------------------------------------------------- - -module JavaTop15 ( makeJava15 ) where - -------------------------------------------------------------------- --- Dependencies. -------------------------------------------------------------------- -import System.Directory ( createDirectory ) -import System.IO.Error ( try, isAlreadyExistsError ) - -import Utils -import CF -import CFtoCup15 ( cf2Cup ) -import CFtoJLex15 -import CFtoJavaAbs15 ( cf2JavaAbs ) -import CFtoJavaPrinter15 ---import CFtoJavaSkeleton -import CFtoVisitSkel15 -import CFtoComposVisitor -import CFtoAbstractVisitor -import CFtoFoldVisitor -import CFtoAllVisitor -import CFtoLatex -import System.Exit -import GetCF ( tryReadCF, writeFileRep ) -import Data.Char -import Data.List(intersperse) - -------------------------------------------------------------------- --- | Build the Java output. --- FIXME: get everything to put the files in the right places. --- Adapt Makefile to do the business. -------------------------------------------------------------------- -makeJava15 :: Bool - -> Maybe String -- ^ Java package name to put the classes in - -> String -- ^ Name of grammar - -> FilePath -- ^ Grammar file - -> IO () -makeJava15 make inPackage name file = - do (cf, isOK) <- tryReadCF file - if isOK - then do mkFiles make inPackage name cf - putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -mkFiles :: Bool -> Maybe String -> String -> CF -> IO () -mkFiles make inPackage name cf = - do -- Create the package directories if necessary. - let packageBase = case inPackage of - Nothing -> name - Just p -> p ++ "." ++ name - packageAbsyn = packageBase ++ "." ++ "Absyn" - dirBase = pkgToDir packageBase - dirAbsyn = pkgToDir packageAbsyn - prepareDir dirBase - prepareDir dirAbsyn - let absynFiles = remDups $ cf2JavaAbs packageBase packageAbsyn cf - absynBaseNames = map fst absynFiles - absynFileNames = map (dirAbsyn ++) absynBaseNames - absynFuns = [ f | (_,ps) <- cf2data cf, (f,_) <- ps ] - let writeAbsyn (filename, contents) = - writeFileRep (dirAbsyn ++ filename ++ ".java") contents - mapM writeAbsyn absynFiles - writeFileRep (dirBase ++ "PrettyPrinter.java") $ cf2JavaPrinter packageBase packageAbsyn cf - writeFileRep (dirBase ++ "VisitSkel.java") $ cf2VisitSkel packageBase packageAbsyn cf - writeFileRep (dirBase ++ "ComposVisitor.java") $ cf2ComposVisitor packageBase packageAbsyn cf - writeFileRep (dirBase ++ "AbstractVisitor.java") $ cf2AbstractVisitor packageBase packageAbsyn cf - writeFileRep (dirBase ++ "FoldVisitor.java") $ cf2FoldVisitor packageBase packageAbsyn cf - writeFileRep (dirBase ++ "AllVisitor.java") $ cf2AllVisitor packageBase packageAbsyn cf - writeFileRep (dirBase ++ "Test.java") $ javaTest packageBase packageAbsyn cf - let (lex, env) = cf2jlex packageBase packageAbsyn cf - writeFileRep (dirBase ++ "Yylex") lex - putStrLn " (Tested with JLex 1.2.6.)" - writeFileRep (dirBase ++ name ++ ".cup") $ cf2Cup packageBase packageAbsyn cf env - -- FIXME: put in a doc directory? - putStrLn $ " (Parser created for category " ++ firstEntry cf ++ ")" - putStrLn " (Tested with CUP 0.10k)" - writeFileRep (name ++ ".tex") $ cfToLatex name cf - if make - then writeFileRep "Makefile" $ makefile name dirBase dirAbsyn absynFileNames - else return () - where - remDups [] = [] - remDups ((a,b):as) = case lookup a as of - Just {} -> remDups as - Nothing -> (a, b) : (remDups as) - - pkgToDir :: String -> FilePath - pkgToDir s = replace '.' pathSep s ++ [pathSep] - - --- FIXME get filenames right. --- FIXME It's almost certainly better to just feed all the Java source --- files to javac in one go. --- Replace with an ANT script? -makefile :: String -> FilePath -> FilePath -> [String] -> String -makefile name dirBase dirAbsyn absynFileNames = - unlines - [ - "JAVAC = javac", - "JAVAC_FLAGS = -sourcepath .", - "", - "JAVA = java", - "JAVA_FLAGS =", - "", - "CUP = java_cup.Main", - "CUPFLAGS = -nopositions -expect 100", - "", - "JLEX = JLex.Main", - "", - "LATEX = latex", - "DVIPS = dvips", - "", - "all: test " ++ name ++ ".ps", - "", - "test: absyn " - ++ unwords (map (dirBase ++) [ - "Yylex.class", - "PrettyPrinter.class", - "Test.class", - "ComposVisitor.class", - "AbstractVisitor.class", - "FoldVisitor.class", - "AllVisitor.class", - "parser.class", - "sym.class", - "Test.class"]), - "", - ".PHONY: absyn", - "", - "%.class: %.java", - "\t${JAVAC} ${JAVAC_FLAGS} $^", - "", - "absyn: " ++ absynJavaSrc, - "\t${JAVAC} ${JAVAC_FLAGS} $^", - "", - dirBase ++ "Yylex.java: " ++ dirBase ++ "Yylex", - "\t${JAVA} ${JAVA_FLAGS} ${JLEX} " ++ dirBase ++ "Yylex", - "", - dirBase ++ "sym.java " ++ dirBase ++ "parser.java: " ++ dirBase ++ name ++ ".cup", - "\t${JAVA} ${JAVA_FLAGS} ${CUP} ${CUPFLAGS} " ++ dirBase ++ name ++ ".cup", - "\tmv sym.java parser.java " ++ dirBase, - "", - dirBase ++ "Yylex.class: " ++ dirBase ++ "Yylex.java" - ++ " " ++ dirBase ++ "sym.java", - "", - dirBase ++ "sym.class: " ++ dirBase ++ "sym.java", - "", - dirBase ++ "parser.class: " ++ dirBase ++ "parser.java " ++ dirBase ++ "sym.java", - "", - dirBase ++ "PrettyPrinter.class: " ++ dirBase ++ "PrettyPrinter.java", - "", - "" ++ name ++ ".dvi: " ++ name ++ ".tex", - "\t${LATEX} " ++ name ++ ".tex", - "", - "" ++ name ++ ".ps: " ++ name ++ ".dvi", - "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps", --- FIXME - "", - "clean:", - "\t rm -f " ++ dirAbsyn ++ "*.class" ++ " " ++ dirBase ++ "*.class", - "\t rm -f " ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps " ++ " *.class", - "", - "vclean:", - "\t rm -f " ++ absynJavaSrc ++ " " ++ absynJavaClass, - "\t rm -f " ++ dirAbsyn ++ "*.class", - "\t rmdir " ++ dirAbsyn, - "\t rm -f " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps ", - "\t rm -f " ++ unwords (map (dirBase ++) [ - "Yylex", - name ++ ".cup", - "Yylex.java", - "VisitSkel.java", - "ComposVisitor.java", - "AbstractVisitor.java", - "FoldVisitor.java", - "AllVisitor.java", - "PrettyPrinter.java", - "Skeleton.java", - "Test.java", - "sym.java", - "parser.java", - "*.class"]), - "\t rm -f Makefile", - "\t rmdir -p " ++ dirBase, - "" - ] - where absynJavaSrc = unwords (map (++ ".java") absynFileNames) - absynJavaClass = unwords (map (++ ".class") absynFileNames) - -javaTest :: String -> String -> CF -> String -javaTest packageBase packageAbsyn cf = - unlines - [ - "package" +++ packageBase ++ ";", - "import java_cup.runtime.*;", - "import" +++ packageBase ++ ".*;", - "import" +++ packageAbsyn ++ ".*;", - "import java.io.*;", - "", - "public class Test", - "{", - " public static void main(String args[]) throws Exception", - " {", - " Yylex l = null;", - " parser p;", - " try", - " {", - " if (args.length == 0) l = new Yylex(System.in);", - " else l = new Yylex(new FileReader(args[0]));", - " }", - " catch(FileNotFoundException e)", - " {", - " System.err.println(\"Error: File not found: \" + args[0]);", - " System.exit(1);", - " }", - " p = new parser(l);", - " /* The default parser is the first-defined entry point. */", - " /* You may want to change this. Other options are: */", - " /* " ++ (concat (intersperse ", " (showOpts (tail eps)))) ++ " */", - " try", - " {", - " " ++ packageAbsyn ++ "." ++ def +++ "parse_tree = p.p" - ++ def ++ "();", - " System.out.println();", - " System.out.println(\"Parse Succesful!\");", - " System.out.println();", - " System.out.println(\"[Abstract Syntax]\");", - " System.out.println();", - " System.out.println(PrettyPrinter.show(parse_tree));", - " System.out.println();", - " System.out.println(\"[Linearized Tree]\");", - " System.out.println();", - " System.out.println(PrettyPrinter.print(parse_tree));", - " }", - " catch(Throwable e)", - " {", - " System.err.println(\"At line \" + String.valueOf(l.line_num()) + \", near \\\"\" + l.buff() + \"\\\" :\");", - " System.err.println(\" \" + e.getMessage());", - " System.exit(1);", - " }", - " }", - "}" - ] - where eps = allEntryPoints cf - def = head eps - showOpts [] = [] - - showOpts (x:[]) = if normCat x /= x then [] else ['p' : (identCat x)] - showOpts (x:xs) = if normCat x /= x then (showOpts xs) - else ('p' : (identCat x)) : (showOpts xs) diff --git a/formats/java1.5/JavaTop15.hs~ b/formats/java1.5/JavaTop15.hs~ deleted file mode 100644 --- a/formats/java1.5/JavaTop15.hs~ +++ /dev/null @@ -1,285 +0,0 @@ -{- - BNF Converter: Java Top File - Copyright (C) 2004 Author: Markus Forsberg, Peter Gammie, - Michael Pellauer, Bjorn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -------------------------------------------------------------------- --- | --- Module : JavaTop --- Copyright : (C)opyright 2003, {markus, aarne, pellauer, peteg, bringert} at cs dot chalmers dot se --- License : GPL (see COPYING for details) --- --- Maintainer : {markus, aarne} at cs dot chalmers dot se --- Stability : alpha --- Portability : Haskell98 --- --- Top-level for the Java back end. --- --- > $Id: JavaTop15.hs,v 1.12 2007/01/08 18:20:23 aarne Exp $ -------------------------------------------------------------------- - -module JavaTop15 ( makeJava15 ) where - -------------------------------------------------------------------- --- Dependencies. -------------------------------------------------------------------- -import System.Directory ( createDirectory ) -import System.IO ( try, isAlreadyExistsError ) - -import Utils -import CF -import CFtoCup15 ( cf2Cup ) -import CFtoJLex15 -import CFtoJavaAbs15 ( cf2JavaAbs ) -import CFtoJavaPrinter15 ---import CFtoJavaSkeleton -import CFtoVisitSkel15 -import CFtoComposVisitor -import CFtoAbstractVisitor -import CFtoFoldVisitor -import CFtoAllVisitor -import CFtoLatex -import System.IO -import GetCF ( tryReadCF, writeFileRep ) -import Data.Char -import Data.List(intersperse) - -------------------------------------------------------------------- --- | Build the Java output. --- FIXME: get everything to put the files in the right places. --- Adapt Makefile to do the business. -------------------------------------------------------------------- -makeJava15 :: Bool - -> Maybe String -- ^ Java package name to put the classes in - -> String -- ^ Name of grammar - -> FilePath -- ^ Grammar file - -> IO () -makeJava15 make inPackage name file = - do (cf, isOK) <- tryReadCF file - if isOK - then do mkFiles make inPackage name cf - putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -mkFiles :: Bool -> Maybe String -> String -> CF -> IO () -mkFiles make inPackage name cf = - do -- Create the package directories if necessary. - let packageBase = case inPackage of - Nothing -> name - Just p -> p ++ "." ++ name - packageAbsyn = packageBase ++ "." ++ "Absyn" - dirBase = pkgToDir packageBase - dirAbsyn = pkgToDir packageAbsyn - prepareDir dirBase - prepareDir dirAbsyn - let absynFiles = remDups $ cf2JavaAbs packageBase packageAbsyn cf - absynBaseNames = map fst absynFiles - absynFileNames = map (dirAbsyn ++) absynBaseNames - absynFuns = [ f | (_,ps) <- cf2data cf, (f,_) <- ps ] - let writeAbsyn (filename, contents) = - writeFileRep (dirAbsyn ++ filename ++ ".java") contents - mapM writeAbsyn absynFiles - writeFileRep (dirBase ++ "PrettyPrinter.java") $ cf2JavaPrinter packageBase packageAbsyn cf - writeFileRep (dirBase ++ "VisitSkel.java") $ cf2VisitSkel packageBase packageAbsyn cf - writeFileRep (dirBase ++ "ComposVisitor.java") $ cf2ComposVisitor packageBase packageAbsyn cf - writeFileRep (dirBase ++ "AbstractVisitor.java") $ cf2AbstractVisitor packageBase packageAbsyn cf - writeFileRep (dirBase ++ "FoldVisitor.java") $ cf2FoldVisitor packageBase packageAbsyn cf - writeFileRep (dirBase ++ "AllVisitor.java") $ cf2AllVisitor packageBase packageAbsyn cf - writeFileRep (dirBase ++ "Test.java") $ javaTest packageBase packageAbsyn cf - let (lex, env) = cf2jlex packageBase packageAbsyn cf - writeFileRep (dirBase ++ "Yylex") lex - putStrLn " (Tested with JLex 1.2.6.)" - writeFileRep (dirBase ++ name ++ ".cup") $ cf2Cup packageBase packageAbsyn cf env - -- FIXME: put in a doc directory? - putStrLn $ " (Parser created for category " ++ firstEntry cf ++ ")" - putStrLn " (Tested with CUP 0.10k)" - writeFileRep (name ++ ".tex") $ cfToLatex name cf - if make - then writeFileRep "Makefile" $ makefile name dirBase dirAbsyn absynFileNames - else return () - where - remDups [] = [] - remDups ((a,b):as) = case lookup a as of - Just {} -> remDups as - Nothing -> (a, b) : (remDups as) - - pkgToDir :: String -> FilePath - pkgToDir s = replace '.' pathSep s ++ [pathSep] - - --- FIXME get filenames right. --- FIXME It's almost certainly better to just feed all the Java source --- files to javac in one go. --- Replace with an ANT script? -makefile :: String -> FilePath -> FilePath -> [String] -> String -makefile name dirBase dirAbsyn absynFileNames = - unlines - [ - "JAVAC = javac", - "JAVAC_FLAGS = -sourcepath .", - "", - "JAVA = java", - "JAVA_FLAGS =", - "", - "CUP = java_cup.Main", - "CUPFLAGS = -nopositions -expect 100", - "", - "JLEX = JLex.Main", - "", - "LATEX = latex", - "DVIPS = dvips", - "", - "all: test " ++ name ++ ".ps", - "", - "test: absyn " - ++ unwords (map (dirBase ++) [ - "Yylex.class", - "PrettyPrinter.class", - "Test.class", - "ComposVisitor.class", - "AbstractVisitor.class", - "FoldVisitor.class", - "AllVisitor.class", - "parser.class", - "sym.class", - "Test.class"]), - "", - ".PHONY: absyn", - "", - "%.class: %.java", - "\t${JAVAC} ${JAVAC_FLAGS} $^", - "", - "absyn: " ++ absynJavaSrc, - "\t${JAVAC} ${JAVAC_FLAGS} $^", - "", - dirBase ++ "Yylex.java: " ++ dirBase ++ "Yylex", - "\t${JAVA} ${JAVA_FLAGS} ${JLEX} " ++ dirBase ++ "Yylex", - "", - dirBase ++ "sym.java " ++ dirBase ++ "parser.java: " ++ dirBase ++ name ++ ".cup", - "\t${JAVA} ${JAVA_FLAGS} ${CUP} ${CUPFLAGS} " ++ dirBase ++ name ++ ".cup", - "\tmv sym.java parser.java " ++ dirBase, - "", - dirBase ++ "Yylex.class: " ++ dirBase ++ "Yylex.java" - ++ " " ++ dirBase ++ "sym.java", - "", - dirBase ++ "sym.class: " ++ dirBase ++ "sym.java", - "", - dirBase ++ "parser.class: " ++ dirBase ++ "parser.java " ++ dirBase ++ "sym.java", - "", - dirBase ++ "PrettyPrinter.class: " ++ dirBase ++ "PrettyPrinter.java", - "", - "" ++ name ++ ".dvi: " ++ name ++ ".tex", - "\t${LATEX} " ++ name ++ ".tex", - "", - "" ++ name ++ ".ps: " ++ name ++ ".dvi", - "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps", --- FIXME - "", - "clean:", - "\t rm -f " ++ dirAbsyn ++ "*.class" ++ " " ++ dirBase ++ "*.class", - "\t rm -f " ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps " ++ " *.class", - "", - "vclean:", - "\t rm -f " ++ absynJavaSrc ++ " " ++ absynJavaClass, - "\t rm -f " ++ dirAbsyn ++ "*.class", - "\t rmdir " ++ dirAbsyn, - "\t rm -f " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps ", - "\t rm -f " ++ unwords (map (dirBase ++) [ - "Yylex", - name ++ ".cup", - "Yylex.java", - "VisitSkel.java", - "ComposVisitor.java", - "AbstractVisitor.java", - "FoldVisitor.java", - "AllVisitor.java", - "PrettyPrinter.java", - "Skeleton.java", - "Test.java", - "sym.java", - "parser.java", - "*.class"]), - "\t rm -f Makefile", - "\t rmdir -p " ++ dirBase, - "" - ] - where absynJavaSrc = unwords (map (++ ".java") absynFileNames) - absynJavaClass = unwords (map (++ ".class") absynFileNames) - -javaTest :: String -> String -> CF -> String -javaTest packageBase packageAbsyn cf = - unlines - [ - "package" +++ packageBase ++ ";", - "import java_cup.runtime.*;", - "import" +++ packageBase ++ ".*;", - "import" +++ packageAbsyn ++ ".*;", - "import java.io.*;", - "", - "public class Test", - "{", - " public static void main(String args[]) throws Exception", - " {", - " Yylex l = null;", - " parser p;", - " try", - " {", - " if (args.length == 0) l = new Yylex(System.in);", - " else l = new Yylex(new FileReader(args[0]));", - " }", - " catch(FileNotFoundException e)", - " {", - " System.err.println(\"Error: File not found: \" + args[0]);", - " System.exit(1);", - " }", - " p = new parser(l);", - " /* The default parser is the first-defined entry point. */", - " /* You may want to change this. Other options are: */", - " /* " ++ (concat (intersperse ", " (showOpts (tail eps)))) ++ " */", - " try", - " {", - " " ++ packageAbsyn ++ "." ++ def +++ "parse_tree = p.p" - ++ def ++ "();", - " System.out.println();", - " System.out.println(\"Parse Succesful!\");", - " System.out.println();", - " System.out.println(\"[Abstract Syntax]\");", - " System.out.println();", - " System.out.println(PrettyPrinter.show(parse_tree));", - " System.out.println();", - " System.out.println(\"[Linearized Tree]\");", - " System.out.println();", - " System.out.println(PrettyPrinter.print(parse_tree));", - " }", - " catch(Throwable e)", - " {", - " System.err.println(\"At line \" + String.valueOf(l.line_num()) + \", near \\\"\" + l.buff() + \"\\\" :\");", - " System.err.println(\" \" + e.getMessage());", - " System.exit(1);", - " }", - " }", - "}" - ] - where eps = allEntryPoints cf - def = head eps - showOpts [] = [] - - showOpts (x:[]) = if normCat x /= x then [] else ['p' : (identCat x)] - showOpts (x:xs) = if normCat x /= x then (showOpts xs) - else ('p' : (identCat x)) : (showOpts xs) diff --git a/formats/ocaml/CFtoOCamlAbs.hs b/formats/ocaml/CFtoOCamlAbs.hs deleted file mode 100644 --- a/formats/ocaml/CFtoOCamlAbs.hs +++ /dev/null @@ -1,63 +0,0 @@ -{- - BNF Converter: OCaml Abstract Syntax Generator - Copyright (C) 2005 Author: Kristofer Johannisson - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - --- based on BNFC Haskell backend - -module CFtoOCamlAbs (cf2Abstract) where - -import CF -import Utils((+++),(++++)) -import Data.List(intersperse) -import OCamlUtil - --- to produce an OCaml module -cf2Abstract :: String -> CF -> String -cf2Abstract name cf = unlines $ - "(* OCaml module generated by the BNF converter *)\n\n" : - mutualRecDefs (map (prSpecialData cf) (specialCats cf) ++ map prData (cf2data cf)) - --- allow mutual recursion so that we do not have to sort the type definitions in --- dependency order -mutualRecDefs :: [String] -> [String] -mutualRecDefs ss = case ss of - [] -> [] - [x] -> ["type" +++ x] - x:xs -> ("type" +++ x) : map ("and" +++) xs - - - -prData :: Data -> String -prData (cat,rules) = - fixType cat +++ "=\n " ++ - concat (intersperse "\n | " (map prRule rules)) ++ - "\n" - -prRule (fun,[]) = fun -prRule (fun,cats) = fun +++ "of" +++ mkTupleType cats - -mkTupleType [c] = fixType c -mkTupleType (c:cs) = fixType c +++ "*" +++ mkTupleType cs - -prSpecialData :: CF -> Cat -> String -prSpecialData cf cat = fixType cat +++ "=" +++ cat +++ "of" +++ contentSpec cf cat --- unwords ["newtype",cat,"=",cat,contentSpec cf cat,"deriving (Eq,Ord,Show)"] - -contentSpec :: CF -> Cat -> String -contentSpec cf cat = -- if isPositionCat cf cat then "((Int,Int),String)" else "String" - if isPositionCat cf cat then "((int * int) * string)" else "string" diff --git a/formats/ocaml/CFtoOCamlLex.hs b/formats/ocaml/CFtoOCamlLex.hs deleted file mode 100644 --- a/formats/ocaml/CFtoOCamlLex.hs +++ /dev/null @@ -1,230 +0,0 @@ -{- - BNF Converter: ocamllex Generator - Copyright (C) 2005 Author: Kristofer Johannisson - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - - --- based on BNFC Haskell backend - -module CFtoOCamlLex (cf2ocamllex) where - -import Data.List -import Data.Char - -import CF -import AbsBNF -import CFtoOCamlYacc (terminal) -import Utils ((+++)) - -cf2ocamllex :: String -> String -> CF -> String -cf2ocamllex name parserMod cf = - unlines $ concat $ intersperse [""] [ - header parserMod cf, - definitions cf, - let r = rules cf in case r of - [] -> [] - x:xs -> ("rule" +++ x) : map ("and" +++) xs - ] - -header :: String -> CF -> [String] -header parserMod cf = [ - "(* This ocamllex file was machine-generated by the BNF converter *)", - "{", - "open " ++ parserMod, - "open Lexing", - "", - hashtables cf, - "", - "let unescapeInitTail (s:string) : string =", - " let rec unesc s = match s with", - " '\\\\'::c::cs when List.mem c ['\\\"'; '\\\\'; '\\\''] -> c :: unesc cs", - " | '\\\\'::'n'::cs -> '\\n' :: unesc cs", - " | '\\\\'::'t'::cs -> '\\t' :: unesc cs", - " | '\\\"'::[] -> []", - " | c::cs -> c :: unesc cs", - " | _ -> []", - " (* explode/implode from caml FAQ *)", - " in let explode (s : string) : char list =", - " let rec exp i l =", - " if i < 0 then l else exp (i - 1) (s.[i] :: l) in", - " exp (String.length s - 1) []", - " in let implode (l : char list) : string =", - " let res = String.create (List.length l) in", - " let rec imp i = function", - " | [] -> res", - " | c :: l -> res.[i] <- c; imp (i + 1) l in", - " imp 0 l", - " in implode (unesc (List.tl (explode s)))", - "", - "let incr_lineno (lexbuf:Lexing.lexbuf) : unit =", - " let pos = lexbuf.lex_curr_p in", - " lexbuf.lex_curr_p <- { pos with", - " pos_lnum = pos.pos_lnum + 1;", - " pos_bol = pos.pos_cnum;", - " }", - "}" - ] - --- | set up hashtables for reserved symbols and words -hashtables :: CF -> String -hashtables cf = ht "symbol_table" (symbols cf ) ++ "\n" ++ - ht "resword_table" (reservedWords cf) - where ht table syms | length syms == 0 = "" - ht table syms = unlines [ - "let" +++ table +++ "= Hashtbl.create " ++ show (length syms), - "let _ = List.iter (fun (kwd, tok) -> Hashtbl.add" +++ table - +++ "kwd tok)", - " [" ++ concat (intersperse ";" keyvals) ++ "]" - ] - where keyvals = map (\(x,y) -> "(" ++ x ++ ", " ++ y ++ ")") - (zip (map show syms) (map (terminal cf) syms)) - - - -definitions :: CF -> [String] -definitions cf = concat [ - cMacros, - rMacros cf - ] - - -cMacros :: [String] -cMacros = [ - "let l = ['a'-'z' 'A'-'Z' '\\192' - '\\255'] # ['\\215' '\\247'] (* isolatin1 letter FIXME *)", - "let c = ['A'-'Z' '\\192'-'\\221'] # ['\\215'] (* capital isolatin1 letter FIXME *)", - "let s = ['a'-'z' '\\222'-'\\255'] # ['\\247'] (* small isolatin1 letter FIXME *)", - "let d = ['0'-'9'] (* digit *)", - "let i = l | d | ['_' '\\''] (* identifier character *)", - "let u = ['\\000'-'\\255'] (* universal: any character *)" - ] - -rMacros :: CF -> [String] -rMacros cf = - let symbs = symbols cf - in - (if null symbs then [] else [ - "let rsyms = (* reserved words consisting of special symbols *)", - " " ++ unwords (intersperse "|" (map mkEsc symbs)) - ]) - where - mkEsc s = "\"" ++ concat (map f s) ++ "\"" - f x = if x `elem` ['"','\\'] then "\\" ++ [x] else [x] - - - -rules :: CF -> [String] -rules cf = oneRule $ concat [ - lexComments (comments cf), - ["l i* " ++ case reservedWords cf of - [] -> "{let id = lexeme lexbuf in TOK_Ident id}" - _ -> "{let id = lexeme lexbuf in try Hashtbl.find resword_table id with Not_found -> TOK_Ident id}" - ], - if null (symbols cf) then [] - else ["rsyms {let id = lexeme lexbuf in try Hashtbl.find symbol_table id with Not_found -> failwith (\"internal lexer error: reserved symbol \" ^ id ^ \" not found in hashtable\")}"], - ["d+ {let i = lexeme lexbuf in TOK_Integer (int_of_string i)}"], - ["d+ '.' d+ ('e' ('-')? d+)? {let f = lexeme lexbuf in TOK_Double (float_of_string f)}"], - ["'\\\"' ((u # ['\\\"' '\\\\' '\\n']) | ('\\\\' ('\\\"' | '\\\\' | '\\\'' | 'n' | 't')))* '\\\"' {let s = lexeme lexbuf in TOK_String (unescapeInitTail s)}"], - ["[' ' '\\t'] {token lexbuf}"], - ["'\\n' {incr_lineno lexbuf; token lexbuf}"], - ["eof { TOK_EOF }"] - ] - where - oneRule xs = ["token = \n parse " ++ concat (intersperse "\n | " xs)] - lexComments ([],[]) = [] - lexComments (xs,s1:ys) = ('\"' : s1 ++ "\"" ++ - " (_ # '\\n')* { token lexbuf } (* Toss single line comments *)") : - lexComments (xs, ys) - lexComments (([l1,l2],[r1,r2]):xs,[]) = (concat $ - [ - ('\"':l1:l2:"\" ((u # ['"), -- FIXME quotes or escape? - (l2:"']) | '"), - (r1:"' (u # ['"), - (r2:"']))* ('"), - (r1:"')+ '"), - (r2:"' { token lexbuf } \n") - ]) : - lexComments (xs, []) - lexComments ((_:xs),[]) = lexComments (xs,[]) - - -------------------------------------------------------------------- --- Modified from the inlined version of @RegToAlex@. -------------------------------------------------------------------- - --- modified from pretty-printer generated by the BNF converter - --- the top-level printing method -printRegOCaml :: Reg -> String -printRegOCaml = render . prt 0 - --- you may want to change render and parenth - -render :: [String] -> String -render = rend 0 - where rend :: Int -> [String] -> String - rend i ss = case ss of - "[" :ts -> cons "[" $ rend i ts - "(" :ts -> cons "(" $ rend i ts - t : "," :ts -> cons t $ space "," $ rend i ts - t : ")" :ts -> cons t $ cons ")" $ rend i ts - t : "]" :ts -> cons t $ cons "]" $ rend i ts - t :ts -> space t $ rend i ts - _ -> "" - - cons s t = s ++ t - new i s = s - space t s = if null s then t else t ++ " " ++ s - -parenth :: [String] -> [String] -parenth ss = ["("] ++ ss ++ [")"] - --- the printer class does the job -class Print a where - prt :: Int -> a -> [String] - prtList :: [a] -> [String] - prtList = concat . map (prt 0) - -instance Print a => Print [a] where - prt _ = prtList - -instance Print Char where - prt _ c = [show c] -- if isAlphaNum c then [[c]] else ['\\':[c]] - prtList s = [show s] -- map (concat . prt 0) s - -prPrec :: Int -> Int -> [String] -> [String] -prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) - RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) - RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) - RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) - RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) - ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) - REps -> prPrec i 3 (["\"\""]) -- special construct for eps in ocamllex? - RChar c -> prPrec i 3 (concat [prt 0 c]) - RAlts str -> prPrec i 3 (concat [["["],prt 0 (concatMap show str),["]"]]) - RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) - RDigit -> prPrec i 3 (concat [["digit"]]) - RLetter -> prPrec i 3 (concat [["letter"]]) - RUpper -> prPrec i 3 (concat [["upper"]]) - RLower -> prPrec i 3 (concat [["lower"]]) - RAny -> prPrec i 3 (concat [["univ"]]) diff --git a/formats/ocaml/CFtoOCamlPrinter.hs b/formats/ocaml/CFtoOCamlPrinter.hs deleted file mode 100644 --- a/formats/ocaml/CFtoOCamlPrinter.hs +++ /dev/null @@ -1,200 +0,0 @@ -{- - BNF Converter: Pretty-printer generator - Copyright (C) 2005 Author: Kristofer Johannisson - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - --- based on BNFC Haskell backend - -module CFtoOCamlPrinter (cf2Printer) where - -import CF -import Utils -import CFtoTemplate -import Data.List (intersperse) -import Data.Char(toLower,isDigit) -import OCamlUtil - --- derive pretty-printer from a BNF grammar. AR 15/2/2002 -cf2Printer :: String -> String -> CF -> String -cf2Printer name absMod cf = unlines [ - prologue name absMod, - charRule cf, - integerRule cf, - doubleRule cf, - stringRule cf, - if hasIdent cf then identRule cf else "", - unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf], - rules cf - ] - - -prologue :: String -> String -> String -prologue name absMod = unlines [ - "(* pretty-printer generated by the BNF converter *)\n", - "open " ++ absMod, - "open Printf", - "", - "(* We use string buffers for efficient string concatenation.", - " A document takes a buffer and an indentation, has side effects on the buffer", - " and returns a new indentation. The indentation argument indicates the level", - " of indentation to be used if a new line has to be started (because of what is", - " already in the buffer) *)", - "type doc = Buffer.t -> int -> int", - "", - "let rec printTree (printer : int -> 'a -> doc) (tree : 'a) : string = ", - " let buffer_init_size = 16 (* you may want to change this *)", - " in let buffer = Buffer.create buffer_init_size", - " in ", - " let _ = printer 0 tree buffer 0 in (* discard return value *)", - " Buffer.contents buffer", - "", - "let indent_width = 4", - "", - "let indent (i: int) : string = ", - " let s = String.make (i+1) ' ' in", - " String.set s 0 '\\n';", - " s", - "", - "(* this render function is written for C-style languages, you may want to change it *)", - "let render (s : string) : doc = fun buf i -> ", - " (* invariant: last char of the buffer is never whitespace *)", - " let n = Buffer.length buf in", - " let last = if n = 0 then None else Some (Buffer.nth buf (n-1)) in", - " let whitespace = match last with", - " None -> \"\" ", - " | Some '{' -> indent i", - " | Some '}' -> (match s with", - " \";\" -> \"\"", - " | _ -> indent i)", - " | Some ';' -> indent i", - " | (Some '[') | (Some '(') -> \"\"", - " | Some _ -> (match s with", - " \",\" | \")\" | \"]\" -> \"\"", - " | _ -> \" \") in", - " let newindent = match s with", - " \"{\" -> i + indent_width", - " | \"}\" -> i - indent_width", - " | _ -> i in", - " Buffer.add_string buf whitespace;", - " Buffer.add_string buf s;", - " newindent", - "", - "let emptyDoc : doc = fun buf i -> i", - "", - "let concatD (ds : doc list) : doc = fun buf i -> ", - " List.fold_left (fun accIndent elemDoc -> elemDoc buf accIndent) (emptyDoc buf i) ds", - "", - "let parenth (d:doc) : doc = concatD [render \"(\"; d; render \")\"]", - "", - "let prPrec (i:int) (j:int) (d:doc) : doc = if j String -rules cf = unlines $ mutualDefs $ - map (\(s,xs) -> case_fun s (map toArgs xs) ++ ifList cf s) $ cf2data cf - where - toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons) - names [] _ = [] - names (x:xs) n - | elem x xs = (x ++ show n) : names xs (n+1) - | otherwise = x : names xs n - var ('[':xs) = var (init xs) ++ "s" - var "Ident" = "id" - var "Integer" = "n" - var "String" = "str" - var "Char" = "c" - var "Double" = "d" - var xs = map toLower xs - checkRes s - | elem s reservedOCaml = s ++ "'" - | otherwise = s - ruleOf s = maybe undefined id $ lookup s (rulesOfCF cf) - ---- case_fun :: Cat -> [(Constructor,Rule)] -> String -case_fun cat xs = unlines [ --- "instance Print" +++ cat +++ "where", - prtFun cat +++"(i:int)" +++ "(e:" ++ fixType cat ++ ") : doc = match e with", - unlines $ insertBar $ map (\ ((c,xx),r) -> - " " ++ c +++ mkTuple xx +++ "->" +++ - "prPrec i" +++ show (precCat (fst r)) +++ mkRhs xx (snd r)) xs - ] - -ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where - nil cat = [" [] -> " ++ mkRhs [] its | - (f,(c,its)) <- rulesOfCF cf, isNilFun f , normCatOfList c == cat] - one cat = [" | [x] -> " ++ mkRhs ["x"] its | - (f,(c,its)) <- rulesOfCF cf, isOneFun f , normCatOfList c == cat] - cons cat = [" | x::xs -> " ++ mkRhs ["x","xs"] its | - (f,(c,its)) <- rulesOfCF cf, isConsFun f , normCatOfList c == cat] - mkListRule [] = "" - mkListRule rs = unlines $ ("and prt" ++ fixTypeUpper cat ++ "ListBNFC" +++ "_ es : doc = match es with"):rs - - -mkRhs args its = - "(concatD [" ++ unwords (intersperse ";" (mk args its)) ++ "])" - where - mk args (Left "#" : items) = mk args items - mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items - mk args (Right s : items) = ("render " ++ show s) : mk args items - mk _ _ = [] - prt c = prtFun c +++ show (precCat c) - -prtFun :: Cat -> String -prtFun c = case c of - '[':xs -> case break (== ']') xs of - (t,"]") -> prtFun t ++ "ListBNFC" - _ -> c -- should not occur (this means an invariant of the type Cat is broken) - _ -> if precCat c > 0 -- precedence-level cats are not in abstract syntax - then "prt" ++ (fixTypeUpper $ reverse (dropWhile isDigit (reverse c))) - else "prt" ++ (fixTypeUpper c) - diff --git a/formats/ocaml/CFtoOCamlShow.hs b/formats/ocaml/CFtoOCamlShow.hs deleted file mode 100644 --- a/formats/ocaml/CFtoOCamlShow.hs +++ /dev/null @@ -1,153 +0,0 @@ -{- - BNF Converter: Non-pretty-printer generator (no "deriving Show" in OCaml...) - Copyright (C) 2005 Author: Kristofer Johannisson - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - --- there is no "deriving Show" in OCaml, although there are solutions based --- on camlp4. Here we generate our own "show module". - - -module CFtoOCamlShow (cf2show) where - -import CF -import Utils -import CFtoTemplate -import Data.List (intersperse) -import Data.Char(toLower,isDigit) -import OCamlUtil - -cf2show :: String -> String -> CF -> String -cf2show name absMod cf = unlines [ - prologue name absMod, - integerRule cf, - doubleRule cf, - if hasIdent cf then identRule cf else "", - unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf], - rules cf - ] - - -prologue :: String -> String -> String -prologue name absMod = unlines [ - "(* show functions generated by the BNF converter *)\n", - "open " ++ absMod, - "", - "(* use string buffers for efficient string concatenations *)", - "type showable = Buffer.t -> unit", - "", - "let show (s : showable) : string = ", - " let init_size = 16 in (* you may want to adjust this *)", - " let b = Buffer.create init_size in", - " s b;", - " Buffer.contents b", - " ", - "let emptyS : showable = fun buf -> ()", - "", - "let c2s (c:char) : showable = fun buf -> Buffer.add_char buf c", - "let s2s (s:string) : showable = fun buf -> Buffer.add_string buf s", - "", - "let ( >> ) (s1 : showable) (s2 : showable) : showable = fun buf -> s1 buf; s2 buf", - "", - "let showChar (c:char) : showable = fun buf -> ", - " Buffer.add_string buf (\"'\" ^ Char.escaped c ^ \"'\")", - "", - "let showString (s:string) : showable = fun buf -> ", - " Buffer.add_string buf (\"\\\"\" ^ String.escaped s ^ \"\\\"\")", - "", - "let showList (showFun : 'a -> showable) (xs : 'a list) : showable = fun buf -> ", - " let rec f ys = match ys with", - " [] -> ()", - " | [y] -> showFun y buf", - " | y::ys -> showFun y buf; Buffer.add_string buf \"; \"; f ys ", - " in", - " Buffer.add_char buf '[';", - " f xs;", - " Buffer.add_char buf ']'", - "" - ] - -integerRule cf = "let showInt (i:int) : showable = s2s (string_of_int i)" - -doubleRule cf = "let showFloat (f:float) : showable = s2s (string_of_float f)" - - -identRule cf = ownPrintRule cf "Ident" - -ownPrintRule cf own = unlines $ [ - "let rec" +++ showsFun own +++ "(" ++ own ++ posn ++ ") : showable = s2s \"" - ++ own ++ " \" >> showString i" - ] - where - posn = if isPositionCat cf own then " (_,i)" else " i" - --- copy and paste from CFtoTemplate - -rules :: CF -> String -rules cf = unlines $ mutualDefs $ - map (\(s,xs) -> case_fun s (map toArgs xs)) $ cf2data cf -- ++ ifList cf s - where - toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), - ruleOf cons) - names [] _ = [] - names (x:xs) n - | elem x xs = (x ++ show n) : names xs (n+1) - | otherwise = x : names xs n - var ('[':xs) = var (init xs) ++ "s" - var "Ident" = "id" - var "Integer" = "n" - var "String" = "str" - var "Char" = "c" - var "Double" = "d" - var xs = map toLower xs - checkRes s - | elem s reservedOCaml = s ++ "'" - | otherwise = s - ruleOf s = maybe undefined id $ lookup s (rulesOfCF cf) - ---- case_fun :: Cat -> [(Constructor,Rule)] -> String -case_fun cat xs = unlines [ --- "instance Print" +++ cat +++ "where", - showsFun cat +++ "(e:" ++ fixType cat ++ ") : showable = match e with", - unlines $ insertBar $ map (\ ((c,xx),r) -> - " " ++ c +++ mkTuple xx +++ "->" +++ - "s2s" +++ show c +++ - case mkRhs xx (snd r) of {[] -> []; str -> ">> c2s ' ' >> " ++ str} - ) - xs - ] - - -mkRhs args its = - case unwords (intersperse " >> s2s \", \" >> " (mk args its)) of - [] -> "" - str -> "c2s '(' >> " ++ str ++ " >> c2s ')'" - where - mk args (Left "#" : items) = mk args items - mk (arg:args) (Left c : items) = (showsFun c +++ arg) : mk args items - mk args (Right s : items) = mk args items - mk _ _ = [] - prt c = showsFun c +++ show (precCat c) - -showsFun :: Cat -> String -showsFun c = case c of - '[':xs -> case break (== ']') xs of - (t,"]") -> "showList" +++ showsFun t -- showFun t ++ "List" - _ -> c -- should not occur (this means an invariant of the type Cat is broken) - _ -> if precCat c > 0 -- precedence-level cats are not in abstract syntax - then "show" ++ (fixTypeUpper $ reverse (dropWhile isDigit (reverse c))) - else "show" ++ (fixTypeUpper c) - diff --git a/formats/ocaml/CFtoOCamlTemplate.hs b/formats/ocaml/CFtoOCamlTemplate.hs deleted file mode 100644 --- a/formats/ocaml/CFtoOCamlTemplate.hs +++ /dev/null @@ -1,73 +0,0 @@ -{- - BNF Converter: Template Generator - Copyright (C) 2005 Author: Kristofer Johannisson - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - --- based on BNFC Haskell backend - - -module CFtoOCamlTemplate ( - cf2Template - ) where - -import CF -import Data.Char -import Data.List (delete) -import Utils((+++)) -import OCamlUtil - - -type ModuleName = String -type Constructor = String - -cf2Template :: ModuleName -> ModuleName -> CF -> String -cf2Template skelName absName cf = unlines - [ - "module "++ skelName ++ " = struct\n", - "(* OCaml module generated by the BNF converter *)\n", - "open " ++ absName ++ "\n", - "type result = string\n", - "let failure x = failwith \"Undefined case.\" (* x discarded *)\n", - unlines $ mutualDefs $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf, - "end" - ] - where toArgs [] = [] - toArgs ((cons,args):xs) - = (cons ++ " " ++ (mkTuple $ names (map (checkRes . var) args) (0 :: Int))) : toArgs xs - names :: [String] -> Int -> [String] - names [] _ = [] - names (x:xs) n - | elem x xs = (x ++ show n) : names xs (n+1) - | otherwise = x : names xs n - var ('[':xs) = var (init xs) ++ "s" - var "Ident" = "id" - var "Integer" = "n" - var "String" = "str" - var "Char" = "c" - var "Double" = "d" - var xs = map toLower xs - checkRes s - | elem s reservedOCaml = s ++ "'" - | otherwise = s - - -case_fun :: Cat -> [Constructor] -> String -case_fun cat xs = - unlines $ - ["trans" ++ cat ++ " (x : " ++ fixType cat ++ ") : result = match x with", - unlines $ insertBar $ map (\s -> s ++ " -> " ++ "failure x") xs] - diff --git a/formats/ocaml/CFtoOCamlTest.hs b/formats/ocaml/CFtoOCamlTest.hs deleted file mode 100644 --- a/formats/ocaml/CFtoOCamlTest.hs +++ /dev/null @@ -1,66 +0,0 @@ -{- - BNF Converter: Generate main/test module for OCaml - Copyright (C) 2005 Author: Kristofer Johannisson - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoOCamlTest where - -import CF -import Utils -import OCamlUtil - -ocamlTestfile :: String -> String -> String -> String -> String -> CF -> String -ocamlTestfile absM lexM parM printM showM cf = - let - lexerName = lexM ++ ".token" - parserName = parM ++ ".p" ++ topTypeC - printerName = printM ++ ".printTree " ++ printM ++ ".prt" ++ topTypeC - showFun = "(fun x -> " ++ showM ++ ".show (" ++ showM ++ ".show" ++ - topTypeC ++ " x))" - topTypeC = fixTypeUpper (firstEntry cf) - topType = absM ++ "." ++ fixType (firstEntry cf) - in unlines [ - "(* automatically generated by the BNF Converter *)", - "", - "open Lexing", - "", - "let parse (c : in_channel) : " ++ topType ++ " = ", - " " ++ parserName +++ lexerName +++ "(Lexing.from_channel c)", - ";;", - "", - "let showTree (t : " ++ topType ++ ") : string = ", - " \"[Abstract syntax]\\n\\n\" ^ " ++ showFun +++ "t" ++ " ^ \"\\n\\n\" ^", - " \"[Linearized tree]\\n\\n\" ^ " ++ printerName +++ "t" ++ " ^ \"\\n\"", - ";;", - "", - "let main () = ", - " let filename = Sys.argv.(1) in", - " let channel = open_in filename in", - " try", - " print_string (showTree (parse channel));", - " flush stdout", - " with BNFC_Util.Parse_error (start_pos, end_pos) ->", -- " ++ parM ++ ". - " Printf.printf \"Parse error at %d.%d-%d.%d\\n\"", - " start_pos.pos_lnum (start_pos.pos_cnum - start_pos.pos_bol)", - " end_pos.pos_lnum (end_pos.pos_cnum - end_pos.pos_bol);", - ";;", - "", - "main ();;", - "" - ] - - diff --git a/formats/ocaml/CFtoOCamlYacc.hs b/formats/ocaml/CFtoOCamlYacc.hs deleted file mode 100644 --- a/formats/ocaml/CFtoOCamlYacc.hs +++ /dev/null @@ -1,232 +0,0 @@ -{- - BNF Converter: ocamlyacc Generator - Copyright (C) 2005 Author: Kristofer Johannisson - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - --- based on BNFC Haskell backend - - -module CFtoOCamlYacc - ( - cf2ocamlyacc, terminal - ) - where - -import CF -import Data.List (intersperse,nub) -import Data.Char - -import Utils ((+++)) -import OCamlUtil - --- Type declarations - -type Rules = [(NonTerminal,[(Pattern,Action)])] -type NonTerminal = String -type Pattern = String -type Action = String -type MetaVar = String - --- default naming - - -tokenName = "Token" - - - --- The main function, that given a CF --- generates a ocamlyacc module. -cf2ocamlyacc :: String -> String -> String -> CF -> String -cf2ocamlyacc name absName lexName cf - = unlines - [header name absName lexName, - declarations absName cf, - "%%", - rules cf - ] - - -header :: String -> String -> String -> String -header modName absName lexName = unlines - ["/* This ocamlyacc file was machine-generated by the BNF converter */", - "%{", - "open " ++ absName, - "open Lexing", - "%}" - ] - - -declarations :: String -> CF -> String -declarations absName cf = unlines - [tokens (symbols cf) (reservedWords cf), - specialTokens cf, - entryPoints absName cf - ] - -tokens :: [String] -> [String] -> String -tokens symbols reswords = unlines - [ - if (length reswords) > 0 - then "%token" +++ concat (intersperse " " (map ("TOK_" ++) reswords)) - else "" - , - concatMap (\(s,n) -> "\n%token SYMB" ++ (show n) +++ "/*" +++ s +++ "*/") - (zip symbols [1..]) - ] - --- | map a CF terminal into a ocamlyacc token -terminal :: CF -> String -> String -terminal cf s | s `elem` reservedWords cf = "TOK_" ++ s -terminal cf s = case lookup s (zip (symbols cf) [1..]) of - Just i -> "SYMB" ++ show i - Nothing -> error $ "CFtoOCamlYacc: terminal " ++ show s ++ " not defined in CF." - - --- | map a CF nonterminal into a ocamlyacc symbol -nonterminal :: Cat -> String -nonterminal c = map spaceToUnderscore (fixType c) - where spaceToUnderscore ' ' = '_' - spaceToUnderscore x = x - -specialTokens :: CF -> String -specialTokens cf = unlines ("%token TOK_EOF" : map aux (nub $ ["Ident","String","Integer","Double","Char"] ++ literals cf)) - where aux cat = "%token" +++ (case cat of - "Ident" -> "" - "String" -> "" - "Integer" -> "" - "Double" -> "" - "Char" -> "" - own -> "" ) - +++ "TOK_" ++ cat - - -entryPoints :: String -> CF -> String -entryPoints absName cf = unlines $ - ("%start" +++ - concat (intersperse " " (map epName eps))) - : - (map typing eps) - where eps = (nub $ map normCat (allEntryPoints cf)) - typing :: Cat -> String - typing c = "%type" +++ "<" ++ qualify c ++ ">" +++ epName c - qualify c = if c `elem` ["Integer","Double","Char","String", - "[Integer]","[Double]","[Char]","[String]"] - then fixType c - else absName ++ "." ++ fixType c - -epName :: Cat -> String -epName c = "p" ++ capitalize (nonterminal c) - where capitalize s = case s of - [] -> [] - c:cs -> toUpper c : cs - -entryPointRules :: CF -> String -entryPointRules cf = unlines $ map mkRule (nub $ map normCat (allEntryPoints cf)) - where - mkRule :: String -> String - mkRule s = unlines [ - epName s ++ " : " ++ nonterminal s ++ " TOK_EOF { $1 }", - " | error { raise (BNFC_Util.Parse_error (Parsing.symbol_start_pos (), Parsing.symbol_end_pos ())) };" - ] - -rules :: CF -> String -rules cf = unlines [ - entryPointRules cf, - (unlines $ map (prOne . mkOne) (ruleGroups cf)), - specialRules cf - ] - where - mkOne (cat,rules) = constructRule cf rules cat - prOne (nt,[]) = [] -- nt has only internal use - prOne (nt,((p,a):ls)) = - unwords [nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ ";\n" - where - nt' = nonterminal nt - pr [] = [] - pr ((p,a):ls) = - unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls - - - --- For every non-terminal, we construct a set of rules. A rule is a sequence of --- terminals and non-terminals, and an action to be performed --- As an optimization, a pair of list rules [C] ::= "" | C k [C] --- is left-recursivized into [C] ::= "" | [C] C k. --- This could be generalized to cover other forms of list rules. -constructRule :: CF -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) -constructRule cf rules nt = (nt,[(p,generateAction nt (funRule r) (mkFlip b m)) | - r0 <- rules, - let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0), - let (p,m) = generatePatterns cf r]) - where - revs = reversibleCats cf - mkFlip doit xs = case xs of - a:b:rest | doit -> b:a:rest - _ -> xs - - - --- Generates a string containing the semantic action. --- An action can for example be: Sum $1 $2, that is, construct an AST --- with the constructor Sum applied to the two metavariables $1 and $2. -generateAction :: NonTerminal -> Fun -> [MetaVar] -> Action -generateAction nt f ms = (if isCoercion f then "" else f') +++ mkTuple ms - where f' = case f of -- ocaml cons is somehow not a standard infix oper, right? - "(:[])" -> "(fun x -> [x])" - "(:)" -> "(fun (x,xs) -> x::xs)" - _ -> f - - -generatePatterns :: CF -> Rule -> (Pattern,[MetaVar]) -generatePatterns cf r = case rhsRule r of - [] -> ("/* empty */",[]) - its -> (unwords (map mkIt its), metas its) - where - mkIt i = case i of - Left c -> nonterminal c - Right s -> terminal cf s - metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its] - revIf c m = if (not (isConsFun (funRule r)) && elem c revs) - then ("(List.rev " ++ m ++ ")") - else m -- no reversal in the left-recursive Cons rule itself - revs = reversibleCats cf - - - - - -specialRules :: CF -> String -specialRules cf = unlines $ - map aux (literals cf) - where - aux cat = - case cat of - "Ident" -> "ident : TOK_Ident { Ident $1 };" - "String" -> "string : TOK_String { $1 };" - "Integer" -> "int : TOK_Integer { $1 };" - "Double" -> "float : TOK_Double { $1 };" - "Char" -> "char : TOK_Char { $1 };" - own -> (fixType own) ++ " : TOK_" ++ own ++ - " { " ++ own ++ " ("++ posn ++ "$1)};" - -- PCC: take "own" as type name? (manual says newtype) - where -- ignore position categories for now - posn = "" -- if isPositionCat cf cat then "mkPosToken " else "" - - - diff --git a/formats/ocaml/OCamlTop.hs b/formats/ocaml/OCamlTop.hs deleted file mode 100644 --- a/formats/ocaml/OCamlTop.hs +++ /dev/null @@ -1,208 +0,0 @@ -{- - BNF Converter: OCaml main file - Copyright (C) 2005 Author: Kristofer Johannisson - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - --- based on BNFC Haskell backend - - -module OCamlTop (makeOCaml) where - -import CF -import CFtoOCamlYacc -import CFtoOCamlLex -import CFtoLatex -import CFtoOCamlAbs -import CFtoOCamlTemplate -import CFtoOCamlPrinter -import CFtoOCamlShow -import CFtoOCamlTest -import CFtoXML -import GetCF -import Utils - -import Data.Char -import Data.Maybe (fromMaybe,maybe) -import System.IO -import System.Exit -import Control.Monad(when) - --- naming conventions - -noLang :: Options -> String -> String -noLang _ name = name - -withLang :: Options -> String -> String -withLang opts name = name ++ lang opts - -mkMod :: (Options -> String -> String) -> String -> Options -> String -mkMod addLang name opts = - pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name - where pref = maybe "" (++".") (inPackage opts) - -mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath -mkFile addLang name ext opts = - pref ++ if inDir opts - then lang opts ++ [pathSep] ++ name ++ ext' - else addLang opts name ++ if null ext then "" else ext' - where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts) - ext' = if null ext then "" else "." ++ ext - -absFile, absFileM, ocamllexFile, ocamllexFileM, dviFile, - ocamlyaccFile, ocamlyaccFileM, - latexFile, utilFile, utilFileM, - templateFile, templateFileM, - printerFile, printerFileM, - psFile, tFile, tFileM :: Options -> String -absFile = mkFile withLang "Abs" "ml" -absFileM = mkMod withLang "Abs" -ocamllexFile = mkFile withLang "Lex" "mll" -ocamllexFileM = mkMod withLang "Lex" -ocamlyaccFile = mkFile withLang "Par" "mly" -ocamlyaccFileM = mkMod withLang "Par" -latexFile = mkFile withLang "Doc" "tex" -templateFile = mkFile withLang "Skel" "ml" -templateFileM = mkMod withLang "Skel" -printerFile = mkFile withLang "Print" "ml" -printerFileM = mkMod withLang "Print" -showFile = mkFile withLang "Show" "ml" -showFileM = mkMod withLang "Show" -dviFile = mkFile withLang "Doc" "dvi" -psFile = mkFile withLang "Doc" "ps" -tFile = mkFile withLang "Test" "ml" -tFileM = mkMod withLang "Test" -utilFile = mkFile noLang "BNFC_Util" "ml" -utilFileM = mkMod noLang "BNFC_Util" -xmlFileM = mkMod withLang "XML" - -data Options = Options - { - make :: Bool, - alex1 :: Bool, - inDir :: Bool, - shareStrings :: Bool, - xml :: Int, - inPackage :: Maybe String, - lang :: String - } - --- FIXME: we probably don't need all these arguments -makeOCaml :: Bool -> Bool -> Bool -> Bool -> Bool -> Int - -> Maybe String -- ^ The hierarchical package to put the modules - -- in, or Nothing. - -> String -> FilePath -> IO () -makeOCaml m a1 d ss g x p n file = do - let opts = Options { make = m, alex1 = a1, inDir = d, shareStrings = ss, - xml = x, inPackage = p, lang = n } - - absMod = absFileM opts - lexMod = ocamllexFileM opts - parMod = ocamlyaccFileM opts - prMod = printerFileM opts - showMod = showFileM opts --- layMod = layoutFileM opts - utilMod = utilFileM opts - (cf, isOK) <- tryReadCF file - if isOK then do - let dir = codeDir opts - when (not (null dir)) $ do - putStrLn $ "Creating directory " ++ dir - prepareDir dir - writeFileRep (absFile opts) $ cf2Abstract absMod cf - writeFileRep (ocamllexFile opts) $ cf2ocamllex lexMod parMod cf - writeFileRep (ocamlyaccFile opts) $ - cf2ocamlyacc parMod absMod lexMod cf - writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf - writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod cf - writeFileRep (printerFile opts) $ cf2Printer prMod absMod cf - writeFileRep (showFile opts) $ cf2show showMod absMod cf - writeFileRep (tFile opts) $ ocamlTestfile absMod lexMod parMod prMod showMod cf - writeFileRep (utilFile opts) $ utilM - when (make opts) $ writeFileRep "Makefile" $ makefile opts - case xml opts of - 2 -> makeXML (lang opts) True cf - 1 -> makeXML (lang opts) False cf - _ -> return () - putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -pkgToDir :: String -> FilePath -pkgToDir s = replace '.' pathSep s - -codeDir :: Options -> FilePath -codeDir opts = let pref = maybe "" pkgToDir (inPackage opts) - dir = if inDir opts then lang opts else "" - sep = if null pref || null dir then "" else [pathSep] - in pref ++ sep ++ dir - -makefile :: Options -> String -makefile opts = makeA where - dir = let d = codeDir opts in if null d then "" else d ++ [pathSep] - cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")" - makeA = unlines - [ - "all:", - "\tocamlyacc " ++ ocamlyaccFile opts, - "\tocamllex " ++ ocamllexFile opts, - "\t" ++ cd ("latex " ++ basename (latexFile opts) - ++ "; " ++ "dvips " ++ basename (dviFile opts) - ++ " -o " ++ basename (psFile opts)), - "\tocamlc -o " ++ mkFile withLang "Test" "" opts +++ - utilFile opts +++ - absFile opts +++ templateFile opts +++ - showFile opts +++ printerFile opts +++ - mkFile withLang "Par" "mli" opts +++ - mkFile withLang "Par" "ml" opts +++ - mkFile withLang "Lex" "ml" opts +++ - tFile opts, - "", - "clean:", - "\t-rm -f " ++ unwords (map (dir++) [ - "*.log", "*.aux", "*.cmi", - "*.cmo", "*.o", "*.dvi" - ]), - "\t-rm -f " ++ psFile opts, - "", - "distclean: clean", - "\t-rm -f " ++ unwords [ - mkFile withLang "Doc" "*" opts, - mkFile withLang "Lex" "*" opts, - mkFile withLang "Par" "*" opts, - mkFile withLang "Layout" "*" opts, - mkFile withLang "Skel" "*" opts, - mkFile withLang "Print" "*" opts, - mkFile withLang "Show" "*" opts, - mkFile withLang "Test" "*" opts, - mkFile withLang "Abs" "*" opts, - mkFile withLang "Test" "" opts, - utilFile opts, - "Makefile*" - ] - ] - - -utilM :: String -utilM = unlines - ["(* automatically generated by BNFC *)", - "", - "open Lexing", - "", - "(* this should really be in the parser, but ocamlyacc won't put it in the .mli *)", - "exception Parse_error of Lexing.position * Lexing.position" - ] - diff --git a/formats/ocaml/OCamlTop.hs~ b/formats/ocaml/OCamlTop.hs~ deleted file mode 100644 --- a/formats/ocaml/OCamlTop.hs~ +++ /dev/null @@ -1,207 +0,0 @@ -{- - BNF Converter: OCaml main file - Copyright (C) 2005 Author: Kristofer Johannisson - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - --- based on BNFC Haskell backend - - -module OCamlTop (makeOCaml) where - -import CF -import CFtoOCamlYacc -import CFtoOCamlLex -import CFtoLatex -import CFtoOCamlAbs -import CFtoOCamlTemplate -import CFtoOCamlPrinter -import CFtoOCamlShow -import CFtoOCamlTest -import CFtoXML -import GetCF -import Utils - -import Data.Char -import Data.Maybe (fromMaybe,maybe) -import System.IO -import Control.Monad(when) - --- naming conventions - -noLang :: Options -> String -> String -noLang _ name = name - -withLang :: Options -> String -> String -withLang opts name = name ++ lang opts - -mkMod :: (Options -> String -> String) -> String -> Options -> String -mkMod addLang name opts = - pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name - where pref = maybe "" (++".") (inPackage opts) - -mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath -mkFile addLang name ext opts = - pref ++ if inDir opts - then lang opts ++ [pathSep] ++ name ++ ext' - else addLang opts name ++ if null ext then "" else ext' - where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts) - ext' = if null ext then "" else "." ++ ext - -absFile, absFileM, ocamllexFile, ocamllexFileM, dviFile, - ocamlyaccFile, ocamlyaccFileM, - latexFile, utilFile, utilFileM, - templateFile, templateFileM, - printerFile, printerFileM, - psFile, tFile, tFileM :: Options -> String -absFile = mkFile withLang "Abs" "ml" -absFileM = mkMod withLang "Abs" -ocamllexFile = mkFile withLang "Lex" "mll" -ocamllexFileM = mkMod withLang "Lex" -ocamlyaccFile = mkFile withLang "Par" "mly" -ocamlyaccFileM = mkMod withLang "Par" -latexFile = mkFile withLang "Doc" "tex" -templateFile = mkFile withLang "Skel" "ml" -templateFileM = mkMod withLang "Skel" -printerFile = mkFile withLang "Print" "ml" -printerFileM = mkMod withLang "Print" -showFile = mkFile withLang "Show" "ml" -showFileM = mkMod withLang "Show" -dviFile = mkFile withLang "Doc" "dvi" -psFile = mkFile withLang "Doc" "ps" -tFile = mkFile withLang "Test" "ml" -tFileM = mkMod withLang "Test" -utilFile = mkFile noLang "BNFC_Util" "ml" -utilFileM = mkMod noLang "BNFC_Util" -xmlFileM = mkMod withLang "XML" - -data Options = Options - { - make :: Bool, - alex1 :: Bool, - inDir :: Bool, - shareStrings :: Bool, - xml :: Int, - inPackage :: Maybe String, - lang :: String - } - --- FIXME: we probably don't need all these arguments -makeOCaml :: Bool -> Bool -> Bool -> Bool -> Bool -> Int - -> Maybe String -- ^ The hierarchical package to put the modules - -- in, or Nothing. - -> String -> FilePath -> IO () -makeOCaml m a1 d ss g x p n file = do - let opts = Options { make = m, alex1 = a1, inDir = d, shareStrings = ss, - xml = x, inPackage = p, lang = n } - - absMod = absFileM opts - lexMod = ocamllexFileM opts - parMod = ocamlyaccFileM opts - prMod = printerFileM opts - showMod = showFileM opts --- layMod = layoutFileM opts - utilMod = utilFileM opts - (cf, isOK) <- tryReadCF file - if isOK then do - let dir = codeDir opts - when (not (null dir)) $ do - putStrLn $ "Creating directory " ++ dir - prepareDir dir - writeFileRep (absFile opts) $ cf2Abstract absMod cf - writeFileRep (ocamllexFile opts) $ cf2ocamllex lexMod parMod cf - writeFileRep (ocamlyaccFile opts) $ - cf2ocamlyacc parMod absMod lexMod cf - writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf - writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod cf - writeFileRep (printerFile opts) $ cf2Printer prMod absMod cf - writeFileRep (showFile opts) $ cf2show showMod absMod cf - writeFileRep (tFile opts) $ ocamlTestfile absMod lexMod parMod prMod showMod cf - writeFileRep (utilFile opts) $ utilM - when (make opts) $ writeFileRep "Makefile" $ makefile opts - case xml opts of - 2 -> makeXML (lang opts) True cf - 1 -> makeXML (lang opts) False cf - _ -> return () - putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -pkgToDir :: String -> FilePath -pkgToDir s = replace '.' pathSep s - -codeDir :: Options -> FilePath -codeDir opts = let pref = maybe "" pkgToDir (inPackage opts) - dir = if inDir opts then lang opts else "" - sep = if null pref || null dir then "" else [pathSep] - in pref ++ sep ++ dir - -makefile :: Options -> String -makefile opts = makeA where - dir = let d = codeDir opts in if null d then "" else d ++ [pathSep] - cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")" - makeA = unlines - [ - "all:", - "\tocamlyacc " ++ ocamlyaccFile opts, - "\tocamllex " ++ ocamllexFile opts, - "\t" ++ cd ("latex " ++ basename (latexFile opts) - ++ "; " ++ "dvips " ++ basename (dviFile opts) - ++ " -o " ++ basename (psFile opts)), - "\tocamlc -o " ++ mkFile withLang "Test" "" opts +++ - utilFile opts +++ - absFile opts +++ templateFile opts +++ - showFile opts +++ printerFile opts +++ - mkFile withLang "Par" "mli" opts +++ - mkFile withLang "Par" "ml" opts +++ - mkFile withLang "Lex" "ml" opts +++ - tFile opts, - "", - "clean:", - "\t-rm -f " ++ unwords (map (dir++) [ - "*.log", "*.aux", "*.cmi", - "*.cmo", "*.o", "*.dvi" - ]), - "\t-rm -f " ++ psFile opts, - "", - "distclean: clean", - "\t-rm -f " ++ unwords [ - mkFile withLang "Doc" "*" opts, - mkFile withLang "Lex" "*" opts, - mkFile withLang "Par" "*" opts, - mkFile withLang "Layout" "*" opts, - mkFile withLang "Skel" "*" opts, - mkFile withLang "Print" "*" opts, - mkFile withLang "Show" "*" opts, - mkFile withLang "Test" "*" opts, - mkFile withLang "Abs" "*" opts, - mkFile withLang "Test" "" opts, - utilFile opts, - "Makefile*" - ] - ] - - -utilM :: String -utilM = unlines - ["(* automatically generated by BNFC *)", - "", - "open Lexing", - "", - "(* this should really be in the parser, but ocamlyacc won't put it in the .mli *)", - "exception Parse_error of Lexing.position * Lexing.position" - ] - diff --git a/formats/ocaml/OCamlUtil.hs b/formats/ocaml/OCamlUtil.hs deleted file mode 100644 --- a/formats/ocaml/OCamlUtil.hs +++ /dev/null @@ -1,71 +0,0 @@ -{- - BNF Converter: OCaml backend utility module - Copyright (C) 2005 Author: Kristofer Johannisson - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module OCamlUtil where - -import CF -import Utils -import Data.Char (toLower, toUpper) - --- Translate Haskell types to OCaml types --- Note: OCaml (data-)types start with lowercase letter -fixType :: Cat -> String -fixType s = case s of - '[':xs -> case break (== ']') xs of - (t,"]") -> fixType t +++ "list" - _ -> s -- should not occur (this means an invariant of the type Cat is broken) - "Integer" -> "int" - "Double" -> "float" - c:cs -> toLower c : cs - _ -> s - --- as fixType, but leave first character in upper case -fixTypeUpper :: Cat -> String -fixTypeUpper c = case fixType c of - [] -> [] - c:cs -> toUpper c : cs - - -reservedOCaml :: [String] -reservedOCaml = [ - "and","as","assert","asr","begin","class", - "constraint","do","done","downto","else","end", - "exception","external","false","for","fun","function", - "functor","if","in","include","inherit","initializer", - "land","lazy","let","lor","lsl","lsr", - "lxor","match","method","mod","module","mutable", - "new","object","of","open","or","private", - "rec","sig","struct","then","to","true", - "try","type","val","virtual","when","while","with"] - -mkTuple :: [String] -> String -mkTuple [] = "" -mkTuple [x] = x -mkTuple (x:xs) = "(" ++ foldl (\acc e -> acc ++ "," +++ e) x xs ++ ")" - -insertBar :: [String] -> [String] -insertBar [] = [] -insertBar [x] = [" " ++ x] -insertBar (x:xs) = (" " ++ x ) : map (" | " ++) xs - -mutualDefs :: [String] -> [String] -mutualDefs defs = case defs of - [] -> [] - [d] -> ["let rec" +++ d] - d:ds -> ("let rec" +++ d) : map ("and" +++) ds diff --git a/formats/profile/CFtoHappyProfile.hs b/formats/profile/CFtoHappyProfile.hs deleted file mode 100644 --- a/formats/profile/CFtoHappyProfile.hs +++ /dev/null @@ -1,223 +0,0 @@ -{- - BNF Converter: Happy Generator - Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoHappyProfile - ( - cf2HappyProfileS - ) - where - -import CF ---import Lexer -import Data.List (intersperse) -import Data.Char - --- Type declarations - -type Rules = [(NonTerminal,[(Pattern,Action)])] -type NonTerminal = String -type Pattern = String -type Action = String -type MetaVar = String - --- default naming - -moduleName = "HappyParser" -tokenName = "Token" - --- The main function, that given a CF and a CFCat to parse according to, --- generates a happy module. -cf2HappyProfileS :: String -> String -> String -> String -> CFP -> String -cf2HappyProfileS = cf2Happy - -cf2Happy :: String -> String -> String -> String -> CFP -> String -cf2Happy name absName lexName errName cf - = unlines - [header name absName lexName errName, - declarations (allEntryPointsP cf), - tokens (symbols cf ++ reservedWords cf), - specialToks cf, - delimiter, - specialRules cf, - prRules (rulesForHappy cf), - finalize cf] - --- construct the header. -header :: String -> String -> String -> String -> String -header modName absName lexName errName = unlines - ["-- This Happy file was machine-generated by the BNF converter", - "{", - "module " ++ modName ++ " where", ----- "import " ++ absName, - "import Trees", - "import " ++ lexName, - "import " ++ errName, - "}" - ] - - --- The declarations of a happy file. -declarations :: [NonTerminal] -> String -declarations ns = unlines - [generateP ns, - "%monad { Err } { thenM } { returnM }", - "%tokentype { " ++ tokenName ++ " }"] - where generateP [] = [] - generateP (n:ns) = concat ["%name p",n'," ",n',"\n",generateP ns] - where n' = identCat n - --- The useless delimiter symbol. -delimiter :: String -delimiter = "\n%%\n" - --- Generate the list of tokens and their identifiers. -tokens :: [String] -> String -tokens toks = "%token \n" ++ prTokens toks - where prTokens [] = [] - prTokens (t:tk) = " " ++ (convert t) ++ - " { " ++ oneTok t ++ " }\n" ++ - prTokens tk - oneTok t = "PT _ (TS " ++ show t ++ ")" - --- Happy doesn't allow characters such as åäö to occur in the happy file. This --- is however not a restriction, just a naming paradigm in the happy source file. -convert :: String -> String -convert "\\" = concat ['\'':"\\\\","\'"] -convert xs = concat ['\'':(escape xs),"\'"] - where escape [] = [] - escape ('\'':xs) = '\\':'\'':escape xs - escape (x:xs) = x:escape xs - -rulesForHappy :: CFP -> Rules -rulesForHappy cf = map mkOne $ ruleGroupsP cf where - mkOne (cat,rules) = constructRule cf rules cat - --- For every non-terminal, we construct a set of rules. A rule is a sequence of --- terminals and non-terminals, and an action to be performed --- As an optimization, a pair of list rules [C] ::= "" | C k [C] --- is left-recursivized into [C] ::= "" | [C] C k. --- This could be generalized to cover other forms of list rules. -constructRule :: CFP -> [RuleP] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) -constructRule cf rules nt = (nt,[(p,generateAction nt (revF b r) m) | - r0 <- rules, - let (b,r) = if isConsFun (funRuleP r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0), - let (p,m) = generatePatterns cf r]) - where - ---- left rec optimization does not work yet - revF b r = ---- if b then ("flip " ++ funRuleP r) else (funRuleP r) - fst r - revs = reversibleCats cf - --- Generates a string containing the semantic action. --- An action can for example be: Sum $1 $2, that is, construct an AST --- with the constructor Sum applied to the two metavariables $1 and $2. -generateAction :: NonTerminal -> FunP -> [MetaVar] -> Action -generateAction nt f@(_,(h,p)) ms = unwords $ (if isCoercion h then args else (fun ++ mss)) - where - fun = ["mkFunTree",show h,show p] - mss = ["["] ++ intersperse "," ms ++ ["]"] - args = intersperse "," ms - --- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal - -generatePatterns :: CFP -> RuleP -> (Pattern,[MetaVar]) -generatePatterns cf r = case rhsRule r of - [] -> ("{- empty -}",[]) - its -> (unwords (map mkIt its), metas its) - where - mkIt i = case i of - Left c -> identCat c - Right s -> convert s - metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its] - revIf c m = if (not (isConsFun (funRuleP r)) && elem c revs) - then ("(reverse " ++ m ++ ")") - else m -- no reversal in the left-recursive Cons rule itself - revs = reversibleCats cf - --- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string. - -prRules :: Rules -> String -prRules = unlines . map prOne - where - prOne (nt,[]) = [] -- nt has only internal use - prOne (nt,((p,a):ls)) = - unwords [nt', "::", "{", "CFTree", "}\n" ++ - nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ "\n" - where - nt' = identCat nt - pr [] = [] - pr ((p,a):ls) = - unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls - --- Finally, some haskell code. - -finalize :: CFP -> String -finalize cf = unlines - [ - "{", - "\nreturnM :: a -> Err a", - "returnM = return", - "\nthenM :: Err a -> (a -> Err b) -> Err b", - "thenM = (>>=)", - "\nhappyError :: [" ++ tokenName ++ "] -> Err a", - "happyError ts =", - " Bad $ \"syntax error at \" ++ tokenPos ts ++ " ++ - "if null ts then [] else " ++ - "(\" before \" ++ " ++ "unwords (map prToken (take 4 ts)))", - "\nmyLexer = tokens", - "}" - ] - --- aarne's modifs 8/1/2002: --- Markus's modifs 11/02/2002 - --- GF literals -specialToks :: CFP -> String -specialToks cf = unlines $ - (map aux (literals cf)) - ++ ["L_err { _ }"] - where aux cat = - case cat of - "Ident" -> "L_ident { PT _ (TV $$) }" - "String" -> "L_quoted { PT _ (TL $$) }" - "Integer" -> "L_integ { PT _ (TI $$) }" - "Double" -> "L_doubl { PT _ (TD $$) }" - "Char" -> "L_charac { PT _ (TC $$) }" - own -> "L_" ++ own ++ " { PT _ (T_" ++ own ++ " " ++ posn ++ ") }" - where - posn = if isPositionCat cf cat then "_" else "$$" - -specialRules :: CFP -> String -specialRules cf = unlines $ - map aux (literals cf) - where - aux cat = - case cat of - "Ident" -> "Ident : L_ident { mkAtTree (AV (Ident $1)) }" - "String" -> "String : L_quoted { mkAtTree (AS $1) }" - "Integer" -> "Integer : L_integ { mkAtTree (AI ((read $1) :: Integer)) }" - "Double" -> "Double : L_doubl { (read $1) :: Double }" ---- - "Char" -> "Char : L_charac { (read $1) :: Char }" ---- - own -> own ++ " : L_" ++ own ++ " { " ++ own ++ " ("++ posn ++ "$1)}" - where - posn = if isPositionCat cf cat then "mkPosToken " else "" diff --git a/formats/profile/ProfileTop.hs b/formats/profile/ProfileTop.hs deleted file mode 100644 --- a/formats/profile/ProfileTop.hs +++ /dev/null @@ -1,235 +0,0 @@ -{- - BNF Converter: Haskell main file - Copyright (C) 2004 Author: Markus Forberg, Peter Gammie, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module ProfileTop (makeAllProfile) where - --- import Utils -import CF -import CFtoHappyProfile -import CFtoAlex -import CFtoAlex2 -import CFtoLatex -import MkErrM ----- import CFtoAbstract ----- import CFtoTemplate ----- import CFtoPrinter ----- import CFtoLayout ----- import CFtoXML --- import CFtoGF ( cf2AbsGF, cf2ConcGF ) --- import System.IO -import GetCF -import Utils - -import Data.Char -import System.IO -import System.Exit -import Control.Monad(when) - --- naming conventions - -nameMod :: String -> Bool -> String -> FilePath -nameMod name inDir lang = - if inDir - then lang ++ "." ++ name - else name ++ lang - -nameFile :: String -> String -> Bool -> String -> FilePath -nameFile name ext inDir lang = - if inDir - then lang ++ "/" ++ name ++ "." ++ ext - else name ++ lang ++ "." ++ ext - -absFile, absFileM, alexFile, alexFileM, dviFile, - gfAbs, gfConc, - happyFile, happyFileM, - latexFile, errFile, errFileM, - templateFile, templateFileM, - printerFile, printerFileM, - layoutFile, layoutFileM, - psFile, tFile, tFileM, mFile :: Bool -> String -> FilePath -absFile = nameFile "Abs" "hs" -absFileM = nameMod "Abs" -alexFile = nameFile "Lex" "x" -alexFileM = nameMod "Lex" -happyFile = nameFile "Par" "y" -happyFileM = nameMod "Par" -latexFile = nameFile "Doc" "tex" -templateFile = nameFile "Skel" "hs" -templateFileM = nameMod "Skel" -printerFile = nameFile "Print" "hs" -printerFileM = nameMod "Print" -dviFile = nameFile "Doc" "dvi" -psFile = nameFile "Doc" "ps" -gfAbs = nameFile "" "Abs.gf" -gfConc = nameFile "" "Conc.gf" -tFile = nameFile "Test" "hs" -tFileM = nameMod "Test" -mFile inDir n = if inDir then n ++ "/" ++ "Makefile" else "Makefile" -errFile b n = if b then n ++ "/" ++ "ErrM.hs" else "ErrM.hs" -errFileM b n = if b then n ++ "." ++ "ErrM" else "ErrM" -layoutFileM = nameMod "Layout" -xmlFileM = nameMod "XML" -layoutFile = nameFile "Layout" "hs" - -makeAllProfile :: Bool -> Bool -> Bool -> Int -> String -> FilePath -> IO () -makeAllProfile make alex1 inDir xml name file = do - let absMod = absFileM inDir name - lexMod = alexFileM inDir name - parMod = happyFileM inDir name - prMod = printerFileM inDir name - layMod = layoutFileM inDir name - tplMod = templateFileM inDir name - errMod = errFileM inDir name - (cfp, isOK) <- tryReadCFP file - let cf = cfp2cf cfp - if isOK then do - - when inDir (prepareDir name) ----- writeFileRep (absFile inDir name) $ cf2Abstract (absFileM inDir name) cf - if (alex1) then do - writeFileRep (alexFile inDir name) $ cf2alex lexMod errMod cf - putStrLn " (Use Alex 1.1 to compile.)" - else do - writeFileRep (alexFile inDir name) $ cf2alex2 lexMod errMod "" False False cf - putStrLn " (Use Alex 2.0 to compile.)" - writeFileRep (happyFile inDir name) $ - cf2HappyProfileS parMod absMod lexMod errMod cfp - putStrLn " (Tested with Happy 1.13)" - writeFileRep (latexFile inDir name) $ cfToLatex name cf ----- writeFileRep (templateFile inDir name) $ ----- cf2Template tplMod absMod errMod cf ----- writeFileRep (printerFile inDir name) $ cf2Printer prMod absMod cf ----- if hasLayout cf then ----- writeFileRep (layoutFile inDir name) $ cf2Layout alex1 inDir layMod lexMod cf ----- else return () - writeFileRep (tFile inDir name) $ testfile inDir name (xml>0) cf - writeFileRep (errFile inDir name) $ errM errMod cf - if make - then (writeFileRep (mFile inDir name) $ makefile inDir name) - else return () ----- case xml of ----- 2 -> makeXML name True cf ----- 1 -> makeXML name False cf ----- _ -> return () ----- putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -makefile :: Bool -> String -> String -makefile inDir name = makeA where - name' = if inDir then "" else name -- Makefile is inDir - ghcCommand = "ghc --make "++ tFile inDir name ++ " -o " ++ - if inDir then name ++ "/" ++ "Test" else "Test" ++ name - makeA = unlines - [ - "all:", - "\thappy -gca " ++ happyFile False name', - "\talex " ++ alexFile False name', - "\tlatex " ++ latexFile False name', - "\tdvips " ++ dviFile False name' ++ " -o " ++ psFile False name', - "\t" ++ if inDir then - "(" ++ "cd ..; " ++ ghcCommand ++ ")" - else ghcCommand, - "clean:", - "\t rm -f " ++ unwords [ - "*.log *.aux *.hi *.o *.dvi", - psFile False name', - "*.o" - ], - "distclean: " ++ if inDir then "" else "clean", - if inDir then - "\t rm -rf ../" ++ name -- erase this directory! - else - "\t rm -f " ++ unwords [ - "Doc" ++ name ++ ".*", - "Lex" ++ name ++ ".*", - "Par" ++ name ++ ".*", ----- "Layout" ++ name ++ ".*", ----- "Skel" ++ name ++ ".*", ----- "Print" ++ name ++ ".*", - "Test" ++ name ++ ".*", ----- "Abs" ++ name ++ ".*", - "Test" ++ name, - "ErrM.*", ----- name ++ ".dtd", ----- "XML" ++ name ++ ".*", - "Makefile*" - ] - ] - - -testfile :: Bool -> String -> Bool -> CF -> String -testfile inDir name xml cf = makeA where - - makeA = let lay = hasLayout cf - xpr = if xml then "XPrint a, " else "" - in unlines - ["-- automatically generated by BNF Converter", - "module Main where\n", - "", - "import Trees", - "import Profile", - "import System.IO ( stdin, hGetContents )", - "import System.IO ( getArgs, getProgName )", - "", - "import " ++ alexFileM inDir name, - "import " ++ happyFileM inDir name, ----- "import " ++ templateFileM inDir name, ----- "import " ++ printerFileM inDir name, ----- "import " ++ absFileM inDir name, ----- if lay then ("import " ++ layoutFileM inDir name) else "", ----- if xml then ("import " ++ xmlFileM inDir name) else "", - "import " ++ errFileM inDir name, - "", - "type ParseFun = [Token] -> Err CFTree", - "", - "myLLexer = " ++ if lay then "resolveLayout True . myLexer" - else "myLexer", - "", - "runFile :: ParseFun -> FilePath -> IO ()", - "runFile p f = readFile f >>= run p", - "", - "run :: ParseFun -> String -> IO ()", - "run p s = do", - " let ts = myLLexer s", - " let etree = p ts", - " case etree of", - " Ok tree -> do", - " case postParse tree of", - " Bad s -> do", - " putStrLn \"\\nParse Failed... CFTree:\\n\"", - " putStrLn $ prCFTree tree", - " putStrLn s", - " Ok tree -> do", - " putStrLn \"\\nParse Successful!\"", - " putStrLn $ \"\\n[Abstract Syntax]\\n\\n\" ++ prt tree", - " Bad s -> do", - " putStrLn s", - " putStrLn \"\\nParse failed... tokenization:\"", - " print ts", - "", - "main :: IO ()", - "main = do args <- getArgs", - " case args of", - " [] -> hGetContents stdin >>= run " ++ firstParser, - " [f] -> runFile " ++ firstParser ++ " f", - " _ -> do progName <- getProgName", - " putStrLn $ progName ++ \": excess arguments.\"" - ] - where firstParser = 'p' : firstEntry cf diff --git a/formats/profile/ProfileTop.hs~ b/formats/profile/ProfileTop.hs~ deleted file mode 100644 --- a/formats/profile/ProfileTop.hs~ +++ /dev/null @@ -1,234 +0,0 @@ -{- - BNF Converter: Haskell main file - Copyright (C) 2004 Author: Markus Forberg, Peter Gammie, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module ProfileTop (makeAllProfile) where - --- import Utils -import CF -import CFtoHappyProfile -import CFtoAlex -import CFtoAlex2 -import CFtoLatex -import MkErrM ----- import CFtoAbstract ----- import CFtoTemplate ----- import CFtoPrinter ----- import CFtoLayout ----- import CFtoXML --- import CFtoGF ( cf2AbsGF, cf2ConcGF ) --- import System.IO -import GetCF -import Utils - -import Data.Char -import System.IO -import Control.Monad(when) - --- naming conventions - -nameMod :: String -> Bool -> String -> FilePath -nameMod name inDir lang = - if inDir - then lang ++ "." ++ name - else name ++ lang - -nameFile :: String -> String -> Bool -> String -> FilePath -nameFile name ext inDir lang = - if inDir - then lang ++ "/" ++ name ++ "." ++ ext - else name ++ lang ++ "." ++ ext - -absFile, absFileM, alexFile, alexFileM, dviFile, - gfAbs, gfConc, - happyFile, happyFileM, - latexFile, errFile, errFileM, - templateFile, templateFileM, - printerFile, printerFileM, - layoutFile, layoutFileM, - psFile, tFile, tFileM, mFile :: Bool -> String -> FilePath -absFile = nameFile "Abs" "hs" -absFileM = nameMod "Abs" -alexFile = nameFile "Lex" "x" -alexFileM = nameMod "Lex" -happyFile = nameFile "Par" "y" -happyFileM = nameMod "Par" -latexFile = nameFile "Doc" "tex" -templateFile = nameFile "Skel" "hs" -templateFileM = nameMod "Skel" -printerFile = nameFile "Print" "hs" -printerFileM = nameMod "Print" -dviFile = nameFile "Doc" "dvi" -psFile = nameFile "Doc" "ps" -gfAbs = nameFile "" "Abs.gf" -gfConc = nameFile "" "Conc.gf" -tFile = nameFile "Test" "hs" -tFileM = nameMod "Test" -mFile inDir n = if inDir then n ++ "/" ++ "Makefile" else "Makefile" -errFile b n = if b then n ++ "/" ++ "ErrM.hs" else "ErrM.hs" -errFileM b n = if b then n ++ "." ++ "ErrM" else "ErrM" -layoutFileM = nameMod "Layout" -xmlFileM = nameMod "XML" -layoutFile = nameFile "Layout" "hs" - -makeAllProfile :: Bool -> Bool -> Bool -> Int -> String -> FilePath -> IO () -makeAllProfile make alex1 inDir xml name file = do - let absMod = absFileM inDir name - lexMod = alexFileM inDir name - parMod = happyFileM inDir name - prMod = printerFileM inDir name - layMod = layoutFileM inDir name - tplMod = templateFileM inDir name - errMod = errFileM inDir name - (cfp, isOK) <- tryReadCFP file - let cf = cfp2cf cfp - if isOK then do - - when inDir (prepareDir name) ----- writeFileRep (absFile inDir name) $ cf2Abstract (absFileM inDir name) cf - if (alex1) then do - writeFileRep (alexFile inDir name) $ cf2alex lexMod errMod cf - putStrLn " (Use Alex 1.1 to compile.)" - else do - writeFileRep (alexFile inDir name) $ cf2alex2 lexMod errMod "" False False cf - putStrLn " (Use Alex 2.0 to compile.)" - writeFileRep (happyFile inDir name) $ - cf2HappyProfileS parMod absMod lexMod errMod cfp - putStrLn " (Tested with Happy 1.13)" - writeFileRep (latexFile inDir name) $ cfToLatex name cf ----- writeFileRep (templateFile inDir name) $ ----- cf2Template tplMod absMod errMod cf ----- writeFileRep (printerFile inDir name) $ cf2Printer prMod absMod cf ----- if hasLayout cf then ----- writeFileRep (layoutFile inDir name) $ cf2Layout alex1 inDir layMod lexMod cf ----- else return () - writeFileRep (tFile inDir name) $ testfile inDir name (xml>0) cf - writeFileRep (errFile inDir name) $ errM errMod cf - if make - then (writeFileRep (mFile inDir name) $ makefile inDir name) - else return () ----- case xml of ----- 2 -> makeXML name True cf ----- 1 -> makeXML name False cf ----- _ -> return () ----- putStrLn $ "Done!" - else do putStrLn $ "Failed!" - exitFailure - -makefile :: Bool -> String -> String -makefile inDir name = makeA where - name' = if inDir then "" else name -- Makefile is inDir - ghcCommand = "ghc --make "++ tFile inDir name ++ " -o " ++ - if inDir then name ++ "/" ++ "Test" else "Test" ++ name - makeA = unlines - [ - "all:", - "\thappy -gca " ++ happyFile False name', - "\talex " ++ alexFile False name', - "\tlatex " ++ latexFile False name', - "\tdvips " ++ dviFile False name' ++ " -o " ++ psFile False name', - "\t" ++ if inDir then - "(" ++ "cd ..; " ++ ghcCommand ++ ")" - else ghcCommand, - "clean:", - "\t rm -f " ++ unwords [ - "*.log *.aux *.hi *.o *.dvi", - psFile False name', - "*.o" - ], - "distclean: " ++ if inDir then "" else "clean", - if inDir then - "\t rm -rf ../" ++ name -- erase this directory! - else - "\t rm -f " ++ unwords [ - "Doc" ++ name ++ ".*", - "Lex" ++ name ++ ".*", - "Par" ++ name ++ ".*", ----- "Layout" ++ name ++ ".*", ----- "Skel" ++ name ++ ".*", ----- "Print" ++ name ++ ".*", - "Test" ++ name ++ ".*", ----- "Abs" ++ name ++ ".*", - "Test" ++ name, - "ErrM.*", ----- name ++ ".dtd", ----- "XML" ++ name ++ ".*", - "Makefile*" - ] - ] - - -testfile :: Bool -> String -> Bool -> CF -> String -testfile inDir name xml cf = makeA where - - makeA = let lay = hasLayout cf - xpr = if xml then "XPrint a, " else "" - in unlines - ["-- automatically generated by BNF Converter", - "module Main where\n", - "", - "import Trees", - "import Profile", - "import System.IO ( stdin, hGetContents )", - "import System.IO ( getArgs, getProgName )", - "", - "import " ++ alexFileM inDir name, - "import " ++ happyFileM inDir name, ----- "import " ++ templateFileM inDir name, ----- "import " ++ printerFileM inDir name, ----- "import " ++ absFileM inDir name, ----- if lay then ("import " ++ layoutFileM inDir name) else "", ----- if xml then ("import " ++ xmlFileM inDir name) else "", - "import " ++ errFileM inDir name, - "", - "type ParseFun = [Token] -> Err CFTree", - "", - "myLLexer = " ++ if lay then "resolveLayout True . myLexer" - else "myLexer", - "", - "runFile :: ParseFun -> FilePath -> IO ()", - "runFile p f = readFile f >>= run p", - "", - "run :: ParseFun -> String -> IO ()", - "run p s = do", - " let ts = myLLexer s", - " let etree = p ts", - " case etree of", - " Ok tree -> do", - " case postParse tree of", - " Bad s -> do", - " putStrLn \"\\nParse Failed... CFTree:\\n\"", - " putStrLn $ prCFTree tree", - " putStrLn s", - " Ok tree -> do", - " putStrLn \"\\nParse Successful!\"", - " putStrLn $ \"\\n[Abstract Syntax]\\n\\n\" ++ prt tree", - " Bad s -> do", - " putStrLn s", - " putStrLn \"\\nParse failed... tokenization:\"", - " print ts", - "", - "main :: IO ()", - "main = do args <- getArgs", - " case args of", - " [] -> hGetContents stdin >>= run " ++ firstParser, - " [f] -> runFile " ++ firstParser ++ " f", - " _ -> do progName <- getProgName", - " putStrLn $ progName ++ \": excess arguments.\"" - ] - where firstParser = 'p' : firstEntry cf diff --git a/formats/xml/CFtoXML.hs b/formats/xml/CFtoXML.hs deleted file mode 100644 --- a/formats/xml/CFtoXML.hs +++ /dev/null @@ -1,217 +0,0 @@ -{- - BNF Converter: XML generator - Copyright (C) 2004 Author: Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoXML ---- (cf2DTD, cf2XML) - where - -import CF -import GetCF (writeFileRep) -import Utils -import CFtoTemplate -import Data.List (intersperse, nub) -import Data.Char(toLower) - -type Coding = Bool ---- change to at least three values - -makeXML :: FilePath -> Coding -> CF -> IO () -makeXML name typ cf = do - writeFileRep (name ++ ".dtd") $ cf2DTD typ name cf - let absmod = "XML" ++ name - writeFileRep (absmod ++ ".hs") $ cf2XMLPrinter typ name absmod cf - --- derive a DTD from a BNF grammar. AR 21/8/2004 -cf2DTD :: Coding -> String -> CF -> String -cf2DTD typ name cf = unlines [ - tag ("?xml version=\"1.0\" standalone=\"yes\"?"), - "" - ] - -tag s = "<" ++ s ++ ">" -element t ts = - tag ("!ELEMENT " ++ t ++ " " ++ alts ts) -attlist t a = - tag ("!ATTLIST " ++ t ++ " " ++ a ++ " CDATA #REQUIRED") -elemAtt t a ts = element t ts ++++ attlist t a -elemt t = elemAtt t "name" -elemc cat fs = unlines $ element cat (map snd fs) : [element f [] | (f,_) <- fs] -elemEmp t = elemAtt t "value" [] -alts ts = - if null ts then "EMPTY" else parenth (unwords (intersperse "|" ts)) - - --- choose between these two encodings: - -elemData b = if b then elemDataConstr else elemDataNotyp -efunDef b = if b then efunDefConstr else efunDefNotyp -endtagDef b = if b then endtagDefConstr else endtagDefNotyp - --- coding 0: ---- not finished --- to show both types and constructors as tags; --- lengthy, but validation guarantees type correctness --- flag -xmlt -elemDataConstrs cf (cat,fcs) = elemc cat ([(f,rhsCat cf (f:cs)) | (f,cs) <- fcs]) -efunDefConstrs = "elemFun i t x = [replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]" -endtagDefConstrs = "endtag f c = tag (\"/\" ++ c)" - --- coding 1: --- to show constructors as empty tags; --- shorter than 0, but validation still guarantees type correctness --- flag -xmlt -elemDataConstr cf (cat,fcs) = elemc cat ([(f,rhsCat cf (f:cs)) | (f,cs) <- fcs]) -efunDefConstr = "elemFun i t x = [replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]" -endtagDefConstr = "endtag f c = tag (\"/\" ++ c)" - --- coding 2: --- constructors as tags, no types. --- clumsy DTD, but nice trees. Validation guarantees type correctness --- flag -xml -elemDataNotyp cf (cat,fcs) = unlines [element f [rhsCatNot cf cs] | (f,cs) <- fcs] -efunDefNotyp = "elemFun i t x = [replicate (i+i) ' ' ++ tag x]" -endtagDefNotyp = "endtag f c = tag (\"/\" ++ f)" - - --- to show constructors as attributes; --- nice, but validation does not guarantee type correctness. --- Therefore rejected. --- elemDataAttr cf (cat,fcs) = elemt cat (nub [rhsCat cf cs | (_,cs) <- fcs]) --- efunDefAttr = "elemFun i t x = [replicate (i+i) ' ' ++ tag (t ++ \" name = \" ++ x)]" - - -rhsCat cf cs = parenth (concat (intersperse ", " (map (symbCat cf) cs))) -rhsCatNot cf cs = if null cs then "EMPTY" else concat (intersperse ", " (map (symbCatNot cf) cs)) - -symbCat cf c - | isList c = normCatOfList c ++ if isEmptyListCat cf c then "*" else "+" - | otherwise = c - -symbCatNot cf c - | isList c = funs (normCatOfList c) ++ if isEmptyListCat cf c then "*" else "+" - | otherwise = funs c - where - funs k = case lookup k (cf2data cf) of - Just [] -> "EMPTY" - Just fcs -> parenth $ unwords $ intersperse "|" $ map fst fcs - _ -> parenth k ---- - -parenth s = "(" ++ s ++ ")" - --- derive an XML printer from a BNF grammar -cf2XMLPrinter :: Bool -> String -> String -> CF -> String -cf2XMLPrinter typ name absMod cf = unlines [ - prologue typ name absMod, - integerRule cf, - doubleRule cf, - stringRule cf, - if hasIdent cf then identRule cf else "", - unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf], - rules cf - ] - - -prologue :: Bool -> String -> String -> String -prologue b name absMod = unlines [ - "module " ++ absMod +++ "where\n", - "-- pretty-printer generated by the BNF converter\n", - "import Abs" ++ name, - "import Data.Char", - "", - "-- the top-level printing method", - "printXML :: XPrint a => a -> String", - "printXML = render . prt 0", - "", - "render = unlines", - "", - "-- the printer class does the job", - "class XPrint a where", - " prt :: Int -> a -> [String]", - " prtList :: Int -> [a] -> [String]", - " prtList i = concat . map (prt i)", - "", - "instance XPrint a => XPrint [a] where", - " prt = prtList", - "", - "tag t = \"<\" ++ t ++ \">\"", - "etag t = \"<\" ++ t ++ \"/>\"", - "elemTok i t x = [replicate (i+i) ' ' ++ tag (t ++ \" value = \" ++ show x ++ \" /\")]", - "elemTokS i t x = elemTok i t (show x)", - efunDef b, - endtagDef b, - "" - ] - -integerRule cf = showsPrintRule cf "Integer" -doubleRule cf = showsPrintRule cf "Double" -stringRule cf = showsPrintRule cf "Char" ++++ " prtList i xs = elemTok i \"String\" xs" - -showsPrintRule cf t = unlines $ [ - "instance XPrint " ++ t ++ " where", - " prt i x = elemTokS i" +++ "\"" ++ t ++ "\"" +++ "x" - ] - -identRule cf = ownPrintRule cf "Ident" - -ownPrintRule cf t = unlines $ [ - "instance XPrint " ++ t ++ " where", - " prt i (" ++ t ++ posn ++ ") = elemTok i" +++ "\"" ++ t ++ "\"" +++ "x" - ] - where - posn = if isPositionCat cf t then " (_,x)" else " x" - -rules :: CF -> String -rules cf = unlines $ - map (\(s,xs) -> case_fun s (map toArgs xs)) $ cf2data cf - where - toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons) - names [] _ = [] - names (x:xs) n - | elem x xs = (x ++ show n) : names xs (n+1) - | otherwise = x : names xs n - var ('[':xs) = var (init xs) ++ "s" - var "Ident" = "id" - var "Integer" = "n" - var "String" = "str" - var "Char" = "c" - var "Double" = "d" - var xs = map toLower xs - checkRes s - | elem s reservedHaskell = s ++ "'" - | otherwise = s - reservedHaskell = ["case","class","data","default","deriving","do","else","if", - "import","in","infix","infixl","infixr","instance","let","module", - "newtype","of","then","type","where","as","qualified","hiding"] - ruleOf s = maybe undefined id $ lookup s (rulesOfCF cf) - ---- case_fun :: Cat -> [(Constructor,Rule)] -> String -case_fun cat xs = unlines [ - "instance XPrint" +++ cat +++ "where", - " prt i" +++ "e = case e of", - unlines $ map (\ ((c,xx),r) -> - " " ++ c +++ unwords xx +++ "-> concat $ " +++ - "elemFun i \"" ++ cat ++ "\" \"" ++ c ++ "\"" +++ - unwords [": prt (i+1)" +++ x | x <- xx] +++ ":" +++ - "[[replicate (i+i) ' ' ++ endtag \"" ++ c ++ "\" \"" ++ cat ++ "\"]]" - ) xs - ] diff --git a/runtime/Algebra/RingUtils.hs b/runtime/Algebra/RingUtils.hs new file mode 100644 --- /dev/null +++ b/runtime/Algebra/RingUtils.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Algebra.RingUtils + ( module Prelude + , AbelianGroup(..) + , AbelianGroupZ(..) + , Ring(..) + , RingP(..) + , Pair(..), select, onlyLeft, onlyRight + , O(..) + , sum + , mulDefault + , module Data.Pair + ) + where + +import qualified Prelude as P +import Prelude hiding ( (+), (*), splitAt, sum ) +import Control.Applicative +import Data.Pair + +class AbelianGroup a where + zero :: a + (+) :: a -> a -> a + +instance AbelianGroup Int where + zero = 0 + (+) = (P.+) + +class AbelianGroup a => AbelianGroupZ a where + isZero :: a -> Bool + +instance AbelianGroupZ Int where + isZero x = x == 0 + +class AbelianGroupZ a => Ring a where + (*) :: a -> a -> a + +class (AbelianGroupZ a) => RingP a where + mul :: Bool -> a -> a -> Pair a +-- mul _ x y = pure $ x * y + +mulDefault x y = leftOf (mul False x y) + +onlyLeft x = x :/: [] +onlyRight x = [] :/: x + +select p = if p then onlyRight else onlyLeft + +newtype O f g a = O {fromO :: f (g a)} + deriving (AbelianGroup, AbelianGroupZ, Show) + +instance (Functor f,Functor g) => Functor (O f g) where + fmap f (O x) = O (fmap (fmap f) x) + +instance AbelianGroup a => AbelianGroup (Pair a) where + zero = (zero:/:zero) + (a:/:b) + (x:/:y) = (a+x) :/: (b+y) + +instance AbelianGroupZ a => AbelianGroupZ (Pair a) where + isZero (a:/:b) = isZero a && isZero b + +instance Ring Int where + (*) = (P.*) + +infixl 7 * +infixl 6 + + +sum :: AbelianGroup a => [a] -> a +sum = foldr (+) zero + +instance AbelianGroup Bool where + zero = False + (+) = (||) diff --git a/runtime/Data/Matrix/Class.hs b/runtime/Data/Matrix/Class.hs new file mode 100644 --- /dev/null +++ b/runtime/Data/Matrix/Class.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Data.Matrix.Class where + +import Prelude () +import Algebra.RingUtils +import Control.Applicative hiding ((<|>)) + + +fingerprint m = [[ if isZero (at i j m) then ' ' else 'X' | i <- [0..x-1] ] | j <- [0..y-1]] + where x = countColumns m + y = countRows m + +(f *** g) (x,y) = (f x,g y) + +data Dimension + = XD + | YD + deriving (Eq,Show) + +quad a b c d = (a <|> b) <-> (c <|> d) + + +nextDim XD = YD +nextDim YD = XD + +type Extent = (Int,Int) + +ext XD (x,y) = x +ext YD (x,y) = y + +glueExt XD (x1,y1) (x2,y2) = (x1+x2,y1) +glueExt YD (x1,y1) (x2,y2) = (x1,y1+y2) + +splitExt XD k (x,y) = ((k,y),(x-k,y)) +splitExt YD k (x,y) = ((x,k),(x,y-k)) + +class Matrix m where + at :: AbelianGroupZ a => Int -> Int -> m a -> a + extent :: m a -> Extent + -- | Sigleton matrix + singleton :: AbelianGroupZ a => a -> m a + glue :: AbelianGroup a => Dimension -> m a -> m a -> m a + split :: AbelianGroupZ a => Dimension -> Int -> m a -> (m a, m a) + zeroMatrix :: AbelianGroup a => Int -> Int -> m a + +instance Matrix m => Matrix (O Pair m) where + at i j (O (x :/: y)) = at i j x + at i j y + extent (O (x :/: y)) = extent x -- union with y + glue d (O p) (O q) = O $ glue d <$> p <*> q + split d k (O (x :/: y)) = (O $ ax :/: ay, O $ bx :/: by) + where (ax,bx) = split d k x + (ay,by) = split d k y + zeroMatrix x y = O $ pure (zeroMatrix x y) + singleton x = O $ pure (singleton x) -- Attention: on both sides always! + + +(<|>) :: (AbelianGroup a, Matrix m) => m a -> m a -> m a +(<|>) = glue XD + +(<->) :: (AbelianGroup a, Matrix m) => m a -> m a -> m a +(<->) = glue YD + +countColumns, countRows :: Matrix m => m a -> Int +countColumns = ext XD . extent +countRows = ext YD . extent + +chopLastColumn, chopFirstRow, chopFirstColumn, chopLastRow, lastColumn, firstRow :: (AbelianGroupZ a, Matrix m) => m a -> m a +chopFirstRow = snd . split YD 1 +chopFirstColumn = snd . split XD 1 +chopLastColumn x = fst . split XD (countColumns x - 1) $ x +firstRow = fst . split YD 1 +lastColumn x = snd . split XD (countColumns x - 1) $ x + +chopLastRow x = fst . split YD (countRows x - 1) $ x + + + + + + diff --git a/runtime/Data/Matrix/Quad.hs b/runtime/Data/Matrix/Quad.hs new file mode 100644 --- /dev/null +++ b/runtime/Data/Matrix/Quad.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE GADTs, DataKinds, ScopedTypeVariables, KindSignatures #-} + +module Data.Matrix.Quad where + +import Prelude () +import Data.List (splitAt,intercalate) +import Control.Applicative +import Algebra.RingUtils hiding (O,concat) +import Data.Traversable +import Data.Foldable + +data Shape = Bin Shape Shape | Leaf + +data Shape' :: Shape -> * where + Bin' :: !Int -> Shape' s -> Shape' s' -> Shape' (Bin s s') + Leaf' :: Shape' Leaf + +data SomeShape where + S :: Shape' s -> SomeShape + +data Mat :: Shape -> Shape -> * -> * where + Quad :: !(Mat x1 y1 a) -> !(Mat x2 y1 a) -> + !(Mat x1 y2 a) -> !(Mat x2 y2 a) -> + Mat (Bin x1 x2) (Bin y1 y2) a + Zero :: Mat x y a + One :: !a -> Mat Leaf Leaf a + Row :: Mat x1 Leaf a -> Mat x2 Leaf a -> Mat (Bin x1 x2) Leaf a + Col :: Mat Leaf y1 a -> Mat Leaf y2 a -> Mat Leaf (Bin y1 y2) a + +data Vec :: Shape -> * -> * where + Z :: Vec s a + O :: a -> Vec Leaf a + (:!) :: Vec s a -> Vec s' a -> Vec (Bin s s') a + + +row Zero Zero = Zero +row x y = Row x y + +col :: Mat Leaf y1 a -> Mat Leaf y2 a -> Mat Leaf (Bin y1 y2) a +col Zero Zero = Zero +col x y = Col x y + +quad Zero Zero Zero Zero = Zero +quad a b c d = Quad a b c d + +one :: AbelianGroupZ a => a -> Mat Leaf Leaf a +one x | isZero x = Zero + | otherwise = One x + +(.+.) :: AbelianGroupZ a => Mat x y a -> Mat x y a -> Mat x y a +Zero .+. x = x +x .+. Zero = x +Quad a b c d .+. Quad a' b' c' d' = quad (a .+. a') (b .+. b') (c .+. c') (d .+. d') +One x .+. One x' = one (x + x') +Row x y .+. Row x' y' = row (x .+. x') (y .+. y') +Col x y .+. Col x' y' = col (x .+. x') (y .+. y') + +instance AbelianGroupZ a => AbelianGroup (Mat x y a) where + (+) = (.+.) + zero = Zero + +mult :: RingP a => Bool -> Mat x y a -> Mat z x a -> Mat z y (Pair a) +mult p a b = a & b where + infixl 7 & + (&) :: RingP a => Mat x y a -> Mat z x a -> Mat z y (Pair a) + Zero & x = Zero + x & Zero = Zero + One x & One x' = one (mul p x x') + One x & Row a b = row (One x & a) (One x & b) + Col a b & One x = col (a & One x) (b & One x) + Row a b & Col a' b' = a & a' + b & b' + Col a b & Row a' b' = quad (a & a') (a & b') (b & a') (b & b') + Row a b & Quad a' b' c' d' = row (a & a' + b & c') (a & b' + b & d') + Quad a b c d & Col a' c' = col (a & a' + b & c') (c & a' + d & c') + Quad a b c d & Quad a' b' c' d' = + quad (a & a' + b & c') (a & b' + b & d') + (c & a' + d & c') (c & b' + d & d') + + x & y = error $ "mult:" ++ intercalate "; " [showR x,showR y] + +-- a variant of traverse. The constraint prevents to just use traverse. +trav :: AbelianGroupZ a => Mat y x (Pair a) -> Pair (Mat y x a) +trav Zero = pure Zero +trav (Quad a b c d) = quad <$> trav a <*> trav b <*> trav c <*> trav d +trav (One x) = one <$> x +trav (Col a b) = col <$> trav a <*> trav b +trav (Row a b) = row <$> trav a <*> trav b + +q0 :: Mat (Bin x x') (Bin y y') a +q0 = Quad Zero Zero Zero Zero + +closeDisjointP :: RingP a => Bool -> Mat x x a -> Mat y x (Pair a) -> Mat y y a -> Pair (Mat y x a) +closeDisjointP p l c r = close l c r + where close :: RingP a => Mat x x a -> Mat y x (Pair a) -> Mat y y a -> Pair (Mat y x a) + close l Zero r = Zero :/: Zero + close Zero x Zero = trav x -- if x = One x', we are in this case + close (Quad a11 a12 Zero a22) (Quad c11 c12 c21 c22) (Quad b11 b12 Zero b22) = quad <$> x11 <*> x12 <*> x21 <*> x22 + where x21 = close a22 c21 b11 + x11 = close a11 (a12 & rightOf x21 + c11) b11 + x22 = close a22 (leftOf x21 & b12 + c22) b22 + x12 = close a11 (a12 & rightOf x22 + leftOf x11 & b12 + c12) b22 + close Zero (Quad c11 c12 c21 c22) (Quad b11 b12 Zero b22) = close q0 (Quad c11 c12 c21 c22) (Quad b11 b12 Zero b22) + close (Quad a11 a12 Zero a22) (Quad c11 c12 c21 c22) Zero = close (Quad a11 a12 Zero a22) (Quad c11 c12 c21 c22) q0 + close (Quad a11 a12 Zero a22) (Col c1 c2) (Zero) = col <$> x1 <*> x2 + where x2 = close a22 c2 Zero + x1 = close a11 (mult p a12 (rightOf x2) + c1) Zero + close Zero (Row c1 c2) (Quad b11 b12 Zero b22) = row <$> x1 <*> x2 + where x1 = close Zero c1 b11 + x2 = close Zero (mult p (leftOf x1) b12 + c2) b22 + close a c b = error $ "closeDisjointP:" ++ intercalate "; " [showR a,showR c,showR b] + (&) :: RingP a => Mat x y a -> Mat z x a -> Mat z y (Pair a) + (&) = mult p + +showR :: Mat x y a -> String +showR Zero = "0" +showR (One _) = "1" +showR (Row a b) = "("++showR a++"-"++showR b++")" +showR (Col a b) = "("++showR a++"|"++showR b++")" +showR (Quad a b c d) = "#("++ intercalate "," [showR a,showR b,showR c,showR d]++")" + +bin' :: Shape' s -> Shape' s' -> Shape' (Bin s s') +bin' s s' = Bin' (sz' s + sz' s') s s' + +mkShape :: Int -> SomeShape +mkShape 1 = S (bin' Leaf' Leaf') +mkShape 2 = S (bin' (bin' Leaf' Leaf') Leaf') +mkShape n = case (mkShape n'1, mkShape n'2) of + (S x, S y) -> S (bin' x y) + where n'1 = n `div` 2 + n'2 = n - n'1 - 1 + +mkSing :: AbelianGroupZ a => Shape' x -> Shape' y -> a -> Mat x y a +mkSing (Bin' _ x1 x2) (Bin' _ y1 y2) a = quad Zero Zero (mkSing x1 y2 a) Zero +mkSing Leaf' Leaf' a = one a +mkSing Leaf' (Bin' _ y1 y2) a = col Zero (mkSing Leaf' y2 a) +mkSing (Bin' _ x1 x2) Leaf' a = row (mkSing x1 Leaf' a) Zero + +data SomeTri a where + T :: Shape' s -> Pair (Mat s s a) -> SomeTri a + +type Q a = SomeTri a + +mkUpDiag :: AbelianGroupZ a => [a] -> Shape' s -> Mat s s a +mkUpDiag [] Leaf' = Zero +mkUpDiag xs (Bin' _ s s') = Quad (mkUpDiag a s) (mkSing s' s c) Zero (mkUpDiag b s') + where (a,c:b) = splitAt (sz' s - 1) xs + +close :: RingP a => Bool -> Mat s s (Pair a) -> Pair (Mat s s a) +close p Zero = zero +close p (One x) = one <$> x +close p (Quad a11 a12 Zero a22) = quad' x11 (closeDisjointP p (leftOf x11) a12 (rightOf x22)) zero x22 + where x11 = close (not p) a11 + x22 = close (not p) a22 + +mkTree :: RingP a => [Pair a] -> SomeTri a +mkTree xs = case mkShape (length xs) of + S s -> T s (close True $ mkUpDiag xs s) + +quad' a b c d = quad <$> a <*> b <*> c <*> d + +mergein :: RingP a => Bool -> SomeTri a -> Pair a -> SomeTri a -> SomeTri a +mergein p (T y a) c (T x b) = T (bin' y x) (quad' a (closeDisjointP p (leftOf a) c' (rightOf b)) zero b) + where c' = mkSing x y c + +-- | A variant of zipWith on vectors +zw :: (AbelianGroup a, AbelianGroup b) => (a -> b -> c) -> Vec y a -> Vec y b -> Vec y c +zw f Z Z = Z +zw f Z (a :! b) = zw f (Z :! Z) (a :! b) +zw f (a :! b) Z = zw f (a :! b) (Z :! Z) +zw f Z (O x) = O $ f zero x +zw f (O x) Z = O $ f x zero +zw f (O x) (O y) = O (f x y) +zw f (a :! b) (a' :! b') = zw f a a' :! zw f b b' + +-- | Lookup in a vector +lk :: AbelianGroup a => Int -> Shape' x -> Vec x a -> a +lk n _ Z = zero +lk 0 Leaf' (O x) = x +lk i (Bin' _ s s') (x :! x') + | i < sz' s = lk i s x + | otherwise = lk (i - sz' s) s' x' + +-- | Linearize a matrix +lin' :: AbelianGroup a => Mat x y a -> Vec y (Vec x a) +lin' Zero = Z +lin' (One a) = O (O a) +lin' (Row a b) = zw (:!) (lin' a) (lin' b) +lin' (Col a b) = lin' a :! lin' b +lin' (Quad a b c d) = zw (:!) (lin' a) (lin' b) :!zw (:!) (lin' c) (lin' d) + +-- | Contents of a vector +contents :: Shape' x -> Vec x a -> [(Int,a)] +contents s Z = [] +contents s (O a) = [(0,a)] +contents (Bin' _ s s') (xs :! xs') = contents s xs ++ map (first (+sz' s)) (contents s' xs') + + +first f (a,b) = (f a,b) +second f (a,b) = (a,f b) + +instance AbelianGroup a => AbelianGroup (Vec x a) where + zero = Z + (+) = zw (+) + +data Path :: Shape -> * where + Here :: Path Leaf + Low :: Path s -> Path (Bin s s') + High :: Path s -> Path (Bin s' s) + +(<||>) :: Maybe (a,Path x) -> Maybe (a,Path x') -> Maybe (a,Path (Bin x x')) +x <||> y = (second High <$> y) <|> (second Low <$> x) + +-- | What is, and where is the rightmost non-zero element on a given +-- line of the matrix? +rightmostOnLine :: Path y -> Mat x y a -> Maybe (a,Path x) +rightmostOnLine _ Zero = Nothing +rightmostOnLine Here (One x) = Just (x,Here) +rightmostOnLine Here (Row a b) = rightmostOnLine Here a <||> rightmostOnLine Here b +rightmostOnLine (Low p) (Col a b) = rightmostOnLine p a +rightmostOnLine (High p) (Col a b) = rightmostOnLine p b +rightmostOnLine (Low p) (Quad a b _ _) = rightmostOnLine p a <||> rightmostOnLine p b +rightmostOnLine (High p) (Quad _ _ a b) = rightmostOnLine p a <||> rightmostOnLine p b + +-- | Is this the rightmost path? +isRightmost :: Path x -> Bool +isRightmost (Low _) = False +isRightmost (Here) = True +isRightmost (High x) = isRightmost x + +results' :: AbelianGroup a => Mat y y a -> Path y -> [(Path y, a, Path y)] +results' m y | isRightmost y = [] + | otherwise = (y,a,x) : results' m x + where Just (a,x) = rightmostOnLine y m + +results :: AbelianGroupZ a => SomeTri a -> [(Int, a, Int)] +results (T s (m :/: m')) = [(fromPath s x,a,fromPath s y) | (x,a,y) <- results' (m+m') (leftMost s)] + +leftMost :: Shape' s -> Path s +leftMost Leaf' = Here +leftMost (Bin' _ s _) = Low $ leftMost s + +fromPath :: Shape' y -> Path y -> Int +fromPath _ Here = 0 +fromPath (Bin' _ s s') (Low x) = fromPath s x +fromPath (Bin' _ s s') (High x) = sz' s + fromPath s' x + + +root' :: AbelianGroup a => Mat x y a -> a +root' Zero = zero +root' (One x) = x +root' (Quad _ a _ _) = root' a +root' (Col a _) = root' a +root' (Row _ a) = root' a + +root (T _ (m :/: m')) = root' m + root' m' + +single x = T Leaf' (one <$> x) + +square2 x = T (bin' Leaf' Leaf') $ quad' zero (one <$> x) zero zero + +square3 p x y = T (bin' (bin' Leaf' Leaf') (Leaf')) + (quad' (quad' zero (one <$> x) zero zero) (Col <$> (one <$> mul p (leftOf x) (rightOf y)) <*> (one <$> y)) zero zero) + + +sz' :: Shape' s -> Int +sz' Leaf' = 1 +sz' (Bin' x l r) = x -- sz' l + sz' r + + +(|+|) = zipWith (++) +(-+-) = (++) + +-- TODO: reimplement using lin' +lin :: AbelianGroup a => Shape' x -> Shape' y -> Mat x y a -> [[a]] +lin x y Zero = replicate (sz' y) $ replicate (sz' x) zero +lin _ _ (One x) = [[x]] +lin (Bin' _ x x') (Bin' _ y y') (Quad a b c d) = (lin x y a |+| lin x' y b) -+- (lin x y' c |+| lin x' y' d) +lin Leaf' (Bin' _ y y') (Col a b) = lin Leaf' y a -+- lin Leaf' y' b +lin (Bin' _ x x') Leaf' (Row a b) = (lin x Leaf' a) |+| (lin x' Leaf' b) + +sparse :: AbelianGroup a => Shape' x -> Shape' y -> Mat x y a -> [(Int,Int,a)] +sparse x y Zero = [] +sparse _ _ (One x) = [(0,0,x)] +sparse (Bin' _ x x') (Bin' _ y y') (Quad a b c d) = sparse x y a ++ shiftX x (sparse x' y b) ++ shiftY y (sparse x y' c) ++ shiftX x (shiftY y(sparse x' y' d)) +sparse Leaf' (Bin' _ y y') (Col a b) = sparse Leaf' y a ++ shiftY y (sparse Leaf' y' b) +sparse (Bin' _ x x') Leaf' (Row a b) = sparse x Leaf' a ++ shiftX x (sparse x' Leaf' b) + +shiftX x0 as = [(x+sz' x0,y,a) | (x,y,a) <- as] +shiftY y0 as = [(x,y+sz' y0,a) | (x,y,a) <- as] + +fingerprint (T s (m :/: m')) = zipWith (zipWith c) (lin s s m) (lin s s m') + where c x y = case (isZero x,isZero y) of + (True , True) -> ' ' + (True , False) -> '>' + (False , True) -> '<' + (False , False) -> 'X' + +scatterplot (T s (m :/: m')) = concat [show x ++ " " ++ show y ++ "\n" | (x,y,_) <- sparse s s m ++ sparse s s m'] + diff --git a/runtime/Parsing/Chart.hs b/runtime/Parsing/Chart.hs new file mode 100644 --- /dev/null +++ b/runtime/Parsing/Chart.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoMonomorphismRestriction, TypeSynonymInstances, FlexibleInstances #-} + +module Parsing.Chart where + +import Data.Array +import Data.Maybe +import Prelude () +import Data.Traversable (sequenceA) +import Control.Applicative ((<$>),(<*>),pure) +import Control.Monad(join) + +import Data.List (splitAt) +import Algebra.RingUtils +import qualified Data.Matrix.Quad as Q +import Data.Matrix.Class + +fingerprint = Q.fingerprint + +{- +mkTreeHelp alt s = sweeps (map single s) + where + sweeps [] = error "can't parse the empty string, sorry" + sweeps [p] = p + sweeps ps = sweeps (pairs ps alts) + + pairs [] _ = [] + pairs [p] _ = [p] + pairs (p:q:ps) (b:bs) = (merging b p q) : pairs ps bs + + alts = cycle alt + -} + +-- mkTree2 :: (AbelianGroupZ (c a), RingP a, IsChart c) => Bool -> [Pair a] -> c a +mkTree2 :: RingP a => Bool -> [Pair a] -> Q.Q a +mkTree2 p [] = error "can't parse the empty string, sorry" +mkTree2 p [x] = Q.square2 x +mkTree2 p [x,y] = Q.square3 p x y +mkTree2 p leaves = Q.mergein p (mkTree2 False xs) y (mkTree2 True zs) + where (xs,y:zs) = splitAt n2 leaves + n2 = length leaves `div` 2 + + +-- mkTree :: (RingP a, IsChart c) => [Pair a] -> c a +mkTree = mkTree2 False -- mkTreeHelp [False,True] +mkTree' = mkTree2 True -- mkTreeHelp [True,False] + + +type Set a = [a] + +-- Sets form an abelian group +instance AbelianGroup (Set a) where + zero = [] + (+) = (++) + +instance AbelianGroupZ (Set a) where + isZero = null + +type MT2 a = Q.Q a + +genXPM xs@(h:_) = unlines $ + ["! XPM2", + -- + show width ++ " " ++ show height ++ " 4 1", + "X c cyan", + "< c blue", + "> c red", + " c black" + ] ++ + xs + where width = length h + height = length xs + +root = Q.root +mergein a c b = Q.mergein a c b +single x = Q.single x + diff --git a/runtime/Parsing/TestProgram.hs b/runtime/Parsing/TestProgram.hs new file mode 100644 --- /dev/null +++ b/runtime/Parsing/TestProgram.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} +module Parsing.TestProgram where + +import System.IO ( stdin, hGetContents ) +import System.Environment ( getArgs, getProgName ) + +import GHC.Exts +import Control.Monad +import Control.Applicative (pure) +import Parsing.Chart hiding (fingerprint,mkTree) +import Data.Matrix.Quad +import Data.Pair +import Algebra.RingUtils + +type Verbosity = Int + +putStrV :: Verbosity -> String -> IO () +putStrV v s = if v > 1 then putStrLn s else return () + + +mainTest :: forall category token. + (RingP [(category,Any)], Eq category) => + ((category,Any) -> String) -> + (Bool -> token -> Pair [(category,Any)]) -> + (String -> [token]) -> + (token -> (Int,Int)) -> + (category -> String) -> + (category -> [category]) -> + IO () +mainTest showAst cnfToksToCat myLLexer getTokPos describe follows = + do args <- getArgs + case args of + [] -> hGetContents stdin >>= run "stdin" 2 + "-s":fs -> mapM_ (runFile 0) fs + fs -> mapM_ (runFile 2) fs + + where + neighbors a b = b `elem` follows a + showResults :: [(category,Any)] -> IO () + showResults x = do + putStrLn $ show (length x) ++ " results" + forM_ x $ \(cat,ast) -> do + putStrLn $ describe cat + putStrLn $ showAst (cat,ast) + + runFile v f = putStrLn f >> readFile f >>= run f v + run f v s = + do case rs of + [(_,x,_)] -> showResults x + _ -> do let errs = pairs rs + best = minimum $ map quality errs + mapM_ (putStrLn . showErr ts) $ filter (\x -> quality x == best) errs + when (v >= 2) $ do + writeFile (f ++ ".xpm") (genXPM $ fingerprint chart) + let scatt = scatterplot chart + putStrLn $ "Scatterplot data size:" ++ show (length scatt) + writeFile (f ++ ".data") scatt + where ts = myLLexer s + chart = mkTree $ zipWith cnfToksToCat (cycle [False,True]) ts + rs = results chart + + showTokPos :: (Int,Int) -> String + showTokPos (l,c) = show l ++ "," ++ show (c-1) + + showPos :: [token] -> Int -> String + showPos ts x = showTokPos (getTokPos $ ts !! x) + + showErr ts ((_,x',p),(_,y',_)) = + showPos ts p ++ ": cannot combine " ++ showBestCat x' ++ " with " ++ showBestCat y' + + quality (a@(_,x',p),b@(_,y',_)) = (or [ neighbors x y | x <- map fst x', y <- map fst y'], + (resSz a) Prelude.+ (resSz b)) + + + showBestCat ((x,_):_) = describe x + +pairs (x:y:xs) = (x,y):pairs (y:xs) +pairs _ = [] + +resSz (i,_,j) = j-i + + + + diff --git a/src/AbsBNF.hs b/src/AbsBNF.hs new file mode 100644 --- /dev/null +++ b/src/AbsBNF.hs @@ -0,0 +1,120 @@ +module AbsBNF where + +-- Haskell module generated by the BNF converter + + +newtype Ident = Ident String deriving (Eq,Ord,Show) +data LGrammar = + LGr [LDef] + deriving (Eq,Ord,Show) + +data LDef = + DefAll Def + | DefSome [Ident] Def + | LDefView [Ident] + deriving (Eq,Ord,Show) + +data Grammar = + Grammar [Def] + deriving (Eq,Ord,Show) + +data Def = + Rule Label Cat [Item] + | Comment String + | Comments String String + | Internal Label Cat [Item] + | Token Ident Reg + | PosToken Ident Reg + | Entryp [Ident] + | Separator MinimumSize Cat String + | Terminator MinimumSize Cat String + | Delimiters Cat String String Separation MinimumSize + | Coercions Ident Integer + | Rules Ident [RHS] + | Function Ident [Arg] Exp + | Layout [String] + | LayoutStop [String] + | LayoutTop + deriving (Eq,Ord,Show) + +data Item = + Terminal String + | NTerminal Cat + deriving (Eq,Ord,Show) + +data Cat = + ListCat Cat + | IdCat Ident + deriving (Eq,Ord,Show) + +data Label = + LabNoP LabelId + | LabP LabelId [ProfItem] + | LabPF LabelId LabelId [ProfItem] + | LabF LabelId LabelId + deriving (Eq,Ord,Show) + +data LabelId = + Id Ident + | Wild + | ListE + | ListCons + | ListOne + deriving (Eq,Ord,Show) + +data ProfItem = + ProfIt [IntList] [Integer] + deriving (Eq,Ord,Show) + +data IntList = + Ints [Integer] + deriving (Eq,Ord,Show) + +data Separation = + SepNone + | SepTerm String + | SepSepar String + deriving (Eq,Ord,Show) + +data Arg = + Arg Ident + deriving (Eq,Ord,Show) + +data Exp = + Cons Exp Exp + | App Ident [Exp] + | Var Ident + | LitInt Integer + | LitChar Char + | LitString String + | LitDouble Double + | List [Exp] + deriving (Eq,Ord,Show) + +data RHS = + RHS [Item] + deriving (Eq,Ord,Show) + +data MinimumSize = + MNonempty + | MEmpty + deriving (Eq,Ord,Show) + +data Reg = + RSeq Reg Reg + | RAlt Reg Reg + | RMinus Reg Reg + | RStar Reg + | RPlus Reg + | ROpt Reg + | REps + | RChar Char + | RAlts String + | RSeqs String + | RDigit + | RLetter + | RUpper + | RLower + | RAny + deriving (Eq,Ord,Show) + diff --git a/src/BNF.cf b/src/BNF.cf new file mode 100644 --- /dev/null +++ b/src/BNF.cf @@ -0,0 +1,153 @@ +{- + BNF Converter: Language definition + Copyright (C) 2004 Author: Markus Forberg, Michael Pellauer, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- A Grammar is a sequence of definitions + +LGr. LGrammar ::= [LDef] ; + +DefAll. LDef ::= Def ; +DefSome. LDef ::= [Ident] ":" Def ; +LDefView. LDef ::= "views" [Ident] ; + +separator LDef ";" ; + +Grammar . Grammar ::= [Def] ; + +separator Def ";" ; + +[] . [Item] ::= ; +(:) . [Item] ::= Item [Item] ; + +--The rules of the grammar +Rule . Def ::= Label "." Cat "::=" [Item] ; + +-- Items +Terminal . Item ::= String ; +NTerminal . Item ::= Cat ; + +-- Categories +ListCat . Cat ::= "[" Cat "]" ; +IdCat . Cat ::= Ident ; + +-- labels with or without profiles +LabNoP . Label ::= LabelId ; +LabP . Label ::= LabelId [ProfItem] ; +LabPF . Label ::= LabelId LabelId [ProfItem] ; +LabF . Label ::= LabelId LabelId ; + +-- functional labels +Id . LabelId ::= Ident ; +Wild . LabelId ::= "_" ; +ListE . LabelId ::= "[" "]" ; +ListCons . LabelId ::= "(" ":" ")" ; +ListOne . LabelId ::= "(" ":" "[" "]" ")" ; + +-- profiles (= permutation and binding patterns) +ProfIt . ProfItem ::= "(" "[" [IntList] "]" "," "[" [Integer] "]" ")" ; + +Ints . IntList ::= "[" [Integer] "]" ; + +separator Integer "," ; +separator IntList "," ; +terminator nonempty ProfItem "" ; + +-- Pragmas +Comment . Def ::= "comment" String ; +Comments . Def ::= "comment" String String ; +Internal . Def ::= "internal" Label "." Cat "::=" [Item] ; +Token. Def ::= "token" Ident Reg ; +PosToken. Def ::= "position" "token" Ident Reg ; +Entryp. Def ::= "entrypoints" [Ident] ; +Separator. Def ::= "separator" MinimumSize Cat String ; +Terminator. Def ::= "terminator" MinimumSize Cat String ; +Delimiters. Def ::= "delimiters" Cat String String Separation MinimumSize; +Coercions. Def ::= "coercions" Ident Integer ; +Rules. Def ::= "rules" Ident "::=" [RHS] ; +Function. Def ::= "define" Ident [Arg] "=" Exp ; + +SepNone. Separation ::= ; +SepTerm. Separation ::= "terminator" String; +SepSepar. Separation ::= "separator" String; + +Layout. Def ::= "layout" [String] ; +LayoutStop. Def ::= "layout" "stop" [String] ; +LayoutTop. Def ::= "layout" "toplevel" ; + +Arg. Arg ::= Ident ; +separator Arg "" ; + +-- Expressions +Cons. Exp ::= Exp1 ":" Exp ; +App. Exp1 ::= Ident [Exp2] ; +Var. Exp2 ::= Ident ; +LitInt. Exp2 ::= Integer ; +LitChar. Exp2 ::= Char ; +LitString. Exp2 ::= String ; +LitDouble. Exp2 ::= Double ; +List. Exp2 ::= "[" [Exp] "]" ; + + +coercions Exp 2; +separator nonempty Exp2 "" ; +separator Exp "," ; + +separator nonempty String "," ; + +separator nonempty RHS "|" ; +RHS. RHS ::= [Item] ; + +-- List size condition +MNonempty. MinimumSize ::= "nonempty" ; +MEmpty. MinimumSize ::= ; + +-- regular expressions +RSeq. Reg2 ::= Reg2 Reg3 ; +RAlt. Reg1 ::= Reg1 "|" Reg2 ; +RMinus. Reg1 ::= Reg2 "-" Reg2 ; + +RStar. Reg3 ::= Reg3 "*" ; +RPlus. Reg3 ::= Reg3 "+" ; +ROpt. Reg3 ::= Reg3 "?" ; + +REps. Reg3 ::= "eps" ; + +RChar. Reg3 ::= Char ; -- single character +RAlts. Reg3 ::= "[" String "]" ; -- list of alternative characters +RSeqs. Reg3 ::= "{" String "}" ; -- character sequence + +RDigit. Reg3 ::= "digit" ; +RLetter. Reg3 ::= "letter" ; +RUpper. Reg3 ::= "upper" ; +RLower. Reg3 ::= "lower" ; +RAny. Reg3 ::= "char" ; + +_. Reg ::= Reg1 ; +_. Reg1 ::= Reg2 ; +_. Reg2 ::= Reg3 ; +_. Reg3 ::= "(" Reg ")" ; + +-- list of categories in the entrypoint pragma +(:[]). [Ident] ::= Ident ; +(:). [Ident] ::= Ident "," [Ident] ; + +-- comments in BNF source +comment "--" ; +comment "{-" "-}" ; + + diff --git a/src/CF.hs b/src/CF.hs new file mode 100644 --- /dev/null +++ b/src/CF.hs @@ -0,0 +1,605 @@ +{-# LANGUAGE PatternGuards, DeriveFunctor, StandaloneDeriving #-} +{- + BNF Converter: Abstract syntax + Copyright (C) 2004 Author: Markus Forberg, Michael Pellauer, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CF ( + -- Types. + CF, + CFG(..), pragmasOfCF, -- ... + Rule, Rul(..), lookupRule, + Pragma(..), + Exp(..), + Literal, + Symbol, + KeyWord, + Cat, + Fun, + Tree(..), + prTree, -- print an abstract syntax tree + Data, -- describes the abstract syntax of a grammar + cf2data, -- translates a grammar to a Data object. + cf2dataLists, -- translates to a Data with List categories included. + -- Literal categories, constants, + firstCat, -- the first value category in the grammar. + firstEntry, -- the first entry or the first value category + specialCats, -- ident + specialCatsP, -- all literals + specialData, -- special data + isCoercion, -- wildcards in grammar (avoid syntactic clutter) + isDefinedRule, -- defined rules (allows syntactic sugar) + isProperLabel, -- not coercion or defined rule + allCats, -- all categories of a grammar + allCatsIdNorm, + allEntryPoints, + reservedWords, + cfTokens, + symbols, + literals, + reversibleCats, + findAllReversibleCats, -- find all reversible categories + identCat, -- transforms '[C]' to ListC (others, unchanged). + isParsable, + rulesOfCF, -- All rules of a grammar. + rulesForCat, -- rules for a given category + ruleGroups, -- Categories are grouped with their rules. + ruleGroupsInternals, --As above, but includes internal cats. + notUniqueNames, -- list of not unique names (replaces the following 2) +-- notUniqueFuns, -- Returns a list of function labels that are not unique. +-- badInheritence, -- Returns a list of all function labels that can cause problems in languages with inheritence. + isList, -- Checks if a category is a list category. + -- Information functions for list functions. + isNilFun, -- empty list function? ([]) + isOneFun, -- one element list function? (:[]) + hasOneFunc, + getCons, + isConsFun, -- constructor function? (:) + isNilCons, -- either three of above? + isEmptyListCat, -- checks if the list permits [] + revSepListRule, -- reverse a rule, if it is of form C t [C]. + normCat, + isDataCat, + normCatOfList, -- Removes precendence information and enclosed List. C1 => C, C2 => C + listCat, + catOfList, + comments, -- translates the pragmas into two list containing the s./m. comments + tokenPragmas, + tokenNames, + precCat, -- get the precendence level of a Cat C1 => 1, C => 0 + precLevels, -- get all precendence levels in the grammar, sorted in increasing order. + precRule, -- get the precendence level of the value category of a rule. + precCF, -- Check if the CF consists of precendence levels. + isUsedCat, + internalCat, + isPositionCat, + hasIdent, + hasLayout, + layoutPragmas, + + CFP, -- CF with profiles + RuleP, + FunP, + Prof, + cf2cfpRule, + cf2cfp, + cfp2cf, + trivialProf, + rulesOfCFP, + funRuleP, ruleGroupsP, allCatsP, allEntryPointsP + ) where + +import Utils (prParenth,(+++)) +import Data.List (nub, intersperse, partition, sort,sort,group,intercalate) +import Data.Char +import AbsBNF (Reg()) + +-- | A context free grammar consists of a set of rules and some extended +-- information (e.g. pragmas, literals, symbols, keywords) +type CF = CFG Fun + +-- | A rule consists of a function name, a main category and a sequence of +-- terminals and non-terminals. +-- function_name . Main_Cat ::= sequence +type Rule = Rul Fun + +-- | Polymorphic rule type for common type signatures for CF and CFP +data Rul function = Rule { funRule :: function + -- ^ The function (semantic action) of a + -- rule. In order to be able to generate + -- data types this must be a constructor + -- (or an identity function). + , valCat :: Cat -- ^ The value category + , rhsRule :: [Either Cat String] + -- ^ The list of Terminals/NonTerminals in + -- the right-hand-side of a rule. + } + deriving (Eq,Functor) + +instance (Show function) => Show (Rul function) where + show (Rule f cat rhs) = show f ++ ". " ++ cat ++ " ::= " ++ intercalate " " (map (either show id) rhs) + +-- | Polymorphic CFG type for common type signatures for CF and CFP +newtype CFG function = CFG { unCFG :: (Exts,[Rul function]) } + deriving (Functor) + + +instance (Show function) => Show (CFG function) where + show (CFG (_,rules)) = unlines $ map show rules + +type Exts = ([Pragma],Info) + +-- | Info is information extracted from the CF, for easy access. +-- Literals - Char, String, Ident, Integer, Double +-- Strings are quoted strings, and Ident are unquoted. +-- Symbols - symbols in the grammar, e.g. ´*´, '->'. +-- KeyWord - reserved words, e.g. 'if' 'while' +type Info = ([Literal],[Symbol],[KeyWord],[Cat]) + +-- Expressions for function definitions +data Exp = App String [Exp] + | LitInt Integer + | LitDouble Double + | LitChar Char + | LitString String + deriving (Eq) + +instance Show Exp where + showsPrec p e = + case listView e of + Right es -> + showString "[" + . foldr (.) id (intersperse (showString ", ") $ map shows es) + . showString "]" + Left (App x []) -> showString x + Left (App "(:)" [e1,e2]) -> + showParen (p>0) + $ showsPrec 1 e1 + . showString " : " + . shows e2 + Left (App x es) -> + showParen (p>1) + $ foldr (.) id + $ intersperse (showString " ") + $ showString x : map (showsPrec 2) es + Left (LitInt n) -> shows n + Left (LitDouble x) -> shows x + Left (LitChar c) -> shows c + Left (LitString s) -> shows s + where + listView (App "[]" []) = Right [] + listView (App "(:)" [e1,e2]) + | Right es <- listView e2 = Right $ e1:es + listView e = Left e + +-- | Pragmas +data Pragma = CommentS String -- ^ for single line comments + | CommentM (String,String) -- ^ for multiple-line comments. + | TokenReg String Bool Reg -- ^ for tokens + | EntryPoints [Cat] + | Layout [String] + | LayoutStop [String] + | LayoutTop + | FunDef String [String] Exp + -- ... + deriving (Show) + +-- | User-defined regular expression tokens +tokenPragmas :: CFG f -> [(String,Reg)] +tokenPragmas cf = [(name,exp) | TokenReg name _ exp <- pragmasOfCF cf] + +-- | The names of all user-defined tokens +tokenNames :: CFG f -> [String] +tokenNames cf = map fst (tokenPragmas cf) + +layoutPragmas :: CF -> (Bool,[String],[String]) +layoutPragmas cf = let ps = pragmasOfCF cf in ( + not (null [() | LayoutTop <- ps]), -- if there's layout betw top-level + concat [ss | Layout ss <- ps], -- layout-block starting words + concat [ss | LayoutStop ss <- ps] -- layout-block ending words + ) + +hasLayout :: CF -> Bool +hasLayout cf = case layoutPragmas cf of + (t,ws,_) -> t || not (null ws) -- (True,[],_) means: top-level layout only + +-- | Literal: Char, String, Ident, Integer, Double +type Literal = Cat +type Symbol = String +type KeyWord = String + +-- | Cat is the Non-terminals of the grammar. +type Cat = String +-- | Fun is the function name of a rule. +type Fun = String +-- | Either Cat or Fun +type Name = String + +-- | The category '#'. It is inserted in 1st position in "internal" +-- rules, essentially ensuring that they are never parsed. +internalCat :: Cat +internalCat = "#" + + +-- | Abstract syntax tree. +newtype Tree = Tree (Fun,[Tree]) + +-- | The abstract syntax of a grammar. +type Data = (Cat, [(Fun,[Cat])]) + +-- | firstCat returns the first Category appearing in the grammar. +firstCat :: CF -> Cat +firstCat = valCat . head . rulesOfCF + +firstEntry :: CF -> Cat +firstEntry cf = case allEntryPoints cf of + (x:_) -> x + _ -> firstCat cf + +rulesOfCF :: CFG f -> [Rul f] +rulesOfCFP :: CFP -> [RuleP] +infoOfCF :: CFG f -> Info +pragmasOfCF :: CFG f -> [Pragma] + +rulesOfCF = snd . unCFG +rulesOfCFP = rulesOfCF +infoOfCF = snd . fst . unCFG +pragmasOfCF = fst . fst . unCFG + +-- aggressively ban nonunique names (AR 31/5/2012) + +notUniqueNames :: [Name] -> CF -> [Fun] +notUniqueNames reserved cf = [head xs | xs <- xss, length xs > 1] where + xss = group (sort names) + names = reserved ++ allCatsIdNorm cf ++ allFuns cf + allFuns g = [ f | f <- map funRule (rulesOfCF g), not (isNilCons f || isCoercion f)] + +{-# DEPRECATED notUniqueFuns "obsolete" #-} +notUniqueFuns :: CF -> [Fun] +notUniqueFuns cf = let xss = group $ sort [ f | f <- map funRule (rulesOfCF cf), + not (isNilCons f || isCoercion f)] + in [ head xs | xs <- xss, length xs > 1] + +badInheritence :: CF -> [Cat] +badInheritence cf = concatMap checkGroup (ruleGroups cf) + where + checkGroup (cat, rs) = if (length rs <= 1) + then [] + else case lookupRule cat rs of + Nothing -> [] + Just x -> [cat] + +-- extract the comment pragmas. +commentPragmas :: [Pragma] -> [Pragma] +commentPragmas = filter isComment + where isComment (CommentS _) = True + isComment (CommentM _) = True + isComment _ = False + +lookupRule :: Eq f => f -> [Rul f] -> Maybe (Cat, [Either Cat String]) +lookupRule f = lookup f . map unRule + where unRule (Rule f c rhs) = (f,(c,rhs)) + +-- | Returns all normal rules that constructs the given Cat. +rulesForCat :: CF -> Cat -> [Rule] +rulesForCat cf cat = [normRuleFun r | r <- rulesOfCF cf, isParsable r, valCat r == cat] + +-- | As rulesForCat, but this version doesn't exclude internal rules. +rulesForCat' :: CF -> Cat -> [Rule] +rulesForCat' cf cat = [normRuleFun r | r <- rulesOfCF cf, valCat r == cat] + +-- | Get all categories of a grammar. (No Cat w/o production returned; No duplicates) +allCats :: CFG f -> [Cat] +allCats = nub . map valCat . rulesOfCF + +-- | Gets all normalized identified Categories +allCatsIdNorm :: CF -> [Cat] +allCatsIdNorm = nub . map identCat . map normCat . allCats + +-- | Is the category is used on an rhs? +isUsedCat :: CFG f -> Cat -> Bool +isUsedCat cf cat = elem cat [c | r <- (rulesOfCF cf), Left c <- rhsRule r] + +-- | Group all categories with their rules. +ruleGroups :: CF -> [(Cat,[Rule])] +ruleGroups cf = [(c, rulesForCat cf c) | c <- allCats cf] + +-- | Group all categories with their rules including internal rules. +ruleGroupsInternals :: CF -> [(Cat,[Rule])] +ruleGroupsInternals cf = [(c, rulesForCat' cf c) | c <- allCats cf] + +-- | Get all literals of a grammar. (e.g. String, Double) +literals :: CFG f -> [String] +literals cf = lits ++ owns + where + (lits,_,_,_) = infoOfCF cf + owns = tokenNames cf + +{-# DEPRECATED symbols, reservedWords "Almost certainly, you should treat symbols and reserved words uniformly, so use cfTokens instead." #-} + +-- | Get all symbols +symbols :: CFG f -> [String] +symbols cf = syms + where (_,syms,_,_) = infoOfCF cf + +-- | Get the keywords of a grammar. +reservedWords :: CFG f -> [String] +reservedWords cf = sort keywords + where (_,_,keywords,_) = infoOfCF cf + +-- | Canonical, numbered list of symbols and reserved words. (These do +-- not end up in the AST.) +cfTokens :: CFG f -> [(String,Int)] +cfTokens cf = zip (sort (symbols cf ++ reservedWords cf)) [1..] +-- NOTE: some backends (incl. Haskell) assume that this list is sorted. + +-- | Categories that is left-recursive transformable. +reversibleCats :: CFG f -> [Cat] +reversibleCats cf = cats + where (_,_,_,cats) = infoOfCF cf + +-- | Comments can be defined by the 'comment' pragma +comments :: CF -> ([(String,String)],[String]) +comments cf = case commentPragmas (pragmasOfCF cf) of + xs -> ([p | CommentM p <- xs], + [s | CommentS s <- xs]) + +-- built-in categories (corresponds to lexer) + +-- | Whether the grammar uses the predefined Ident type. +hasIdent :: CFG f -> Bool +hasIdent cf = isUsedCat cf "Ident" + + +-- these need new datatypes + +-- | Categories corresponding to tokens. These end up in the +-- AST. (unlike tokens returned by 'cfTokens') +specialCats :: CF -> [Cat] +specialCats cf = (if hasIdent cf then ("Ident":) else id) (tokenNames cf) + +-- the parser needs these +specialCatsP :: [Cat] +specialCatsP = words "Ident Integer String Char Double" + +-- to print parse trees +prTree :: Tree -> String +prTree (Tree (fun,[])) = fun +prTree (Tree (fun,trees)) = fun +++ unwords (map pr2 trees) where + pr2 t@(Tree (_,ts)) = (if (null ts) then id else prParenth) (prTree t) + +-- abstract syntax trees: data type definitions + +cf2data' :: (Cat -> Bool) -> CF -> [Data] +cf2data' predicate cf = + [(cat, nub (map mkData [r | r <- rulesOfCF cf, + let f = funRule r, + not (isDefinedRule f), + not (isCoercion f), eqCat cat (valCat r)])) + | cat <- filter predicate (allCats cf)] + where + mkData (Rule f _ its) = (normFun f,[normCat c | Left c <- its, c /= internalCat]) + +cf2data :: CF -> [Data] +cf2data = cf2data' isDataCat + +-- | Does the category correspond to a data type? +isDataCat c = isDataOrListCat c && not (isList c) + +isDataOrListCat c = not (isDigit (last c) || head c == '@') + +cf2dataLists :: CF -> [Data] +cf2dataLists = cf2data' isDataOrListCat + +specialData :: CF -> [Data] +specialData cf = [(c,[(c,[arg c])]) | c <- specialCats cf] where + arg c = case c of + _ -> "String" + + +-- to deal with coercions + +-- the Haskell convention: the wildcard _ is not a constructor + +-- | Is this function just a coercion? (Ie. the identity) +isCoercion :: Fun -> Bool +isCoercion = (== "_") -- perhaps this should be changed to "id"? + +isDefinedRule :: Fun -> Bool +isDefinedRule (x:_) = isLower x + +isProperLabel :: Fun -> Bool +isProperLabel f = not (isCoercion f || isDefinedRule f) + +-- categories C1, C2,... (one digit in end) are variants of C + +eqCat :: Cat -> Cat -> Bool +eqCat c c1 = catCat c == catCat c1 + where catCat :: Cat -> Cat + catCat = fst . analyseCat + + + +-- | Removes precendence information. C1 => C, [C2] => [C] +normCat :: Cat -> Cat +normCat c = case c of + '[':cs -> "[" ++ norm (init cs) ++ "]" + _ -> unList $ norm c -- to be deprecated + where + norm = reverse . dropWhile isDigit . reverse + +normCatOfList :: Cat -> Cat +normCatOfList = normCat . catOfList + +-- | When given a list Cat, i.e. '[C]', it removes the square +-- brackets, and adds the prefix List, i.e. 'ListC'. (for Happy and +-- Latex) +identCat :: Cat -> Cat +identCat c = case c of + '[':cs -> "List" ++ identCat (init cs) + _ -> c + +{-# DEPRECATED normFun "It's just the identity function" #-} +normFun :: Fun -> Fun +normFun = id -- takeWhile (not . isDigit) + +normRuleFun :: Rule -> Rule +normRuleFun (Rule f p rhs) = Rule (normFun f) p rhs + + +-- | Checks if the rule is parsable. +isParsable :: Rul f -> Bool +isParsable (Rule _ _ (Left c:_)) = c /= internalCat +isParsable _ = True + +isList :: Cat -> Bool +isList c = head c == '[' + +{-# DEPRECATED unList "It's just the identity function" #-} +unList :: Cat -> Cat +unList c = c + +-- | Adds list constructor +listCat :: Cat -> Cat +listCat c = "[" ++ c ++ "]" + +-- | Unwraps the list constructor from the category name. Eg. [C1] => C1 +catOfList :: Cat -> Cat +catOfList c = case c of + '[':_:_ -> init (tail c) + _ -> c + +isNilFun, isOneFun, isConsFun, isNilCons,isConcatFun :: Fun -> Bool +isNilCons f = isNilFun f || isOneFun f || isConsFun f || isConcatFun f +isNilFun f = f == "[]" +isOneFun f = f == "(:[])" +isConsFun f = f == "(:)" +isConcatFun f = f == "(++)" + +-- | Checks if the list has a non-empty rule. +hasOneFunc :: [Rule] -> Bool +hasOneFunc = any (isOneFun . funRule) + +-- | Gets the separator for a list. +getCons :: [Rule] -> String +getCons (Rule f c cats:rs) = + if isConsFun f + then seper cats + else getCons rs + where + seper [] = [] + seper ((Right x):xs) = x + seper ((Left x):xs) = seper xs + + +isEmptyListCat :: CF -> Cat -> Bool +isEmptyListCat cf c = elem "[]" $ map funRule $ rulesForCat' cf c + +isNonterm = either (const True) (const False) + +-- used in Happy to parse lists of form 'C t [C]' in reverse order +-- applies only if the [] rule has no terminals +revSepListRule :: Rul f -> Rul f +revSepListRule (Rule f c ts) = Rule f c (xs : x : sep) where + (x,sep,xs) = (head ts, init (tail ts), last ts) +-- invariant: test in findAllReversibleCats have been performed + +findAllReversibleCats :: CF -> [Cat] +findAllReversibleCats cf = [c | (c,r) <- ruleGroups cf, isRev c r] where + isRev c rs = case rs of + [r1,r2] | isList c -> if isConsFun (funRule r2) + then tryRev r2 r1 + else if isConsFun (funRule r1) + then tryRev r1 r2 + else False + _ -> False + tryRev (Rule f _ ts@(x:_:xs)) r = isEmptyNilRule r && + isConsFun f && isNonterm x && isNonterm (last ts) + tryRev _ _ = False + +isEmptyNilRule (Rule f _ ts) = isNilFun f && null ts + +precCat :: Cat -> Int +precCat = snd . analyseCat + +precRule :: Rule -> Int +precRule = precCat . valCat + +precLevels :: CF -> [Int] +precLevels cf = sort $ nub $ [ precCat c | c <- allCats cf] + +precCF :: CF -> Bool +precCF cf = length (precLevels cf) > 1 + + +analyseCat :: Cat -> (Cat,Int) +analyseCat c = if (isList c) then list c else noList c + where + list cat = let (rc,n) = noList (init (tail cat)) in (listCat rc,n) + noList cat = case span isDigit (reverse cat) of + ([],c') -> (reverse c', 0) + (d,c') -> (reverse c', read (reverse d)) + + +-- | Does the category have a position stored in AST? +isPositionCat :: CFG f -> Cat -> Bool +isPositionCat cf cat = or [b | TokenReg name b _ <- pragmasOfCF cf, name == cat] + + +-- | Grammar with permutation profile à la GF. AR 22/9/2004 +type CFP = CFG FunP -- (Exts,[RuleP]) +type FunP = (Fun,Prof) +type RuleP = Rul FunP -- (FunP, (Cat, [Either Cat String])) + +-- | Pair of: the original function name, profile +type Prof = (Fun, [([[Int]],[Int])]) + +cf2cfp :: CF -> CFP +cf2cfp (CFG (es,rs)) = CFG (es, map cf2cfpRule rs) + +cf2cfpRule :: Rule -> RuleP +cf2cfpRule (Rule f c its) = Rule (f, (f, trivialProf its)) c its + +cfp2cf :: CFP -> CF +cfp2cf = fmap fst + +trivialProf :: [Either Cat String] -> [([[Int]],[Int])] +trivialProf its = [([],[i]) | (i,_) <- zip [0..] [c | Left c <- its]] + +{-# DEPRECATED rulesOfCFP, allCatsP, allEntryPointsP "Use the version without P postfix instead" #-} + +funRuleP :: RuleP -> Fun +funRuleP = fst . funRule + +ruleGroupsP :: CFP -> [(Cat,[RuleP])] +ruleGroupsP cf = [(c, rulesForCatP cf c) | c <- allCatsP cf] + +rulesForCatP :: CFP -> Cat -> [RuleP] +rulesForCatP cf cat = [r | r <- rulesOfCFP cf, isParsable r, valCat r == cat] + +allCatsP :: CFP -> [Cat] +allCatsP = allCats + + +-- | Categories that are entry points to the parser +allEntryPoints :: CFG f -> [Cat] +allEntryPoints cf = case concat [cats | EntryPoints cats <- pragmasOfCF cf] of + [] -> allCats cf + cs -> cs + +allEntryPointsP :: CFP -> [Cat] +allEntryPointsP = allEntryPoints diff --git a/src/Common/Makefile.hs b/src/Common/Makefile.hs new file mode 100644 --- /dev/null +++ b/src/Common/Makefile.hs @@ -0,0 +1,59 @@ +module Common.Makefile where + +import Text.Printf +import Text.Show (ShowS) -- Efficient string concatenation +import System.FilePath (replaceExtension) + +type Makefile = ShowS + + +mkRule :: String -- ^ The target name + -> [String] -- ^ Dependencies + -> [String] -- ^ Recipe + -> Makefile +mkRule target deps recipe = (++) $ unlines $ + [ printf "%s: %s" target (unwords deps) ] + ++ map (printf "\t%s") recipe + ++ [""] + +mkDoc :: String -> Makefile +mkDoc texfile = mkRule "doc" [pdffile] [] + . mkRule pdffile [texfile] + [ printf "pdflatex %s" texfile ] + where pdffile = replaceExtension texfile "pdf" + +-- [ +-- "all:", +-- "\thappy -gca " ++ glr_params ++ happyFile opts, +-- "\talex -g " ++ alexFile opts, +-- "\t" ++ cd ("latex " ++ basename (latexFile opts) +-- ++ "; " ++ "dvips " ++ basename (dviFile opts) +-- ++ " -o " ++ basename (psFile opts)), +-- "\tghc --make " ++ tFile opts ++ " -o " ++ mkFile withLang "Test" "" opts, +-- "clean:", +-- "\t-rm -f " ++ unwords (map (dir++) [ +-- "*.log", "*.aux", "*.hi", +-- "*.o", "*.dvi" +-- ]), +-- "\t-rm -f " ++ psFile opts, +-- +-- "distclean: clean", +-- "\t-rm -f " ++ unwords [ +-- mkFile withLang "Doc" "*" opts, +-- mkFile withLang "Lex" "*" opts, +-- mkFile withLang "Par" "*" opts, +-- mkFile withLang "Layout" "*" opts, +-- mkFile withLang "Skel" "*" opts, +-- mkFile withLang "Print" "*" opts, +-- mkFile withLang "Test" "*" opts, +-- mkFile withLang "Abs" "*" opts, +-- mkFile withLang "Test" "" opts, +-- mkFile noLang "ErrM" "*" opts, +-- mkFile noLang "SharedString" "*" opts, +-- dir ++ lang opts ++ ".dtd", +-- mkFile withLang "XML" "*" opts, +-- "Makefile*" +-- ], +-- if null dir then "" else "\t-rmdir -p " ++ dir +-- ] + diff --git a/src/Data/Pair.hs b/src/Data/Pair.hs new file mode 100644 --- /dev/null +++ b/src/Data/Pair.hs @@ -0,0 +1,16 @@ +module Data.Pair where + +import Control.Applicative + +infixl 2 :/: + +data Pair a = (:/:) {leftOf :: a, rightOf :: a} + deriving (Show) + +instance Functor Pair where + fmap f (a :/: b) = f a :/: f b + +instance Applicative Pair where + pure a = a :/: a + (f :/: g) <*> (a :/: b) = f a :/: g b + diff --git a/src/ErrM.hs b/src/ErrM.hs new file mode 100644 --- /dev/null +++ b/src/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 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/GetCF.hs b/src/GetCF.hs new file mode 100644 --- /dev/null +++ b/src/GetCF.hs @@ -0,0 +1,373 @@ +{- + BNF Converter: Abstract syntax + Copyright (C) 2004 Author: Markus Forsberg, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +module GetCF(tryReadCFP) where + +import Control.Monad ( when ) + +import CF +import Utils +import ParBNF +import Data.List(nub,partition) +import qualified AbsBNF as Abs +import Data.Maybe (catMaybes) +import Data.Either (partitionEithers) +import ErrM +import Data.Char +import TypeChecker +import Options + +readCF :: SharedOptions -> FilePath -> IO CFP +readCF opts f = tryReadCFP opts f >>= return . fst + +tryReadCFP :: SharedOptions -> FilePath -> IO (CFP,Bool) +tryReadCFP opts file = do + putStrLn $ "\nReading grammar from " ++ file + s <- readFile file + let (cfp,msgs1) = getCFP (cnf opts) s + cf = cfp2cf cfp + msgs2 = case checkDefinitions cf of + Bad err -> [err] + Ok () -> [] + msgs3 = checkTokens cf + msg = msgs1++msgs2 -- ++ msgs3 -- in a future version + ret = cfp + + let reserved = if anyTarget opts [TargetJava,TargetJava15] + then [takeWhile (/='.') file] else [] + case filter (not . isDefinedRule) $ notUniqueNames reserved cf of + ns@(_:_) + | not (anyTarget opts [TargetHaskell,TargetHaskellGADT,TargetOCAML]) -> do + putStrLn $ "ERROR: names not unique: " ++ unwords ns + return (ret,False) + ns -> do + case ns of + _:_ -> do + putStrLn $ "Warning: names not unique: " ++ unwords ns + putStrLn "This can be an error in other back ends." + _ -> return () + putStrLn $ unlines msgs3 + if not (null msg) then do + putStrLn $ unlines msg + return (ret,False) + else do + putStrLn $ show (length (rulesOfCF cf)) +++ "rules accepted\n" + let c3s = [(b,e) | (b,e) <- fst (comments cf), length b > 2 || length e > 2] + if null c3s then return () else do + putStrLn + "Warning: comment delimiters longer than 2 characters ignored in Haskell:" + mapM_ putStrLn [b +++ "-" +++ e | (b,e) <- c3s] + return (ret,True) + +{- + case filter (not . isDefinedRule) $ notUniqueFuns cf of + [] -> case (badInheritence cf) of + [] -> return (ret,True) + xs -> do + putStrLn "Warning :" + putStrLn $ " Bad Label name in Category(s) :" ++ unwords xs + putStrLn $ " These categories have more than one Label, yet one of these" + putStrLn $ " Labels has the same name as the Category. This will almost" + putStrLn $ " certainly cause problems in languages other than Haskell.\n" + return (ret,True) + xs -> do + putStrLn $ "Warning :" + putStrLn $ " Non-unique label name(s) : " ++ unwords xs + putStrLn $ " There may be problems with the pretty-printer.\n" + case (badInheritence cf) of + [] -> return (ret,True) + xs -> do + putStrLn $ "Warning :" + putStrLn $ " Bad Label name in Category(s) :" ++ unwords xs + putStrLn $ " These categories have more than one Label, yet one of these" + putStrLn $ " Labels has the same name as the Category. This will almost" + putStrLn $ " certainly cause problems in languages other than Haskell.\n" + return (ret,True) +-} + +nilCFP :: CFP +nilCFP = CFG (([],([],[],[],[])),[]) + +getCFP :: Bool -> String -> (CFP,[String]) +getCFP cnf s = case pGrammar . myLexer $ s of + Bad s -> (nilCFP,[s]) + Ok (Abs.Grammar defs) -> (cf0,msgs) + where (pragma,rules) = partitionEithers $ concatMap (transDef cnf) defs + msgs = catMaybes $ map (checkRule (cfp2cf cf0)) (rulesOfCF cf0) + cf0 = revs srt + srt = let literals = nub [lit | xs <- map rhsRule rules, + Left lit <- xs, + elem lit specialCatsP] + (symbols,keywords) = partition notIdent reservedWords + notIdent s = null s || not (isAlpha (head s)) || any (not . isIdentRest) s + isIdentRest c = isAlphaNum c || c == '_' || c == '\'' + reservedWords = nub [t | r <- rules, Right t <- rhsRule r] + in CFG((pragma,(literals,symbols,keywords,[])),rules) + revs cf1@(CFG((pragma,(literals,symbols,keywords,_)),rules)) = + CFG((pragma,(literals,symbols,keywords,findAllReversibleCats (cfp2cf cf1))),rules) + +transDef :: Bool -> Abs.Def -> [Either Pragma RuleP] +transDef cnf x = case x of + Abs.Rule label cat items -> + [Right $ Rule (transLabel label) (transCat cat) (map transItem items)] + Abs.Comment str -> [Left $ CommentS str] + Abs.Comments str0 str -> [Left $ CommentM (str0,str)] + Abs.Token ident reg -> [Left $ TokenReg (transIdent ident) False reg] + Abs.PosToken ident reg -> [Left $ TokenReg (transIdent ident) True reg] + Abs.Entryp idents -> [Left $ EntryPoints (map transIdent idents)] + Abs.Internal label cat items -> + [Right $ Rule (transLabel label) (transCat cat) (Left internalCat:(map transItem items))] + Abs.Separator size ident str -> map (Right . cf2cfpRule) $ separatorRules size ident str + Abs.Terminator size ident str -> map (Right . cf2cfpRule) $ terminatorRules size ident str + Abs.Delimiters a b c d e -> map (Right . cf2cfpRule) $ delimiterRules cnf a b c d e + Abs.Coercions ident int -> map (Right . cf2cfpRule) $ coercionRules ident int + Abs.Rules ident strs -> map (Right . cf2cfpRule) $ ebnfRules ident strs + Abs.Layout ss -> [Left $ Layout ss] + Abs.LayoutStop ss -> [Left $ LayoutStop ss] + Abs.LayoutTop -> [Left $ LayoutTop] + Abs.Function f xs e -> [Left $ FunDef (transIdent f) (map transArg xs) (transExp e)] + + + +delimiterRules :: Bool -> Abs.Cat -> String -> String -> Abs.Separation -> Abs.MinimumSize -> [Rule] +delimiterRules False a0 l r sep size = [ + Rule "_" as [Right l, Left (listCat x), Right r] + ] ++ separationRules (Abs.IdCat $ Abs.Ident $ x) sep size + where + a = transCat a0 + as = listCat a + x = a ++ "_without_delimiters" +delimiterRules True a0 l r (Abs.SepTerm "") size = delimiterRules True a0 l r Abs.SepNone size +delimiterRules True a0 l r (Abs.SepSepar "") size = delimiterRules True a0 l r Abs.SepNone size +delimiterRules True a0 l r sep size = [ + -- recognizing a single element + Rule "(:[])" a' (Left a : termin), -- optional terminator/separator + + -- glueing two sublists + Rule "(++)" a' [Left a', Left a'], + + -- starting on either side with a delimiter + Rule "[]" c [Right l], + Rule (if optFinal then "(:[])" else + "[]") + d ([Left a | optFinal] ++ [Right r]), + + -- gathering chains + Rule "(++)" c [Left c, Left a'], + Rule "(++)" d [Left a', Left d], + + -- finally, put together left and right chains + Rule "(++)" as [Left c,Left d]] ++ [ + -- special rule for the empty list if necessary + Rule "[]" as [Right l,Right r] | optEmpty] + where a = transCat a0 + as = listCat a + a' = '@':'@':a + c = '@':'{':a + d = '@':'}':a + -- optionally separated concat. of x and y categories. + x // y = (Left x : + [Right t | Abs.SepSepar t <- [sep]] ++ + [Left y ]) + termin = case sep of + Abs.SepSepar t -> [Right t] + Abs.SepTerm t -> [Right t] + _ -> [] + optFinal = case (sep,size) of + (Abs.SepSepar t,_) -> True + (Abs.SepTerm _,Abs.MNonempty) -> True + (Abs.SepNone,Abs.MNonempty) -> True + _ -> False + optEmpty = case sep of + Abs.SepSepar _ -> size == Abs.MEmpty + _ -> False + + +separationRules :: Abs.Cat -> Abs.Separation -> Abs.MinimumSize -> [Rule] +separationRules c Abs.SepNone size = terminatorRules size c "" +separationRules c (Abs.SepTerm t) size = terminatorRules size c t +separationRules c (Abs.SepSepar t) size = separatorRules size c t + + +separatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [Rule] +separatorRules size c s = if null s then terminatorRules size c s else ifEmpty [ + Rule "(:[])" cs [Left c'], + Rule "(:)" cs [Left c', Right s, Left cs] + ] + where + c' = transCat c + cs = listCat c' + ifEmpty rs = if (size == Abs.MNonempty) + then rs + else Rule "[]" cs [] : rs + +terminatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [Rule] +terminatorRules size c s = [ + ifEmpty, + Rule "(:)" cs (Left c' : s' [Left cs]) + ] + where + c' = transCat c + cs = listCat c' + s' its = if null s then its else (Right s : its) + ifEmpty = if (size == Abs.MNonempty) + then Rule "(:[])" cs ([Left c'] ++ if null s then [] else [Right s]) + else Rule "[]" cs [] + +coercionRules :: Abs.Ident -> Integer -> [Rule] +coercionRules (Abs.Ident c) n = + Rule "_" c [Left (c ++ "1")] : + [(Rule "_" (c ++ show (i-1)) [Left (c ++ show i)]) | i <- [2..n]] ++ + [(Rule "_" (c ++ show n) [Right "(", Left c, Right ")"])] + +ebnfRules :: Abs.Ident -> [Abs.RHS] -> [Rule] +ebnfRules (Abs.Ident c) rhss = + [Rule (mkFun k c its) c (map transItem its) + | (k, Abs.RHS its) <- zip [1 :: Int ..] rhss] + where + mkFun k c i = case i of + [Abs.Terminal s] -> c' ++ "_" ++ mkName k s + [Abs.NTerminal n] -> c' ++ identCat (transCat n) + _ -> c' ++ "_" ++ show k + c' = c --- normCat c + mkName k s = if all (\c -> isAlphaNum c || elem c "_'") s + then s else show k + +transItem :: Abs.Item -> Either Cat String +transItem x = case x of + Abs.Terminal str -> Right str + Abs.NTerminal cat -> Left (transCat cat) + +transCat :: Abs.Cat -> Cat +transCat x = case x of + Abs.ListCat cat -> "[" ++ (transCat cat) ++ "]" + Abs.IdCat id -> transIdent id + +transLabel :: Abs.Label -> (Fun,Prof) +transLabel y = case y of + Abs.LabNoP f -> let g = transLabelId f in (g,(g,[])) ---- should be Nothing + Abs.LabP f p -> let g = transLabelId f in (g,(g, map transProf p)) + Abs.LabPF f g p -> (transLabelId f,(transLabelId g, map transProf p)) + Abs.LabF f g -> (transLabelId f,(transLabelId g, [])) + where + transLabelId x = case x of + Abs.Id id -> transIdent id + Abs.Wild -> "_" + Abs.ListE -> "[]" + Abs.ListCons -> "(:)" + Abs.ListOne -> "(:[])" + transProf (Abs.ProfIt bss as) = + ([map fromInteger bs | Abs.Ints bs <- bss], map fromInteger as) + +transIdent :: Abs.Ident -> String +transIdent x = case x of + Abs.Ident str -> str + +transArg :: Abs.Arg -> String +transArg (Abs.Arg x) = transIdent x + +transExp :: Abs.Exp -> Exp +transExp e = case e of + Abs.App x es -> App (transIdent x) (map transExp es) + Abs.Var x -> App (transIdent x) [] + Abs.Cons e1 e2 -> cons e1 (transExp e2) + Abs.List es -> foldr cons nil es + Abs.LitInt x -> LitInt x + Abs.LitDouble x -> LitDouble x + Abs.LitChar x -> LitChar x + Abs.LitString x -> LitString x + where + cons e1 e2 = App "(:)" [transExp e1, e2] + nil = App "[]" [] + +-------------------------------------------------------------------------------- + +--checkTokens :: CFG f -> [String] +checkTokens cf = + if null ns + then [] + else ["Warning : ", -- change to error in a future version + " The following tokens accept the empty string: ", + " "++unwords ns, + " This is error-prone and will not be supported in the future."] + where + ns = map fst . filter (nullable.snd) $ tokenPragmas cf + +-- | Check if a regular expression is nullable (accepts the empty string) +nullable :: Abs.Reg -> Bool +nullable r = + case r of + Abs.RSeq r1 r2 -> nullable r1 && nullable r2 + Abs.RAlt r1 r2 -> nullable r1 || nullable r2 + Abs.RMinus r1 r2 -> nullable r1 && not (nullable r2) + Abs.RStar _ -> True + Abs.RPlus r1 -> nullable r1 + Abs.ROpt _ -> True + Abs.REps -> True + Abs.RChar _ -> False + Abs.RAlts _ -> False + Abs.RSeqs s -> null s + Abs.RDigit -> False + Abs.RLetter -> False + Abs.RUpper -> False + Abs.RLower -> False + Abs.RAny -> False + + +-- we should actually check that +-- (1) coercions are always between variants +-- (2) no other digits are used + +checkRule :: CF -> RuleP -> Maybe String +checkRule cf (Rule _ ('@':_) rhs) = Nothing -- Generated by a pragma; it's a trusted category +checkRule cf (Rule (f,_) cat rhs) + | badCoercion = Just $ "Bad coercion in rule" +++ s + | badNil = Just $ "Bad empty list rule" +++ s + | badOne = Just $ "Bad one-element list rule" +++ s + | badCons = Just $ "Bad list construction rule" +++ s + | badList = Just $ "Bad list formation rule" +++ s + | badSpecial = Just $ "Bad special category rule" +++ s + | badTypeName = Just $ "Bad type name" +++ unwords badtypes +++ "in" +++ s + | badFunName = Just $ "Bad constructor name" +++ f +++ "in" +++ s + | badMissing = Just $ "No production for" +++ unwords missing ++ + ", appearing in rule" +++ s + | otherwise = Nothing + where + s = f ++ "." +++ cat +++ "::=" +++ unwords (map (either id show) rhs) -- Todo: consider using the show instance of Rule + c = normCat cat + cs = [normCat c | Left c <- rhs] + badCoercion = isCoercion f && not ([c] == cs) + badNil = isNilFun f && not (isList c && null cs) + badOne = isOneFun f && not (isList c && cs == [catOfList c]) + badCons = isConsFun f && not (isList c && cs == [catOfList c, c]) + badList = isList c && + not (isCoercion f || isNilCons f) + badSpecial = elem c specialCatsP && not (isCoercion f) + + badMissing = not (null missing) + missing = filter nodef [c | Left c <- rhs] + nodef t = notElem t defineds + defineds = + internalCat : tokenNames cf ++ specialCatsP ++ map valCat (rulesOfCF cf) + badTypeName = not (null badtypes) + badtypes = filter isBadType $ cat : [c | Left c <- rhs] + isBadType c = not (isUpper (head c) || isList c || c == internalCat || (head c == '@') ) + badFunName = not (all (\c -> isAlphaNum c || c == '_') f {-isUpper (head f)-} + || isCoercion f || isNilCons f) diff --git a/src/LexBNF.x b/src/LexBNF.x new file mode 100644 --- /dev/null +++ b/src/LexBNF.x @@ -0,0 +1,170 @@ +-- -*- haskell -*- +-- This Alex file was machine-generated by the BNF converter +{ +{-# OPTIONS -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -w #-} +module LexBNF where + + + +import qualified Data.Bits +import Data.Word (Word8) +} + + +$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 (TV . 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)) } +\' ($u # [\' \\] | \\ [\\ \' n t]) \' { tok (\p s -> PT p (TC $ share 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 !Int -- 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" + +tokenPosn (PT p _) = p +tokenPosn (Err p) = p +tokenLineCol = posLineCol . tokenPosn +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 + + +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 "digit" 21 (b "=" 11 (b "-" 6 (b "*" 3 (b ")" 2 (b "(" 1 N N) N) (b "," 5 (b "+" 4 N N) N)) (b "::=" 9 (b ":" 8 (b "." 7 N N) N) (b ";" 10 N N))) (b "char" 16 (b "]" 14 (b "[" 13 (b "?" 12 N N) N) (b "_" 15 N N)) (b "define" 19 (b "comment" 18 (b "coercions" 17 N N) N) (b "delimiters" 20 N N)))) (b "separator" 31 (b "letter" 26 (b "internal" 24 (b "eps" 23 (b "entrypoints" 22 N N) N) (b "layout" 25 N N)) (b "position" 29 (b "nonempty" 28 (b "lower" 27 N N) N) (b "rules" 30 N N))) (b "upper" 36 (b "token" 34 (b "terminator" 33 (b "stop" 32 N N) N) (b "toplevel" 35 N N)) (b "|" 39 (b "{" 38 (b "views" 37 N N) N) (b "}" 40 N N)))) + where b s n = let bs = id s + in B bs (TS bs n) + +unescapeInitTail :: String -> String +unescapeInitTail = id . unesc . tail . id 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 Byte = Word8 + +type AlexInput = (Posn, -- current position, + Char, -- previous char + [Byte], -- pending bytes on the current char + String) -- current input string + +tokens :: String -> [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 (take len str) : (go inp') + +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s)) +alexGetByte (p, _, [], s) = + case s of + [] -> Nothing + (c:s) -> + let p' = alexMove p c + (b:bs) = utf8Encode c + in p' `seq` Just (b, (p', c, bs, s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p, c, bs, s) = c + + -- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +utf8Encode :: Char -> [Word8] +utf8Encode = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) + , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] +} diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,231 @@ +{- + BNF Converter: Main file + Copyright (C) 2002-2013 Authors: + Jonas Almström Duregård, Krasimir Angelov, Jean-Philippe Bernardy, Björn Bringert, Johan Broberg, Paul Callaghan, + Grégoire Détrez, Markus Forsberg, Ola Frid, Peter Gammie, Thomas Hallgren, Patrik Jansson, + Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell, + Michael Pellauer and Aarne Ranta 2002 - 2013. + + Björn Bringert, Johan Broberg, Markus Forberg, Peter Gammie, + Patrik Jansson, Antti-Juhani Kaijanaho, Ulf Norell, + Michael Pellauer, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +module Main where + +-- import Utils +import CF (cfp2cf) +import HaskellTop +import HaskellTopGADT +import ProfileTop +import JavaTop +import JavaTop15 +import CPPTop +import CSharpTop +import STLTop +import CTop +import OCamlTop +import FSharpTop +import CFtoXML +import Utils +import Options +import GetCF + +import MultiView (preprocessMCF, mkTestMulti, mkMakefileMulti) + +import System.Environment (getEnv,getArgs ) +import System.Exit (exitFailure,exitSuccess) +import System.Cmd (system) +import Data.Char +import Data.List (elemIndex, foldl') +import Control.Monad (when,unless) + +import Paths_BNFC ( version ) +import Data.Version ( showVersion ) + +title = unlines [ + "The BNF Converter, "++showVersion version, + "(c) Jonas Almström Duregård, Krasimir Angelov, Jean-Philippe Bernardy, Björn Bringert, Johan Broberg, Paul Callaghan, ", + " Grégoire Détrez, Markus Forsberg, Ola Frid, Peter Gammie, Thomas Hallgren, Patrik Jansson, ", + " Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell, ", + " Michael Pellauer and Aarne Ranta 2002 - 2013.", + "Free software under GNU General Public License (GPL).", + "Bug reports to bnfc-dev@googlegroups.com." + ] + +main :: IO () +main = do + xx <- getArgs + + case xx of + ["--numeric-version"] -> do + putStrLn (showVersion version) + exitSuccess + [] -> printUsage + _ | elem "-multi" xx -> do + putStrLn "preprocessing multilingual BNF" + let file = last xx + (files,entryp) <- preprocessMCF file + mapM_ mkOne [init xx ++ [f] | f <- files] + mkTestMulti entryp xx file files + mkMakefileMulti xx file files + _ -> mkOne xx + +mkOne :: [String] -> IO () +mkOne xx = do + let args = (map (filter (not . isSpace)) xx) + let file = last args + if (head file == '-') then printUsage + else do + let name = takeWhile (/= '.') $ basename file + let make = elem "-m" args + let multi = elem "-multi" args + let c = elem "-c" args + let cpp_no_stl = elem "-cpp_no_stl" args + let cpp_stl = elem "-cpp_stl" args || elem "-cpp" args + let csharp = elem "-csharp" args + let java14 = elem "-java1.4" args + let java15 = elem "-java1.5" args || elem "-java" args + let ocaml = elem "-ocaml" args + let fsharp = elem "-fsharp" args + let haskell = elem "-haskell" args + let haskellGADT = elem "-gadt" args + let profile = elem "-prof" args + let alexMode = foldl' (\m arg -> + case arg of + "-alex1" -> Alex1 + "-alex2" -> Alex2 + "-alex3" -> Alex3 + _ -> m + ) Alex3 args + alex1 = alexMode == Alex1 + alex2StringSharing = elem "-sharestrings" args + alex2ByteString = elem "-bytestrings" args + glr = "-glr" `elem` args + let xml = if elem "-xml" args then 1 else + if elem "-xmlt" args then 2 else 0 + let inDir = elem "-d" args + let vsfiles = elem "-vs" args + let wcfSupport = elem "-wcf" args + let linenumbers = elem "-l" args -- for C++ STL target + inPackage <- case elemIndex "-p" args of + Nothing -> return Nothing + Just i | i < length args - 1 -> return (Just (args!!(i+1))) + _ -> do + putStrLn "-p option requires an argument" + printUsage + let options = Options {make = make, + alexMode = alexMode, + inDir = inDir, + shareStrings = alex2StringSharing, + byteStrings = alex2ByteString, + glr = if glr then GLR else Standard, + xml = xml, + inPackage = inPackage, + lang = name, + multi = multi, + cnf = elem "-cnf" args, + targets = targets + } + targets0 = [ TargetC |c] ++ [ TargetCPP | cpp_no_stl ] ++ [TargetCPP_STL | cpp_stl + ] ++ [ TargetCSharp | csharp] ++ [ TargetFSharp |fsharp] ++ [TargetHaskellGADT|haskellGADT + ] ++ [ TargetJava15 |java15] ++ [TargetJava |java14] ++ [TargetOCAML |ocaml] ++ [TargetProfile|profile] + targets = if null targets0 then [TargetHaskell] else targets0 + putStrLn title + unless (length targets == 1) $ + fail "Error: only one language mode may be chosen" + unless (isCF (reverse file)) $ + fail "Error: the input file must end with .cf" + (cfp, isOk) <- tryReadCFP options file + let cf = cfp2cf cfp + unless isOk $ + fail "Error: Failed" + case () of + _ | c -> makeC make name cf + _ | cpp_no_stl -> makeCPP make name cf + _ | cpp_stl-> makeSTL make linenumbers inPackage name cf + _ | csharp -> makeCSharp make vsfiles wcfSupport inPackage cf file + _ | java14 -> makeJava make name cf + _ | java15 -> makeJava15 make inPackage name cf + _ | ocaml -> makeOCaml options cf + _ | fsharp -> makeFSharp options cf + _ | profile-> makeAllProfile make alex1 False xml name cfp + _ | haskellGADT -> makeAllGADT options cf + _ -> makeAll options cf + when (make && multi) $ do + system ("cp Makefile Makefile_" ++ name) + return () + putStrLn "Done!" + where isCF ('f':'c':'.':_) = True + isCF ('f':'n':'b':'.':_) = True + isCF ('f':'n':'b':'l':'.':_) = True + isCF ('c':'f':'n':'b':'.':_) = True + isCF _ = False + +printUsage = do + putStrLn title + putStrLn "Usage: bnfc * ? * file.cf" + putStrLn "" + putStrLn "Version options:" + putStrLn " --numeric-version Print just the version number" + putStrLn "" + putStrLn "Make option:" + putStrLn " -m generate Makefile" + putStrLn "" + putStrLn "Languages (Only one language mode may be selected.)" + putStrLn " -java Output Java 1.5 code for use with JLex and CUP" + putStrLn " -java1.5 Output Java 1.5 code for use with JLex and CUP (same as -java)" + putStrLn " -java1.4 Output Java 1.4 code for use with JLex and CUP (before 2.5 was: -java)" + putStrLn " -c Output C code for use with FLex and Bison" + putStrLn " -cpp Output C++ code for use with FLex and Bison (same as -cpp_stl)" + putStrLn " -cpp_stl Output C++ code for use with FLex and Bison (same as -cpp)" + putStrLn " -cpp_no_stl Output C++ code (without STL) for use with FLex and Bison (before 2.5 was: -cpp)" + putStrLn " and the Standard Template Library" + putStrLn " -csharp Output C# code for use with GPLEX and GPPG" + putStrLn " -ocaml Output OCaml code for use with ocamllex and ocamlyacc" + putStrLn " -fsharp Output F# code for use with fslex and fsyacc" + putStrLn " -haskell Output Haskell code for use with Alex and Happy (default)" + putStrLn " -prof Output Haskell code for rules with permutation profiles" + putStrLn " -gadt Output Haskell code which uses GADTs" + putStrLn "" + putStrLn "Special options for the Haskell back-end:" + putStrLn " -d Put Haskell code in modules Lang.* instead of Lang*" + putStrLn " -p Prepend to the Haskell module names." + putStrLn " Dots in the module name create hierarchical modules." + putStrLn " -alex1 Use Alex 1.1 as Haskell lexer tool" + putStrLn " -alex2 Use Alex 2 as Haskell lexer tool" + putStrLn " -alex3 Use Alex 3 as Haskell lexer tool (default)" + putStrLn " -sharestrings Use string sharing in Alex 2 lexer" + putStrLn " -bytestrings Use byte string in Alex 2 lexer" + putStrLn " -glr Output Happy GLR parser" + putStrLn " -xml Also generate a DTD and an XML printer" + putStrLn " -xmlt DTD and an XML printer, another encoding" + putStrLn "" + putStrLn "Special options for the C++ (with STL) back-end:" + putStrLn " -l Add and set line_number field for all syntax classes" + putStrLn " -p Use as the C++ namespace" + putStrLn "" + putStrLn "Special options for the Java (v 1.5) back-end:" + putStrLn " -p Prepend to the Java package name" + putStrLn "" + putStrLn "Special options for the C# backend:" + putStrLn " -p Use as the C# namespace" + putStrLn " -vs Generate Visual Studio solution/project files" + putStrLn " -wcf Add support for Windows Communication Foundation, by" + putStrLn " marking abstract syntax classes as DataContracts" + exitFailure diff --git a/src/MultiView.hs b/src/MultiView.hs new file mode 100644 --- /dev/null +++ b/src/MultiView.hs @@ -0,0 +1,137 @@ +{- + BNF Converter: Abstract syntax + Copyright (C) 2004 Author: Markus Forsberg, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +module MultiView where + +import System.Directory ( doesFileExist, renameFile ) + +import qualified CF as CF +import Utils +import ParBNF +import PrintBNF +import Data.List(nub,partition) +import AbsBNF +-- import LexBNF +import ErrM +import Data.Char +import TypeChecker + +preprocessMCF :: FilePath -> IO ([FilePath],String) +preprocessMCF f = do + s <- readFile f + gr <- case pLGrammar $ myLexer s of + Ok g -> return g + Bad s -> error s + let name = takeWhile (/='.') f + let grs = extract name gr + let entryp = entrypoint gr + mapM_ writeCF grs + return $ (map fst grs,entryp) + +extract :: String -> LGrammar -> [(FilePath, Grammar)] +extract name (LGr ldefs) = + [(file lang,Grammar [unldef ldef | ldef <- ldefs, isFor lang ldef]) | + lang <- views] + where + views = [lang | LDefView langs <- ldefs, Ident lang <- langs] + isFor lang ldef = case ldef of + DefAll _ -> True + DefSome ids _ -> elem (Ident lang) ids + _ -> False + unldef ldef = case ldef of + DefAll d -> d + DefSome _ d -> d + file lang = name ++ "_" ++ lang ++ ".cf" + +--- the entrypoint is the same for all languages - could be different + +entrypoint :: LGrammar -> String +entrypoint (LGr rs0) = head $ + [c | Entryp (Ident c:_) <- rs] ++ + [c | Rule _ (IdCat (Ident c)) _ <- rs] + where + rs = concatMap getR rs0 + getR d = case d of + DefAll d -> [d] + DefSome _ d -> [d] + _ -> [] --- LDefView + +writeCF :: (FilePath, Grammar) -> IO () +writeCF (file,gr) = do + writeFile file $ printTree gr + putStrLn $ "wrote file " ++ file + +---- These are Haskell specific; +---- should be generalized by inspecting the options xx + +mkTestMulti :: String -> [String] -> FilePath -> [FilePath] -> IO () +mkTestMulti cat xx file files = do + let abs = takeWhile (/='.') file + let cncs = map (takeWhile (/='.')) files + let content = testfile cat xx abs cncs + writeFile ("TestTrans" ++ abs ++ ".hs") content + +mkMakefileMulti :: [String] -> FilePath -> [FilePath] -> IO () +mkMakefileMulti xx file files = do + let abs = takeWhile (/='.') file + let cncs = map (takeWhile (/='.')) files + let content = makefile xx abs cncs + writeFile "Makefile" content + +makefile xx abs cncs = unlines $ + "all:" : + ["\tmake -f Makefile_" ++ cnc | cnc <- cncs] ++ + ["\tghc --make -o TestTrans" ++ abs ++ " TestTrans" ++ abs, + "" + ] + +testfile cat xx abs cncs = unlines $ + ["module Main where"] ++ + ["import qualified Lex" ++ cnc | cnc <- cncs] ++ + ["import qualified Par" ++ cnc | cnc <- cncs] ++ + ["import qualified Print" ++ cnc | cnc <- cncs] ++ + ["import Abs" ++ abs, + "import ErrM", + "import System.Environment (getArgs)", + "", + "main :: IO ()", + "main = do", + " i:o:f:_ <- getArgs", + " s <- readFile f", + " case parse i s of", + " Ok t -> putStrLn $ prin o t", + " Bad s -> error s", + "", + "parse i = case i of" + ] ++ + [ + " " ++ sho cnc ++ " -> Par" ++ cnc ++ ".p" ++ cat ++ + " . Par" ++ cnc ++ ".myLexer" | cnc <- cncs + ] ++ + [ + "", + "prin o = case o of" + ] ++ + [ + " " ++ sho cnc ++ " -> Print" ++ cnc ++ + ".printTree" | cnc <- cncs + ] + where + sho = show . tail . dropWhile (/='_') diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -0,0 +1,34 @@ +module Options where + +data Target = TargetC | TargetCPP |TargetCPP_STL + | TargetCSharp | TargetFSharp |TargetHaskell |TargetHaskellGADT + | TargetJava15 |TargetJava |TargetOCAML |TargetProfile + deriving Eq + +-- | Which version of Alex is targeted? +data AlexMode = Alex1 | Alex2 | Alex3 deriving Eq + +data HappyMode = Standard | GLR deriving Eq + +data SharedOptions = Options + { + targets :: [Target], + make :: Bool, + alexMode :: AlexMode, + inDir :: Bool, + shareStrings :: Bool, + byteStrings :: Bool, + glr :: HappyMode, + xml :: Int, + inPackage :: Maybe String, -- ^ The hierarchical package to put + -- the modules in, or Nothing. + lang :: String, -- ^ Prefix to use in module names + multi :: Bool, + cnf :: Bool -- ^ Generate CNF-like tables? + } + +anyTarget opts vs = any (isOpt opts) vs + where isOpt opts v = elem v $ targets opts + + + diff --git a/src/ParBNF.y b/src/ParBNF.y new file mode 100644 --- /dev/null +++ b/src/ParBNF.y @@ -0,0 +1,327 @@ +-- This Happy file was machine-generated by the BNF converter +{ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} +module ParBNF where +import AbsBNF +import LexBNF +import ErrM + +} + +%name pLGrammar LGrammar +%name pLDef LDef +%name pListLDef ListLDef +%name pGrammar Grammar +%name pListDef ListDef +%name pListItem ListItem +%name pDef Def +%name pItem Item +%name pCat Cat +%name pLabel Label +%name pLabelId LabelId +%name pProfItem ProfItem +%name pIntList IntList +%name pListInteger ListInteger +%name pListIntList ListIntList +%name pListProfItem ListProfItem +%name pSeparation Separation +%name pArg Arg +%name pListArg ListArg +%name pExp Exp +%name pExp1 Exp1 +%name pExp2 Exp2 +%name pListExp2 ListExp2 +%name pListExp ListExp +%name pListString ListString +%name pListRHS ListRHS +%name pRHS RHS +%name pMinimumSize MinimumSize +%name pReg2 Reg2 +%name pReg1 Reg1 +%name pReg3 Reg3 +%name pReg Reg +%name pListIdent ListIdent + +-- 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) } + 'char' { PT _ (TS _ 16) } + 'coercions' { PT _ (TS _ 17) } + 'comment' { PT _ (TS _ 18) } + 'define' { PT _ (TS _ 19) } + 'delimiters' { PT _ (TS _ 20) } + 'digit' { PT _ (TS _ 21) } + 'entrypoints' { PT _ (TS _ 22) } + 'eps' { PT _ (TS _ 23) } + 'internal' { PT _ (TS _ 24) } + 'layout' { PT _ (TS _ 25) } + 'letter' { PT _ (TS _ 26) } + 'lower' { PT _ (TS _ 27) } + 'nonempty' { PT _ (TS _ 28) } + 'position' { PT _ (TS _ 29) } + 'rules' { PT _ (TS _ 30) } + 'separator' { PT _ (TS _ 31) } + 'stop' { PT _ (TS _ 32) } + 'terminator' { PT _ (TS _ 33) } + 'token' { PT _ (TS _ 34) } + 'toplevel' { PT _ (TS _ 35) } + 'upper' { PT _ (TS _ 36) } + 'views' { PT _ (TS _ 37) } + '{' { PT _ (TS _ 38) } + '|' { PT _ (TS _ 39) } + '}' { PT _ (TS _ 40) } + +L_quoted { PT _ (TL $$) } +L_ident { PT _ (TV $$) } +L_integ { PT _ (TI $$) } +L_charac { PT _ (TC $$) } +L_doubl { PT _ (TD $$) } +L_err { _ } + + +%% + +String :: { String } : L_quoted { $1 } +Ident :: { Ident } : L_ident { Ident $1 } +Integer :: { Integer } : L_integ { (read ( $1)) :: Integer } +Char :: { Char } : L_charac { (read ( $1)) :: Char } +Double :: { Double } : L_doubl { (read ( $1)) :: Double } + +LGrammar :: { LGrammar } +LGrammar : ListLDef { LGr $1 } + + +LDef :: { LDef } +LDef : Def { DefAll $1 } + | ListIdent ':' Def { DefSome $1 $3 } + | 'views' ListIdent { LDefView $2 } + + +ListLDef :: { [LDef] } +ListLDef : {- empty -} { [] } + | LDef { (:[]) $1 } + | LDef ';' ListLDef { (:) $1 $3 } + + +Grammar :: { Grammar } +Grammar : ListDef { Grammar $1 } + + +ListDef :: { [Def] } +ListDef : {- empty -} { [] } + | Def { (:[]) $1 } + | Def ';' ListDef { (:) $1 $3 } + + +ListItem :: { [Item] } +ListItem : {- empty -} { [] } + | ListItem Item { flip (:) $1 $2 } + + +Def :: { Def } +Def : Label '.' Cat '::=' ListItem { Rule $1 $3 (reverse $5) } + | 'comment' String { Comment $2 } + | 'comment' String String { Comments $2 $3 } + | 'internal' Label '.' Cat '::=' ListItem { Internal $2 $4 (reverse $6) } + | 'token' Ident Reg { Token $2 $3 } + | 'position' 'token' Ident Reg { PosToken $3 $4 } + | 'entrypoints' ListIdent { Entryp $2 } + | 'separator' MinimumSize Cat String { Separator $2 $3 $4 } + | 'terminator' MinimumSize Cat String { Terminator $2 $3 $4 } + | 'delimiters' Cat String String Separation MinimumSize { Delimiters $2 $3 $4 $5 $6 } + | 'coercions' Ident Integer { Coercions $2 $3 } + | 'rules' Ident '::=' ListRHS { Rules $2 $4 } + | 'define' Ident ListArg '=' Exp { Function $2 (reverse $3) $5 } + | 'layout' ListString { Layout $2 } + | 'layout' 'stop' ListString { LayoutStop $3 } + | 'layout' 'toplevel' { LayoutTop } + + +Item :: { Item } +Item : String { Terminal $1 } + | Cat { NTerminal $1 } + + +Cat :: { Cat } +Cat : '[' Cat ']' { ListCat $2 } + | Ident { IdCat $1 } + + +Label :: { Label } +Label : LabelId { LabNoP $1 } + | LabelId ListProfItem { LabP $1 $2 } + | LabelId LabelId ListProfItem { LabPF $1 $2 $3 } + | LabelId LabelId { LabF $1 $2 } + + +LabelId :: { LabelId } +LabelId : Ident { Id $1 } + | '_' { Wild } + | '[' ']' { ListE } + | '(' ':' ')' { ListCons } + | '(' ':' '[' ']' ')' { ListOne } + + +ProfItem :: { ProfItem } +ProfItem : '(' '[' ListIntList ']' ',' '[' ListInteger ']' ')' { ProfIt $3 $7 } + + +IntList :: { IntList } +IntList : '[' ListInteger ']' { Ints $2 } + + +ListInteger :: { [Integer] } +ListInteger : {- empty -} { [] } + | Integer { (:[]) $1 } + | Integer ',' ListInteger { (:) $1 $3 } + + +ListIntList :: { [IntList] } +ListIntList : {- empty -} { [] } + | IntList { (:[]) $1 } + | IntList ',' ListIntList { (:) $1 $3 } + + +ListProfItem :: { [ProfItem] } +ListProfItem : ProfItem { (:[]) $1 } + | ProfItem ListProfItem { (:) $1 $2 } + + +Separation :: { Separation } +Separation : {- empty -} { SepNone } + | 'terminator' String { SepTerm $2 } + | 'separator' String { SepSepar $2 } + + +Arg :: { Arg } +Arg : Ident { Arg $1 } + + +ListArg :: { [Arg] } +ListArg : {- empty -} { [] } + | ListArg Arg { flip (:) $1 $2 } + + +Exp :: { Exp } +Exp : Exp1 ':' Exp { Cons $1 $3 } + | Exp1 { $1 } + + +Exp1 :: { Exp } +Exp1 : Ident ListExp2 { App $1 $2 } + | Exp2 { $1 } + + +Exp2 :: { Exp } +Exp2 : Ident { Var $1 } + | Integer { LitInt $1 } + | Char { LitChar $1 } + | String { LitString $1 } + | Double { LitDouble $1 } + | '[' ListExp ']' { List $2 } + | '(' Exp ')' { $2 } + + +ListExp2 :: { [Exp] } +ListExp2 : Exp2 { (:[]) $1 } + | Exp2 ListExp2 { (:) $1 $2 } + + +ListExp :: { [Exp] } +ListExp : {- empty -} { [] } + | Exp { (:[]) $1 } + | Exp ',' ListExp { (:) $1 $3 } + + +ListString :: { [String] } +ListString : String { (:[]) $1 } + | String ',' ListString { (:) $1 $3 } + + +ListRHS :: { [RHS] } +ListRHS : RHS { (:[]) $1 } + | RHS '|' ListRHS { (:) $1 $3 } + + +RHS :: { RHS } +RHS : ListItem { RHS (reverse $1) } + + +MinimumSize :: { MinimumSize } +MinimumSize : 'nonempty' { MNonempty } + | {- empty -} { MEmpty } + + +Reg2 :: { Reg } +Reg2 : Reg2 Reg3 { RSeq $1 $2 } + | Reg3 { $1 } + + +Reg1 :: { Reg } +Reg1 : Reg1 '|' Reg2 { RAlt $1 $3 } + | Reg2 '-' Reg2 { RMinus $1 $3 } + | Reg2 { $1 } + + +Reg3 :: { Reg } +Reg3 : Reg3 '*' { RStar $1 } + | Reg3 '+' { RPlus $1 } + | Reg3 '?' { ROpt $1 } + | 'eps' { REps } + | Char { RChar $1 } + | '[' String ']' { RAlts $2 } + | '{' String '}' { RSeqs $2 } + | 'digit' { RDigit } + | 'letter' { RLetter } + | 'upper' { RUpper } + | 'lower' { RLower } + | 'char' { RAny } + | '(' Reg ')' { $2 } + + +Reg :: { Reg } +Reg : Reg1 { $1 } + + +ListIdent :: { [Ident] } +ListIdent : Ident { (:[]) $1 } + | Ident ',' ListIdent { (:) $1 $3 } + + + +{ + +returnM :: a -> Err a +returnM = return + +thenM :: Err a -> (a -> Err b) -> Err b +thenM = (>>=) + +happyError :: [Token] -> Err a +happyError ts = + Bad $ "syntax error at " ++ tokenPos ts ++ + case ts of + [] -> [] + [Err _] -> " due to lexer error" + _ -> " before " ++ unwords (map (id . prToken) (take 4 ts)) + +myLexer = tokens +} + diff --git a/src/PrintBNF.hs b/src/PrintBNF.hs new file mode 100644 --- /dev/null +++ b/src/PrintBNF.hs @@ -0,0 +1,251 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +module PrintBNF where + +-- pretty-printer generated by the BNF converter + +import AbsBNF +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 + "[" :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 (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + + +instance Print Double where + prt _ x = doc (shows x) + + +instance Print Ident where + prt _ (Ident i) = doc (showString ( i)) + prtList es = case es of + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + + + +instance Print LGrammar where + prt i e = case e of + LGr ldefs -> prPrec i 0 (concatD [prt 0 ldefs]) + + +instance Print LDef where + prt i e = case e of + DefAll def -> prPrec i 0 (concatD [prt 0 def]) + DefSome ids def -> prPrec i 0 (concatD [prt 0 ids , doc (showString ":") , prt 0 def]) + LDefView ids -> prPrec i 0 (concatD [doc (showString "views") , prt 0 ids]) + + prtList es = case es of + [] -> (concatD []) + [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 + Grammar defs -> prPrec i 0 (concatD [prt 0 defs]) + + +instance Print Def where + prt i e = case e of + Rule label cat items -> prPrec i 0 (concatD [prt 0 label , doc (showString ".") , prt 0 cat , doc (showString "::=") , prt 0 items]) + Comment str -> prPrec i 0 (concatD [doc (showString "comment") , prt 0 str]) + Comments str0 str -> prPrec i 0 (concatD [doc (showString "comment") , prt 0 str0 , prt 0 str]) + Internal label cat items -> prPrec i 0 (concatD [doc (showString "internal") , prt 0 label , doc (showString ".") , prt 0 cat , doc (showString "::=") , prt 0 items]) + Token id reg -> prPrec i 0 (concatD [doc (showString "token") , prt 0 id , prt 0 reg]) + PosToken id reg -> prPrec i 0 (concatD [doc (showString "position") , doc (showString "token") , prt 0 id , prt 0 reg]) + Entryp ids -> prPrec i 0 (concatD [doc (showString "entrypoints") , prt 0 ids]) + Separator minimumsize cat str -> prPrec i 0 (concatD [doc (showString "separator") , prt 0 minimumsize , prt 0 cat , prt 0 str]) + Terminator minimumsize cat str -> prPrec i 0 (concatD [doc (showString "terminator") , prt 0 minimumsize , prt 0 cat , prt 0 str]) + Delimiters cat str0 str separation minimumsize -> prPrec i 0 (concatD [doc (showString "delimiters") , prt 0 cat , prt 0 str0 , prt 0 str , prt 0 separation , prt 0 minimumsize]) + Coercions id n -> prPrec i 0 (concatD [doc (showString "coercions") , prt 0 id , prt 0 n]) + Rules id rhss -> prPrec i 0 (concatD [doc (showString "rules") , prt 0 id , doc (showString "::=") , prt 0 rhss]) + Function id args exp -> prPrec i 0 (concatD [doc (showString "define") , prt 0 id , prt 0 args , doc (showString "=") , prt 0 exp]) + Layout strs -> prPrec i 0 (concatD [doc (showString "layout") , prt 0 strs]) + LayoutStop strs -> prPrec i 0 (concatD [doc (showString "layout") , doc (showString "stop") , prt 0 strs]) + LayoutTop -> prPrec i 0 (concatD [doc (showString "layout") , doc (showString "toplevel")]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Item where + prt i e = case e of + Terminal str -> prPrec i 0 (concatD [prt 0 str]) + NTerminal cat -> prPrec i 0 (concatD [prt 0 cat]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print Cat where + prt i e = case e of + ListCat cat -> prPrec i 0 (concatD [doc (showString "[") , prt 0 cat , doc (showString "]")]) + IdCat id -> prPrec i 0 (concatD [prt 0 id]) + + +instance Print Label where + prt i e = case e of + LabNoP labelid -> prPrec i 0 (concatD [prt 0 labelid]) + LabP labelid profitems -> prPrec i 0 (concatD [prt 0 labelid , prt 0 profitems]) + LabPF labelid0 labelid profitems -> prPrec i 0 (concatD [prt 0 labelid0 , prt 0 labelid , prt 0 profitems]) + LabF labelid0 labelid -> prPrec i 0 (concatD [prt 0 labelid0 , prt 0 labelid]) + + +instance Print LabelId where + prt i e = case e of + Id id -> prPrec i 0 (concatD [prt 0 id]) + Wild -> prPrec i 0 (concatD [doc (showString "_")]) + ListE -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "]")]) + ListCons -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ":") , doc (showString ")")]) + ListOne -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ":") , doc (showString "[") , doc (showString "]") , doc (showString ")")]) + + +instance Print ProfItem where + prt i e = case e of + ProfIt intlists ns -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "[") , prt 0 intlists , doc (showString "]") , doc (showString ",") , doc (showString "[") , prt 0 ns , doc (showString "]") , doc (showString ")")]) + + prtList es = case es of + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print IntList where + prt i e = case e of + Ints ns -> prPrec i 0 (concatD [doc (showString "[") , prt 0 ns , 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 Separation where + prt i e = case e of + SepNone -> prPrec i 0 (concatD []) + SepTerm str -> prPrec i 0 (concatD [doc (showString "terminator") , prt 0 str]) + SepSepar str -> prPrec i 0 (concatD [doc (showString "separator") , prt 0 str]) + + +instance Print Arg where + prt i e = case e of + Arg id -> prPrec i 0 (concatD [prt 0 id]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print Exp where + prt i e = case e of + Cons exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString ":") , prt 0 exp]) + App id exps -> prPrec i 1 (concatD [prt 0 id , prt 2 exps]) + Var id -> prPrec i 2 (concatD [prt 0 id]) + LitInt n -> prPrec i 2 (concatD [prt 0 n]) + LitChar c -> prPrec i 2 (concatD [prt 0 c]) + LitString str -> prPrec i 2 (concatD [prt 0 str]) + LitDouble d -> prPrec i 2 (concatD [prt 0 d]) + List exps -> prPrec i 2 (concatD [doc (showString "[") , prt 0 exps , doc (showString "]")]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 2 x]) + x:xs -> (concatD [prt 2 x , prt 2 xs]) + +instance Print RHS where + prt i e = case e of + RHS items -> prPrec i 0 (concatD [prt 0 items]) + + prtList es = case es of + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) + +instance Print MinimumSize where + prt i e = case e of + MNonempty -> prPrec i 0 (concatD [doc (showString "nonempty")]) + MEmpty -> prPrec i 0 (concatD []) + + +instance Print Reg where + prt i e = case e of + RSeq reg0 reg -> prPrec i 2 (concatD [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concatD [prt 1 reg0 , doc (showString "|") , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concatD [prt 2 reg0 , doc (showString "-") , prt 2 reg]) + RStar reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "*")]) + RPlus reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "+")]) + ROpt reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "?")]) + REps -> prPrec i 3 (concatD [doc (showString "eps")]) + RChar c -> prPrec i 3 (concatD [prt 0 c]) + RAlts str -> prPrec i 3 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")]) + RSeqs str -> prPrec i 3 (concatD [doc (showString "{") , prt 0 str , doc (showString "}")]) + RDigit -> prPrec i 3 (concatD [doc (showString "digit")]) + RLetter -> prPrec i 3 (concatD [doc (showString "letter")]) + RUpper -> prPrec i 3 (concatD [doc (showString "upper")]) + RLower -> prPrec i 3 (concatD [doc (showString "lower")]) + RAny -> prPrec i 3 (concatD [doc (showString "char")]) + + + diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs new file mode 100644 --- /dev/null +++ b/src/TypeChecker.hs @@ -0,0 +1,146 @@ + +module TypeChecker where + +import Control.Monad +import Data.List +import Data.Char + +import CF +import ErrM + +data Base = BaseT String + | ListT Base + deriving (Eq) + +data Type = FunT [Base] Base + deriving (Eq) + +instance Show Base where + show (BaseT x) = x + show (ListT t) = "[" ++ show t ++ "]" + +instance Show Type where + show (FunT ts t) = unwords $ map show ts ++ ["->", show t] + +data Context = Ctx { ctxLabels :: [(String, Type)] + , ctxTokens :: [String] + } + +catchErr :: Err a -> (String -> Err a) -> Err a +catchErr (Bad s) f = f s +catchErr (Ok x) _ = Ok x + +buildContext :: CF -> Context +buildContext cf@(CFG(_,rules)) = + Ctx + [ (f, mkType cat args) | Rule f cat args <- rules + , not (isCoercion f) + , not (isNilCons f) + ] + ("Ident" : tokenNames cf) + where + + mkType cat args = FunT [ mkBase t | Left t <- args, t /= internalCat ] + (mkBase cat) + mkBase t + | isList t = ListT $ mkBase $ normCatOfList t + | otherwise = BaseT $ normCat t + +isToken :: String -> Context -> Bool +isToken x ctx = elem x $ ctxTokens ctx + +extendContext :: Context -> [(String,Type)] -> Context +extendContext ctx xs = ctx { ctxLabels = xs ++ ctxLabels ctx } + +lookupCtx :: String -> Context -> Err Type +lookupCtx x ctx + | isToken x ctx = return $ FunT [BaseT "String"] (BaseT x) + | otherwise = + case lookup x $ ctxLabels ctx of + Nothing -> fail $ "Undefined symbol '" ++ x ++ "'." + Just t -> return t + +checkDefinitions :: CF -> Err () +checkDefinitions cf = + do checkContext ctx + sequence_ [checkDefinition ctx f xs e | FunDef f xs e <- pragmasOfCF cf] + where + ctx = buildContext cf + +checkContext :: Context -> Err () +checkContext ctx = + mapM_ checkEntry $ groupSnd $ ctxLabels ctx + where + -- This is a very handy function which transforms a lookup table + -- with duplicate keys to a list valued lookup table with no duplicate + -- keys. + groupSnd :: Ord a => [(a,b)] -> [(a,[b])] + groupSnd = + map ((fst . head) /\ map snd) + . groupBy ((==) **.* fst) + . sortBy (compare **.* fst) + + (f /\ g) x = (f x, g x) + (f **.* g) x y = f (g x) (g y) + + checkEntry (f,ts) = + case nub ts of + [_] -> return () + ts' -> + fail $ "The symbol '" ++ f ++ "' is used at conflicting types:\n" ++ + unlines (map ((" " ++) . show) ts') + +checkDefinition :: Context -> String -> [String] -> Exp -> Err () +checkDefinition ctx f xs e = + do checkDefinition' dummyConstructors ctx f xs e + return () + +data ListConstructors = LC + { nil :: Base -> String + , cons :: Base -> String + } + +dummyConstructors :: ListConstructors +dummyConstructors = LC (const "[]") (const "(:)") + +checkDefinition' :: ListConstructors -> Context -> String -> [String] -> Exp -> Err ([(String,Base)],(Exp,Base)) +checkDefinition' list ctx f xs e = + do unless (isLower $ head f) $ fail "Defined functions must start with a lowercase letter." + t@(FunT ts t') <- lookupCtx f ctx `catchErr` \_ -> + fail $ "'" ++ f ++ "' must be used in a rule." + let expect = length ts + given = length xs + unless (expect == given) $ fail $ "'" ++ f ++ "' is used with type " ++ show t ++ " but defined with " ++ show given ++ " argument" ++ plural given ++ "." + e' <- checkExp list (extendContext ctx $ zip xs (map (FunT []) ts)) e t' + return (zip xs ts, (e', t')) + `catchErr` \err -> fail $ "In the definition " ++ unwords (f : xs ++ ["=",show e,";"]) ++ "\n " ++ err + where + plural 1 = "" + plural _ = "s" + +checkExp :: ListConstructors -> Context -> Exp -> Base -> Err Exp +checkExp list ctx (App "[]" []) (ListT t) = return (App (nil list t) []) +checkExp _ _ (App "[]" _) _ = fail $ "[] is applied to too many arguments." +checkExp list ctx (App "(:)" [e,es]) (ListT t) = + do e' <- checkExp list ctx e t + es' <- checkExp list ctx es (ListT t) + return $ App (cons list t) [e',es'] +checkExp _ _ (App "(:)" es) _ = fail $ "(:) takes 2 arguments, but has been given " ++ show (length es) ++ "." +checkExp list ctx e@(App x es) t = + do FunT ts t' <- lookupCtx x ctx + es' <- matchArgs ctx es ts + unless (t == t') $ fail $ show e ++ " has type " ++ show t' ++ ", but something of type " ++ show t ++ " was expected." + return $ App x es' + where + matchArgs ctx es ts + | expect /= given = fail $ "'" ++ x ++ "' takes " ++ show expect ++ " arguments, but has been given " ++ show given ++ "." + | otherwise = zipWithM (checkExp list ctx) es ts + where + expect = length ts + given = length es +checkExp _ _ e@(LitInt _) (BaseT "Integer") = return e +checkExp _ _ e@(LitDouble _) (BaseT "Double") = return e +checkExp _ _ e@(LitChar _) (BaseT "Char") = return e +checkExp _ _ e@(LitString _) (BaseT "String") = return e +checkExp _ _ e t = fail $ show e ++ " does not have type " ++ show t ++ "." + diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,168 @@ +{- + BNF Converter: Abstract syntax + Copyright (C) 2004 Author: Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Utils where + +import Control.Monad (unless) +import System.IO.Error (tryIOError) +import System.Directory (createDirectory, doesDirectoryExist, renameFile, + removeFile, doesFileExist) + +infixr 5 +++ +infixr 5 ++++ +infixr 5 +++++ +infixr 2 ||| +infixr 5 ... +infixr 3 *** + + +-- printing operations + +a +++ b = a ++ " " ++ b +a ++++ b = a ++ "\n" ++ b +a +++++ b = a ++ "\n\n" ++ b + +prParenth s = if s == "" then "" else "(" ++ s ++ ")" + + +-- parser combinators a` la Wadler and Hutton + +type Parser a b = [a] -> [(b,[a])] + +(...) :: Parser a b -> Parser a c -> Parser a (b,c) +(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t] + +(|||) :: Parser a b -> Parser a b -> Parser a b +(p ||| q) s = p s ++ q s + +lit :: (Eq a) => a -> Parser a a +lit x (c:cs) = [(x,cs) | x == c] +lit _ _ = [] + +(***) :: Parser a b -> (b -> c) -> Parser a c +(p *** f) s = [(f x,r) | (x,r) <- p s] + +succeed :: b -> Parser a b +succeed v s = [(v,s)] + +fails :: Parser a b +fails s = [] + +-- to get parse results + +parseResults :: Parser a b -> [a] -> [b] +parseResults p s = [x | (x,r) <- p s, null r] + + +-- * List utilities + +-- | Replace all occurences of a value by another value +replace :: Eq a => + a -- ^ Value to replace + -> a -- ^ Value to replace it with + -> [a] -> [a] +replace x y xs = [ if z == x then y else z | z <- xs] + +-- | Split a list on the first occurence of a value. +-- Does not include the value that was split on in either +-- of the returned lists. +split :: Eq a => a -> [a] -> ([a],[a]) +split x xs = let (ys, zs) = break (==x) xs + in (ys, drop 1 zs) + +-- | Split a list on every occurence of a value. +-- If the value does not occur in the list, +-- the result is the singleton list containing the input list. +-- Thus the returned list is never the empty list. +splitAll :: Eq a => a -> [a] -> [[a]] +splitAll _ [] = [[]] +splitAll x xs = let (ys, zs) = break (==x) xs + in ys : case zs of + [] -> [] + _:zs' -> splitAll x zs' + +-- * File utilities + +-- | Ensure that a directory exists. +prepareDir :: FilePath -> IO () +prepareDir = mapM_ createDirectoryIfNotExists . pathInits + +-- | Ensure that a directory exists. All parent directories +-- must already exist. +createDirectoryIfNotExists :: FilePath -> IO () +createDirectoryIfNotExists d = do + exists <- doesDirectoryExist d + unless exists (createDirectory d) + +pathSep :: Char +pathSep = '/' + +-- | Like the prelude function 'inits' but for path names. +-- For example: +-- > pathInits "foo/bar" = ["foo","foo/bar"] +-- > pathInits "foo/bar/baz.hs" = ["foo","foo/bar","foo/bar/baz.hs"] +pathInits :: String -> [String] +pathInits "" = [] +pathInits xs = let (ys,zs) = split pathSep xs + in ys : map ((ys ++ [pathSep]) ++) (pathInits zs) + +-- | Like basename(1), remove all leading directories from a path name. +basename :: String -> String +basename = last . splitAll pathSep + + +-- | Write a file, after making a backup of an existing file with the same name. +writeFileRep :: FilePath -> String -> IO () +writeFileRep = writeFileRep2 + +-- peteg: FIXME this is racey. +-- want to be a bit smarter about whether we actually generate the file +-- or save it... e.g. ErrM.hs need not be regenerated if it exists. +writeFileRep1 f s = + do exists <- doesFileExist f + backedUp <- if exists + then do let fbak = f ++ ".bak" + renameFile f fbak + return $ " (saving old file as " ++ fbak ++ ")" + else return "" + putStrLn $ "writing file " ++ f ++ backedUp + writeFile f s + +-- New version by TH, 2010-09-23 +-- If an old version of the file exist and the new version is the same, +-- keep the old file and don't create a .bak file. +writeFileRep2 :: FilePath -> String -> IO () +writeFileRep2 path s = + either newFile updateFile =<< tryIOError (readFile path) + where + newFile _ = + do putStrLn $ "writing new file "++path + writeFile path s + updateFile old = + do let tmp=path++".tmp" + writeFile tmp s + new <- readFile tmp + if new==old -- test is O(1) space, O(n) time + then do putStrLn $ "no change to file "++path + removeFile tmp + else do let bak=path++".bak" + putStrLn $ "writing file "++path + ++" (saving old file as "++bak++")" + renameFile path bak + renameFile tmp path diff --git a/src/formats/CFtoLatex.hs b/src/formats/CFtoLatex.hs new file mode 100644 --- /dev/null +++ b/src/formats/CFtoLatex.hs @@ -0,0 +1,276 @@ +{- + BNF Converter: Latex Generator + Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoLatex (cfToLatex)where + +import CF +import AbsBNF (Reg (..)) +import Utils +import Data.List (nub,intersperse) + +cfToLatex :: String -> CF -> String +cfToLatex name cf = unlines [ + "\\batchmode", + beginDocument name, + macros, + introduction, + prtTerminals name cf, + prtBNF name cf, + endDocument + ] + +introduction :: String +introduction = concat + [ + "\nThis document was automatically generated by ", + "the {\\em BNF-Converter}.", + " It was generated together with the lexer, the parser, and the", + " abstract syntax module, which guarantees that the document", + " matches with the implementation of the language (provided no", + " hand-hacking has taken place).\n" + ] + +prtTerminals :: String -> CF -> String +prtTerminals name cf = unlines [ + "\\section*{The lexical structure of " ++ name ++ "}", + identSection cf, + "\\subsection*{Literals}", + prtLiterals name cf, + unlines (map prtOwnToken (tokenPragmas cf)), + "\\subsection*{Reserved words and symbols}", + prtReserved name cf, + prtSymb name cf, + "\\subsection*{Comments}", + prtComments $ comments cf + ] + +identSection cf = if not (hasIdent cf) then [] else + unlines [ + "\\subsection*{Identifiers}", + prtIdentifiers + ] + +prtIdentifiers :: String +prtIdentifiers = unlines + [ + "Identifiers \\nonterminal{Ident} are unquoted strings beginning with a letter,", + "followed by any combination of letters, digits, and the characters {\\tt \\_ '},", + "reserved words excluded." + ] + +prtLiterals :: String -> CF -> String +prtLiterals name cf = + unlines $ map stringLit $ + filter (`notElem` ["Ident"]) $ + literals cf + +stringLit :: String -> String +stringLit cat = unlines $ case cat of + "Char" -> ["Character literals \\nonterminal{Char}\\ have the form", + "\\terminal{'}$c$\\terminal{'}, where $c$ is any single character.", + "" + ] + "String" -> ["String literals \\nonterminal{String}\\ have the form", + "\\terminal{\"}$x$\\terminal{\"}, where $x$ is any sequence of any characters", + "except \\terminal{\"}\\ unless preceded by \\verb6\\6.", + ""] + "Integer" -> ["Integer literals \\nonterminal{Int}\\ are nonempty sequences of digits.", + ""] + "Double" -> ["Double-precision float literals \\nonterminal{Double}\\ have the structure", + "indicated by the regular expression" +++ + "$\\nonterminal{digit}+ \\mbox{{\\it `.'}} \\nonterminal{digit}+ (\\mbox{{\\it `e'}} \\mbox{{\\it `-'}}? \\nonterminal{digit}+)?$ i.e.\\", + "two sequences of digits separated by a decimal point, optionally", + "followed by an unsigned or negative exponent.", + ""] + _ -> [] + +prtOwnToken (name,reg) = unlines + [name +++ "literals are recognized by the regular expression", + "\\(" ++ + latexRegExp reg ++ + "\\)" + ] + +prtComments :: ([(String,String)],[String]) -> String +prtComments (xs,ys) = concat + [ + if (null ys) then + "There are no single-line comments in the grammar. \\\\" + else + "Single-line comments begin with " ++ sing ++". \\\\", + if (null xs) then + "There are no multiple-line comments in the grammar." + else + "Multiple-line comments are enclosed with " ++ mult ++"." + ] + where + sing = concat $ intersperse ", " $ map (symbol.prt) ys + mult = concat $ intersperse ", " $ + map (\(x,y) -> (symbol (prt x)) + ++ " and " ++ + (symbol (prt y))) xs + +prtSymb :: String -> CF -> String +prtSymb name cf = case symbols cf of + [] -> "\nThere are no symbols in " ++ name ++ ".\\\\\n" + xs -> "The symbols used in " ++ name ++ " are the following: \\\\\n" + ++ + (tabular 3 $ three $ map (symbol.prt) xs) + +prtReserved :: String -> CF -> String +prtReserved name cf = case reservedWords cf of + [] -> stringRes name ++ + "\nThere are no reserved words in " ++ name ++ ".\\\\\n" + xs -> stringRes name ++ + (tabular 3 $ three $ map (reserved.prt) xs) + +stringRes :: String -> String +stringRes name = concat + ["The set of reserved words is the set of terminals ", + "appearing in the grammar. Those reserved words ", + "that consist of non-letter characters are called symbols, and ", + "they are treated in a different way from those that ", + "are similar to identifiers. The lexer ", + "follows rules familiar from languages ", + "like Haskell, C, and Java, including longest match ", + "and spacing conventions.", + "\n\n", + "The reserved words used in " ++ name ++ " are the following: \\\\\n"] + +three :: [String] -> [[String]] +three [] = [] +three [x] = [[x,[],[]]] +three [x,y] = [[x,y,[]]] +three (x:y:z:xs) = [x,y,z] : three xs + +prtBNF :: String -> CF -> String +prtBNF name cf = unlines [ + "\\section*{The syntactic structure of " ++ name ++"}", + "Non-terminals are enclosed between $\\langle$ and $\\rangle$. ", + "The symbols " ++ arrow ++ " (production), " ++ + delimiter ++" (union) ", + "and " ++ empty ++ " (empty rule) belong to the BNF notation. ", + "All other symbols are terminals.\\\\", + prtRules (ruleGroups cf) + ] + +prtRules :: [(Cat,[Rule])] -> String +prtRules [] = [] +prtRules ((c,[]):xs) + = tabular 3 [[nonterminal c,arrow,[]]] ++ prtRules xs +prtRules ((c,(r:rs)):xs) + = tabular 3 ([[nonterminal c,arrow,prtSymbols $ rhsRule r]] ++ + [[[],delimiter,prtSymbols (rhsRule y)] | y <- rs]) ++ + prtRules xs + +prtSymbols :: [Either Cat String] -> String +prtSymbols [] = empty +prtSymbols xs = foldr (+++) [] (map p xs) + where p (Left r) = nonterminal r --- (prt r) + p (Right r) = terminal (prt r) + +prt :: String -> String +prt [] = [] +prt (c:xs) + | elem c "$&%#_{}^" = "\\" ++ [c] ++ prt xs + | elem c "+=|<>-" = "{$" ++ [c] ++ "$}" ++ prt xs + | c == '\\' = "$\\backslash$" + | c == '~' = "\\~{}" + | otherwise = c : prt xs + +macros :: String +macros = + "\\newcommand{\\emptyP}{\\mbox{$\\epsilon$}}" ++++ + "\\newcommand{\\terminal}[1]{\\mbox{{\\texttt {#1}}}}" ++++ + "\\newcommand{\\nonterminal}[1]{\\mbox{$\\langle \\mbox{{\\sl #1 }} \\! \\rangle$}}" ++++ + "\\newcommand{\\arrow}{\\mbox{::=}}" ++++ + "\\newcommand{\\delimit}{\\mbox{$|$}}" ++++ + "\\newcommand{\\reserved}[1]{\\mbox{{\\texttt {#1}}}}" ++++ + "\\newcommand{\\literal}[1]{\\mbox{{\\texttt {#1}}}}" ++++ + "\\newcommand{\\symb}[1]{\\mbox{{\\texttt {#1}}}}" + +reserved :: String -> String +reserved s = "{\\reserved{" ++ s ++ "}}" + +literal :: String -> String +literal s = "{\\literal{" ++ s ++ "}}" + +empty :: String +empty = "{\\emptyP}" + +symbol :: String -> String +symbol s = "{\\symb{" ++ s ++ "}}" + +tabular :: Int -> [[String]] -> String +tabular n xs = "\n\\begin{tabular}{" ++ concat (replicate n "l") ++ "}\n" ++ + concat (map (\(a:as) -> foldr (+++) "\\\\\n" (a:(map ('&':) as))) xs) ++ + "\\end{tabular}\\\\\n" + +terminal :: String -> String +terminal s = "{\\terminal{" ++ s ++ "}}" + +nonterminal :: String -> String +nonterminal s = "{\\nonterminal{" ++ identCat (mkId s) ++ "}}" where + mkId = map mk + mk c = case c of + '_' -> '-' --- + _ -> c + + +arrow :: String +arrow = " {\\arrow} " + +delimiter :: String +delimiter = " {\\delimit} " + +beginDocument :: String -> String +beginDocument name = + "%This Latex file is machine-generated by the BNF-converter\n" ++++ + "\\documentclass[a4paper,11pt]{article}" ++++ + "\\author{BNF-converter}" ++++ + "\\title{The Language " ++ name ++ "}" ++++ + -- "\\usepackage{isolatin1}" ++++ + "\\setlength{\\parindent}{0mm}" ++++ + "\\setlength{\\parskip}{1mm}" ++++ + "\\begin{document}\n" ++++ + "\\maketitle\n" + +endDocument :: String +endDocument = + "\n\\end{document}\n" + +latexRegExp :: Reg -> String +latexRegExp = rex (0 :: Int) where + rex i e = case e of + RSeq reg0 reg -> ifPar i 2 $ rex 2 reg0 +++ rex 2 reg + RAlt reg0 reg -> ifPar i 1 $ rex 1 reg0 +++ "\\mid" +++ rex 1 reg + RMinus reg0 reg -> ifPar i 1 $ rex 2 reg0 +++ "-" +++ rex 2 reg + RStar reg -> rex 3 reg ++ "*" + RPlus reg -> rex 3 reg ++ "+" + ROpt reg -> rex 3 reg ++ "?" + REps -> "\\epsilon" + RChar c -> "\\mbox{`" ++ prt [c] ++ "'}" + RAlts str -> "[" ++ "\\mbox{``" ++ prt str ++ "''}" ++ "]" + RSeqs str -> "\\{" ++ "\\mbox{``" ++ prt str ++ "''}" ++ "\\}" + RDigit -> "{\\nonterminal{digit}}" + RLetter -> "{\\nonterminal{letter}}" + RUpper -> "{\\nonterminal{upper}}" + RLower -> "{\\nonterminal{lower}}" + RAny -> "{\\nonterminal{anychar}}" + ifPar i j s = if i > j then "(" ++ s ++ ")" else s diff --git a/src/formats/CFtoTxt.hs b/src/formats/CFtoTxt.hs new file mode 100644 --- /dev/null +++ b/src/formats/CFtoTxt.hs @@ -0,0 +1,249 @@ +{- + BNF Converter: Latex Generator + Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoTxt (cfToTxt)where + +import CF +import AbsBNF (Reg (..)) +import Utils +import Data.List (nub,intersperse) + +cfToTxt :: String -> CF -> String +cfToTxt name cf = unlines [ + beginDocument name, + introduction, + prtTerminals name cf, + prtBNF name cf + ] + +introduction :: String +introduction = concat + [ + "\nThis document was automatically generated by ", + "the //BNF-Converter//.", + " It was generated together with the lexer, the parser, and the", + " abstract syntax module, which guarantees that the document", + " matches with the implementation of the language (provided no", + " hand-hacking has taken place).\n" + ] + +prtTerminals :: String -> CF -> String +prtTerminals name cf = unlines [ + "==The lexical structure of " ++ name ++ "==", + identSection cf, + "===Literals===", + prtLiterals name cf, + unlines (map prtOwnToken (tokenPragmas cf)), + "===Reserved words and symbols===", + prtReserved name cf, + prtSymb name cf, + "===Comments===", + prtComments $ comments cf + ] + +identSection cf = if not (hasIdent cf) then [] else + unlines [ + "===Identifiers===", + prtIdentifiers + ] + +prtIdentifiers :: String +prtIdentifiers = unlines + [ + "Identifiers //Ident// are unquoted strings beginning with a letter,", + "followed by any combination of letters, digits, and the characters ``_ '``", + "reserved words excluded." + ] + +prtLiterals :: String -> CF -> String +prtLiterals name cf = + unlines $ map stringLit $ + filter (`notElem` ["Ident"]) $ + literals cf + +stringLit :: String -> String +stringLit cat = unlines $ case cat of + "Char" -> ["Character literals //Char// have the form", + "``'``//c//``'``, where //c// is any single character.", + "" + ] + "String" -> ["String literals //String// have the form", + "``\"``//x//``\"``}, where //x// is any sequence of any characters", + "except ``\"`` unless preceded by ``\\``.", + ""] + "Integer" -> ["Integer literals //Integer// are nonempty sequences of digits.", + ""] + "Double" -> ["Double-precision float literals //Double// have the structure", + "indicated by the regular expression" +++ + "``digit+ '.' digit+ ('e' ('-')? digit+)?`` i.e.\\", + "two sequences of digits separated by a decimal point, optionally", + "followed by an unsigned or negative exponent.", + ""] + _ -> [] + +prtOwnToken (name,reg) = unlines + [name +++ "literals are recognized by the regular expression", + "```" ++ + latexRegExp reg ++ + "```" + ] + +prtComments :: ([(String,String)],[String]) -> String +prtComments (xs,ys) = concat + [ + if (null ys) then + "There are no single-line comments in the grammar." + else + "Single-line comments begin with " ++ sing ++".", + if (null xs) then + "There are no multiple-line comments in the grammar." + else + "Multiple-line comments are enclosed with " ++ mult ++"." + ] + where + sing = concat $ intersperse ", " $ map (symbol.prt) ys + mult = concat $ intersperse ", " $ + map (\(x,y) -> (symbol (prt x)) + ++ " and " ++ + (symbol (prt y))) xs + +prtSymb :: String -> CF -> String +prtSymb name cf = case symbols cf of + [] -> "\nThere are no symbols in " ++ name ++ ".\n" + xs -> "The symbols used in " ++ name ++ " are the following:\n" + ++ + (tabular 4 $ three $ map (symbol.prt) xs) + +prtReserved :: String -> CF -> String +prtReserved name cf = case reservedWords cf of + [] -> stringRes name ++ + "\nThere are no reserved words in " ++ name ++ ".\n" + xs -> stringRes name ++ + (tabular 4 $ three $ map quote xs) + +stringRes :: String -> String +stringRes name = concat + ["The set of reserved words is the set of terminals ", + "appearing in the grammar. Those reserved words ", + "that consist of non-letter characters are called symbols, and ", + "they are treated in a different way from those that ", + "are similar to identifiers. The lexer ", + "follows rules familiar from languages ", + "like Haskell, C, and Java, including longest match ", + "and spacing conventions.", + "\n\n", + "The reserved words used in " ++ name ++ " are the following:\n"] + +three :: [String] -> [[String]] +three [] = [] +three [x] = [[x,[],[],[]]] +three [x,y] = [[x,y,[],[]]] +three [x,y,z] = [[x,y,z,[]]] +three (x:y:z:u:xs) = [x,y,z,u] : three xs + +prtBNF :: String -> CF -> String +prtBNF name cf = unlines [ + "==The syntactic structure of " ++ name ++"==", + "Non-terminals are enclosed between < and >. ", + "The symbols " ++ arrow ++ " (production), " ++ + delimiter ++" (union) ", + "and " ++ empty ++ " (empty rule) belong to the BNF notation. ", + "All other symbols are terminals.", + "", + prtRules (ruleGroups cf) + ] + +prtRules :: [(Cat,[Rule])] -> String +prtRules [] = [] +prtRules ((c,[]):xs) + = tabular 3 [[nonterminal c,arrow,[]]] ++ prtRules xs +prtRules ((c,(r:rs)):xs) + = tabular 3 ([[nonterminal c,arrow,prtSymbols $ rhsRule r]] ++ + [[[],delimiter,prtSymbols (rhsRule y)] | y <- rs]) ++ + --- "\n\n" ++ --- with empty lines good for latex, bad for html + prtRules xs + +prtSymbols :: [Either Cat String] -> String +prtSymbols [] = empty +prtSymbols xs = foldr (+++) [] (map p xs) + where p (Left r) = nonterminal r + p (Right r) = terminal r + +prt :: String -> String +prt s = s + +reserved :: String -> String +reserved s = "{\\reserved{" ++ s ++ "}}" + +literal :: String -> String +literal s = "{\\literal{" ++ s ++ "}}" + +empty :: String +empty = "**eps**" + +symbol :: String -> String +symbol s = s + +tabular :: Int -> [[String]] -> String +tabular n xs = unlines [unwords (intersperse "|" (" " : x)) | x <- xs] + +terminal :: String -> String +terminal s = "``" ++ s ++ "``" + +nonterminal :: String -> String +nonterminal s = "//" ++ s ++ "//" + +arrow :: String +arrow = "->" + +delimiter :: String +delimiter = " **|** " + +beginDocument :: String -> String +beginDocument name = unlines [ + "The Language " ++ name, + "BNF Converter", + "", + "", + "%This txt2tags file is machine-generated by the BNF-converter", + "%Process by txt2tags to generate html or latex", + "" + ] + +latexRegExp :: Reg -> String +latexRegExp = quote . rex (0 :: Int) where + rex i e = case e of + RSeq reg0 reg -> ifPar i 2 $ rex 2 reg0 +++ rex 2 reg + RAlt reg0 reg -> ifPar i 1 $ rex 1 reg0 +++ "|" +++ rex 1 reg + RMinus reg0 reg -> ifPar i 1 $ rex 2 reg0 +++ "-" +++ rex 2 reg + RStar reg -> rex 3 reg ++ "*" + RPlus reg -> rex 3 reg ++ "+" + ROpt reg -> rex 3 reg ++ "?" + REps -> "eps" + RChar c -> "'" ++ [c] ++ "'" + RAlts str -> "[\"" ++ str ++ "\"]" + RSeqs str -> "{\"" ++ str ++ "\"}" + RDigit -> "digit" + RLetter -> "letter" + RUpper -> "upper" + RLower -> "lower" + RAny -> "char" + ifPar i j s = if i > j then "(" ++ s ++ ")" else s + +quote s = "``" ++ s ++ "``" diff --git a/src/formats/NamedVariables.hs b/src/formats/NamedVariables.hs new file mode 100644 --- /dev/null +++ b/src/formats/NamedVariables.hs @@ -0,0 +1,109 @@ + +{- + BNF Converter: Named instance variables + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +{- + ************************************************************** + BNF Converter Module + + Description : This module provides support for languages which need + named instance variables. (IE Java, C, C++) It provides + a data type to represent the name mapping and utility + functions to work with it. + + Variables are grouped and numbered in a nice way. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + ************************************************************** +-} + +module NamedVariables where + +import CF +import Data.Char (toLower) +import Data.List (nub) + +type IVar = (String, Int) +--The type of an instance variable +--and a # unique to that type + +type UserDef = String --user-defined types + + +--A symbol-mapping environment. +type SymEnv = [(String, String)] + +--Converts a list of categories into their types to be used as instance variables. +getVars :: [Cat] -> [IVar] +getVars [] = [] +getVars cs = foldl addVar [] (map identCat cs) + where + addVar vs c = addVar' vs 0 c + addVar' [] n c = [(c, n)] + addVar' (i@(t,x):is) n c = + if c == t + then if x == 0 + then (t, 1) : (addVar' is 2 c) + else i : (addVar' is (x+1) c) + else i : (addVar' is n c) + +--Given a rule's definition, it goes through and nicely the variables by type. +numVars :: [(String, Int)] -> [Either String b] -> [Either String b] +numVars _env [] = [] +numVars env ((Right f) : fs) = (Right f) : (numVars env fs) +numVars env ((Left f) : fs) = + case lookup f' env of + Nothing -> (Left f') : (numVars ((f',1):env) fs) + Just n -> (Left $ f' ++ (show $ n + 1)) : (numVars ((f',n+1):env) fs) + where + f' = varName (normCat (identCat f)) + +--This makes numbers a little nicer. +--If there's only one variable of a type we drop the redundant _1 label. +--(Actually here we add _1 labels to variables that need it, but the effect +-- is the same.) +fixOnes [] = [] +fixOnes ((Right f): fs) = (Right f) : (fixOnes fs) +fixOnes ((Left f) : fs) = + if elem (Left (f ++ "2")) fs + then (Left (f ++ "1")) : (fixOnes fs) + else (Left f) : (fixOnes fs) + +--This fixes the problem with coercions. +fixCoercions :: [(Cat, [Rule])] -> [(Cat, [Rule])] +fixCoercions rs = nub (fixAll rs rs) + where + fixCoercion :: Cat -> [(Cat, [Rule])] -> [Rule] + fixCoercion _ [] = [] + fixCoercion cat ((c,rules):cats) = if (normCat c) == (normCat cat) + then rules ++ (fixCoercion cat cats) + else fixCoercion cat cats + fixAll :: [(Cat, [Rule])] -> [(Cat, [Rule])] -> [(Cat, [Rule])] + fixAll _ [] = [] + fixAll top ((cat,rules):cats) = if isCoercion cat + then fixAll top cats + else (normCat cat, fixCoercion cat top) : (fixAll top cats) + +--A generic variable name for C-like languages. +varName c = (map toLower c) ++ "_" + +--this makes var names a little cleaner. +showNum n = if n == 0 then [] else (show n) diff --git a/src/formats/OOAbstract.hs b/src/formats/OOAbstract.hs new file mode 100644 --- /dev/null +++ b/src/formats/OOAbstract.hs @@ -0,0 +1,129 @@ +{- + BNF Converter: Datastructure for object-oriented abstract syntax generators + Copyright (C) 2006 Author: Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module defines a data structure that is + used for generating abstract syntax in cpp_stl. + It should be used in other STL modules as well, + and could be used for object-oriented languages + in general, to avoid duplicated work. + + Author : Aarne Ranta (aarne@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 29 August, 2006 + + Modified : 29 August, 2006 / Aarne Ranta + + + ************************************************************** +-} + +module OOAbstract where + +import CF +import Utils((+++),(++++)) +import NamedVariables +import Data.List +import Data.Char(toLower) + +-- A datastructure more appropriate than CF + +data CAbs = CAbs { + tokentypes :: [Cat], -- user non-position token types + listtypes :: [(Cat,Bool)], -- list types used, whether of classes + absclasses :: [Cat], -- grammar-def cats, normalized names + conclasses :: [Fun], -- constructors, except list ones + signatures :: [(Cat,[CAbsRule])], -- rules for each class, incl. pos tokens + postokens :: [Cat], -- position token types + defineds :: [Fun] -- defined (non-)constructors + } + +-- (valcat,(constr,args)), True = is class (not basic), class variable stored +type CAbsRule = (Fun,[(Cat,Bool,String)]) + +-- all those names that denote classes in C++ +allClasses :: CAbs -> [Cat] +allClasses ca = + absclasses ca ++ conclasses ca ++ map fst (listtypes ca) ++ postokens ca + +-- all those names that denote non-class types in C++ +allNonClasses :: CAbs -> [Cat] +allNonClasses ca = + map fst basetypes ++ tokentypes ca + +cf2cabs :: CF -> CAbs +cf2cabs cf = CAbs { + tokentypes = toks, + listtypes = [(c, snd (status (drop 4 c))) | -- remove "List" from "ListC" + c <- map (normCat . identCat) lists], + absclasses = nub $ map normCat cats, + conclasses = [f | Just f <- map testRule (rulesOfCF cf)], + signatures = posdata ++ map normSig (cf2data cf), + postokens = pos, + defineds = defs + } + where + (pos,base) = partition (isPositionCat cf) $ fst (unzip (tokenPragmas cf)) + (lists,cats) = partition isList $ allCats cf + toks = map normCat base + testRule (Rule f c r) + | isList c = Nothing + | f == "_" = Nothing + | otherwise = Just f + normSig (c,fcs) = + (identCat c,[(f, classVars (map (status . identCat) cs)) | (f,cs) <- fcs]) + posdata = + [("Visitable", -- to give superclass + [(c,[("String",False,"string_"),("Integer",False,"integer_")])]) | c<-pos] + status cat = (cat, notElem cat (map fst basetypes ++ toks)) + defs = [f | FunDef f _ _ <- pragmasOfCF cf] + + classVars :: [(Cat,Bool)] -> [(Cat,Bool,String)] + classVars cs = + [(c,b,s) | ((c,b),s) <- zip cs (vars [] (map (classVar . fst) cs))] + --- creating new names is quadratic, but parameter lists are short + --- this should conform with Michael's naming + vars seen vv = case vv of + [] -> vv + v:vs -> case length (filter (==v) seen) of + 0 | elem v vs -> (v ++ "1"): vars (v:seen) vs + 0 -> v : vars (v:seen) vs + n -> (v ++ show (n+1)) : vars (v:seen) vs + +basetypes = [ + ("Integer","int"), + ("Char", "char"), + ("Double", "double"), + ("String", "std::string"), + ("Ident", "std::string") + ] + +isBaseType :: CAbs -> Cat -> Bool +isBaseType cf c = elem c $ tokentypes cf ++ map fst basetypes + +classVar :: Cat -> String +classVar c = map toLower c ++ "_" + +pointerIf :: Bool -> String -> String +pointerIf b v = if b then "*" ++ v else v diff --git a/src/formats/c-sharp/CAbstoCSharpAbs.hs b/src/formats/c-sharp/CAbstoCSharpAbs.hs new file mode 100644 --- /dev/null +++ b/src/formats/c-sharp/CAbstoCSharpAbs.hs @@ -0,0 +1,277 @@ +{- + BNF Converter: C# Abstract Syntax Generator + Copyright (C) 2006-2007 Author: Johan Broberg + + Modified from CFtoSTLAbs + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C# Abstract Syntax + tree classes. It uses the Visitor design + pattern. + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 22 November, 2006 + + Modified : 21 January, 2007 by Johan Broberg + + ************************************************************** +-} + +module CAbstoCSharpAbs (cabs2csharpabs) where + +import OOAbstract +import CF +import Utils((+++),(++++)) +import NamedVariables +import Data.List +import Data.Char(toLower) +import Data.Maybe +import CSharpUtils + +--The result is one file (.cs) + +cabs2csharpabs :: Namespace -> CAbs -> Bool -> String +cabs2csharpabs namespace cabs useWCF = unlinesInline [ + "//C# Abstract Syntax Interface generated by the BNF Converter.", + -- imports + "using System;", + if useWCF then "using System.Runtime.Serialization;" else "", + "using System.Collections.Generic;", + "namespace " ++ namespace ++ ".Absyn", + "{", + " #region Token Classes", + prTokenBaseType useWCF, + unlinesInlineMap (prToken namespace useWCF) (tokentypes cabs), + " #endregion", + " ", + " #region Abstract Syntax Classes", + unlinesInlineMap (prAbs namespace useWCF) abstractclasses, + " ", + unlinesInlineMap (prCon namespace useWCF) (flattenSignatures cabs), + " ", + " #region Lists", + unlinesInlineMap (prList namespace) (listtypes cabs), + " #endregion", + " #endregion", + "}" + ] + where + -- an abstract class is a category which does not contain rules + abstractclasses = [ (cat, (map fst cabsrules)) | (cat, cabsrules) <- signatures cabs, cat `notElem` (map fst cabsrules) ] + +-- auxiliaries + +prDataContract :: Bool -> [Cat] -> String +prDataContract False _ = "" +prDataContract True [] = " [DataContract]" +prDataContract True funs = unlinesInline [ + prDataContract True [], + unlinesInline $ map prDataContract' funs + ] + where + prDataContract' :: Cat -> String + prDataContract' fun = " [KnownType(typeof(" ++ fun ++ "))]" + +prDataMember :: Bool -> String +prDataMember False = "" +prDataMember True = " [DataMember]" + +prTokenBaseType :: Bool -> String +prTokenBaseType useWCF = unlinesInline [ + prDataContract useWCF [], + " public class TokenBaseType", + " {", + prDataMember useWCF, + " private string str;", + " ", + " public TokenBaseType(string str)", + " {", + " this.str = str;", + " }", + " ", + " public override string ToString()", + " {", + " return this.str;", + " }", + " }", + " " + ] + +prToken :: Namespace -> Bool -> Cat -> String +prToken namespace useWCF name = unlinesInline [ + prDataContract useWCF [], + " public class " ++ name ++ " : " ++ identifier namespace "TokenBaseType", + " {", + " public " ++ name ++ "(string str) : base(str)", + " {", + " }", + prAccept namespace name Nothing, + prVisitor namespace [name], + prEquals namespace name ["ToString()"], + prHashCode namespace name ["ToString()"], + " }" + ] + +prAbs :: Namespace -> Bool -> (Cat, [Cat]) -> String +prAbs namespace useWCF (cat, funs) = unlinesInline [ + prDataContract useWCF funs, + " public abstract class " ++ cat, + " {", + " public abstract R Accept(" ++ identifier namespace cat ++ ".Visitor v, A arg);", + prVisitor namespace funs, + " }" + ] + +prVisitor :: Namespace -> [Cat] -> String +prVisitor namespace funs = unlinesInline [ + " ", + " public interface Visitor", + " {", + unlinesInline (map prVisitFun funs), + " }" + ] + where + prVisitFun f = " R Visit(" ++ identifier namespace f ++ " p, A arg);" + +prCon :: Namespace -> Bool -> (Cat,CSharpAbsRule) -> String +prCon namespace useWCF (c,(f,cs)) = unlinesInline [ + prDataContract useWCF [], + " public class " ++ f ++ ext, + " {", + -- Instance variables + unlines [prInstVar typ var | (typ,_,var,_) <- cs], + prConstructor namespace (f,cs), + unlinesInline [prProperty typ var prop | (typ,_,var,prop) <- cs], + prEquals namespace f propnames, + prHashCode namespace f propnames, + -- print Accept method, override keyword needed for classes inheriting an abstract class + prAccept namespace c (if isAlsoCategory f c then Nothing else (Just " override")), + -- if this label is also a category, we need to print the Visitor interface + -- (if not, it was already printed in the abstract class) + if isAlsoCategory f c then prVisitor namespace [c] else "", + " }" + ] + where + -- This handles the case where a LBNF label is the same as the category. + ext = if isAlsoCategory f c then "" else " : " ++ identifier namespace (identCat c) + propnames = [prop | (_, _, _, prop) <- cs] + prInstVar typ var = unlinesInline [ + " private " ++ identifier namespace (typename typ) +++ var ++ ";" + ] + prProperty typ var prop = unlinesInline [ + " ", + prDataMember useWCF, + " public " ++ identifier namespace (typename typ) +++ prop, + " {", + " get", + " {", + " return this." ++ var ++ ";", + " }", + " set", + " {", + " this." ++ var ++ " = value;", + " }", + " }" + ] + +-- Creates the Equals() methods +prEquals :: Namespace -> Fun -> [String] -> String +prEquals namespace c vars = unlinesInline [ + " ", + " public override bool Equals(Object obj)", + " {", + " if(this == obj)", + " {", + " return true;", + " }", + " if(obj is " ++ identifier namespace c ++ ")", + " {", + " return this.Equals((" ++ identifier namespace c ++ ")obj);", + " }", + " return base.Equals(obj);", + " }", + " ", + " public bool Equals(" ++ identifier namespace c ++ " obj)", + " {", + " if(this == obj)", + " {", + " return true;", + " }", + " return " ++ prEqualsVars vars ++ ";", + " }" + ] + where + prEqualsVars [] = "true" + prEqualsVars vs = concat $ intersperse " && " $ map equalVar vs + equalVar v = "this." ++ v ++ ".Equals(obj." ++ v ++ ")" + +-- Creates the GetHashCode() method. +prHashCode :: Namespace -> Fun -> [String] -> String +prHashCode namespace c vars = unlinesInline [ + " ", + " public override int GetHashCode()", + " {", + " return " ++ prHashVars vars ++ ";", + " }" + ] + where + aPrime = 37 + prHashVars [] = show aPrime + prHashVars (v:vs) = prHashVars' (hashVar v) vs + prHashVars' r [] = r + prHashVars' r (v:vs) = prHashVars' (show aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashVar v) vs + hashVar var = "this." ++ var ++ ".GetHashCode()" + +prList :: Namespace -> (Cat,Bool) -> String +prList namespace (c,_) = unlinesInline [ + " public class " ++ c ++ " : List<" ++ identifier namespace (typename bas) ++ ">", + " {", + " }" + ] + where + bas = drop 4 c -- drop List + +-- The standard Accept method for the Visitor pattern +prAccept :: Namespace -> Cat -> Maybe String -> String +prAccept namespace cat maybeOverride = unlinesInline [ + " ", + " public" ++ fromMaybe "" maybeOverride ++ " R Accept(" ++ identifier namespace cat ++ ".Visitor visitor, A arg)", + " {", + " return visitor.Visit(this, arg);", + " }" + ] + +-- The constructor assigns the parameters to the corresponding instance variables. +prConstructor :: Namespace -> CSharpAbsRule -> String +prConstructor namespace (f,cs) = unlinesInline [ + " public " ++ f ++ "(" ++ conargs ++ ")", + " {", + unlinesInline [" " ++ c ++ " = " ++ p ++ ";" | (c,p) <- zip cvs pvs], + " }" + ] + where + cvs = [c | (_,_,c,_) <- cs] + pvs = ["p" ++ show i | ((x,st,_,_),i) <- zip cs [1..]] + conargs = concat $ intersperse ", " + [identifier namespace (typename x) +++ v | ((x,_,_,_),v) <- zip cs pvs] diff --git a/src/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs b/src/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs new file mode 100644 --- /dev/null +++ b/src/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs @@ -0,0 +1,97 @@ +{- + BNF Converter: C# Abstract Visit Skeleton Generator + + Copyright (C) 2006 Author: Johan Broberg + + Modified from CAbstoCSharpVisitSkeleton + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates an Abstract Visit Skeleton for C#. + This can be useful if you often make changes to your + grammar and want to keep your own changes (not having to + merge with the new visit skeleton each time), while still + getting compile errors if your code is no longer correct. + The generated file uses the Visitor design pattern. + + This could have been generated from within + CAbstoVisitSkeleton, but that would have made it more + difficult to actually use it (and the visit skeleton). + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 19 December, 2006 + + Modified : 19 December, 2006 by Johan Broberg + + ************************************************************** +-} + +module CAbstoCSharpAbstractVisitSkeleton (cabs2csharpAbstractVisitSkeleton) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import OOAbstract hiding (basetypes) +import CSharpUtils +import CAbstoCSharpAbs + +--Produces .cs file +cabs2csharpAbstractVisitSkeleton :: Namespace -> CAbs -> String +cabs2csharpAbstractVisitSkeleton namespace cabs = unlines [ + "/*** BNFC-Generated Abstract Visitor Design Pattern Skeleton. ***/", + "/* This implements the common visitor design pattern.", + " Replace the R and A parameters with the desired return", + " and context types.*/", + "", + "namespace " ++ namespace ++ ".VisitSkeleton", + "{", + " #region Classes", + unlinesInlineMap (prCon namespace) (signatures cabs), + " #endregion", + " ", + " #region Token types", + unlinesInlineMap (prBasic namespace) (tokentypes cabs), + " #endregion", + "}" + ] + +prBasic namespace c = unlinesInline [ + " public abstract class Abstract" ++ c ++ "Visitor : " ++ identifier namespace c ++ ".Visitor", + " {", + " public abstract R Visit(" ++ identifier namespace (typename c) +++ varname c ++ ", A arg);", + " }" + ] + +prCon :: Namespace -> (Cat, [CAbsRule]) -> String +prCon namespace (c,fs) = unlinesInline [ + " public abstract class Abstract" ++ c ++ "Visitor : " ++ identifier namespace c ++ ".Visitor", + " {", + unlinesInlineMap (prVisit namespace) fs, + " }" + ] + +prVisit :: Namespace -> (Fun, [(Cat, Bool, String)]) -> String +prVisit namespace (f,cs) = unlinesInline [ + " public abstract R Visit(" ++ identifier namespace f +++ varname f ++ ", A arg);" + ] diff --git a/src/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs b/src/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs new file mode 100644 --- /dev/null +++ b/src/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs @@ -0,0 +1,118 @@ +{- + BNF Converter: C# Visit Skeleton Generator + + Copyright (C) 2006 Author: Johan Broberg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C# Visit Skeleton. + The generated file uses the Visitor design pattern. + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 30 November, 2006 + + Modified : 21 January, 2007 by Johan Broberg + + ************************************************************** +-} + +module CAbstoCSharpVisitSkeleton (cabs2csharpvisitskeleton) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import OOAbstract hiding (basetypes) +import CSharpUtils +import CAbstoCSharpAbs + +--Produces .cs file +cabs2csharpvisitskeleton :: Namespace -> CAbs -> String +cabs2csharpvisitskeleton namespace cabs = unlines [ + "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/", + "/* This implements the common visitor design pattern. To make sure that", + " compile errors occur when code in the Visitor don't match the abstract", + " syntaxt, the \"abstract visit skeleton\" is used.", + " ", + " Replace the R and A parameters with the desired return", + " and context types.*/", + "", + "namespace " ++ namespace ++ ".VisitSkeleton", + "{", + " #region Classes", + unlinesInlineMap (prCon namespace) (signatures cabs), + " #endregion", + " ", + " #region Token types", + unlinesInlineMap (prBasic namespace) (tokentypes cabs), + " #endregion", + "}" + ] + +prBasic namespace c = unlinesInline [ + " public class " ++ c ++ "Visitor : Abstract" ++ c ++ "Visitor", + " {", + " public override R Visit(" ++ identifier namespace (typename c) +++ varname c ++ ", A arg)", + " {", + " /* Code for " ++ c ++ " Goes Here */", + " return default(R);", + " }", + " }" + ] + +prCon :: Namespace -> (Cat, [CAbsRule]) -> String +prCon namespace (c,fs) = unlinesInline [ + " public class " ++ c ++ "Visitor : Abstract" ++ c ++ "Visitor", + " {", + unlinesInlineMap (prVisit namespace) (map cabsrule2csharpabsrule fs), + " }" + ] + + +prVisit :: Namespace -> CSharpAbsRule -> String +prVisit namespace (f,cs) = unlinesInline [ + " public override R Visit(" ++ identifier namespace f +++ varname f ++ ", A arg)", + " {", + " /* Code For " ++ f ++ " Goes Here */", + unlinesInline $ map (prVisitArg namespace (varname f)) cs, + " return default(R);", + " }" + ] + +prVisitArg :: Namespace -> String -> (Cat, Bool, VariableName, PropertyName) -> String +prVisitArg namespace vname (cat, isPt, var, prop) + | cat `elem` (map fst basetypes) = " // " ++ vname ++ "." ++ prop + -- var /= "list_" is a dummy fix to make sure that a category named "List" doesn't get interpreted as a List. + -- this isn't very good though, and should be fixed somehow. + | "list" `isPrefixOf` var && var /= "list_" = listAccept + | otherwise = " " ++ vname ++ "." ++ prop ++ ".Accept(new " ++ cat ++ "Visitor(), arg);" + where + listtype = typename (drop 4 cat) + listAccept = unlinesInline [ + " foreach(" ++ identifier namespace listtype ++ " x in " ++ vname ++ "." ++ prop ++ ")", + " {", + if listtype `notElem` (map snd basetypes) + then " x.Accept(new " ++ listtype ++ "Visitor(), arg);" + else " // x", + " }" + ] diff --git a/src/formats/c-sharp/CFtoCSharpPrinter.hs b/src/formats/c-sharp/CFtoCSharpPrinter.hs new file mode 100644 --- /dev/null +++ b/src/formats/c-sharp/CFtoCSharpPrinter.hs @@ -0,0 +1,455 @@ +{- + BNF Converter: C# Pretty Printer Generator + Copyright (C) 2006 Author: Johan Broberg + + Modified from CFtoSTLPrinter + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C# Pretty Printer. + It also generates the "show" method for + printing an abstract syntax tree. + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 26 November, 2006 + + Modified : 21 January, 2007 by Johan Broberg + + ************************************************************** +-} + +module CFtoCSharpPrinter (cf2csharpprinter) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower, toUpper, isSpace) +import Data.Maybe +import CSharpUtils + +--Produces .cs file +cf2csharpprinter :: Namespace -> CF -> String +cf2csharpprinter namespace cf = unlinesInline [ + header namespace cf, + " ", + entrypoints namespace cf, + " ", + " #region (Internal) Print Methods", + unlinesInlineMap (prData namespace user) groups, + " #endregion", + " ", + " #region (Internal) Show Methods", + unlinesInlineMap (shData namespace user) groups, + " #endregion", + " }", + " #endregion", + "}" + ] + where + groups = fixCoercions (ruleGroupsInternals cf) + user = [n | (n,_) <- tokenPragmas cf] + +header :: Namespace -> CF -> String +header namespace cf = unlinesInline [ + "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/", + " ", + -- imports + "using System;", + "using System.Text; // for StringBuilder", + "using " ++ namespace ++ ".Absyn;", + " ", + "namespace " ++ namespace, + "{", + " #region Pretty-printer class", + " public class PrettyPrinter", + " {", + " #region Misc rendering functions", + " // You may wish to change these:", + " private const int BUFFER_INITIAL_CAPACITY = 2000;", + " private const string LEFT_PARENTHESIS = \"(\";", + " private const string RIGHT_PARENTHESIS = \")\";", + " private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;", + " ", + " private static int _n_ = 0;", + " private static StringBuilder buffer = new StringBuilder(BUFFER_INITIAL_CAPACITY);", + " ", + " //You may wish to change render", + " private static void Render(String s)", + " {", + " if(s == \"{\")", + " {", + " buffer.Append(\"\\n\");", + " Indent();", + " buffer.Append(s);", + " _n_ = _n_ + 2;", + " buffer.Append(\"\\n\");", + " Indent();", + " }", + " else if(s == \"(\" || s == \"[\")", + " buffer.Append(s);", + " else if(s == \")\" || s == \"]\")", + " {", + " Backup();", + " buffer.Append(s);", + " buffer.Append(\" \");", + " }", + " else if(s == \"}\")", + " {", + " _n_ = _n_ - 2;", + " Backup();", + " Backup();", + " buffer.Append(s);", + " buffer.Append(\"\\n\");", + " Indent();", + " }", + " else if(s == \",\")", + " {", + " Backup();", + " buffer.Append(s);", + " buffer.Append(\" \");", + " }", + " else if(s == \";\")", + " {", + " Backup();", + " buffer.Append(s);", + " buffer.Append(\"\\n\");", + " Indent();", + " }", + " else if(s == \"\") return;", + " else", + " {", + " // Make sure escaped characters are printed properly!", + " if(s.StartsWith(\"\\\"\") && s.EndsWith(\"\\\"\"))", + " {", + " buffer.Append('\"');", + " StringBuilder sb = new StringBuilder(s);", + " // Remove enclosing citation marks", + " sb.Remove(0,1);", + " sb.Remove(sb.Length-1,1);", + " // Note: we have to replace backslashes first! (otherwise it will \"double-escape\" the other escapes)", + " sb.Replace(\"\\\\\", \"\\\\\\\\\");", + " sb.Replace(\"\\n\", \"\\\\n\");", + " sb.Replace(\"\\t\", \"\\\\t\");", + " sb.Replace(\"\\\"\", \"\\\\\\\"\");", + " buffer.Append(sb.ToString());", + " buffer.Append('\"');", + " }", + " else", + " {", + " buffer.Append(s);", + " }", + " buffer.Append(\" \");", + " }", + " }", + " ", + " private static void PrintInternal(int n, int _i_)", + " {", + " buffer.Append(n.ToString(InvariantFormatInfo));", + " buffer.Append(' ');", + " }", + " ", + " private static void PrintInternal(double d, int _i_)", + " {", + " buffer.Append(d.ToString(InvariantFormatInfo));", + " buffer.Append(' ');", + " }", + " ", + " private static void PrintInternal(string s, int _i_)", + " {", + " Render(s);", + " }", + " ", + " private static void PrintInternal(char c, int _i_)", + " {", + " PrintQuoted(c);", + " }", + " ", + unlinesInlineMap (prToken namespace) (tokenNames cf), + " ", + " private static void ShowInternal(int n)", + " {", + " Render(n.ToString(InvariantFormatInfo));", + " }", + " ", + " private static void ShowInternal(double d)", + " {", + " Render(d.ToString(InvariantFormatInfo));", + " }", + " ", + " private static void ShowInternal(char c)", + " {", + " PrintQuoted(c);", + " }", + " ", + " private static void ShowInternal(string s)", + " {", + " PrintQuoted(s);", + " }", + " ", + unlinesInlineMap (shToken namespace) (tokenNames cf), + " ", + " private static void PrintQuoted(string s)", + " {", + " Render(\"\\\"\" + s + \"\\\"\");", + " }", + " ", + " private static void PrintQuoted(char c)", + " {", + " // Makes sure the character is escaped properly before printing it.", + " string str = c.ToString();", + " if(c == '\\n') str = \"\\\\n\";", + " if(c == '\\t') str = \"\\\\t\";", + " Render(\"'\" + str + \"'\");", + " }", + " ", + " private static void Indent()", + " {", + " int n = _n_;", + " while (n > 0)", + " {", + " buffer.Append(' ');", + " n--;", + " }", + " }", + " ", + " private static void Backup()", + " {", + " if(buffer[buffer.Length - 1] == ' ')", + " {", + " buffer.Length = buffer.Length - 1;", + " }", + " }", + " ", + " private static void Trim()", + " {", + " while(buffer.Length > 0 && buffer[0] == ' ')", + " buffer.Remove(0, 1); ", + " while(buffer.Length > 0 && buffer[buffer.Length-1] == ' ')", + " buffer.Remove(buffer.Length-1, 1);", + " }", + " ", + " private static string GetAndReset()", + " {", + " Trim();", + " string strReturn = buffer.ToString();", + " Reset();", + " return strReturn;", + " }", + " ", + " private static void Reset()", + " {", + " buffer.Remove(0, buffer.Length);", + " }", + " #endregion" + ] + +prToken :: Namespace -> Cat -> String +prToken namespace token = unlinesInline [ + " private static void PrintInternal(" ++ identifier namespace token ++ " token, int _i_)", + " {", + " buffer.Append('\\\"');", + " buffer.Append(token.ToString());", + " buffer.Append('\\\"');", + " }" + ] + +shToken :: Namespace -> Cat -> String +shToken namespace token = unlinesInline [ + " private static void ShowInternal(" ++ identifier namespace token ++ " token)", + " {", + " Render(token.ToString());", + " }" + ] + +entrypoints :: Namespace -> CF -> String +entrypoints namespace cf = unlinesInline [ + " #region Print Entry Points", + unlinesInlineMap prEntryPoint (allCats cf), + " #endregion", + " ", + " #region Show Entry Points", + unlinesInlineMap shEntryPoint (allCats cf), + " #endregion" + ] + where + prEntryPoint cat | (normCat cat) == cat = unlinesInline [ + " public static string Print(" ++ identifier namespace (identCat cat) ++ " cat)", + " {", + " PrintInternal(cat, 0);", + " return GetAndReset();", + " }" + ] + prEntryPoint _ = "" + shEntryPoint cat | (normCat cat) == cat = unlinesInline [ + " public static String Show(" ++ identifier namespace (identCat cat) ++ " cat)", + " {", + " ShowInternal(cat);", + " return GetAndReset();", + " }" + ] + shEntryPoint _ = "" + +prData :: Namespace -> [UserDef] -> (Cat, [Rule]) -> String +prData namespace user (cat, rules) + -- list + | isList cat = unlinesInline [ + " private static void PrintInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p, int _i_)", + " {", + (prList user cat rules), + " }" + ] + -- not a list + | otherwise = unlinesInline [ + " private static void PrintInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p, int _i_)", + " {", + -- first rule starts with "if", the rest of them start with "else if". + -- this isn't very pretty, but does the job and produces nice code. + prRule namespace Nothing firstRule, + unlinesInline $ map (prRule namespace (Just "else ")) otherRules, + " }" + ] + where + -- Removes the rules at the beginning of the list which won't be used by the prRule function. + rules' = dropWhile (\r -> isCoercion (funRule r) || isDefinedRule (funRule r)) rules + firstRule = head rules' + otherRules = tail rules' + +prRule :: Namespace -> Maybe String -> Rule -> String +prRule namespace maybeElse r@(Rule fun _c cats) + | not (isCoercion fun || isDefinedRule fun) = unlinesInline [ + " " ++ fromMaybe "" maybeElse ++ "if(p is " ++ identifier namespace fun ++ ")", + " {", + " " ++ identifier namespace fun +++ fnm ++ " = (" ++ identifier namespace fun ++ ")p;", + " if(_i_ > " ++ (show p) ++ ") Render(LEFT_PARENTHESIS);", + cats', + " if(_i_ > " ++ (show p) ++ ") Render(RIGHT_PARENTHESIS);", + " }" + ] + where + p = precRule r + cats' = case cats of + [] -> "" + _ -> unlinesInline $ map (prCat fnm) (zip (fixOnes (numProps [] cats)) (map getPrec cats)) + fnm = '_' : map toLower fun + + getPrec (Right {}) = 0 + getPrec (Left c) = precCat c +prRule _nm _ _ = "" + +prList :: [UserDef] -> Cat -> [Rule] -> String +prList user c rules = unlinesInline [ + " for(int i=0; i < p.Count; i++)", + " {", + " PrintInternal(p[i], 0);", + " if(i < p.Count - 1)", + " {", + " Render(\"" ++ escapeChars sep ++ "\");", + " }", + " else", + " {", + " Render(\"" ++ optsep ++ "\");", + " }", + " }" + ] + where + et = typename (normCatOfList c) + sep = getCons rules + optsep = if hasOneFunc rules then "" else escapeChars sep + +prCat fnm (c, p) = + case c of + Right t -> " Render(\"" ++ escapeChars t ++ "\");" + Left nt + | "string" `isPrefixOf` nt -> " PrintQuoted(" ++ fnm ++ "." ++ nt ++ ");" + | isInternalVar nt -> "" + | otherwise -> " PrintInternal(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");" + + +--The following methods generate the Show function. + +shData :: Namespace -> [UserDef] -> (Cat, [Rule]) -> String +shData namespace user (cat, rules) + | isList cat = unlinesInline [ + " private static void ShowInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p)", + " {", + (shList user cat rules), + " }" + ] + | otherwise = unlinesInline [ + " private static void ShowInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p)", + " {", + unlinesInline $ map (shRule namespace) rules, + " }" + ] + +shRule :: Namespace -> Rule -> String +shRule namespace (Rule fun _c cats) + | not (isCoercion fun || isDefinedRule fun) = unlinesInline [ + " if(p is " ++ identifier namespace fun ++ ")", + " {", + " " ++ identifier namespace fun +++ fnm ++ " = (" ++ identifier namespace fun ++ ")p;", + lparen, + " Render(\"" ++ (escapeChars fun) ++ "\");", + cats', + rparen, + " }" + ] + where + cats' | allTerms cats = "" + | otherwise = unlinesInline $ map (shCat fnm) (fixOnes (numProps [] cats)) + lparen | allTerms cats = "" + | otherwise = " Render(\"(\");" + rparen | allTerms cats = "" + | otherwise = " Render(\")\");" + allTerms [] = True + allTerms ((Left {}):_) = False + allTerms (_:zs) = allTerms zs + fnm = '_' : map toLower fun +shRule _nm _ = "" + +shList :: [UserDef] -> Cat -> [Rule] -> String +shList user c _rules = unlinesInline [ + " for(int i=0; i < p.Count; i++)", + " {", + " ShowInternal(p[i]);", + " if(i < p.Count - 1)", + " Render(\",\");", + " }" + ] + where + et = typename (normCatOfList c) + +shCat fnm c = + case c of + Right {} -> "" + Left nt + | "list" `isPrefixOf` nt -> unlinesInline [ + " Render(\"[\");", + " ShowInternal(" ++ fnm ++ "." ++ nt ++ ");", + " Render(\"]\");" + ] + | isInternalVar nt -> "" + | otherwise -> " ShowInternal(" ++ fnm ++ "." ++ nt ++ ");" + +isInternalVar x = x == internalCat ++ "_" diff --git a/src/formats/c-sharp/CFtoGPLEX.hs b/src/formats/c-sharp/CFtoGPLEX.hs new file mode 100644 --- /dev/null +++ b/src/formats/c-sharp/CFtoGPLEX.hs @@ -0,0 +1,221 @@ +{- + BNF Converter: C# GPLEX Generator + Copyright (C) 2006 Author: Johan Broberg + + Modified from CFtoFlex + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the GPLEX file. + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 23 November, 2006 + + Modified : 17 December, 2006 by Johan Broberg + + ************************************************************** +-} + +module CFtoGPLEX (cf2gplex) where + +import CF +import RegToGPLEX +import Utils((+++), (++++)) +import NamedVariables +import Data.List +import CSharpUtils + +--The environment must be returned for the parser to use. +cf2gplex :: Namespace -> CF -> (String, SymEnv) +cf2gplex namespace cf = (unlines [ + prelude namespace, + cMacros, + prettyprinter $ (lexSymbols env) ++ (gplex namespace cf env'), + "%%" + ], env') + where + env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) + env' = env ++ (makeSymEnv (fst (unzip (tokenPragmas cf))) (length env)) + -- GPPG doesn't seem to like tokens beginning with an underscore, so they (the underscores, nothing else) have been removed. + makeSymEnv [] _ = [] + makeSymEnv (s:symbs) n = (s, "SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) + +prelude :: Namespace -> String +prelude namespace = unlines [ + "/* This GPLex file was machine-generated by the BNF converter */", + "", + "%namespace " ++ namespace, + "", + "%{", + " /// ", + " /// Buffer for escaped characters in strings.", + " /// ", + " private System.Text.StringBuilder strBuffer = new System.Text.StringBuilder();", + "", + " /// ", + " /// Change to enable output - useful for debugging purposes", + " /// ", + " public bool Trace = false;", + "", + " /// ", + " /// Culture-independent IFormatProvider for numbers. ", + " /// This is just a \"wrapper\" for System.Globalization.NumberFormatInfo.InvariantInfo.", + " /// ", + " /// ", + " /// This should be used when parsing numbers. Otherwise the parser might fail: ", + " /// culture en-US uses a dot as decimal separator, while for example sv-SE uses a comma. ", + " /// BNFC uses dot as decimal separator for Double values, so if your culture is sv-SE ", + " /// the parse will fail if this InvariantInfo isn't used.", + " /// ", + " private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;", + "", + " /// ", + " /// Convenience method to create scanner AND initialize it correctly.", + " /// As long as you don't want to enable trace output, this is all you ", + " /// need to call and give to the parser to be able to parse.", + " /// ", + " public static Scanner CreateScanner(Stream stream)", + " {", + " Scanner scanner = new Scanner(stream);", + " scanner.Begin();", + " return scanner;", + " }", + "", + " /// ", + " /// Sets the scanner to the correct initial state (YYINITIAL). ", + " /// You should call this method prior to calling parser.Parse().", + " /// ", + " public void Begin()", + " {", + " BEGIN(YYINITIAL);", + " }", + "", + " /// ", + " /// Convenience method to \"reset\" the buffer for escaped characters in strings.", + " /// ", + " private void BufferReset()", + " {", + " this.strBuffer = new System.Text.StringBuilder();", + " }", + "", + "%}", + "" + ] + +--For now all categories are included. +--Optimally only the ones that are used should be generated. +cMacros :: String +cMacros = unlines + [ + "alpha [a-zA-Z]", + "alphaCapital [A-Z]", + "alphaSmall [a-z]", + "digit [0-9]", + "ident [a-zA-Z0-9'_]", + -- start states, must be defined one at a time + "%s YYINITIAL", + "%s COMMENT", + "%s CHAR", + "%s CHARESC", + "%s CHAREND", + "%s STRING", + "%s ESCAPED", + "%%" + ] + +lexSymbols :: SymEnv -> [(String, String)] +lexSymbols ss = map transSym ss + where + transSym (s,r) = + ("\"" ++ s' ++ "\"" , "if(Trace) System.Console.Error.WriteLine(yytext); return (int)Tokens." ++ r ++ ";") + where + s' = escapeChars s + +gplex :: Namespace -> CF -> SymEnv -> [(String, String)] +gplex namespace cf env = concat [ + lexComments (comments cf), + userDefTokens, + ifC "String" strStates, + ifC "Char" charStates, + ifC "Double" [("{digit}+\".\"{digit}+(\"e\"(\\-)?{digit}+)?" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.double_ = Double.Parse(yytext, InvariantFormatInfo); return (int)Tokens.DOUBLE_;")], + ifC "Integer" [("{digit}+" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.int_ = Int32.Parse(yytext, InvariantFormatInfo); return (int)Tokens.INTEGER_;")], + ifC "Ident" [("{alpha}{ident}*" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.string_ = yytext; return (int)Tokens.IDENT_;")], + [("[ \\t\\r\\n\\f]" , "/* ignore white space. */;")], + [("." , "return (int)Tokens.error;")] + ] + where + ifC cat s = if isUsedCat cf cat then s else [] + userDefTokens = map tokenline (tokenPragmas cf) + where + tokenline (name, exp) = ("" ++ printRegGPLEX exp , action name) + action n = "if(Trace) System.Console.Error.WriteLine(yytext); yylval." ++ varName (normCat n) ++ " = new " ++ identifier namespace n ++ "(yytext); return (int)Tokens." ++ sName n ++ ";" + sName n = case lookup n env of + Just x -> x + Nothing -> n + -- These handle escaped characters in Strings. + strStates = [ + ("\"\\\"\"" , "BEGIN(STRING);"), + ("\\\\" , "BEGIN(ESCAPED);"), + ("\\\"" , "yylval.string_ = this.strBuffer.ToString(); BufferReset(); BEGIN(YYINITIAL); return (int)Tokens.STRING_;"), + ("." , "this.strBuffer.Append(yytext);"), + ("n" , "this.strBuffer.Append(\"\\n\"); BEGIN(STRING);"), + ("\\\"" , "this.strBuffer.Append(\"\\\"\"); BEGIN(STRING);"), + ("\\\\" , "this.strBuffer.Append(\"\\\\\"); BEGIN(STRING);"), + ("t" , "this.strBuffer.Append(\"\\t\"); BEGIN(STRING);"), + ("." , "this.strBuffer.Append(yytext); BEGIN(STRING);") + ] + -- These handle escaped characters in Chars. + charStates = [ + ("\"'\"" , "BEGIN(CHAR);"), + ("\\\\" , "BEGIN(CHARESC);"), + ("[^']" , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"), + ("n" , "BEGIN(CHAREND); yylval.char_ = '\\n'; return (int)Tokens.CHAR_;"), + ("t" , "BEGIN(CHAREND); yylval.char_ = '\\t'; return (int)Tokens.CHAR_;"), + ("." , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"), + ("\"'\"" , "BEGIN(YYINITIAL);") + ] + +lexComments :: ([(String, String)], [String]) -> [(String, String)] +lexComments (m,s) = (map lexSingleComment s) ++ (concatMap lexMultiComment m) + +lexSingleComment :: String -> (String, String) +lexSingleComment c = + ("\"" ++ c ++ "\"[^\\n]*\\n" , "/* BNFC single-line comment */;") + +--There might be a possible bug here if a language includes 2 multi-line comments. +--They could possibly start a comment with one character and end it with another. +--However this seems rare. +lexMultiComment :: (String, String) -> [(String, String)] +lexMultiComment (b,e) = [ + ("\"" ++ b ++ "\"" , "BEGIN(COMMENT);"), + ("\"" ++ e ++ "\"" , "BEGIN(YYINITIAL);"), + ("." , "/* BNFC multi-line comment */;"), + ("[\\n]" , "/* BNFC multi-line comment */;") + ] + +-- Used to print the lexer rules; makes sure that all rules are equally indented, to make the GPLEX file a little more readable. +prettyprinter :: [(String, String)] -> String +prettyprinter xs = unlines $ map prettyprinter' xs + where + padlength = 1 + (last $ sort $ map length $ map fst xs) + prettyprinter' (x, y) = x ++ replicate (padlength - length x) ' ' ++ y diff --git a/src/formats/c-sharp/CFtoGPPG.hs b/src/formats/c-sharp/CFtoGPPG.hs new file mode 100644 --- /dev/null +++ b/src/formats/c-sharp/CFtoGPPG.hs @@ -0,0 +1,275 @@ +{- + BNF Converter: C# GPPG Generator + Copyright (C) 2006 Author: Johan Broberg + + Modified from CFtoBisonSTL. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the GPPG input file. + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 24 November, 2006 + + Modified : 17 December, 2006 by Johan Broberg + + ************************************************************** +-} + +module CFtoGPPG (cf2gppg) where + +import CF +import Data.List (intersperse, isPrefixOf) +import NamedVariables hiding (varName) +import Data.Char (toLower,isUpper,isDigit) +import Utils ((+++), (++++)) +import TypeChecker +import ErrM +import OOAbstract hiding (basetypes) +import CSharpUtils + +--This follows the basic structure of CFtoHappy. + +-- Type declarations +type Rules = [(NonTerminal,[(Pattern,Action)])] +type NonTerminal = String +type Pattern = String +type Action = String +type MetaVar = String + +--The environment comes from the CFtoGPLEX +cf2gppg :: Namespace -> CF -> SymEnv -> String +cf2gppg namespace cf env = unlines [ + header namespace cf, + union namespace (positionCats cf ++ allCats cf ++ tokentypes (cf2cabs cf)), + tokens user env, + declarations cf, + "", + specialToks cf, + "", + "%%", + prRules (rulesForGPPG namespace cf env) + ] + where + user = fst (unzip (tokenPragmas cf)) + +positionCats cf = filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf)) + +header :: Namespace -> CF -> String +header namespace cf = unlines [ + "/* This GPPG file was machine-generated by BNFC */", + "", + "%namespace " ++ namespace, + "%{", + definedRules namespace cf, + unlinesInline $ map (parseMethod namespace) (allCatsIdNorm cf ++ positionCats cf), + "%}" + ] + +definedRules :: Namespace -> CF -> String +definedRules namespace cf = unlinesInline [ + if null [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ] + then "" + else error "Defined rules are not yet available in C# mode!" + ] + where + ctx = buildContext cf + + list = LC (const "[]") (\t -> "List" ++ unBase t) + where + unBase (ListT t) = unBase t + unBase (BaseT x) = normCat x + + rule f xs e = + case checkDefinition' list ctx f xs e of + Bad err -> error $ "Panic! This should have been caught already:\n" ++ err + Ok (args,(e',t)) -> unlinesInline [ + "Defined Rule goes here" + ] + +--This generates a parser method for each entry point. +parseMethod :: Namespace -> Cat -> String +parseMethod namespace cat = unlinesInline [ + " " ++ returntype +++ returnvar ++ " = null;", + " public " ++ returntype ++ " Parse" ++ cat' ++ "()", + " {", + " if(this.Parse())", + " {", + " return " ++ returnvar ++ ";", + " }", + " else", + " {", + " throw new Exception(\"Could not parse input stream!\");", + " }", + " }", + " " + ] + where + cat' = identCat (normCat cat) + returntype = identifier namespace cat' + returnvar = resultName cat' + +--The union declaration is special to GPPG/GPLEX and gives the type of yylval. +--For efficiency, we may want to only include used categories here. +union :: Namespace -> [Cat] -> String +union namespace cats = unlines $ filter (\x -> x /= "\n") [ + "%union", + "{", + " public int int_;", + " public char char_;", + " public double double_;", + " public string string_;", + unlinesInline $ map catline cats, + "}" + ] + where --This is a little weird because people can make [Exp2] etc. + catline cat | (identCat cat /= cat) || (normCat cat == cat) = + " public " ++ identifier namespace (identCat (normCat cat)) +++ (varName (normCat cat)) ++ ";" + catline cat = "" + +--declares non-terminal types. +declarations :: CF -> String +declarations cf = unlinesInline $ map (typeNT cf) (positionCats cf ++ allCats cf) + where --don't define internal rules + typeNT cf nt | (isPositionCat cf nt || rulesForCat cf nt /= []) = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) + typeNT cf nt = "" + +--declares terminal types. +tokens :: [UserDef] -> SymEnv -> String +tokens user ts = concatMap (declTok user) ts + where + declTok u (s,r) = if elem s u + then "%token<" ++ varName (normCat s) ++ "> " ++ r ++ " // " ++ s ++ "\n" + else "%token " ++ r ++ " // " ++ s ++ "\n" + +specialToks :: CF -> String +specialToks cf = unlinesInline [ + ifC "String" "%token STRING_", + ifC "Char" "%token CHAR_", + ifC "Integer" "%token INTEGER_", + ifC "Double" "%token DOUBLE_", + ifC "Ident" "%token IDENT_" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + +--The following functions are a (relatively) straightforward translation +--of the ones in CFtoHappy.hs +rulesForGPPG :: Namespace -> CF -> SymEnv -> Rules +rulesForGPPG namespace cf env = (map mkOne $ ruleGroups cf) ++ posRules where + mkOne (cat,rules) = constructRule namespace cf env rules cat + posRules = map mkPos $ positionCats cf + mkPos cat = (cat, [(maybe cat id (lookup cat env), + "$$ = new " ++ cat ++ "($1);")]) + +-- For every non-terminal, we construct a set of rules. +constructRule :: Namespace -> + CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule namespace cf env rules nt = + (nt,[(p,(generateAction namespace nt (ruleName r) b m) +++ result) | + r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True,revSepListRule r0) + else (False,r0), + let (p,m) = generatePatterns cf env r b]) + where + ruleName r = case funRule r of + ---- "(:)" -> identCat nt + ---- "(:[])" -> identCat nt + z -> z + revs = reversibleCats cf + eps = allEntryPoints cf + isEntry nt = if elem nt eps then True else False + result = if isEntry nt then (resultName (normCat (identCat nt))) ++ "= $$;" else "" + +-- Generates a string containing the semantic action. +-- This was copied from CFtoCup15, with only a few small modifications +generateAction :: Namespace -> NonTerminal -> Fun -> Bool -> [(MetaVar, Bool)] + -> Action +generateAction namespace nt f rev mbs + | isNilFun f = "$$ = new " ++ identifier namespace c ++ "();" + | isOneFun f = "$$ = new " ++ identifier namespace c ++ "(); $$.Add(" ++ p_1 ++ ");" + | isConsFun f && not rev = "$$ = " ++ p_2 ++ "; " ++ p_2 ++ ".Insert(0, " ++ p_1 ++ ");" + | isConsFun f && rev = "$$ = " ++ p_1 ++ "; " ++ p_1 ++ ".Add(" ++ p_2 ++ ");" + | isCoercion f = "$$ = " ++ p_1 ++ ";" + | isDefinedRule f = "$$ = " ++ f ++ "_" ++ "(" ++ concat (intersperse "," ms) ++ ");" + | otherwise = "$$ = new " ++ identifier namespace c ++ "(" ++ concat (intersperse "," ms) ++ ");" + where + c = if isNilFun f || isOneFun f || isConsFun f + then identCat (normCat nt) else f + ms = map fst mbs + p_1 = ms!!0 + p_2 = ms!!1 + + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal +generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)]) +generatePatterns cf env r revv = case rhsRule r of + [] -> ("/* empty */",[]) + its -> (unwords (map mkIt its), metas its) + where + mkIt i = case i of + Left c -> case lookup c env of + -- This used to be x, but that didn't work if we had a symbol "String" in env, and tried to use a normal String - it would use the symbol... + Just x | not (isPositionCat cf c) && c `notElem` (map fst basetypes) -> x + _ -> typeName (identCat c) + Right s -> case lookup s env of + Just x -> x + Nothing -> s + metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its] + + -- notice: reversibility with push_back vectors is the opposite + -- of right-recursive lists! + revert c = (head c == '[') && + not (isConsFun (funRule r)) && notElem c revs + revs = reversibleCats cf + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. + +prRules :: Rules -> String +prRules [] = [] +prRules ((nt, []):rs) = prRules rs --internal rule +prRules ((nt,((p,a):ls)):rs) = + (unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ ", a , "}"])]) ++ pr ls + +--Some helper functions. +resultName :: String -> String +resultName s = "YY_RESULT_" ++ s ++ "_" + +--slightly stronger than the NamedVariable version. +varName :: String -> String +varName s = (map toLower (identCat s)) ++ "_" + +typeName :: String -> String +typeName "Ident" = "IDENT_" +typeName "String" = "STRING_" +typeName "Char" = "CHAR_" +typeName "Integer" = "INTEGER_" +typeName "Double" = "DOUBLE_" +typeName x = x diff --git a/src/formats/c-sharp/CSharpTop.hs b/src/formats/c-sharp/CSharpTop.hs new file mode 100644 --- /dev/null +++ b/src/formats/c-sharp/CSharpTop.hs @@ -0,0 +1,350 @@ +{- + BNF Converter: C# Main file + Copyright (C) 2006-2007 Author: Johan Broberg + + Modified from STLTop 2006. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} +{- + ************************************************************** + BNF Converter Module + + Description : C# Main file + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 20 November, 2006 + + Modified : 8 January, 2007 by Johan Broberg + + ************************************************************** +-} + +module CSharpTop (makeCSharp) where + +import Utils +import CF +import OOAbstract +import CAbstoCSharpAbs +import CFtoGPLEX +import CFtoGPPG +import CAbstoCSharpVisitSkeleton +import CAbstoCSharpAbstractVisitSkeleton +import CFtoCSharpPrinter +import CFtoLatex +import CSharpUtils +import Data.Char +import System.Exit (exitFailure) +import System.Environment (getEnv) +import System.Directory +import System.IO +import System.IO.Error (catchIOError) +import System.Process +import Data.Maybe +import Data.Char +import Control.Monad.ST +import qualified Common.Makefile as Makefile +import System.FilePath ((<.>)) +-- Control.Monad.State + +makeCSharp :: Bool -- Makefile + -> Bool -- Visual Studio files + -> Bool -- Windows Communication Foundation support + -> Maybe Namespace -- C# namespace to use + -> CF + -> FilePath + -> IO () +makeCSharp make vsfiles wcfSupport maybenamespace cf file = do + let namespace = fromMaybe (filepathtonamespace file) maybenamespace + cabs = cf2cabs cf + absyn = cabs2csharpabs namespace cabs wcfSupport + (gplex, env) = cf2gplex namespace cf + gppg = cf2gppg namespace cf env + skeleton = cabs2csharpvisitskeleton namespace cabs + absSkeleton = cabs2csharpAbstractVisitSkeleton namespace cabs + printer = cf2csharpprinter namespace cf + latex = cfToLatex namespace cf + writeFileRep "Absyn.cs" absyn + writeFileRep (namespace ++ ".l") gplex + putStrLn " (Tested with GPLEX RC1)" + writeFileRep (namespace ++ ".y") gppg + putStrLn " (Tested with GPPG 1.0)" + writeFileRep "AbstractVisitSkeleton.cs" absSkeleton + writeFileRep "VisitSkeleton.cs" skeleton + writeFileRep "Printer.cs" printer + writeFileRep "Test.cs" (csharptest namespace cf) + writeFileRep (namespace ++ ".tex") latex + if vsfiles then (writeVisualStudioFiles namespace) else return () + if make then (writeMakefile namespace) else return () + +writeMakefile :: Namespace -> IO () +writeMakefile namespace = do + writeFileRep "Makefile" makefile + putStrLn "" + putStrLn "-----------------------------------------------------------------------------" + putStrLn "Generated Makefile, which uses mono. You may want to modify the paths to" + putStrLn "GPLEX and GPPG - unless you are sure that they are globally accessible (the" + putStrLn "default commands are \"mono gplex.exe\" and \"mono gppg.exe\", respectively." + putStrLn "The Makefile assumes that ShiftReduceParser.dll is located in ./bin and that" + putStrLn "is also where test.exe will be generated." + putStrLn "-----------------------------------------------------------------------------" + putStrLn "" + where + makefile = + (unlines [ "MONO = mono", "MONOC = gmcs" + , "MONOCFLAGS = -optimize -reference:${PARSERREF}" + , "GPLEX = ${MONO} gplex.exe", "GPPG = ${MONO} gppg.exe" + , "PARSERREF = bin/ShiftReduceParser.dll" + -- Apparently GPLEX outputs filenames in + -- lowercase, so scanner.cs is supposed to be like that! + , "CSFILES = Absyn.cs Parser.cs Printer.cs scanner.cs Test.cs VisitSkeleton.cs" ] ++) + $ Makefile.mkRule "all" [ "test" ] + [] + $ Makefile.mkRule "clean" [] + -- peteg: don't nuke what we generated - move that to the "vclean" target. + [ "rm -f " ++ namespace ++ ".pdf test" ] + $ Makefile.mkRule "distclean" [ "clean" ] + [ "rm -f ${CSFILES}" + , "rm -f " ++ unwords [namespace <.> ext | ext <- [ "l","y","tex" ]] + , "rm -f Makefile" ] + $ Makefile.mkRule "test" [ "Parser.cs", "Scanner.cs" ] + [ "@echo \"Compiling test...\"" + , "${MONOC} ${MONOCFLAGS} -out:bin/test.exe ${CSFILES}" ] + $ Makefile.mkRule "Scanner.cs" [ namespace <.> "l" ] + [ "${GPLEX} /out:Scanner.cs " ++ namespace <.> "l" ] + $ Makefile.mkRule "Parser.cs" [ namespace <.> "y" ] + [ "${GPPG} /gplex " ++ namespace <.> "y > Parser.cs" ] + $ Makefile.mkDoc namespace + "" + +writeVisualStudioFiles :: Namespace -> IO () +writeVisualStudioFiles namespace = do + guid <- projectguid + writeFileRep (namespace ++ ".csproj") (csproj guid) + writeFileRep (namespace ++ ".sln") (sln guid) + writeFileRep "run-gp.bat" batchfile + putStrLn "" + putStrLn "-----------------------------------------------------------------------------" + putStrLn "Visual Studio solution (.sln) and project (.csproj) files were written." + putStrLn "The project file has a reference to GPLEX/GPPG's ShiftReduceParser. You will" + putStrLn "have to either copy this file to bin\\ShiftReduceParser.dll or change the" + putStrLn "reference so that it points to the right location (you can do this from" + putStrLn "within Visual Studio)." + putStrLn "Additionally, the project includes Parser.cs and Scanner.cs. These have not" + putStrLn "been generated yet. You can use the run-gp.bat file to generate them, but" + putStrLn "note that it requires gppg and gplex to be in your PATH." + putStrLn "-----------------------------------------------------------------------------" + putStrLn "" + where + batchfile = unlines [ + "@echo off", + "gppg /gplex " ++ namespace ++ ".y > Parser.cs", + "gplex /verbose /out:Scanner.cs " ++ namespace ++ ".l" + ] + sln guid = unlines [ + "Microsoft Visual Studio Solution File, Format Version 9.00", + "# Visual Studio 2005", + "Project(\"{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}\") = \"" ++ namespace ++ "\", \"" ++ namespace ++ ".csproj\", \"" ++ guid ++ "\"", + "EndProject", + "Global", + " GlobalSection(SolutionConfigurationPlatforms) = preSolution", + " Debug|Any CPU = Debug|Any CPU", + " Release|Any CPU = Release|Any CPU", + " EndGlobalSection", + " GlobalSection(ProjectConfigurationPlatforms) = postSolution", + " " ++ guid ++ ".Debug|Any CPU.ActiveCfg = Debug|Any CPU", + " " ++ guid ++ ".Debug|Any CPU.Build.0 = Debug|Any CPU", + " " ++ guid ++ ".Release|Any CPU.ActiveCfg = Release|Any CPU", + " " ++ guid ++ ".Release|Any CPU.Build.0 = Release|Any CPU", + " EndGlobalSection", + " GlobalSection(SolutionProperties) = preSolution", + " HideSolutionNode = FALSE", + " EndGlobalSection", + "EndGlobal" + ] + csproj guid = unlines [ + "", + "", + " ", + " Debug", + " AnyCPU", + " 8.0.50727", + " 2.0", + " " ++ guid ++ "", + " Library", + " Properties", + " " ++ namespace ++ "", + " " ++ namespace ++ "", + " ", + " ", + " ", + " ", + " true", + " full", + " false", + " bin\\Debug\\", + " DEBUG;TRACE", + " prompt", + " 4", + " ", + " ", + " pdbonly", + " true", + " bin\\Release\\", + " TRACE", + " prompt", + " 4", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " False", + " bin\\ShiftReduceParser.dll", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + "" + ] + +csharptest :: Namespace -> CF -> String +csharptest namespace cf = unlines [ + "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", + "/* */", + "/* This test will parse a file, print the abstract syntax tree, and then */", + "/* pretty-print the result. */", + "/* */", + "/****************************************************************************/", + "using System;", + "using System.IO;", + "using " ++ namespace ++ ".Absyn;", + "", + "namespace " ++ namespace, + "{", + " public class Test", + " {", + " public static void Main(string[] args)", + " {", + " if (args.Length > 0)", + " {", + " Stream stream = File.OpenRead(args[0]);", + " /* The default entry point is used. For other options see class Parser */", + " Parser parser = new Parser();", + " Scanner scanner = Scanner.CreateScanner(stream);", + " // Uncomment to enable trace information:", + " // parser.Trace shows what the parser is doing", + " // parser.Trace = true;", + " // scanner.Trace prints the tokens as they are parsed, one token per line", + " // scanner.Trace = true;", + " parser.scanner = scanner;", + " try", + " {", + " " ++ def ++ " parse_tree = parser.Parse" ++ def ++ "();", + " if (parse_tree != null)", + " {", + " Console.Out.WriteLine(\"Parse Successful!\");", + " Console.Out.WriteLine(\"\");", + " Console.Out.WriteLine(\"[Abstract Syntax]\");", + " Console.Out.WriteLine(\"{0}\", PrettyPrinter.Show(parse_tree));", + " Console.Out.WriteLine(\"\");", + " Console.Out.WriteLine(\"[Linearized Tree]\");", + " Console.Out.WriteLine(\"{0}\", PrettyPrinter.Print(parse_tree));", + " }", + " else", + " {", + " Console.Out.WriteLine(\"Parse NOT Successful!\");", + " }", + " }", + " catch(Exception e)", + " {", + " Console.Out.WriteLine(\"Parse NOT Successful:\");", + " Console.Out.WriteLine(e.Message);", + " Console.Out.WriteLine(\"\");", + " Console.Out.WriteLine(\"Stack Trace:\");", + " Console.Out.WriteLine(e.StackTrace);", + " }", + " }", + " else", + " {", + " Console.Out.WriteLine(\"You must specify a filename!\");", + " }", + " }", + " }", + "}" + ] + where + def = head (allEntryPoints cf) + +filepathtonamespace :: FilePath -> Namespace +filepathtonamespace file = take (length file - 3) (basename file) + +projectguid :: IO String +projectguid = do + maybeFilePath <- findDirectory + guid <- maybe getBadGUID getGoodGUID maybeFilePath + return guid + where + getBadGUID :: IO String + getBadGUID = do + putStrLn "-----------------------------------------------------------------------------" + putStrLn "Could not find Visual Studio tool uuidgen.exe to generate project GUID!" + putStrLn "You might want to put this tool in your PATH." + putStrLn "-----------------------------------------------------------------------------" + return "{00000000-0000-0000-0000-000000000000}" + getGoodGUID :: FilePath -> IO String + getGoodGUID filepath = do + let filepath' = "\"" ++ filepath ++ "\"" + (hIn, hOut, hErr, processHandle) <- runInteractiveCommand filepath' + guid <- hGetLine hOut + return ('{' : init guid ++ "}") + findDirectory :: IO (Maybe FilePath) + findDirectory = do + -- This works with Visual Studio 2005. + -- We will probably have to be modify this to include another environment variable name for Orcas. + -- I doubt there is any need to support VS2003? (I doubt they have patched it up to have 2.0 support?) + toolpath <- catchIOError (getEnv "VS80COMNTOOLS") (\_ -> return "C:\\Program Files\\Microsoft Visual Studio 8\\Common7\\Tools") + exists <- doesDirectoryExist toolpath + if exists + then return (Just (toolpath ++ "\\uuidgen.exe")) + -- this handles the case when the user was clever enough to add the directory to his/her PATH + else findExecutable "uuidgen.exe" diff --git a/src/formats/c-sharp/CSharpUtils.hs b/src/formats/c-sharp/CSharpUtils.hs new file mode 100644 --- /dev/null +++ b/src/formats/c-sharp/CSharpUtils.hs @@ -0,0 +1,154 @@ +{- + BNF Converter: Utility Functions for C# + Copyright (C) 2006 Author: Johan Broberg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module provides utility functions for the + C# format. + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 23 November, 2006 + + Modified : 21 January, 2007 by Johan Broberg + + ************************************************************** +-} + +module CSharpUtils where + +import CF +import Control.Monad.ST +-- Control.Monad.State +import Data.Char (toLower) +import Data.Maybe +import Data.List +import OOAbstract hiding (basetypes) + +type Namespace = String + +--The visit-function name of a basic type +visitFunName :: String -> String +visitFunName v = + if "integer_" `isPrefixOf` v then "Integer" + else if "char_" `isPrefixOf` v then "Char" + else if "string_" `isPrefixOf` v then "String" + else if "double_" `isPrefixOf` v then "Double" + else if "ident_" `isPrefixOf` v then "Ident" + else "Ident" --User-defined type + +isUserDefined :: String -> Bool +isUserDefined v = v `notElem` (map classVar (map fst basetypes)) + +basetypes = [ + ("Integer","int"), + ("Char", "char"), + ("Double", "double"), + ("String", "string"), + ("Ident", "string") + ] + +typename :: String -> String +typename name + | name == "Char" = "char" + | name == "Double" = "double" + | name == "Ident" = "string" + | name == "Integer" = "int" + | name == "String" = "string" + | otherwise = name + +-- Creates a variable name. +-- To make sure that no reserved keyword is generated, an underscore is added at the end. Not very pretty, but effective. +varname :: String -> String +varname name = (map toLower name) ++ "_" + +-- Given a variable name (in an abstract syntax class), returns ".ToString()" if the name doesn't match one of the basetypes. +toString :: String -> String +toString v = if isUserDefined v then ".ToString()" else "" + +-- Prepends namespace ".Absyn." to typ unless it is one of the basetypes +identifier :: Namespace -> String -> String +identifier namespace typ + | typ `elem` (map snd basetypes) = typ + | otherwise = namespace ++ ".Absyn." ++ typ + +-- Removes empty lines, and removes the line-break at the end. +-- This can be useful if you want to use unlines "inside" unlines and don't want a whole lot of "useless" line-breaks. +unlinesInline :: [String] -> String +unlinesInline xs = concat $ intersperse "\n" $ filter (\x -> x /= "") xs + +unlinesInlineMap :: (a -> String) -> [a] -> String +unlinesInlineMap fun xs = unlinesInline $ intersperse " " $ filter (\x -> x /= "") $ map fun xs + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) + +isAlsoCategory :: Fun -> Cat -> Bool +isAlsoCategory f c = f == c + +flattenSignatures :: CAbs -> [(Cat, CSharpAbsRule)] +flattenSignatures cabs = [(c,r) | (c,rs) <- signatures cabs, r <- map cabsrule2csharpabsrule rs] + +type VariableName = String +type PropertyName = String + +-- Just like CAbsRule in OOAbstract, except this also has PropertyName. +-- (valcat,(constr,args)), True = is class (not basic), class variable stored +type CSharpAbsRule = (Fun,[(Cat,Bool,VariableName,PropertyName)]) + +cabsrule2csharpabsrule :: CAbsRule -> CSharpAbsRule +cabsrule2csharpabsrule (f, cabsrule) = (f, addPropertyNames cabsrule) + +-- This generates names for properties. It's done the same way as generation of variable names in OOAbstract->cf2cabs +-- A property name uses the same casing as its category, but has an underscore at the end +addPropertyNames :: [(Cat, Bool, String)] -> [(Cat, Bool, VariableName, PropertyName)] +addPropertyNames cs = [(c,b,v,p) | ((c,b,v),p) <- zip cs (properties [] (map propertyName [c | (c,_,_) <- cs]))] + --- creating new names is quadratic, but parameter lists are short + --- this should conform with Michael's naming + where + properties seen vv = case vv of + [] -> vv + v:vs -> case length (filter (==v) seen) of + 0 | elem v vs -> (v ++ "1"): properties (v:seen) vs + 0 -> v : properties (v:seen) vs + n -> (v ++ show (n+1)) : properties (v:seen) vs + +propertyName :: Cat -> PropertyName +propertyName c = c ++ "_" + +-- Given a rule's definition, it goes through and nicely the properties by type. +-- Does the same thing as numVars in NamedVariables, except the varName part +numProps :: [(String, Int)] -> [Either String b] -> [Either String b] +numProps _env [] = [] +numProps env ((Right f) : fs) = (Right f) : (numProps env fs) +numProps env ((Left f) : fs) = + case lookup f' env of + Nothing -> (Left f') : (numProps ((f',1):env) fs) + Just n -> (Left $ f' ++ (show $ n + 1)) : (numProps ((f',n+1):env) fs) + where + f' = propertyName (normCat (identCat f)) + diff --git a/src/formats/c-sharp/RegToGPLEX.hs b/src/formats/c-sharp/RegToGPLEX.hs new file mode 100644 --- /dev/null +++ b/src/formats/c-sharp/RegToGPLEX.hs @@ -0,0 +1,73 @@ +module RegToGPLEX (printRegGPLEX) where + +-- modified from RegToFlex + +import AbsBNF +import Data.Char + +-- the top-level printing method +printRegGPLEX :: Reg -> String +printRegGPLEX = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend (0::Int) where + rend i ss = case ss of + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + cons s t = s ++ t + new i s = s + space t s = if null s then t else t ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ c = [[c]] + prtList s = map (concat . prt 0) s + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["[^.]"]) + RChar c -> prPrec i 3 (prt 0 [mkEsc [c]]) + RAlts str -> prPrec i 3 (concat [["["], prt 0 $ mkEsc str, ["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) $ mkEsc str)) + RDigit -> prPrec i 3 (concat [["{digit}"]]) + RLetter -> prPrec i 3 (concat [["{alpha}"]]) + RUpper -> prPrec i 3 (concat [["{alphaCapital}"]]) + RLower -> prPrec i 3 (concat [["{alphaSmall}"]]) + RAny -> prPrec i 3 (concat [["."]]) + +-- Handle special characters in regular expressions. +mkEsc :: String -> String +mkEsc = concatMap escChar + where escChar c + | c `elem` "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" = '\\':[c] + | otherwise = [c] diff --git a/src/formats/c/CFtoBisonC.hs b/src/formats/c/CFtoBisonC.hs new file mode 100644 --- /dev/null +++ b/src/formats/c/CFtoBisonC.hs @@ -0,0 +1,275 @@ +{- + BNF Converter: C Bison generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Bison input file. + Note that because of the way bison stores results + the programmer can increase performance by limiting + the number of entry points in their grammar. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 6 August, 2003 + + Modified : 6 August, 2003 + + + ************************************************************** +-} + + +module CFtoBisonC (cf2Bison) where + +import CF +import Data.List (intersperse, isPrefixOf) +import NamedVariables hiding (varName) +import Data.Char (toLower) +import Utils ((+++), (++++)) + +--This follows the basic structure of CFtoHappy. + +-- Type declarations +type Rules = [(NonTerminal,[(Pattern,Action)])] +type NonTerminal = String +type Pattern = String +type Action = String +type MetaVar = String + +--The environment comes from the CFtoFlex +cf2Bison :: String -> CF -> SymEnv -> String +cf2Bison name cf env + = unlines + [header name cf, + union (allCats cf), + "%token _ERROR_", + tokens user env, + declarations cf, + specialToks cf, + "%%", + prRules (rulesForBison cf env) + ] + where + user = fst (unzip (tokenPragmas cf)) + +header :: String -> CF -> String +header name cf = unlines + ["/* This Bison file was machine-generated by BNFC */", + "%{", + "#include ", + "#include ", + "#include ", + "#include \"Absyn.h\"", + "#define initialize_lexer " ++ name ++ "_initialize_lexer", + "extern int yyparse(void);", + "extern int yylex(void);", + "extern int initialize_lexer(FILE * inp);", + "void yyerror(const char *str)", + "{", + " fprintf(stderr,\"error: %s\\n\",str);", + "}", + "", + -- M.F. 2004-09-17 changed allEntryPoints to allCatsIdNorm. Seems to fix the [Ty2] bug. + unlines $ map (parseMethod name) (allCatsIdNorm cf), -- (allEntryPoints cf), + concatMap reverseList (filter isList (allCats cf)), + "%}" + ] + +--This generates a parser method for each entry point. +parseMethod :: String -> Cat -> String +parseMethod name cat = +-- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm +-- then "" +-- else + unlines + [ + cat' +++ (resultName cat') +++ "= 0;", + cat' ++ " p" ++ cat' ++ "(FILE *inp)", + "{", + " initialize_lexer(inp);", + " if (yyparse())", + " { /* Failure */", + " return 0;", + " }", + " else", + " { /* Success */", + " return" +++ (resultName cat') ++ ";", + " }", + "}" + ] + where + cat' = identCat (normCat cat) + +--This method generates list reversal functions for each list type. +reverseList :: Cat -> String +reverseList c = unlines + [ + c' ++ " reverse" ++ c' ++ "(" ++ c' +++ "l)", + "{", + " " ++ c' +++"prev = 0;", + " " ++ c' +++"tmp = 0;", + " while (l)", + " {", + " tmp = l->" ++ v ++ ";", + " l->" ++ v +++ "= prev;", + " prev = l;", + " l = tmp;", + " }", + " return prev;", + "}" + ] + where + c' = identCat (normCat c) + v = (map toLower c') ++ "_" + +--The union declaration is special to Bison/Yacc and gives the type of yylval. +--For efficiency, we may want to only include used categories here. +union :: [Cat] -> String +union cats = unlines + [ + "%union", + "{", + " int int_;", + " char char_;", + " double double_;", + " char* string_;", + concatMap mkPointer cats, + "}" + ] + where --This is a little weird because people can make [Exp2] etc. + mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion. + " " ++ (identCat (normCat s)) +++ (varName (normCat s)) ++ ";\n" + mkPointer s | normCat s == s = --normal cat + " " ++ (identCat (normCat s)) +++ (varName (normCat s)) ++ ";\n" + mkPointer s = "" + +--declares non-terminal types. +declarations :: CF -> String +declarations cf = concatMap (typeNT cf) (allCats cf) + where --don't define internal rules + typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n" + typeNT cf nt = "" + +--declares terminal types. +tokens :: [UserDef] -> SymEnv -> String +tokens user ts = concatMap (declTok user) ts + where + declTok u (s,r) = if elem s u + then "%token " ++ r ++ " /* " ++ s ++ " */\n" + else "%token " ++ r ++ " /* " ++ s ++ " */\n" + +specialToks :: CF -> String +specialToks cf = concat [ + ifC "String" "%token _STRING_\n", + ifC "Char" "%token _CHAR_\n", + ifC "Integer" "%token _INTEGER_\n", + ifC "Double" "%token _DOUBLE_\n", + ifC "Ident" "%token _IDENT_\n" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + +--The following functions are a (relatively) straightforward translation +--of the ones in CFtoHappy.hs +rulesForBison :: CF -> SymEnv -> Rules +rulesForBison cf env = map mkOne $ ruleGroups cf where + mkOne (cat,rules) = constructRule cf env rules cat + +-- For every non-terminal, we construct a set of rules. +constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule cf env rules nt = (nt,[(p,(generateAction (normCat (identCat nt)) (ruleName r) b m) +++ result) | + r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True,revSepListRule r0) + else (False,r0), + let (p,m) = generatePatterns cf env r]) + where + ruleName r = case funRule r of + "(:)" -> identCat nt + z -> z + revs = reversibleCats cf + eps = allEntryPoints cf + isEntry nt = if elem nt eps then True else False + result = if isEntry nt then (resultName (normCat (identCat nt))) ++ "= $$;" else "" + +-- Generates a string containing the semantic action. +generateAction :: NonTerminal -> Fun -> Bool -> [MetaVar] -> Action +generateAction nt f b ms = + if isCoercion f + then (unwords ms) ++ ";" + else if isNilFun f + then "0;" + else if isOneFun f + then concat ["make_", nt, "(", (concat (intersperse ", " ms')), ", 0);"] + else concat ["make_", normCat f, "(", (concat (intersperse ", " ms')), ");"] + where + ms' = if b then reverse ms else ms + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal +generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar]) +generatePatterns cf env r = case rhsRule r of + [] -> ("/* empty */",[]) + its -> (unwords (map mkIt its), metas its) + where + mkIt i = case i of + Left c -> case lookup c env of + Just x -> x + Nothing -> typeName (identCat c) + Right s -> case lookup s env of + Just x -> x + Nothing -> s + metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its] + revIf c m = if (not (isConsFun (funRule r)) && elem c revs) + then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")") + else m -- no reversal in the left-recursive Cons rule itself + revs = reversibleCats cf + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. + +prRules :: Rules -> String +prRules [] = [] +prRules ((nt, []):rs) = prRules rs --internal rule +prRules ((nt,((p,a):ls)):rs) = + (unwords [nt', ":" , p, "{ $$ =", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ $$ =", a , "}"])]) ++ pr ls + +--Some helper functions. +resultName :: String -> String +resultName s = "YY_RESULT_" ++ s ++ "_" + +--slightly stronger than the NamedVariable version. +varName :: String -> String +varName s = (map toLower (identCat s)) ++ "_" + +typeName :: String -> String +typeName "Ident" = "_IDENT_" +typeName "String" = "_STRING_" +typeName "Char" = "_CHAR_" +typeName "Integer" = "_INTEGER_" +typeName "Double" = "_DOUBLE_" +typeName x = x diff --git a/src/formats/c/CFtoCAbs.hs b/src/formats/c/CFtoCAbs.hs new file mode 100644 --- /dev/null +++ b/src/formats/c/CFtoCAbs.hs @@ -0,0 +1,329 @@ +{- + BNF Converter: C Abstract syntax + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C Abstract Syntax + tree classes. It generates both a Header file + and an Implementation file, and Appel's C + method. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 15 September, 2003 + + Modified : 15 September, 2003 + + + ************************************************************** +-} + +module CFtoCAbs (cf2CAbs) where + +import CF +import Utils((+++),(++++)) +import NamedVariables +import Data.List +import Data.Char(toLower) + + +--The result is two files (.H file, .C file) +cf2CAbs :: String -> CF -> (String, String) +cf2CAbs name cf = (mkHFile cf, mkCFile cf) + + +{- **** Header (.H) File Functions **** -} + +--Makes the Header file. +mkHFile :: CF -> String +mkHFile cf = unlines + [ + "#ifndef ABSYN_HEADER", + "#define ABSYN_HEADER", + "", + header, + prTypeDefs user, + "/******************** Forward Declarations ********************/\n", + concatMap prForward classes, + "", + "/******************** Abstract Syntax Classes ********************/\n", + concatMap (prDataH user) (cf2dataLists cf), + "", + "#endif" + ] + where + user = fst (unzip (tokenPragmas cf)) + header = "/* C++ Abstract Syntax Interface generated by the BNF Converter.*/\n" + rules = getRules cf + classes = rules ++ getClasses (allCats cf) + prForward s | not (isCoercion s) = unlines + [ + "struct " ++ s' ++ "_;", + "typedef struct " ++ s' ++ "_ *" ++ s' ++ ";" + ] + where + s' = normCat s + prForward s = "" + getRules cf = (map testRule (rulesOfCF cf)) + getClasses [] = [] + getClasses (c:cs) = + if identCat (normCat c) /= c + then getClasses cs + else if elem c rules + then getClasses cs + else c : (getClasses cs) + + testRule (Rule f c r) = + if isList c + then if isConsFun f + then identCat c + else "_" --ignore this + else "_" + +--Prints struct definitions for all categories. +prDataH :: [UserDef] -> Data -> String +prDataH user (cat, rules) = + if isList cat + then unlines + [ + "struct " ++ c' ++ "_", + "{", + " " ++ mem +++ (varName mem) ++ ";", + " " ++ c' +++ (varName c') ++ ";", + "};", + "", + c' ++ " make_" ++ c' ++ "(" ++ mem ++ " p1, " ++ c' ++ " p2);" + ] + else unlines + [ + "struct " ++ cat ++ "_", + "{", + " enum { " ++ (concat (intersperse ", " (map prKind rules))) ++ " } kind;", + " union", + " {", + concatMap (prUnion user) rules ++ " } u;", + "};", + "", + concatMap (prRuleH user cat) rules + ] + where + c' = identCat (normCat cat) + mem = identCat (normCatOfList cat) + prKind (fun, cats) = "is_" ++ (normCat fun) + prMember user (fun, []) = "" + prMember user (fun, cats) = " " ++ (prInstVars user (getVars cats)) + prUnion user (fun, []) = "" + prUnion user (fun, cats) = " struct { " ++ (prInstVars user (getVars cats)) ++ " } " ++ (memName fun) ++ ";\n" + + +--Interface definitions for rules vary on the type of rule. +prRuleH :: [UserDef] -> String -> (Fun, [Cat]) -> String +prRuleH user c (fun, cats) = + if isNilFun fun || isOneFun fun || isConsFun fun + then "" --these are not represented in the AbSyn + else --a standard rule + c ++ " make_" ++ fun' ++ "(" ++ (prParamsH 0 (getVars cats)) ++ ");\n" + where + fun' = identCat (normCat fun) + prParamsH :: Int -> [(String, a)] -> String + prParamsH _ [] = "" + prParamsH n ((t,_):[]) = t ++ " p" ++ (show n) + prParamsH n ((t,_):vs) = (t ++ " p" ++ (show n) ++ ", ") ++ (prParamsH (n+1) vs) + +--typedefs in the Header make generation much nicer. +prTypeDefs user = unlines + [ + "/******************** TypeDef Section ********************/", + "typedef int Integer;", + "typedef char Char;", + "typedef double Double;", + "typedef char* String;", + "typedef char* Ident;", + concatMap prUserDef user + ] + where + prUserDef s = "typedef char* " ++ s ++ ";\n" + +--A class's instance variables. +prInstVars :: [UserDef] -> [IVar] -> String +prInstVars _ [] = [] +prInstVars user vars@((t,n):[]) = + t +++ uniques + where + (uniques, vs') = prUniques t vars +prInstVars user vars@((t,n):vs) = + t +++ uniques ++ + (prInstVars user vs') + where + (uniques, vs') = prUniques t vars + +--these functions group the types together nicely +prUniques :: String -> [IVar] -> (String, [IVar]) +prUniques t vs = (prVars (findIndices (\x -> case x of (y,_) -> y == t) vs) vs, remType t vs) + where + remType :: String -> [IVar] -> [IVar] + remType _ [] = [] + remType t ((t2,n):ts) = if t == t2 + then (remType t ts) + else (t2,n) : (remType t ts) + prVars (x:[]) vs = case vs !! x of + (t,n) -> (varName t) ++ (showNum n) ++ ";" + prVars (x:xs) vs = case vs !! x of + (t,n) -> (varName t) ++ (showNum n) ++ ", " ++ + (prVars xs vs) + + +{- **** Implementation (.C) File Functions **** -} + +--Makes the .C file +mkCFile :: CF -> String +mkCFile cf = unlines + [ + header, + concatMap (prDataC user) (cf2dataLists cf) + ] + where + user = fst (unzip (tokenPragmas cf)) + header = unlines + [ + "/* C Abstract Syntax Implementation generated by the BNF Converter. */", + "", + "#include ", + "#include ", + "#include \"Absyn.h\"", + "" + ] + +--This is not represented in the implementation. +--This is not represented in the implementation. +prDataC :: [UserDef] -> Data -> String +prDataC user (cat, rules) = concatMap (prRuleC user cat) rules + +--Classes for rules vary based on the type of rule. +prRuleC user c (fun, cats) = + if isNilFun fun || isOneFun fun + then "" --these are not represented in the AbSyn + else if isConsFun fun + then --this is the linked list case. + unlines + [ + "/******************** " ++ c' ++ " ********************/", + prListFuncs user c', + "" + ] + else --a standard rule + unlines + [ + "/******************** " ++ fun' ++ " ********************/", + prConstructorC user c fun' vs cats, + "" + ] + where + vs = getVars cats + fun' = identCat (normCat fun) + c' = identCat (normCat c) + +--These are all built-in list functions. +--Later we could include things like lookup,insert,delete,etc. +prListFuncs :: [UserDef] -> String -> String +prListFuncs user c = unlines + [ + c ++ " make_" ++ c ++"(" ++ m ++ " p1" ++ ", " ++ c ++ " p2)", + "{", + " " ++ c ++ " tmp = (" ++ c ++ ") malloc(sizeof(*tmp));", + " if (!tmp)", + " {", + " fprintf(stderr, \"Error: out of memory when allocating " ++ c ++ "!\\n\");", + " exit(1);", + " }", + " tmp->" ++ m' ++ " = " ++ "p1;", + " tmp->" ++ v ++ " = " ++ "p2;", + " return tmp;", + "}" + ] + where + v = (map toLower c) ++ "_" + m = drop 4 c + m' = drop 4 v + +--The constructor just assigns the parameters to the corresponding instance variables. +prConstructorC :: [UserDef] -> String -> String -> [IVar] -> [Cat] -> String +prConstructorC user cat c vs cats = + unlines + [ + cat' ++ " make_" ++ c ++"(" ++ (interleave types params) ++ ")", + "{", + " " ++ cat' ++ " tmp = (" ++ cat' ++ ") malloc(sizeof(*tmp));", + " if (!tmp)", + " {", + " fprintf(stderr, \"Error: out of memory when allocating " ++ c ++ "!\\n\");", + " exit(1);", + " }", + " tmp->kind = is_" ++ c ++ ";", + prAssigns c vs params, + " return tmp;", + "}" + ] + where + cat' = identCat (normCat cat) + (types, params) = unzip (prParams cats (length cats) ((length cats)+1)) + interleave _ [] = [] + interleave (x:[]) (y:[]) = x +++ y + interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys) + +--Prints the constructor's parameters. +prParams :: [Cat] -> Int -> Int -> [(String,String)] +prParams [] _ _ = [] +prParams (c:cs) n m = (identCat c,"p" ++ (show (m-n))) + : (prParams cs (n-1) m) + +--Prints the assignments of parameters to instance variables. +--This algorithm peeks ahead in the list so we don't use map or fold +prAssigns :: String -> [IVar] -> [String] -> String +prAssigns _ [] _ = [] +prAssigns _ _ [] = [] +prAssigns c ((t,n):vs) (p:ps) = + if n == 1 then + case findIndices (\x -> case x of (l,r) -> l == t) vs of + [] -> " tmp->u." ++ c' ++ "_." ++ (varName t) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps) + z -> " tmp->u." ++ c' ++ "_." ++ ((varName t) ++ (showNum n)) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps) + else " tmp->u." ++ c' ++ "_." ++ ((varName t) ++ (showNum n)) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps) + where + c' = map toLower c + +{- **** Helper Functions **** -} + +--Checks if something is a basic or user-defined type. +isBasic :: [UserDef] -> String -> Bool +isBasic user x = + if elem x user + then True + else case x of + "Integer" -> True + "Char" -> True + "String" -> True + "Double" -> True + "Ident" -> True + _ -> False + +memName s = (map toLower s) ++ "_" diff --git a/src/formats/c/CFtoCPrinter.hs b/src/formats/c/CFtoCPrinter.hs new file mode 100644 --- /dev/null +++ b/src/formats/c/CFtoCPrinter.hs @@ -0,0 +1,654 @@ +{- + BNF Converter: C Pretty Printer printer + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C Pretty Printer. + It also generates the "show" method for + printing an abstract syntax tree. + + The generated files use the Visitor design pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 10 August, 2003 + + Modified : 3 September, 2003 + * Added resizable buffers + + ************************************************************** +-} + +module CFtoCPrinter (cf2CPrinter) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower, toUpper) + +--Produces (.h file, .c file) +cf2CPrinter :: CF -> (String, String) +cf2CPrinter cf = (mkHFile cf groups, mkCFile cf groups) + where + groups = (fixCoercions (ruleGroupsInternals cf)) + +{- **** Header (.h) File Methods **** -} + +--An extremely large function to make the Header File +mkHFile :: CF -> [(Cat,[Rule])] -> String +mkHFile cf groups = unlines + [ + header, + concatMap prPrints eps, + concatMap prPrintDataH groups, + concatMap prShows eps, + concatMap prShowDataH groups, + footer + ] + where + eps = allEntryPoints cf + prPrints s | normCat s == s = "char* print" ++ s' ++ "(" ++ s' ++ " p);\n" + where + s' = identCat s + prPrints _ = "" + prShows s | normCat s == s = "char* show" ++ s' ++ "(" ++ s' ++ " p);\n" + where + s' = identCat s + prShows _ = "" + header = unlines + [ + "#ifndef PRINTER_HEADER", + "#define PRINTER_HEADER", + "", + "#include \"Absyn.h\"", + "", + "/* Certain applications may improve performance by changing the buffer size */", + "#define BUFFER_INITIAL 2000", + "/* You may wish to change _L_PAREN or _R_PAREN */", + "#define _L_PAREN '('", + "#define _R_PAREN ')'", + "", + "/* The following are simple heuristics for rendering terminals */", + "/* You may wish to change them */", + "void renderCC(Char c);", + "void renderCS(String s);", + "void indent(void);", + "void backup(void);", + "" + ] + footer = unlines $ + ["void pp" ++ t ++ "(String s, int i);" | t <- tokenNames cf] + ++ + ["void sh" ++ t ++ "(String s);" | t <- tokenNames cf] + ++ + [ + "void ppInteger(Integer n, int i);", + "void ppDouble(Double d, int i);", + "void ppChar(Char c, int i);", + "void ppString(String s, int i);", + "void ppIdent(String s, int i);", + "void shInteger(Integer n);", + "void shDouble(Double d);", + "void shChar(Char c);", + "void shString(String s);", + "void shIdent(String s);", + "void bufAppendS(const char* s);", + "void bufAppendC(const char c);", + "void bufReset(void);", + "void resizeBuffer(void);", + "", + "#endif" + ] + +--Prints all the required method names and their parameters. +prPrintDataH :: (Cat, [Rule]) -> String +prPrintDataH (cat, rules) = concat ["void pp", cl, "(", cl, " p, int i);\n"] + where + cl = identCat (normCat cat) + +--Prints all the required method names and their parameters. +prShowDataH :: (Cat, [Rule]) -> String +prShowDataH (cat, rules) = concat ["void sh", cl, "(", cl, " p);\n"] + where + cl = identCat (normCat cat) + +{- **** Implementation (.C) File Methods **** -} + +--This makes the .C file by a similar method. +mkCFile :: CF -> [(Cat,[Rule])] -> String +mkCFile cf groups = concat + [ + header, + prRender, + concatMap prPrintFun eps, + concatMap prShowFun eps, + concatMap (prPrintData user) groups, + printBasics, + printTokens, + concatMap (prShowData user) groups, + showBasics, + showTokens, + footer + ] + where + eps = allEntryPoints cf + user = fst (unzip (tokenPragmas cf)) + header = unlines + [ + "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/", + "", + "#include \"Printer.h\"", + "#include ", + "#include ", + "#include ", + "", + "int _n_;", + "char* buf_;", + "int cur_;", + "int buf_size;", + "" + ] + printBasics = unlines + [ + "void ppInteger(Integer n, int i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%d\", n);", + " bufAppendS(tmp);", + "}", + "void ppDouble(Double d, int i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%g\", d);", + " bufAppendS(tmp);", + "}", + "void ppChar(Char c, int i)", + "{", + " bufAppendC('\\'');", + " bufAppendC(c);", + " bufAppendC('\\'');", + "}", + "void ppString(String s, int i)", + "{", + " bufAppendC('\\\"');", + " bufAppendS(s);", + " bufAppendC('\\\"');", + "}", + "void ppIdent(String s, int i)", + "{", + " renderS(s);", + "}", + "" + ] + printTokens = unlines + [unlines [ + "void pp" ++ t ++ "(String s, int i)", + "{", + " renderS(s);", + "}", + "" + ] | t <- tokenNames cf + ] + showBasics = unlines + [ + "void shInteger(Integer i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%d\", i);", + " bufAppendS(tmp);", + "}", + "void shDouble(Double d)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%g\", d);", + " bufAppendS(tmp);", + "}", + "void shChar(Char c)", + "{", + " bufAppendC('\\'');", + " bufAppendC(c);", + " bufAppendC('\\'');", + "}", + "void shString(String s)", + "{", + " bufAppendC('\\\"');", + " bufAppendS(s);", + " bufAppendC('\\\"');", + "}", + "void shIdent(String s)", + "{", + " bufAppendC('\\\"');", + " bufAppendS(s);", + " bufAppendC('\\\"');", + "}", + "" + ] + showTokens = unlines + [unlines [ + "void sh" ++ t ++ "(String s)", + "{", + " bufAppendC('\\\"');", + " bufAppendS(s);", + " bufAppendC('\\\"');", + "}", + "" + ] | t <- tokenNames cf + ] + footer = unlines + [ + "void bufAppendS(const char* s)", + "{", + " int len = strlen(s);", + " int n;", + " while (cur_ + len > buf_size)", + " {", + " buf_size *= 2; /* Double the buffer size */", + " resizeBuffer();", + " }", + " for(n = 0; n < len; n++)", + " {", + " buf_[cur_ + n] = s[n];", + " }", + " cur_ += len;", + " buf_[cur_] = 0;", + "}", + "void bufAppendC(const char c)", + "{", + " if (cur_ == buf_size)", + " {", + " buf_size *= 2; /* Double the buffer size */", + " resizeBuffer();", + " }", + " buf_[cur_] = c;", + " cur_++;", + " buf_[cur_] = 0;", + "}", + "void bufReset(void)", + "{", + " cur_ = 0;", + " buf_size = BUFFER_INITIAL;", + " resizeBuffer();", + " memset(buf_, 0, buf_size);", + "}", + "void resizeBuffer(void)", + "{", + " char* temp = (char*) malloc(buf_size);", + " if (!temp)", + " {", + " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");", + " exit(1);", + " }", + " if (buf_)", + " {", + " strncpy(temp, buf_, buf_size); /* peteg: strlcpy is safer, but not POSIX/ISO C. */", + " free(buf_);", + " }", + " buf_ = temp;", + "}", + "char *buf_;", + "int cur_, buf_size;", + "" + ] + + +{- **** Pretty Printer Methods **** -} + +--An entry point to begin printing +prPrintFun :: Cat -> String +prPrintFun ep | normCat ep == ep = unlines + [ + "char* print" ++ ep' ++ "(" ++ ep' ++ " p)", + "{", + " _n_ = 0;", + " bufReset();", + " pp" ++ ep' ++ "(p, 0);", + " return buf_;", + "}" + ] + where + ep' = identCat ep +prPrintFun _ = "" + +--Generates methods for the Pretty Printer +prPrintData :: [UserDef] -> (Cat, [Rule]) -> String +prPrintData user (cat, rules) = + if isList cat + then unlines + [ + "void pp" ++ cl ++ "("++ cl +++ vname ++ ", int i)", + "{", + " while(" ++ vname ++ "!= 0)", + " {", + " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)", + " {", + visitMember, + optsep, + " " ++ vname +++ "= 0;", + " }", + " else", + " {", + visitMember, + " render" ++ sc ++ "(" ++ sep ++ ");", + " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", + " }", + " }", + "}", + "" + ] --Not a list: + else unlines + [ + "void pp" ++ cl ++ "(" ++ cl ++ " _p_, int _i_)", + "{", + " switch(_p_->kind)", + " {", + concatMap (prPrintRule user) rules, + " default:", + " fprintf(stderr, \"Error: bad kind field when printing " ++ cat ++ "!\\n\");", + " exit(1);", + " }", + "}\n" + ] + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl + visitMember = " pp" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_, 0);" + (sc, sep) = if length sep' == 1 + then ("C", "'" ++ escapeChars sep' ++ "'") + else ("S", "\"" ++ escapeChars sep' ++ "\"") + sep' = getCons rules + optsep = if hasOneFunc rules then "" else (" render" ++ sc ++ "(" ++ sep ++ ");") + +--Pretty Printer methods for a rule. +prPrintRule :: [UserDef] -> Rule -> String +prPrintRule user r@(Rule fun c cats) | not (isCoercion fun) = unlines + [ + " case is_" ++ fun ++ ":", + lparen, + cats', + rparen, + " break;\n" + ] + where + p = precRule r + (lparen, rparen) = + (" if (_i_ > " ++ (show p) ++ ") renderC(_L_PAREN);", + " if (_i_ > " ++ (show p) ++ ") renderC(_R_PAREN);") + cats' = (concatMap (prPrintCat user fun) (zip3 (fixOnes (numVars [] cats)) cats (map getPrec cats))) + getPrec (Right s) = (0 :: Int) + getPrec (Left c) = precCat c +prPrintRule _ _ = "" + +--This goes on to recurse to the instance variables. +prPrintCat :: [UserDef] -> String -> (Either Cat String, Either Cat String, Int) -> String +prPrintCat user fnm (c,o,p) = case c of + (Right t) -> " render" ++ sc ++ "(" ++ t' ++ ");\n" + where + (sc,t') = if length t == 1 + then ("C", "'" ++ (escapeChars t) ++ "'") + else ("S", "\"" ++ (escapeChars t) ++ "\"") + (Left nt) -> if isBasic user nt + then " pp" ++ (basicFunName nt) ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ", " ++ (show p) ++ ");\n" + else if nt == "#_" --Internal category + then " /* Internal Category */\n" + else " pp" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ", " ++ (show p) ++ ");\n" + where + v = map toLower (identCat (normCat fnm)) + o' = case o of + Right x -> x + Left x -> normCat (identCat x) + +{- **** Abstract Syntax Tree Printer **** -} + +--An entry point to begin printing +prShowFun :: Cat -> String +prShowFun ep | normCat ep == ep = unlines + [ + "char* show" ++ ep' ++ "(" ++ ep' ++ " p)", + "{", + " _n_ = 0;", + " bufReset();", + " sh" ++ ep' ++ "(p);", + " return buf_;", + "}" + ] + where + ep' = identCat ep +prShowFun _ = "" + +--This prints the functions for Abstract Syntax tree printing. +prShowData :: [UserDef] -> (Cat, [Rule]) -> String +prShowData user (cat, rules) = + if isList cat + then unlines + [ + "void sh" ++ cl ++ "("++ cl +++ vname ++ ")", + "{", + " while(" ++ vname ++ "!= 0)", + " {", + " if (" ++ vname ++ "->" ++ vname ++ "_)", + " {", + visitMember, + " bufAppendS(\", \");", + " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", + " }", + " else", + " {", + visitMember, + " " ++ vname ++ " = 0;", + " }", + " }", + "}", + "" + ] --Not a list: + else unlines + [ + "void sh" ++ cl ++ "(" ++ cl ++ " _p_)", + "{", + " switch(_p_->kind)", + " {", + concatMap (prShowRule user) rules, + " default:", + " fprintf(stderr, \"Error: bad kind field when showing " ++ cat ++ "!\\n\");", + " exit(1);", + " }", + "}\n" + ] + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl + visitMember = " sh" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);" + +--Pretty Printer methods for a rule. +prShowRule :: [UserDef] -> Rule -> String +prShowRule user r@(Rule fun c cats) | not (isCoercion fun) = unlines + [ + " case is_" ++ fun ++ ":", + lparen, + " bufAppendS(\"" ++ fun ++ "\");\n", + optspace, + cats', + rparen, + " break;\n" + ] + where + (optspace, lparen, rparen) = if allTerms cats + then ("","","") + else (" bufAppendC(' ');\n", " bufAppendC('(');\n"," bufAppendC(')');\n") + cats' = if allTerms cats + then "" + else concat (insertSpaces (map (prShowCat user fun) (zip (fixOnes (numVars [] cats)) cats))) + insertSpaces [] = [] + insertSpaces (x:[]) = [x] + insertSpaces (x:xs) = if x == "" + then insertSpaces xs + else (x : [" bufAppendC(' ');\n"]) ++ (insertSpaces xs) + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs +prShowRule _ _ = "" + +--This goes on to recurse to the instance variables. +prShowCat :: [UserDef] -> String -> (Either Cat String, Either Cat String) -> String +prShowCat user fnm (c,o) = case c of + (Right t) -> "" + (Left nt) -> if isBasic user nt + then " sh" ++ (basicFunName nt) ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n" + else if nt == "#_" --Internal category + then " /* Internal Category */\n" + else if ((normCat nt) /= nt) + then " sh" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n" + else concat + [ + " bufAppendC('[');\n", + " sh" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n", + " bufAppendC(']');\n" + ] + where + v = map toLower (identCat (normCat fnm)) + o' = case o of + Right x -> x + Left x -> normCat (identCat x) + +{- **** Helper Functions Section **** -} + + +--Just checks if something is a basic or user-defined type. +--This is because you don't -> a basic non-pointer type. +isBasic :: [UserDef] -> String -> Bool +isBasic user v = + if elem (init v) user' + then True + else if "integer_" `isPrefixOf` v then True + else if "char_" `isPrefixOf` v then True + else if "string_" `isPrefixOf` v then True + else if "double_" `isPrefixOf` v then True + else if "ident_" `isPrefixOf` v then True + else False + where + user' = map (map toLower) user + +--The visit-function name of a basic type +basicFunName :: String -> String +basicFunName v = + if "integer_" `isPrefixOf` v then "Integer" + else if "char_" `isPrefixOf` v then "Char" + else if "string_" `isPrefixOf` v then "String" + else if "double_" `isPrefixOf` v then "Double" + else if "ident_" `isPrefixOf` v then "Ident" + else "Ident" --User-defined type + +--Just sets the coercion level for parentheses in the Pretty Printer. +setI :: Int -> String +setI n = "_i_ = " ++ (show n) ++ "; " + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) + +--An extremely simple renderCer for terminals. +prRender :: String +prRender = unlines + [ + "/* You may wish to change the renderC functions */", + "void renderC(Char c)", + "{", + " if (c == '{')", + " {", + " bufAppendC('\\n');", + " indent();", + " bufAppendC(c);", + " _n_ = _n_ + 2;", + " bufAppendC('\\n');", + " indent();", + " }", + " else if (c == '(' || c == '[')", + " bufAppendC(c);", + " else if (c == ')' || c == ']')", + " {", + " backup();", + " bufAppendC(c);", + " bufAppendC(' ');", + " }", + " else if (c == '}')", + " {", + " _n_ = _n_ - 2;", + " backup();", + " backup();", + " bufAppendC(c);", + " bufAppendC('\\n\');", + " indent();", + " }", + " else if (c == ',')", + " {", + " backup();", + " bufAppendC(c);", + " bufAppendC(' ');", + " }", + " else if (c == ';')", + " {", + " backup();", + " bufAppendC(c);", + " bufAppendC('\\n');", + " indent();", + " }", + " else if (c == 0) return;", + " else", + " {", + " bufAppendC(c);", + " bufAppendC(' ');", + " }", + "}", + "void renderS(String s)", + "{", + " if(strlen(s) > 0)", + " {", + " bufAppendS(s);", + " bufAppendC(' ');", + " }", + "}", + "void indent(void)", + "{", + " int n = _n_;", + " while (n > 0)", + " {", + " bufAppendC(' ');", + " n--;", + " }", + "}", + "void backup(void)", + "{", + " if (buf_[cur_ - 1] == ' ')", + " {", + " buf_[cur_ - 1] = 0;", + " cur_--;", + " }", + "}" + ] diff --git a/src/formats/c/CFtoCSkel.hs b/src/formats/c/CFtoCSkel.hs new file mode 100644 --- /dev/null +++ b/src/formats/c/CFtoCSkel.hs @@ -0,0 +1,240 @@ +{- + BNF Converter: C Skeleton generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C Skeleton functions. + + The generated files follow Appel's case method. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 9 August, 2003 + + Modified : 12 August, 2003 + + + ************************************************************** +-} + +module CFtoCSkel (cf2CSkel) where + +import CF +import Utils ( (+++) ) +import NamedVariables +import Data.List ( isPrefixOf ) +import Data.Char ( toLower, toUpper ) + +--Produces (.H file, .C file) +cf2CSkel :: CF -> (String, String) +cf2CSkel cf = (mkHFile cf groups, mkCFile cf groups) + where + groups = (fixCoercions (ruleGroups cf)) + + +{- **** Header (.H) File Functions **** -} + +--Generates the Header File +mkHFile :: CF -> [(Cat,[Rule])] -> String +mkHFile cf groups = unlines + [ + header, + concatMap prDataH groups, + concatMap prUserH user, + footer + ] + where + user = fst (unzip (tokenPragmas cf)) + header = unlines + [ + "#ifndef SKELETON_HEADER", + "#define SKELETON_HEADER", + "/* You might want to change the above name. */", + "", + "#include \"Absyn.h\"", + "" + ] + prUserH u = "void visit" ++ u' ++ "(" ++ u ++ " p);" + where + u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem. + footer = unlines + [ + "void visitIdent(Ident i);", + "void visitInteger(Integer i);", + "void visitDouble(Double d);", + "void visitChar(Char c);", + "void visitString(String s);", + "", + "#endif" + ] + +--Prints out visit functions for a category +prDataH :: (Cat, [Rule]) -> String +prDataH (cat, _rules) = + if isList cat + then concat ["void visit", cl, "(", cl, " p);\n"] + else "void visit" ++ cl ++ "(" ++ cl ++ " p);\n" + where cl = identCat $ normCat cat + +{- **** Implementation (.C) File Functions **** -} + +--Makes the .C File +mkCFile :: CF -> [(Cat,[Rule])] -> String +mkCFile cf groups = concat + [ + header, + concatMap (prData user) groups, + concatMap prUser user, + footer + ] + where + user = fst (unzip (tokenPragmas cf)) + header = unlines [ + "/*** BNFC-Generated Visitor Traversal Skeleton. ***/", + "/* This traverses the abstract syntax tree.", + " To use, copy Skeleton.h and Skeleton.c to", + " new files. */", + "", + "#include \"Skeleton.h\"", + "" + ] + prUser u = unlines + [ + "void visit" ++ u' ++ "(" ++ u ++ " p)", + "{", + " /* Code for " ++ u ++ " Goes Here */", + "}" + ] + where + u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem. + footer = unlines + [ + "void visitIdent(Ident i)", + "{", + " /* Code for Ident Goes Here */", + "}", + "void visitInteger(Integer i)", + "{", + " /* Code for Integer Goes Here */", + "}", + "void visitDouble(Double d)", + "{", + " /* Code for Double Goes Here */", + "}", + "void visitChar(Char c)", + "{", + " /* Code for Char Goes Here */", + "}", + "void visitString(String s)", + "{", + " /* Code for String Goes Here */", + "}", + "" + ] + +--Visit functions for a category. +prData :: [UserDef] -> (Cat, [Rule]) -> String +prData user (cat, rules) = + if isList cat + then unlines + [ + "void visit" ++ cl ++ "("++ cl +++ vname ++ ")", + "{", + " while(" ++ vname ++ " != 0)", + " {", + " /* Code For " ++ cl ++ " Goes Here */", + " visit" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);", + " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", + " }", + "}", + "" + ] + -- Not a list: + else unlines + [ + "void visit" ++ cl ++ "(" ++ cl ++ " _p_)", + "{", + " switch(_p_->kind)", + " {", + concatMap (prPrintRule user) rules, + " default:", + " fprintf(stderr, \"Error: bad kind field when printing " ++ cl ++ "!\\n\");", + " exit(1);", + " }", + "}\n" + ] + where cl = identCat $ normCat cat + ecl = identCat $ normCatOfList cat + vname = map toLower cl + member = map toLower ecl + +-- Visits all the instance variables of a category. +prPrintRule :: [UserDef] -> Rule -> String +prPrintRule user (Rule fun _c cats) | not (isCoercion fun) = unlines + [ + " case is_" ++ fun ++ ":", + " /* Code for " ++ fun ++ " Goes Here */", + cats' ++ " break;" + ] + where + cats' = concatMap (prCat user fun) (zip (fixOnes (numVars [] cats)) cats) +prPrintRule _user (Rule _fun _ _) = "" + +-- Prints the actual instance-variable visiting. +prCat :: [UserDef] -> String -> (Either Cat Cat, Either Cat Cat) -> String +prCat user fnm (c, o) = + case c of + Right {} -> "" + Left nt -> + if isBasic user nt + then " visit" ++ basicFunName nt ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n" + else " visit" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n" + where v = map toLower $ identCat $ normCat fnm + o' = case o of + Right x -> x + Left x -> normCat $ identCat x + +--Just checks if something is a basic or user-defined type. +--This is because you don't -> a basic non-pointer type. +isBasic :: [UserDef] -> String -> Bool +isBasic user v = + if elem (init v) user' + then True + else if "integer_" `isPrefixOf` v then True + else if "char_" `isPrefixOf` v then True + else if "string_" `isPrefixOf` v then True + else if "double_" `isPrefixOf` v then True + else if "ident_" `isPrefixOf` v then True + else False + where + user' = map (map toLower) user + +--The visit-function name of a basic type +basicFunName :: String -> String +basicFunName v = + if "integer_" `isPrefixOf` v then "Integer" + else if "char_" `isPrefixOf` v then "Char" + else if "string_" `isPrefixOf` v then "String" + else if "double_" `isPrefixOf` v then "Double" + else if "ident_" `isPrefixOf` v then "Ident" + else (toUpper (head v)) : (init (tail v)) --User-defined type diff --git a/src/formats/c/CFtoFlexC.hs b/src/formats/c/CFtoFlexC.hs new file mode 100644 --- /dev/null +++ b/src/formats/c/CFtoFlexC.hs @@ -0,0 +1,189 @@ +{- + BNF Converter: C flex generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Flex file. It is + similar to JLex but with a few peculiarities. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 5 August, 2003 + + Modified : 10 August, 2003 + + + ************************************************************** +-} +module CFtoFlexC (cf2flex) where + +import CF +import RegToFlex +-- import Utils((+++), (++++)) +import NamedVariables +import Data.List + +--The environment must be returned for the parser to use. +cf2flex :: String -> CF -> (String, SymEnv) +cf2flex name cf = (unlines + [ + prelude name, + cMacros, + lexSymbols env, + restOfFlex cf env' + ], env') + where + env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) + env' = env ++ (makeSymEnv (fst (unzip (tokenPragmas cf))) (length env)) + makeSymEnv [] _ = [] + makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) + +prelude :: String -> String +prelude name = unlines + [ + "/* -*- c -*- This FLex file was machine-generated by the BNF converter */", + "%option noyywrap", + "%{", + "#define yylval " ++ name ++ "lval", + "#define YY_BUFFER_APPEND " ++ name ++ "_BUFFER_APPEND", + "#define YY_BUFFER_RESET " ++ name ++ "_BUFFER_RESET", + "#define initialize_lexer " ++ name ++ "_initialize_lexer", + "#include ", + "#include \"Parser.h\"", + "#define YY_BUFFER_LENGTH 4096", + "char YY_PARSED_STRING[YY_BUFFER_LENGTH];", + "void YY_BUFFER_APPEND(char *s)", + "{", + " strcat(YY_PARSED_STRING, s); //Do something better here!", + "}", + "void YY_BUFFER_RESET(void)", + "{", + " int x;", + " for(x = 0; x < YY_BUFFER_LENGTH; x++)", + " YY_PARSED_STRING[x] = 0;", + "}", + "", + "%}" + ] + +--For now all categories are included. +--Optimally only the ones that are used should be generated. +cMacros :: String +cMacros = unlines + [ + "LETTER [a-zA-Z]", + "CAPITAL [A-Z]", + "SMALL [a-z]", + "DIGIT [0-9]", + "IDENT [a-zA-Z0-9'_]", + "%START YYINITIAL COMMENT CHAR CHARESC CHAREND STRING ESCAPED", + "%%" + ] + +lexSymbols :: SymEnv -> String +lexSymbols ss = concatMap transSym ss + where + transSym (s,r) = + "\"" ++ s' ++ "\" \t return " ++ r ++ ";\n" + where + s' = escapeChars s + +restOfFlex :: CF -> SymEnv -> String +restOfFlex cf env = concat + [ + lexComments (comments cf), + userDefTokens, + ifC "String" strStates, + ifC "Char" chStates, + ifC "Double" "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t yylval.double_ = atof(yytext); return _DOUBLE_;\n", + ifC "Integer" "{DIGIT}+ \t yylval.int_ = atoi(yytext); return _INTEGER_;\n", + ifC "Ident" "{LETTER}{IDENT}* \t yylval.string_ = strdup(yytext); return _IDENT_;\n" + , "[ \\t\\r\\n\\f] \t /* ignore white space. */;\n", + ". \t return _ERROR_;\n", + "%%\n", + footer + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + userDefTokens = unlines $ + ["" ++ printRegFlex exp ++ + " \t yylval.string_ = strdup(yytext); return " ++ sName name ++ ";" + | (name, exp) <- tokenPragmas cf] + where + sName n = case lookup n env of + Just x -> x + Nothing -> n + strStates = unlines --These handle escaped characters in Strings. + [ + "\"\\\"\" \t BEGIN STRING;", + "\\\\ \t BEGIN ESCAPED;", + "\\\" \t yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return _STRING_;", + ". \t YY_BUFFER_APPEND(yytext);", + "n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;", + "\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;", + "\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;", + "t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;", + ". \t YY_BUFFER_APPEND(yytext); BEGIN STRING;" + ] + chStates = unlines --These handle escaped characters in Chars. + [ + "\"'\" \tBEGIN CHAR;", + "\\\\ \t BEGIN CHARESC;", + "[^'] \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;", + "n \t BEGIN CHAREND; yylval.char_ = '\\n'; return _CHAR_;", + "t \t BEGIN CHAREND; yylval.char_ = '\\t'; return _CHAR_;", + ". \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;", + "\"'\" \t BEGIN YYINITIAL;" + ] + footer = "void initialize_lexer(FILE *inp) { yyin = inp; BEGIN YYINITIAL; }" + +lexComments :: ([(String, String)], [String]) -> String +lexComments (m,s) = + (unlines (map lexSingleComment s)) + ++ (unlines (map lexMultiComment m)) + +lexSingleComment :: String -> String +lexSingleComment c = + "\"" ++ c ++ "\"[^\\n]*\\n \t /* BNFC single-line comment */;" + +--There might be a possible bug here if a language includes 2 multi-line comments. +--They could possibly start a comment with one character and end it with another. +--However this seems rare. +lexMultiComment :: (String, String) -> String +lexMultiComment (b,e) = unlines [ + "\"" ++ b ++ "\" \t BEGIN COMMENT;", + "\"" ++ e ++ "\" \t BEGIN YYINITIAL;", + ". \t /* BNFC multi-line comment */;", + "[\\n] \t /* BNFC multi-line comment */;" + ] + +lexReserved :: String -> String +lexReserved s = "\"" ++ s ++ "\" \t yylval.string_ = strdup(yytext); return TS;" + + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) diff --git a/src/formats/c/CTop.hs b/src/formats/c/CTop.hs new file mode 100644 --- /dev/null +++ b/src/formats/c/CTop.hs @@ -0,0 +1,202 @@ +{- + BNF Converter: C Main file + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} +module CTop (makeC) where + +import Utils +import CF +import CFtoCAbs +import CFtoFlexC +import CFtoBisonC +import CFtoCSkel +import CFtoCPrinter +import CFtoLatex +import Data.Char +import System.Exit (exitFailure) +import qualified Common.Makefile as Makefile + +makeC :: Bool -> String -> CF -> IO () +makeC make name cf = do + let (hfile, cfile) = cf2CAbs prefix cf + writeFileRep "Absyn.h" hfile + writeFileRep "Absyn.c" cfile + let (flex, env) = cf2flex prefix cf + writeFileRep (name ++ ".l") flex + putStrLn " (Tested with flex 2.5.31)" + let bison = cf2Bison prefix cf env + writeFileRep (name ++ ".y") bison + putStrLn " (Tested with bison 1.875a)" + let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env + writeFileRep "Parser.h" header + let (skelH, skelC) = cf2CSkel cf + writeFileRep "Skeleton.h" skelH + writeFileRep "Skeleton.c" skelC + let (prinH, prinC) = cf2CPrinter cf + writeFileRep "Printer.h" prinH + writeFileRep "Printer.c" prinC + writeFileRep "Test.c" (ctest cf) + let latex = cfToLatex name cf + writeFileRep (name ++ ".tex") latex + if make then (writeFileRep "Makefile" $ makefile name prefix) else return () + where prefix :: String -- The prefix is a string used by flex and bison + -- that is prepended to generated function names. + -- In most cases we want the grammar name as the prefix + -- but in a few specific cases, this can create clashes + -- with existing functions + prefix = if name `elem` ["m","c","re","std","str"] + then (name ++ "_") + else name + +makefile :: String -> String -> String +makefile name prefix = + (++) (unlines [ "CC = gcc", + "CCFLAGS = -g -W -Wall", "", + "FLEX = flex", + "FLEX_OPTS = -P" ++ prefix, "", + "BISON = bison", + "BISON_OPTS = -t -p" ++ prefix, ""]) + $ Makefile.mkRule ".PHONY" ["clean", "distclean"] + [] + $ Makefile.mkRule "all" [testName] + [] + $ Makefile.mkRule "clean" [] + -- peteg: don't nuke what we generated - move that to the "vclean" target. + [ "rm -f *.o " ++ unwords [ name ++ e | e <- [".aux",".log",".pdf",""]] ] + $ Makefile.mkRule "distclean" ["clean"] -- FIXME + [ "rm -f " ++ unwords + [ "Absyn.c", "Absyn.h", "Test.c", "Parser.c", "Parser.h", "Lexer.c" + , "Skeleton.c", "Skeleton.h", "Printer.c" ,"Printer.h" + , name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " + , testName, "Makefile" ]] + $ Makefile.mkRule testName ["Absyn.o", "Lexer.o", "Parser.o", "Printer.o", "Test.o"] + [ "@echo \"Linking test" ++ name ++ "...\"" + , "${CC} ${CCFLAGS} *.o -o Test" ++ name ] + $ Makefile.mkRule "Absyn.o" [ "Absyn.c", "Absyn.h"] + [ "${CC} ${CCFLAGS} -c Absyn.c" ] + $ Makefile.mkRule "Lexer.c" [ name ++ ".l" ] + [ "${FLEX} ${FLEX_OPTS} -oLexer.c " ++ name ++ ".l" ] + $ Makefile.mkRule "Parser.c" [ name ++ ".y" ] + [ "${BISON} ${BISON_OPTS} " ++ name ++ ".y -o Parser.c" ] + $ Makefile.mkRule "Lexer.o" [ "Lexer.c", "Parser.h" ] + [ "${CC} ${CCFLAGS} -c Lexer.c " ] + $ Makefile.mkRule "Parser.o" ["Parser.c", "Absyn.h" ] + [ "${CC} ${CCFLAGS} -c Parser.c" ] + $ Makefile.mkRule "Printer.o" [ "Printer.c", "Printer.h", "Absyn.h" ] + [ "${CC} ${CCFLAGS} -c Printer.c" ] + $ Makefile.mkRule "Test.o" [ "Test.c", "Parser.h", "Printer.h", "Absyn.h" ] + [ "${CC} ${CCFLAGS} -c Test.c" ] + $ Makefile.mkDoc (name ++ ".tex") + "" + where testName = "Test" ++ name + +ctest :: CF -> String +ctest cf = + unlines + [ + "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", + "/* */", + "/* This test will parse a file, print the abstract syntax tree, and then */", + "/* pretty-print the result. */", + "/* */", + "/****************************************************************************/", + "", + "#include ", + "#include ", + "", + "#include \"Parser.h\"", + "#include \"Printer.h\"", + "#include \"Absyn.h\"", + "", + "int main(int argc, char ** argv)", + "{", + " FILE *input;", + " " ++ def ++ " parse_tree;", + " if (argc > 1) ", + " {", + " input = fopen(argv[1], \"r\");", + " if (!input)", + " {", + " fprintf(stderr, \"Error opening input file.\\n\");", + " exit(1);", + " }", + " }", + " else input = stdin;", + " /* The default entry point is used. For other options see Parser.h */", + " parse_tree = p" ++ def ++ "(input);", + " if (parse_tree)", + " {", + " printf(\"\\nParse Succesful!\\n\");", + " printf(\"\\n[Abstract Syntax]\\n\");", + " printf(\"%s\\n\\n\", show" ++ def ++ "(parse_tree));", + " printf(\"[Linearized Tree]\\n\");", + " printf(\"%s\\n\\n\", print" ++ def ++ "(parse_tree));", + " return 0;", + " }", + " return 1;", + "}", + "" + ] + where + def = head (allEntryPoints cf) + +mkHeaderFile :: CF -> [Cat] -> [Cat] -> [(a, String)] -> String +mkHeaderFile cf cats eps env = unlines + [ + "#ifndef PARSER_HEADER_FILE", + "#define PARSER_HEADER_FILE", + "", + "#include \"Absyn.h\"", + "", + "typedef union", + "{", + " int int_;", + " char char_;", + " double double_;", + " char* string_;", + (concatMap mkVar cats) ++ "} YYSTYPE;", + "", + "#define _ERROR_ 258", + mkDefines (259::Int) env, + "extern YYSTYPE yylval;", + concatMap mkFunc eps, + "", + "#endif" + ] + where + mkVar s | (normCat s == s) = " " ++ (identCat s) +++ (map toLower (identCat s)) ++ "_;\n" + mkVar _ = "" + mkDefines n [] = mkString n + mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) + mkString n = if isUsedCat cf "String" + then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) + else mkChar n + mkChar n = if isUsedCat cf "Char" + then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1) + else mkInteger n + mkInteger n = if isUsedCat cf "Integer" + then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1) + else mkDouble n + mkDouble n = if isUsedCat cf "Double" + then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1) + else mkIdent n + mkIdent n = if isUsedCat cf "Ident" + then ("#define _IDENT_ " ++ show n ++ "\n") + else "" + mkFunc s | (normCat s == s) = (identCat s) ++ " p" ++ (identCat s) ++ "(FILE *inp);\n" + mkFunc _ = "" + diff --git a/src/formats/cpp/CFtoBison.hs b/src/formats/cpp/CFtoBison.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp/CFtoBison.hs @@ -0,0 +1,352 @@ +{- + BNF Converter: Bison generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + BNF Converter: C++ Bison generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Bison input file. + Note that because of the way bison stores results + the programmer can increase performance by limiting + the number of entry points in their grammar. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 6 August, 2003 + + Modified : 6 August, 2003 + + + ************************************************************** +-} + + +module CFtoBison (cf2Bison) where + +import CF +import Data.List (intersperse, isPrefixOf) +import NamedVariables hiding (varName) +import Data.Char (toLower,isUpper) +import Utils ((+++), (++++)) +import TypeChecker +import ErrM + +--This follows the basic structure of CFtoHappy. + +-- Type declarations +type Rules = [(NonTerminal,[(Pattern,Action)])] +type NonTerminal = String +type Pattern = String +type Action = String +type MetaVar = String + +--The environment comes from the CFtoFlex +cf2Bison :: String -> CF -> SymEnv -> String +cf2Bison name cf env + = unlines + [header name cf, + union (allCats cf), + "%token _ERROR_", + tokens user env, + declarations cf, + specialToks cf, + "%%", + prRules (rulesForBison name cf env) + ] + where + user = fst (unzip (tokenPragmas cf)) + +header :: String -> CF -> String +header name cf = unlines + ["/* This Bison file was machine-generated by BNFC */", + "%{", + "#include ", + "#include ", + "#include ", + "#include ", + "#include \"Absyn.H\"", + "int yyparse(void);", + "int yylex(void);", + "int yy_mylinenumber;", --- hack to get line number. AR 2006 + "int initialize_lexer(FILE * inp);", + "int yywrap(void)", + "{", + " return 1;", + "}", + "void yyerror(const char *str)", + "{", + " std::cout << \"line \" << yy_mylinenumber + 1 << std::endl ;", + " fprintf(stderr,\"error: %s\\n\",str);", + "}", + "", + definedRules cf, + unlines $ map (parseMethod name) (allCatsIdNorm cf), -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug. + concatMap reverseList (filter isList (allCats cf)), + "%}" + ] + +definedRules :: CF -> String +definedRules cf = + unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf] + where + ctx = buildContext cf + + list = LC (const "[]") (\t -> "List" ++ unBase t) + where + unBase (ListT t) = unBase t + unBase (BaseT x) = normCat x + + rule f xs e = + case checkDefinition' list ctx f xs e of + Bad err -> error $ "Panic! This should have been caught already:\n" ++ err + Ok (args,(e',t)) -> unlines + [ cppType t ++ " " ++ f ++ "_ (" ++ + concat (intersperse ", " $ map cppArg args) ++ ") {" + , " return " ++ cppExp e' ++ ";" + , "}" + ] + where + + cppType :: Base -> String + cppType (ListT (BaseT x)) = "List" ++ normCat x ++ " *" + cppType (ListT t) = cppType t ++ " *" + cppType (BaseT x) + | isToken x ctx = "String" + | otherwise = normCat x ++ " *" + + cppArg :: (String, Base) -> String + cppArg (x,t) = cppType t ++ " " ++ x ++ "_" + + cppExp :: Exp -> String + cppExp (App "[]" []) = "0" + cppExp (App x []) + | elem x xs = x ++ "_" -- argument + cppExp (App t [e]) + | isToken t ctx = cppExp e + cppExp (App x es) + | isUpper (head x) = call ("new " ++ x) es + | otherwise = call (x ++ "_") es + cppExp (LitInt n) = show n + cppExp (LitDouble x) = show x + cppExp (LitChar c) = show c + cppExp (LitString s) = show s + + call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")" + + +--This generates a parser method for each entry point. +parseMethod :: String -> Cat -> String +parseMethod name cat = + -- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm + -- then "" + -- else + unlines + [ + cat' ++ "*" +++ (resultName cat') +++ "= 0;", + cat' ++"* p" ++ cat' ++ "(FILE *inp)", + "{", + " initialize_lexer(inp);", + " if (yyparse())", + " { /* Failure */", + " return 0;", + " }", + " else", + " { /* Success */", + " return" +++ (resultName cat') ++ ";", + " }", + "}" + ] + where + cat' = identCat (normCat cat) + +--This method generates list reversal functions for each list type. +reverseList :: Cat -> String +reverseList c = unlines + [ + c' ++ "* reverse" ++ c' ++ "(" ++ c' +++ "*l)", + "{", + " " ++ c' +++"*prev = 0;", + " " ++ c' +++"*tmp = 0;", + " while (l)", + " {", + " tmp = l->" ++ v ++ ";", + " l->" ++ v +++ "= prev;", + " prev = l;", + " l = tmp;", + " }", + " return prev;", + "}" + ] + where + c' = identCat (normCat c) + v = (map toLower c') ++ "_" + +--The union declaration is special to Bison/Yacc and gives the type of yylval. +--For efficiency, we may want to only include used categories here. +union :: [Cat] -> String +union cats = unlines + [ + "%union", + "{", + " int int_;", + " char char_;", + " double double_;", + " char* string_;", + concatMap mkPointer cats, + "}" + ] + where --This is a little weird because people can make [Exp2] etc. + mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion. + " " ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n" + mkPointer s | normCat s == s = --normal cat + " " ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n" + mkPointer s = "" + +--declares non-terminal types. +declarations :: CF -> String +declarations cf = concatMap (typeNT cf) (allCats cf) + where --don't define internal rules + typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n" + typeNT cf nt = "" + +--declares terminal types. +tokens :: [UserDef] -> SymEnv -> String +tokens user ts = concatMap (declTok user) ts + where + declTok u (s,r) = if elem s u + then "%token " ++ r ++ " // " ++ s ++ "\n" + else "%token " ++ r ++ " // " ++ s ++ "\n" + +specialToks :: CF -> String +specialToks cf = concat [ + ifC "String" "%token _STRING_\n", + ifC "Char" "%token _CHAR_\n", + ifC "Integer" "%token _INTEGER_\n", + ifC "Double" "%token _DOUBLE_\n", + ifC "Ident" "%token _IDENT_\n" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + +--The following functions are a (relatively) straightforward translation +--of the ones in CFtoHappy.hs +rulesForBison :: String -> CF -> SymEnv -> Rules +rulesForBison name cf env = map mkOne $ ruleGroups cf where + mkOne (cat,rules) = constructRule cf env rules cat + +-- For every non-terminal, we construct a set of rules. +constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule cf env rules nt = (nt,[(p,(generateAction (ruleName r) b m) +++ result) | + r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True,revSepListRule r0) + else (False,r0), + let (p,m) = generatePatterns cf env r]) + where + ruleName r = case funRule r of + "(:)" -> identCat nt + "(:[])" -> identCat nt + z -> z + revs = reversibleCats cf + eps = allEntryPoints cf + isEntry nt = if elem nt eps then True else False + result = if isEntry nt then (resultName (normCat (identCat nt))) ++ "= $$;" else "" + +-- Generates a string containing the semantic action. +generateAction :: Fun -> Bool -> [MetaVar] -> Action +generateAction f b ms = + if isCoercion f + then (unwords ms) ++ ";" + else if f == "[]" + then "0;" + else if isDefinedRule f + then concat [ f, "_", "(", concat $ intersperse ", " ms', ");" ] + else concat ["new ", normCat f, "(", (concat (intersperse ", " ms')), ");"] + where + ms' = if b then reverse ms else ms + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal +generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar]) +generatePatterns cf env r = case rhsRule r of + [] -> ("/* empty */",[]) + its -> (unwords (map mkIt its), metas its) + where + mkIt i = case i of + Left c -> case lookup c env of + Just x -> x + Nothing -> typeName (identCat c) + Right s -> case lookup s env of + Just x -> x + Nothing -> s + metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its] + revIf c m = if (not (isConsFun (funRule r)) && elem c revs) + then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")") + else m -- no reversal in the left-recursive Cons rule itself + revs = reversibleCats cf + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. + +prRules :: Rules -> String +prRules [] = [] +prRules ((nt, []):rs) = prRules rs --internal rule +prRules ((nt,((p,a):ls)):rs) = + (unwords [nt', ":" , p, "{ $$ =", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ $$ =", a , "}"])]) ++ pr ls + +--Some helper functions. +resultName :: String -> String +resultName s = "YY_RESULT_" ++ s ++ "_" + +--slightly stronger than the NamedVariable version. +varName :: String -> String +varName s = (map toLower (identCat s)) ++ "_" + +typeName :: String -> String +typeName "Ident" = "_IDENT_" +typeName "String" = "_STRING_" +typeName "Char" = "_CHAR_" +typeName "Integer" = "_INTEGER_" +typeName "Double" = "_DOUBLE_" +typeName x = x diff --git a/src/formats/cpp/CFtoCPPAbs.hs b/src/formats/cpp/CFtoCPPAbs.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp/CFtoCPPAbs.hs @@ -0,0 +1,443 @@ +{- + BNF Converter: C++ abstract syntax generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C++ Abstract Syntax + tree classes. It generates both a Header file + and an Implementation file, and uses the Visitor + design pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 4 August, 2003 + + Modified : 22 May, 2004 / Antti-Juhani Kaijanaho + + + ************************************************************** +-} + +module CFtoCPPAbs (cf2CPPAbs) where + +import CF +import Utils((+++),(++++)) +import NamedVariables +import Data.List +import Data.Char(toLower) + + +--The result is two files (.H file, .C file) +cf2CPPAbs :: String -> CF -> (String, String) +cf2CPPAbs name cf = (mkHFile cf, mkCFile cf) + + +{- **** Header (.H) File Functions **** -} + +--Makes the Header file. +mkHFile :: CF -> String +mkHFile cf = unlines + [ + "#ifndef ABSYN_HEADER", + "#define ABSYN_HEADER", + "", + header, + prTypeDefs user, + "/******************** Forward Declarations ********************/\n", + concatMap prForward classes, + "", + prVisitor classes, + prVisitable, + "", + "/******************** Abstract Syntax Classes ********************/\n", + concatMap (prDataH user) (cf2dataLists cf), + "", + "#endif" + ] + where + user = fst (unzip (tokenPragmas cf)) + header = "//C++ Abstract Syntax Interface generated by the BNF Converter.\n" + rules = getRules cf + classes = rules ++ (getClasses (allCats cf)) + prForward s | isProperLabel s = "class " ++ (normCat s) ++ ";\n" + prForward s = "" + getRules cf = (map testRule (rulesOfCF cf)) + getClasses [] = [] + getClasses (c:cs) = + if identCat (normCat c) /= c + then getClasses cs + else if elem c rules + then getClasses cs + else c : (getClasses cs) + + testRule (Rule f c r) = + if isList c + then if isConsFun f + then identCat c + else "_" --ignore this + else f + +--Prints interface classes for all categories. +prDataH :: [UserDef] -> Data -> String +prDataH user (cat, rules) = + case lookup cat rules of + Just x -> concatMap (prRuleH user cat) rules + Nothing -> if isList cat + then concatMap (prRuleH user cat) rules + else unlines + [ + "class" +++ (identCat cat) +++ ": public Visitable {", + "public:", + " virtual" +++ (identCat cat) +++ "*clone() const = 0;", + "};\n", + concatMap (prRuleH user cat) rules + ] + +--Interface definitions for rules vary on the type of rule. +prRuleH :: [UserDef] -> String -> (Fun, [Cat]) -> String +prRuleH user c (fun, cats) = + if isNilFun fun || isOneFun fun + then "" --these are not represented in the AbSyn + else if isConsFun fun + then --this is the linked list case. + unlines + [ + "class" +++ c' +++ ": public Visitable", + "{", + " public:", + prInstVars user vs, + " " ++ c' ++ "(const" +++ c' +++ "&);", + " " ++ c' ++ " &operator=(const" +++ c' +++ "&);", + " " ++ c' ++ "(" ++ (prConstructorH 1 vs) ++ ");", + " " ++ c' ++ "(" ++ mem +++ memstar ++ "p);", + prDestructorH c', + " " ++ c' ++ "* reverse();", + " " ++ c' ++ "* reverse(" ++ c' ++ " *l);", + " virtual void accept(Visitor *v);", + " virtual " ++ c' ++ " *clone() const;", + " void swap(" ++ c' +++ "&);", + "};" + ] + else --a standard rule + unlines + [ + "class" +++ fun' +++ ": public" +++ super, + "{", + " public:", + prInstVars user vs, + " " ++ fun' ++ "(const" +++ fun' +++ "&);", + " " ++ fun' ++ " &operator=(const" +++ fun' +++ "&);", + " " ++ fun' ++ "(" ++ (prConstructorH 1 vs) ++ ");", + prDestructorH fun', + " virtual void accept(Visitor *v);", + " virtual " +++ fun' +++ " *clone() const;", + " void swap(" ++ fun' +++ "&);", + "};\n" + ] + where + vs = getVars cats + fun' = identCat (normCat fun) + c' = identCat (normCat c); + mem = drop 4 c' + memstar = if isBasic user mem then "" else "*" + super = if c == fun then "Visitable" else (identCat c) + prConstructorH :: Int -> [(String, b)] -> String + prConstructorH _ [] = "" + prConstructorH n ((t,_):[]) = t +++ (optstar t) ++ "p" ++ (show n) + prConstructorH n ((t,_):vs) =( t +++ (optstar t) ++ "p" ++ (show n) ++ ", ") ++ (prConstructorH (n+1) vs) + prDestructorH n = " ~" ++ n ++ "();" + optstar x = if isBasic user x + then "" + else "*" + +prVisitable :: String +prVisitable = unlines + [ + "class Visitable", + "{", + " public:", + -- all classes with virtual methods require a virtual destructor + " virtual ~Visitable() {}", + " virtual void accept(Visitor *v) = 0;", + "};\n" + ] + +prVisitor :: [String] -> String +prVisitor fs = unlines + [ + "/******************** Visitor Interfaces ********************/", + "", + "class Visitor", + "{", + " public:", + " virtual ~Visitor() {}", + (concatMap (prVisitFun) fs), + footer + ] + where + footer = unlines + [ --later only include used categories + " virtual void visitInteger(Integer i) = 0;", + " virtual void visitDouble(Double d) = 0;", + " virtual void visitChar(Char c) = 0;", + " virtual void visitString(String s) = 0;", + "};" + ] + prVisitFun f | isProperLabel f = + " virtual void visit" ++ f' ++ "(" ++ f' ++ " *p) = 0;\n" + where + f' = identCat (normCat f) + prVisitFun _ = "" + +--typedefs in the Header make generation much nicer. +prTypeDefs user = unlines + [ + "/******************** TypeDef Section ********************/", + "typedef int Integer;", + "typedef char Char;", + "typedef double Double;", + "typedef char* String;", + "typedef char* Ident;", + concatMap prUserDef user + ] + where + prUserDef s = "typedef char* " ++ s ++ ";\n" + +--A class's instance variables. +prInstVars :: [UserDef] -> [IVar] -> String +prInstVars _ [] = [] +prInstVars user vars@((t,n):vs) = + " " ++ t +++ uniques ++ ";" ++++ + (prInstVars user vs') + where + (uniques, vs') = prUniques t vars + --these functions group the types together nicely + prUniques :: String -> [IVar] -> (String, [IVar]) + prUniques t vs = (prVars (findIndices (\x -> case x of (y,_) -> y == t) vs) vs, remType t vs) + prVars (x:[]) vs = case vs !! x of + (t,n) -> ((varLinkName t) ++ (showNum n)) + prVars (x:xs) vs = case vs !! x of + (t,n) -> ((varLinkName t) ++ (showNum n)) ++ "," +++ + (prVars xs vs) + varLinkName z = if isBasic user z + then (map toLower z) ++ "_" + else "*" ++ (map toLower z) ++ "_" + remType :: String -> [IVar] -> [IVar] + remType _ [] = [] + remType t ((t2,n):ts) = if t == t2 + then (remType t ts) + else (t2,n) : (remType t ts) + + +{- **** Implementation (.C) File Functions **** -} + +--Makes the .C file +mkCFile :: CF -> String +mkCFile cf = unlines + [ + header, + concatMap (prDataC user) (cf2dataLists cf) + ] + where + user = fst (unzip (tokenPragmas cf)) + header = unlines + [ + "//C++ Abstract Syntax Implementation generated by the BNF Converter.", + "#include ", + "#include \"Absyn.H\"" + ] + +--This is not represented in the implementation. +prDataC :: [UserDef] -> Data -> String +prDataC user (cat, rules) = concatMap (prRuleC user cat) rules + +--Classes for rules vary based on the type of rule. +prRuleC user c (fun, cats) = + if isNilFun fun || isOneFun fun + then "" --these are not represented in the AbSyn + else if isConsFun fun + then --this is the linked list case. + unlines + [ + "/******************** " ++ c' ++ " ********************/", + prConstructorC user c' vs cats, + prCopyC user c' vs, + prDestructorC user c' vs, + prListFuncs user c', + prAcceptC c', + prCloneC user c' vs, + "" + ] + else --a standard rule + unlines + [ + "/******************** " ++ fun' ++ " ********************/", + prConstructorC user fun' vs cats, + prCopyC user fun' vs, + prDestructorC user fun' vs, + prAcceptC fun, + prCloneC user fun' vs, + "" + ] + where + vs = getVars cats + fun' = identCat (normCat fun) + c' = identCat (normCat c) + +--These are all built-in list functions. +--Later we could include things like lookup,insert,delete,etc. +prListFuncs :: [UserDef] -> String -> String +prListFuncs user c = unlines + [ + c ++ "::" ++ c ++ "(" ++ m +++ mstar ++ "p)", + "{", + " " ++ m' ++ " = p;", + " " ++ v ++ "= 0;", + "}", + c ++ "*" +++ c ++ "::" ++ "reverse()", + "{", + " if (" ++ v +++ "== 0) return this;", + " else", + " {", + " " ++ c ++ " *tmp =" +++ v ++ "->reverse(this);", + " " ++ v +++ "= 0;", + " return tmp;", + " }", + "}", + "", + c ++ "*" +++ c ++ "::" ++ "reverse(" ++ c ++ "* prev)", + "{", + " if (" ++ v +++ "== 0)", + " {", + " " ++ v +++ "= prev;", + " return this;", + " }", + " else", + " {", + " " ++ c +++ "*tmp =" +++ v ++ "->reverse(this);", + " " ++ v +++ "= prev;", + " return tmp;", + " }", + "}" + ] + where + v = (map toLower c) ++ "_" + m = drop 4 c + mstar = if isBasic user m then "" else "*" + m' = drop 4 v + +--The standard accept function for the Visitor pattern +prAcceptC :: String -> String +prAcceptC ty = + "\nvoid " ++ ty ++ "::accept(Visitor *v) { v->visit" ++ ty ++ "(this); }" + +--The constructor just assigns the parameters to the corresponding instance variables. +prConstructorC :: [UserDef] -> String -> [IVar] -> [Cat] -> String +prConstructorC user c vs cats = + c ++ "::" ++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" +++ + prAssigns vs params ++ "}" + where + (types, params) = unzip (prParams cats (length cats) ((length cats)+1)) + interleave _ [] = [] + interleave (x:[]) (y:[]) = x +++ (optstar x) ++ y + interleave (x:xs) (y:ys) = x +++ (optstar x) ++ y ++ "," +++ (interleave xs ys) + optstar x = if isBasic user x + then "" + else "*" + +--Print copy constructor and copy assignment +prCopyC :: [UserDef] -> String -> [IVar] -> String +prCopyC user c vs = + c ++ "::" ++ c ++ "(const" +++ c +++ "& other) {" +++ + concatMap doV vs ++++ + "}" ++++ + c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other) {" ++++ + " " ++ c +++ "tmp(other);" ++++ + " swap(tmp);" ++++ + " return *this;" ++++ + "}" ++++ + "void" +++ c ++ "::swap(" ++ c +++ "& other) {" ++++ + concatMap swapV vs ++++ + "}\n" + where doV :: IVar -> String + doV v@(t, _) + | isBasic user t = " " ++ vn v ++ " = other." ++ vn v ++ ";\n" + | otherwise = " " ++ vn v ++ " = other." ++ vn v ++ "->clone();\n" + vn :: IVar -> String + vn (t, 0) = varName t + vn (t, n) = varName t ++ show n + swapV :: IVar -> String + swapV v = " std::swap(" ++ vn v ++ ", other." ++ vn v ++ ");\n" + +--The cloner makes a new deep copy of the object +prCloneC :: [UserDef] -> String -> [IVar] -> String +prCloneC user c vs = + c +++ "*" ++ c ++ "::clone() const {" ++++ + " return new" +++ c ++ "(*this);\n}" + +--The destructor deletes all a class's members. +prDestructorC :: [UserDef] -> String -> [IVar] -> String +prDestructorC user c vs = + c ++ "::~" ++ c ++"()" +++ "{" +++ + (concatMap prDeletes vs) ++ "}" + where + prDeletes :: (String, Int) -> String + prDeletes (t, n) = if isBasic user t + then "" + else if n == 0 + then "delete(" ++ (varName t) ++ "); " + else "delete(" ++ (varName t) ++ (show n) ++ "); " + +--Prints the constructor's parameters. +prParams :: [Cat] -> Int -> Int -> [(String,String)] +prParams [] _ _ = [] +prParams (c:cs) n m = (identCat c,"p" ++ (show (m-n))) + : (prParams cs (n-1) m) + +--Prints the assignments of parameters to instance variables. +--This algorithm peeks ahead in the list so we don't use map or fold +prAssigns :: [IVar] -> [String] -> String +prAssigns [] _ = [] +prAssigns _ [] = [] +prAssigns ((t,n):vs) (p:ps) = + if n == 1 then + case findIndices (\x -> case x of (l,r) -> l == t) vs of + [] -> (varName t) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + z -> ((varName t) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + else ((varName t) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + + +{- **** Helper Functions **** -} + +--Checks if something is a basic or user-defined type. +isBasic :: [UserDef] -> String -> Bool +isBasic user x = + if elem x user + then True + else case x of + "Integer" -> True + "Char" -> True + "String" -> True + "Double" -> True + "Ident" -> True + _ -> False diff --git a/src/formats/cpp/CFtoCPPPrinter.hs b/src/formats/cpp/CFtoCPPPrinter.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp/CFtoCPPPrinter.hs @@ -0,0 +1,606 @@ +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C++ Pretty Printer. + It also generates the "show" method for + printing an abstract syntax tree. + + The generated files use the Visitor design pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 10 August, 2003 + + Modified : 3 September, 2003 + * Added resizable buffers + + ************************************************************** +-} + +module CFtoCPPPrinter (cf2CPPPrinter) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower, toUpper) + +--Produces (.H file, .C file) +cf2CPPPrinter :: CF -> (String, String) +cf2CPPPrinter cf = (mkHFile cf groups, mkCFile cf groups) + where + groups = (fixCoercions (ruleGroupsInternals cf)) + +{- **** Header (.H) File Methods **** -} + +--An extremely large function to make the Header File +mkHFile :: CF -> [(Cat,[Rule])] -> String +mkHFile cf groups = unlines + [ + printHeader, + concatMap prDataH groups, + classFooter, + showHeader, + concatMap prDataH groups, + classFooter, + footer + ] + where + printHeader = unlines + [ + "#ifndef PRINTER_HEADER", + "#define PRINTER_HEADER", + "", + "#include \"Absyn.H\"", + "#include ", + "#include ", + "#include ", + "", + "/* Certain applications may improve performance by changing the buffer size */", + "#define BUFFER_INITIAL 2000", + "/* You may wish to change _L_PAREN or _R_PAREN */", + "#define _L_PAREN '('", + "#define _R_PAREN ')'", + "", + "class PrintAbsyn : public Visitor", + "{", + " protected:", + " int _n_, _i_;", + " /* The following are simple heuristics for rendering terminals */", + " /* You may wish to change them */", + " void render(Char c);", + " void render(String s);", + " void indent(void);", + " void backup(void);", + " public:", + " PrintAbsyn(void);", + " ~PrintAbsyn(void);", + " char* print(Visitable* v);" + ] + classFooter = unlines + [ + " void visitInteger(Integer i);", + " void visitDouble(Double d);", + " void visitChar(Char c);", + " void visitString(String s);", + " void visitIdent(String s);", + " protected:", + " void inline bufAppend(const char* s)", + " {", + " int len = strlen(s);", + " while (cur_ + len > buf_size)", + " {", + " buf_size *= 2; /* Double the buffer size */", + " resizeBuffer();", + " }", + " for(int n = 0; n < len; n++)", + " {", + " buf_[cur_ + n] = s[n];", + " }", + " cur_ += len;", + " buf_[cur_] = 0;", + " }", + " void inline bufAppend(const char c)", + " {", + " if (cur_ == buf_size)", + " {", + " buf_size *= 2; /* Double the buffer size */", + " resizeBuffer();", + " }", + " buf_[cur_] = c;", + " cur_++;", + " buf_[cur_] = 0;", + " }", + " void inline bufReset(void)", + " {", + " cur_ = 0;", + " buf_size = BUFFER_INITIAL;", + " resizeBuffer();", + " memset(buf_, 0, buf_size);", + " }", + " void inline resizeBuffer(void)", + " {", + " char* temp = (char*) malloc(buf_size);", + " if (!temp)", + " {", + " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");", + " exit(1);", + " }", + " if (buf_)", + " {", + " strcpy(temp, buf_);", + " free(buf_);", + " }", + " buf_ = temp;", + " }", + " char *buf_;", + " int cur_, buf_size;", + "};", + "" + ] + showHeader = unlines + [ + "", + "class ShowAbsyn : public Visitor", + "{", + " public:", + " ShowAbsyn(void);", + " ~ShowAbsyn(void);", + " char* show(Visitable* v);" + ] + footer = unlines + [ + "", + "#endif" + ] + +--Prints all the required method names and their parameters. +prDataH :: (Cat, [Rule]) -> String +prDataH (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then concat [" void visit", cl, "(", cl, "* p);\n"] + else abstract ++ (concatMap prRuleH rules) + where + cl = identCat (normCat cat) + abstract = case lookupRule cat rules of + Just x -> "" + Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n" + +--Prints all the methods to visit a rule. +prRuleH :: Rule -> String +prRuleH (Rule fun c cats) | isProperLabel fun = concat + [" void visit", fun, "(", fun, " *p);\n"] +prRuleH _ = "" + +{- **** Implementation (.C) File Methods **** -} + +--This makes the .C file by a similar method. +mkCFile :: CF -> [(Cat,[Rule])] -> String +mkCFile cf groups = concat + [ + header, + prRender, + printEntries, + concatMap (prPrintData user) groups, + printBasics, + showEntries, + concatMap (prShowData user) groups, + showBasics + ] + where + user = fst (unzip (tokenPragmas cf)) + header = unlines + [ + "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/", + "", + "#include \"Printer.H\"", + "" + ] + printEntries = unlines + [ + "PrintAbsyn::PrintAbsyn(void)", + "{", + " _i_ = 0; _n_ = 0;", + " buf_ = 0;", + " bufReset();", + "}", + "", + "PrintAbsyn::~PrintAbsyn(void)", + "{", + "}", + "", + "char* PrintAbsyn::print(Visitable *v)", + "{", + " _i_ = 0; _n_ = 0;", + " bufReset();", + " v->accept(this);", + " return buf_;", + "}" + ] + showEntries = unlines + [ + "ShowAbsyn::ShowAbsyn(void)", + "{", + " buf_ = 0;", + " bufReset();", + "}", + "", + "ShowAbsyn::~ShowAbsyn(void)", + "{", + "}", + "", + "char* ShowAbsyn::show(Visitable *v)", + "{", + " bufReset();", + " v->accept(this);", + " return buf_;", + "}" + ] + printBasics = unlines + [ + "void PrintAbsyn::visitInteger(Integer i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%d\", i);", + " bufAppend(tmp);", + "}", + "void PrintAbsyn::visitDouble(Double d)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%g\", d);", + " bufAppend(tmp);", + "}", + "void PrintAbsyn::visitChar(Char c)", + "{", + " bufAppend('\\'');", + " bufAppend(c);", + " bufAppend('\\'');", + "}", + "void PrintAbsyn::visitString(String s)", + "{", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "void PrintAbsyn::visitIdent(String s)", + "{", + " render(s);", + "}", + "" + ] + showBasics = unlines + [ + "void ShowAbsyn::visitInteger(Integer i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%d\", i);", + " bufAppend(tmp);", + "}", + "void ShowAbsyn::visitDouble(Double d)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%g\", d);", + " bufAppend(tmp);", + "}", + "void ShowAbsyn::visitChar(Char c)", + "{", + " bufAppend('\\'');", + " bufAppend(c);", + " bufAppend('\\'');", + "}", + "void ShowAbsyn::visitString(String s)", + "{", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "void ShowAbsyn::visitIdent(String s)", + "{", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "" + ] + +{- **** Pretty Printer Methods **** -} + +--Generates methods for the Pretty Printer +prPrintData :: [UserDef] -> (Cat, [Rule]) -> String +prPrintData user (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then unlines + [ + "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")", + "{", + " while(" ++ vname ++ "!= 0)", + " {", + " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)", + " {", + visitMember, + optsep, + " " ++ vname +++ "= 0;", + " }", + " else", + " {", + visitMember, + " render(" ++ sep ++ ");", + " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", + " }", + " }", + "}", + "" + ] --Not a list: + else abstract ++ (concatMap (prPrintRule user) rules) + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl ++ "_" + visitMember = if isBasic user member + then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" + else " " ++ vname ++ "->" ++ member ++ "->accept(this);" + sep = if (length sep') == 1 + then "'" ++ (escapeChars sep') ++ "'" + else "\"" ++ (escapeChars sep') ++ "\"" + sep' = getCons rules + optsep = if hasOneFunc rules then "" else (" render(" ++ sep ++ ");") + abstract = case lookupRule cat rules of + Just x -> "" + Nothing -> "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl ++ "*p) {} //abstract class\n\n" + +--Pretty Printer methods for a rule. +prPrintRule :: [UserDef] -> Rule -> String +prPrintRule user r@(Rule fun c cats) | isProperLabel fun = unlines + [ + "void PrintAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")", + "{", + " int oldi = _i_;", + lparen, + cats', + rparen, + " _i_ = oldi;", + "}\n" + ] + where + p = precRule r + (lparen, rparen) = + (" if (oldi > " ++ (show p) ++ ") render(_L_PAREN);\n", + " if (oldi > " ++ (show p) ++ ") render(_R_PAREN);\n") + cats' = (concatMap (prPrintCat user fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats))) + fnm = "p" --old names could cause conflicts + getPrec (Right s) = 0 + getPrec (Left c) = precCat c +prPrintRule _ _ = "" + +--This goes on to recurse to the instance variables. +prPrintCat :: [UserDef] -> String -> (Either Cat String, Int) -> String +prPrintCat user fnm (c,p) = case c of + (Right t) -> " render(" ++ t' ++ ");\n" + where + t' = if length t == 1 + then "'" ++ (escapeChars t) ++ "'" + else "\"" ++ (escapeChars t) ++ "\"" + (Left nt) -> if isBasic user nt + then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" + else if "list" `isPrefixOf` nt + then " if(" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}" + else " " ++ accept ++ "\n" + where + accept = if nt == "#_" --Internal category + then "/* Internal Category */\n" + else (setI p) ++ fnm ++ "->" ++ nt ++ "->accept(this);" + +{- **** Abstract Syntax Tree Printer **** -} + +--This prints the functions for Abstract Syntax tree printing. +prShowData :: [UserDef] -> (Cat, [Rule]) -> String +prShowData user (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then unlines + [ + "void ShowAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")", + "{", + " while(" ++ vname ++ "!= 0)", + " {", + " if (" ++ vname ++ "->" ++ vname ++ "_)", + " {", + visitMember, + " bufAppend(\", \");", + " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", + " }", + " else", + " {", + visitMember, + " " ++ vname ++ " = 0;", + " }", + " }", + "}", + "" + ] --Not a list: + else abstract ++ (concatMap (prShowRule user) rules) + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl ++ "_" + visitMember = if isBasic user member + then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" + else " " ++ vname ++ "->" ++ member ++ "->accept(this);" + abstract = case lookupRule cat rules of + Just x -> "" + Nothing -> "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ "* p) {} //abstract class\n\n" + +--This prints all the methods for Abstract Syntax tree rules. +prShowRule :: [UserDef] -> Rule -> String +prShowRule user (Rule fun c cats) | isProperLabel fun = concat + [ + "void ShowAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")\n", + "{\n", + lparen, + " bufAppend(\"" ++ fun ++ "\");\n", + optspace, + cats', + rparen, + "}\n" + ] + where + (optspace, lparen, rparen) = if allTerms cats + then ("","","") + else (" bufAppend(' ');\n", " bufAppend('(');\n"," bufAppend(')');\n") + cats' = if allTerms cats + then "" + else concat (insertSpaces (map (prShowCat user fnm) (fixOnes (numVars [] cats)))) + insertSpaces [] = [] + insertSpaces (x:[]) = [x] + insertSpaces (x:xs) = if x == "" + then insertSpaces xs + else (x : [" bufAppend(' ');\n"]) ++ (insertSpaces xs) + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs + fnm = "p" --other names could cause conflicts +prShowRule _ _ = "" + +--This recurses to the instance variables of a class. +prShowCat :: [UserDef] -> String -> Either Cat String -> String +prShowCat user fnm c = + case c of + (Right t) -> "" + (Left nt) -> + if isBasic user nt + then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" + else if nt == "#_" --internal category + then "/* Internal Category */\n" + else if ((normCat nt) /= nt) + then accept + else concat + [ + " bufAppend('[');\n", + " if (" ++ fnm ++ "->" ++ nt ++ ")" ++ accept, + " bufAppend(']');\n" + ] + where + accept = " " ++ fnm ++ "->" ++ nt ++ "->accept(this);\n" + +{- **** Helper Functions Section **** -} + + +--Just checks if something is a basic or user-defined type. +--This is because you don't -> a basic non-pointer type. +isBasic :: [UserDef] -> String -> Bool +isBasic user v = + if elem (init v) user' + then True + else if "integer_" `isPrefixOf` v then True + else if "char_" `isPrefixOf` v then True + else if "string_" `isPrefixOf` v then True + else if "double_" `isPrefixOf` v then True + else if "ident_" `isPrefixOf` v then True + else False + where + user' = map (map toLower) user + +--The visit-function name of a basic type +funName :: String -> String +funName v = + if "integer_" `isPrefixOf` v then "Integer" + else if "char_" `isPrefixOf` v then "Char" + else if "string_" `isPrefixOf` v then "String" + else if "double_" `isPrefixOf` v then "Double" + else if "ident_" `isPrefixOf` v then "Ident" + else "Ident" --User-defined type + +--Just sets the coercion level for parentheses in the Pretty Printer. +setI :: Int -> String +setI n = "_i_ = " ++ (show n) ++ "; " + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) + +--An extremely simple renderer for terminals. +prRender :: String +prRender = unlines + [ + "//You may wish to change render", + "void PrintAbsyn::render(Char c)", + "{", + " if (c == '{')", + " {", + " bufAppend('\\n');", + " indent();", + " bufAppend(c);", + " _n_ = _n_ + 2;", + " bufAppend('\\n');", + " indent();", + " }", + " else if (c == '(' || c == '[')", + " bufAppend(c);", + " else if (c == ')' || c == ']')", + " {", + " backup();", + " bufAppend(c);", + " bufAppend(' ');", + " }", + " else if (c == '}')", + " {", + " _n_ = _n_ - 2;", + " backup();", + " backup();", + " bufAppend(c);", + " bufAppend('\\n\');", + " indent();", + " }", + " else if (c == ',')", + " {", + " backup();", + " bufAppend(c);", + " bufAppend(' ');", + " }", + " else if (c == ';')", + " {", + " backup();", + " bufAppend(c);", + " bufAppend('\\n');", + " indent();", + " }", + " else if (c == 0) return;", + " else", + " {", + " bufAppend(c);", + " bufAppend(' ');", + " }", + "}", + "void PrintAbsyn::render(String s)", + "{", + " if(strlen(s) > 0)", + " {", + " bufAppend(s);", + " bufAppend(' ');", + " }", + "}", + "void PrintAbsyn::indent()", + "{", + " int n = _n_;", + " while (n > 0)", + " {", + " bufAppend(' ');", + " n--;", + " }", + "}", + "void PrintAbsyn::backup()", + "{", + " if (buf_[cur_ - 1] == ' ')", + " {", + " buf_[cur_ - 1] = 0;", + " cur_--;", + " }", + "}" + ] diff --git a/src/formats/cpp/CFtoCVisitSkel.hs b/src/formats/cpp/CFtoCVisitSkel.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp/CFtoCVisitSkel.hs @@ -0,0 +1,259 @@ +{- + BNF Converter: C++ Skeleton generation + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C++ Skeleton functions. + + The generated files use the Visitor design pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 9 August, 2003 + + Modified : 12 August, 2003 + + + ************************************************************** +-} + +module CFtoCVisitSkel (cf2CVisitSkel) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower, toUpper) + +--Produces (.H file, .C file) +cf2CVisitSkel :: CF -> (String, String) +cf2CVisitSkel cf = (mkHFile cf groups, mkCFile cf groups) + where + groups = (fixCoercions (ruleGroups cf)) + + +{- **** Header (.H) File Functions **** -} + +--Generates the Header File +mkHFile :: CF -> [(Cat,[Rule])] -> String +mkHFile cf groups = unlines + [ + header, + concatMap prDataH groups, + concatMap prUserH user, + footer + ] + where + user = fst (unzip (tokenPragmas cf)) + header = unlines + [ + "#ifndef SKELETON_HEADER", + "#define SKELETON_HEADER", + "/* You might want to change the above name. */", + "", + "#include \"Absyn.H\"", + "", + "class Skeleton : public Visitor", + "{", + " public:" + ] + prUserH u = " void visit" ++ u' ++ "(" ++ u ++ " p);" + where + u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem. + footer = unlines + [ + " void visitIdent(String s);", + " void visitInteger(Integer i);", + " void visitDouble(Double d);", + " void visitChar(Char c);", + " void visitString(String s);", + "};", + "", + "#endif" + ] + +--Prints out visit functions for a category +prDataH :: (Cat, [Rule]) -> String +prDataH (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then concat [" void visit", cl, "(", cl, "* ", vname, ");"] + else abstract ++ (concatMap prRuleH rules) + where + cl = identCat (normCat cat) + vname = map toLower cl + abstract = case lookupRule cat rules of + Just x -> "" + Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ "*" +++ vname ++ "); /* abstract class */\n" + +--Visit functions for a rule. +prRuleH :: Rule -> String +prRuleH (Rule fun c cats) | not (isCoercion fun) = concat + [" void visit", fun, "(", fun, "* ", fnm, ");\n"] + where + fnm = map toLower fun +prRuleH _ = "" + + +{- **** Implementation (.C) File Functions **** -} + +--Makes the .C File +mkCFile :: CF -> [(Cat,[Rule])] -> String +mkCFile cf groups = concat + [ + header, + concatMap (prData user) groups, + concatMap prUser user, + footer + ] + where + user = fst (unzip (tokenPragmas cf)) + header = unlines [ + "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/", + "/* This implements the common visitor design pattern.", + " Note that this method uses Visitor-traversal of lists, so", + " List->accept() does NOT traverse the list. This allows different", + " algorithms to use context information differently. */", + "", + "#include \"Skeleton.H\"", + "" + ] + prUser x = unlines + [ + "void Skeleton::visit" ++ x' ++ "(" ++ x ++ " p)", + "{", + " /* Code for " ++ x ++ " Goes Here */", + "}" + ] + where + x' = ((toUpper (head x)) : (map toLower (tail x))) --this is a hack to fix a potential capitalization problem. + footer = unlines + [ + "void Skeleton::visitIdent(Ident i)", + "{", + " /* Code for Ident Goes Here */", + "}", + "void Skeleton::visitInteger(Integer i)", + "{", + " /* Code for Integers Goes Here */", + "}", + "void Skeleton::visitDouble(Double d)", + "{", + " /* Code for Doubles Goes Here */", + "}", + "void Skeleton::visitChar(Char c)", + "{", + " /* Code for Chars Goes Here */", + "}", + "void Skeleton::visitString(String s)", + "{", + " /* Code for Strings Goes Here */", + "}", + "" + ] + +--Visit functions for a category. +prData :: [UserDef] -> (Cat, [Rule]) -> String +prData user (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then unlines + [ + "void Skeleton::visit" ++ cl ++ "("++ cl ++ "*" +++ vname ++ ")", + "{", + " while(" ++ vname ++ "!= 0)", + " {", + " /* Code For " ++ cl ++ " Goes Here */", + visitMember, + " " ++ vname ++ " = " ++ vname ++ "->" ++ vname ++ "_;", + " }", + "}", + "" + ] --Not a list: + else abstract ++ (concatMap (prRule user) rules) + where + cl = identCat (normCat cat) + vname = map toLower cl + ecl = identCat (normCatOfList cat) + member = map toLower ecl ++ "_" + visitMember = if isBasic user member + then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" + else " " ++ vname ++ "->" ++ member ++ "->accept(this);" + abstract = case lookupRule cat rules of + Just x -> "" + Nothing -> "void Skeleton::visit" ++ cl ++ "(" ++ cl ++ "*" +++ vname ++ ") {} //abstract class\n\n" + +--Visits all the instance variables of a category. +prRule :: [UserDef] -> Rule -> String +prRule user (Rule fun c cats) | not (isCoercion fun) = unlines + [ + "void Skeleton::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")", + "{", + " /* Code For " ++ fun ++ " Goes Here */", + "", + cats' ++ "}\n" + ] + where + cats' = if allTerms cats + then "" + else (concatMap (prCat user fnm) (fixOnes (numVars [] cats))) + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs + fnm = map toLower fun +prRule user _ = "" + +--Prints the actual instance-variable visiting. +prCat user fnm c = + case c of + (Right t) -> "" + (Left nt) -> if isBasic user nt + then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" + else if "list" `isPrefixOf` nt + then " if (" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}\n" + else " " ++ accept ++ "\n" + where + accept = fnm ++ "->" ++ nt ++ "->accept(this);" + +--Just checks if something is a basic or user-defined type. +--This is because you don't -> a basic non-pointer type. +isBasic :: [UserDef] -> String -> Bool +isBasic user v = + if elem (init v) user' + then True + else if "integer_" `isPrefixOf` v then True + else if "char_" `isPrefixOf` v then True + else if "string_" `isPrefixOf` v then True + else if "double_" `isPrefixOf` v then True + else if "ident_" `isPrefixOf` v then True + else False + where + user' = map (map toLower) user + +--The visit-function name of a basic type +funName :: String -> String +funName v = + if "integer_" `isPrefixOf` v then "Integer" + else if "char_" `isPrefixOf` v then "Char" + else if "string_" `isPrefixOf` v then "String" + else if "double_" `isPrefixOf` v then "Double" + else if "ident_" `isPrefixOf` v then "Ident" + else (toUpper (head v)) : (init (tail v)) --User-defined type diff --git a/src/formats/cpp/CFtoFlex.hs b/src/formats/cpp/CFtoFlex.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp/CFtoFlex.hs @@ -0,0 +1,191 @@ +{- + BNF Converter: Flex generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Flex file. It is + similar to JLex but with a few peculiarities. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 5 August, 2003 + + Modified : 22 August, 2006 by Aarne Ranta + + + ************************************************************** +-} +module CFtoFlex (cf2flex) where + +import CF +import RegToFlex +import Utils((+++), (++++)) +import NamedVariables +import Data.List +import STLUtils + +--The environment must be returned for the parser to use. +cf2flex :: Maybe String -> String -> CF -> (String, SymEnv) +cf2flex inPackage name cf = (unlines + [ + prelude inPackage name, + cMacros, + lexSymbols env, + restOfFlex inPackage cf env' + ], env') + where + env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) + env' = env ++ (makeSymEnv (fst (unzip (tokenPragmas cf))) (length env)) + makeSymEnv [] _ = [] + makeSymEnv (s:symbs) n = (s, nsDefine inPackage "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) + +prelude :: Maybe String -> String -> String +prelude inPackage name = unlines + [ + maybe "" (\ns -> "%option prefix=\"" ++ ns ++ "yy\"") inPackage, + "/* This FLex file was machine-generated by the BNF converter */", + "%{", + "#include ", + "#include \"Parser.H\"", + "#define YY_BUFFER_LENGTH 4096", + "extern int " ++ nsString inPackage ++ "yy_mylinenumber ;", --- hack to get line number. AR 2006 + "static char YY_PARSED_STRING[YY_BUFFER_LENGTH];", + "static void YY_BUFFER_APPEND(char *s)", + "{", + " strcat(YY_PARSED_STRING, s); //Do something better here!", + "}", + "static void YY_BUFFER_RESET(void)", + "{", + " for(int x = 0; x < YY_BUFFER_LENGTH; x++)", + " YY_PARSED_STRING[x] = 0;", + "}", + "", + "%}" + ] + +--For now all categories are included. +--Optimally only the ones that are used should be generated. +cMacros :: String +cMacros = unlines + [ + "LETTER [a-zA-Z]", + "CAPITAL [A-Z]", + "SMALL [a-z]", + "DIGIT [0-9]", + "IDENT [a-zA-Z0-9'_]", + "%START YYINITIAL COMMENT CHAR CHARESC CHAREND STRING ESCAPED", + "%%" + ] + +lexSymbols :: SymEnv -> String +lexSymbols ss = concatMap transSym ss + where + transSym (s,r) = + "\"" ++ s' ++ "\" \t return " ++ r ++ ";\n" + where + s' = escapeChars s + +restOfFlex :: Maybe String -> CF -> SymEnv -> String +restOfFlex inPackage cf env = concat + [ + lexComments inPackage (comments cf), + userDefTokens, + ifC "String" strStates, + ifC "Char" chStates, + ifC "Double" ("{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t " ++ ns ++ "yylval.double_ = atof(yytext); return " ++ nsDefine inPackage "_DOUBLE_" ++ ";\n"), + ifC "Integer" ("{DIGIT}+ \t " ++ ns ++ "yylval.int_ = atoi(yytext); return " ++ nsDefine inPackage "_INTEGER_" ++ ";\n"), + ifC "Ident" ("{LETTER}{IDENT}* \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ nsDefine inPackage "_IDENT_" ++ ";\n"), + "\\n ++" ++ ns ++ "yy_mylinenumber ;\n", + "[ \\t\\r\\n\\f] \t /* ignore white space. */;\n", + ". \t return " ++ nsDefine inPackage "_ERROR_" ++ ";\n", + "%%\n", + footer + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + ns = nsString inPackage + userDefTokens = unlines $ + ["" ++ printRegFlex exp ++ + " \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ sName name ++ ";" + | (name, exp) <- tokenPragmas cf] + where + sName n = case lookup n env of + Just x -> x + Nothing -> n + strStates = unlines --These handle escaped characters in Strings. + [ + "\"\\\"\" \t BEGIN STRING;", + "\\\\ \t BEGIN ESCAPED;", + "\\\" \t " ++ ns ++ "yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return " ++ nsDefine inPackage "_STRING_" ++ ";", + ". \t YY_BUFFER_APPEND(yytext);", + "n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;", + "\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;", + "\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;", + "t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;", + ". \t YY_BUFFER_APPEND(yytext); BEGIN STRING;" + ] + chStates = unlines --These handle escaped characters in Chars. + [ + "\"'\" \tBEGIN CHAR;", + "\\\\ \t BEGIN CHARESC;", + "[^'] \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";", + "n \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\n'; return " ++ nsDefine inPackage "_CHAR_" ++ ";", + "t \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\t'; return " ++ nsDefine inPackage "_CHAR_" ++ ";", + ". \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";", + "\"'\" \t BEGIN YYINITIAL;" + ] + footer = unlines + [ + "int " ++ ns ++ "initialize_lexer(FILE *inp) { yyin = inp; BEGIN YYINITIAL; }", + "int yywrap(void) { return 1; }" + ] + + +lexComments :: Maybe String -> ([(String, String)], [String]) -> String +lexComments inPackage (m,s) = + (unlines (map (lexSingleComment inPackage) s)) + ++ (unlines (map (lexMultiComment inPackage) m)) + +lexSingleComment :: Maybe String -> String -> String +lexSingleComment inPackage c = + "\"" ++ c ++ "\"[^\\n]*\\n ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC single-line comment */;" + +--There might be a possible bug here if a language includes 2 multi-line comments. +--They could possibly start a comment with one character and end it with another. +--However this seems rare. +lexMultiComment :: Maybe String -> (String, String) -> String +lexMultiComment inPackage (b,e) = unlines [ + "\"" ++ b ++ "\" \t BEGIN COMMENT;", + "\"" ++ e ++ "\" \t BEGIN YYINITIAL;", + ". \t /* BNFC multi-line comment */;", + "[\\n] ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC multi-line comment */;" + ---- "\\n ++yy_mylinenumber ;" + ] + + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) diff --git a/src/formats/cpp/CPPTop.hs b/src/formats/cpp/CPPTop.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp/CPPTop.hs @@ -0,0 +1,183 @@ +{- + BNF Converter: C++ Main file + Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CPPTop (makeCPP) where + +import Utils +import CF +import CFtoCPPAbs +import CFtoFlex +import CFtoBison +import CFtoCVisitSkel +import CFtoCPPPrinter +import CFtoLatex +import Data.Char +import System.Exit (exitFailure) +import qualified Common.Makefile as Makefile + +makeCPP :: Bool -> String -> CF -> IO () +makeCPP make name cf = do + let (hfile, cfile) = cf2CPPAbs name cf + writeFileRep "Absyn.H" hfile + writeFileRep "Absyn.C" cfile + let (flex, env) = cf2flex Nothing name cf + writeFileRep (name ++ ".l") flex + putStrLn " (Tested with flex 2.5.31)" + let bison = cf2Bison name cf env + writeFileRep (name ++ ".y") bison + putStrLn " (Tested with bison 1.875a)" + let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env + writeFileRep "Parser.H" header + let (skelH, skelC) = cf2CVisitSkel cf + writeFileRep "Skeleton.H" skelH + writeFileRep "Skeleton.C" skelC + let (prinH, prinC) = cf2CPPPrinter cf + writeFileRep "Printer.H" prinH + writeFileRep "Printer.C" prinC + writeFileRep "Test.C" (cpptest cf) + let latex = cfToLatex name cf + writeFileRep (name ++ ".tex") latex + if make then (writeFileRep "Makefile" $ makefile name) else return () + +makefile :: String -> String +makefile name = + (++) (unlines [ "CC = g++", "CCFLAGS = -g", "FLEX = flex", "BISON = bison", "" ]) + $ Makefile.mkRule "all" [ "Test" ++ name ] + [] + $ Makefile.mkRule "clean" [] + -- peteg: don't nuke what we generated - move that to the "vclean" target. + [ "rm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps Test" ++ name ] + $ Makefile.mkRule "distclean" [] + [ "rm -f *.o Absyn.C Absyn.H Test.C Parser.C Parser.H Lexer.C Skeleton.C Skeleton.H Printer.C Printer.H" + , "rm -f " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " + , "rm -f " ++ name ++ ".log " ++ name ++ ".ps Test" ++ name ++ " Makefile" ] + $ Makefile.mkRule ("Test" ++ name) [ "Absyn.o", "Lexer.o", "Parser.o", "Printer.o", "Test.o" ] + [ "@echo \"Linking Test" ++ name ++ "...\"" + , "${CC} ${CCFLAGS} *.o -o Test" ++ name ] + $ Makefile.mkRule "Absyn.o" [ "Absyn.C", "Absyn.H" ] + [ "${CC} ${CCFLAGS} -c Absyn.C" ] + $ Makefile.mkRule "Lexer.C" [ name ++ ".l" ] + [ "${FLEX} -oLexer.C " ++ name ++ ".l" ] + $ Makefile.mkRule "Parser.C" [ name ++ ".y" ] + [ "${BISON} " ++ name ++ ".y -o Parser.C" ] + $ Makefile.mkRule "Lexer.o" [ "Lexer.C", "Parser.H" ] + [ "${CC} ${CCFLAGS} -c Lexer.C " ] + $ Makefile.mkRule "Parser.o" [ "Parser.C", "Absyn.H" ] + [ "${CC} ${CCFLAGS} -c Parser.C" ] + $ Makefile.mkRule "Printer.o" [ "Printer.C", "Printer.H", "Absyn.H" ] + [ "${CC} ${CCFLAGS} -c Printer.C" ] + $ Makefile.mkRule "Test.o" [ "Test.C", "Parser.H", "Printer.H", "Absyn.H" ] + [ "${CC} ${CCFLAGS} -c Test.C" ] + $ Makefile.mkDoc name + "" + + +cpptest :: CF -> String +cpptest cf = + unlines + [ + "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", + "/* */", + "/* This test will parse a file, print the abstract syntax tree, and then */", + "/* pretty-print the result. */", + "/* */", + "/****************************************************************************/", + "#include ", + "#include \"Parser.H\"", + "#include \"Printer.H\"", + "#include \"Absyn.H\"", + "", + "int main(int argc, char ** argv)", + "{", + " FILE *input;", + " if (argc > 1) ", + " {", + " input = fopen(argv[1], \"r\");", + " if (!input)", + " {", + " fprintf(stderr, \"Error opening input file.\\n\");", + " exit(1);", + " }", + " }", + " else input = stdin;", + " /* The default entry point is used. For other options see Parser.H */", + " " ++ def ++ " *parse_tree = p" ++ def ++ "(input);", + " if (parse_tree)", + " {", + " printf(\"\\nParse Succesful!\\n\");", + " printf(\"\\n[Abstract Syntax]\\n\");", + " ShowAbsyn *s = new ShowAbsyn();", + " printf(\"%s\\n\\n\", s->show(parse_tree));", + " printf(\"[Linearized Tree]\\n\");", + " PrintAbsyn *p = new PrintAbsyn();", + " printf(\"%s\\n\\n\", p->print(parse_tree));", + " return 0;", + " }", + " return 1;", + "}", + "" + ] + where + def = head (allEntryPoints cf) + +mkHeaderFile cf cats eps env = unlines + [ + "#ifndef PARSER_HEADER_FILE", + "#define PARSER_HEADER_FILE", + "", + concatMap mkForwardDec cats, + "typedef union", + "{", + " int int_;", + " char char_;", + " double double_;", + " char* string_;", + (concatMap mkVar cats) ++ "} YYSTYPE;", + "", + "#define _ERROR_ 258", + mkDefines (259 :: Int) env, + "extern YYSTYPE yylval;", + concatMap mkFunc eps, + "", + "#endif" + ] + where + mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n" + mkForwardDec _ = "" + mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n" + mkVar _ = "" + mkDefines n [] = mkString n + mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) + mkString n = if isUsedCat cf "String" + then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) + else mkChar n + mkChar n = if isUsedCat cf "Char" + then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1) + else mkInteger n + mkInteger n = if isUsedCat cf "Integer" + then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1) + else mkDouble n + mkDouble n = if isUsedCat cf "Double" + then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1) + else mkIdent n + mkIdent n = if isUsedCat cf "Ident" + then ("#define _IDENT_ " ++ show n ++ "\n") + else "" + mkFunc s | (normCat s == s) = (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(FILE *inp);\n" + mkFunc _ = "" diff --git a/src/formats/cpp/RegToFlex.hs b/src/formats/cpp/RegToFlex.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp/RegToFlex.hs @@ -0,0 +1,73 @@ +module RegToFlex (printRegFlex) where + +-- modified from pretty-printer generated by the BNF converter + +import AbsBNF +import Data.Char + +-- the top-level printing method +printRegFlex :: Reg -> String +printRegFlex = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend (0::Int) where + rend i ss = case ss of + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + cons s t = s ++ t + new i s = s + space t s = if null s then t else t ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ c = [[c]] + prtList s = map (concat . prt 0) s + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["[^.]"]) + RChar c -> prPrec i 3 (prt 0 [mkEsc [c]]) + RAlts str -> prPrec i 3 (concat [["["], prt 0 $ mkEsc str, ["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) $ mkEsc str)) + RDigit -> prPrec i 3 (concat [["{DIGIT}"]]) + RLetter -> prPrec i 3 (concat [["{LETTER}"]]) + RUpper -> prPrec i 3 (concat [["{CAPITAL}"]]) + RLower -> prPrec i 3 (concat [["{SMALL}"]]) + RAny -> prPrec i 3 (concat [["."]]) + +-- Handle special characters in regular expressions. +mkEsc :: String -> String +mkEsc = concatMap escChar + where escChar c + | c `elem` "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" = '\\':[c] + | otherwise = [c] diff --git a/src/formats/cpp_stl/CFtoBisonSTL.hs b/src/formats/cpp_stl/CFtoBisonSTL.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp_stl/CFtoBisonSTL.hs @@ -0,0 +1,374 @@ +{- + BNF Converter: C++ Bison generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Bison input file using + STL. The main difference to CFtoBison is in handling + lists: by using std::vector and push_back, our rules + for reverting lists are the opposite to linked lists. + Note that because of the way bison stores results + the programmer can increase performance by limiting + the number of entry points in their grammar. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 6 August, 2003 + + Modified : 19 August, 2006, by Aarne Ranta (aarne@cs.chalmers.se) + + + ************************************************************** +-} + + +module CFtoBisonSTL (cf2Bison) where + +import CF +import Data.List (intersperse, isPrefixOf) +import NamedVariables hiding (varName) +import Data.Char (toLower,isUpper,isDigit) +import Utils ((+++), (++++)) +import TypeChecker +import ErrM +import STLUtils + +--This follows the basic structure of CFtoHappy. + +-- Type declarations +type Rules = [(NonTerminal,[(Pattern,Action)])] +type NonTerminal = String +type Pattern = String +type Action = String +type MetaVar = String + +--The environment comes from the CFtoFlex +cf2Bison :: Bool -> Maybe String -> String -> CF -> SymEnv -> String +cf2Bison ln inPackage name cf env + = unlines + [header inPackage name cf, + union inPackage (positionCats cf ++ allCats cf), + maybe "" (\ns -> "%name-prefix=\"" ++ ns ++ "yy\"") inPackage, + "%token _ERROR_", + tokens user env, + declarations cf, + specialToks cf, + "%%", + prRules (rulesForBison ln inPackage name cf env) + ] + where + user = fst (unzip (tokenPragmas cf)) + + +positionCats cf = filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf)) + +header :: Maybe String -> String -> CF -> String +header inPackage name cf = unlines + ["/* This Bison file was machine-generated by BNFC */", + "%{", + "#include ", + "#include ", + "#include ", + "#include ", + "#include ", + "#include \"Absyn.H\"", + "typedef struct yy_buffer_state *YY_BUFFER_STATE;", + "int yyparse(void);", + "int yylex(void);", + "YY_BUFFER_STATE " ++ ns ++ "yy_scan_string(const char *str);", + "void " ++ ns ++ "yy_delete_buffer(YY_BUFFER_STATE buf);", + "int " ++ ns ++ "yy_mylinenumber;", --- hack to get line number. AR 2006 + "int " ++ ns ++ "initialize_lexer(FILE * inp);", + "int " ++ ns ++ "yywrap(void)", + "{", + " return 1;", + "}", + "void " ++ ns ++ "yyerror(const char *str)", + "{", + " std::cout << \"line \" << " ++ ns ++ "yy_mylinenumber << std::endl ;", + " fprintf(stderr,\"error: %s\\n\",str);", + "}", + "", + definedRules cf, + nsStart inPackage, + unlines $ map (parseMethod inPackage name) (allCatsIdNorm cf ++ positionCats cf), -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug. + nsEnd inPackage, + "%}" + ] + where + ns = nsString inPackage + +definedRules :: CF -> String +definedRules cf = + unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ] + where + ctx = buildContext cf + + list = LC (const "[]") (\t -> "List" ++ unBase t) + where + unBase (ListT t) = unBase t + unBase (BaseT x) = normCat x + + rule f xs e = + case checkDefinition' list ctx f xs e of + Bad err -> error $ "Panic! This should have been caught already:\n" ++ err + Ok (args,(e',t)) -> unlines + [ cppType t ++ " " ++ f ++ "_ (" ++ + concat (intersperse ", " $ map cppArg args) ++ ") {" + , " return " ++ cppExp e' ++ ";" + , "}" + ] + where + + cppType :: Base -> String + cppType (ListT (BaseT x)) = "List" ++ normCat x ++ " *" + cppType (ListT t) = cppType t ++ " *" + cppType (BaseT x) + | isToken x ctx = "String" + | otherwise = normCat x ++ " *" + + cppArg :: (String, Base) -> String + cppArg (x,t) = cppType t ++ " " ++ x ++ "_" + + cppExp :: Exp -> String + cppExp (App "[]" []) = "0" + cppExp (App x []) + | elem x xs = x ++ "_" -- argument + cppExp (App t [e]) + | isToken t ctx = cppExp e + cppExp (App x es) + | isUpper (head x) = call ("new " ++ x) es + | otherwise = call (x ++ "_") es + cppExp (LitInt n) = show n + cppExp (LitDouble x) = show x + cppExp (LitChar c) = show c + cppExp (LitString s) = show s + + call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")" + + +--This generates a parser method for each entry point. +parseMethod :: Maybe String -> String -> Cat -> String +parseMethod inPackage name cat = + -- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm + -- then "" + -- else + unlines + [ + "static " ++ cat' ++ "*" +++ (resultName cat') +++ "= 0;", + cat' ++"* p" ++ cat' ++ "(FILE *inp)", + "{", + " " ++ ns ++ "yy_mylinenumber = 1;", -- O.F. + " " ++ ns ++ "initialize_lexer(inp);", + " if (yyparse())", + " { /* Failure */", + " return 0;", + " }", + " else", + " { /* Success */", + " return" +++ (resultName cat') ++ ";", + " }", + "}", + cat' ++"* p" ++ cat' ++ "(const char *str)", + "{", + " YY_BUFFER_STATE buf;", + " int result;", + " " ++ ns ++ "yy_mylinenumber = 1;", + " " ++ ns ++ "initialize_lexer(0);", + " buf = " ++ ns ++ "yy_scan_string(str);", + " result = yyparse();", + " " ++ ns ++ "yy_delete_buffer(buf);", + " if (result)", + " { /* Failure */", + " return 0;", + " }", + " else", + " { /* Success */", + " return" +++ (resultName cat') ++ ";", + " }", + "}" + ] + where + cat' = identCat (normCat cat) + ns = nsString inPackage + + +--The union declaration is special to Bison/Yacc and gives the type of yylval. +--For efficiency, we may want to only include used categories here. +union :: Maybe String -> [Cat] -> String +union inPackage cats = unlines + [ + "%union", + "{", + " int int_;", + " char char_;", + " double double_;", + " char* string_;", + concatMap mkPointer cats, + "}" + ] + where --This is a little weird because people can make [Exp2] etc. + mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion. + " " ++ scope ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n" + mkPointer s | normCat s == s = --normal cat + " " ++ scope ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n" + mkPointer s = "" + scope = nsScope inPackage + +--declares non-terminal types. +declarations :: CF -> String +declarations cf = concatMap (typeNT cf) (positionCats cf ++ allCats cf) + where --don't define internal rules + typeNT cf nt | (isPositionCat cf nt || rulesForCat cf nt /= []) = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n" + typeNT cf nt = "" + +--declares terminal types. +tokens :: [UserDef] -> SymEnv -> String +tokens user ts = concatMap (declTok user) ts + where + declTok u (s,r) = if elem s u + then "%token " ++ r ++ " // " ++ s ++ "\n" + else "%token " ++ r ++ " // " ++ s ++ "\n" + +specialToks :: CF -> String +specialToks cf = concat [ + ifC "String" "%token _STRING_\n", + ifC "Char" "%token _CHAR_\n", + ifC "Integer" "%token _INTEGER_\n", + ifC "Double" "%token _DOUBLE_\n", + ifC "Ident" "%token _IDENT_\n" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + +--The following functions are a (relatively) straightforward translation +--of the ones in CFtoHappy.hs +rulesForBison :: Bool -> Maybe String -> String -> CF -> SymEnv -> Rules +rulesForBison ln inPackage name cf env = (map mkOne $ ruleGroups cf) ++ posRules where + mkOne (cat,rules) = constructRule ln inPackage cf env rules cat + posRules = map mkPos $ positionCats cf + mkPos cat = (cat, [(maybe cat id (lookup cat env), + "$$ = new " ++ cat ++ "($1," ++ nsString inPackage ++ "yy_mylinenumber) ; YY_RESULT_" ++ + cat ++ "_= $$ ;")]) + +-- For every non-terminal, we construct a set of rules. +constructRule :: + Bool -> Maybe String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule ln inPackage cf env rules nt = + (nt,[(p,(generateAction ln inPackage nt (ruleName r) b m) +++ result) | + r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True,revSepListRule r0) + else (False,r0), + let (p,m) = generatePatterns cf env r b]) + where + ruleName r = case funRule r of + ---- "(:)" -> identCat nt + ---- "(:[])" -> identCat nt + z -> z + revs = reversibleCats cf + eps = allEntryPoints cf + isEntry nt = if elem nt eps then True else False + result = if isEntry nt then (nsScope inPackage ++ resultName (normCat (identCat nt))) ++ "= $$;" else "" + +-- Generates a string containing the semantic action. +generateAction :: Bool -> Maybe String -> NonTerminal -> Fun -> Bool -> [(MetaVar,Bool)] -> Action +generateAction ln inPackage cat f b mbs = + reverses ++ + if isCoercion f + then "$$ = " ++ (unwords ms) ++ ";" + else if (f == "[]") + then concat ["$$ = ","new ", scope, identCatV cat, "();"] + else if (f == "(:[])") + then concat ["$$ = ","new ", scope, identCatV cat, "() ; $$->push_back($1);"] + else if (f == "(:)" && b) + then "$1->push_back("++ lastms ++ ") ; $$ = $1 ;" + else if (f == "(:)") + then lastms ++ "->push_back($1) ; $$ = " ++ lastms ++ " ;" ---- not left rec + else if isDefinedRule f + then concat ["$$ = ", scope, f, "_", "(", concat $ intersperse ", " ms', ");" ] + else concat + ["$$ = ", "new ", scope, f, "(", (concat (intersperse ", " ms')), ");" ++ addLn ln] + where + ms = map fst mbs + ms' = ms + addLn ln = if ln then " $$->line_number = " ++ nsString inPackage ++ "yy_mylinenumber;" else "" -- O.F. + lastms = last ms + identCatV cat = reverse $ dropWhile isDigit $ reverse $ identCat cat + reverses = unwords [ + "std::reverse(" ++ m ++"->begin(),"++m++"->end()) ;" | + (m,True) <- mbs] + scope = nsScope inPackage + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal +generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)]) +generatePatterns cf env r revv = case rhsRule r of + [] -> ("/* empty */",[]) + its -> (unwords (map mkIt its), metas its) + where + mkIt i = case i of + Left c -> case lookup c env of + Just x | not (isPositionCat cf c) -> x + _ -> typeName (identCat c) + Right s -> case lookup s env of + Just x -> x + Nothing -> s + metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its] + + -- notice: reversibility with push_back vectors is the opposite + -- of right-recursive lists! + revert c = (head c == '[') && + not (isConsFun (funRule r)) && notElem c revs + revs = reversibleCats cf + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. + +prRules :: Rules -> String +prRules [] = [] +prRules ((nt, []):rs) = prRules rs --internal rule +prRules ((nt,((p,a):ls)):rs) = + (unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ ", a , "}"])]) ++ pr ls + +--Some helper functions. +resultName :: String -> String +resultName s = "YY_RESULT_" ++ s ++ "_" + +--slightly stronger than the NamedVariable version. +varName :: String -> String +varName s = (map toLower (identCat s)) ++ "_" + +typeName :: String -> String +typeName "Ident" = "_IDENT_" +typeName "String" = "_STRING_" +typeName "Char" = "_CHAR_" +typeName "Integer" = "_INTEGER_" +typeName "Double" = "_DOUBLE_" +typeName x = x + + diff --git a/src/formats/cpp_stl/CFtoCVisitSkelSTL.hs b/src/formats/cpp_stl/CFtoCVisitSkelSTL.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp_stl/CFtoCVisitSkelSTL.hs @@ -0,0 +1,148 @@ +{- + BNF Converter: C++ Skeleton generation + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C++ Skeleton functions. + + The generated files use the Visitor design pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 9 August, 2003 + + Modified : 29 August, 2006 Aarne Ranta + + + ************************************************************** +-} + +module CFtoCVisitSkelSTL (cf2CVisitSkel) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower, toUpper) +import OOAbstract +import STLUtils + +--Produces (.H file, .C file) +cf2CVisitSkel :: Maybe String -> CF -> (String, String) +cf2CVisitSkel inPackage cf = (mkHFile inPackage cab, mkCFile inPackage cab) + where + cab = cf2cabs cf + +-- **** Header (.H) File Functions **** + +--Generates the Header File +mkHFile :: Maybe String -> CAbs -> String +mkHFile inPackage cf = unlines [ + "#ifndef " ++ hdef, + "#define " ++ hdef, + "/* You might want to change the above name. */", + "", + "#include \"Absyn.H\"", + "", + nsStart inPackage, + "class Skeleton : public Visitor", + "{", + "public:", + unlines [" void visit" ++ b ++ "(" ++ b ++ "* p);" | + b <- classes, notElem b (defineds cf)], + unlines [" void visit" ++ b ++ "(" ++ b ++ " x);" | b <- basics], + "};", + nsEnd inPackage, + "", + "#endif" + ] + where + hdef = nsDefine inPackage "SKELETON_HEADER" + classes = allClasses cf + basics = tokentypes cf ++ map fst basetypes + + +-- **** Implementation (.C) File Functions **** + +--Makes the .C File +mkCFile :: Maybe String -> CAbs -> String +mkCFile inPackage cf = unlines [ + headerC, + nsStart inPackage, + unlines [ + "void Skeleton::visit" ++ t ++ "(" ++ + t ++ "* t) {} //abstract class" | t <- absclasses cf], + unlines [prCon r | (_,rs) <- signatures cf, r <- rs], + unlines [prList cb | cb <- listtypes cf], + unlines [prBasic b | b <- tokentypes cf ++ map fst basetypes], + nsEnd inPackage + ] + +headerC = unlines [ + "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/", + "/* This implements the common visitor design pattern.", + " Note that this method uses Visitor-traversal of lists, so", + " List->accept() does NOT traverse the list. This allows different", + " algorithms to use context information differently. */", + "", + "#include \"Skeleton.H\"", + "" + ] + +prBasic c = unlines [ + "void Skeleton::visit" ++ c ++ "(" ++ c ++ " x)", + "{", + " /* Code for " ++ c ++ " Goes Here */", + "}" + ] + +prList (cl,b) = unlines [ + "void Skeleton::visit" ++ cl ++ "("++ cl ++ "*" +++ vname ++ ")", + "{", + " for ("++ cl ++"::iterator i = " ++ + vname++"->begin() ; i != " ++vname ++"->end() ; ++i)", + " {", + if b + then " (*i)->accept(this);" + else " visit" ++ drop 4 cl ++ "(*i) ;", + " }", + "}" + ] + where + vname = map toLower cl + +prCon fcs@(f,cs) = unlines [ + "void Skeleton::visit" ++ f ++ "(" ++ f ++ " *" ++ v ++ ")", + "{", + " /* Code For " ++ f ++ " Goes Here */", + "", + unlines [" " ++ visitArg c | c <- cs], + "}" + ] + where + v = map toLower f + visitArg (cat,isPt,var) = + if isPt + then (v ++ "->" ++ var ++ "->accept(this);") + else ("visit" ++ cat ++ "(" ++ v ++ "->" ++ var ++ ");") + diff --git a/src/formats/cpp_stl/CFtoSTLAbs.hs b/src/formats/cpp_stl/CFtoSTLAbs.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp_stl/CFtoSTLAbs.hs @@ -0,0 +1,275 @@ +{- + BNF Converter: C++ abstract syntax generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C++ Abstract Syntax + tree classes. It generates both a Header file + and an Implementation file, and uses the Visitor + design pattern. It uses STL (Standard Template Library). + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 4 August, 2003 + + Modified : 22 May, 2004 / Antti-Juhani Kaijanaho + 29 August, 2006 / Aarne Ranta + + ************************************************************** +-} + +module CFtoSTLAbs (cf2CPPAbs) where + +import OOAbstract +import CF +import Utils((+++),(++++)) +import NamedVariables +import Data.List +import Data.Char(toLower) +import STLUtils + +--The result is two files (.H file, .C file) + +cf2CPPAbs :: Bool -> Maybe String -> String -> CF -> (String, String) +cf2CPPAbs ln inPackage name cf = (mkHFile ln inPackage cab, mkCFile inPackage cab) + where + cab = cf2cabs cf + + +-- **** Header (.H) File Functions **** -- + +--Makes the Header file. +mkHFile :: Bool -> Maybe String -> CAbs -> String +mkHFile ln inPackage cf = unlines + [ + "#ifndef " ++ hdef, + "#define " ++ hdef, + "", + "#include", + "#include", + "", + "//C++ Abstract Syntax Interface generated by the BNF Converter.", + nsStart inPackage, + "/******************** TypeDef Section ********************/", + "", + unlines ["typedef " ++ d ++ " " ++ c ++ ";" | (c,d) <- basetypes], + "", + unlines ["typedef std::string " ++ s ++ ";" | s <- tokentypes cf], + "", + "/******************** Forward Declarations ********************/", + "", + unlines ["class " ++ c ++ ";" | c <- classes, notElem c (defineds cf)], + "", + "/******************** Visitor Interfaces ********************/", + prVisitor cf, + "", + prVisitable, + "", + "/******************** Abstract Syntax Classes ********************/", + "", + unlines [prAbs ln c | c <- absclasses cf], + "", + unlines [prCon (c,r) | (c,rs) <- signatures cf, r <- rs], + "", + unlines [prList c | c <- listtypes cf], + nsEnd inPackage, + "#endif" + ] + where + classes = allClasses cf + hdef = nsDefine inPackage "ABSYN_HEADER" + +-- auxiliaries + +prVisitable :: String +prVisitable = unlines [ + "class Visitable", + "{", + " public:", + -- all classes with virtual methods require a virtual destructor + " virtual ~Visitable() {}", + " virtual void accept(Visitor *v) = 0;", + "};" + ] + +prVisitor :: CAbs -> String +prVisitor cf = unlines [ + "class Visitor", + "{", + "public:", + " virtual ~Visitor() {}", + unlines + [" virtual void visit"++c++"("++c++" *p) = 0;" | c <- allClasses cf, + notElem c (defineds cf)], + "", + unlines + [" virtual void visit"++c++"(" ++c++" x) = 0;" | c <- allNonClasses cf], + "};" + ] + +prAbs :: Bool -> Cat -> String +prAbs ln c = unlines [ + "class " ++c++ " : public Visitable", + "{", + "public:", + " virtual " ++ c ++ " *clone() const = 0;", + if ln then " int line_number;" else "", + "};" + ] + +prCon :: (Cat,CAbsRule) -> String +prCon (c,(f,cs)) = unlines [ + "class " ++f++ " : public " ++ c, + "{", + "public:", + unlines + [" "++ typ +++ pointerIf st var ++ ";" | (typ,st,var) <- cs], + " " ++ f ++ "(const " ++ f ++ " &);", + " " ++ f ++ " &operator=(const " ++f++ " &);", + " " ++ f ++ "(" ++ conargs ++ ");", + -- Typ *p1, PIdent *p2, ListStm *p3); + " ~" ++f ++ "();", + " virtual void accept(Visitor *v);", + " virtual " ++f++ " *clone() const;", + " void swap(" ++f++ " &);", + "};" + ] + where + conargs = concat $ intersperse ", " + [x +++ pointerIf st ("p" ++ show i) | ((x,st,_),i) <- zip cs [1..]] + +prList :: (Cat,Bool) -> String +prList (c,b) = unlines [ + "class " ++c++ " : public Visitable, public std::vector<" ++bas++ ">", + "{", + "public:", + " virtual void accept(Visitor *v);", + " virtual " ++ c ++ " *clone() const;", + "};" + ] + where + bas = drop 4 c ++ -- drop List + if b then "*" else "" + + +-- **** Implementation (.C) File Functions **** -- + +mkCFile :: Maybe String -> CAbs -> String +mkCFile inPackage cf = unlines $ [ + "//C++ Abstract Syntax Implementation generated by the BNF Converter.", + "#include ", + "#include ", + "#include ", + "#include ", + "#include \"Absyn.H\"", + nsStart inPackage, + unlines [prConC r | (_,rs) <- signatures cf, r <- rs], + unlines [prListC c | (c,_) <- listtypes cf], + nsEnd inPackage + ] + +prConC :: CAbsRule -> String +prConC fcs@(f,cs) = unlines [ + "/******************** " ++ f ++ " ********************/", + prConstructorC fcs, + prCopyC fcs, + prDestructorC fcs, + prAcceptC f, + prCloneC f, + "" + ] + +prListC :: Cat -> String +prListC c = unlines [ + "/******************** " ++ c ++ " ********************/", + "", + prAcceptC c, + "", + prCloneC c + ] + + +--The standard accept function for the Visitor pattern +prAcceptC :: Cat -> String +prAcceptC ty = unlines [ + "void " ++ ty ++ "::accept(Visitor *v)", + "{", + " v->visit" ++ ty ++ "(this);", + "}" + ] + +--The cloner makes a new deep copy of the object +prCloneC :: Cat -> String +prCloneC c = unlines [ + c +++ "*" ++ c ++ "::clone() const", + "{", + " return new" +++ c ++ "(*this);", + "}" + ] + +--The constructor assigns the parameters to the corresponding instance variables. +prConstructorC :: CAbsRule -> String +prConstructorC (f,cs) = unlines [ + f ++ "::" ++ f ++ "(" ++ conargs ++ ")", + "{", + unlines [" " ++ c ++ " = " ++ p ++ ";" | (c,p) <- zip cvs pvs], + "}" + ] + where + cvs = [c | (_,_,c) <- cs] + pvs = ["p" ++ show i | ((x,st,_),i) <- zip cs [1..]] + conargs = concat $ intersperse ", " + [x +++ pointerIf st v | ((x,st,_),v) <- zip cs pvs] + + +--Copy constructor and copy assignment +prCopyC :: CAbsRule -> String +prCopyC (c,cs) = unlines [ + c ++ "::" ++ c ++ "(const" +++ c +++ "& other)", + "{", + unlines [" " ++ cv ++ " = other." ++ cloneIf st cv ++ ";" | (_,st,cv) <- cs], + "}", + "", + c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other)", + "{", + " " ++ c +++ "tmp(other);", + " swap(tmp);", + " return *this;", + "}", + "", + "void" +++ c ++ "::swap(" ++ c +++ "& other)", + "{", + unlines [" std::swap(" ++ cv ++ ", other." ++ cv ++ ");" | (_,_,cv) <- cs], + "}" + ] + where + cloneIf st cv = if st then (cv ++ "->clone()") else cv + +--The destructor deletes all a class's members. +prDestructorC :: CAbsRule -> String +prDestructorC (c,cs) = unlines [ + c ++ "::~" ++ c ++"()", + "{", + unlines [" delete(" ++ cv ++ ");" | (_,isPointer,cv) <- cs, isPointer], + "}" + ] diff --git a/src/formats/cpp_stl/CFtoSTLPrinter.hs b/src/formats/cpp_stl/CFtoSTLPrinter.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp_stl/CFtoSTLPrinter.hs @@ -0,0 +1,658 @@ +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C++ Pretty Printer. + It also generates the "show" method for + printing an abstract syntax tree. + + The generated files use the Visitor design pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 10 August, 2003 + + Modified : 3 September, 2003 + * Added resizable buffers + + ************************************************************** +-} + +module CFtoSTLPrinter (cf2CPPPrinter) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower, toUpper) +import STLUtils + +--Produces (.H file, .C file) +cf2CPPPrinter :: Maybe String -> CF -> (String, String) +cf2CPPPrinter inPackage cf = (mkHFile inPackage cf groups, mkCFile inPackage cf groups) + where + groups = positionRules cf ++ (fixCoercions (ruleGroupsInternals cf)) + +positionRules :: CF -> [(Cat,[Rule])] +positionRules cf = + [(cat,[Rule cat cat [Left "String", Left "Integer"]]) | + cat <- filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))] + +{- **** Header (.H) File Methods **** -} + +--An extremely large function to make the Header File +mkHFile :: Maybe String -> CF -> [(Cat,[Rule])] -> String +mkHFile inPackage cf groups = unlines + [ + printHeader, + concatMap prDataH groups, + classFooter, + showHeader, + concatMap prDataH groups, + classFooter, + footer + ] + where + printHeader = unlines + [ + "#ifndef " ++ hdef, + "#define " ++ hdef, + "", + "#include \"Absyn.H\"", + "#include ", + "#include ", + "#include ", + "", + nsStart inPackage, + "/* Certain applications may improve performance by changing the buffer size */", + "#define " ++ nsDefine inPackage "BUFFER_INITIAL" ++ " 2000", + "/* You may wish to change _L_PAREN or _R_PAREN */", + "#define " ++ nsDefine inPackage "_L_PAREN" ++ " '('", + "#define " ++ nsDefine inPackage "_R_PAREN" ++ " ')'", + "", + "class PrintAbsyn : public Visitor", + "{", + " protected:", + " int _n_, _i_;", + " /* The following are simple heuristics for rendering terminals */", + " /* You may wish to change them */", + " void render(Char c);", + " void render(String s);", + " void indent(void);", + " void backup(void);", + " public:", + " PrintAbsyn(void);", + " ~PrintAbsyn(void);", + " char* print(Visitable* v);" + ] + hdef = nsDefine inPackage "PRINTER_HEADER" + classFooter = unlines $ + [ + " void visitInteger(Integer i);", + " void visitDouble(Double d);", + " void visitChar(Char c);", + " void visitString(String s);", + " void visitIdent(String s);" + ] ++ [" void visit" ++ t ++ "(String s);" | t <- tokenNames cf] ++ + [ + " protected:", + " void inline bufAppend(const char* s)", + " {", + " int len = strlen(s);", + " while (cur_ + len > buf_size)", + " {", + " buf_size *= 2; /* Double the buffer size */", + " resizeBuffer();", + " }", + " for(int n = 0; n < len; n++)", + " {", + " buf_[cur_ + n] = s[n];", + " }", + " cur_ += len;", + " buf_[cur_] = 0;", + " }", + " void inline bufAppend(const char c)", + " {", + " if (cur_ == buf_size)", + " {", + " buf_size *= 2; /* Double the buffer size */", + " resizeBuffer();", + " }", + " buf_[cur_] = c;", + " cur_++;", + " buf_[cur_] = 0;", + " }", + " void inline bufReset(void)", + " {", + " cur_ = 0;", + " buf_size = " ++ nsDefine inPackage "BUFFER_INITIAL" ++ ";", + " resizeBuffer();", + " memset(buf_, 0, buf_size);", + " }", + " void inline resizeBuffer(void)", + " {", + " char* temp = (char*) malloc(buf_size);", + " if (!temp)", + " {", + " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");", + " exit(1);", + " }", + " if (buf_)", + " {", + " strcpy(temp, buf_);", + " free(buf_);", + " }", + " buf_ = temp;", + " }", + " char *buf_;", + " int cur_, buf_size;", + "};", + "" + ] + showHeader = unlines + [ + "", + "class ShowAbsyn : public Visitor", + "{", + " public:", + " ShowAbsyn(void);", + " ~ShowAbsyn(void);", + " char* show(Visitable* v);" + ] + footer = unlines + [ + nsEnd inPackage, + "", + "#endif" + ] + +--Prints all the required method names and their parameters. +prDataH :: (Cat, [Rule]) -> String +prDataH (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then concat [" void visit", cl, "(", cl, "* p);\n"] + else abstract ++ (concatMap prRuleH rules) + where + cl = identCat (normCat cat) + abstract = case lookupRule cat rules of + Just x -> "" + Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n" + +--Prints all the methods to visit a rule. +prRuleH :: Rule -> String +prRuleH (Rule fun c cats) | isProperLabel fun = concat + [" void visit", fun, "(", fun, " *p);\n"] +prRuleH _ = "" + +{- **** Implementation (.C) File Methods **** -} + +--This makes the .C file by a similar method. +mkCFile :: Maybe String -> CF -> [(Cat,[Rule])] -> String +mkCFile inPackage cf groups = concat + [ + header, + nsStart inPackage ++ "\n", + prRender, + printEntries, + concatMap (prPrintData inPackage cf user) groups, + printBasics, + printTokens, + showEntries, + concatMap (prShowData user) groups, + showBasics, + showTokens, + nsEnd inPackage ++ "\n" + ] + where + user0 = fst (unzip (tokenPragmas cf)) + (userPos,user) = partition (isPositionCat cf) user0 + header = unlines + [ + "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/", + "", + "#include ", + "#include \"Printer.H\"", + "" + ] + printEntries = unlines + [ + "PrintAbsyn::PrintAbsyn(void)", + "{", + " _i_ = 0; _n_ = 0;", + " buf_ = 0;", + " bufReset();", + "}", + "", + "PrintAbsyn::~PrintAbsyn(void)", + "{", + "}", + "", + "char* PrintAbsyn::print(Visitable *v)", + "{", + " _i_ = 0; _n_ = 0;", + " bufReset();", + " v->accept(this);", + " return buf_;", + "}" + ] + showEntries = unlines + [ + "ShowAbsyn::ShowAbsyn(void)", + "{", + " buf_ = 0;", + " bufReset();", + "}", + "", + "ShowAbsyn::~ShowAbsyn(void)", + "{", + "}", + "", + "char* ShowAbsyn::show(Visitable *v)", + "{", + " bufReset();", + " v->accept(this);", + " return buf_;", + "}" + ] + printBasics = unlines + [ + "void PrintAbsyn::visitInteger(Integer i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%d\", i);", + " bufAppend(tmp);", + "}", + "void PrintAbsyn::visitDouble(Double d)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%g\", d);", + " bufAppend(tmp);", + "}", + "void PrintAbsyn::visitChar(Char c)", + "{", + " bufAppend('\\'');", + " bufAppend(c);", + " bufAppend('\\'');", + "}", + "void PrintAbsyn::visitString(String s_)", + "{", + " const char *s = s_.c_str() ;", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "void PrintAbsyn::visitIdent(String s_)", + "{", + " const char *s = s_.c_str() ;", + " render(s);", + "}", + "" + ] + + printTokens = unlines + [unlines [ + "void PrintAbsyn::visit" ++ t ++ "(String s_)", + "{", + " const char *s = s_.c_str() ;", + " render(s);", + "}", + "" + ] | t <- tokenNames cf + ] + + showBasics = unlines + [ + "void ShowAbsyn::visitInteger(Integer i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%d\", i);", + " bufAppend(tmp);", + "}", + "void ShowAbsyn::visitDouble(Double d)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%g\", d);", + " bufAppend(tmp);", + "}", + "void ShowAbsyn::visitChar(Char c)", + "{", + " bufAppend('\\'');", + " bufAppend(c);", + " bufAppend('\\'');", + "}", + "void ShowAbsyn::visitString(String s_)", + "{", + " const char *s = s_.c_str() ;", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "void ShowAbsyn::visitIdent(String s_)", + "{", + " const char *s = s_.c_str() ;", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "" + ] + + showTokens = unlines + [unlines [ + "void ShowAbsyn::visit" ++ t ++ "(String s_)", + "{", + " const char *s = s_.c_str() ;", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "" + ] | t <- tokenNames cf + ] + + +{- **** Pretty Printer Methods **** -} + +--Generates methods for the Pretty Printer +prPrintData :: Maybe String -> CF -> [UserDef] -> (Cat, [Rule]) -> String +prPrintData inPackage cf user (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then unlines + [ + "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")", + "{", + " for ("++ cl ++"::const_iterator i = " ++ + vname++"->begin() ; i != " ++vname ++"->end() ; ++i)", + " {", + if isBase user vname + then " visit" ++ baseName cl ++ "(*i) ;" + else " (*i)->accept(this);", + optsep, + " }", + "}", + "" + ] --Not a list: + -- a position token + else if isPositionCat cf cat then unlines [ + "void PrintAbsyn::visit" ++ cat ++ "(" ++ cat ++ "* p)", + "{", + " visitIdent(p->string_);", + "}" + ] + else abstract ++ (concatMap (prPrintRule inPackage user) rules) + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl ++ "_" + visitMember = if isBasic user member + then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" + else " " ++ vname ++ "->" ++ member ++ "->accept(this);" + sep = if (length sep') == 1 + then "'" ++ (escapeChars sep') ++ "'" + else "\"" ++ (escapeChars sep') ++ "\"" + sep' = getCons rules + optsep = + (if hasOneFunc rules + then " if (i != " ++ vname ++ "->end() - 1) " + else " " + ) ++ "render(" ++ sep ++ ");" + abstract = case lookupRule cat rules of + Just x -> "" + Nothing -> "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl ++ "*p) {} //abstract class\n\n" + +--Pretty Printer methods for a rule. +prPrintRule :: Maybe String -> [UserDef] -> Rule -> String +prPrintRule inPackage user r@(Rule fun c cats) | isProperLabel fun = unlines + [ + "void PrintAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")", + "{", + " int oldi = _i_;", + lparen, + cats', + rparen, + " _i_ = oldi;", + "}\n" + ] + where + p = precRule r + (lparen, rparen) = + (" if (oldi > " ++ (show p) ++ ") render(" ++ nsDefine inPackage "_L_PAREN" ++ ");\n", + " if (oldi > " ++ (show p) ++ ") render(" ++ nsDefine inPackage "_R_PAREN" ++ ");\n") + cats' = (concatMap (prPrintCat user fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats))) + fnm = "p" --old names could cause conflicts + getPrec (Right s) = 0 + getPrec (Left c) = precCat c +prPrintRule _ _ _ = "" + +--This goes on to recurse to the instance variables. +prPrintCat :: [UserDef] -> String -> (Either Cat String, Int) -> String +prPrintCat user fnm (c,p) = case c of + (Right t) -> " render(" ++ t' ++ ");\n" + where + t' = if length t == 1 + then "'" ++ (escapeChars t) ++ "'" + else "\"" ++ (escapeChars t) ++ "\"" + (Left nt) -> if isBasic user nt + then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" + else if "list" `isPrefixOf` nt + then " if(" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}" + else " " ++ accept ++ "\n" + where + accept = if nt == "#_" --Internal category + then "/* Internal Category */\n" + else (setI p) ++ fnm ++ "->" ++ nt ++ "->accept(this);" + +{- **** Abstract Syntax Tree Printer **** -} + +--This prints the functions for Abstract Syntax tree printing. +prShowData :: [UserDef] -> (Cat, [Rule]) -> String +prShowData user (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then unlines + [ + "void ShowAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")", + "{", + " for ("++ cl ++"::const_iterator i = " ++ + vname++"->begin() ; i != " ++vname ++"->end() ; ++i)", + " {", + if isBase user vname + then " visit" ++ baseName cl ++ "(*i) ;" + else " (*i)->accept(this);", + " if (i != " ++ vname ++ "->end() - 1) bufAppend(\", \");", + " }", + "}", + "" + ] --Not a list: + else abstract ++ (concatMap (prShowRule user) rules) + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl ++ "_" + visitMember = if isBasic user member + then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" + else " " ++ vname ++ "->" ++ member ++ "->accept(this);" + abstract = case lookupRule cat rules of + Just x -> "" + Nothing -> "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ "* p) {} //abstract class\n\n" + +--This prints all the methods for Abstract Syntax tree rules. +prShowRule :: [UserDef] -> Rule -> String +prShowRule user (Rule fun c cats) | isProperLabel fun = concat + [ + "void ShowAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")\n", + "{\n", + lparen, + " bufAppend(\"" ++ fun ++ "\");\n", + optspace, + cats', + rparen, + "}\n" + ] + where + (optspace, lparen, rparen) = if allTerms cats + then ("","","") + else (" bufAppend(' ');\n", " bufAppend('(');\n"," bufAppend(')');\n") + cats' = if allTerms cats + then "" + else concat (insertSpaces (map (prShowCat user fnm) (fixOnes (numVars [] cats)))) + insertSpaces [] = [] + insertSpaces (x:[]) = [x] + insertSpaces (x:xs) = if x == "" + then insertSpaces xs + else (x : [" bufAppend(' ');\n"]) ++ (insertSpaces xs) + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs + fnm = "p" --other names could cause conflicts +prShowRule _ _ = "" + +--This recurses to the instance variables of a class. +prShowCat :: [UserDef] -> String -> Either Cat String -> String +prShowCat user fnm c = + case c of + (Right t) -> "" + (Left nt) -> + if isBasic user nt + then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" + else if nt == "#_" --internal category + then "/* Internal Category */\n" + else if ((normCat nt) /= nt) + then accept + else concat + [ + " bufAppend('[');\n", + " if (" ++ fnm ++ "->" ++ nt ++ ")" ++ accept, + " bufAppend(']');\n" + ] + where + accept = " " ++ fnm ++ "->" ++ nt ++ "->accept(this);\n" + +{- **** Helper Functions Section **** -} + + +--Just checks if something is a basic or user-defined type. +--This is because you don't -> a basic non-pointer type. +isBasic :: [UserDef] -> String -> Bool +isBasic user v = + if elem (init v) user' + then True + else if "integer_" `isPrefixOf` v then True + else if "char_" `isPrefixOf` v then True + else if "string_" `isPrefixOf` v then True + else if "double_" `isPrefixOf` v then True + else if "ident_" `isPrefixOf` v then True + else False + where + user' = map (map toLower) user + +-- from listident to ident_ +isBase user vn = isBasic user (baseName vn ++ "_") +-- from ListIdent to Ident +baseName cl = drop 4 cl + + +--The visit-function name of a basic type +funName :: String -> String +funName v = + if "integer_" `isPrefixOf` v then "Integer" + else if "char_" `isPrefixOf` v then "Char" + else if "string_" `isPrefixOf` v then "String" + else if "double_" `isPrefixOf` v then "Double" + else if "ident_" `isPrefixOf` v then "Ident" + else "Ident" --User-defined type + +--Just sets the coercion level for parentheses in the Pretty Printer. +setI :: Int -> String +setI n = "_i_ = " ++ (show n) ++ "; " + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) + +--An extremely simple renderer for terminals. +prRender :: String +prRender = unlines + [ + "//You may wish to change render", + "void PrintAbsyn::render(Char c)", + "{", + " if (c == '{')", + " {", + " bufAppend('\\n');", + " indent();", + " bufAppend(c);", + " _n_ = _n_ + 2;", + " bufAppend('\\n');", + " indent();", + " }", + " else if (c == '(' || c == '[')", + " bufAppend(c);", + " else if (c == ')' || c == ']')", + " {", + " backup();", + " bufAppend(c);", + " bufAppend(' ');", + " }", + " else if (c == '}')", + " {", + " _n_ = _n_ - 2;", + " backup();", + " backup();", + " bufAppend(c);", + " bufAppend('\\n\');", + " indent();", + " }", + " else if (c == ',')", + " {", + " backup();", + " bufAppend(c);", + " bufAppend(' ');", + " }", + " else if (c == ';')", + " {", + " backup();", + " bufAppend(c);", + " bufAppend('\\n');", + " indent();", + " }", + " else if (c == 0) return;", + " else", + " {", + " bufAppend(c);", + " bufAppend(' ');", + " }", + "}", + "void PrintAbsyn::render(String s_)", + "{", + " const char *s = s_.c_str() ;", + " if(strlen(s) > 0)", + " {", + " bufAppend(s);", + " bufAppend(' ');", + " }", + "}", + "void PrintAbsyn::indent()", + "{", + " int n = _n_;", + " while (n > 0)", + " {", + " bufAppend(' ');", + " n--;", + " }", + "}", + "void PrintAbsyn::backup()", + "{", + " if (buf_[cur_ - 1] == ' ')", + " {", + " buf_[cur_ - 1] = 0;", + " cur_--;", + " }", + "}" + ] diff --git a/src/formats/cpp_stl/STLTop.hs b/src/formats/cpp_stl/STLTop.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp_stl/STLTop.hs @@ -0,0 +1,196 @@ +{- + BNF Converter: C++ Main file + Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer + + Modified from CPPTop to STLTop 2006 by Aarne Ranta. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module STLTop (makeSTL) where + +import Utils +import CF +import CFtoSTLAbs +import CFtoFlex +import CFtoBisonSTL +import CFtoCVisitSkelSTL +import CFtoSTLPrinter +import CFtoLatex +import System.Exit (exitFailure) +import Data.Char +import STLUtils +import qualified Common.Makefile as Makefile + +makeSTL :: Bool -> Bool -> Maybe String -> String -> CF -> IO () +makeSTL make linenumbers inPackage name cf = do + let (hfile, cfile) = cf2CPPAbs linenumbers inPackage name cf + writeFileRep "Absyn.H" hfile + writeFileRep "Absyn.C" cfile + let (flex, env) = cf2flex inPackage name cf + writeFileRep (name ++ ".l") flex + putStrLn " (Tested with flex 2.5.31)" + let bison = cf2Bison linenumbers inPackage name cf env + writeFileRep (name ++ ".y") bison + putStrLn " (Tested with bison 1.875a)" + let header = mkHeaderFile inPackage cf (allCats cf) (allEntryPoints cf) env + writeFileRep "Parser.H" header + let (skelH, skelC) = cf2CVisitSkel inPackage cf + writeFileRep "Skeleton.H" skelH + writeFileRep "Skeleton.C" skelC + let (prinH, prinC) = cf2CPPPrinter inPackage cf + writeFileRep "Printer.H" prinH + writeFileRep "Printer.C" prinC + writeFileRep "Test.C" (cpptest inPackage cf) + let latex = cfToLatex name cf + writeFileRep (name ++ ".tex") latex + if make then (writeFileRep "Makefile" $ makefile name) else return () + +makefile :: String -> String +makefile name = + (unlines [ "CC = g++", "CCFLAGS = -g", "FLEX = flex", "BISON = bison" ] ++) + $ Makefile.mkRule "all" [ "Test" ++ name ] + [] + $ Makefile.mkRule "clean" [] + -- peteg: don't nuke what we generated - move that to the "vclean" target. + [ "rm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " + , "rm -f " ++ name ++ ".pdf Test" ++ name ] + $ Makefile.mkRule "distclean" [] + [ " rm -f *.o Absyn.C Absyn.H Test.C Parser.C Parser.H Lexer.C Skeleton.C Skeleton.H Printer.C Printer.H " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps Test" ++ name ++ " Makefile" ] + $ Makefile.mkRule ("Test" ++ name) [ "Absyn.o", "Lexer.o", + "Parser.o", "Printer.o", "Test.o" ] + [ "@echo \"Linking Test" ++ name ++ "...\"" + , "${CC} ${CCFLAGS} *.o -o Test" ++ name ] + $ Makefile.mkRule "Absyn.o" [ "Absyn.C", "Absyn.H" ] + [ "${CC} ${CCFLAGS} -c Absyn.C" ] + $ Makefile.mkRule "Lexer.C" [ name ++ ".l" ] + [ "${FLEX} -oLexer.C " ++ name ++ ".l" ] + $ Makefile.mkRule "Parser.C" [ name ++ ".y" ] + [ "${BISON} " ++ name ++ ".y -o Parser.C" ] + $ Makefile.mkRule "Lexer.o" [ "Lexer.C", "Parser.H" ] + [ "${CC} ${CCFLAGS} -c Lexer.C" ] + $ Makefile.mkRule "Parser.o" [ "Parser.C", "Absyn.H" ] + [ "${CC} ${CCFLAGS} -c Parser.C" ] + $ Makefile.mkRule "Printer.o" [ "Printer.C", "Printer.H", "Absyn.H" ] + [ "${CC} ${CCFLAGS} -c Printer.C" ] + $ Makefile.mkRule "Skeleton.o" [ "Skeleton.C", "Skeleton.H", "Absyn.H" ] + [ "${CC} ${CCFLAGS} -c Skeleton.C" ] + $ Makefile.mkRule "Test.o" [ "Test.C", "Parser.H", "Printer.H", "Absyn.H" ] + [ "${CC} ${CCFLAGS} -c Test.C" ] + $ Makefile.mkDoc name + "" + +cpptest :: Maybe String -> CF -> String +cpptest inPackage cf = + unlines + [ + "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", + "/* */", + "/* This test will parse a file, print the abstract syntax tree, and then */", + "/* pretty-print the result. */", + "/* */", + "/****************************************************************************/", + "#include ", + "#include \"Parser.H\"", + "#include \"Printer.H\"", + "#include \"Absyn.H\"", + "", + "int main(int argc, char ** argv)", + "{", + " FILE *input;", + " if (argc > 1) ", + " {", + " input = fopen(argv[1], \"r\");", + " if (!input)", + " {", + " fprintf(stderr, \"Error opening input file.\\n\");", + " exit(1);", + " }", + " }", + " else input = stdin;", + " /* The default entry point is used. For other options see Parser.H */", + " " ++ scope ++ def ++ " *parse_tree = " ++ scope ++ "p" ++ def ++ "(input);", + " if (parse_tree)", + " {", + " printf(\"\\nParse Succesful!\\n\");", + " printf(\"\\n[Abstract Syntax]\\n\");", + " " ++ scope ++ "ShowAbsyn *s = new " ++ scope ++ "ShowAbsyn();", + " printf(\"%s\\n\\n\", s->show(parse_tree));", + " printf(\"[Linearized Tree]\\n\");", + " " ++ scope ++ "PrintAbsyn *p = new " ++ scope ++ "PrintAbsyn();", + " printf(\"%s\\n\\n\", p->print(parse_tree));", + " return 0;", + " }", + " return 1;", + "}", + "" + ] + where + def = head (allEntryPoints cf) + scope = nsScope inPackage + +mkHeaderFile inPackage cf cats eps env = unlines + [ + "#ifndef " ++ hdef, + "#define " ++ hdef, + "", + "#include", + "#include", + "", + nsStart inPackage, + concatMap mkForwardDec cats, + "typedef union", + "{", + " int int_;", + " char char_;", + " double double_;", + " char* string_;", + (concatMap mkVar cats) ++ "} YYSTYPE;", + "", + concatMap mkFuncs eps, + nsEnd inPackage, + "", + "#define " ++ nsDefine inPackage "_ERROR_" ++ " 258", + mkDefines (259 :: Int) env, + "extern " ++ nsScope inPackage ++ "YYSTYPE " ++ nsString inPackage ++ "yylval;", + "", + "#endif" + ] + where + hdef = nsDefine inPackage "PARSER_HEADER_FILE" + mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n" + mkForwardDec _ = "" + mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n" + mkVar _ = "" + mkDefines n [] = mkString n + mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) -- "nsDefine inPackage s" not needed (see cf2flex::makeSymEnv) + mkString n = if isUsedCat cf "String" + then ("#define " ++ nsDefine inPackage "_STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) + else mkChar n + mkChar n = if isUsedCat cf "Char" + then ("#define " ++ nsDefine inPackage "_CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1) + else mkInteger n + mkInteger n = if isUsedCat cf "Integer" + then ("#define " ++ nsDefine inPackage "_INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1) + else mkDouble n + mkDouble n = if isUsedCat cf "Double" + then ("#define " ++ nsDefine inPackage "_DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1) + else mkIdent n + mkIdent n = if isUsedCat cf "Ident" + then ("#define " ++ nsDefine inPackage "_IDENT_ " ++ show n ++ "\n") + else "" + mkFuncs s | (normCat s == s) = (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(FILE *inp);\n" ++ + (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(const char *str);\n" + mkFuncs _ = "" diff --git a/src/formats/cpp_stl/STLUtils.hs b/src/formats/cpp_stl/STLUtils.hs new file mode 100644 --- /dev/null +++ b/src/formats/cpp_stl/STLUtils.hs @@ -0,0 +1,37 @@ +{- + BNF Converter: C++ common functions + Copyright (C) 2008 Author: Martin Ejdestig + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module STLUtils where + +import Data.Char + +nsDefine :: Maybe String -> String -> String +nsDefine inPackage h = maybe h (\ns -> map toUpper ns ++ "_" ++ h) inPackage + +nsStart :: Maybe String -> String +nsStart inPackage = maybe "" (\ns -> "namespace " ++ ns ++ "\n{") inPackage + +nsEnd :: Maybe String -> String +nsEnd inPackage = maybe "" (\ns -> "}") inPackage + +nsScope :: Maybe String -> String +nsScope inPackage = maybe "" (\ns -> ns ++ "::") inPackage + +nsString :: Maybe String -> String +nsString inPackage = maybe "" id inPackage diff --git a/src/formats/f-sharp/FSharpTop.hs b/src/formats/f-sharp/FSharpTop.hs new file mode 100644 --- /dev/null +++ b/src/formats/f-sharp/FSharpTop.hs @@ -0,0 +1,188 @@ +{- + BNF Converter: F# main file + Copyright (C) 2005 Author: Kristofer Johannisson + Copyright (C) 2007 Author: Bjorn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- based on BNFC O'Caml backend + + +module FSharpTop (makeFSharp) where + +import CF +import CFtoOCamlYacc +import CFtoOCamlLex +import CFtoLatex +import CFtoOCamlAbs +import CFtoOCamlTemplate +import CFtoOCamlPrinter +import CFtoOCamlShow +import CFtoOCamlTest +import CFtoXML +import Utils +import Options + +import Data.Char +import Data.Maybe (fromMaybe,maybe) +import System.Exit (exitFailure) +import Control.Monad(when) + +-- naming conventions + +noLang :: Options -> String -> String +noLang _ name = name + +withLang :: Options -> String -> String +withLang opts name = name ++ lang opts + +mkMod :: (Options -> String -> String) -> String -> Options -> String +mkMod addLang name opts = + pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name + where pref = maybe "" (++".") (inPackage opts) + +mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath +mkFile addLang name ext opts = + pref ++ if inDir opts + then lang opts ++ [pathSep] ++ name ++ ext' + else addLang opts name ++ if null ext then "" else ext' + where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts) + ext' = if null ext then "" else "." ++ ext + +absFile, absFileM, ocamllexFile, ocamllexFileM, dviFile, + ocamlyaccFile, ocamlyaccFileM, + latexFile, utilFile, utilFileM, + templateFile, templateFileM, + printerFile, printerFileM, + psFile, tFile, tFileM :: Options -> String +absFile = mkFile withLang "Abs" "ml" +absFileM = mkMod withLang "Abs" +ocamllexFile = mkFile withLang "Lex" "mll" +ocamllexFileM = mkMod withLang "Lex" +ocamlyaccFile = mkFile withLang "Par" "mly" +ocamlyaccFileM = mkMod withLang "Par" +latexFile = mkFile withLang "Doc" "tex" +templateFile = mkFile withLang "Skel" "ml" +templateFileM = mkMod withLang "Skel" +printerFile = mkFile withLang "Print" "ml" +printerFileM = mkMod withLang "Print" +showFile = mkFile withLang "Show" "ml" +showFileM = mkMod withLang "Show" +dviFile = mkFile withLang "Doc" "dvi" +psFile = mkFile withLang "Doc" "ps" +tFile = mkFile withLang "Test" "ml" +tFileM = mkMod withLang "Test" +utilFile = mkFile noLang "BNFC_Util" "ml" +utilFileM = mkMod noLang "BNFC_Util" +xmlFileM = mkMod withLang "XML" + +type Options = SharedOptions + +makeFSharp :: Options -> CF -> IO () +makeFSharp opts cf = do + let absMod = absFileM opts + lexMod = ocamllexFileM opts + parMod = ocamlyaccFileM opts + prMod = printerFileM opts + showMod = showFileM opts +-- layMod = layoutFileM opts + utilMod = utilFileM opts + do + let dir = codeDir opts + when (not (null dir)) $ do + putStrLn $ "Creating directory " ++ dir + prepareDir dir + writeFileRep (absFile opts) $ cf2Abstract absMod cf + writeFileRep (ocamllexFile opts) $ cf2ocamllex lexMod parMod cf + writeFileRep (ocamlyaccFile opts) $ + cf2ocamlyacc parMod absMod lexMod cf + writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf + writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod cf + writeFileRep (printerFile opts) $ cf2Printer prMod absMod cf + writeFileRep (showFile opts) $ cf2show showMod absMod cf + writeFileRep (tFile opts) $ ocamlTestfile absMod lexMod parMod prMod showMod cf + writeFileRep (utilFile opts) $ utilM + when (make opts) $ writeFileRep "Makefile" $ makefile opts + case xml opts of + 2 -> makeXML (lang opts) True cf + 1 -> makeXML (lang opts) False cf + _ -> return () + +pkgToDir :: String -> FilePath +pkgToDir s = replace '.' pathSep s + +codeDir :: Options -> FilePath +codeDir opts = let pref = maybe "" pkgToDir (inPackage opts) + dir = if inDir opts then lang opts else "" + sep = if null pref || null dir then "" else [pathSep] + in pref ++ sep ++ dir + +makefile :: Options -> String +makefile opts = makeA where + dir = let d = codeDir opts in if null d then "" else d ++ [pathSep] + cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")" + makeA = unlines + [ + "all:", + "\tfsyacc " ++ ocamlyaccFile opts, + "\tfslex " ++ ocamllexFile opts, + "\t" ++ cd ("latex " ++ basename (latexFile opts) + ++ "; " ++ "dvips " ++ basename (dviFile opts) + ++ " -o " ++ basename (psFile opts)), + "\tfsc -o " ++ mkFile withLang "Test" "exe" opts +++ + utilFile opts +++ + absFile opts +++ templateFile opts +++ + showFile opts +++ printerFile opts +++ + mkFile withLang "Par" "mli" opts +++ + mkFile withLang "Par" "ml" opts +++ + mkFile withLang "Lex" "fs" opts +++ + tFile opts, + "", + "clean:", + "\t-rm -f " ++ unwords (map (dir++) [ + "*.log", "*.aux", "*.cmi", + "*.cmo", "*.o", "*.dvi" + ]), + "\t-rm -f " ++ psFile opts, + "", + "distclean: clean", + "\t-rm -f " ++ unwords [ + mkFile withLang "Doc" "*" opts, + mkFile withLang "Lex" "*" opts, + mkFile withLang "Par" "*" opts, + mkFile withLang "Layout" "*" opts, + mkFile withLang "Skel" "*" opts, + mkFile withLang "Print" "*" opts, + mkFile withLang "Show" "*" opts, + mkFile withLang "Test" "*" opts, + mkFile withLang "Abs" "*" opts, + mkFile withLang "Test" "" opts, + utilFile opts, + "Makefile*" + ] + ] + + +utilM :: String +utilM = unlines + ["(* automatically generated by BNFC *)", + "", + "open Lexing", + "", + "(* this should really be in the parser, but ocamlyacc won't put it in the .mli *)", + "exception Parse_error of Lexing.position * Lexing.position" + ] + diff --git a/src/formats/haskell-gadt/CFtoAbstractGADT.hs b/src/formats/haskell-gadt/CFtoAbstractGADT.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell-gadt/CFtoAbstractGADT.hs @@ -0,0 +1,147 @@ +{- + BNF Converter: GADT Abstract syntax Generator + Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoAbstractGADT (cf2Abstract) where + +import CF +import Utils((+++),(++++)) +import Data.List(intersperse,nub) + +import HaskellGADTCommon + +import Data.Maybe (catMaybes) + +-- to produce a Haskell module +cf2Abstract :: Bool -> String -> CF -> String -> String +cf2Abstract byteStrings name cf composOpMod = unlines $ [ + "{-# OPTIONS_GHC -fglasgow-exts #-}", + "module" +++ name +++ "(" ++ concat (intersperse ", " exports) ++ ")" +++ "where", + "", + "import " ++ composOpMod, + "", + "import Data.Monoid", + (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""), + "", + "-- Haskell module generated by the BNF converter", + ""] + ++ prDummyTypes cf + ++ [""] + ++ prTreeType byteStrings cf + ++ [""] + ++ prCompos cf + ++ [""] + ++ prShow cf + ++ [""] + ++ prEq cf + ++ [""] + ++ prOrd cf + where exports = ["Tree(..)"] + ++ getTreeCats cf + ++ ["johnMajorEq"] + ++ ["module " ++ composOpMod] + +getTreeCats :: CF -> [String] +getTreeCats cf = nub $ filter (not . isList) $ map consCat $ cf2cons cf + +prDummyTypes :: CF -> [String] +prDummyTypes cf = concatMap prDummyType $ getTreeCats cf + where + prDummyType cat = ["data" +++ t, "type" +++ cat +++ "= Tree" +++ t ] + where t = mkRealType cat + +mkRealType :: Cat -> String +mkRealType cat = cat ++ "_" -- FIXME: make sure that there is no such category already + +prTreeType :: Bool -> CF -> [String] +prTreeType byteStrings cf = ["data Tree :: * -> * where"] ++ map ((" "++) . prTreeCons) (cf2cons cf) + where + prTreeCons c + | isPositionCat cf cat = fun +++ ":: ((Int,Int),"++stringType++") -> Tree" +++ mkRealType cat + | otherwise = fun +++ "::" +++ concat [c +++ "-> " | (c,_) <- consVars c] ++ "Tree" +++ mkRealType cat + where (cat,fun) = (consCat c, consFun c) + stringType + | byteStrings = "BS.ByteString" + | otherwise = "String" + +prCompos :: CF -> [String] +prCompos cf = + ["instance Compos Tree where", + " compos r a f t = case t of"] + ++ map (" "++) (concatMap prComposCons cs + ++ if not (all isRecursive cs) then ["_ -> r t"] else []) + where + cs = cf2cons cf + prComposCons c + | isRecursive c = [consFun c +++ unwords (map snd (consVars c)) +++ "->" +++ rhs c] + | otherwise = [] + isRecursive c = any (isTreeType cf) (map fst (consVars c)) + rhs c = "r" +++ consFun c +++ unwords (map prRec (consVars c)) + where prRec (cat,var) | not (isTreeType cf cat) = "`a`" +++ "r" +++ var + | isList cat = "`a` foldr (a . a (r (:)) . f) (r [])" +++ var + | otherwise = "`a`" +++ "f" +++ var + +prShow :: CF -> [String] +prShow cf = ["instance Show (Tree c) where", + " showsPrec n t = case t of"] + ++ map (" "++) (map prShowCons cs) + ++ [" where opar n = if n > 0 then showChar '(' else id", + " cpar n = if n > 0 then showChar ')' else id"] + where + cs = cf2cons cf + prShowCons c | null vars = fun +++ "->" +++ "showString" +++ show fun + | otherwise = fun +++ unwords (map snd vars) +++ "->" + +++ "opar n . showString" +++ show fun + +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | (_,x) <- vars] + +++ ". cpar n" + where (fun, vars) = (consFun c, consVars c) + +prEq :: CF -> [String] +prEq cf = ["instance Eq (Tree c) where (==) = johnMajorEq", + "", + "johnMajorEq :: Tree a -> Tree b -> Bool"] + ++ map (prEqCons) (cf2cons cf) + ++ ["johnMajorEq _ _ = False"] + where prEqCons c + | null vars = "johnMajorEq" +++ fun +++ fun +++ "=" +++ "True" + | otherwise = "johnMajorEq" +++ "(" ++ fun +++ unwords vars ++ ")" + +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "=" + +++ (concat $ intersperse " && " $ zipWith (\x y -> x +++ "==" +++ y) vars vars') + where (fun, vars) = (consFun c, map snd (consVars c)) + vars' = map (++"_") vars + +prOrd :: CF -> [String] +prOrd cf = ["instance Ord (Tree c) where", + " compare x y = compare (index x) (index y) `mappend` compareSame x y"] ++ + ["index :: Tree c -> Int"] ++ + zipWith (\ c i -> mkIndex c i) cs [0..] ++ + ["compareSame :: Tree c -> Tree c -> Ordering"] ++ + map mkCompareSame cs ++ + ["compareSame x y = error \"BNFC error:\" compareSame"] + where cs = cf2cons cf + mkCompareSame c + | null vars = "compareSame" +++ fun +++ fun +++ "=" +++ "EQ" + | otherwise = "compareSame" +++ "(" ++ fun +++ unwords vars ++ ")" + +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "=" + +++ foldr1 (\x y -> "mappend (" ++ x ++") ("++y++")") cc + where (fun, vars) = (consFun c, map snd (consVars c)) + vars' = map (++"_") vars + cc = zipWith (\x y -> "compare"+++x+++y) vars vars' + mkIndex c i = "index" +++ "(" ++ consFun c + +++ unwords (replicate (length (consVars c)) "_") ++ ")" + +++ "=" +++ show i diff --git a/src/formats/haskell-gadt/CFtoPrinterGADT.hs b/src/formats/haskell-gadt/CFtoPrinterGADT.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell-gadt/CFtoPrinterGADT.hs @@ -0,0 +1,167 @@ +{- + BNF Converter: GADT Pretty-printer generator + Copyright (C) 2004-2005 Author: Aarne Ranta, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoPrinterGADT (cf2Printer) where + +import CF +import Utils +import CFtoTemplate +import Data.List (intersperse) +import Data.Char(toLower) + +import HaskellGADTCommon + +-- derive pretty-printer from a BNF grammar. AR 15/2/2002 +cf2Printer :: String -> String -> CF -> String +cf2Printer name absMod cf = unlines $ [ + prologue name absMod, + integerRule cf, + doubleRule cf] + ++ prPrt cf + ++ [""] + ++ concatMap (prPrtList cf) (filter isList (allCats cf)) + +prologue :: String -> String -> String +prologue name absMod = unlines [ + "{-# OPTIONS_GHC -fglasgow-exts #-}", + "module " ++ name +++ "where\n", + "-- pretty-printer generated by the BNF converter\n", + "import " ++ absMod, + "import Data.Char", + "import Data.List (intersperse)", + "", + "-- 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", + "", + "unwordsD :: [Doc] -> Doc", + "unwordsD = concatD . intersperse (doc (showChar ' '))", + "", + "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", + "", + "instance Print Char where", + " prt _ s = doc (showChar '\\'' . mkEsc '\\'' s . showChar '\\'')", + "", + "instance Print String where", + " prt _ 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 Cat -> [String] +ifList cf cat = prPrtList cf ("["++cat++"]") -- FIXME: hackish + +prPrt :: CF -> [String] +prPrt cf = ["instance Print (Tree c) where", + " prt _i e = case e of" + ] ++ map prPrtCons (cf2cons cf) + where + prPrtCons c = " " ++ consFun c +++ unwords (vars c) +++ "->" +++ + "prPrec _i" +++ show (consPrec c) +++ rhs + -- for token rules, just print the string argument unquoted + where rhs | isToken c = let [v] = vars c in "(doc (showString " ++ v ++ "))" + | otherwise = mkRhs (vars c) (consRhs c) + vars = map snd . consVars + isToken c = consCat c `elem` specialCats cf + +prPrtList :: CF -> Cat -> [String] +prPrtList cf cat = mkListRule (nil ++ one ++ cons) + where + nil = [" [] -> " ++ mkRhs [] its | + Rule f _ its <- rules, isNilFun f] + one = [" [x] -> " ++ mkRhs ["x"] its | + Rule f _ its <- rules, isOneFun f] + cons = [" x:xs -> " ++ mkRhs ["x","xs"] its | + Rule f _ its <- rules, isConsFun f] + mkListRule [] = [] + mkListRule rs = ["instance Print" +++ cat +++ "where", + " prt _" +++ "es = case es of"] ++ rs + rules = rulesForCat cf cat + +mkRhs :: [String] -> [Either Cat String] -> String +mkRhs args its = + "(concatD [" ++ unwords (intersperse "," (mk args its)) ++ "])" + where + mk args (Left "#" : items) = mk args items + mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items + mk args (Right s : items) = ("doc (showString" +++ show s ++ ")") : mk args items + mk _ _ = [] + prt c = "prt" +++ show (precCat c) + diff --git a/src/formats/haskell-gadt/CFtoTemplateGADT.hs b/src/formats/haskell-gadt/CFtoTemplateGADT.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell-gadt/CFtoTemplateGADT.hs @@ -0,0 +1,65 @@ +{- + BNF Converter: GADT Template Generator + Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +module CFtoTemplateGADT ( + cf2Template + ) where + +import CF +import Utils((+++)) +import Data.List (delete,groupBy) + +import HaskellGADTCommon + +type ModuleName = String + +cf2Template :: ModuleName -> ModuleName -> ModuleName -> CF -> String +cf2Template skelName absName errName cf = unlines $ + [ + "module "++ skelName ++ " where", + "", + "-- Haskell module generated by the BNF converter", + "", + "import " ++ absName, + "import " ++ errName, + "type Result = Err String\n", + "failure :: Show a => a -> Result", + "failure x = Bad $ \"Undefined case: \" ++ show x", + "", + "transTree :: Tree c -> Result", + "transTree t = case t of"] + ++ map prConsCase (cf2cons cf) + ++ [""] + ++ concatMap ((++[""]) . uncurry prCatTrans) (catCons cf) + +prConsCase :: Constructor -> String +prConsCase c = + " " ++ consFun c +++ unwords (map snd (consVars c)) +++ "-> failure t" + +catCons :: CF -> [(Cat,[Constructor])] +catCons cf = [ (consCat (head cs),cs) | cs <- groupBy catEq $ cf2cons cf] + +catEq :: Constructor -> Constructor -> Bool +catEq c1 c2 = consCat c1 == consCat c2 + +prCatTrans :: Cat -> [Constructor] -> [String] +prCatTrans cat cs = ["trans" ++ cat +++ "::" +++ cat +++ "-> Result", + "trans" ++ cat +++ "t = case t of"] + ++ map prConsCase cs diff --git a/src/formats/haskell-gadt/HaskellGADTCommon.hs b/src/formats/haskell-gadt/HaskellGADTCommon.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell-gadt/HaskellGADTCommon.hs @@ -0,0 +1,83 @@ +{- + BNF Converter: Haskell GADT back-end common stuff + Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module HaskellGADTCommon (Constructor(..), cf2cons, isTreeType) where + +import CF + +import Data.Char + +data Constructor = Constructor { + consCat :: Cat, + consFun :: Fun, + consPrec :: Int, + consVars :: [(Cat,String)], + consRhs :: [Either Cat String] + } + +-- | Get category, function, and rhs categories paired with variable names. +cf2cons :: CF -> [Constructor] +cf2cons cf = [ Constructor { consCat = cat, + consFun = fun, + consPrec = precFun cf fun, + consVars = zip cats (mkVars cats), + consRhs = rhsFun cf fun} + | (cat,rules) <- cf2data cf, (fun,cats) <- rules] + ++ [ Constructor { consCat = cat, + consFun = cat, + consPrec = 0, + consVars = [("String","str")], + consRhs = [Left "String"]} + | cat <- specialCats cf] + where mkVars cats = mkUnique (map catToVar cats) (0 :: Int) + mkUnique [] _ = [] + mkUnique (x:xs) n | elem x xs || n > 0 = (x ++ show n) : mkUnique xs (n+1) + | otherwise = x : mkUnique xs n + +-- | Make a variable name for a category. +catToVar :: Cat -> String +catToVar = checkRes . var + where var cat | isList cat = var (normCatOfList cat) ++ "s" + var "Ident" = "i" + var "Integer" = "n" + var "String" = "str" + var "Char" = "c" + var "Double" = "d" + var xs = map toLower xs + checkRes s | elem s reservedHaskell = s ++ "'" + | otherwise = s + reservedHaskell = ["case","class","data","default","deriving","do","else","if", + "import","in","infix","infixl","infixr","instance","let","module", + "newtype","of","then","type","where","as","qualified","hiding"] + +-- | Get the rule for a function. +ruleFun :: CF -> Fun -> Rule +ruleFun cf f = head $ filter (\r -> funRule r == f) $ rulesOfCF cf + +-- | Get the precedence of a function. +precFun :: CF -> Fun -> Int +precFun cf f = precRule $ ruleFun cf f + +-- | Get the RHS of a function +rhsFun :: CF -> Fun -> [Either Cat String] +rhsFun cf f = rhsRule $ ruleFun cf f + +isTreeType :: CF -> Cat -> Bool +isTreeType cf c | isList c = isTreeType cf (catOfList c) + | otherwise = c `elem` (allCats cf ++ specialCats cf) diff --git a/src/formats/haskell-gadt/HaskellTopGADT.hs b/src/formats/haskell-gadt/HaskellTopGADT.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell-gadt/HaskellTopGADT.hs @@ -0,0 +1,306 @@ +{- + BNF Converter: Haskell main file + Copyright (C) 2004-2005 Author: Markus Forberg, Peter Gammie, + Aarne Ranta, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module HaskellTopGADT (makeAllGADT) where + + + +-- import Utils +import Options +import HsOpts +import CF +import CFtoHappy +import CFtoAlex +import CFtoAlex2 +import CFtoAlex3 +import CFtoLatex +import HaskellTop(AlexMode(..)) +import CFtoAbstractGADT +import CFtoTemplateGADT +import CFtoPrinterGADT +import CFtoLayout +import CFtoXML +import MkErrM +import MkSharedString +import Utils +import qualified Common.Makefile as Makefile +import qualified HaskellTop as Haskell + +import Data.Char +import Data.Maybe (fromMaybe,maybe) +import System.Exit (exitFailure) +import Control.Monad(when) + + +makeAllGADT :: Options -> CF -> IO () +makeAllGADT opts cf = do + let absMod = absFileM opts + composOpMod = composOpFileM opts + lexMod = alexFileM opts + parMod = happyFileM opts + prMod = printerFileM opts + layMod = layoutFileM opts + errMod = errFileM opts + shareMod = shareFileM opts + do + let dir = codeDir opts + when (not (null dir)) $ do + putStrLn $ "Creating directory " ++ dir + prepareDir dir + writeFileRep (absFile opts) $ cf2Abstract (byteStrings opts) absMod cf composOpMod + writeFileRep (composOpFile opts) $ composOp composOpMod + case alexMode opts of + Alex1 -> do + writeFileRep (alexFile opts) $ cf2alex lexMod errMod cf + putStrLn " (Use Alex 1.1 to compile.)" + Alex2 -> do + writeFileRep (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf + putStrLn " (Use Alex 2.0 to compile.)" + Alex3 -> do + writeFileRep (alexFile opts) $ cf2alex3 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf + putStrLn " (Use Alex 3.0 to compile.)" + writeFileRep (happyFile opts) $ + cf2HappyS parMod absMod lexMod errMod (glr opts) (byteStrings opts) cf + putStrLn " (Tested with Happy 1.15)" + writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf + writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod cf + writeFileRep (printerFile opts) $ cf2Printer prMod absMod cf + when (hasLayout cf) $ writeFileRep (layoutFile opts) $ cf2Layout (alexMode opts == Alex1) (inDir opts) layMod lexMod cf + writeFileRep (tFile opts) $ testfile opts cf + writeFileRep (errFile opts) $ errM errMod cf + when (shareStrings opts) $ writeFileRep (shareFile opts) $ sharedString shareMod (byteStrings opts) cf + when (make opts) $ writeFileRep "Makefile" $ makefile opts + case xml opts of + 2 -> makeXML (lang opts) True cf + 1 -> makeXML (lang opts) False cf + _ -> return () + +codeDir :: Options -> FilePath +codeDir opts = let pref = maybe "" pkgToDir (inPackage opts) + dir = if inDir opts then lang opts else "" + sep = if null pref || null dir then "" else [pathSep] + in pref ++ sep ++ dir + +makefile :: Options -> String +makefile = Haskell.makefile +-- makefile opts = makeA where +-- glr_params = if glr opts == GLR then "--glr --decode " else "" +-- dir = let d = codeDir opts in if null d then "" else d ++ [pathSep] +-- cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")" +--- makeA = Makefile.mkRule "all" [] +-- [ "happy -gca " ++ glr_params ++ happyFile opts +--- , "alex -g " ++ alexFile opts +-- , "ghc --make " ++ tFile opts ++ " -o " ++ mkFile withLang "Test" "" opts] +-- $ Makefile.mkDoc (basename (latexFile opts)) +-- $ Makefile.mkRule "clean" [] +-- [ "-rm -f " ++ unwords +-- (map (dir++) [ "*.log", "*.aux", "*.hi", "*.o", "*.dvi" ]) +-- , "-rm -f " ++ psFile opts ] +-- $ Makefile.mkRule "distclean" ["clean"] +-- [ "-rm -f " ++ unwords +-- [ mkFile withLang "Doc" "*" opts +-- , mkFile withLang "Lex" "*" opts +-- , mkFile withLang "Par" "*" opts +-- , mkFile withLang "Layout" "*" opts +-- , mkFile withLang "Skel" "*" opts +-- , mkFile withLang "Print" "*" opts +-- , mkFile withLang "Test" "*" opts +-- , mkFile withLang "Abs" "*" opts +-- , mkFile withLang "Test" "" opts +-- , mkFile noLang "ErrM" "*" opts +-- , mkFile noLang "SharedString" "*" opts +-- , dir ++ lang opts ++ ".dtd" +-- , mkFile withLang "XML" "*" opts +-- , "Makefile*" +-- , mkFile withLang "ComposOp" "*" opts +-- , dir ++ lang opts ++ ".dtd" +-- , mkFile withLang "XML" "*" opts ] +-- , if null dir then "" else "\t-rmdir -p " ++ dir ] +-- "" + + +testfile :: Options -> CF -> String +testfile opts cf + = let lay = hasLayout cf + use_xml = xml opts > 0 + xpr = if use_xml then "XPrint a, " else "" + use_glr = glr opts == GLR + if_glr s = if use_glr then s else "" + firstParser = if use_glr then "the_parser" else parserName + parserName = 'p' : topType + topType = firstEntry cf + in unlines + ["-- automatically generated by BNF Converter", + "module Main where\n", + "", + "import System.IO ( stdin, hGetContents )", + "import System.Environment ( getArgs, getProgName )", + "", + "import " ++ alexFileM opts, + "import " ++ happyFileM opts, + "import " ++ templateFileM opts, + "import " ++ printerFileM opts, + "import " ++ absFileM opts, + if lay then ("import " ++ layoutFileM opts) else "", + if use_xml then ("import " ++ xmlFileM opts) else "", + if_glr "import Data.FiniteMap(FiniteMap, lookupFM, fmToList)", + if_glr "import Data.Maybe(fromJust)", + "import " ++ errFileM opts, + "", + if use_glr + then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))" + else "type ParseFun a = [Token] -> Err a", + "", + "myLLexer = " ++ if lay then "resolveLayout True . myLexer" + else "myLexer", + "", + "type Verbosity = Int", + "", + "putStrV :: Verbosity -> String -> IO ()", + "putStrV v s = if v > 1 then putStrLn s else return ()", + "", + "runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()", + "runFile v p f = putStrLn f >> readFile f >>= run v p", + "", + "run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()", + if use_glr then run_glr else run_std use_xml, + "", + "showTree :: (Show a, Print a) => Int -> a -> IO ()", + "showTree v tree", + " = do", + " putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree", + " putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree", + "", + "main :: IO ()", + "main = do args <- getArgs", + " case args of", + " [] -> hGetContents stdin >>= run 2 " ++ firstParser, + " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs", + " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs", + "", + if_glr $ "the_parser :: ParseFun " ++ topType, + if_glr $ "the_parser = lift_parser " ++ parserName, + if_glr $ "", + if_glr $ lift_parser + ] + +run_std xml + = unlines + [ "run v p s = let ts = myLLexer s in case p ts of" + , " Bad s -> do putStrLn \"\\nParse Failed...\\n\"" + , " putStrV v \"Tokens:\"" + , " putStrV v $ show ts" + , " putStrLn s" + , " Ok tree -> do putStrLn \"\\nParse Successful!\"" + , " showTree v tree" + , if xml then + " putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree" + else "" + ] + +run_glr + = unlines + [ "run v p s" + , " = let ts = map (:[]) $ myLLexer s" + , " (raw_output, simple_output) = p ts in" + , " case simple_output of" + , " GLR_Fail major minor -> do" + , " putStrLn major" + , " putStrV v minor" + , " GLR_Result df trees -> do" + , " putStrLn \"\\nParse Successful!\"" + , " case trees of" + , " [] -> error \"No results but parse succeeded?\"" + , " [Ok x] -> showTree v x" + , " xs@(_:_) -> showSeveralTrees v xs" + , " where" + , " showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()" + , " showSeveralTrees v trees" + , " = sequence_ " + , " [ do putStrV v (replicate 40 '-')" + , " putStrV v $ \"Parse number: \" ++ show n" + , " showTree v t" + , " | (Ok t,n) <- zip trees [1..]" + , " ]" + ] + + +lift_parser + = unlines + [ "type Forest = FiniteMap ForestId [Branch] -- omitted in ParX export." + , "data GLR_Output a" + , " = GLR_Result { pruned_decode :: (Forest -> Forest) -> [a]" + , " , semantic_result :: [a]" + , " }" + , " | GLR_Fail { main_message :: String" + , " , extra_info :: String" + , " }" + , "" + , "lift_parser" + , " :: (TreeDecode a, Show a, Print a)" + , " => ([[Token]] -> GLRResult) -> ParseFun a" + , "lift_parser parser ts" + , " = let result = parser ts in" + , " (\\o -> (result, o)) $" + , " case result of" + , " ParseError ts f -> GLR_Fail \"Parse failed, unexpected token(s)\\n\"" + , " (\"Tokens: \" ++ show ts)" + , " ParseEOF f -> GLR_Fail \"Parse failed, unexpected EOF\\n\"" + , " (\"Partial forest:\\n\"" + , " ++ unlines (map show $ fmToList f))" + , " ParseOK r f -> let find f = fromJust . lookupFM f" + , " dec_fn f = decode (find f) r" + , " in GLR_Result (\\ff -> dec_fn $ ff f) (dec_fn f)" + ] + +composOp :: String -> String +composOp composOpMod = unlines + [ + "{-# OPTIONS_GHC -fglasgow-exts #-}", + "module " ++ composOpMod ++ " (Compos(..),composOp,composOpM,composOpM_,composOpMonoid,", + " composOpMPlus,composOpFold) where", + "", + "import Control.Monad.Identity", + "import Data.Monoid", + "", + "class Compos t where", + " compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)", + " -> (forall a. t a -> m (t a)) -> t c -> m (t c)", + "", + "composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c", + "composOp f = runIdentity . composOpM (Identity . f)", + "", + "composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)", + "composOpM = compos return ap", + "", + "composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()", + "composOpM_ = composOpFold (return ()) (>>)", + "", + "composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m", + "composOpMonoid = composOpFold mempty mappend", + "", + "composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b", + "composOpMPlus = composOpFold mzero mplus", + "", + "composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b", + "composOpFold z c f = unC . compos (\\_ -> C z) (\\(C x) (C y) -> C (c x y)) (C . f)", + "", + "newtype C b a = C { unC :: b }" + ] diff --git a/src/formats/haskell2/CFtoAbstract.hs b/src/formats/haskell2/CFtoAbstract.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/CFtoAbstract.hs @@ -0,0 +1,51 @@ +{- + BNF Converter: Abstract syntax Generator + Copyright (C) 2004 Author: Markus Forberg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoAbstract (cf2Abstract) where + +import CF +import Utils((+++),(++++)) +import Data.List(intersperse) + +-- to produce a Haskell module +cf2Abstract :: Bool -> String -> CF -> String +cf2Abstract byteStrings name cf = unlines $ + ("module "++name +++ "where\n") : + "-- Haskell module generated by the BNF converter\n" : + (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "") : + (map (prSpecialData byteStrings cf) (specialCats cf) ++ map prData (cf2data cf)) + +prData :: Data -> String +prData (cat,rules) = + "data" +++ cat +++ "=\n " ++ + concat (intersperse "\n | " (map prRule rules)) ++++ + " deriving (Eq,Ord,Show)\n" + where + prRule (fun,cats) = unwords (fun:cats) + +prSpecialData :: Bool -> CF -> Cat -> String +prSpecialData byteStrings cf cat = + unwords ["newtype",cat,"=",cat,contentSpec byteStrings cf cat,"deriving (Eq,Ord,Show)"] + +contentSpec :: Bool -> CF -> Cat -> String +contentSpec byteStrings cf cat = if isPositionCat cf cat then "((Int,Int),"++stringType++")" else stringType + where + stringType + | byteStrings = "BS.ByteString" + | otherwise = "String" diff --git a/src/formats/haskell2/CFtoAlex.hs b/src/formats/haskell2/CFtoAlex.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/CFtoAlex.hs @@ -0,0 +1,230 @@ +{- + BNF Converter: Alex 1.1 Generator + Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +module CFtoAlex (cf2alex) where + +import CF +import RegToAlex +import Data.List + +cf2alex :: String -> String -> CF -> String +cf2alex name errMod cf = unlines $ concat $ intersperse [""] [ + prelude name errMod, + cMacros, + rMacros cf, + restOfAlex cf + ] + +prelude :: String -> String -> [String] +prelude name errMod = [ + "-- This Alex file was machine-generated by the BNF converter", + "%{", + "module " ++ name ++ " where", + "", + "import Alex", + "import " ++ errMod, + "%}" + ] +{- ---- +cf2alex :: String -> CF -> String +cf2alex name cf = unlines $ concat $ intersperse [""] [ + prelude name, + cMacros, + rMacros cf, + restOfAlex cf + ] + +prelude :: String -> [String] +prelude name = [ + "-- This Alex file was machine-generated by the BNF converter", + "%{", + "module Lex" ++ name ++ " where", + "", + "import Alex", + "import ErrM", + "%}" + ] +-} +cMacros :: [String] +cMacros = [ + "{ ^l = [a-zA-Z^192-^255] # [^215 ^247]} -- isolatin1 letter", + "{ ^c = [A-Z^192-^221] # [^215]} -- capital isolatin1 letter", + "{ ^s = [a-z^222-^255] # [^247]} -- small isolatin1 letter", + "{ ^d = [0-9] } -- digit", + "{ ^i = [^l^d^'^_] } -- identifier character", + "{ ^u = [^0-^255] } -- universal: any character" + ] + +rMacros :: CF -> [String] +rMacros cf = + let symbs = symbols cf + in + (if null symbs then [] else [ + "{ %s = -- reserved words consisting of special symbols", + " " ++ unwords (intersperse "|" (map mkEsc symbs)), + "}" + ]) + where + mkEsc = unwords . map ( f . (:[])) + f s = if all isSpec s then '^':s else s + isSpec = flip elem "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" + +restOfAlex :: CF -> [String] +restOfAlex cf = [ + "\"tokens_lx\"/\"tokens_acts\":-", + lexComments (comments cf), + "<> ::= ^w+", + pTSpec (symbols cf,[]), -- modif Markus 12/02 - 2002 + + userDefTokenTypes, + identAndRes, + + ifC "String" " ::= ^\" ([^u # [^\"^\\^n]] | (^\\ (^\" | ^\\ | ^' | n | t)))* ^\"" ++ + "%{ string p = PT p . TL . unescapeInitTail %}", + ifC "Char" " ::= ^\' (^u # [^\'^\\] | ^\\ [^\\ ^\' n t]) ^' %{ char p = PT p . TC %}", + ifC "Integer" " ::= ^d+ %{ int p = PT p . TI %}", + ifC "Double" + " ::= ^d+ ^. ^d+ (e (^-)? ^d+)? %{ double p = PT p . TD %}", + "", + "%{ ", + "", + "data Tok =", + " TS String -- reserved words", + " | TL String -- string literals", + " | TI String -- integer literals", + " | TV String -- identifiers", + " | TD String -- double precision float literals", + " | TC String -- character literals", + userDefTokenConstrs, + " deriving (Eq,Show)", + "", + "data Token = ", + " PT Posn Tok", + " | Err Posn", + " deriving Show", + "", + "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", + userDefTokenPrint, + " _ -> show t", + "", + "tokens:: String -> [Token]", + "tokens inp = scan tokens_scan inp", + "", + "tokens_scan:: Scan Token", + "tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx", + " where", + " stop_act p \"\" = []", + " stop_act p inp = [Err p]", + "", + "eitherResIdent :: (String -> Tok) -> String -> Tok", + "eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where", + " isResWord s = isInTree s $", + " " ++ (show $ sorted2tree $ sort resws), + "", + "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", + "", + "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", + " _ -> []", + "%}" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + lexComments ([],[]) = [] + lexComments (xs,s1:ys) = "<> ::= " ++ ('^':intersperse '^' s1) ++ " [.]* ^n\n" ++ lexComments (xs,ys) + lexComments (([l1,l2],[r1,r2]):xs,[]) = concat $ + [ + "<> ::= ", + ('^':l1:' ':'^':l2:" ([^u # ^"), + (l2:"] | ^"), + (r1:" [^u # ^"), + (r2:"])* (^"), + (r1:")+ ^"), + (r2:"\n"), + lexComments (xs,[]) + ] + lexComments ((_:xs),[]) = lexComments (xs,[]) +--- lexComments (xs,(_:ys)) = lexComments (xs,ys) + pTSpec ([],[]) = "" + pTSpec xp = + " ::= " ++ aux xp ++ "%{ pTSpec p = PT p . TS %}" + aux (xs,[]) = " %s " + aux ([],ys) = " %r " + aux (xs,ys) = " %s | %r " + resWs = + "[" ++ concat (intersperse "," [show s | s <- resws]) ++ "]" + --- show s can be strange for isolatin1 characters + --- precompile to search tree! + + userDefTokenTypes = unlines $ + [" ::= " ++ printRegAlex exp ++ + "%{ mk_" ++ name ++ " p = PT p . eitherResIdent T_" ++ name ++ " %}" + | (name,exp) <- tokenPragmas cf] + userDefTokenConstrs = unlines $ + [" | T_" ++ name ++ " String" | (name,_) <- tokenPragmas cf] + userDefTokenPrint = unlines $ + [" PT _ (T_" ++ name ++ " s) -> s" | (name,_) <- tokenPragmas cf] + + identAndRes = --This has to be there for Reserved Words. Michael + " ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" + --ifC "Ident" " ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" + + resws = reservedWords cf + +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 + +sorted2tree :: [String] -> BTree +sorted2tree [] = N +sorted2tree xs = B x (sorted2tree t1) (sorted2tree t2) where + (t1,(x:t2)) = splitAt (length xs `div` 2) xs diff --git a/src/formats/haskell2/CFtoAlex2.hs b/src/formats/haskell2/CFtoAlex2.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/CFtoAlex2.hs @@ -0,0 +1,338 @@ +{- + BNF Converter: Alex 2.0 Generator + Copyright (C) 2004 Author: Peter Gammie + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +------------------------------------------------------------------- +-- | +-- Module : CFtoAlex2 +-- Copyright : (C)opyright 2003, {aarne,markus,peteg} at cs dot chalmers dot se +-- License : GPL (see COPYING for details) +-- +-- Maintainer : {markus,aarne} at cs dot chalmers dot se +-- Stability : alpha +-- Portability : Haskell98 +-- +-- Hacked version of @CFtoAlex@ to cope with Alex2. +-- +------------------------------------------------------------------- +module CFtoAlex2 (cf2alex2) where + +import CF +import Data.List + +-- For RegToAlex, see below. +import AbsBNF +import Data.Char + +cf2alex2 :: String -> String -> String -> Bool -> Bool -> CF -> String +cf2alex2 name errMod shareMod shareStrings byteStrings cf = + unlines $ concat $ intersperse [""] [ + prelude name errMod shareMod shareStrings byteStrings, + cMacros, + rMacros cf, + restOfAlex shareMod shareStrings byteStrings cf + ] + +prelude :: String -> String -> String -> Bool -> Bool -> [String] +prelude name errMod shareMod shareStrings byteStrings = [ + "-- -*- haskell -*-", + "-- This Alex file was machine-generated by the BNF converter", + "{", + "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}", + "module " ++ name ++ " where", + "", + -- "import " ++ errMod, + if shareStrings then "import " ++ shareMod else "", + if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "", + "}", + "" + ] + +cMacros :: [String] +cMacros = [ + "$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" + ] + +rMacros :: CF -> [String] +rMacros cf = + let symbs = symbols cf + in + (if null symbs then [] else [ + "@rsyms = -- symbols and non-identifier-like reserved words", + " " ++ unwords (intersperse "|" (map mkEsc symbs)) + ]) + where + mkEsc = unwords . esc + esc s = if null a then rest else show a : rest + where (a,r) = span isAlphaNum s + rest = case r of + [] -> [] + (c:xs) -> s : esc xs + where s = if isPrint c then ['\\',c] + else '\\':show (ord c) + +restOfAlex :: String -> Bool -> Bool -> CF -> [String] +restOfAlex shareMod shareStrings byteStrings cf = [ + ":-", + lexComments (comments cf), + "$white+ ;", + pTSpec (symbols cf), + + userDefTokenTypes, + ident, + + ifC "String" ("\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t)))* \\\"" ++ + "{ tok (\\p s -> PT p (TL $ share $ unescapeInitTail s)) }"), + ifC "Char" "\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t]) \\' { tok (\\p s -> PT p (TC $ share s)) }", + ifC "Integer" "$d+ { tok (\\p s -> PT p (TI $ share s)) }", + ifC "Double" "$d+ \\. $d+ (e (\\-)? $d+)? { tok (\\p s -> PT p (TD $ share s)) }", + "", + "{", + "", + "tok f p s = f p s", + "", + "share :: "++stringType++" -> "++stringType, + "share = " ++ if shareStrings then "shareString" else "id", + "", + "data Tok =", + " TS !"++stringType++" !Int -- reserved words and symbols", + " | TL !"++stringType++" -- string literals", + " | TI !"++stringType++" -- integer literals", + " | TV !"++stringType++" -- identifiers", + " | TD !"++stringType++" -- double precision float literals", + " | TC !"++stringType++" -- character literals", + userDefTokenConstrs, + " 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", + userDefTokenPrint, + "", + "data BTree = N | B "++stringType++" Tok BTree BTree deriving (Show)", + "", + "eitherResIdent :: ("++stringType++" -> Tok) -> "++stringType++" -> 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 = " ++ (show $ sorted2tree $ zip (sort resws) [1..]), + " where b s n = let bs = "++stringPack++" s", + " in B bs (TS bs n)", + "", + "unescapeInitTail :: "++stringType++" -> "++stringType++"", + "unescapeInitTail = "++stringPack++" . unesc . tail . "++stringUnpack++" 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", + " "++stringType++") -- current input string", + "", + "tokens :: "++stringType++" -> [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 ("++stringTake++" len str) : (go inp')", + "", + "alexGetChar :: AlexInput -> Maybe (Char,AlexInput)", + "alexGetChar (p, _, s) =", + " case "++stringUncons++" s of", + " "++stringNilP++" -> Nothing", + " "++stringConsP++" ->", + " let p' = alexMove p c", + " in p' `seq` Just (c, (p', c, s))", + "", + "alexInputPrevChar :: AlexInput -> Char", + "alexInputPrevChar (p, c, s) = c", + "}" + ] + where + (stringType,stringTake,stringUncons,stringPack,stringUnpack,stringNilP,stringConsP) + | byteStrings = ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)") + | otherwise = ("String", "take", "", "id", "id", "[]", "(c:s)" ) + + ifC cat s = if isUsedCat cf cat then s else "" + lexComments ([],[]) = [] + lexComments (xs,s1:ys) = '\"' : s1 ++ "\"" ++ " [.]* ; -- Toss single line comments\n" ++ lexComments (xs, ys) + lexComments (([l1,l2],[r1,r2]):xs,[]) = concat $ + [ + ('\"':l1:l2:"\" ([$u # \\"), -- FIXME quotes or escape? + (l2:"] | \\"), + (r1:" [$u # \\"), + (r2:"])* (\""), + (r1:"\")+ \""), + (r2:"\" ; \n"), + lexComments (xs, []) + ] + lexComments ((_:xs),[]) = lexComments (xs,[]) +--- lexComments (xs,(_:ys)) = lexComments (xs,ys) + + -- tokens consisting of special symbols + pTSpec [] = "" + pTSpec _ = "@rsyms { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }" + + userDefTokenTypes = unlines $ + [printRegAlex exp ++ + " { tok (\\p s -> PT p (eitherResIdent (T_" ++ name ++ " . share) s)) }" + | (name,exp) <- tokenPragmas cf] + userDefTokenConstrs = unlines $ + [" | T_" ++ name ++ " !"++stringType | (name,_) <- tokenPragmas cf] + userDefTokenPrint = unlines $ + [" PT _ (T_" ++ name ++ " s) -> s" | (name,_) <- tokenPragmas cf] + + ident = + "$l $i* { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }" + --ifC "Ident" " ::= ^l ^i* { ident p = PT p . eitherResIdent TV }" + + resws = reservedWords cf ++ symbols cf + + +data BTree = N | B String Int BTree BTree + +instance Show BTree where + showsPrec _ N = showString "N" + showsPrec n (B s k l r) = wrap (showString "b " . shows s . showChar ' '. shows k . showChar ' ' + . showsPrec 1 l . showChar ' ' + . showsPrec 1 r) + where wrap f = if n > 0 then showChar '(' . f . showChar ')' else f + +sorted2tree :: [(String,Int)] -> BTree +sorted2tree [] = N +sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2) where + (t1,((x,n):t2)) = splitAt (length xs `div` 2) xs + + +------------------------------------------------------------------- +-- Inlined version of @RegToAlex@. +-- Syntax has changed... +------------------------------------------------------------------- + +-- modified from pretty-printer generated by the BNF converter + +-- the top-level printing method +printRegAlex :: Reg -> String +printRegAlex = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend 0 + where rend :: Int -> [String] -> String + rend i ss = case ss of + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + + cons s t = s ++ t + new i s = s + space t s = if null s then t else t ++ " " ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ c = if isAlphaNum c then [[c]] else ['\\':[c]] + prtList s = map (concat . prt 0) s + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["()"]) + RChar c -> prPrec i 3 (concat [prt 0 c]) + RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) + RDigit -> prPrec i 3 (concat [["$d"]]) + RLetter -> prPrec i 3 (concat [["$l"]]) + RUpper -> prPrec i 3 (concat [["$c"]]) + RLower -> prPrec i 3 (concat [["$s"]]) + RAny -> prPrec i 3 (concat [["$u"]]) diff --git a/src/formats/haskell2/CFtoAlex3.hs b/src/formats/haskell2/CFtoAlex3.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/CFtoAlex3.hs @@ -0,0 +1,357 @@ +{- + BNF Converter: Alex 3.0 Generator + Copyright (C) 2012 Author: Antti-Juhani Kaijanaho + Copyright (C) 2004 Author: Peter Gammie + (C)opyright 2003, {aarne,markus,peteg} at cs dot chalmers dot se + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoAlex3 (cf2alex3) where + +import CF +import Data.List + +-- For RegToAlex, see below. +import AbsBNF +import Data.Char + +cf2alex3 :: String -> String -> String -> Bool -> Bool -> CF -> String +cf2alex3 name errMod shareMod shareStrings byteStrings cf = + unlines $ concat $ intersperse [""] [ + prelude name errMod shareMod shareStrings byteStrings, + cMacros, + rMacros cf, + restOfAlex shareMod shareStrings byteStrings cf + ] + +prelude :: String -> String -> String -> Bool -> Bool -> [String] +prelude name errMod shareMod shareStrings byteStrings = [ + "-- -*- haskell -*-", + "-- This Alex file was machine-generated by the BNF converter", + "{", + "{-# OPTIONS -fno-warn-incomplete-patterns #-}", + "{-# OPTIONS_GHC -w #-}", + "module " ++ name ++ " where", + "", + -- "import " ++ errMod, + if shareStrings then "import " ++ shareMod else "", + if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "", + "import qualified Data.Bits", + "import Data.Word (Word8)", + "}", + "" + ] + +cMacros :: [String] +cMacros = [ + "$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" + ] + +rMacros :: CF -> [String] +rMacros cf = + let symbs = symbols cf + in + (if null symbs then [] else [ + "@rsyms = -- symbols and non-identifier-like reserved words", + " " ++ unwords (intersperse "|" (map mkEsc symbs)) + ]) + where + mkEsc = unwords . esc + esc s = if null a then rest else show a : rest + where (a,r) = span isAlphaNum s + rest = case r of + [] -> [] + (c:xs) -> s : esc xs + where s = if isPrint c then ['\\',c] + else '\\':show (ord c) + +restOfAlex :: String -> Bool -> Bool -> CF -> [String] +restOfAlex shareMod shareStrings byteStrings cf = [ + ":-", + lexComments (comments cf), + "$white+ ;", + pTSpec (symbols cf), + + userDefTokenTypes, + ident, + + ifC "String" ("\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t)))* \\\"" ++ + "{ tok (\\p s -> PT p (TL $ share $ unescapeInitTail s)) }"), + ifC "Char" "\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t]) \\' { tok (\\p s -> PT p (TC $ share s)) }", + ifC "Integer" "$d+ { tok (\\p s -> PT p (TI $ share s)) }", + ifC "Double" "$d+ \\. $d+ (e (\\-)? $d+)? { tok (\\p s -> PT p (TD $ share s)) }", + "", + "{", + "", + "tok f p s = f p s", + "", + "share :: "++stringType++" -> "++stringType, + "share = " ++ if shareStrings then "shareString" else "id", + "", + "data Tok =", + " TS !"++stringType++" !Int -- reserved words and symbols", + " | TL !"++stringType++" -- string literals", + " | TI !"++stringType++" -- integer literals", + " | TV !"++stringType++" -- identifiers", + " | TD !"++stringType++" -- double precision float literals", + " | TC !"++stringType++" -- character literals", + userDefTokenConstrs, + " 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\"", + "", + "tokenPosn (PT p _) = p", + "tokenPosn (Err p) = p", + "tokenLineCol = posLineCol . tokenPosn", + "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", + userDefTokenPrint, + "", + "data BTree = N | B "++stringType++" Tok BTree BTree deriving (Show)", + "", + "eitherResIdent :: ("++stringType++" -> Tok) -> "++stringType++" -> 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 = " ++ (show $ sorted2tree $ cfTokens $ cf), + " where b s n = let bs = "++stringPack++" s", + " in B bs (TS bs n)", + "", + "unescapeInitTail :: "++stringType++" -> "++stringType++"", + "unescapeInitTail = "++stringPack++" . unesc . tail . "++stringUnpack++" 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 Byte = Word8", + "", + "type AlexInput = (Posn, -- current position,", + " Char, -- previous char", + " [Byte], -- pending bytes on the current char", + " "++stringType++") -- current input string", + "", + "tokens :: "++stringType++" -> [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 ("++stringTake++" len str) : (go inp')", + "", + "alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)", + "alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))", + "alexGetByte (p, _, [], s) =", + " case "++stringUncons++" s of", + " "++stringNilP++" -> Nothing", + " "++stringConsP++" ->", + " let p' = alexMove p c", + " (b:bs) = utf8Encode c", + " in p' `seq` Just (b, (p', c, bs, s))", + "", + "alexInputPrevChar :: AlexInput -> Char", + "alexInputPrevChar (p, c, bs, s) = c", + "", + " -- | Encode a Haskell String to a list of Word8 values, in UTF8 format.", + "utf8Encode :: Char -> [Word8]", + "utf8Encode = map fromIntegral . go . ord", + " where", + " go oc", + " | oc <= 0x7f = [oc]", + "", + " | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6)", + " , 0x80 + oc Data.Bits..&. 0x3f", + " ]", + "", + " | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12)", + " , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)", + " , 0x80 + oc Data.Bits..&. 0x3f", + " ]", + " | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18)", + " , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)", + " , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)", + " , 0x80 + oc Data.Bits..&. 0x3f", + " ]", + "}" + ] + where + (stringType,stringTake,stringUncons,stringPack,stringUnpack,stringNilP,stringConsP) + | byteStrings = ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)") + | otherwise = ("String", "take", "", "id", "id", "[]", "(c:s)" ) + + ifC cat s = if isUsedCat cf cat then s else "" + lexComments ([],[]) = [] + lexComments (xs,s1:ys) = '\"' : s1 ++ "\"" ++ " [.]* ; -- Toss single line comments\n" ++ lexComments (xs, ys) + lexComments (([l1,l2],[r1,r2]):xs,[]) = concat $ + [ + ('\"':l1:l2:"\" ([$u # \\"), -- FIXME quotes or escape? + (l2:"] | \\"), + (r1:" [$u # \\"), + (r2:"])* (\""), + (r1:"\")+ \""), + (r2:"\" ; \n"), + lexComments (xs, []) + ] + lexComments ((_:xs),[]) = lexComments (xs,[]) +--- lexComments (xs,(_:ys)) = lexComments (xs,ys) + + -- tokens consisting of special symbols + pTSpec [] = "" + pTSpec _ = "@rsyms { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }" + + userDefTokenTypes = unlines $ + [printRegAlex exp ++ + " { tok (\\p s -> PT p (eitherResIdent (T_" ++ name ++ " . share) s)) }" + | (name,exp) <- tokenPragmas cf] + userDefTokenConstrs = unlines $ + [" | T_" ++ name ++ " !"++stringType | (name,_) <- tokenPragmas cf] + userDefTokenPrint = unlines $ + [" PT _ (T_" ++ name ++ " s) -> s" | (name,_) <- tokenPragmas cf] + + ident = + "$l $i* { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }" + --ifC "Ident" " ::= ^l ^i* { ident p = PT p . eitherResIdent TV }" + + +data BTree = N | B String Int BTree BTree + +instance Show BTree where + showsPrec _ N = showString "N" + showsPrec n (B s k l r) = wrap (showString "b " . shows s . showChar ' '. shows k . showChar ' ' + . showsPrec 1 l . showChar ' ' + . showsPrec 1 r) + where wrap f = if n > 0 then showChar '(' . f . showChar ')' else f + +sorted2tree :: [(String,Int)] -> BTree +sorted2tree [] = N +sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2) where + (t1,((x,n):t2)) = splitAt (length xs `div` 2) xs + + +------------------------------------------------------------------- +-- Inlined version of @RegToAlex@. +-- Syntax has changed... +------------------------------------------------------------------- + +-- modified from pretty-printer generated by the BNF converter + +-- the top-level printing method +printRegAlex :: Reg -> String +printRegAlex = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend 0 + where rend :: Int -> [String] -> String + rend i ss = case ss of + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + + cons s t = s ++ t + new i s = s + space t s = if null s then t else t ++ " " ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ c = if isAlphaNum c then [[c]] else ['\\':[c]] + prtList s = map (concat . prt 0) s + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["$"]) + RChar c -> prPrec i 3 (concat [prt 0 c]) + RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) + RDigit -> prPrec i 3 (concat [["$d"]]) + RLetter -> prPrec i 3 (concat [["$l"]]) + RUpper -> prPrec i 3 (concat [["$c"]]) + RLower -> prPrec i 3 (concat [["$s"]]) + RAny -> prPrec i 3 (concat [["$u"]]) diff --git a/src/formats/haskell2/CFtoHappy.hs b/src/formats/haskell2/CFtoHappy.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/CFtoHappy.hs @@ -0,0 +1,278 @@ +{- + BNF Converter: Happy Generator + Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoHappy + ( + cf2HappyS -- cf2HappyS :: CF -> CFCat -> String + ) + where + +import CF +--import Lexer +import Data.List (intersperse, sort) +import Data.Char +import Options (HappyMode(..)) +-- Type declarations + +type Rules = [(NonTerminal,[(Pattern,Action)])] +type NonTerminal = String +type Pattern = String +type Action = String +type MetaVar = String + +-- default naming + +moduleName = "HappyParser" +tokenName = "Token" + +-- Happy mode + + + +cf2HappyS :: String -> String -> String -> String -> HappyMode -> Bool -> CF -> String +---- cf2HappyS :: String -> CF -> String +cf2HappyS = cf2Happy + +-- The main function, that given a CF and a CFCat to parse according to, +-- generates a happy module. +cf2Happy name absName lexName errName mode byteStrings cf + = unlines + [header name absName lexName errName mode byteStrings, + declarations mode (allEntryPoints cf), + tokens (cfTokens cf), + specialToks cf, + delimiter, + specialRules byteStrings cf, + prRules (rulesForHappy cf), + finalize byteStrings cf] + +-- construct the header. +header :: String -> String -> String -> String -> HappyMode -> Bool -> String +header modName absName lexName errName mode byteStrings = unlines + ["-- This Happy file was machine-generated by the BNF converter", + "{", + "{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}", + case mode of + Standard -> "module " ++ modName ++ " where" + GLR -> "-- module name filled in by Happy", + "import " ++ absName, + "import " ++ lexName, + "import " ++ errName, + if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "", + "}" + ] + +{- ---- +cf2Happy :: String -> CF -> String +cf2Happy name cf + = unlines + [header name, + declarations (allEntryPoints cf), + tokens (cfTokens cf), + specialToks cf, + delimiter, + specialRules cf, + prRules (rulesForHappy cf), + finalize cf] + +-- construct the header. +header :: String -> String +header name = unlines + ["-- This Happy file was machine-generated by the BNF converter", + "{", + "module Par" ++ name ++ " where", + "import Abs"++name, + "import Lex"++name, + "import ErrM", + "}" + ] +-} + +-- The declarations of a happy file. +declarations :: HappyMode -> [NonTerminal] -> String +declarations mode ns = unlines + [generateP ns, + case mode of + Standard -> "-- no lexer declaration" + GLR -> "%lexer { myLexer } { Err _ }", + "%monad { Err } { thenM } { returnM }", + "%tokentype { " ++ tokenName ++ " }"] + where generateP [] = [] + generateP (n:ns) = concat ["%name p",n'," ",n',"\n",generateP ns] + where n' = identCat n + +-- The useless delimiter symbol. +delimiter :: String +delimiter = "\n%%\n" + +-- Generate the list of tokens and their identifiers. +tokens :: [(String,Int)] -> String +tokens toks = "%token \n" ++ prTokens toks + where prTokens [] = [] + prTokens ((t,k):tk) = " " ++ (convert t) ++ + " { " ++ oneTok t k ++ " }\n" ++ + prTokens tk + oneTok t k = "PT _ (TS _ " ++ show k ++ ")" + +-- Happy doesn't allow characters such as åäö to occur in the happy file. This +-- is however not a restriction, just a naming paradigm in the happy source file. +convert :: String -> String +convert "\\" = concat ['\'':"\\\\","\'"] +convert xs = concat ['\'':(escape xs),"\'"] + where escape [] = [] + escape ('\'':xs) = '\\':'\'':escape xs + escape (x:xs) = x:escape xs + +rulesForHappy :: CF -> Rules +rulesForHappy cf = map mkOne $ ruleGroups cf where + mkOne (cat,rules) = constructRule cf rules cat + +-- For every non-terminal, we construct a set of rules. A rule is a sequence of +-- terminals and non-terminals, and an action to be performed +-- As an optimization, a pair of list rules [C] ::= "" | C k [C] +-- is left-recursivized into [C] ::= "" | [C] C k. +-- This could be generalized to cover other forms of list rules. +constructRule :: CF -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule cf rules nt = (nt,[(p,generateAction nt (revF b r) m) | + r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True,revSepListRule r0) + else (False,r0), + let (p,m) = generatePatterns cf r]) + where + revF b r = if b then ("flip " ++ funRule r) else (underscore $ funRule r) + revs = reversibleCats cf + underscore f | isDefinedRule f = f ++ "_" + | otherwise = f + +-- Generates a string containing the semantic action. +-- An action can for example be: Sum $1 $2, that is, construct an AST +-- with the constructor Sum applied to the two metavariables $1 and $2. +generateAction :: NonTerminal -> Fun -> [MetaVar] -> Action +generateAction nt f ms = unwords $ (if isCoercion f then [] else [f]) ++ ms + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal + +generatePatterns :: CF -> Rule -> (Pattern,[MetaVar]) +generatePatterns cf r = case rhsRule r of + [] -> ("{- empty -}",[]) + its -> (unwords (map mkIt its), metas its) + where + mkIt i = case i of + Left c -> identCat c + Right s -> convert s + metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its] + revIf c m = if (not (isConsFun (funRule r)) && elem c revs) + then ("(reverse " ++ m ++ ")") + else m -- no reversal in the left-recursive Cons rule itself + revs = reversibleCats cf + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. + +prRules :: Rules -> String +prRules = unlines . map prOne + where + prOne (nt,[]) = [] -- nt has only internal use + prOne (nt,((p,a):ls)) = + unwords [nt', "::", "{", normCat nt, "}\n" ++ + nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ "\n" + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = + unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls + +-- Finally, some haskell code. + +finalize :: Bool -> CF -> String +finalize byteStrings cf = unlines $ + [ + "{", + "\nreturnM :: a -> Err a", + "returnM = return", + "\nthenM :: Err a -> (a -> Err b) -> Err b", + "thenM = (>>=)", + "\nhappyError :: [" ++ tokenName ++ "] -> Err a", + "happyError ts =", + " Bad $ \"syntax error at \" ++ tokenPos ts ++ ", + " case ts of", + " [] -> []", + " [Err _] -> \" due to lexer error\"", + " _ -> \" before \" ++ unwords (map ("++stringUnpack++" . prToken) (take 4 ts))", + "", + "myLexer = tokens" + ] ++ definedRules cf ++ [ "}" ] + where + stringUnpack + | byteStrings = "BS.unpack" + | otherwise = "id" + + +definedRules cf = [ mkDef f xs e | FunDef f xs e <- pragmasOfCF cf ] + where + mkDef f xs e = unwords $ (f ++ "_") : xs' ++ ["=", show e'] + where + xs' = map (++"_") xs + e' = underscore e + underscore (App x es) + | isLower $ head x = App (x ++ "_") $ map underscore es + | otherwise = App x $ map underscore es + underscore e = e + +-- aarne's modifs 8/1/2002: +-- Markus's modifs 11/02/2002 + +-- GF literals +specialToks :: CF -> String +specialToks cf = unlines $ + (map aux (literals cf)) + ++ ["L_err { _ }"] + where aux cat = + case cat of + "Ident" -> "L_ident { PT _ (TV $$) }" + "String" -> "L_quoted { PT _ (TL $$) }" + "Integer" -> "L_integ { PT _ (TI $$) }" + "Double" -> "L_doubl { PT _ (TD $$) }" + "Char" -> "L_charac { PT _ (TC $$) }" + own -> "L_" ++ own ++ " { PT _ (T_" ++ own ++ " " ++ posn ++ ") }" + where + posn = if isPositionCat cf cat then "_" else "$$" + +specialRules :: Bool -> CF -> String +specialRules byteStrings cf = unlines $ + map aux (literals cf) + where + aux cat = + case cat of + "Ident" -> "Ident :: { Ident } : L_ident { Ident $1 }" + "String" -> "String :: { String } : L_quoted { "++stringUnpack++" $1 }" + "Integer" -> "Integer :: { Integer } : L_integ { (read ("++stringUnpack++" $1)) :: Integer }" + "Double" -> "Double :: { Double } : L_doubl { (read ("++stringUnpack++" $1)) :: Double }" + "Char" -> "Char :: { Char } : L_charac { (read ("++stringUnpack++" $1)) :: Char }" + own -> own ++ " :: { " ++ own ++ "} : L_" ++ own ++ " { " ++ own ++ " ("++ posn ++ "$1)}" + -- PCC: take "own" as type name? (manual says newtype) + where + posn = if isPositionCat cf cat then "mkPosToken " else "" + + stringUnpack + | byteStrings = "BS.unpack" + | otherwise = "" + diff --git a/src/formats/haskell2/CFtoLayout.hs b/src/formats/haskell2/CFtoLayout.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/CFtoLayout.hs @@ -0,0 +1,270 @@ +{- + BNF Converter: Layout handling Generator + Copyright (C) 2004 Author: Aarne Ranta + Copyright (C) 2005 Bjorn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoLayout where + +import Data.List (sort) +import CF + +layoutOpen = "{" +layoutClose = "}" +layoutSep = ";" + +cf2Layout :: Bool -> Bool -> String -> String -> CF -> String +cf2Layout alex1 inDir layName lexName cf = + let + (top,lay,stop) = layoutPragmas cf + in unlines $ [ + "module " ++ layName ++ " where", + "", + "import " ++ lexName, + if alex1 then "import Alex" else "", + "", + "import Data.Maybe (isNothing, fromJust)", + "", + "-- Generated by the BNF Converter", + "", + "-- local parameters", + "", + "topLayout = " ++ show top, + "layoutWords = " ++ show lay, + "layoutStopWords = " ++ show stop, + "", + "-- layout separators", + "", + "layoutOpen = " ++ show layoutOpen, + "layoutClose = " ++ show layoutClose, + "layoutSep = " ++ show layoutSep, + "", + "-- | Replace layout syntax with explicit layout tokens.", + "resolveLayout :: Bool -- ^ Whether to use top-level layout.", + " -> [Token] -> [Token]", + "resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]", + " where", + " -- Do top-level layout if the function parameter and the grammar say so.", + " tl = tp && topLayout", + "", + " res :: Maybe Token -- ^ The previous token, if any.", + " -> [Block] -- ^ A stack of layout blocks.", + " -> [Token] -> [Token]", + "", + " -- The stack should never be empty.", + " res _ [] ts = error $ \"Layout error: stack empty. Tokens: \" ++ show ts", + "", + " res _ st (t0:ts)", + " -- We found an open brace in the input,", + " -- put an explicit layout block on the stack.", + " -- This is done even if there was no layout word,", + " -- to keep opening and closing braces.", + " | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts", + "", + " res _ st (t0:ts)", + " -- Start a new layout block if the first token is a layout word", + " | isLayout t0 =", + " case ts of", + " -- Explicit layout, just move on. The case above", + " -- will push an explicit layout block.", + " t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts", + " -- at end of file, the start column doesn't matter", + " _ -> let col = if null ts then column t0 else column (head ts)", + " -- insert an open brace after the layout word", + " b:ts' = addToken (nextPos t0) layoutOpen ts", + " -- save the start column", + " st' = Implicit col:st ", + " in moveAlong st' [t0,b] ts'", + "", + " -- If we encounter a closing brace, exit the first explicit layout block.", + " | isLayoutClose t0 = ", + " let st' = drop 1 (dropWhile isImplicit st)", + " in if null st' ", + " then error $ \"Layout error: Found \" ++ layoutClose ++ \" at (\" ", + " ++ show (line t0) ++ \",\" ++ show (column t0) ", + " ++ \") without an explicit layout block.\"", + " else moveAlong st' [t0] ts", + "", + " -- We are in an implicit layout block", + " res pt st@(Implicit n:ns) (t0:ts)", + "", + " -- End of implicit block by a layout stop word", + " | isStop t0 = ", + " -- Exit the current block and all implicit blocks ", + " -- more indented than the current token", + " let (ebs,ns') = span (`moreIndent` column t0) ns", + " moreIndent (Implicit x) y = x > y", + " moreIndent Explicit _ = False", + " -- the number of blocks exited", + " b = 1 + length ebs", + " bs = replicate b layoutClose", + " -- Insert closing braces after the previous token.", + " (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)", + " in moveAlong ns' ts1 ts2", + "", + " -- End of an implicit layout block", + " | newLine && column t0 < n = ", + " -- Insert a closing brace after the previous token.", + " let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)", + " -- Repeat, with the current block removed from the stack", + " in moveAlong ns [b] (t0':ts')", + "", + " -- Encounted a new line in an implicit layout block.", + " | newLine && column t0 == n = ", + " -- Insert a semicolon after the previous token.", + " -- unless we are the beginning of the file,", + " -- or the previous token is a semicolon or open brace.", + " if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt) ", + " then moveAlong st [t0] ts", + " else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts)", + " in moveAlong st [b,t0'] ts'", + " where newLine = case pt of", + " Nothing -> True", + " Just t -> line t /= line t0", + "", + " -- Nothing to see here, move along.", + " res _ st (t:ts) = moveAlong st [t] ts", + "", + " -- At EOF: skip explicit blocks.", + " res (Just t) (Explicit:bs) [] | null bs = []", + " | otherwise = res (Just t) bs []", + "", + " -- If we are using top-level layout, insert a semicolon after", + " -- the last token, if there isn't one already", + " res (Just t) [Implicit n] []", + " | isTokenIn [layoutSep] t = []", + " | otherwise = addToken (nextPos t) layoutSep []", + "", + " -- At EOF in an implicit, non-top-level block: close the block", + " res (Just t) (Implicit n:bs) [] =", + " let c = addToken (nextPos t) layoutClose []", + " in moveAlong bs c []", + "", + " -- This should only happen if the input is empty.", + " res Nothing st [] = []", + "", + " -- | Move on to the next token.", + " moveAlong :: [Block] -- ^ The layout stack.", + " -> [Token] -- ^ Any tokens just processed.", + " -> [Token] -- ^ the rest of the tokens.", + " -> [Token]", + " moveAlong st [] ts = error $ \"Layout error: moveAlong got [] as old tokens\"", + " moveAlong st ot ts = ot ++ res (Just $ last ot) st ts", + "", + "data Block = Implicit Int -- ^ An implicit layout block with its start column.", + " | Explicit ", + " deriving Show", + "", + "type Position = Posn", + "", + "-- | Check if s block is implicit.", + "isImplicit :: Block -> Bool", + "isImplicit (Implicit _) = True", + "isImplicit _ = False", + "", + "-- | Insert a number of tokens at the begninning of a list of tokens.", + "addTokens :: Position -- ^ Position of the first new token.", + " -> [String] -- ^ Token symbols.", + " -> [Token] -- ^ The rest of the tokens. These will have their", + " -- positions updated to make room for the new tokens .", + " -> [Token] ", + "addTokens p ss ts = foldr (addToken p) ts ss", + "", + "-- | Insert a new symbol token at the begninning of a list of tokens.", + "addToken :: Position -- ^ Position of the new token.", + " -> String -- ^ Symbol in the new token.", + " -> [Token] -- ^ The rest of the tokens. These will have their", + " -- positions updated to make room for the new token.", " -> [Token]", + "addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts", + "", + "-- | Get the position immediately to the right of the given token.", + "-- If no token is given, gets the first position in the file.", + "afterPrev :: Maybe Token -> Position", + "afterPrev = maybe (Pn 0 1 1) nextPos", + "", + "-- | Get the position immediately to the right of the given token.", + "nextPos :: Token -> Position ", + "nextPos t = Pn (g + s) l (c + s + 1) ", + " where Pn g l c = position t", + " s = tokenLength t", + "", + "-- | Add to the global and column positions of a token.", + "-- The column position is only changed if the token is on", + "-- the same line as the given position.", + "incrGlobal :: Position -- ^ If the token is on the same line", + " -- as this position, update the column position.", + " -> Int -- ^ Number of characters to add to the position.", + " -> Token -> Token", + "incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) =", + " if l /= l0 then PT (Pn (g + i) l c) t", + " else PT (Pn (g + i) l (c + i)) t", + "incrGlobal _ _ p = error $ \"cannot add token at \" ++ show p", + "", + "-- | Create a symbol token.", + "sToken :: Position -> String -> Token", + "sToken p s = PT p (TS s i)", + " where", + " i = case s of"] ++ + [ " " ++ show s ++ " -> " ++ show i + | (s, i) <- zip resws [1..] + ] ++ + [" _ -> error $ \"not a reserved word: \" ++ show s", + "", + "-- | Get the position of a token.", + "position :: Token -> Position", + "position t = case t of", + " PT p _ -> p", + " Err p -> p", + "", + "-- | Get the line number of a token.", + "line :: Token -> Int", + "line t = case position t of Pn _ l _ -> l", + "", + "-- | Get the column number of a token.", + "column :: Token -> Int", + "column t = case position t of Pn _ _ c -> c", + "", + "-- | Check if a token is one of the given symbols.", + "isTokenIn :: [String] -> Token -> Bool", + "isTokenIn ts t = case t of", + " PT _ (TS r _) | elem r ts -> True", + " _ -> False", + "", + "-- | Check if a word is a layout start token.", + "isLayout :: Token -> Bool", + "isLayout = isTokenIn layoutWords", + "", + "-- | Check if a token is a layout stop token.", + "isStop :: Token -> Bool", + "isStop = isTokenIn layoutStopWords", + "", + "-- | Check if a token is the layout open token.", + "isLayoutOpen :: Token -> Bool", + "isLayoutOpen = isTokenIn [layoutOpen]", + "", + "-- | Check if a token is the layout close token.", + "isLayoutClose :: Token -> Bool", + "isLayoutClose = isTokenIn [layoutClose]", + "", + "-- | Get the number of characters in the token.", + "tokenLength :: Token -> Int", + "tokenLength t = length $ prToken t", + + "" + ] + where + resws = sort (reservedWords cf ++ symbols cf) diff --git a/src/formats/haskell2/CFtoPrinter.hs b/src/formats/haskell2/CFtoPrinter.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/CFtoPrinter.hs @@ -0,0 +1,189 @@ +{- + BNF Converter: Pretty-printer generator + Copyright (C) 2004 Author: Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoPrinter (cf2Printer) where + +import CF +import Utils +import CFtoTemplate +import Data.List (intersperse) +import Data.Char(toLower) + +-- derive pretty-printer from a BNF grammar. AR 15/2/2002 +cf2Printer :: Bool -> String -> String -> CF -> String +cf2Printer byteStrings name absMod cf = unlines [ + prologue byteStrings name absMod, + integerRule cf, + doubleRule cf, + if hasIdent cf then identRule byteStrings cf else "", + unlines [ownPrintRule byteStrings cf own | (own,_) <- tokenPragmas cf], + rules cf + ] + + +prologue :: Bool -> String -> String -> String +prologue byteStrings name absMod = unlines [ + "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}", + "module " ++ name +++ "where\n", + "-- pretty-printer generated by the BNF converter\n", + "import " ++ absMod, + "import Data.Char", + (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""), + "", + "-- 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 String +rules cf = unlines $ + map (\(s,xs) -> case_fun s (map toArgs xs) ++ ifList cf s) $ cf2data cf + where + toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons) + names [] _ = [] + names (x:xs) n + | elem x xs = (x ++ show n) : names xs (n+1) + | otherwise = x : names xs n + var ('[':xs) = var (init xs) ++ "s" + var "Ident" = "id" + var "Integer" = "n" + var "String" = "str" + var "Char" = "c" + var "Double" = "d" + var xs = map toLower xs + checkRes s + | elem s reservedHaskell = s ++ "'" + | otherwise = s + reservedHaskell = ["case","class","data","default","deriving","do","else","if", + "import","in","infix","infixl","infixr","instance","let","module", + "newtype","of","then","type","where","as","qualified","hiding"] + ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf) + +--- case_fun :: Cat -> [(Constructor,Rule)] -> String +case_fun cat xs = unlines [ + "instance Print" +++ cat +++ "where", + " prt i" +++ "e = case e of", + unlines $ map (\ ((c,xx),r) -> + " " ++ c +++ unwords xx +++ "->" +++ + "prPrec i" +++ show (precCat (fst r)) +++ mkRhs xx (snd r)) xs + ] + +ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where + nil cat = [" [] -> " ++ mkRhs [] its | + Rule f c its <- rulesOfCF cf, isNilFun f , normCatOfList c == cat] + one cat = [" [x] -> " ++ mkRhs ["x"] its | + Rule f c its <- rulesOfCF cf, isOneFun f , normCatOfList c == cat] + cons cat = [" x:xs -> " ++ mkRhs ["x","xs"] its | + Rule f c its <- rulesOfCF cf, isConsFun f , normCatOfList c == cat] + mkListRule [] = "" + mkListRule rs = unlines $ (" prtList" +++ "es = case es of"):rs + + +mkRhs args its = + "(concatD [" ++ unwords (intersperse "," (mk args its)) ++ "])" + where + mk args (Left "#" : items) = mk args items + mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items + mk args (Right s : items) = ("doc (showString" +++ show s ++ ")") : mk args items + mk _ _ = [] + prt c = "prt" +++ show (precCat c) + diff --git a/src/formats/haskell2/CFtoTemplate.hs b/src/formats/haskell2/CFtoTemplate.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/CFtoTemplate.hs @@ -0,0 +1,114 @@ +{- + BNF Converter: Template Generator + Copyright (C) 2004 Author: Markus Forberg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +module CFtoTemplate ( + cf2Template + ) where + +import CF +import Data.Char +import Data.List (delete) + +type ModuleName = String +type Constructor = String + +cf2Template :: ModuleName -> ModuleName -> ModuleName -> CF -> String +cf2Template skelName absName errName cf = unlines + [ + "module "++ skelName ++ " where\n", + "-- Haskell module generated by the BNF converter\n", + "import " ++ absName, + "import " ++ errName, + "type Result = Err String\n", + "failure :: Show a => a -> Result", + "failure x = Bad $ \"Undefined case: \" ++ show x\n", + unlines $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf + ] + where toArgs [] = [] + toArgs ((cons,args):xs) + = (cons ++ " " ++ names False (map (checkRes . var) args) (1 :: Int)) : toArgs xs + names _ [] _ = [] + names b (x:xs) n + | elem x xs = (x ++ show n) ++ " " ++ names True xs (n+1) + | otherwise = (x ++ if b then show n else "") ++ " " ++ names b xs (if b then n+1 else n) +{- + toArgs ((cons,args):xs) + = (cons ++ " " ++ names (map (checkRes . var) args) (0 :: Int)) : toArgs xs + names [] _ = [] + names (x:xs) n + | elem x xs = (x ++ show n) ++ " " ++ names xs (n+1) + | otherwise = x ++ " " ++ names xs n +-} + var ('[':xs) = var (init xs) ++ "s" + var "Ident" = "id" + var "Integer" = "n" + var "String" = "str" + var "Char" = "c" + var "Double" = "d" + var xs = map toLower xs + checkRes s + | elem s reservedHaskell = s ++ "'" + | otherwise = s + reservedHaskell = ["case","class","data","default","deriving","do","else","if", + "import","in","infix","infixl","infixr","instance","let","module", + "newtype","of","then","type","where","as","qualified","hiding"] + +{- ---- +cf2Template :: ModuleName -> CF -> String +cf2Template name cf = unlines + [ + "module Skel"++ name ++ " where\n", + "-- Haskell module generated by the BNF converter\n", + "import Abs" ++ name, + "import ErrM", + "type Result = Err String\n", + "failure :: Show a => a -> Result", + "failure x = Bad $ \"Undefined case: \" ++ show x\n", + unlines $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf + ] + where toArgs [] = [] + toArgs ((cons,args):xs) + = (cons ++ " " ++ names False (map (checkRes . var) args) (1 :: Int)) : toArgs xs + names _ [] _ = [] + names b (x:xs) n + | elem x xs = (x ++ show n) ++ " " ++ names True xs (n+1) + | otherwise = (x ++ if b then show n else "") ++ " " ++ names b xs (if b then n+1 else n) + var ('[':xs) = var (init xs) ++ "s" + var "Ident" = "id" + var "Integer" = "n" + var "String" = "str" + var "Char" = "c" + var "Double" = "d" + var xs = map toLower xs + checkRes s + | elem s reservedHaskell = s ++ "'" + | otherwise = s + reservedHaskell = ["case","class","data","default","deriving","do","else","if", + "import","in","infix","infixl","infixr","instance","let","module", + "newtype","of","then","type","where","as","qualified","hiding"] +-} + +case_fun :: Cat -> [Constructor] -> String +case_fun cat xs = + unlines $ + ["trans" ++ cat ++ " :: " ++ cat ++ " -> Result", + "trans" ++ cat ++ " x = case x of", + unlines $ map (\s -> " " ++ s ++ " -> " ++ "failure x") xs] + diff --git a/src/formats/haskell2/HaskellTop.hs b/src/formats/haskell2/HaskellTop.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/HaskellTop.hs @@ -0,0 +1,277 @@ +{- + BNF Converter: Haskell main file + Copyright (C) 2004 Author: Markus Forberg, Peter Gammie, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module HaskellTop (makeAll, AlexMode(..), makefile) where + + + +-- import Utils +import Options +import CF +import CFtoHappy +import CFtoAlex +import CFtoAlex2 +import CFtoAlex3 +import CFtoLatex +import CFtoTxt +import CFtoAbstract +import CFtoTemplate +import CFtoPrinter +import CFtoLayout +import CFtoXML +import HsOpts +import ToCNF +import MkErrM +import MkSharedString +import Utils +import qualified Common.Makefile as Makefile + +import Data.Char +import Data.Maybe (fromMaybe,maybe) +import System.Exit (exitFailure) +import Control.Monad(when,unless) + +-- naming conventions + + + + +makeAll :: Options -> CF -> IO () +makeAll opts cf = do + let absMod = absFileM opts + lexMod = alexFileM opts + parMod = happyFileM opts + prMod = printerFileM opts + layMod = layoutFileM opts + errMod = errFileM opts + shareMod = shareFileM opts + do + let dir = codeDir opts + unless (null dir) $ do + putStrLn $ "Creating directory " ++ dir + prepareDir dir + writeFileRep (absFile opts) $ cf2Abstract (byteStrings opts) absMod cf + case alexMode opts of + Alex1 -> do + writeFileRep (alexFile opts) $ cf2alex lexMod errMod cf + putStrLn " (Use Alex 1.1 to compile.)" + Alex2 -> do + writeFileRep (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf + putStrLn " (Use Alex 2.0 to compile.)" + Alex3 -> do + writeFileRep (alexFile opts) $ cf2alex3 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf + putStrLn " (Use Alex 3.0 to compile.)" + writeFileRep (happyFile opts) $ + cf2HappyS parMod absMod lexMod errMod (glr opts) (byteStrings opts) cf + putStrLn " (Tested with Happy 1.15)" + writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf + writeFileRep (txtFile opts) $ cfToTxt (lang opts) cf + writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod cf + writeFileRep (printerFile opts) $ cf2Printer (byteStrings opts) prMod absMod cf + when (hasLayout cf) $ writeFileRep (layoutFile opts) $ cf2Layout (alex1 opts) (inDir opts) layMod lexMod cf + writeFileRep (tFile opts) $ testfile opts cf + writeFileRep (errFile opts) $ errM errMod cf + when (shareStrings opts) $ writeFileRep (shareFile opts) $ sharedString shareMod (byteStrings opts) cf + when (make opts) $ writeFileRep "Makefile" $ makefile opts + case xml opts of + 2 -> makeXML (lang opts) True cf + 1 -> makeXML (lang opts) False cf + _ -> return () + when (cnf opts) $ do + writeFileRep (cnfTablesFile opts) $ ToCNF.generate opts cf + writeFileRep "TestCNF.hs" $ ToCNF.genTestFile opts cf + writeFileRep "BenchCNF.hs" $ ToCNF.genBenchmark opts + +codeDir :: Options -> FilePath +codeDir opts = let pref = maybe "" pkgToDir (inPackage opts) + dir = if inDir opts then lang opts else "" + sep = if null pref || null dir then "" else [pathSep] + in pref ++ sep ++ dir + +makefile :: Options -> String +makefile opts = makeA where + glr_params = if glr opts == GLR then "--glr --decode " else "" + dir = let d = codeDir opts in if null d then "" else d ++ [pathSep] + cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")" + makeA = Makefile.mkRule "all" [] + [ "happy -gca " ++ glr_params ++ happyFile opts + , "alex -g " ++ alexFile opts + , "ghc --make " ++ tFile opts ++ " -o " ++ mkFile withLang "Test" "" opts] + $ Makefile.mkDoc (basename (latexFile opts)) + $ Makefile.mkRule "clean" [] + [ "-rm -f " ++ unwords + (map (dir++) [ "*.log", "*.aux", "*.hi", "*.o", "*.dvi" ]) + , "-rm -f " ++ psFile opts ] + $ Makefile.mkRule "distclean" ["clean"] + [ "-rm -f " ++ unwords + [ mkFile withLang "Doc" "*" opts + , mkFile withLang "Lex" "*" opts + , mkFile withLang "Par" "*" opts + , mkFile withLang "Layout" "*" opts + , mkFile withLang "Skel" "*" opts + , mkFile withLang "Print" "*" opts + , mkFile withLang "Test" "*" opts + , mkFile withLang "Abs" "*" opts + , mkFile withLang "Test" "" opts + , mkFile noLang "ErrM" "*" opts + , mkFile noLang "SharedString" "*" opts + , mkFile withLang "ComposOp" "*" opts + , dir ++ lang opts ++ ".dtd" + , mkFile withLang "XML" "*" opts + , "Makefile*" ] + , if null dir then "" else "\t-rmdir -p " ++ dir ] + "" + +testfile :: Options -> CF -> String +testfile opts cf + = let lay = hasLayout cf + use_xml = xml opts > 0 + xpr = if use_xml then "XPrint a, " else "" + use_glr = glr opts == GLR + if_glr s = if use_glr then s else "" + firstParser = if use_glr then "the_parser" else parserName + parserName = 'p' : topType + topType = firstEntry cf + in unlines + ["-- automatically generated by BNF Converter", + "module Main where\n", + "", + "import System.IO ( stdin, hGetContents )", + "import System.Environment ( getArgs, getProgName )", + "import System.Exit ( exitFailure, exitSuccess )", + "", + "import " ++ alexFileM opts, + "import " ++ happyFileM opts, + "import " ++ templateFileM opts, + "import " ++ printerFileM opts, + "import " ++ absFileM opts, + if lay then "import " ++ layoutFileM opts else "", + if use_xml then "import " ++ xmlFileM opts else "", + if_glr "import Data.FiniteMap(FiniteMap, lookupFM, fmToList)", + if_glr "import Data.Maybe(fromJust)", + "import " ++ errFileM opts, + "", + if use_glr + then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))" + else "type ParseFun a = [Token] -> Err a", + "", + "myLLexer = " ++ if lay then "resolveLayout True . myLexer" + else "myLexer", + "", + "type Verbosity = Int", + "", + "putStrV :: Verbosity -> String -> IO ()", + "putStrV v s = if v > 1 then putStrLn s else return ()", + "", + "runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()", + "runFile v p f = putStrLn f >> readFile f >>= run v p", + "", + "run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()", + if use_glr then run_glr else run_std use_xml, + "", + "showTree :: (Show a, Print a) => Int -> a -> IO ()", + "showTree v tree", + " = do", + " putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree", + " putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree", + "", + "main :: IO ()", + "main = do args <- getArgs", + " case args of", + " [] -> hGetContents stdin >>= run 2 " ++ firstParser, + " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs", + " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs", + "", + if_glr $ "the_parser :: ParseFun " ++ topType, + if_glr $ "the_parser = lift_parser " ++ parserName, + if_glr $ "", + if_glr $ lift_parser + ] + +run_std xml + = unlines + [ "run v p s = let ts = myLLexer s in case p ts of" + , " Bad s -> do putStrLn \"\\nParse Failed...\\n\"" + , " putStrV v \"Tokens:\"" + , " putStrV v $ show ts" + , " putStrLn s" + , " exitFailure" + , " Ok tree -> do putStrLn \"\\nParse Successful!\"" + , " showTree v tree" + , if xml then + " putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree" + else "" + , " exitSuccess" + ] + +run_glr + = unlines + [ "run v p s" + , " = let ts = map (:[]) $ myLLexer s" + , " (raw_output, simple_output) = p ts in" + , " case simple_output of" + , " GLR_Fail major minor -> do" + , " putStrLn major" + , " putStrV v minor" + , " GLR_Result df trees -> do" + , " putStrLn \"\\nParse Successful!\"" + , " case trees of" + , " [] -> error \"No results but parse succeeded?\"" + , " [Ok x] -> showTree v x" + , " xs@(_:_) -> showSeveralTrees v xs" + , " where" + , " showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()" + , " showSeveralTrees v trees" + , " = sequence_ " + , " [ do putStrV v (replicate 40 '-')" + , " putStrV v $ \"Parse number: \" ++ show n" + , " showTree v t" + , " | (Ok t,n) <- zip trees [1..]" + , " ]" + ] + + +lift_parser + = unlines + [ "type Forest = FiniteMap ForestId [Branch] -- omitted in ParX export." + , "data GLR_Output a" + , " = GLR_Result { pruned_decode :: (Forest -> Forest) -> [a]" + , " , semantic_result :: [a]" + , " }" + , " | GLR_Fail { main_message :: String" + , " , extra_info :: String" + , " }" + , "" + , "lift_parser" + , " :: (TreeDecode a, Show a, Print a)" + , " => ([[Token]] -> GLRResult) -> ParseFun a" + , "lift_parser parser ts" + , " = let result = parser ts in" + , " (\\o -> (result, o)) $" + , " case result of" + , " ParseError ts f -> GLR_Fail \"Parse failed, unexpected token(s)\\n\"" + , " (\"Tokens: \" ++ show ts)" + , " ParseEOF f -> GLR_Fail \"Parse failed, unexpected EOF\\n\"" + , " (\"Partial forest:\\n\"" + , " ++ unlines (map show $ fmToList f))" + , " ParseOK r f -> let find f = fromJust . lookupFM f" + , " dec_fn f = decode (find f) r" + , " in GLR_Result (\\ff -> dec_fn $ ff f) (dec_fn f)" + ] + diff --git a/src/formats/haskell2/HsOpts.hs b/src/formats/haskell2/HsOpts.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/HsOpts.hs @@ -0,0 +1,78 @@ +module HsOpts where + +import Utils +import Options + +type Options = SharedOptions + +alex1 opts = alexMode opts == Alex1 + +absFile, absFileM, alexFile, alexFileM, dviFile, + composOpFile, composOpFileM, + gfAbs, gfConc, + happyFile, happyFileM, + latexFile, errFile, errFileM, + templateFile, templateFileM, + printerFile, printerFileM, + layoutFile, layoutFileM, + psFile, tFile, tFileM :: Options -> String +absFile = mkFile withLangAbs "Abs" "hs" +absFileM = mkMod withLangAbs "Abs" +alexFile = mkFile withLang "Lex" "x" +alexFileM = mkMod withLang "Lex" +happyFile = mkFile withLang "Par" "y" +happyFileM = mkMod withLang "Par" +latexFile = mkFile withLang "Doc" "tex" +txtFile = mkFile withLang "Doc" "txt" +templateFile = mkFile withLang "Skel" "hs" +templateFileM = mkMod withLang "Skel" +printerFile = mkFile withLang "Print" "hs" +printerFileM = mkMod withLang "Print" +dviFile = mkFile withLang "Doc" "dvi" +psFile = mkFile withLang "Doc" "ps" +gfAbs = mkFile withLangAbs "" "Abs.gf" +gfConc = mkFile withLang "" "Conc.gf" +tFile = mkFile withLang "Test" "hs" +tFileM = mkMod withLang "Test" +errFile = mkFile noLang "ErrM" "hs" +errFileM = mkMod noLang "ErrM" +shareFile = mkFile noLang "SharedString" "hs" +shareFileM = mkMod noLang "SharedString" +layoutFileM = mkMod withLang "Layout" +layoutFile = mkFile withLang "Layout" "hs" +cnfTablesFile = mkFile withLang "CnfTables" "hs" +cnfTablesFileM= mkMod withLang "CnfTables" +xmlFileM = mkMod withLang "XML" +composOpFile = mkFile noLang "ComposOp" "hs" +composOpFileM = mkMod noLang "ComposOp" + + +noLang :: Options -> String -> String +noLang _ name = name + +withLang :: Options -> String -> String +withLang opts name = name ++ lang opts + +withLangAbs :: Options -> String -> String +withLangAbs opts name = postp $ name ++ lang opts + where + postp nam = if multi opts + then takeWhile (/='_') nam + else nam + +pkgToDir :: String -> FilePath +pkgToDir s = replace '.' pathSep s + + +mkMod :: (Options -> String -> String) -> String -> Options -> String +mkMod addLang name opts = + pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name + where pref = maybe "" (++".") (inPackage opts) + +mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath +mkFile addLang name ext opts = + pref ++ if inDir opts + then lang opts ++ [pathSep] ++ name ++ ext' + else addLang opts name ++ if null ext then "" else ext' + where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts) + ext' = if null ext then "" else "." ++ ext diff --git a/src/formats/haskell2/MkErrM.hs b/src/formats/haskell2/MkErrM.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/MkErrM.hs @@ -0,0 +1,51 @@ +{- + BNF Converter: Haskell error monad + Copyright (C) 2004-2007 Author: Markus Forberg, Peter Gammie, + Aarne Ranta, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} +module MkErrM where + +errM :: String -> b -> String +errM errMod _ = unlines + [ + "-- BNF Converter: Error Monad", + "-- Copyright (C) 2004 Author: Aarne Ranta", + "", + "-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.", + "module " ++ errMod ++ " 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/formats/haskell2/MkSharedString.hs b/src/formats/haskell2/MkSharedString.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/MkSharedString.hs @@ -0,0 +1,67 @@ +{- + BNF Converter: Haskell string sharing + Copyright (C) 2004-2007 Author: Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} +module MkSharedString where + +sharedString :: String -> Bool -> b -> String +sharedString shareMod byteString _ = unlines $ + if byteString + then + [ + "module " ++ shareMod ++ " (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'" + ] + else + [ + "module " ++ shareMod ++ " (shareString) where", + "", + "import Data.HashTable as H", + "import System.IO.Unsafe (unsafePerformIO)", + "", + "{-# NOINLINE stringPool #-}", + "stringPool :: HashTable String String", + "stringPool = unsafePerformIO $ new (==) hashString", + "", + "{-# NOINLINE shareString #-}", + "shareString :: String -> String", + "shareString s = unsafePerformIO $ do", + " mv <- H.lookup stringPool s", + " case mv of", + " Just s' -> return s'", + " Nothing -> do", + " H.insert stringPool s s", + " return s" + ] diff --git a/src/formats/haskell2/RegToAlex.hs b/src/formats/haskell2/RegToAlex.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/RegToAlex.hs @@ -0,0 +1,88 @@ +{- + BNF Converter: Regular expression pretty printer + Copyright (C) 2004 Author: BNF Converter, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module RegToAlex (printRegAlex) where + +-- modified from pretty-printer generated by the BNF converter + +import AbsBNF +import Data.Char + +-- the top-level printing method +printRegAlex :: Reg -> String +printRegAlex = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend (0::Int) where + rend i ss = case ss of + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + cons s t = s ++ t + new i s = s + space t s = if null s then t else t ++ " " ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ c = if isAlphaNum c then [[c]] else ['^':[c]] + prtList s = map (concat . prt 0) s + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["$"]) + RChar c -> prPrec i 3 (concat [prt 0 c]) + RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) + RDigit -> prPrec i 3 (concat [["^d"]]) + RLetter -> prPrec i 3 (concat [["^l"]]) + RUpper -> prPrec i 3 (concat [["^c"]]) + RLower -> prPrec i 3 (concat [["^s"]]) + RAny -> prPrec i 3 (concat [["^u"]]) + + + diff --git a/src/formats/haskell2/ToCNF.hs b/src/formats/haskell2/ToCNF.hs new file mode 100644 --- /dev/null +++ b/src/formats/haskell2/ToCNF.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{- + Copyright (C) 2012 Authors: + Jean-Philippe Bernardy. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{-# LANGUAGE OverloadedStrings #-} + +module ToCNF (generate, genTestFile, genBenchmark) where + +{- + +Construction of CYK tables. The algorithm follows: + +Lange, Martin; Leiß, Hans (2009), "To CNF or not to CNF? An Efficient +Yet Presentable Version of the CYK Algorithm", Informatica Didactica + +-} + +import CF hiding (App,Exp) +import HsOpts +import Control.Monad.RWS +import Control.Applicative hiding (Const) +import qualified Data.Map as M +import Data.List (nub,intercalate,sortBy,sort) +import Data.Maybe (maybeToList) +import Data.Function (on) +import Data.Char (isAlphaNum,ord) +import Data.String +import Data.Pair +import Text.PrettyPrint.HughesPJ hiding (first,(<>)) + +(f *** g) (a,b) = (f a, g b) +second g = id *** g + +onRules f (CFG (exts,rules)) = CFG (exts,f rules) + +toCNF cf0 = (cf1,cf2,units,descriptions) + where cf01@(CFG (exts01,_)) = funToExp . onRules delInternal $ cf0 + (rules',descriptions) = toBin (rulesOfCF cf01) + cf1 = CFG (exts01,rules') + cf2 = delNull cf1 + units = unitSet cf2 + +funToExp :: CFG Fun -> CFG Exp +funToExp = fmap toExp + +delInternal = filter (not . isInternalRhs . rhsRule) + where isInternalRhs (Left c:_) = c == internalCat + isInternalRhs _ = False + +-------------------------------------------------------------- +-- BIN: make sure no rule has more than 2 symbols on the rhs + +allocateCatName = do + n <- get + put (1+n) + return $ show n + +toBin :: [Rul Exp] -> ([Rul Exp], CatDescriptions) +toBin cf = (a,w) + where (a,_,w) = runRWS (concat <$> forM cf toBinRul) () 0 + +type CatDescriptions = M.Map Cat Doc + +-- | Convert a rule into a number of equivalent rules with at most 2 +-- symbols on the rhs. +-- Also writes an explanation of what new categories are. +toBinRul :: Rul Exp -> RWS () CatDescriptions Int [Rul Exp] +toBinRul (Rule f cat rhs) | length rhs > 2 = do + cat' <- allocateCatName + r' <- toBinRul $ Rule f cat' p + tell $ M.singleton cat' (int (length p) <> "-prefix of " <> prettyExp f <> " " <> parens (prettyRHS p)) + return $ Rule (Con "($)") cat [Left cat',l] + : r' + where l = last rhs + p = init rhs + fun' = case l of + Left _ -> Con "($)" -- in this case we have to apply the final argument to the partial result + Right _ -> Con "const" -- in this case the 2nd argument must be ignored (it is not present in the result). +toBinRul r = return [r] + +prettyRHS = hcat . punctuate " " . map (either text (quotes . text)) + +--------------------------- +-- Fixpoint utilities + +x ∪ y = sort $ nub (x ++ y) + +lk cat nullset = maybe [] id (M.lookup cat nullset) + +type Set k x = M.Map k [x] + +fixpointOnGrammar :: (Show k, Show x,Ord k, Ord x) => String -> (Set k x -> Rul f -> Set k x) -> CFG f -> Set k x +fixpointOnGrammar name f cf = case fixn 100 step M.empty of + Left x -> error $ "Could not find fixpoint of " ++ name ++". Last iteration:\n" ++ show x + Right x -> x + where step curSet = M.unionsWith (∪) (map (f curSet) (rulesOfCF cf)) + +fixn :: Eq a => Int -> (a -> a) -> a -> Either a a +fixn 0 f x = Left x +fixn n f x = if x' == x then Right x else fixn (n-1) f x' + where x' = f x + +------------------------------------------------------- +-- DEL : make sure no rule has 0 symbol on the rhs + +type Nullable = Set Cat Exp + +cross :: [[a]] -> [[a]] +cross [] = [[]] +cross (x:xs) = [y:ys | y <- x, ys <- cross xs] + +nullRule :: Nullable -> Rul Exp -> (Cat,[Exp]) +nullRule nullset (Rule f c rhs) = (c, map (\xs -> (appMany f xs)) (cross (map nulls rhs))) + where nulls (Right tok) = [] + nulls (Left cat) = lk cat nullset + +nullable :: Nullable -> Rul Exp -> Bool +nullable s = not . null . snd . nullRule s + +nullSet :: CFG Exp -> Nullable +nullSet = fixpointOnGrammar "nullable" (\s r -> uncurry M.singleton (nullRule s r)) + +-- | Replace nullable occurences by nothing, and adapt the function consequently. +delNullable :: Nullable -> Rul Exp -> [Rul Exp] +delNullable nullset r@(Rule f cat rhs) = case rhs of + [] -> [] + [_] -> [r] + [r1,r2] -> [r] ++ [Rule (app' f x) cat [r2] | x <- lk' r1] + ++ [Rule (app2 (isCat r1) f x) cat [r1] | x <- lk' r2] + _ -> error $ "Panic:" ++ show r ++ "should have at most two elements." + where lk' (Right tok) = [] + lk' (Left cat) = lk cat nullset + + +delNull cf = onRules (concatMap (delNullable (nullSet cf))) cf + + +--------------- +-- UNIT + +type UnitRel cat = Set (Either cat String) (Exp,cat) + +-- (c,(f,c')) ∈ unitSet ⇒ f : c → c' + +unitSet :: CFG Exp -> UnitRel Cat +unitSet = fixpointOnGrammar "unit set" unitRule + +unitRule unitSet (Rule f c [r]) = M.singleton r $ (f,c) : [(g `appl` f,c') | (g,c') <- lk (Left c) unitSet] + where appl = case r of + Left _ -> after + Right _ -> app' +unitRule _ _ = M.empty + +isUnitRule (Rule f c [r]) = True +isUnitRule _ = False + + +------------------------ +-- Left/Right occurences + +isOnLeft, isOnRight :: RHSEl -> Rul f -> Bool +isOnLeft c (Rule f _ [c',_]) = c == c' +isOnLeft _ _ = False + +isOnRight c (Rule f _ [_,c']) = c == c' +isOnRight _ _ = False + +isEntryPoint cf el = either (`elem` allEntryPoints cf) (const False) el + +occurs :: (RHSEl -> Rul f -> Bool) -> RHSEl -> CFG f -> Bool +occurs where_ el cf = any (where_ el) (rulesOfCF cf) + +splitLROn :: (a -> RHSEl) -> CFG f -> [a] -> Pair [a] +splitLROn f cf xs = filt <*> pure xs + where filt = filter (\c -> occurs isOnLeft (f c) cf || isEntryPoint cf (f c)) :/: + filter (\c -> occurs isOnRight (f c) cf) + +isSpecial (Left ('@':'@':_)) = True +isSpecial _ = False + +optim :: (a -> RHSEl) -> Pair [a] -> Pair [(a,Doc -> Doc)] +optim f (x:/:y) = map modif x :/: map modif' y + where modif a | isSpecial (f a) = (a,\x -> "(if not p then (" <> x <> ":) else id)") + | otherwise = (a,rob) + modif' a | isSpecial (f a) = (a,\x -> "(if p then (" <> x <> ":) else id)") + | otherwise = (a,rob) + rob x = "("<> x <> ":)" + + +splitOptim f cf xs = optim f $ splitLROn f cf $ xs + + +--------------------------- +-- Error reporting + +-- leftOf C = ⋃ { {X} ∪ leftOf X | C ::= X B ∈ Grammar or C ::= X ∈ Grammar } +leftRight pos s (Rule f c rhs) = M.singleton c (lkCat x s) + where x = pos rhs + +lkCat (Right t) s = [Right t] +lkCat (Left c) s = Left c:lk c s + +-- neighbors A B = ∃ A' B'. A ∈ rightOf A' ∧ B ∈ leftOf B +neighborSet cf = map (second (nub . sort)) $ group' [(x',lkCat y leftSet) | Rule _ _ [x,y] <- rulesOfCF cf, x' <- lkCat x rightSet] + where leftSet = fixpointOnGrammar "left set" (leftRight head) cf + rightSet = fixpointOnGrammar "right set" (leftRight last) cf + +genNeighborSet cf = vcat + ["neighbors " <> catTag x <> " = " <> ppList (map catTag y) + | (x,y) <- neighborSet cf] $$ + "neighbors _ = []" + +ppList = brackets . punctuate' ", " + +------------------------- +-- Code generation + +incomment x = "{-" <> x <> "-}" + +generate opts cf0 = render $ vcat [header opts + ,genShowFunction cf0 + ,genCatTags cf1 + ,genDesc cf1 descriptions + ,genNeighborSet cf1 + ,genCombTable units (onRules (filter (not . isUnitRule)) cf) + ,genTokTable units cf + ,incomment $ vcat + ["Normalised grammar:" + ,text $ show cf + ,"Unit relation:" + ,prettyUnitSet units + ] + ] + where (cf1,cf,units,descriptions) = toCNF cf0 + +class Pretty a where + pretty :: a -> Doc + +instance (Pretty k, Pretty v) => Pretty (Set k v) where + pretty s = sep [pretty k <> " --> " <> pretty v | (k,x) <- M.assocs s, v <- x] + +instance Pretty (Either Cat String) where + pretty (Left x) = text x + pretty (Right x) = quotes $ text x + +instance Pretty String where + pretty = text + +prettyUnitSet units = vcat [prettyExp f <> " : " <> catTag cat <> " --> " <> text cat' | (cat,x) <- M.assocs units, (f,cat') <- x] + +header opts + = vcat ["{-# LANGUAGE MagicHash, FlexibleInstances #-}" + ,"module " <> text (cnfTablesFileM opts) <> " where" + ,"import GHC.Prim" + ,"import GHC.Exts" + ,"import Control.Applicative hiding (Const)" + ,"import Algebra.RingUtils" + ,"import Parsing.Chart ()" + ,"import " <> text (absFileM opts) + ,"import " <> text (alexFileM opts) + ,"import " <> text ( printerFileM opts) + ,"readInteger :: String -> Integer" + ,"readInteger = read" + ,"readDouble :: String -> Double" + ,"readDouble = read" + ,"instance RingP [(CATEGORY,Any)] where" + ," mul p a b = trav [map (app tx ty) l :/: map (app tx ty) r | (x,tx) <- a, (y,ty) <- b, let l:/:r = combine p x y]" + ," where trav :: [Pair [a]] -> Pair [a]" + ," trav [] = pure []" + ," trav (x:xs) = (++) <$> x <*> trav xs" + ," app tx ty (z,f) = (z, f tx ty)" + ] + +punctuate' p = cat . punctuate p + +genShowFunction cf = hang "showAst (cat,ast) = case cat of " 6 + (vcat [catTag (Left cat) <> " -> printTree ((unsafeCoerce# ast)::" <> text cat <> ")" + | cat <- filter isDataCat $ allCats cf] $$ + "_ -> \"Unprintable category\"") + + +genCatTags :: CFG Exp -> Doc +genCatTags cf = "data CATEGORY = " <> punctuate' "|" (map catTag (allSyms cf)) $$ + " deriving (Eq,Ord,Show)" + +genDesc :: CFG Exp -> CatDescriptions -> Doc +genDesc cf descs = vcat ["describe " <> catTag s <> " = " <> doubleQuotes (descOf s) | s <- allSyms cf] + where descOf (Right x) = "token " <> text x + descOf (Left x) = maybe (text x) id $ M.lookup x descs + + + +genCombTable :: UnitRel Cat -> CFG Exp -> Doc +genCombTable units cf = + "combine :: Bool -> CATEGORY -> CATEGORY -> Pair [(CATEGORY, Any -> Any -> Any)]" + $$ genCombine units cf + $$ "combine _ _ _ = pure []" + +allSyms :: CFG Exp -> [Either String String] +allSyms cf = map Left (allCats cf ++ literals cf) ++ map (Right . fst) (cfTokens cf) + + +ppPair (x,y) = parens $ x <> comma <> " " <> y + +unsafeCoerce' = app' (Con "unsafeCoerce#") + +type RHSEl = Either Cat String + +isCat (Right _) = False +isCat (Left _) = True + +group0 :: Eq a => [(a,[b])] -> [(a,[b])] +group0 [] = [] +group0 ((a,bs):xs) = (a,bs ++ concatMap snd ys) : group0 zs + where (ys,zs) = span (\x -> fst x == a) xs + +group' :: Ord a => [(a,[b])] -> [(a,[b])] +group' = group0 . sortBy (compare `on` fst) + +prettyPair (x :/: y) = sep [x,":/:",y] +prettyListFun xs = parens $ sep (map (<> "$") xs) <> "[]" + + +genCombine :: UnitRel Cat -> CFG Exp -> Doc +genCombine units cf = vcat $ map genEntry $ group' $ map (alt units) (rulesOfCF cf) + where genEntry :: ((RHSEl,RHSEl),[(Cat,Exp)]) -> Doc + genEntry ((r1,r2),cs) = "combine p " <> catTag r1 <> " " <> catTag r2 <> " = " <> prettyPair (genList <$> splitOptim (Left . fst) cf cs) + mkLam body = "\\x y -> " <> body + genList xs = prettyListFun [p (ppPair (catTag . Left $ x, mkLam . prettyExp . unsafeCoerce' $ y)) | ((x,y),p) <- xs] + +alt :: UnitRel Cat -> Rul Exp -> ((RHSEl,RHSEl),[(Cat,Exp)]) +alt units (Rule f c [r1,r2]) = ((r1,r2),initial:others) + where initial = (c, f `appMany` args) + others = [(c', f' `app'` (f `appMany` args)) | (f',c') <- lk (Left c) units] + args = map (unsafeCoerce' . Con) $ ["x"|isCat r1]++["y"|isCat r2] + + +catTag :: Either String String -> Doc +catTag (Left c) = "CAT_" <> text (concatMap escape c) +catTag (Right t) = "TOK_" <> text (concatMap escape t) + +escape c | isAlphaNum c || c == '_' = [c] +escape '[' = "" +escape ']' = "_List" +escape '{' = "OPEN_" +escape '}' = "CLOS_" +escape '@' = "BIN_" +escape c = show $ ord c + +genTokTable :: UnitRel Cat -> CFG Exp -> Doc +genTokTable units cf = "tokenToCats :: Bool -> Token -> Pair [(CATEGORY,Any)]" $$ + vcat (map (genSpecEntry cf units) (tokInfo cf)) $$ + vcat (map (genTokEntry cf units) (cfTokens cf)) $$ + "tokenToCats p t = error (\"unknown token: \" ++ show t)" + +tokInfo cf = ("Char","TC",Con "head"): + ("String","TL",Id):("Integer","TI",Con "readInteger"): + ("Double","TD",Con "readDouble"): + [("Ident","TV",Con "Ident")|hasIdent cf] ++ + [(t,"T_" <> text t,(Con t)) | t <- tokenNames cf] + +genTokCommon cf xs = prettyPair (gen <$> splitOptim fst cf xs) + where gen ys = prettyListFun [p (ppPair (catTag x,y)) | ((x,y),p) <- ys] + +genSpecEntry cf units (tokName,constrName,fun) = "tokenToCats p (PT (Pn _ l c) (" <> constrName <> " x)) = " <> genTokCommon cf xs + where xs = map (second (prettyExp . (\f -> unsafeCoerce' (f `app'` tokArgs)))) $ + (Left tokName, fun) : [(Left c,f `after` fun) | (f,c) <- lk (Left tokName) units] + tokArgs | isPositionCat cf tokName = Con "((l,c),x)" + | otherwise = Con "x" + +genTokEntry cf units (tok,x) = + " -- " <> text tok $$ + "tokenToCats p (PT posn (TS _ " <> int x <> ")) = " <> genTokCommon cf xs + where xs = (Right tok, tokVal) : + [(Left c,prettyExp (unsafeCoerce' f)) | (f,c) <- lk (Right tok) units] + tokVal = "error" <> (text $ show $ "cannot access value of token: " ++ tok) + +------------------------ +-- Test file generation + +genTestFile opts cf = render $ vcat + ["module Main where" + ,"import " <> text ( alexFileM opts) + ,"import " <> text ( cnfTablesFileM opts) + ,"import Parsing.TestProgram" + ,"main = mainTest showAst tokenToCats tokens tokenLineCol describe neighbors"] + + +genBenchmark opts = render $ vcat + ["import System.Environment ( getArgs )" + ,"import "<> text ( alexFileM opts) <> " as Lexer" + ,"import "<> text ( cnfTablesFileM opts) <> " as Parser" + ,"import GHC.Exts" + ,"import Parsing.Chart" + ,"import Criterion.Main" + ,"import Algebra.RingUtils" + ,"import Control.Applicative" + ,"type T = [(CATEGORY,Any)]" + ,"pLGrammar :: [Pair T] -> MT2 T" + ,"pLGrammar = mkTree" + ,"main = do" + ," f:_ <- getArgs" + ," s <- readFile f" + ," let ts = zipWith tokenToCats (cycle [False,True]) (Lexer.tokens s)" + ," (ts1,x:ts2) = splitAt (length ts `div` 2) ts" + ," cs = [mkTree ts1,mkTree' ts2]" + ," work [c1,c2] = show $ map fst $ root $ mergein False c1 x c2" + ," defaultMain [bench f $ nf work cs] -- note the hack!!!" + ] + + + +--------------------------------- +-- Management of expressions. + +-- Most of this is not strictly useful; its main purpose is to +-- generate "nice-looking" semantic actions + +data Exp = Id -- identity function + | Con String -- constructor or variable + | App Exp Exp + | Exp `After` Exp + | App2 Exp Exp + deriving (Eq,Ord) + +prettyExp Id = "id" +prettyExp (Con x) = text x +prettyExp (App f x) = prettyExp f <+> (parens $ prettyExp x) +prettyExp (App2 f x) = "flip" <+> parens (prettyExp f) <+> parens (prettyExp x) +prettyExp (f `After` g) = parens (prettyExp f) <> "." <> parens (prettyExp g) + +instance Show Exp where show = render . prettyExp + +-- | Apply in 2nd position if the flag is true, otherwise apply normally. +app2 True f x = App2 f x +app2 False f x = app' f x + +infixl `app'` +app' :: Exp -> Exp -> Exp +app' (f `After` g) x = app' f (app' g x) +app' Id x = x +app' (App2 f y) x = (f `app'` x) `app'` y +app' (Con "($)") f = f +-- app' (Con "const") f = f +app' f x = App f x + +toExp f | isCoercion f = Id + | otherwise = Con f + +after :: Exp -> Exp -> Exp +after Id f = f +after f Id = f +after f g = f `After` g + + +appMany f args = foldl app' f args diff --git a/src/formats/java/CFtoCup.hs b/src/formats/java/CFtoCup.hs new file mode 100644 --- /dev/null +++ b/src/formats/java/CFtoCup.hs @@ -0,0 +1,282 @@ +{- + BNF Converter: Java Cup Generator + Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the CUP input file. It + follows the same basic structure of CFtoHappy. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 26 April, 2003 + + Modified : 2 September, 2003 + + + ************************************************************** +-} +module CFtoCup ( cf2Cup ) where + +import CF +import Data.List (intersperse, isPrefixOf) +import Data.Char (isUpper) +import NamedVariables +import TypeChecker -- We need to (re-)typecheck to figure out list instances in + -- defined rules. +import ErrM +import Utils ( (+++) ) + +-- Type declarations +type Rules = [(NonTerminal,[(Pattern,Action)])] +type NonTerminal = String +type Pattern = String +type Action = String +type MetaVar = String + +--The environment comes from the CFtoJLex +cf2Cup :: String -> String -> CF -> SymEnv -> String +cf2Cup packageBase packageAbsyn cf env = unlines + [ + header, + declarations packageAbsyn (allCats cf), + tokens env, + specialToks cf, + specialRules cf, + prEntryPoint cf, + prRules (rulesForCup packageAbsyn cf env) + ] + where + header :: String + header = unlines + ["// -*- Java -*- This Cup file was machine-generated by BNFC", + "package" +++ packageBase ++ ";", + "", + "import java_cup.runtime.*;", + "import" +++ packageAbsyn ++ ".*;", + "", + "parser code {:", + parseMethod packageAbsyn (firstEntry cf), + definedRules packageAbsyn cf, + -- unlines $ map (parseMethod packageAbsyn) (allEntryPoints cf), + "public void syntax_error(Symbol cur_token)", + "{", + "\treport_error(\"Syntax Error, trying to recover and continue parse...\", cur_token);", + "}", + "", + "public void unrecovered_syntax_error(Symbol cur_token) throws java.lang.Exception", + "{", + "\tthrow new Exception(\"Unrecoverable Syntax Error\");", + "}", + "", + ":}" + ] + +definedRules :: String -> CF -> String +definedRules packageAbsyn cf = + unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ] + where + ctx = buildContext cf + + list = LC (const "null") (\t -> "List" ++ unBase t) + where + unBase (ListT t) = unBase t + unBase (BaseT x) = normCat x + + rule f xs e = + case checkDefinition' list ctx f xs e of + Bad err -> error $ "Panic! This should have been caught already:\n" ++ err + Ok (args,(e',t)) -> unlines + [ "public " ++ javaType t ++ " " ++ f ++ "_ (" ++ + concat (intersperse ", " $ map javaArg args) ++ ") {" + , " return " ++ javaExp e' ++ ";" + , "}" + ] + where + + javaType :: Base -> String + javaType (ListT (BaseT x)) = packageAbsyn ++ ".List" ++ normCat x + javaType (ListT t) = javaType t + javaType (BaseT x) + | isToken x ctx = "String" + | otherwise = packageAbsyn ++ "." ++ normCat x + + javaArg :: (String, Base) -> String + javaArg (x,t) = javaType t ++ " " ++ x ++ "_" + + javaExp :: Exp -> String + javaExp (App "null" []) = "null" + javaExp (App x []) + | elem x xs = x ++ "_" -- argument + javaExp (App t [e]) + | isToken t ctx = call ("new String") [e] + javaExp (App x es) + | isUpper (head x) = call ("new " ++ packageAbsyn ++ "." ++ x) es + | otherwise = call (x ++ "_") es + javaExp (LitInt n) = "new Integer(" ++ show n ++ ")" + javaExp (LitDouble x) = "new Double(" ++ show x ++ ")" + javaExp (LitChar c) = "new Character(" ++ show c ++ ")" + javaExp (LitString s) = "new String(" ++ show s ++ ")" + + call x es = x ++ "(" ++ concat (intersperse ", " $ map javaExp es) ++ ")" + +-- peteg: FIXME JavaCUP can only cope with one entry point AFAIK. +prEntryPoint :: CF -> String +prEntryPoint cf = unlines ["", "start with " ++ firstEntry cf ++ ";", ""] +-- [ep] -> unlines ["", "start with " ++ ep ++ ";", ""] +-- eps -> error $ "FIXME multiple entry points." ++ show eps + +--This generates a parser method for each entry point. +parseMethod :: String -> Cat -> String +parseMethod packageAbsyn cat = + if normCat cat /= cat + then "" + else unlines + [ + " public" +++ packageAbsyn ++ "." ++ cat' +++ "p" ++ cat' ++ "()" + ++ " throws Exception", + " {", + "\tSymbol res = parse();", + "\treturn (" ++ packageAbsyn ++ "." ++ cat' ++ ") res.value;", + " }" + ] + where cat' = identCat (normCat cat) + +--non-terminal types +declarations :: String -> [NonTerminal] -> String +declarations packageAbsyn ns = unlines (map (typeNT packageAbsyn) ns) + where + typeNT _nm nt = "nonterminal" +++ packageAbsyn ++ "." + ++ identCat (normCat nt) +++ identCat nt ++ ";" + +--terminal types +tokens :: SymEnv -> String +tokens ts = unlines (map declTok ts) + where + declTok (s,r) = "terminal" +++ r ++ "; // " ++ s + +specialToks :: CF -> String +specialToks cf = unlines [ + ifC "String" "terminal String _STRING_;", + ifC "Char" "terminal Character _CHAR_;", + ifC "Integer" "terminal Integer _INTEGER_;", + ifC "Double" "terminal Double _DOUBLE_;", + ifC "Ident" "terminal String _IDENT_;" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + +-- This handles user defined tokens +-- FIXME +specialRules:: CF -> String +specialRules cf = + unlines ["terminal String " ++ name ++ ";" | (name, _) <- tokenPragmas cf] + +--The following functions are a (relatively) straightforward translation +--of the ones in CFtoHappy.hs +rulesForCup :: String -> CF -> SymEnv -> Rules +rulesForCup packageAbsyn cf env = map mkOne $ ruleGroups cf where + mkOne (cat,rules) = constructRule packageAbsyn cf env rules cat + +-- For every non-terminal, we construct a set of rules. A rule is a sequence of +-- terminals and non-terminals, and an action to be performed. +constructRule :: String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule packageAbsyn cf env rules nt = + (nt, [(p,generateAction packageAbsyn nt (funRule r) (revM b m)) + | r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True, revSepListRule r0) + else (False, r0) + (p,m) = generatePatterns cf env r]) + where + --this basically reverses revSepListRule for the parameters + revM False m = m + revM True (h:c:t) = (t ++ [c] ++ [h]) + revs = reversibleCats cf + +-- Generates a string containing the semantic action. +generateAction :: String -> NonTerminal -> Fun -> [MetaVar] -> Action +generateAction packageAbsyn nt f ms = + if isNilFun f + then "RESULT = null;" + else if isOneFun f + then "RESULT = new " ++ packageAbsyn ++ "." ++ identCat (normCat nt) ++ + (concat $ ["("] ++ ms ++ [",null);"]) + else + (unwords $ + (if isCoercion f then [unwords revLists, "RESULT = "] + else if isDefinedRule f then [unwords revLists, "RESULT = parser." ++ f ++ "_"] + else [unwords revLists, "RESULT = new " ++ packageAbsyn ++ "." ++ f'] + )) + ++ (concat $ ["("] ++ ms'' ++ [");"]) + where + f' = if isConsFun f then identCat (normCat nt) + else f + (revLists, ms') = revMs [] [] ms + ms'' = reverse ms' + revMs ls ns [] = (ls,ns) + revMs ls ns (m:ms) = if "list_" `isPrefixOf` m + then revMs (("if (" ++ m' ++ " != null) " ++ m' ++ " = " ++ m' ++ ".reverse(); ") : ls) + (m' : ns) ms + else revMs ls (m:ns) ms + where m' = drop 5 m --remove the list marker + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal +generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar]) +generatePatterns cf env r = case rhsRule r of + [] -> (" /* empty */ ",[]) + its -> (mkIt env 1 its, metas its) + where + mkIt _env _n [] = [] + mkIt env n (i:is) = case i of + Left c -> c' ++ ":p_" ++ (show (n :: Int)) +++ (mkIt env (n+1) is) + where + c' = case c of + "Ident" -> "_IDENT_" + "Integer" -> "_INTEGER_" + "Char" -> "_CHAR_" + "Double" -> "_DOUBLE_" + "String" -> "_STRING_" + _ -> identCat c + Right s -> case (lookup s env) of + (Just x) -> x +++ (mkIt env (n+1) is) + (Nothing) -> (mkIt env n is) + metas its = intersperse "," [revIf c ("p_" ++ (show i)) | (i,Left c) <- zip [1 :: Int ..] its] + --This is slightly messy, but it marks lists for reversal. + revIf c m = if (not (isConsFun (funRule r)) && elem c revs) + then "list_" ++ m -- ("(reverse " ++ m ++ ")") --not yet! + else m -- no reversal in the left-recursive Cons rule itself + revs = reversibleCats cf + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. +prRules :: Rules -> String +prRules [] = [] +prRules ((nt, []):rs) = prRules rs --internal rule +prRules ((nt,((p,a):ls)):rs) = + (unwords [nt', "::=", p, "{:", a, ":}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{:", a , ":}"])]) ++ pr ls + diff --git a/src/formats/java/CFtoJLex.hs b/src/formats/java/CFtoJLex.hs new file mode 100644 --- /dev/null +++ b/src/formats/java/CFtoJLex.hs @@ -0,0 +1,174 @@ +{- + BNF Converter: Java JLex generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the JLex input file. This + file is quite different than Alex or Flex. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 25 April, 2003 + + Modified : 2 September, 2003 + + + ************************************************************** +-} + +module CFtoJLex ( cf2jlex ) where + +import CF +import RegToJLex +import Utils ( (+++) ) +import NamedVariables +import Data.List + +--The environment must be returned for the parser to use. +cf2jlex :: String -> String -> CF -> (String, SymEnv) +cf2jlex packageBase packageAbsyn cf = (unlines $ concat $ + [ + prelude packageBase packageAbsyn, + cMacros, + lexSymbols env, + restOfJLex cf + ], env) + where + env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) + makeSymEnv [] _ = [] + makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) + +prelude :: String -> String -> [String] +prelude packageBase packageAbsyn = + [ + "// This JLex file was machine-generated by the BNF converter", + "package" +++ packageBase ++ ";", + "", + "import java_cup.runtime.*;", + "import " ++ packageAbsyn ++ ".*;", + "%%", + "%cup", + "%full", + "%line", + "%{", + " String pstring = new String();", + " public int line_num() { return (yyline+1); }", + " public String buff() { return new String(yy_buffer,yy_buffer_index,10).trim(); }", + "%}" + ] + +--For now all categories are included. +--Optimally only the ones that are used should be generated. +cMacros :: [String] +cMacros = [ + "LETTER = ({CAPITAL}|{SMALL})", + "CAPITAL = [A-Z\\xC0-\\xD6\\xD8-\\xDE]", + "SMALL = [a-z\\xDF-\\xF6\\xF8-\\xFF]", + "DIGIT = [0-9]", + "IDENT = ({LETTER}|{DIGIT}|['_])", + "%state COMMENT", + "%state CHAR", + "%state CHARESC", + "%state CHAREND", + "%state STRING", + "%state ESCAPED", + "%%" + ] + +lexSymbols :: SymEnv -> [String] +lexSymbols ss = map transSym ss + where + transSym (s,r) = + "" ++ (escapeChars s) ++ " { return new Symbol(sym." + ++ r ++ "); }" + +restOfJLex :: CF -> [String] +restOfJLex cf = + [ + lexComments (comments cf), + userDefTokens, + ifC "String" strStates, + ifC "Char" chStates, + ifC "Double" "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }", + ifC "Integer" "{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }", + ifC "Ident" "{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, new String(yytext())); }" + , "[ \\t\\r\\n\\f] { /* ignore white space. */ }" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + userDefTokens = unlines $ + ["" ++ printRegJLex exp +++ + "{ return new Symbol(sym." ++ name ++ ", yytext()); }" + | (name, exp) <- tokenPragmas cf] + strStates = unlines --These handle escaped characters in Strings. + [ + "\"\\\"\" { yybegin(STRING); }", + "\\\\ { yybegin(ESCAPED); }", + "\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo); }", + ". { pstring += yytext(); }", + "n { pstring += \"\\n\"; yybegin(STRING); }", + "\\\" { pstring += \"\\\"\"; yybegin(STRING); }", + "\\\\ { pstring += \"\\\\\"; yybegin(STRING); }", + "t { pstring += \"\\t\"; yybegin(STRING); }", + ". { pstring += yytext(); yybegin(STRING); }" + ] + chStates = unlines --These handle escaped characters in Chars. + [ + "\"'\" { yybegin(CHAR); }", + "\\\\ { yybegin(CHARESC); }", + "[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", + "n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }", + "t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }", + ". { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", + "\"'\" {yybegin(YYINITIAL);}" + ] + + + + +lexComments :: ([(String, String)], [String]) -> String +lexComments (m,s) = + (unlines (map lexSingleComment s)) + ++ (unlines (map lexMultiComment m)) + +lexSingleComment :: String -> String +lexSingleComment c = + "\"" ++ c ++ "\"[^\\n]*\\n { /* BNFC single-line comment */ }" + +--There might be a possible bug here if a language includes 2 multi-line comments. +--They could possibly start a comment with one character and end it with another. +--However this seems rare. +lexMultiComment :: (String, String) -> String +lexMultiComment (b,e) = unlines [ + "\"" ++ b ++ "\" { yybegin(COMMENT); }", + "\"" ++ e ++ "\" { yybegin(YYINITIAL); }", + ". { }", + "[\\n] { }" + ] + +-- lexReserved :: String -> String +-- lexReserved s = "\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }" + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars = concatMap escapeChar diff --git a/src/formats/java/CFtoJavaAbs.hs b/src/formats/java/CFtoJavaAbs.hs new file mode 100644 --- /dev/null +++ b/src/formats/java/CFtoJavaAbs.hs @@ -0,0 +1,238 @@ +{- + BNF Converter: Java Abstract Syntax + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Java Abstract Syntax + It uses the NamedVariables module for variable + naming. It returns a list of file names, and the + contents to be written into that file. (In Java + public classes must go in their own file.) + + The generated classes also support the Visitor + Design Pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 24 April, 2003 + + Modified : 2 September, 2003 + + + ************************************************************** +-} + +module CFtoJavaAbs (cf2JavaAbs) where + +import CF +import Utils((+++),(++++)) +import NamedVariables hiding (IVar, getVars, varName) +import Data.List +import Data.Char(toLower) + +--Produces abstract data types in Java. +--These follow Appel's "non-object oriented" version. +--They also allow users to use the Visitor design pattern. + +type IVar = (String, Int, String) +--The type of an instance variable +--a # unique to that type +--and an optional name (handles typedefs). + +--The result is a list of files which must be written to disk. +--The tuple is (FileName, FileContents) +cf2JavaAbs :: String -> String -> CF -> [(FilePath, String)] +cf2JavaAbs packageBase packageAbsyn cf = + concat (map (prData header packageBase user) (cf2dataLists cf)) + where + header = "package " ++ packageAbsyn ++ "; // Java Package generated by the BNF Converter.\n" + user = [n | (n,_) <- tokenPragmas cf] + +--Generates a (possibly abstract) category class, and classes for all its rules. +prData :: String -> String -> [UserDef] -> Data ->[(String, String)] +prData header name user (cat, rules) = + (identCat cat, header ++++ + "public abstract class" +++ (identCat cat) +++ "implements" +++ name ++ ".Visitable {}\n") : + prRules header name user cat rules --don't use map because some will be Nil + where + prRules h n u c [] = [] --this is basically a map which excludes Nil values. + prRules h n u c (f:fs) = case res of + ("","") -> prRules h n u c fs + z -> res : (prRules h n u c fs) + where res = prRule h n u c f + +--Generates classes for a rule, depending on what type of rule it is. +prRule h name user c (fun, cats) = + if isNilFun fun || isOneFun fun + then ("","") --these are not represented in the AbSyn + else if isConsFun fun + then (fun', --this is the linked list case. + unlines + [ + h, + "public class" +++ fun' +++ "implements"+++ name ++ ".Visitable", + "{", + (prInstVars vs), + prConstructor fun' user vs cats, + prListFuncs fun', + prAccept name fun', + "}" + ]) + else (fun, --a standard rule + unlines + [ + h, + "public class" +++ fun +++ ext +++ "implements"+++ name ++ ".Visitable", + "{", + (prInstVars vs), + prConstructor fun user vs cats, + prAccept name fun, + "}\n" + ]) + where + vs = getVars cats user + fun' = identCat (normCat c) + --This handles the case where a LBNF label is the same as the category. + ext = if fun == c then "" else "extends" +++ (identCat c) + +--These are all built-in list functions. +--Later we could include things like lookup,insert,delete,etc. +prListFuncs :: String -> String +prListFuncs c = unlines + [ + " public" +++ c +++ "reverse()", + " {", + " if (" ++ v +++ "== null) return this;", + " else", + " {", + " " ++ c ++ " tmp =" +++ v ++ ".reverse(this);", + " " ++ v +++ "= null;", + " return tmp;", + " }", + " }", + " public" +++ c +++ "reverse(" ++ c +++ "prev)", + " {", + " if (" ++ v +++ "== null)", + " {", + " " ++ v +++ "= prev;", + " return this;", + " }", + " else", + " {", + " " ++ c +++ "tmp =" +++ v ++ ".reverse(this);", + " " ++ v +++ "= prev;", + " return tmp;", + " }", + " }" + ] + where + v = (map toLower c) ++ "_" + +--The standard accept function for the Visitor pattern +prAccept :: String -> String -> String +prAccept pack ty = + "\n public void accept(" ++ pack ++ ".Visitor v) { v.visit" ++ ty ++ "(this); }" + +--A class's instance variables. +prInstVars :: [IVar] -> String +prInstVars [] = [] +prInstVars vars@((t,n,nm):vs) = + " public" +++ t +++ uniques ++ ";" ++++ + (prInstVars vs') + where + (uniques, vs') = prUniques t vars + --these functions group the types together nicely + prUniques :: String -> [IVar] -> (String, [IVar]) + prUniques t vs = (prVars (findIndices (\x -> case x of (y,_,_) -> y == t) vs) vs, remType t vs) + prVars (x:[]) vs = case vs !! x of + (t,n,nm) -> ((varName t nm) ++ (showNum n)) + prVars (x:xs) vs = case vs !! x of + (t,n,nm) -> ((varName t nm) ++ (showNum n)) ++ "," +++ + (prVars xs vs) + remType :: String -> [IVar] -> [IVar] + remType _ [] = [] + remType t ((t2,n,nm):ts) = if t == t2 + then (remType t ts) + else (t2,n,nm) : (remType t ts) + +--The constructor just assigns the parameters to the corresponding instance variables. +prConstructor :: String -> [UserDef] -> [IVar] -> [Cat] -> String +prConstructor c u vs cats = + " public" +++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" +++ + prAssigns vs params ++ "}" + where + (types, params) = unzip (prParams cats u (length cats) ((length cats)+1)) + interleave _ [] = [] + interleave (x:[]) (y:[]) = x +++ y + interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys) + +--Prints the parameters to the constructors. +prParams :: [Cat] -> [UserDef] -> Int -> Int -> [(String,String)] +prParams [] _ _ _ = [] +prParams (c:cs) u n m = (identCat c',"p" ++ (show (m-n))) + : (prParams cs u (n-1) m) + where + c' = typename c u + +--This algorithm peeks ahead in the list so we don't use map or fold +prAssigns :: [IVar] -> [String] -> String +prAssigns [] _ = [] +prAssigns _ [] = [] +prAssigns ((t,n,nm):vs) (p:ps) = + if n == 1 then + case findIndices (\x -> case x of (l,r,_) -> l == t) vs of + [] -> (varName t nm) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + z -> ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + else ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + +--Different than the standard NamedVariables version because of the user-defined +--types. +getVars :: [Cat] -> [UserDef] -> [IVar] +getVars cs user = foldl (addVar user) [] (map identCat cs) + where + addVar user vs c = addVar' vs user 0 c + addVar' [] u n c = [(c', n, nm)] + where + c' = typename c user + nm = if c == c' then "" else c + addVar' (i@(t,x,nm):is) u n c = + if c == t || c == nm + then if x == 0 + then (t, 1, nm) : (addVar' is u 2 c) + else i : (addVar' is u (x+1) c) + else i : (addVar' is u n c) + + +varName c s = (map toLower c') ++ "_" + where + c' = if s == "" then c else s + +--This makes up for the fact that there's no typedef in Java +typename t user = + if t == "Ident" + then "String" + else if t == "Char" + then "Character" + else if elem t user + then "String" + else t diff --git a/src/formats/java/CFtoJavaPrinter.hs b/src/formats/java/CFtoJavaPrinter.hs new file mode 100644 --- /dev/null +++ b/src/formats/java/CFtoJavaPrinter.hs @@ -0,0 +1,367 @@ +{- + BNF Converter: Java Pretty Printer generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Java Pretty Printer + class. In addition, since there's no good way + to display a class heirarchy (toString() doesn't + count) in Java, it generates a method that + displays the Abstract Syntax in a way similar + to Haskell. + + This uses Appel's method and may serve as a + useful example to those who wish to use it. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 24 April, 2003 + + Modified : 2 September, 2003 + + Added string buffer for efficiency (Michael, August 03) + ************************************************************** +-} +module CFtoJavaPrinter ( cf2JavaPrinter ) where + +import CF +import NamedVariables +import Utils ( (+++) ) +import Data.List +import Data.Char ( toLower ) + +--Produces the PrettyPrinter class. +--It will generate two methods "print" and "show" +--print is the actual pretty printer for linearization. +--show produces a Haskell-style syntax that can be extremely useful +--especially for testing parser correctness. + +cf2JavaPrinter :: String -> String -> CF -> String +cf2JavaPrinter packageBase packageAbsyn cf = + unlines + [ + header, + prEntryPoints packageAbsyn cf, + unlines (map (prData packageAbsyn) groups), + unlines (map (shData packageAbsyn) groups), + footer + ] + where + groups = (fixCoercions (ruleGroupsInternals cf)) + header = unlines [ + "package" +++ packageBase ++ ";", + "import" +++ packageAbsyn ++ ".*;", + "", + "public class PrettyPrinter", + "{", + " //For certain applications increasing the initial size of the buffer may improve performance.", + " private static final int INITIAL_BUFFER_SIZE = 128;", + " //You may wish to change the parentheses used in precedence.", + " private static final String _L_PAREN = new String(\"(\");", + " private static final String _R_PAREN = new String(\")\");", + prRender + ] + footer = unlines [ --later only include used categories + " private static void pp(Integer n, int _i_) { buf_.append(n); buf_.append(\" \"); }", + " private static void pp(Double d, int _i_) { buf_.append(d); buf_.append(\" \"); }", + " private static void pp(String s, int _i_) { buf_.append(s); buf_.append(\" \"); }", + " private static void pp(Character c, int _i_) { buf_.append(\"'\" + c.toString() + \"'\"); buf_.append(\" \"); }", + " private static void sh(Integer n) { buf_.append(n); }", + " private static void sh(Double d) { buf_.append(d); }", + " private static void sh(Character c) { buf_.append(c); }", + " private static void sh(String s) { printQuoted(s); }", + " private static void printQuoted(String s) { buf_.append(\"\\\"\" + s + \"\\\"\"); }", + " private static void indent()", + " {", + " int n = _n_;", + " while (n > 0)", + " {", + " buf_.append(\" \");", + " n--;", + " }", + " }", + " private static void backup()", + " {", + " String s = buf_.toString();", -- peteg: java 1.1.8 compatibility. + "", + " if (s.substring(buf_.length() - 1, buf_.length()).equals(\" \")) {", + " buf_.setCharAt(buf_.length() - 1, '\\\"');", + " buf_.setLength(buf_.length() - 1);", + " }", + " }", + " private static int _n_ = 0;", + " private static StringBuffer buf_ = new StringBuffer(INITIAL_BUFFER_SIZE);", + "}" + ] + +--An extremely simple renderer for terminals. +prRender :: String +prRender = unlines + [ + " //You may wish to change render", + " private static void render(String s)", + " {", + " if (s.equals(\"{\"))", + " {", + " buf_.append(\"\\n\");", + " indent();", + " buf_.append(s);", + " _n_ = _n_ + 2;", + " buf_.append(\"\\n\");", + " indent();", + " }", + " else if (s.equals(\"(\") || s.equals(\"[\"))", + " buf_.append(s);", + " else if (s.equals(\")\") || s.equals(\"]\"))", + " {", + " backup();", + " buf_.append(s);", + " buf_.append(\" \");", + " }", + " else if (s.equals(\"}\"))", + " {", + " _n_ = _n_ - 2;", + " backup();", + " backup();", + " buf_.append(s);", + " buf_.append(\"\\n\");", + " indent();", + " }", + " else if (s.equals(\",\"))", + " {", + " backup();", + " buf_.append(s);", + " buf_.append(\" \");", + " }", + " else if (s.equals(\";\"))", + " {", + " backup();", + " buf_.append(s);", + " buf_.append(\"\\n\");", + " indent();", + " }", + " else if (s.equals(\"\")) return;", + " else", + " {", + " buf_.append(s);", + " buf_.append(\" \");", + " }", + " }" + ] + +prEntryPoints :: String -> CF -> String +prEntryPoints packageAbsyn cf = + msg ++ concat (map prEntryPoint (allEntryPoints cf)) ++ msg2 + where + msg = " // print and show methods are defined for each Entry Point type.\n" + msg2 = " /*** You shouldn't need to change anything beyond this point. ***/\n" + prEntryPoint cat | (normCat cat) == cat = unlines + [ + " public static String print(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)", + " {", + " pp(foo, 0);", + " String temp = buf_.toString();", + " buf_ = new StringBuffer(INITIAL_BUFFER_SIZE);", + " return temp;", + " }", + " public static String show(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)", + " {", + " sh(foo);", + " String temp = buf_.toString();", + " buf_ = new StringBuffer(INITIAL_BUFFER_SIZE);", + " return temp;", + " }" + ] + where + cat' = identCat cat + prEntryPoint _ = "" + +prData :: String -> (Cat, [Rule]) -> String +prData packageAbsyn (cat, rules) = + if isList cat + then unlines + [ + " private static void pp(" ++ packageAbsyn ++ "." + ++ identCat (normCat cat) +++ "foo, int _i_)", + " {", + (prList cat rules) ++ " }" + ] + else unlines --not a list + [ + " private static void pp(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo, int _i_)", + " {", + (concat (map (prRule packageAbsyn) rules)) ++ " }" + ] + +prRule :: String -> Rule -> String +prRule packageAbsyn r@(Rule fun _c cats) + | not (isCoercion fun) && not (isDefinedRule fun) = concat + [ + " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")\n", + " {\n", + " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= (" + ++ packageAbsyn ++ "." ++ fun ++ ") foo;\n", + lparen, + cats', + rparen, + " }\n" + ] + where + p = precRule r + (lparen, rparen) = + (" if (_i_ > " ++ (show p) ++ ") render(_L_PAREN);\n", + " if (_i_ > " ++ (show p) ++ ") render(_R_PAREN);\n") + cats' = case cats of + [] -> "" + _ -> concatMap (prCat fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats)) + fnm = '_' : map toLower fun + + getPrec (Right {}) = 0 + getPrec (Left c) = precCat c + +prRule _nm _ = "" + +prList :: Cat -> [Rule] -> String +prList c rules = unlines + [ + " while (foo != null)", + " {", + " if (foo." ++ c'' ++ "_ == null)", + " {", + " pp(foo." ++ c' ++ "_, 0);", + optsep, + " }", + " else", + " {", + " pp(foo." ++ c' ++ "_, 0);", + " render(\"" ++ (escapeChars sep) ++ "\");", + " }", + " foo = foo." ++ c'' ++ "_;", + " }" + ] + where + c' = map toLower (identCat (normCatOfList c)) + c'' = map toLower (identCat c) + sep = getCons rules + optsep = if hasOneFunc rules then "" else (" render(\"" ++ (escapeChars sep) ++ "\");") + +prCat fnm (c, p) = + case c of + Right t -> " render(\"" ++ escapeChars t ++ "\");\n" + Left nt | "string" `isPrefixOf` nt + -> " printQuoted(" ++ fnm ++ "." ++ nt ++ ");\n" + | isInternalVar nt -> "" + | otherwise + -> " pp(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");\n" + +--The following methods generate the Show function. + +shData :: String -> (Cat, [Rule]) -> String +shData packageAbsyn (cat, rules) = + if isList cat + then unlines + [ + " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)", + " {", + (shList cat rules) ++ " }" + ] + else unlines + [ + " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)", + " {", + (concat (map (shRule packageAbsyn) rules)) ++ " }" + ] + +shRule :: String -> Rule -> String +shRule packageAbsyn (Rule fun _c cats) + | not (isCoercion fun) && not (isDefinedRule fun) = unlines + [ + " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")", + " {", + " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= (" + ++ packageAbsyn ++ "." ++ fun ++ ") foo;", + members ++ " }" + ] + where + members = concat + [ + lparen, + " render(\"" ++ (escapeChars fun) ++ "\");\n", + cats', + rparen + ] + cats' = if allTerms cats + then "" + else (concat (map (shCat fnm) (fixOnes (numVars [] cats)))) + (lparen, rparen) = + if allTerms cats + then ("","") + else (" render(\"(\");\n"," render(\")\");\n") + allTerms [] = True + allTerms ((Left {}):_) = False + allTerms (_:zs) = allTerms zs + fnm = '_' : map toLower fun +shRule _nm _ = "" + +shList :: Cat -> [Rule] -> String +shList c _rules = unlines + [ + " while (foo != null)", + " {", + " if (foo." ++ c'' ++ "_ == null)", + " {", + " sh(foo." ++ c' ++ "_);", + " }", + " else", + " {", + " sh(foo." ++ c' ++ "_);", + " render(\",\");", + " }", + " foo = foo." ++ c'' ++ "_;", + " }" + ] + where + c' = map toLower (identCat (normCatOfList c)) + c'' = map toLower (identCat c) + + +shCat fnm c = + case c of + Right {} -> "" + Left nt | "list" `isPrefixOf` nt + -> unlines [" render(\"[\");", + " sh(" ++ fnm ++ "." ++ nt ++ ");", + " render(\"]\");"] + | isInternalVar nt -> "" + | otherwise -> " sh(" ++ fnm ++ "." ++ nt ++ ");\n" + + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) + +isInternalVar x = x == internalCat ++ "_" diff --git a/src/formats/java/CFtoJavaSkeleton.hs b/src/formats/java/CFtoJavaSkeleton.hs new file mode 100644 --- /dev/null +++ b/src/formats/java/CFtoJavaSkeleton.hs @@ -0,0 +1,124 @@ +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Skeleton Function + using Appel's method, not the Visitor Pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 29 April, 2003 + + Modified : 2 September, 2003 + + + ************************************************************** +-} +module CFtoJavaSkeleton (cf2JavaSkeleton) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower) + + +cf2JavaSkeleton :: String -> String -> CF -> String +cf2JavaSkeleton packageBase packageAbsyn cf = + unlines [ + header, + unlines (map (prData packageAbsyn) groups), + footer] + where + groups = (fixCoercions (ruleGroups cf)) + header = unlines [ + "package" +++ packageBase ++ ";", + "import" +++ packageAbsyn ++ ".*;", + "/*** BNFC-Generated Skeleton function. ***/", + "/* You will probably want to save this in a new file.", + " Then do two search-and-replaces.", + " First replace \"skel\" with a real funciton name.", + " Then replace Object with a real return type. */", + "", + "public class Skeleton", + "{" + ] + footer = unlines [ --later only include used categories + " public static Object skel(Integer i) { return null; }", + " public static Object skel(Double d) { return null; }", + " public static Object skel(String s) { return null; }", + "}" + ] + +--Traverses a category based on its type. +prData :: String -> (Cat, [Rule]) -> String +prData packageAbsyn (cat, rules) = + if isList cat + then unlines + [ + " public static Object skel(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)", + " {", + prList cat rules, + " }" + ] + else unlines --not a list + [ + " public static Object skel(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)", + " {", + unlines (map (prRule packageAbsyn) rules), + " return null;", + " }" + ] + +--traverses a standard rule +prRule :: String -> Rule -> String +prRule packageAbsyn (Rule fun c cats) | not (isCoercion fun) = unlines + [ + " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")", + " {", + " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= (" + ++ packageAbsyn ++ "." ++ fun ++ ") foo;", + "", + " /* Code For " ++ fun ++ " Goes Here */", + "", + cats', + " return null;", + " }" + ] + where + cats' = if allTerms cats + then "" + else (unlines (map (prCat fnm) (fixOnes (numVars [] cats)))) + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs + fnm = map toLower fun +prRule nm _ = "" + +--This traverses list rules. +prList :: Cat -> [Rule] -> String +prList c rules = unlines + [ + " if (foo == null)", + " {", + " /* Optional End of List Code Goes Here */", + " return null;", + " }", + " else", + " {", + " /* Optional List Member Code Goes Here */", + " skel(foo." ++ c' ++ "_);", + " skel(foo." ++ c'' ++ "_);", + " return null;", + " }" + ] + where + c' = map toLower (identCat (normCatOfList c)) + c'' = map toLower (identCat c) + +--This traverses a class's instance variables. +prCat fnm c = case c of + (Right t) -> "" + (Left nt) -> " skel(" ++ fnm ++ "." ++ nt ++ ");" diff --git a/src/formats/java/CFtoVisitSkel.hs b/src/formats/java/CFtoVisitSkel.hs new file mode 100644 --- /dev/null +++ b/src/formats/java/CFtoVisitSkel.hs @@ -0,0 +1,173 @@ +{- + BNF Converter: Java Vistor skeleton generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates a Skeleton function + which uses the Visitor Design Pattern, which + users may find more familiar than Appel's + method. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 4 August, 2003 + + Modified : 2 September, 2003 + + + ************************************************************** +-} +module CFtoVisitSkel (cf2VisitSkel) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower, toUpper) + +--Produces a Skeleton using the Visitor Design Pattern. +--Thus the user can choose which Skeleton to use. + +cf2VisitSkel :: String -> String -> CF -> String +cf2VisitSkel packageBase packageAbsyn cf = + concat [ + header, + concatMap (prData packageAbsyn user) groups, + concatMap prUser user, + footer] + where + user = fst (unzip (tokenPragmas cf)) + groups = (fixCoercions (ruleGroups cf)) + header = unlines [ + "package" +++ packageBase ++ ";", + "import" +++ packageAbsyn ++ ".*;", + "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/", + "/* This implements the common visitor design pattern.", + " Tests show it to be slightly less efficient than the", + " instanceof method, but easier to use.", + " Note that this method uses Visitor-traversal of lists, so", + " List.accept() does NOT traverse the list. This allows different", + " algorithms to use context information differently. */", + "", + "public class VisitSkel implements Visitor", + "{" + ] + prUser u = " public void visit" ++ u' ++ "(String p) {}\n" + where + u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem. + footer = unlines + [ --later only include used categories + " public void visitIdent(String i) {}", + " public void visitInteger(Integer i) {}", + " public void visitDouble(Double d) {}", + " public void visitChar(Character c) {}", + " public void visitString(String s) {}", + "}" + ] + +--Traverses a category based on its type. +prData :: String -> [UserDef] -> (Cat, [Rule]) -> String +prData packageAbsyn user (cat, rules) = + if isList cat + then unlines + [ + " public void visit" ++ cl ++ "(" ++ packageAbsyn ++ "." ++ cl +++ vname ++ ")", + " {", + " while(" ++ vname ++ "!= null)", + " {", + " /* Code For" +++ cl +++ "Goes Here */", + visitMember, + " " ++ vname +++ "=" +++ vname ++ "." ++ vname ++ "_;", + " }", + " }" + ] --Not a list: + else abstract ++ (concatMap (prRule packageAbsyn user) rules) + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl ++ "_" + visitMember = if isBasic user member + then " visit" ++ (funName member) ++ "(" ++ vname ++ "." ++ member ++ ");" + else " " ++ vname ++ "." ++ member ++ ".accept(this);" + abstract = case lookupRule cat rules of + Just x -> "" + Nothing -> " public void visit" ++ cl ++ "(" ++ packageAbsyn ++ "." + ++ cl +++ vname ++ ") {} //abstract class\n" + +--traverses a standard rule. +prRule :: String -> [UserDef] -> Rule -> String +prRule packageAbsyn user (Rule fun c cats) | not (isCoercion fun) = unlines + [ + " public void visit" ++ fun ++ "(" ++ packageAbsyn ++ "." ++ fun +++ fnm ++ ")", + " {", + " /* Code For " ++ fun ++ " Goes Here */", + "", + cats' ++ " }" + ] + where + cats' = if allTerms cats + then "" + else (concatMap (prCat user fnm) (fixOnes (numVars [] cats))) + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs + fnm = map toLower fun +prRule user nm _ = "" + +--Traverses a class's instance variables. +prCat user fnm c = + case c of + (Right t) -> "" + (Left nt) -> if isBasic user nt + then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "." ++ nt ++ ");\n" + else if "list" `isPrefixOf` nt + then " if (" ++ fnm ++ "." ++ nt ++ " != null) {" ++ accept ++ "}\n" + else " " ++ accept ++ "\n" + where + accept = fnm ++ "." ++ nt ++ ".accept(this);" + +--Just checks if something is a basic or user-defined type. +--This is because you don't -> a basic non-pointer type. +isBasic :: [UserDef] -> String -> Bool +isBasic user v = + if elem (init v) user' + then True + else if "integer_" `isPrefixOf` v then True + else if "char_" `isPrefixOf` v then True + else if "string_" `isPrefixOf` v then True + else if "double_" `isPrefixOf` v then True + else if "ident_" `isPrefixOf` v then True + else False + where + user' = map (map toLower) user + +--The visit-function name of a basic type +funName :: String -> String +funName v = + if "integer_" `isPrefixOf` v then "Integer" + else if "char_" `isPrefixOf` v then "Char" + else if "string_" `isPrefixOf` v then "String" + else if "double_" `isPrefixOf` v then "Double" + else if "ident_" `isPrefixOf` v then "Ident" + else (toUpper (head v)) : (init (tail v)) --User-defined type diff --git a/src/formats/java/JavaTop.hs b/src/formats/java/JavaTop.hs new file mode 100644 --- /dev/null +++ b/src/formats/java/JavaTop.hs @@ -0,0 +1,306 @@ +{- + BNF Converter: Java Top File + Copyright (C) 2004 Author: Markus Forsberg, Peter Gammie, Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +------------------------------------------------------------------- +-- | +-- Module : JavaTop +-- Copyright : (C)opyright 2003, {markus, aarne, pellauer, peteg} at cs dot chalmers dot se +-- License : GPL (see COPYING for details) +-- +-- Maintainer : {markus, aarne} at cs dot chalmers dot se +-- Stability : alpha +-- Portability : Haskell98 +-- +-- Top-level for the Java back end. +-- +-- > $Id: JavaTop.hs,v 1.10 2005/09/21 13:06:10 bringert Exp $ +------------------------------------------------------------------- + +module JavaTop ( makeJava ) where + +------------------------------------------------------------------- +-- Dependencies. +------------------------------------------------------------------- +import System.Directory ( createDirectory ) +import System.IO.Error ( tryIOError, isAlreadyExistsError ) +import System.Exit ( exitFailure ) + +import Utils +import CF +import CFtoCup ( cf2Cup ) +import CFtoJLex +import CFtoJavaAbs ( cf2JavaAbs ) +import CFtoJavaPrinter +import CFtoJavaSkeleton +import CFtoVisitSkel +import CFtoLatex +import Data.Char +import Data.List(intersperse) + +------------------------------------------------------------------- +-- | Build the Java output. +-- FIXME: get everything to put the files in the right places. +-- Adapt Makefile to do the business. +------------------------------------------------------------------- +makeJava :: Bool -> String -> CF -> IO () +makeJava = mkFiles + +mkFiles :: Bool -> String -> CF -> IO () +mkFiles make name cf = + do -- Create the package directories if necessary. + let packageBase = name + packageAbsyn = packageBase ++ "." ++ "Absyn" + dirBase = pkgToDir packageBase + dirAbsyn = pkgToDir packageAbsyn + chkExists dirBase + chkExists dirAbsyn + let absynFiles = remDups $ cf2JavaAbs packageBase packageAbsyn cf + absynBaseNames = map fst absynFiles + absynFileNames = map (dirAbsyn ++) absynBaseNames + let writeAbsyn (filename, contents) = + writeFileRep (dirAbsyn ++ filename ++ ".java") contents + mapM writeAbsyn absynFiles + writeFileRep (dirBase ++ "PrettyPrinter.java") $ cf2JavaPrinter packageBase packageAbsyn cf + writeFileRep (dirBase ++ "Skeleton.java") $ cf2JavaSkeleton packageBase packageAbsyn cf + writeFileRep (dirBase ++ "Visitable.java") $ prVisitable packageBase + let user = fst $ unzip $ tokenPragmas cf -- FIXME better var name + writeFileRep (dirBase ++ "Visitor.java") $ prVisitor packageBase packageAbsyn absynBaseNames user + writeFileRep (dirBase ++ "VisitSkel.java") $ cf2VisitSkel packageBase packageAbsyn cf + writeFileRep (dirBase ++ "Test.java") $ javaTest packageBase packageAbsyn cf + let (lex, env) = cf2jlex packageBase packageAbsyn cf + writeFileRep (dirBase ++ "Yylex") lex + putStrLn " (Tested with JLex 1.2.6.)" + writeFileRep (dirBase ++ name ++ ".cup") $ cf2Cup packageBase packageAbsyn cf env + -- FIXME: put in a doc directory? + putStrLn $ " (Parser created for category " ++ firstEntry cf ++ ")" + putStrLn " (Tested with CUP 0.10k)" + writeFileRep (name ++ ".tex") $ cfToLatex name cf + if make + then writeFileRep "Makefile" $ makefile name dirBase dirAbsyn absynFileNames + else return () + where + remDups [] = [] + remDups ((a,b):as) = case lookup a as of + Just {} -> remDups as + Nothing -> (a, b) : (remDups as) + + pkgToDir :: String -> FilePath + pkgToDir p = [ if c == '.' then '/' else c | c <- p] ++ "/" + + chkExists :: FilePath -> IO () + chkExists dir = + do eErr <- tryIOError $ createDirectory dir + case eErr of + Left ioerr -> if isAlreadyExistsError ioerr + then return () + else fail $ show ioerr + Right () -> putStrLn $ "Created directory: " ++ dir + +-- FIXME get filenames right. +-- FIXME It's almost certainly better to just feed all the Java source +-- files to javac in one go. +-- Replace with an ANT script? +makefile :: String -> FilePath -> FilePath -> [String] -> String +makefile name dirBase dirAbsyn absynFileNames = + unlines + [ + "JAVAC = javac", + "JAVAC_FLAGS = -sourcepath .", + "", + "JAVA = java", + "", + "CUP = java_cup.Main", + "CUPFLAGS = -nopositions -expect 100", + "", + "JLEX = JLex.Main", + "", + "LATEX = latex", + "DVIPS = dvips", + "", + "all: test " ++ name ++ ".ps", + "", + "test: absyn " + ++ unwords (map (dirBase ++) ["Visitor.class", + "Visitable.class", + "Test.class"]), + "", + ".PHONE: absyn", + "", + "absyn: " ++ absynJavaClass, + "", + "%.class: " ++ "%.java", + "\t${JAVAC} ${JAVAC_FLAGS} $*.java", + "", + dirBase ++ "Visitable.class: " ++ dirBase ++ "Visitable.java", + "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Visitable.java", + "", + dirBase ++ "Visitor.class: " ++ dirBase ++ "Visitor.java", + "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Visitor.java", + "", + dirBase ++ "Yylex.java: " ++ dirBase ++ "Yylex", + "\t${JAVA} ${JLEX} " ++ dirBase ++ "Yylex", + "", + -- FIXME + dirBase ++ "sym.java" ++ " " ++ dirBase ++ "parser.java: " ++ dirBase ++ name ++ ".cup", + "\t${JAVA} ${CUP} ${CUPFLAGS} " ++ dirBase ++ name ++ ".cup ; mv sym.java parser.java " ++ dirBase, + "", + dirBase ++ "Yylex.class: " ++ dirBase ++ "Yylex.java " + ++ dirBase ++ "sym.java", + "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Yylex.java", + "", + dirBase ++ "Test.class: " + ++ unwords (map (dirBase ++) ["Test.java", + "PrettyPrinter.class", + "Yylex.class", + "parser.class", + "sym.class"]), + "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Test.java", + "", + "" ++ name ++ ".dvi: " ++ name ++ ".tex", + "\t${LATEX} " ++ name ++ ".tex", + "", + "" ++ name ++ ".ps: " ++ name ++ ".dvi", + "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps", +-- FIXME + "", + "clean:", + "\t rm -f " ++ absynJavaClass, + "\t rm -f " ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps " ++ " *.class Makefile", + "", + "distclean:", + "\t rm -f " ++ absynJavaSrc ++ " " ++ absynJavaClass, + "\t rmdir " ++ dirAbsyn, + "\t rm -f " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps ", + "\t rm -f " ++ unwords (map (dirBase ++) ["Yylex", + name ++ ".cup", + "Yylex.java", + "sym.java", + "parser.java", + "Visitor.java", + "Visitable.java", + "VisitSkel.java", + "PrettyPrinter.java", + "Skeleton.java", + "Test.java", + "*.class"]), + "\t rmdir " ++ dirBase, + "\t rm -f Makefile", + "" + ] + where absynJavaSrc = unwords (map (++ ".java") absynFileNames) + absynJavaClass = unwords (map (++ ".class") absynFileNames) + +prVisitable :: String -> String +prVisitable packageBase = unlines + [ + "package" +++ packageBase ++ ";\n", + "public interface Visitable", + "{", + " public void accept(" ++ packageBase ++ ".Visitor v);", + "}" + ] + +prVisitor :: String -> String -> [String] -> [String]-> String +prVisitor packageBase packageAbsyn funs user = + unlines + [ + "package" +++ packageBase ++ ";\n", + "public interface Visitor", + "{", + concatMap prVisitFun funs, + concatMap prUser user, + footer + ] + where + prUser u = " public void visit" ++ u' ++ "(String p);\n" + where + u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem. + footer = unlines + [ --later only include used categories + " public void visitIdent(String i);", + " public void visitInteger(Integer i);", + " public void visitDouble(Double d);", + " public void visitChar(Character c);", + " public void visitString(String s);", + "}" + ] + prVisitFun f = " public void visit" ++ f ++ "(" ++ packageAbsyn + ++ "." ++ f ++ " p);\n" + +javaTest :: String -> String -> CF -> String +javaTest packageBase packageAbsyn cf = + unlines + [ + "package" +++ packageBase ++ ";", + "import java_cup.runtime.*;", + "import" +++ packageBase ++ ".*;", + "import" +++ packageAbsyn ++ ".*;", + "import java.io.*;", + "", + "public class Test", + "{", + " public static void main(String args[]) throws Exception", + " {", + " Yylex l = null;", + " parser p;", + " try", + " {", + " if (args.length == 0) l = new Yylex(System.in);", + " else l = new Yylex(new FileReader(args[0]));", + " }", + " catch(FileNotFoundException e)", + " {", + " System.err.println(\"Error: File not found: \" + args[0]);", + " System.exit(1);", + " }", + " p = new parser(l);", + " /* The default parser is the first-defined entry point. */", + " /* You may want to change this. Other options are: */", + " /* " ++ (concat (intersperse ", " (showOpts (tail eps)))) ++ " */", + " try", + " {", + " " ++ packageAbsyn ++ "." ++ def +++ "parse_tree = p.p" + ++ def ++ "();", + " System.out.println();", + " System.out.println(\"Parse Succesful!\");", + " System.out.println();", + " System.out.println(\"[Abstract Syntax]\");", + " System.out.println();", + " System.out.println(PrettyPrinter.show(parse_tree));", + " System.out.println();", + " System.out.println(\"[Linearized Tree]\");", + " System.out.println();", + " System.out.println(PrettyPrinter.print(parse_tree));", + " }", + " catch(Throwable e)", + " {", + " System.err.println(\"At line \" + String.valueOf(l.line_num()) + \", near \\\"\" + l.buff() + \"\\\" :\");", + " System.err.println(\" \" + e.getMessage());", + " System.exit(1);", + " }", + " }", + "}" + ] + where eps = allEntryPoints cf + def = head eps + showOpts [] = [] + + showOpts (x:[]) = if normCat x /= x then [] else ['p' : (identCat x)] + showOpts (x:xs) = if normCat x /= x then (showOpts xs) + else ('p' : (identCat x)) : (showOpts xs) diff --git a/src/formats/java/RegToJLex.hs b/src/formats/java/RegToJLex.hs new file mode 100644 --- /dev/null +++ b/src/formats/java/RegToJLex.hs @@ -0,0 +1,86 @@ +module RegToJLex (printRegJLex, escapeChar) where + +-- modified from pretty-printer generated by the BNF converter + +import AbsBNF +import Data.Char + +-- the top-level printing method +printRegJLex :: Reg -> String +printRegJLex = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend (0 :: Int) where + rend i ss = case ss of + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + cons s t = s ++ t + new i s = s + space t s = if null s then t else t ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ c = [escapeChar c] + prtList s = map (concat . prt 0) s + +escapeChar :: Char -> String +escapeChar '^' = "\\x5E" -- special case, since \^ is a control character escape +escapeChar x | x `elem` jlexReserved = '\\' : [x] +escapeChar x = [x] + +-- Characters that must be escaped in JLex regular expressions +jlexReserved :: [Char] +jlexReserved = ['?', '*', '+', '|', '(', ')', '^', '$', '.', '[', ']', '{', '}', '"', '\\'] + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + + -- JLex does not support set difference + --RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RMinus reg0 REps -> prt i reg0 -- REps is identity for set difference + RMinus RAny reg@(RChar _) -> prPrec i 3 (concat [["[^"],prt 0 reg,["]"]]) + RMinus RAny (RAlts str) -> prPrec i 3 (concat [["[^"],prt 0 str,["]"]]) + -- FIXME: maybe we could add cases for char - RDigit, RLetter etc. + RMinus reg0 reg -> error $ "JLex does not support general set difference" + + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["[^.]"]) + RChar c -> prPrec i 3 (concat [prt 0 c]) + RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) + RDigit -> prPrec i 3 (concat [["{DIGIT}"]]) + RLetter -> prPrec i 3 (concat [["{LETTER}"]]) + RUpper -> prPrec i 3 (concat [["{CAPITAL}"]]) + RLower -> prPrec i 3 (concat [["{SMALL}"]]) + RAny -> prPrec i 3 (concat [["."]]) + + + diff --git a/src/formats/java1.5/CFtoAbstractVisitor.hs b/src/formats/java1.5/CFtoAbstractVisitor.hs new file mode 100644 --- /dev/null +++ b/src/formats/java1.5/CFtoAbstractVisitor.hs @@ -0,0 +1,60 @@ +{- + BNF Converter: Java 1.5 Abstract Vistor generator + Copyright (C) 2006 Bjorn Bringert + Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoAbstractVisitor (cf2AbstractVisitor) where + +import CF +import CFtoJavaAbs15 (typename) +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower, toUpper, isDigit) + +cf2AbstractVisitor :: String -> String -> CF -> String +cf2AbstractVisitor packageBase packageAbsyn cf = + unlines [ + "package" +++ packageBase ++ ";", + "import" +++ packageAbsyn ++ ".*;", + "/** BNFC-Generated Abstract Visitor */", + "public class AbstractVisitor implements AllVisitor {", + concatMap (prData packageAbsyn user) groups, + "}"] + where + user = fst (unzip (tokenPragmas cf)) + groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ] + +--Traverses a category based on its type. +prData :: String -> [UserDef] -> (Cat, [Rule]) -> String +prData packageAbsyn user (cat, rules) = + unlines $ ["/* " ++ identCat cat ++ " */"] + ++ map (prRule packageAbsyn user cat) rules + ++ [" public R visitDefault(" ++ q ++ " p, A arg) {", + " throw new IllegalArgumentException(this.getClass().getName() + \": \" + p);", + " }"] + where q = packageAbsyn ++ "." ++ identCat cat + +--traverses a standard rule. +prRule :: String -> [UserDef] -> Cat -> Rule -> String +prRule packageAbsyn user cat (Rule fun _ cats) + | not (isCoercion fun || isDefinedRule fun) = + " public R visit(" ++ cls ++ " p, A arg) { return visitDefault(p, arg); }" + where cls = packageAbsyn ++ "." ++ fun +prRule _ _ _ _ = "" + diff --git a/src/formats/java1.5/CFtoAllVisitor.hs b/src/formats/java1.5/CFtoAllVisitor.hs new file mode 100644 --- /dev/null +++ b/src/formats/java1.5/CFtoAllVisitor.hs @@ -0,0 +1,51 @@ +{- + BNF Converter: Java 1.5 All Visitor generator + Copyright (C) 2006 Bjorn Bringert + Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoAllVisitor (cf2AllVisitor) where + +import CF +import CFtoJavaAbs15 (typename) +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower, toUpper, isDigit) + +cf2AllVisitor :: String -> String -> CF -> String +cf2AllVisitor packageBase packageAbsyn cf = + unlines [ + "package" +++ packageBase ++ ";", + "", + "import" +++ packageAbsyn ++ ".*;", + "", + "/** BNFC-Generated All Visitor */", + "public interface AllVisitor extends", + concat $ intersperse ",\n" $ map (" "++) is, + "{}"] + where + groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ] + is = map (prInterface packageAbsyn) groups + header = unlines [ + + ] + +prInterface :: String -> (Cat, [Rule]) -> String +prInterface packageAbsyn (cat, rules) = + q ++ ".Visitor" + where q = packageAbsyn ++ "." ++ identCat cat diff --git a/src/formats/java1.5/CFtoComposVisitor.hs b/src/formats/java1.5/CFtoComposVisitor.hs new file mode 100644 --- /dev/null +++ b/src/formats/java1.5/CFtoComposVisitor.hs @@ -0,0 +1,117 @@ +{- + BNF Converter: Java 1.5 Compositional Vistor generator + Copyright (C) 2006 Bjorn Bringert + Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoComposVisitor (cf2ComposVisitor) where + +import CF +import CFtoJavaAbs15 (typename) +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower, toUpper, isDigit) + +cf2ComposVisitor :: String -> String -> CF -> String +cf2ComposVisitor packageBase packageAbsyn cf = + concat [ + header, + concatMap (prData packageAbsyn user) groups, + "}"] + where + user = fst (unzip (tokenPragmas cf)) + groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ] + is = map (prInterface packageAbsyn) groups + header = unlines [ + "package" +++ packageBase ++ ";", + "import" +++ packageAbsyn ++ ".*;", + "/** BNFC-Generated Composition Visitor", + "*/", + "", + "public class ComposVisitor implements", + concat $ intersperse ",\n" $ map (" "++) is, + "{" + ] + + +prInterface :: String -> (Cat, [Rule]) -> String +prInterface packageAbsyn (cat, rules) = + q ++ ".Visitor<" ++ q ++ ",A>" + where q = packageAbsyn ++ "." ++ identCat cat + +commaList :: [String] -> String +commaList = concat . intersperse ", " + +--Traverses a category based on its type. +prData :: String -> [UserDef] -> (Cat, [Rule]) -> String +prData packageAbsyn user (cat, rules) = + unlines [ + "/* " ++ identCat cat ++ " */", + concatMap (prRule packageAbsyn user cat) rules + ] +--traverses a standard rule. +prRule :: String -> [UserDef] -> Cat -> Rule -> String +prRule packageAbsyn user cat (Rule fun _ cats) + | not (isCoercion fun || isDefinedRule fun) = unlines + [ + " public " ++ identCat cat ++ " visit(" ++ cls ++ " p, A arg)", + " {", + unlines (map (" "++) visitVars), + " return new " ++ cls ++ "(" ++ commaList children ++ ");", + " }" + ] + where + cats' = if allTerms cats + then [] + else [ (c,v) | + (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)), c /= internalCat ] + cls = packageAbsyn ++ "." ++ fun + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs + children = map snd cats' + visitVars = concatMap (uncurry (prCat user)) cats' +prRule _ _ _ _ = "" + +--Traverses a class's instance variables. +prCat :: [UserDef] + -> Cat -- ^ Variable category + -> String -- ^ Variable name + -> [String] -- ^ Code for visiting the variable +prCat user cat nt + | isBasicType user varType || (isListType varType && isBasicType user et) = [decl var] + | isListType varType = listAccept + | otherwise = [decl (var ++ ".accept(this, arg)")] + where + var = "p." ++ nt + varType = typename (normCat (identCat cat)) user + accept = var ++ ".accept(this, arg);" + et = typename (normCatOfList cat) user + decl v = varType +++ nt +++ "=" +++ v ++ ";" + listAccept = [decl ("new"+++varType++"()"), + "for (" ++ et ++ " x : " ++ var ++ ") {", + " " ++ nt ++ ".add(x.accept(this,arg));", + "}"] + +isListType :: String -> Bool +isListType nt = "List" `isPrefixOf` nt + +--Just checks if something is a basic or user-defined type. +isBasicType :: [UserDef] -> String -> Bool +isBasicType user v = v `elem` (user ++ ["Integer","Character","String","Double"]) + diff --git a/src/formats/java1.5/CFtoCup15.hs b/src/formats/java1.5/CFtoCup15.hs new file mode 100644 --- /dev/null +++ b/src/formats/java1.5/CFtoCup15.hs @@ -0,0 +1,274 @@ +{- + BNF Converter: Java 1.5 Cup Generator + Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer, + Bjorn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the CUP input file. It + follows the same basic structure of CFtoHappy. + + Author : Michael Pellauer (pellauer@cs.chalmers.se), + Bjorn Bringert (bringert@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 26 April, 2003 + + Modified : 5 Aug, 2004 + + + ************************************************************** +-} +module CFtoCup15 ( cf2Cup ) where + +import CF +import Data.List (intersperse, isPrefixOf) +import NamedVariables +import Utils ( (+++) ) +import TypeChecker -- We need to (re-)typecheck to figure out list instances in + -- defined rules. +import ErrM + +import Data.Char + +-- Type declarations +type Rules = [(NonTerminal,[(Pattern,Action)])] +type NonTerminal = String +type Pattern = String +type Action = String +type MetaVar = String + +--The environment comes from the CFtoJLex +cf2Cup :: String -> String -> CF -> SymEnv -> String +cf2Cup packageBase packageAbsyn cf env = unlines + [ + header, + declarations packageAbsyn (allCats cf), + tokens env, + specialToks cf, + specialRules cf, + prEntryPoint cf, + prRules (rulesForCup packageAbsyn cf env) + ] + where + header :: String + header = unlines + ["// -*- Java -*- This Cup file was machine-generated by BNFC", + "package" +++ packageBase ++ ";", + "", + "parser code {:", + parseMethod packageAbsyn (firstEntry cf), + "public > A cons_(B x, A xs) { xs.addFirst(x); return xs; }", + definedRules packageAbsyn cf, + -- unlines $ map (parseMethod packageAbsyn) (allEntryPoints cf), + "public void syntax_error(java_cup.runtime.Symbol cur_token)", + "{", + "\treport_error(\"Syntax Error, trying to recover and continue parse...\", cur_token);", + "}", + "", + "public void unrecovered_syntax_error(java_cup.runtime.Symbol cur_token) throws java.lang.Exception", + "{", + "\tthrow new Exception(\"Unrecoverable Syntax Error\");", + "}", + "", + ":}" + ] + +definedRules :: String -> CF -> String +definedRules packageAbsyn cf = + unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ] + where + ctx = buildContext cf + + list = LC (\t -> "List" ++ unBase t) (const "cons") + where + unBase (ListT t) = unBase t + unBase (BaseT x) = normCat x + + rule f xs e = + case checkDefinition' list ctx f xs e of + Bad err -> error $ "Panic! This should have been caught already:\n" ++ err + Ok (args,(e',t)) -> unlines + [ "public " ++ javaType t ++ " " ++ f ++ "_ (" ++ + concat (intersperse ", " $ map javaArg args) ++ ") {" + , " return " ++ javaExp e' ++ ";" + , "}" + ] + where + + javaType :: Base -> String + javaType (ListT (BaseT x)) = packageAbsyn ++ ".List" ++ normCat x + javaType (ListT t) = javaType t + javaType (BaseT x) + | isToken x ctx = "String" + | otherwise = packageAbsyn ++ "." ++ normCat x + + javaArg :: (String, Base) -> String + javaArg (x,t) = javaType t ++ " " ++ x ++ "_" + + javaExp :: Exp -> String + javaExp (App "null" []) = "null" + javaExp (App x []) + | elem x xs = x ++ "_" -- argument + javaExp (App t [e]) + | isToken t ctx = call ("new String") [e] + javaExp (App x es) + | isUpper (head x) = call ("new " ++ packageAbsyn ++ "." ++ x) es + | otherwise = call (x ++ "_") es + javaExp (LitInt n) = "new Integer(" ++ show n ++ ")" + javaExp (LitDouble x) = "new Double(" ++ show x ++ ")" + javaExp (LitChar c) = "new Character(" ++ show c ++ ")" + javaExp (LitString s) = "new String(" ++ show s ++ ")" + + call x es = x ++ "(" ++ concat (intersperse ", " $ map javaExp es) ++ ")" + + +-- peteg: FIXME JavaCUP can only cope with one entry point AFAIK. +prEntryPoint :: CF -> String +prEntryPoint cf = unlines ["", "start with " ++ firstEntry cf ++ ";", ""] +-- [ep] -> unlines ["", "start with " ++ ep ++ ";", ""] +-- eps -> error $ "FIXME multiple entry points." ++ show eps + +--This generates a parser method for each entry point. +parseMethod :: String -> Cat -> String +parseMethod packageAbsyn cat = + if normCat cat /= cat + then "" + else unlines + [ + " public" +++ packageAbsyn ++ "." ++ cat' +++ "p" ++ cat' ++ "()" + ++ " throws Exception", + " {", + "\tjava_cup.runtime.Symbol res = parse();", + "\treturn (" ++ packageAbsyn ++ "." ++ cat' ++ ") res.value;", + " }" + ] + where cat' = identCat (normCat cat) + +--non-terminal types +declarations :: String -> [NonTerminal] -> String +declarations packageAbsyn ns = unlines (map (typeNT packageAbsyn) ns) + where + typeNT _nm nt = "nonterminal" +++ packageAbsyn ++ "." + ++ identCat (normCat nt) +++ identCat nt ++ ";" + +--terminal types +tokens :: SymEnv -> String +tokens ts = unlines (map declTok ts) + where + declTok (s,r) = "terminal" +++ r ++ "; // " ++ s + +specialToks :: CF -> String +specialToks cf = unlines [ + ifC "String" "terminal String _STRING_;", + ifC "Char" "terminal Character _CHAR_;", + ifC "Integer" "terminal Integer _INTEGER_;", + ifC "Double" "terminal Double _DOUBLE_;", + ifC "Ident" "terminal String _IDENT_;" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + +-- This handles user defined tokens +-- FIXME +specialRules:: CF -> String +specialRules cf = + unlines ["terminal String " ++ name ++ ";" | (name, _) <- tokenPragmas cf] + +--The following functions are a (relatively) straightforward translation +--of the ones in CFtoHappy.hs +rulesForCup :: String -> CF -> SymEnv -> Rules +rulesForCup packageAbsyn cf env = map mkOne $ ruleGroups cf where + mkOne (cat,rules) = constructRule packageAbsyn cf env rules cat + +-- For every non-terminal, we construct a set of rules. A rule is a sequence of +-- terminals and non-terminals, and an action to be performed. +constructRule :: String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule packageAbsyn cf env rules nt = + (nt, [(p,generateAction packageAbsyn nt (funRule r) (revM b m) b) + | r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True, revSepListRule r0) + else (False, r0) + (p,m) = generatePatterns cf env r]) + where + revM False m = m + revM True [h,t] = [t,h] + revs = reversibleCats cf + +-- Generates a string containing the semantic action. +generateAction :: String -> NonTerminal -> Fun -> [MetaVar] + -> Bool -- ^ Whether the list should be reversed or not. + -- Only used if this is a list rule. + -> Action +generateAction packageAbsyn nt f ms rev + | isNilFun f = "RESULT = new " ++ c ++ "();" + | isOneFun f = "RESULT = new " ++ c ++ "(); RESULT.addLast(" ++ p_1 ++ ");" + | isConsFun f = "RESULT = " ++ p_2 ++ "; " + ++ p_2 ++ "." ++ add ++ "(" ++ p_1 ++ ");" + | isCoercion f = "RESULT = " ++ p_1 ++ ";" + | isDefinedRule f = "RESULT = parser." ++ f ++ "_" + ++ "(" ++ concat (intersperse "," ms) ++ ");" + | otherwise = "RESULT = new " ++ c + ++ "(" ++ concat (intersperse "," ms) ++ ");" + where + c = packageAbsyn ++ "." ++ + if isNilFun f || isOneFun f || isConsFun f + then identCat (normCat nt) else f + p_1 = ms!!0 + p_2 = ms!!1 + add = if rev then "addLast" else "addFirst" + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal +generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar]) +generatePatterns cf env r = case rhsRule r of + [] -> (" /* empty */ ",[]) + its -> (mkIt env 1 its, metas its) + where + mkIt _env _n [] = [] + mkIt env n (i:is) = case i of + Left c -> c' ++ ":p_" ++ (show (n :: Int)) +++ (mkIt env (n+1) is) + where + c' = case c of + "Ident" -> "_IDENT_" + "Integer" -> "_INTEGER_" + "Char" -> "_CHAR_" + "Double" -> "_DOUBLE_" + "String" -> "_STRING_" + _ -> identCat c + Right s -> case (lookup s env) of + (Just x) -> x +++ (mkIt env (n+1) is) + (Nothing) -> (mkIt env n is) + metas its = ["p_" ++ show i | (i,Left c) <- zip [1 :: Int ..] its] + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. +prRules :: Rules -> String +prRules [] = [] +prRules ((nt, []):rs) = prRules rs --internal rule +prRules ((nt,((p,a):ls)):rs) = + (unwords [nt', "::=", p, "{:", a, ":}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{:", a , ":}"])]) ++ pr ls + diff --git a/src/formats/java1.5/CFtoFoldVisitor.hs b/src/formats/java1.5/CFtoFoldVisitor.hs new file mode 100644 --- /dev/null +++ b/src/formats/java1.5/CFtoFoldVisitor.hs @@ -0,0 +1,104 @@ +{- + BNF Converter: Java 1.5 Fold Vistor generator + Copyright (C) 2006 Bjorn Bringert + Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoFoldVisitor (cf2FoldVisitor) where + +import CF +import CFtoJavaAbs15 (typename) +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower, toUpper, isDigit) + +cf2FoldVisitor :: String -> String -> CF -> String +cf2FoldVisitor packageBase packageAbsyn cf = + unlines + ["package" +++ packageBase ++ ";", + "", + "import" +++ packageAbsyn ++ ".*;", + "import java.util.Collections;", + "import java.util.List;", + "import java.util.ArrayList;", + "", + "/** BNFC-Generated Fold Visitor */", + "public abstract class FoldVisitor implements AllVisitor {", + " public abstract R leaf(A arg);", + " public abstract R combine(R x, R y, A arg);", + "", + concatMap (prData packageAbsyn user) groups, + "}"] + where + user = fst (unzip (tokenPragmas cf)) + groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ] + +--Traverses a category based on its type. +prData :: String -> [UserDef] -> (Cat, [Rule]) -> String +prData packageAbsyn user (cat, rules) = + unlines [ + "/* " ++ identCat cat ++ " */", + concatMap (prRule packageAbsyn user cat) rules + ] + +--traverses a standard rule. +prRule :: String -> [UserDef] -> Cat -> Rule -> String +prRule packageAbsyn user cat (Rule fun _ cats) + | not (isCoercion fun || isDefinedRule fun) = unlines $ + [" public R visit(" ++ cls ++ " p, A arg) {", + " R r = leaf(arg);"] + ++ map (" "++) visitVars + ++ [" return r;", + " }"] + where + cats' = if allTerms cats + then [] + else [ (c,v) | + (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)), c /= internalCat ] + cls = packageAbsyn ++ "." ++ fun + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs + children = map snd cats' + visitVars = concatMap (uncurry (prCat user)) cats' +prRule _ _ _ _ = "" + +--Traverses a class's instance variables. +prCat :: [UserDef] + -> Cat -- ^ Variable category + -> String -- ^ Variable name + -> [String] -- ^ Code for visiting the variable +prCat user cat nt + | isBasicType user varType || (isListType varType && isBasicType user et) = [] + | isListType varType = listAccept + | otherwise = ["r = combine(" ++ var ++ ".accept(this, arg), r, arg);"] + where + var = "p." ++ nt + varType = typename (normCat (identCat cat)) user + et = typename (normCatOfList cat) user + listAccept = ["for (" ++ et ++ " x : " ++ var ++ ") {", + " r = combine(x.accept(this,arg), r, arg);", + "}"] + +isListType :: String -> Bool +isListType nt = "List" `isPrefixOf` nt + +--Just checks if something is a basic or user-defined type. +isBasicType :: [UserDef] -> String -> Bool +isBasicType user v = v `elem` (user ++ ["Integer","Character","String","Double"]) + diff --git a/src/formats/java1.5/CFtoJLex15.hs b/src/formats/java1.5/CFtoJLex15.hs new file mode 100644 --- /dev/null +++ b/src/formats/java1.5/CFtoJLex15.hs @@ -0,0 +1,175 @@ +{- + BNF Converter: Java JLex generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the JLex input file. This + file is quite different than Alex or Flex. + + Author : Michael Pellauer (pellauer@cs.chalmers.se), + Bjorn Bringert (bringert@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 25 April, 2003 + + Modified : 4 Nov, 2004 + + + ************************************************************** +-} + +module CFtoJLex15 ( cf2jlex ) where + +import CF +import RegToJLex +import Utils ( (+++) ) +import NamedVariables +import Data.List + +--The environment must be returned for the parser to use. +cf2jlex :: String -> String -> CF -> (String, SymEnv) +cf2jlex packageBase packageAbsyn cf = (unlines $ concat $ + [ + prelude packageBase packageAbsyn, + cMacros, + lexSymbols env, + restOfJLex cf + ], env) + where + env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) + makeSymEnv [] _ = [] + makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) + +prelude :: String -> String -> [String] +prelude packageBase packageAbsyn = + [ + "// This JLex file was machine-generated by the BNF converter", + "package" +++ packageBase ++ ";", + "", + "import java_cup.runtime.*;", + "%%", + "%cup", + "%unicode", + "%line", + "%public", + "%{", + " String pstring = new String();", + " public int line_num() { return (yyline+1); }", + " public String buff() { return new String(yy_buffer,yy_buffer_index,10).trim(); }", + "%}" + ] + +--For now all categories are included. +--Optimally only the ones that are used should be generated. +cMacros :: [String] +cMacros = [ + "LETTER = ({CAPITAL}|{SMALL})", + "CAPITAL = [A-Z\\xC0-\\xD6\\xD8-\\xDE]", + "SMALL = [a-z\\xDF-\\xF6\\xF8-\\xFF]", + "DIGIT = [0-9]", + "IDENT = ({LETTER}|{DIGIT}|['_])", + "%state COMMENT", + "%state CHAR", + "%state CHARESC", + "%state CHAREND", + "%state STRING", + "%state ESCAPED", + "%%" + ] + +lexSymbols :: SymEnv -> [String] +lexSymbols ss = map transSym ss + where + transSym (s,r) = + "" ++ (escapeChars s) ++ " { return new Symbol(sym." + ++ r ++ "); }" + +restOfJLex :: CF -> [String] +restOfJLex cf = + [ + lexComments (comments cf), + userDefTokens, + ifC "String" strStates, + ifC "Char" chStates, + ifC "Double" "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }", + ifC "Integer" "{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }", + ifC "Ident" "{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, yytext().intern()); }" + , "[ \\t\\r\\n\\f] { /* ignore white space. */ }" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + userDefTokens = unlines $ + ["" ++ printRegJLex exp +++ + "{ return new Symbol(sym." ++ name ++ ", yytext().intern()); }" + | (name, exp) <- tokenPragmas cf] + strStates = unlines --These handle escaped characters in Strings. + [ + "\"\\\"\" { yybegin(STRING); }", + "\\\\ { yybegin(ESCAPED); }", + "\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo.intern()); }", + ". { pstring += yytext(); }", + "n { pstring += \"\\n\"; yybegin(STRING); }", + "\\\" { pstring += \"\\\"\"; yybegin(STRING); }", + "\\\\ { pstring += \"\\\\\"; yybegin(STRING); }", + "t { pstring += \"\\t\"; yybegin(STRING); }", + ". { pstring += yytext(); yybegin(STRING); }" + ] + chStates = unlines --These handle escaped characters in Chars. + [ + "\"'\" { yybegin(CHAR); }", + "\\\\ { yybegin(CHARESC); }", + "[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", + "n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }", + "t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }", + ". { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", + "\"'\" {yybegin(YYINITIAL);}" + ] + + + + +lexComments :: ([(String, String)], [String]) -> String +lexComments (m,s) = + (unlines (map lexSingleComment s)) + ++ (unlines (map lexMultiComment m)) + +lexSingleComment :: String -> String +lexSingleComment c = + "\"" ++ c ++ "\"[^\\n]*\\n { /* BNFC single-line comment */ }" + +--There might be a possible bug here if a language includes 2 multi-line comments. +--They could possibly start a comment with one character and end it with another. +--However this seems rare. +lexMultiComment :: (String, String) -> String +lexMultiComment (b,e) = unlines [ + "\"" ++ b ++ "\" { yybegin(COMMENT); }", + "\"" ++ e ++ "\" { yybegin(YYINITIAL); }", + ". { }", + "[\\n] { }" + ] + +-- lexReserved :: String -> String +-- lexReserved s = "\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }" + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars = concatMap escapeChar diff --git a/src/formats/java1.5/CFtoJavaAbs15.hs b/src/formats/java1.5/CFtoJavaAbs15.hs new file mode 100644 --- /dev/null +++ b/src/formats/java1.5/CFtoJavaAbs15.hs @@ -0,0 +1,263 @@ +{- + BNF Converter: Java 1.5 Abstract Syntax + Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Java Abstract Syntax + It uses the NamedVariables module for variable + naming. It returns a list of file names, and the + contents to be written into that file. (In Java + public classes must go in their own file.) + + The generated classes also support the Visitor + Design Pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se), + Bjorn Bringert (bringert@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 24 April, 2003 + + Modified : 16 June, 2004 + + + ************************************************************** +-} + +module CFtoJavaAbs15 (cf2JavaAbs, typename) where + +import CF +import Utils((+++),(++++)) +import NamedVariables hiding (IVar, getVars, varName) +import Data.List +import Data.Char(toLower, isDigit) +import Data.Maybe(catMaybes,fromMaybe) + +--Produces abstract data types in Java. +--These follow Appel's "non-object oriented" version. +--They also allow users to use the Visitor design pattern. + +type IVar = (String, Int, Maybe String) +--The type of an instance variable +--a # unique to that type +--and an optional name (handles typedefs). + +--The result is a list of files which must be written to disk. +--The tuple is (FileName, FileContents) +cf2JavaAbs :: String -> String -> CF -> [(FilePath, String)] +cf2JavaAbs packageBase packageAbsyn cf = + concatMap (prData header packageAbsyn user) rules + where + header = "package " ++ packageAbsyn ++ "; // Java Package generated by the BNF Converter.\n" + user = [n | (n,_) <- tokenPragmas cf] + rules = [ (normCat c,fs) | (c,fs) <- cf2dataLists cf] + +--Generates a (possibly abstract) category class, and classes for all its rules. +prData :: String -> String -> [UserDef] -> Data ->[(String, String)] +prData header packageAbsyn user (cat, rules) = + categoryClass ++ (catMaybes $ map (prRule header packageAbsyn funs user cat) rules) + where + funs = map fst rules + categoryClass + | cat `elem` funs = [] -- the catgory is also a function, skip abstract class + | otherwise = [(identCat cat, header ++++ + unlines [ + "public abstract class" +++ cls + +++ "implements java.io.Serializable {", + " public abstract R accept(" + ++ cls ++ ".Visitor v, A arg);", + prVisitor packageAbsyn funs, + "}" + ])] + where cls = identCat cat + +prVisitor :: String -> [String] -> String +prVisitor packageAbsyn funs = + unlines [ + " public interface Visitor {", + unlines (map prVisitFun funs), + " }" + ] + where + prVisitFun f = " public R visit(" ++ packageAbsyn ++ "." ++ f ++ " p, A arg);" + +--Generates classes for a rule, depending on what type of rule it is. +prRule :: String -- ^ Header + -> String -- ^ Abstract syntax package name + -> [String] -- ^ Names of all constructors in the category + -> [UserDef] -> String -> (Fun, [Cat]) -> Maybe (String, String) +prRule h packageAbsyn funs user c (fun, cats) = + if isNilFun fun || isOneFun fun + then Nothing --these are not represented in the AbSyn + else if isConsFun fun + then Just $ (fun', --this is the linked list case. + unlines + [ + h, + "public class" +++ fun' +++ "extends java.util.LinkedList<"++ et ++"> {", + "}" + ]) + else Just $ (fun, --a standard rule + unlines + [ + h, + "public class" +++ fun ++ ext +++ "{", + (prInstVars vs), + prConstructor fun user vs cats, + prAccept packageAbsyn c fun, + prEquals packageAbsyn fun vs, + prHashCode packageAbsyn fun vs, + if isAlsoCategory then prVisitor packageAbsyn funs else "", + "}" + ]) + where + vs = getVars cats user + fun' = identCat (normCat c) + isAlsoCategory = fun == c + --This handles the case where a LBNF label is the same as the category. + ext = if isAlsoCategory then "" else " extends" +++ (identCat c) + et = typename (normCatOfList c) user + + +--The standard accept function for the Visitor pattern +prAccept :: String -> String -> String -> String +prAccept pack cat _ = "\n public R accept(" ++ pack ++ "." ++ cat + ++ ".Visitor v, A arg) { return v.visit(this, arg); }\n" + +-- Creates the equals() method. +prEquals :: String -> String -> [IVar] -> String +prEquals pack fun vs = + unlines $ map (" "++) $ ["public boolean equals(Object o) {", + " if (this == o) return true;", + " if (o instanceof " ++ fqn ++ ") {"] + ++ (if null vs + then [" return true;"] + else [" " ++ fqn +++ "x = ("++fqn++")o;", + " return " ++ checkKids ++ ";"]) ++ + [" }", + " return false;", + "}"] + where + fqn = pack++"."++fun + checkKids = concat $ intersperse " && " $ map checkKid vs + checkKid iv = "this." ++ v ++ ".equals(x." ++ v ++ ")" + where v = iVarName iv + +-- Creates the equals() method. +prHashCode :: String -> String -> [IVar] -> String +prHashCode pack fun vs = + unlines $ map (" "++) ["public int hashCode() {", + " return " ++ hashKids vs ++ ";", + "}" + ] + where + aPrime = 37 + hashKids [] = show aPrime + hashKids (v:vs) = hashKids_ (hashKid v) vs + hashKids_ r [] = r + hashKids_ r (v:vs) = hashKids_ (show aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashKid v) vs + hashKid iv = "this." ++ iVarName iv ++ ".hashCode()" + + +--A class's instance variables. +prInstVars :: [IVar] -> String +prInstVars [] = [] +prInstVars vars@((t,n,nm):vs) = + " public" +++ "final" +++ t +++ uniques ++ ";" ++++ + (prInstVars vs') + where + (uniques, vs') = prUniques t vars + --these functions group the types together nicely + prUniques :: String -> [IVar] -> (String, [IVar]) + prUniques t vs = (prVars (findIndices (\x -> case x of (y,_,_) -> y == t) vs) vs, remType t vs) + prVars (x:[]) vs = iVarName (vs!!x) + prVars (x:xs) vs = iVarName (vs!!x) ++ "," +++ prVars xs vs + remType :: String -> [IVar] -> [IVar] + remType _ [] = [] + remType t ((t2,n,nm):ts) = if t == t2 + then (remType t ts) + else (t2,n,nm) : (remType t ts) + +iVarName :: IVar -> String +iVarName (t,n,nm) = varName t nm ++ showNum n + +--The constructor just assigns the parameters to the corresponding instance variables. +prConstructor :: String -> [UserDef] -> [IVar] -> [Cat] -> String +prConstructor c u vs cats = + " public" +++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" +++ + prAssigns vs params ++ "}" + where + (types, params) = unzip (prParams cats u (length cats) ((length cats)+1)) + interleave _ [] = [] + interleave (x:[]) (y:[]) = x +++ y + interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys) + +--Prints the parameters to the constructors. +prParams :: [Cat] -> [UserDef] -> Int -> Int -> [(String,String)] +prParams [] _ _ _ = [] +prParams (c:cs) u n m = (identCat c',"p" ++ (show (m-n))) + : (prParams cs u (n-1) m) + where + c' = typename c u + +--This algorithm peeks ahead in the list so we don't use map or fold +prAssigns :: [IVar] -> [String] -> String +prAssigns [] _ = [] +prAssigns _ [] = [] +prAssigns ((t,n,nm):vs) (p:ps) = + if n == 1 then + case findIndices (\x -> case x of (l,r,_) -> l == t) vs of + [] -> (varName t nm) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + z -> ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + else ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + +--Different than the standard NamedVariables version because of the user-defined +--types. +getVars :: [Cat] -> [UserDef] -> [IVar] +getVars cs user = reverse $ singleToZero $ foldl addVar [] (map identCat cs) + where + addVar is c = (c', n, nm):is + where c' = typename c user + nm = if c == c' then Nothing else Just c + n = maximum (1:[n'+1 | (t,n',_) <- is, t == c']) + singleToZero is = [(t,n',nm) | (t,n,nm) <- is, + let n' = if length (filter (hasType t) is) == 1 + then 0 else n] + hasType t (t',_,_) = t == t' + +varName :: String -- ^ Category + -> Maybe String -- ^ Java type name + -> String -- ^ Variable name +varName c jt = (map toLower c') ++ "_" + where + c' = fromMaybe c jt + +--This makes up for the fact that there's no typedef in Java +typename :: String -> [UserDef] -> String +typename t user = + if t == "Ident" + then "String" + else if t == "Char" + then "Character" + else if elem t user + then "String" + else t diff --git a/src/formats/java1.5/CFtoJavaPrinter15.hs b/src/formats/java1.5/CFtoJavaPrinter15.hs new file mode 100644 --- /dev/null +++ b/src/formats/java1.5/CFtoJavaPrinter15.hs @@ -0,0 +1,361 @@ +{- + BNF Converter: Java Pretty Printer generator + Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Java Pretty Printer + class. In addition, since there's no good way + to display a class heirarchy (toString() doesn't + count) in Java, it generates a method that + displays the Abstract Syntax in a way similar + to Haskell. + + This uses Appel's method and may serve as a + useful example to those who wish to use it. + + Author : Michael Pellauer (pellauer@cs.chalmers.se), + Bjorn Bringert (bringert@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 24 April, 2003 + + Modified : 9 Aug, 2004 + + Added string buffer for efficiency (Michael, August 03) + ************************************************************** +-} +module CFtoJavaPrinter15 ( cf2JavaPrinter ) where + +import CFtoJavaAbs15 + +import CF +import NamedVariables +import Utils ( (+++) ) +import Data.List +import Data.Char ( toLower, isSpace ) + +--Produces the PrettyPrinter class. +--It will generate two methods "print" and "show" +--print is the actual pretty printer for linearization. +--show produces a Haskell-style syntax that can be extremely useful +--especially for testing parser correctness. + +cf2JavaPrinter :: String -> String -> CF -> String +cf2JavaPrinter packageBase packageAbsyn cf = + unlines + [ + header, + prEntryPoints packageAbsyn cf, + unlines (map (prData packageAbsyn user) groups), + unlines (map (shData packageAbsyn user) groups), + footer + ] + where + user = [n | (n,_) <- tokenPragmas cf] + groups = fixCoercions (ruleGroupsInternals cf) + header = unlines [ + "package" +++ packageBase ++ ";", + "import" +++ packageAbsyn ++ ".*;", + "", + "public class PrettyPrinter", + "{", + " //For certain applications increasing the initial size of the buffer may improve performance.", + " private static final int INITIAL_BUFFER_SIZE = 128;", + " //You may wish to change the parentheses used in precedence.", + " private static final String _L_PAREN = new String(\"(\");", + " private static final String _R_PAREN = new String(\")\");", + prRender + ] + footer = unlines [ --later only include used categories + " private static void pp(Integer n, int _i_) { buf_.append(n); buf_.append(\" \"); }", + " private static void pp(Double d, int _i_) { buf_.append(d); buf_.append(\" \"); }", + " private static void pp(String s, int _i_) { buf_.append(s); buf_.append(\" \"); }", + " private static void pp(Character c, int _i_) { buf_.append(\"'\" + c.toString() + \"'\"); buf_.append(\" \"); }", + " private static void sh(Integer n) { render(n.toString()); }", + " private static void sh(Double d) { render(d.toString()); }", + " private static void sh(Character c) { render(c.toString()); }", + " private static void sh(String s) { printQuoted(s); }", + " private static void printQuoted(String s) { render(\"\\\"\" + s + \"\\\"\"); }", + " private static void indent()", + " {", + " int n = _n_;", + " while (n > 0)", + " {", + " buf_.append(\" \");", + " n--;", + " }", + " }", + " private static void backup()", + " {", + " if (buf_.charAt(buf_.length() - 1) == ' ') {", + " buf_.setLength(buf_.length() - 1);", + " }", + " }", + " private static void trim()", + " {", + " while (buf_.length() > 0 && buf_.charAt(0) == ' ')", + " buf_.deleteCharAt(0); ", + " while (buf_.length() > 0 && buf_.charAt(buf_.length()-1) == ' ')", + " buf_.deleteCharAt(buf_.length()-1);", + " }", + " private static int _n_ = 0;", + " private static StringBuilder buf_ = new StringBuilder(INITIAL_BUFFER_SIZE);", + "}" + ] + +--An extremely simple renderer for terminals. +prRender :: String +prRender = unlines + [ + " //You may wish to change render", + " private static void render(String s)", + " {", + " if (s.equals(\"{\"))", + " {", + " buf_.append(\"\\n\");", + " indent();", + " buf_.append(s);", + " _n_ = _n_ + 2;", + " buf_.append(\"\\n\");", + " indent();", + " }", + " else if (s.equals(\"(\") || s.equals(\"[\"))", + " buf_.append(s);", + " else if (s.equals(\")\") || s.equals(\"]\"))", + " {", + " backup();", + " buf_.append(s);", + " buf_.append(\" \");", + " }", + " else if (s.equals(\"}\"))", + " {", + " _n_ = _n_ - 2;", + " backup();", + " backup();", + " buf_.append(s);", + " buf_.append(\"\\n\");", + " indent();", + " }", + " else if (s.equals(\",\"))", + " {", + " backup();", + " buf_.append(s);", + " buf_.append(\" \");", + " }", + " else if (s.equals(\";\"))", + " {", + " backup();", + " buf_.append(s);", + " buf_.append(\"\\n\");", + " indent();", + " }", + " else if (s.equals(\"\")) return;", + " else", + " {", + " buf_.append(s);", + " buf_.append(\" \");", + " }", + " }" + ] + +prEntryPoints :: String -> CF -> String +prEntryPoints packageAbsyn cf = + msg ++ concat (map prEntryPoint (allCats cf)) ++ msg2 + where + msg = " // print and show methods are defined for each category.\n" + msg2 = " /*** You shouldn't need to change anything beyond this point. ***/\n" + prEntryPoint cat | (normCat cat) == cat = unlines + [ + " public static String print(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)", + " {", + " pp(foo, 0);", + " trim();", + " String temp = buf_.toString();", + " buf_.delete(0,buf_.length());", + " return temp;", + " }", + " public static String show(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)", + " {", + " sh(foo);", + " String temp = buf_.toString();", + " buf_.delete(0,buf_.length());", + " return temp;", + " }" + ] + where + cat' = identCat cat + prEntryPoint _ = "" + +prData :: String -> [UserDef] -> (Cat, [Rule]) -> String +prData packageAbsyn user (cat, rules) = + if isList cat + then unlines + [ + " private static void pp(" ++ packageAbsyn ++ "." + ++ identCat (normCat cat) +++ "foo, int _i_)", + " {", + (prList user cat rules) ++ " }" + ] + else unlines --not a list + [ + " private static void pp(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo, int _i_)", + " {", + (concat (addElse $ map (prRule packageAbsyn) rules)) ++ " }" + ] + where addElse = map (" "++). intersperse "else " . filter (not . null) . map (dropWhile isSpace) + +prRule :: String -> Rule -> String +prRule packageAbsyn r@(Rule fun _c cats) | not (isCoercion fun || isDefinedRule fun) = concat + [ + " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")\n", + " {\n", + " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= (" + ++ packageAbsyn ++ "." ++ fun ++ ") foo;\n", + lparen, + cats', + rparen, + " }\n" + ] + where + p = precRule r + (lparen, rparen) = + (" if (_i_ > " ++ (show p) ++ ") render(_L_PAREN);\n", + " if (_i_ > " ++ (show p) ++ ") render(_R_PAREN);\n") + cats' = case cats of + [] -> "" + _ -> concatMap (prCat fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats)) + fnm = '_' : map toLower fun + + getPrec (Right {}) = 0 + getPrec (Left c) = precCat c + +prRule _nm _ = "" + +prList :: [UserDef] -> Cat -> [Rule] -> String +prList user c rules = unlines + [ + " for (java.util.Iterator<" ++ et + ++ "> it = foo.iterator(); it.hasNext();)", + " {", + " pp(it.next(), 0);", + " if (it.hasNext()) {", + " render(\"" ++ sep ++ "\");", + " } else {", + " render(\"" ++ optsep ++ "\");", + " }", + " }" + ] + where + et = typename (normCatOfList c) user + sep = escapeChars $ getCons rules + optsep = if hasOneFunc rules then "" else sep + +prCat fnm (c, p) = + case c of + Right t -> " render(\"" ++ escapeChars t ++ "\");\n" + Left nt | "string" `isPrefixOf` nt + -> " printQuoted(" ++ fnm ++ "." ++ nt ++ ");\n" + | isInternalVar nt -> "" + | otherwise + -> " pp(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");\n" + +--The following methods generate the Show function. + +shData :: String -> [UserDef] -> (Cat, [Rule]) -> String +shData packageAbsyn user (cat, rules) = + if isList cat + then unlines + [ + " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)", + " {", + (shList user cat rules) ++ " }" + ] + else unlines + [ + " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)", + " {", + (concat (map (shRule packageAbsyn) rules)) ++ " }" + ] + +shRule :: String -> Rule -> String +shRule packageAbsyn (Rule fun _c cats) | not (isCoercion fun || isDefinedRule fun) = unlines + [ + " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")", + " {", + " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= (" + ++ packageAbsyn ++ "." ++ fun ++ ") foo;", + members ++ " }" + ] + where + members = concat + [ + lparen, + " render(\"" ++ (escapeChars fun) ++ "\");\n", + cats', + rparen + ] + cats' = if allTerms cats + then "" + else (concat (map (shCat fnm) (fixOnes (numVars [] cats)))) + (lparen, rparen) = + if allTerms cats + then ("","") + else (" render(\"(\");\n"," render(\")\");\n") + allTerms [] = True + allTerms ((Left {}):_) = False + allTerms (_:zs) = allTerms zs + fnm = '_' : map toLower fun +shRule _nm _ = "" + +shList :: [UserDef] -> Cat -> [Rule] -> String +shList user c _rules = unlines + [ + " for (java.util.Iterator<" ++ et + ++ "> it = foo.iterator(); it.hasNext();)", + " {", + " sh(it.next());", + " if (it.hasNext())", + " render(\",\");", + " }" + ] + where + et = typename (normCatOfList c) user + +shCat fnm c = + case c of + Right {} -> "" + Left nt | "list" `isPrefixOf` nt + -> unlines [" render(\"[\");", + " sh(" ++ fnm ++ "." ++ nt ++ ");", + " render(\"]\");"] + | isInternalVar nt -> "" + | otherwise -> " sh(" ++ fnm ++ "." ++ nt ++ ");\n" + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) + +isInternalVar x = x == internalCat ++ "_" diff --git a/src/formats/java1.5/CFtoVisitSkel15.hs b/src/formats/java1.5/CFtoVisitSkel15.hs new file mode 100644 --- /dev/null +++ b/src/formats/java1.5/CFtoVisitSkel15.hs @@ -0,0 +1,141 @@ +{- + BNF Converter: Java Vistor skeleton generator + Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates a Skeleton function + which uses the Visitor Design Pattern, which + users may find more familiar than Appel's + method. + + Author : Michael Pellauer (pellauer@cs.chalmers.se), + Bjorn Bringert (bringert@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 4 August, 2003 + + Modified : 16 June, 2004 + + + ************************************************************** +-} +module CFtoVisitSkel15 (cf2VisitSkel) where + +import CF +import CFtoJavaAbs15 (typename) +import Utils ((+++), (++++)) +import NamedVariables +import Data.List +import Data.Char(toLower, toUpper, isDigit) + +--Produces a Skeleton using the Visitor Design Pattern. +--Thus the user can choose which Skeleton to use. + +cf2VisitSkel :: String -> String -> CF -> String +cf2VisitSkel packageBase packageAbsyn cf = + concat [ + header, +-- " // NOT IMPLEMENTED for java1.5\n", + concatMap (prData packageAbsyn user) groups, + "}"] + where + user = fst (unzip (tokenPragmas cf)) + groups = (fixCoercions (ruleGroups cf)) + header = unlines [ + "package" +++ packageBase ++ ";", + "import" +++ packageAbsyn ++ ".*;", + "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/", + "/* This implements the common visitor design pattern.", + " Tests show it to be slightly less efficient than the", + " instanceof method, but easier to use. ", + " Replace the R and A parameters with the desired return", + " and context types.*/", + "", + "public class VisitSkel", + "{" + ] + + +--Traverses a category based on its type. +prData :: String -> [UserDef] -> (Cat, [Rule]) -> String +prData packageAbsyn user (cat, rules) = + if isList cat + then "" + else unlines [" public class " ++ identCat cat ++ "Visitor implements " + ++ identCat cat ++ ".Visitor", + " {", + concatMap (prRule packageAbsyn user) rules, + " }" + ] + +--traverses a standard rule. +prRule :: String -> [UserDef] -> Rule -> String +prRule packageAbsyn user (Rule fun c cats) | not (isCoercion fun || isDefinedRule fun) = unlines + [ + " public R visit(" ++ packageAbsyn ++ "." ++ fun ++ " p, A arg)", + " {", + " /* Code For " ++ fun ++ " Goes Here */", + "", + concatMap (uncurry (prCat user)) cats', + " return null;", + " }" + ] + where + cats' = if allTerms cats + then [] + else [ (c,v) | + (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)) ] + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs +prRule user nm _ = "" + +--Traverses a class's instance variables. +prCat :: [UserDef] + -> Cat -- ^ Variable category + -> String -- ^ Variable name + -> String -- ^ Code for visiting the variable +prCat user cat nt | isBasic user nt = " //" ++ var ++ ";\n" + | "list" `isPrefixOf` nt = listAccept + | otherwise = " " ++ accept ++ "\n" + where + var = "p." ++ nt + varType = typename (normCat (identCat cat)) user + accept = var ++ ".accept(new " ++ varType ++ "Visitor(), arg);" + et = typename (normCatOfList cat) user + listAccept = unlines [" for (" ++ et ++ " x : " ++ var ++ ") {", + " }"] + +--Just checks if something is a basic or user-defined type. +--This is because you don't -> a basic non-pointer type. +isBasic :: [UserDef] -> String -> Bool +isBasic user v = + if elem (init v) user' + then True + else if "integer_" `isPrefixOf` v then True + else if "char_" `isPrefixOf` v then True + else if "string_" `isPrefixOf` v then True + else if "double_" `isPrefixOf` v then True + else if "ident_" `isPrefixOf` v then True + else False + where + user' = map (map toLower) user diff --git a/src/formats/java1.5/JavaTop15.hs b/src/formats/java1.5/JavaTop15.hs new file mode 100644 --- /dev/null +++ b/src/formats/java1.5/JavaTop15.hs @@ -0,0 +1,261 @@ +{- + BNF Converter: Java Top File + Copyright (C) 2004 Author: Markus Forsberg, Peter Gammie, + Michael Pellauer, Bjorn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +------------------------------------------------------------------- +-- | +-- Module : JavaTop +-- Copyright : (C)opyright 2003, {markus, aarne, pellauer, peteg, bringert} at cs dot chalmers dot se +-- License : GPL (see COPYING for details) +-- +-- Maintainer : {markus, aarne} at cs dot chalmers dot se +-- Stability : alpha +-- Portability : Haskell98 +-- +-- Top-level for the Java back end. +-- +-- > $Id: JavaTop15.hs,v 1.12 2007/01/08 18:20:23 aarne Exp $ +------------------------------------------------------------------- + +module JavaTop15 ( makeJava15 ) where + +------------------------------------------------------------------- +-- Dependencies. +------------------------------------------------------------------- +import System.Directory ( createDirectory ) +import System.IO.Error ( isAlreadyExistsError ) +import System.Exit ( exitFailure ) +import Utils +import CF +import CFtoCup15 ( cf2Cup ) +import CFtoJLex15 +import CFtoJavaAbs15 ( cf2JavaAbs ) +import CFtoJavaPrinter15 +--import CFtoJavaSkeleton +import CFtoVisitSkel15 +import CFtoComposVisitor +import CFtoAbstractVisitor +import CFtoFoldVisitor +import CFtoAllVisitor +import CFtoLatex +import Data.Char +import Data.List(intersperse) +import qualified Common.Makefile as Makefile +------------------------------------------------------------------- +-- | Build the Java output. +-- FIXME: get everything to put the files in the right places. +-- Adapt Makefile to do the business. +------------------------------------------------------------------- +makeJava15 :: Bool + -> Maybe String -- ^ Java package name to put the classes in + -> String -- ^ Name of grammar + -> CF -- ^ Grammar file + -> IO () +makeJava15 = mkFiles + +mkFiles :: Bool -> Maybe String -> String -> CF -> IO () +mkFiles make inPackage name cf = + do -- Create the package directories if necessary. + let packageBase = case inPackage of + Nothing -> name + Just p -> p ++ "." ++ name + packageAbsyn = packageBase ++ "." ++ "Absyn" + dirBase = pkgToDir packageBase + dirAbsyn = pkgToDir packageAbsyn + prepareDir dirBase + prepareDir dirAbsyn + let absynFiles = remDups $ cf2JavaAbs packageBase packageAbsyn cf + absynBaseNames = map fst absynFiles + absynFileNames = map (dirAbsyn ++) absynBaseNames + absynFuns = [ f | (_,ps) <- cf2data cf, (f,_) <- ps ] + let writeAbsyn (filename, contents) = + writeFileRep (dirAbsyn ++ filename ++ ".java") contents + mapM writeAbsyn absynFiles + writeFileRep (dirBase ++ "PrettyPrinter.java") $ cf2JavaPrinter packageBase packageAbsyn cf + writeFileRep (dirBase ++ "VisitSkel.java") $ cf2VisitSkel packageBase packageAbsyn cf + writeFileRep (dirBase ++ "ComposVisitor.java") $ cf2ComposVisitor packageBase packageAbsyn cf + writeFileRep (dirBase ++ "AbstractVisitor.java") $ cf2AbstractVisitor packageBase packageAbsyn cf + writeFileRep (dirBase ++ "FoldVisitor.java") $ cf2FoldVisitor packageBase packageAbsyn cf + writeFileRep (dirBase ++ "AllVisitor.java") $ cf2AllVisitor packageBase packageAbsyn cf + writeFileRep (dirBase ++ "Test.java") $ javaTest packageBase packageAbsyn cf +--- writeFileRep ("Test" ++ name) $ "java " ++ dirBase ++ "Test $(1)" + let (lex, env) = cf2jlex packageBase packageAbsyn cf + writeFileRep (dirBase ++ "Yylex") lex + putStrLn " (Tested with JLex 1.2.6.)" + writeFileRep (dirBase ++ name ++ ".cup") $ cf2Cup packageBase packageAbsyn cf env + -- FIXME: put in a doc directory? + putStrLn $ " (Parser created for category " ++ firstEntry cf ++ ")" + putStrLn " (Tested with CUP 0.10k)" + writeFileRep (name ++ ".tex") $ cfToLatex name cf + if make + then writeFileRep "Makefile" $ makefile name dirBase dirAbsyn absynFileNames + else return () + where + remDups [] = [] + remDups ((a,b):as) = case lookup a as of + Just {} -> remDups as + Nothing -> (a, b) : (remDups as) + + pkgToDir :: String -> FilePath + pkgToDir s = replace '.' pathSep s ++ [pathSep] + + +-- FIXME get filenames right. +-- FIXME It's almost certainly better to just feed all the Java source +-- files to javac in one go. +-- Replace with an ANT script? +makefile :: String -> FilePath -> FilePath -> [String] -> String +makefile name dirBase dirAbsyn absynFileNames = + (++) (unlines [ "JAVAC = javac", + "JAVAC_FLAGS = -sourcepath .", "", + "JAVA = java", + "JAVA_FLAGS =", "", + "CUP = java_cup.Main", + "CUPFLAGS = -nopositions -expect 100", "", + "JLEX = JLex.Main", "" ]) + $ Makefile.mkRule "all" [ "test" ] + [] + $ Makefile.mkRule "test" ("absyn":(map (dirBase ++) [ "Yylex.class", + "PrettyPrinter.class", + "Test.class", + "ComposVisitor.class", + "AbstractVisitor.class", + "FoldVisitor.class", + "AllVisitor.class", + "parser.class", + "sym.class", + "Test.class"])) + [] + $ Makefile.mkRule ".PHONY" ["absyn"] + [] + $ Makefile.mkRule "%.class" [ "%.java" ] + [ "${JAVAC} ${JAVAC_FLAGS} $^" ] + $ Makefile.mkRule "absyn" [absynJavaSrc] + [ "${JAVAC} ${JAVAC_FLAGS} $^" ] + $ Makefile.mkRule (dirBase ++ "Yylex.java") [ dirBase ++ "Yylex" ] + [ "${JAVA} ${JAVA_FLAGS} ${JLEX} " ++ dirBase ++ "Yylex" ] + $ Makefile.mkRule (dirBase ++ "sym.java " ++ dirBase ++ "parser.java") + [ dirBase ++ name ++ ".cup" ] + [ "${JAVA} ${JAVA_FLAGS} ${CUP} ${CUPFLAGS} " ++ dirBase ++ name ++ ".cup" + , "mv sym.java parser.java " ++ dirBase ] + $ Makefile.mkRule (dirBase ++ "Yylex.class") [ dirBase ++ "Yylex.java", + dirBase ++ "sym.java" ] + [] + $ Makefile.mkRule (dirBase ++ "sym.class") [ dirBase ++ "sym.java" ] + [] + $ Makefile.mkRule (dirBase ++ "parser.class") [ dirBase ++ "parser.java" + , dirBase ++ "sym.java" ] + [] + $ Makefile.mkRule (dirBase ++ "PrettyPrinter.class") + [ dirBase ++ "PrettyPrinter.java" ] + [] +-- FIXME + $ Makefile.mkRule "clean" [] + [ "rm -f " ++ dirAbsyn ++ "*.class" ++ " " ++ dirBase ++ "*.class" + , "rm -f " ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps " ++ " *.class" ] + $ Makefile.mkRule "distclean" [ "vclean" ] + [] + $ Makefile.mkRule "vclean" [] + [ " rm -f " ++ absynJavaSrc ++ " " ++ absynJavaClass + , " rm -f " ++ dirAbsyn ++ "*.class" +-- , "rm -f " ++ "Test" ++ name + , " rmdir " ++ dirAbsyn + , " rm -f " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps " + , " rm -f " ++ unwords (map (dirBase ++) [ + "Yylex", + name ++ ".cup", + "Yylex.java", + "VisitSkel.java", + "ComposVisitor.java", + "AbstractVisitor.java", + "FoldVisitor.java", + "AllVisitor.java", + "PrettyPrinter.java", + "Skeleton.java", + "Test.java", + "sym.java", + "parser.java", + "*.class"]) + , "rm -f Makefile" + , "rmdir -p " ++ dirBase ] + "" + where absynJavaSrc = unwords (map (++ ".java") absynFileNames) + absynJavaClass = unwords (map (++ ".class") absynFileNames) + +javaTest :: String -> String -> CF -> String +javaTest packageBase packageAbsyn cf = + unlines + [ + "package" +++ packageBase ++ ";", + "import java_cup.runtime.*;", + "import" +++ packageBase ++ ".*;", + "import" +++ packageAbsyn ++ ".*;", + "import java.io.*;", + "", + "public class Test", + "{", + " public static void main(String args[]) throws Exception", + " {", + " Yylex l = null;", + " parser p;", + " try", + " {", + " if (args.length == 0) l = new Yylex(System.in);", + " else l = new Yylex(new FileReader(args[0]));", + " }", + " catch(FileNotFoundException e)", + " {", + " System.err.println(\"Error: File not found: \" + args[0]);", + " System.exit(1);", + " }", + " p = new parser(l);", + " /* The default parser is the first-defined entry point. */", + " /* You may want to change this. Other options are: */", + " /* " ++ (concat (intersperse ", " (showOpts (tail eps)))) ++ " */", + " try", + " {", + " " ++ packageAbsyn ++ "." ++ def +++ "parse_tree = p.p" + ++ def ++ "();", + " System.out.println();", + " System.out.println(\"Parse Succesful!\");", + " System.out.println();", + " System.out.println(\"[Abstract Syntax]\");", + " System.out.println();", + " System.out.println(PrettyPrinter.show(parse_tree));", + " System.out.println();", + " System.out.println(\"[Linearized Tree]\");", + " System.out.println();", + " System.out.println(PrettyPrinter.print(parse_tree));", + " }", + " catch(Throwable e)", + " {", + " System.err.println(\"At line \" + String.valueOf(l.line_num()) + \", near \\\"\" + l.buff() + \"\\\" :\");", + " System.err.println(\" \" + e.getMessage());", + " System.exit(1);", + " }", + " }", + "}" + ] + where eps = allEntryPoints cf + def = head eps + showOpts [] = [] + + showOpts (x:[]) = if normCat x /= x then [] else ['p' : (identCat x)] + showOpts (x:xs) = if normCat x /= x then (showOpts xs) + else ('p' : (identCat x)) : (showOpts xs) diff --git a/src/formats/ocaml/CFtoOCamlAbs.hs b/src/formats/ocaml/CFtoOCamlAbs.hs new file mode 100644 --- /dev/null +++ b/src/formats/ocaml/CFtoOCamlAbs.hs @@ -0,0 +1,63 @@ +{- + BNF Converter: OCaml Abstract Syntax Generator + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- based on BNFC Haskell backend + +module CFtoOCamlAbs (cf2Abstract) where + +import CF +import Utils((+++),(++++)) +import Data.List(intersperse) +import OCamlUtil + +-- to produce an OCaml module +cf2Abstract :: String -> CF -> String +cf2Abstract name cf = unlines $ + "(* OCaml module generated by the BNF converter *)\n\n" : + mutualRecDefs (map (prSpecialData cf) (specialCats cf) ++ map prData (cf2data cf)) + +-- allow mutual recursion so that we do not have to sort the type definitions in +-- dependency order +mutualRecDefs :: [String] -> [String] +mutualRecDefs ss = case ss of + [] -> [] + [x] -> ["type" +++ x] + x:xs -> ("type" +++ x) : map ("and" +++) xs + + + +prData :: Data -> String +prData (cat,rules) = + fixType cat +++ "=\n " ++ + concat (intersperse "\n | " (map prRule rules)) ++ + "\n" + +prRule (fun,[]) = fun +prRule (fun,cats) = fun +++ "of" +++ mkTupleType cats + +mkTupleType [c] = fixType c +mkTupleType (c:cs) = fixType c +++ "*" +++ mkTupleType cs + +prSpecialData :: CF -> Cat -> String +prSpecialData cf cat = fixType cat +++ "=" +++ cat +++ "of" +++ contentSpec cf cat +-- unwords ["newtype",cat,"=",cat,contentSpec cf cat,"deriving (Eq,Ord,Show)"] + +contentSpec :: CF -> Cat -> String +contentSpec cf cat = -- if isPositionCat cf cat then "((Int,Int),String)" else "String" + if isPositionCat cf cat then "((int * int) * string)" else "string" diff --git a/src/formats/ocaml/CFtoOCamlLex.hs b/src/formats/ocaml/CFtoOCamlLex.hs new file mode 100644 --- /dev/null +++ b/src/formats/ocaml/CFtoOCamlLex.hs @@ -0,0 +1,230 @@ +{- + BNF Converter: ocamllex Generator + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +-- based on BNFC Haskell backend + +module CFtoOCamlLex (cf2ocamllex) where + +import Data.List +import Data.Char + +import CF +import AbsBNF +import CFtoOCamlYacc (terminal) +import Utils ((+++)) + +cf2ocamllex :: String -> String -> CF -> String +cf2ocamllex name parserMod cf = + unlines $ concat $ intersperse [""] [ + header parserMod cf, + definitions cf, + let r = rules cf in case r of + [] -> [] + x:xs -> ("rule" +++ x) : map ("and" +++) xs + ] + +header :: String -> CF -> [String] +header parserMod cf = [ + "(* This ocamllex file was machine-generated by the BNF converter *)", + "{", + "open " ++ parserMod, + "open Lexing", + "", + hashtables cf, + "", + "let unescapeInitTail (s:string) : string =", + " let rec unesc s = match s with", + " '\\\\'::c::cs when List.mem c ['\\\"'; '\\\\'; '\\\''] -> c :: unesc cs", + " | '\\\\'::'n'::cs -> '\\n' :: unesc cs", + " | '\\\\'::'t'::cs -> '\\t' :: unesc cs", + " | '\\\"'::[] -> []", + " | c::cs -> c :: unesc cs", + " | _ -> []", + " (* explode/implode from caml FAQ *)", + " in let explode (s : string) : char list =", + " let rec exp i l =", + " if i < 0 then l else exp (i - 1) (s.[i] :: l) in", + " exp (String.length s - 1) []", + " in let implode (l : char list) : string =", + " let res = String.create (List.length l) in", + " let rec imp i = function", + " | [] -> res", + " | c :: l -> res.[i] <- c; imp (i + 1) l in", + " imp 0 l", + " in implode (unesc (List.tl (explode s)))", + "", + "let incr_lineno (lexbuf:Lexing.lexbuf) : unit =", + " let pos = lexbuf.lex_curr_p in", + " lexbuf.lex_curr_p <- { pos with", + " pos_lnum = pos.pos_lnum + 1;", + " pos_bol = pos.pos_cnum;", + " }", + "}" + ] + +-- | set up hashtables for reserved symbols and words +hashtables :: CF -> String +hashtables cf = ht "symbol_table" (symbols cf ) ++ "\n" ++ + ht "resword_table" (reservedWords cf) + where ht table syms | length syms == 0 = "" + ht table syms = unlines [ + "let" +++ table +++ "= Hashtbl.create " ++ show (length syms), + "let _ = List.iter (fun (kwd, tok) -> Hashtbl.add" +++ table + +++ "kwd tok)", + " [" ++ concat (intersperse ";" keyvals) ++ "]" + ] + where keyvals = map (\(x,y) -> "(" ++ x ++ ", " ++ y ++ ")") + (zip (map show syms) (map (terminal cf) syms)) + + + +definitions :: CF -> [String] +definitions cf = concat [ + cMacros, + rMacros cf + ] + + +cMacros :: [String] +cMacros = [ + "let l = ['a'-'z' 'A'-'Z' '\\192' - '\\255'] # ['\\215' '\\247'] (* isolatin1 letter FIXME *)", + "let c = ['A'-'Z' '\\192'-'\\221'] # ['\\215'] (* capital isolatin1 letter FIXME *)", + "let s = ['a'-'z' '\\222'-'\\255'] # ['\\247'] (* small isolatin1 letter FIXME *)", + "let d = ['0'-'9'] (* digit *)", + "let i = l | d | ['_' '\\''] (* identifier character *)", + "let u = ['\\000'-'\\255'] (* universal: any character *)" + ] + +rMacros :: CF -> [String] +rMacros cf = + let symbs = symbols cf + in + (if null symbs then [] else [ + "let rsyms = (* reserved words consisting of special symbols *)", + " " ++ unwords (intersperse "|" (map mkEsc symbs)) + ]) + where + mkEsc s = "\"" ++ concat (map f s) ++ "\"" + f x = if x `elem` ['"','\\'] then "\\" ++ [x] else [x] + + + +rules :: CF -> [String] +rules cf = oneRule $ concat [ + lexComments (comments cf), + ["l i* " ++ case reservedWords cf of + [] -> "{let id = lexeme lexbuf in TOK_Ident id}" + _ -> "{let id = lexeme lexbuf in try Hashtbl.find resword_table id with Not_found -> TOK_Ident id}" + ], + if null (symbols cf) then [] + else ["rsyms {let id = lexeme lexbuf in try Hashtbl.find symbol_table id with Not_found -> failwith (\"internal lexer error: reserved symbol \" ^ id ^ \" not found in hashtable\")}"], + ["d+ {let i = lexeme lexbuf in TOK_Integer (int_of_string i)}"], + ["d+ '.' d+ ('e' ('-')? d+)? {let f = lexeme lexbuf in TOK_Double (float_of_string f)}"], + ["'\\\"' ((u # ['\\\"' '\\\\' '\\n']) | ('\\\\' ('\\\"' | '\\\\' | '\\\'' | 'n' | 't')))* '\\\"' {let s = lexeme lexbuf in TOK_String (unescapeInitTail s)}"], + ["[' ' '\\t'] {token lexbuf}"], + ["'\\n' {incr_lineno lexbuf; token lexbuf}"], + ["eof { TOK_EOF }"] + ] + where + oneRule xs = ["token = \n parse " ++ concat (intersperse "\n | " xs)] + lexComments ([],[]) = [] + lexComments (xs,s1:ys) = ('\"' : s1 ++ "\"" ++ + " (_ # '\\n')* { token lexbuf } (* Toss single line comments *)") : + lexComments (xs, ys) + lexComments (([l1,l2],[r1,r2]):xs,[]) = (concat $ + [ + ('\"':l1:l2:"\" ((u # ['"), -- FIXME quotes or escape? + (l2:"']) | '"), + (r1:"' (u # ['"), + (r2:"']))* ('"), + (r1:"')+ '"), + (r2:"' { token lexbuf } \n") + ]) : + lexComments (xs, []) + lexComments ((_:xs),[]) = lexComments (xs,[]) + + +------------------------------------------------------------------- +-- Modified from the inlined version of @RegToAlex@. +------------------------------------------------------------------- + +-- modified from pretty-printer generated by the BNF converter + +-- the top-level printing method +printRegOCaml :: Reg -> String +printRegOCaml = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend 0 + where rend :: Int -> [String] -> String + rend i ss = case ss of + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + + cons s t = s ++ t + new i s = s + space t s = if null s then t else t ++ " " ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ c = [show c] -- if isAlphaNum c then [[c]] else ['\\':[c]] + prtList s = [show s] -- map (concat . prt 0) s + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["\"\""]) -- special construct for eps in ocamllex? + RChar c -> prPrec i 3 (concat [prt 0 c]) + RAlts str -> prPrec i 3 (concat [["["],prt 0 (concatMap show str),["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) + RDigit -> prPrec i 3 (concat [["digit"]]) + RLetter -> prPrec i 3 (concat [["letter"]]) + RUpper -> prPrec i 3 (concat [["upper"]]) + RLower -> prPrec i 3 (concat [["lower"]]) + RAny -> prPrec i 3 (concat [["univ"]]) diff --git a/src/formats/ocaml/CFtoOCamlPrinter.hs b/src/formats/ocaml/CFtoOCamlPrinter.hs new file mode 100644 --- /dev/null +++ b/src/formats/ocaml/CFtoOCamlPrinter.hs @@ -0,0 +1,200 @@ +{- + BNF Converter: Pretty-printer generator + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- based on BNFC Haskell backend + +module CFtoOCamlPrinter (cf2Printer) where + +import CF +import Utils +import CFtoTemplate +import Data.List (intersperse) +import Data.Char(toLower,isDigit) +import OCamlUtil + +-- derive pretty-printer from a BNF grammar. AR 15/2/2002 +cf2Printer :: String -> String -> CF -> String +cf2Printer name absMod cf = unlines [ + prologue name absMod, + charRule cf, + integerRule cf, + doubleRule cf, + stringRule cf, + if hasIdent cf then identRule cf else "", + unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf], + rules cf + ] + + +prologue :: String -> String -> String +prologue name absMod = unlines [ + "(* pretty-printer generated by the BNF converter *)\n", + "open " ++ absMod, + "open Printf", + "", + "(* We use string buffers for efficient string concatenation.", + " A document takes a buffer and an indentation, has side effects on the buffer", + " and returns a new indentation. The indentation argument indicates the level", + " of indentation to be used if a new line has to be started (because of what is", + " already in the buffer) *)", + "type doc = Buffer.t -> int -> int", + "", + "let rec printTree (printer : int -> 'a -> doc) (tree : 'a) : string = ", + " let buffer_init_size = 16 (* you may want to change this *)", + " in let buffer = Buffer.create buffer_init_size", + " in ", + " let _ = printer 0 tree buffer 0 in (* discard return value *)", + " Buffer.contents buffer", + "", + "let indent_width = 4", + "", + "let indent (i: int) : string = ", + " let s = String.make (i+1) ' ' in", + " String.set s 0 '\\n';", + " s", + "", + "(* this render function is written for C-style languages, you may want to change it *)", + "let render (s : string) : doc = fun buf i -> ", + " (* invariant: last char of the buffer is never whitespace *)", + " let n = Buffer.length buf in", + " let last = if n = 0 then None else Some (Buffer.nth buf (n-1)) in", + " let whitespace = match last with", + " None -> \"\" ", + " | Some '{' -> indent i", + " | Some '}' -> (match s with", + " \";\" -> \"\"", + " | _ -> indent i)", + " | Some ';' -> indent i", + " | (Some '[') | (Some '(') -> \"\"", + " | Some _ -> (match s with", + " \",\" | \")\" | \"]\" -> \"\"", + " | _ -> \" \") in", + " let newindent = match s with", + " \"{\" -> i + indent_width", + " | \"}\" -> i - indent_width", + " | _ -> i in", + " Buffer.add_string buf whitespace;", + " Buffer.add_string buf s;", + " newindent", + "", + "let emptyDoc : doc = fun buf i -> i", + "", + "let concatD (ds : doc list) : doc = fun buf i -> ", + " List.fold_left (fun accIndent elemDoc -> elemDoc buf accIndent) (emptyDoc buf i) ds", + "", + "let parenth (d:doc) : doc = concatD [render \"(\"; d; render \")\"]", + "", + "let prPrec (i:int) (j:int) (d:doc) : doc = if j String +rules cf = unlines $ mutualDefs $ + map (\(s,xs) -> case_fun s (map toArgs xs) ++ ifList cf s) $ cf2data cf + where + toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons) + names [] _ = [] + names (x:xs) n + | elem x xs = (x ++ show n) : names xs (n+1) + | otherwise = x : names xs n + var ('[':xs) = var (init xs) ++ "s" + var "Ident" = "id" + var "Integer" = "n" + var "String" = "str" + var "Char" = "c" + var "Double" = "d" + var xs = map toLower xs + checkRes s + | elem s reservedOCaml = s ++ "'" + | otherwise = s + ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf) + +--- case_fun :: Cat -> [(Constructor,Rule)] -> String +case_fun cat xs = unlines [ +-- "instance Print" +++ cat +++ "where", + prtFun cat +++"(i:int)" +++ "(e:" ++ fixType cat ++ ") : doc = match e with", + unlines $ insertBar $ map (\ ((c,xx),r) -> + " " ++ c +++ mkTuple xx +++ "->" +++ + "prPrec i" +++ show (precCat (fst r)) +++ mkRhs xx (snd r)) xs + ] + +ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where + nil cat = [" [] -> " ++ mkRhs [] its | + Rule f c its <- rulesOfCF cf, isNilFun f , normCatOfList c == cat] + one cat = [" | [x] -> " ++ mkRhs ["x"] its | + Rule f c its <- rulesOfCF cf, isOneFun f , normCatOfList c == cat] + cons cat = [" | x::xs -> " ++ mkRhs ["x","xs"] its | + Rule f c its <- rulesOfCF cf, isConsFun f , normCatOfList c == cat] + mkListRule [] = "" + mkListRule rs = unlines $ ("and prt" ++ fixTypeUpper cat ++ "ListBNFC" +++ "_ es : doc = match es with"):rs + + +mkRhs args its = + "(concatD [" ++ unwords (intersperse ";" (mk args its)) ++ "])" + where + mk args (Left "#" : items) = mk args items + mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items + mk args (Right s : items) = ("render " ++ show s) : mk args items + mk _ _ = [] + prt c = prtFun c +++ show (precCat c) + +prtFun :: Cat -> String +prtFun c = case c of + '[':xs -> case break (== ']') xs of + (t,"]") -> prtFun t ++ "ListBNFC" + _ -> c -- should not occur (this means an invariant of the type Cat is broken) + _ -> if precCat c > 0 -- precedence-level cats are not in abstract syntax + then "prt" ++ (fixTypeUpper $ reverse (dropWhile isDigit (reverse c))) + else "prt" ++ (fixTypeUpper c) + diff --git a/src/formats/ocaml/CFtoOCamlShow.hs b/src/formats/ocaml/CFtoOCamlShow.hs new file mode 100644 --- /dev/null +++ b/src/formats/ocaml/CFtoOCamlShow.hs @@ -0,0 +1,153 @@ +{- + BNF Converter: Non-pretty-printer generator (no "deriving Show" in OCaml...) + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- there is no "deriving Show" in OCaml, although there are solutions based +-- on camlp4. Here we generate our own "show module". + + +module CFtoOCamlShow (cf2show) where + +import CF +import Utils +import CFtoTemplate +import Data.List (intersperse) +import Data.Char(toLower,isDigit) +import OCamlUtil + +cf2show :: String -> String -> CF -> String +cf2show name absMod cf = unlines [ + prologue name absMod, + integerRule cf, + doubleRule cf, + if hasIdent cf then identRule cf else "", + unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf], + rules cf + ] + + +prologue :: String -> String -> String +prologue name absMod = unlines [ + "(* show functions generated by the BNF converter *)\n", + "open " ++ absMod, + "", + "(* use string buffers for efficient string concatenations *)", + "type showable = Buffer.t -> unit", + "", + "let show (s : showable) : string = ", + " let init_size = 16 in (* you may want to adjust this *)", + " let b = Buffer.create init_size in", + " s b;", + " Buffer.contents b", + " ", + "let emptyS : showable = fun buf -> ()", + "", + "let c2s (c:char) : showable = fun buf -> Buffer.add_char buf c", + "let s2s (s:string) : showable = fun buf -> Buffer.add_string buf s", + "", + "let ( >> ) (s1 : showable) (s2 : showable) : showable = fun buf -> s1 buf; s2 buf", + "", + "let showChar (c:char) : showable = fun buf -> ", + " Buffer.add_string buf (\"'\" ^ Char.escaped c ^ \"'\")", + "", + "let showString (s:string) : showable = fun buf -> ", + " Buffer.add_string buf (\"\\\"\" ^ String.escaped s ^ \"\\\"\")", + "", + "let showList (showFun : 'a -> showable) (xs : 'a list) : showable = fun buf -> ", + " let rec f ys = match ys with", + " [] -> ()", + " | [y] -> showFun y buf", + " | y::ys -> showFun y buf; Buffer.add_string buf \"; \"; f ys ", + " in", + " Buffer.add_char buf '[';", + " f xs;", + " Buffer.add_char buf ']'", + "" + ] + +integerRule cf = "let showInt (i:int) : showable = s2s (string_of_int i)" + +doubleRule cf = "let showFloat (f:float) : showable = s2s (string_of_float f)" + + +identRule cf = ownPrintRule cf "Ident" + +ownPrintRule cf own = unlines $ [ + "let rec" +++ showsFun own +++ "(" ++ own ++ posn ++ ") : showable = s2s \"" + ++ own ++ " \" >> showString i" + ] + where + posn = if isPositionCat cf own then " (_,i)" else " i" + +-- copy and paste from CFtoTemplate + +rules :: CF -> String +rules cf = unlines $ mutualDefs $ + map (\(s,xs) -> case_fun s (map toArgs xs)) $ cf2data cf -- ++ ifList cf s + where + toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), + ruleOf cons) + names [] _ = [] + names (x:xs) n + | elem x xs = (x ++ show n) : names xs (n+1) + | otherwise = x : names xs n + var ('[':xs) = var (init xs) ++ "s" + var "Ident" = "id" + var "Integer" = "n" + var "String" = "str" + var "Char" = "c" + var "Double" = "d" + var xs = map toLower xs + checkRes s + | elem s reservedOCaml = s ++ "'" + | otherwise = s + ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf) + +--- case_fun :: Cat -> [(Constructor,Rule)] -> String +case_fun cat xs = unlines [ +-- "instance Print" +++ cat +++ "where", + showsFun cat +++ "(e:" ++ fixType cat ++ ") : showable = match e with", + unlines $ insertBar $ map (\ ((c,xx),r) -> + " " ++ c +++ mkTuple xx +++ "->" +++ + "s2s" +++ show c +++ + case mkRhs xx (snd r) of {[] -> []; str -> ">> c2s ' ' >> " ++ str} + ) + xs + ] + + +mkRhs args its = + case unwords (intersperse " >> s2s \", \" >> " (mk args its)) of + [] -> "" + str -> "c2s '(' >> " ++ str ++ " >> c2s ')'" + where + mk args (Left "#" : items) = mk args items + mk (arg:args) (Left c : items) = (showsFun c +++ arg) : mk args items + mk args (Right s : items) = mk args items + mk _ _ = [] + prt c = showsFun c +++ show (precCat c) + +showsFun :: Cat -> String +showsFun c = case c of + '[':xs -> case break (== ']') xs of + (t,"]") -> "showList" +++ showsFun t -- showFun t ++ "List" + _ -> c -- should not occur (this means an invariant of the type Cat is broken) + _ -> if precCat c > 0 -- precedence-level cats are not in abstract syntax + then "show" ++ (fixTypeUpper $ reverse (dropWhile isDigit (reverse c))) + else "show" ++ (fixTypeUpper c) + diff --git a/src/formats/ocaml/CFtoOCamlTemplate.hs b/src/formats/ocaml/CFtoOCamlTemplate.hs new file mode 100644 --- /dev/null +++ b/src/formats/ocaml/CFtoOCamlTemplate.hs @@ -0,0 +1,73 @@ +{- + BNF Converter: Template Generator + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- based on BNFC Haskell backend + + +module CFtoOCamlTemplate ( + cf2Template + ) where + +import CF +import Data.Char +import Data.List (delete) +import Utils((+++)) +import OCamlUtil + + +type ModuleName = String +type Constructor = String + +cf2Template :: ModuleName -> ModuleName -> CF -> String +cf2Template skelName absName cf = unlines + [ + "module "++ skelName ++ " = struct\n", + "(* OCaml module generated by the BNF converter *)\n", + "open " ++ absName ++ "\n", + "type result = string\n", + "let failure x = failwith \"Undefined case.\" (* x discarded *)\n", + unlines $ mutualDefs $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf, + "end" + ] + where toArgs [] = [] + toArgs ((cons,args):xs) + = (cons ++ " " ++ (mkTuple $ names (map (checkRes . var) args) (0 :: Int))) : toArgs xs + names :: [String] -> Int -> [String] + names [] _ = [] + names (x:xs) n + | elem x xs = (x ++ show n) : names xs (n+1) + | otherwise = x : names xs n + var ('[':xs) = var (init xs) ++ "s" + var "Ident" = "id" + var "Integer" = "n" + var "String" = "str" + var "Char" = "c" + var "Double" = "d" + var xs = map toLower xs + checkRes s + | elem s reservedOCaml = s ++ "'" + | otherwise = s + + +case_fun :: Cat -> [Constructor] -> String +case_fun cat xs = + unlines $ + ["trans" ++ cat ++ " (x : " ++ fixType cat ++ ") : result = match x with", + unlines $ insertBar $ map (\s -> s ++ " -> " ++ "failure x") xs] + diff --git a/src/formats/ocaml/CFtoOCamlTest.hs b/src/formats/ocaml/CFtoOCamlTest.hs new file mode 100644 --- /dev/null +++ b/src/formats/ocaml/CFtoOCamlTest.hs @@ -0,0 +1,70 @@ +{- + BNF Converter: Generate main/test module for OCaml + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoOCamlTest where + +import CF +import Utils +import OCamlUtil + +ocamlTestfile :: String -> String -> String -> String -> String -> CF -> String +ocamlTestfile absM lexM parM printM showM cf = + let + lexerName = lexM ++ ".token" + parserName = parM ++ ".p" ++ topTypeC + printerName = printM ++ ".printTree " ++ printM ++ ".prt" ++ topTypeC + showFun = "(fun x -> " ++ showM ++ ".show (" ++ showM ++ ".show" ++ + topTypeC ++ " x))" + topTypeC = fixTypeUpper (firstEntry cf) + topType = absM ++ "." ++ fixType (firstEntry cf) + in unlines [ + "(* automatically generated by the BNF Converter *)", + "", + "open Lexing", + "", + "let parse (c : in_channel) : " ++ topType ++ " = ", + " " ++ parserName +++ lexerName +++ "(Lexing.from_channel c)", + ";;", + "", + "let showTree (t : " ++ topType ++ ") : string = ", + " \"[Abstract syntax]\\n\\n\" ^ " ++ showFun +++ "t" ++ " ^ \"\\n\\n\" ^", + " \"[Linearized tree]\\n\\n\" ^ " ++ printerName +++ "t" ++ " ^ \"\\n\"", + ";;", + "", + "let main () =", + " let channel =", + " if Array.length Sys.argv > 1 then", + " open_in Sys.argv.(1)", + " else", + " stdin", + " in", + " try", + " print_string (showTree (parse channel));", + " flush stdout", + " with BNFC_Util.Parse_error (start_pos, end_pos) ->", -- " ++ parM ++ ". + " Printf.printf \"Parse error at %d.%d-%d.%d\\n\"", + " start_pos.pos_lnum (start_pos.pos_cnum - start_pos.pos_bol)", + " end_pos.pos_lnum (end_pos.pos_cnum - end_pos.pos_bol);", + ";;", + "", + "main ();;", + "" + ] + + diff --git a/src/formats/ocaml/CFtoOCamlYacc.hs b/src/formats/ocaml/CFtoOCamlYacc.hs new file mode 100644 --- /dev/null +++ b/src/formats/ocaml/CFtoOCamlYacc.hs @@ -0,0 +1,232 @@ +{- + BNF Converter: ocamlyacc Generator + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- based on BNFC Haskell backend + + +module CFtoOCamlYacc + ( + cf2ocamlyacc, terminal + ) + where + +import CF +import Data.List (intersperse,nub) +import Data.Char + +import Utils ((+++)) +import OCamlUtil + +-- Type declarations + +type Rules = [(NonTerminal,[(Pattern,Action)])] +type NonTerminal = String +type Pattern = String +type Action = String +type MetaVar = String + +-- default naming + + +tokenName = "Token" + + + +-- The main function, that given a CF +-- generates a ocamlyacc module. +cf2ocamlyacc :: String -> String -> String -> CF -> String +cf2ocamlyacc name absName lexName cf + = unlines + [header name absName lexName, + declarations absName cf, + "%%", + rules cf + ] + + +header :: String -> String -> String -> String +header modName absName lexName = unlines + ["/* This ocamlyacc file was machine-generated by the BNF converter */", + "%{", + "open " ++ absName, + "open Lexing", + "%}" + ] + + +declarations :: String -> CF -> String +declarations absName cf = unlines + [tokens (symbols cf) (reservedWords cf), + specialTokens cf, + entryPoints absName cf + ] + +tokens :: [String] -> [String] -> String +tokens symbols reswords = unlines + [ + if (length reswords) > 0 + then "%token" +++ concat (intersperse " " (map ("TOK_" ++) reswords)) + else "" + , + concatMap (\(s,n) -> "\n%token SYMB" ++ (show n) +++ "/*" +++ s +++ "*/") + (zip symbols [1..]) + ] + +-- | map a CF terminal into a ocamlyacc token +terminal :: CF -> String -> String +terminal cf s | s `elem` reservedWords cf = "TOK_" ++ s +terminal cf s = case lookup s (zip (symbols cf) [1..]) of + Just i -> "SYMB" ++ show i + Nothing -> error $ "CFtoOCamlYacc: terminal " ++ show s ++ " not defined in CF." + + +-- | map a CF nonterminal into a ocamlyacc symbol +nonterminal :: Cat -> String +nonterminal c = map spaceToUnderscore (fixType c) + where spaceToUnderscore ' ' = '_' + spaceToUnderscore x = x + +specialTokens :: CF -> String +specialTokens cf = unlines ("%token TOK_EOF" : map aux (nub $ ["Ident","String","Integer","Double","Char"] ++ literals cf)) + where aux cat = "%token" +++ (case cat of + "Ident" -> "" + "String" -> "" + "Integer" -> "" + "Double" -> "" + "Char" -> "" + own -> "" ) + +++ "TOK_" ++ cat + + +entryPoints :: String -> CF -> String +entryPoints absName cf = unlines $ + ("%start" +++ + concat (intersperse " " (map epName eps))) + : + (map typing eps) + where eps = (nub $ map normCat (allEntryPoints cf)) + typing :: Cat -> String + typing c = "%type" +++ "<" ++ qualify c ++ ">" +++ epName c + qualify c = if c `elem` ["Integer","Double","Char","String", + "[Integer]","[Double]","[Char]","[String]"] + then fixType c + else absName ++ "." ++ fixType c + +epName :: Cat -> String +epName c = "p" ++ capitalize (nonterminal c) + where capitalize s = case s of + [] -> [] + c:cs -> toUpper c : cs + +entryPointRules :: CF -> String +entryPointRules cf = unlines $ map mkRule (nub $ map normCat (allEntryPoints cf)) + where + mkRule :: String -> String + mkRule s = unlines [ + epName s ++ " : " ++ nonterminal s ++ " TOK_EOF { $1 }", + " | error { raise (BNFC_Util.Parse_error (Parsing.symbol_start_pos (), Parsing.symbol_end_pos ())) };" + ] + +rules :: CF -> String +rules cf = unlines [ + entryPointRules cf, + (unlines $ map (prOne . mkOne) (ruleGroups cf)), + specialRules cf + ] + where + mkOne (cat,rules) = constructRule cf rules cat + prOne (nt,[]) = [] -- nt has only internal use + prOne (nt,((p,a):ls)) = + unwords [nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ ";\n" + where + nt' = nonterminal nt + pr [] = [] + pr ((p,a):ls) = + unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls + + + +-- For every non-terminal, we construct a set of rules. A rule is a sequence of +-- terminals and non-terminals, and an action to be performed +-- As an optimization, a pair of list rules [C] ::= "" | C k [C] +-- is left-recursivized into [C] ::= "" | [C] C k. +-- This could be generalized to cover other forms of list rules. +constructRule :: CF -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule cf rules nt = (nt,[(p,generateAction nt (funRule r) (mkFlip b m)) | + r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True,revSepListRule r0) + else (False,r0), + let (p,m) = generatePatterns cf r]) + where + revs = reversibleCats cf + mkFlip doit xs = case xs of + a:b:rest | doit -> b:a:rest + _ -> xs + + + +-- Generates a string containing the semantic action. +-- An action can for example be: Sum $1 $2, that is, construct an AST +-- with the constructor Sum applied to the two metavariables $1 and $2. +generateAction :: NonTerminal -> Fun -> [MetaVar] -> Action +generateAction nt f ms = (if isCoercion f then "" else f') +++ mkTuple ms + where f' = case f of -- ocaml cons is somehow not a standard infix oper, right? + "(:[])" -> "(fun x -> [x])" + "(:)" -> "(fun (x,xs) -> x::xs)" + _ -> f + + +generatePatterns :: CF -> Rule -> (Pattern,[MetaVar]) +generatePatterns cf r = case rhsRule r of + [] -> ("/* empty */",[]) + its -> (unwords (map mkIt its), metas its) + where + mkIt i = case i of + Left c -> nonterminal c + Right s -> terminal cf s + metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its] + revIf c m = if (not (isConsFun (funRule r)) && elem c revs) + then ("(List.rev " ++ m ++ ")") + else m -- no reversal in the left-recursive Cons rule itself + revs = reversibleCats cf + + + + + +specialRules :: CF -> String +specialRules cf = unlines $ + map aux (literals cf) + where + aux cat = + case cat of + "Ident" -> "ident : TOK_Ident { Ident $1 };" + "String" -> "string : TOK_String { $1 };" + "Integer" -> "int : TOK_Integer { $1 };" + "Double" -> "float : TOK_Double { $1 };" + "Char" -> "char : TOK_Char { $1 };" + own -> (fixType own) ++ " : TOK_" ++ own ++ + " { " ++ own ++ " ("++ posn ++ "$1)};" + -- PCC: take "own" as type name? (manual says newtype) + where -- ignore position categories for now + posn = "" -- if isPositionCat cf cat then "mkPosToken " else "" + + + diff --git a/src/formats/ocaml/OCamlTop.hs b/src/formats/ocaml/OCamlTop.hs new file mode 100644 --- /dev/null +++ b/src/formats/ocaml/OCamlTop.hs @@ -0,0 +1,188 @@ +{- + BNF Converter: OCaml main file + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- based on BNFC Haskell backend + + +module OCamlTop (makeOCaml) where + +import CF +import CFtoOCamlYacc +import CFtoOCamlLex +import CFtoLatex +import CFtoOCamlAbs +import CFtoOCamlTemplate +import CFtoOCamlPrinter +import CFtoOCamlShow +import CFtoOCamlTest +import CFtoXML +import Utils +import Options + +import Data.Char +import Data.Maybe (fromMaybe,maybe) +import System.Exit (exitFailure) +import Control.Monad(when) + +-- naming conventions + +noLang :: Options -> String -> String +noLang _ name = name + +withLang :: Options -> String -> String +withLang opts name = name ++ lang opts + +mkMod :: (Options -> String -> String) -> String -> Options -> String +mkMod addLang name opts = + pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name + where pref = maybe "" (++".") (inPackage opts) + +mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath +mkFile addLang name ext opts = + pref ++ if inDir opts + then lang opts ++ [pathSep] ++ name ++ ext' + else addLang opts name ++ if null ext then "" else ext' + where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts) + ext' = if null ext then "" else "." ++ ext + +absFile, absFileM, ocamllexFile, ocamllexFileM, dviFile, + ocamlyaccFile, ocamlyaccFileM, + latexFile, utilFile, utilFileM, + templateFile, templateFileM, + printerFile, printerFileM, + psFile, tFile, tFileM :: Options -> String +absFile = mkFile withLang "Abs" "ml" +absFileM = mkMod withLang "Abs" +ocamllexFile = mkFile withLang "Lex" "mll" +ocamllexFileM = mkMod withLang "Lex" +ocamlyaccFile = mkFile withLang "Par" "mly" +ocamlyaccFileM = mkMod withLang "Par" +latexFile = mkFile withLang "Doc" "tex" +templateFile = mkFile withLang "Skel" "ml" +templateFileM = mkMod withLang "Skel" +printerFile = mkFile withLang "Print" "ml" +printerFileM = mkMod withLang "Print" +showFile = mkFile withLang "Show" "ml" +showFileM = mkMod withLang "Show" +dviFile = mkFile withLang "Doc" "dvi" +psFile = mkFile withLang "Doc" "ps" +tFile = mkFile withLang "Test" "ml" +tFileM = mkMod withLang "Test" +utilFile = mkFile noLang "BNFC_Util" "ml" +utilFileM = mkMod noLang "BNFC_Util" +xmlFileM = mkMod withLang "XML" + +type Options = SharedOptions + +-- FIXME: we probably don't need all these arguments +makeOCaml :: Options -> CF -> IO () +makeOCaml opts cf = do + let absMod = absFileM opts + lexMod = ocamllexFileM opts + parMod = ocamlyaccFileM opts + prMod = printerFileM opts + showMod = showFileM opts +-- layMod = layoutFileM opts + utilMod = utilFileM opts + do + let dir = codeDir opts + when (not (null dir)) $ do + putStrLn $ "Creating directory " ++ dir + prepareDir dir + writeFileRep (absFile opts) $ cf2Abstract absMod cf + writeFileRep (ocamllexFile opts) $ cf2ocamllex lexMod parMod cf + writeFileRep (ocamlyaccFile opts) $ + cf2ocamlyacc parMod absMod lexMod cf + writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf + writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod cf + writeFileRep (printerFile opts) $ cf2Printer prMod absMod cf + writeFileRep (showFile opts) $ cf2show showMod absMod cf + writeFileRep (tFile opts) $ ocamlTestfile absMod lexMod parMod prMod showMod cf + writeFileRep (utilFile opts) $ utilM + when (make opts) $ writeFileRep "Makefile" $ makefile opts + case xml opts of + 2 -> makeXML (lang opts) True cf + 1 -> makeXML (lang opts) False cf + _ -> return () + +pkgToDir :: String -> FilePath +pkgToDir s = replace '.' pathSep s + +codeDir :: Options -> FilePath +codeDir opts = let pref = maybe "" pkgToDir (inPackage opts) + dir = if inDir opts then lang opts else "" + sep = if null pref || null dir then "" else [pathSep] + in pref ++ sep ++ dir + +makefile :: Options -> String +makefile opts = makeA where + dir = let d = codeDir opts in if null d then "" else d ++ [pathSep] + cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")" + makeA = unlines + [ + "all:", + "\tocamlyacc " ++ ocamlyaccFile opts, + "\tocamllex " ++ ocamllexFile opts, + "\t" ++ cd ("latex " ++ basename (latexFile opts) + ++ "; " ++ "dvips " ++ basename (dviFile opts) + ++ " -o " ++ basename (psFile opts)), + "\tocamlc -o " ++ mkFile withLang "Test" "" opts +++ + utilFile opts +++ + absFile opts +++ templateFile opts +++ + showFile opts +++ printerFile opts +++ + mkFile withLang "Par" "mli" opts +++ + mkFile withLang "Par" "ml" opts +++ + mkFile withLang "Lex" "ml" opts +++ + tFile opts, + "", + "clean:", + "\t-rm -f " ++ unwords (map (dir++) [ + "*.log", "*.aux", "*.cmi", + "*.cmo", "*.o", "*.dvi" + ]), + "\t-rm -f " ++ psFile opts, + "", + "distclean: clean", + "\t-rm -f " ++ unwords [ + mkFile withLang "Doc" "*" opts, + mkFile withLang "Lex" "*" opts, + mkFile withLang "Par" "*" opts, + mkFile withLang "Layout" "*" opts, + mkFile withLang "Skel" "*" opts, + mkFile withLang "Print" "*" opts, + mkFile withLang "Show" "*" opts, + mkFile withLang "Test" "*" opts, + mkFile withLang "Abs" "*" opts, + mkFile withLang "Test" "" opts, + utilFile opts, + "Makefile*" + ] + ] + + +utilM :: String +utilM = unlines + ["(* automatically generated by BNFC *)", + "", + "open Lexing", + "", + "(* this should really be in the parser, but ocamlyacc won't put it in the .mli *)", + "exception Parse_error of Lexing.position * Lexing.position" + ] + diff --git a/src/formats/ocaml/OCamlUtil.hs b/src/formats/ocaml/OCamlUtil.hs new file mode 100644 --- /dev/null +++ b/src/formats/ocaml/OCamlUtil.hs @@ -0,0 +1,72 @@ +{- + BNF Converter: OCaml backend utility module + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module OCamlUtil where + +import CF +import Utils +import Data.Char (toLower, toUpper) + +-- Translate Haskell types to OCaml types +-- Note: OCaml (data-)types start with lowercase letter +fixType :: Cat -> String +fixType s = case s of + '[':xs -> case break (== ']') xs of + (t,"]") -> fixType t +++ "list" + _ -> s -- should not occur (this means an invariant of the type Cat is broken) + "Integer" -> "int" + "Double" -> "float" + c:cs -> let ls = toLower c : cs in + if (elem ls reservedOCaml) then (ls ++ "T") else ls + _ -> s + +-- as fixType, but leave first character in upper case +fixTypeUpper :: Cat -> String +fixTypeUpper c = case fixType c of + [] -> [] + c:cs -> toUpper c : cs + + +reservedOCaml :: [String] +reservedOCaml = [ + "and","as","assert","asr","begin","class", + "constraint","do","done","downto","else","end", + "exception","external","false","for","fun","function", + "functor","if","in","include","inherit","initializer", + "land","lazy","let","lor","lsl","lsr", + "lxor","match","method","mod","module","mutable", + "new","object","of","open","or","private", + "rec","sig","struct","then","to","true", + "try","type","val","virtual","when","while","with"] + +mkTuple :: [String] -> String +mkTuple [] = "" +mkTuple [x] = x +mkTuple (x:xs) = "(" ++ foldl (\acc e -> acc ++ "," +++ e) x xs ++ ")" + +insertBar :: [String] -> [String] +insertBar [] = [] +insertBar [x] = [" " ++ x] +insertBar (x:xs) = (" " ++ x ) : map (" | " ++) xs + +mutualDefs :: [String] -> [String] +mutualDefs defs = case defs of + [] -> [] + [d] -> ["let rec" +++ d] + d:ds -> ("let rec" +++ d) : map ("and" +++) ds diff --git a/src/formats/profile/CFtoHappyProfile.hs b/src/formats/profile/CFtoHappyProfile.hs new file mode 100644 --- /dev/null +++ b/src/formats/profile/CFtoHappyProfile.hs @@ -0,0 +1,223 @@ +{- + BNF Converter: Happy Generator + Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoHappyProfile + ( + cf2HappyProfileS + ) + where + +import CF +--import Lexer +import Data.List (intersperse) +import Data.Char + +-- Type declarations + +type Rules = [(NonTerminal,[(Pattern,Action)])] +type NonTerminal = String +type Pattern = String +type Action = String +type MetaVar = String + +-- default naming + +moduleName = "HappyParser" +tokenName = "Token" + +-- The main function, that given a CF and a CFCat to parse according to, +-- generates a happy module. +cf2HappyProfileS :: String -> String -> String -> String -> CFP -> String +cf2HappyProfileS = cf2Happy + +cf2Happy :: String -> String -> String -> String -> CFP -> String +cf2Happy name absName lexName errName cf + = unlines + [header name absName lexName errName, + declarations (allEntryPointsP cf), + tokens (symbols cf ++ reservedWords cf), + specialToks cf, + delimiter, + specialRules cf, + prRules (rulesForHappy cf), + finalize cf] + +-- construct the header. +header :: String -> String -> String -> String -> String +header modName absName lexName errName = unlines + ["-- This Happy file was machine-generated by the BNF converter", + "{", + "module " ++ modName ++ " where", +---- "import " ++ absName, + "import Trees", + "import " ++ lexName, + "import " ++ errName, + "}" + ] + + +-- The declarations of a happy file. +declarations :: [NonTerminal] -> String +declarations ns = unlines + [generateP ns, + "%monad { Err } { thenM } { returnM }", + "%tokentype { " ++ tokenName ++ " }"] + where generateP [] = [] + generateP (n:ns) = concat ["%name p",n'," ",n',"\n",generateP ns] + where n' = identCat n + +-- The useless delimiter symbol. +delimiter :: String +delimiter = "\n%%\n" + +-- Generate the list of tokens and their identifiers. +tokens :: [String] -> String +tokens toks = "%token \n" ++ prTokens toks + where prTokens [] = [] + prTokens (t:tk) = " " ++ (convert t) ++ + " { " ++ oneTok t ++ " }\n" ++ + prTokens tk + oneTok t = "PT _ (TS " ++ show t ++ ")" + +-- Happy doesn't allow characters such as åäö to occur in the happy file. This +-- is however not a restriction, just a naming paradigm in the happy source file. +convert :: String -> String +convert "\\" = concat ['\'':"\\\\","\'"] +convert xs = concat ['\'':(escape xs),"\'"] + where escape [] = [] + escape ('\'':xs) = '\\':'\'':escape xs + escape (x:xs) = x:escape xs + +rulesForHappy :: CFP -> Rules +rulesForHappy cf = map mkOne $ ruleGroupsP cf where + mkOne (cat,rules) = constructRule cf rules cat + +-- For every non-terminal, we construct a set of rules. A rule is a sequence of +-- terminals and non-terminals, and an action to be performed +-- As an optimization, a pair of list rules [C] ::= "" | C k [C] +-- is left-recursivized into [C] ::= "" | [C] C k. +-- This could be generalized to cover other forms of list rules. +constructRule :: CFP -> [RuleP] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule cf rules nt = (nt,[(p,generateAction nt (revF b r) m) | + r0 <- rules, + let (b,r) = if isConsFun (funRuleP r0) && elem (valCat r0) revs + then (True,revSepListRule r0) + else (False,r0), + let (p,m) = generatePatterns cf r]) + where + ---- left rec optimization does not work yet + revF b r = ---- if b then ("flip " ++ funRuleP r) else (funRuleP r) + funRule r + revs = reversibleCats cf + +-- Generates a string containing the semantic action. +-- An action can for example be: Sum $1 $2, that is, construct an AST +-- with the constructor Sum applied to the two metavariables $1 and $2. +generateAction :: NonTerminal -> FunP -> [MetaVar] -> Action +generateAction nt f@(_,(h,p)) ms = unwords $ (if isCoercion h then args else (fun ++ mss)) + where + fun = ["mkFunTree",show h,show p] + mss = ["["] ++ intersperse "," ms ++ ["]"] + args = intersperse "," ms + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal + +generatePatterns :: CFP -> RuleP -> (Pattern,[MetaVar]) +generatePatterns cf r = case rhsRule r of + [] -> ("{- empty -}",[]) + its -> (unwords (map mkIt its), metas its) + where + mkIt i = case i of + Left c -> identCat c + Right s -> convert s + metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its] + revIf c m = if (not (isConsFun (funRuleP r)) && elem c revs) + then ("(reverse " ++ m ++ ")") + else m -- no reversal in the left-recursive Cons rule itself + revs = reversibleCats cf + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. + +prRules :: Rules -> String +prRules = unlines . map prOne + where + prOne (nt,[]) = [] -- nt has only internal use + prOne (nt,((p,a):ls)) = + unwords [nt', "::", "{", "CFTree", "}\n" ++ + nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ "\n" + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = + unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls + +-- Finally, some haskell code. + +finalize :: CFP -> String +finalize cf = unlines + [ + "{", + "\nreturnM :: a -> Err a", + "returnM = return", + "\nthenM :: Err a -> (a -> Err b) -> Err b", + "thenM = (>>=)", + "\nhappyError :: [" ++ tokenName ++ "] -> Err a", + "happyError ts =", + " Bad $ \"syntax error at \" ++ tokenPos ts ++ " ++ + "if null ts then [] else " ++ + "(\" before \" ++ " ++ "unwords (map prToken (take 4 ts)))", + "\nmyLexer = tokens", + "}" + ] + +-- aarne's modifs 8/1/2002: +-- Markus's modifs 11/02/2002 + +-- GF literals +specialToks :: CFP -> String +specialToks cf = unlines $ + (map aux (literals cf)) + ++ ["L_err { _ }"] + where aux cat = + case cat of + "Ident" -> "L_ident { PT _ (TV $$) }" + "String" -> "L_quoted { PT _ (TL $$) }" + "Integer" -> "L_integ { PT _ (TI $$) }" + "Double" -> "L_doubl { PT _ (TD $$) }" + "Char" -> "L_charac { PT _ (TC $$) }" + own -> "L_" ++ own ++ " { PT _ (T_" ++ own ++ " " ++ posn ++ ") }" + where + posn = if isPositionCat cf cat then "_" else "$$" + +specialRules :: CFP -> String +specialRules cf = unlines $ + map aux (literals cf) + where + aux cat = + case cat of + "Ident" -> "Ident : L_ident { mkAtTree (AV (Ident $1)) }" + "String" -> "String : L_quoted { mkAtTree (AS $1) }" + "Integer" -> "Integer : L_integ { mkAtTree (AI ((read $1) :: Integer)) }" + "Double" -> "Double : L_doubl { (read $1) :: Double }" ---- + "Char" -> "Char : L_charac { (read $1) :: Char }" ---- + own -> own ++ " : L_" ++ own ++ " { " ++ own ++ " ("++ posn ++ "$1)}" + where + posn = if isPositionCat cf cat then "mkPosToken " else "" diff --git a/src/formats/profile/ProfileTop.hs b/src/formats/profile/ProfileTop.hs new file mode 100644 --- /dev/null +++ b/src/formats/profile/ProfileTop.hs @@ -0,0 +1,226 @@ +{- + BNF Converter: Haskell main file + Copyright (C) 2004 Author: Markus Forberg, Peter Gammie, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module ProfileTop (makeAllProfile) where + +-- import Utils +import CF +import CFtoHappyProfile +import CFtoAlex +import CFtoAlex2 +import CFtoLatex +import MkErrM +---- import CFtoAbstract +---- import CFtoTemplate +---- import CFtoPrinter +---- import CFtoLayout +---- import CFtoXML +import Utils + +import Data.Char +import System.Exit(exitFailure) +import Control.Monad(when) + +-- naming conventions + +nameMod :: String -> Bool -> String -> FilePath +nameMod name inDir lang = + if inDir + then lang ++ "." ++ name + else name ++ lang + +nameFile :: String -> String -> Bool -> String -> FilePath +nameFile name ext inDir lang = + if inDir + then lang ++ "/" ++ name ++ "." ++ ext + else name ++ lang ++ "." ++ ext + +absFile, absFileM, alexFile, alexFileM, dviFile, + gfAbs, gfConc, + happyFile, happyFileM, + latexFile, errFile, errFileM, + templateFile, templateFileM, + printerFile, printerFileM, + layoutFile, layoutFileM, + psFile, tFile, tFileM, mFile :: Bool -> String -> FilePath +absFile = nameFile "Abs" "hs" +absFileM = nameMod "Abs" +alexFile = nameFile "Lex" "x" +alexFileM = nameMod "Lex" +happyFile = nameFile "Par" "y" +happyFileM = nameMod "Par" +latexFile = nameFile "Doc" "tex" +templateFile = nameFile "Skel" "hs" +templateFileM = nameMod "Skel" +printerFile = nameFile "Print" "hs" +printerFileM = nameMod "Print" +dviFile = nameFile "Doc" "dvi" +psFile = nameFile "Doc" "ps" +gfAbs = nameFile "" "Abs.gf" +gfConc = nameFile "" "Conc.gf" +tFile = nameFile "Test" "hs" +tFileM = nameMod "Test" +mFile inDir n = if inDir then n ++ "/" ++ "Makefile" else "Makefile" +errFile b n = if b then n ++ "/" ++ "ErrM.hs" else "ErrM.hs" +errFileM b n = if b then n ++ "." ++ "ErrM" else "ErrM" +layoutFileM = nameMod "Layout" +xmlFileM = nameMod "XML" +layoutFile = nameFile "Layout" "hs" + +makeAllProfile :: Bool -> Bool -> Bool -> Int -> String -> CFP -> IO () +makeAllProfile make alex1 inDir xml name cfp = do + let absMod = absFileM inDir name + lexMod = alexFileM inDir name + parMod = happyFileM inDir name + prMod = printerFileM inDir name + layMod = layoutFileM inDir name + tplMod = templateFileM inDir name + errMod = errFileM inDir name + let cf = cfp2cf cfp + do + when inDir (prepareDir name) +---- writeFileRep (absFile inDir name) $ cf2Abstract (absFileM inDir name) cf + if (alex1) then do + writeFileRep (alexFile inDir name) $ cf2alex lexMod errMod cf + putStrLn " (Use Alex 1.1 to compile.)" + else do + writeFileRep (alexFile inDir name) $ cf2alex2 lexMod errMod "" False False cf + putStrLn " (Use Alex 2.0 to compile.)" + writeFileRep (happyFile inDir name) $ + cf2HappyProfileS parMod absMod lexMod errMod cfp + putStrLn " (Tested with Happy 1.13)" + writeFileRep (latexFile inDir name) $ cfToLatex name cf +---- writeFileRep (templateFile inDir name) $ +---- cf2Template tplMod absMod errMod cf +---- writeFileRep (printerFile inDir name) $ cf2Printer prMod absMod cf +---- if hasLayout cf then +---- writeFileRep (layoutFile inDir name) $ cf2Layout alex1 inDir layMod lexMod cf +---- else return () + writeFileRep (tFile inDir name) $ testfile inDir name (xml>0) cf + writeFileRep (errFile inDir name) $ errM errMod cf + if make + then (writeFileRep (mFile inDir name) $ makefile inDir name) + else return () +---- case xml of +---- 2 -> makeXML name True cf +---- 1 -> makeXML name False cf +---- _ -> return () + +makefile :: Bool -> String -> String +makefile inDir name = makeA where + name' = if inDir then "" else name -- Makefile is inDir + ghcCommand = "ghc --make "++ tFile inDir name ++ " -o " ++ + if inDir then name ++ "/" ++ "Test" else "Test" ++ name + makeA = unlines + [ + "all:", + "\thappy -gca " ++ happyFile False name', + "\talex " ++ alexFile False name', + "\tlatex " ++ latexFile False name', + "\tdvips " ++ dviFile False name' ++ " -o " ++ psFile False name', + "\t" ++ if inDir then + "(" ++ "cd ..; " ++ ghcCommand ++ ")" + else ghcCommand, + "clean:", + "\t rm -f " ++ unwords [ + "*.log *.aux *.hi *.o *.dvi", + psFile False name', + "*.o" + ], + "distclean: " ++ if inDir then "" else "clean", + if inDir then + "\t rm -rf ../" ++ name -- erase this directory! + else + "\t rm -f " ++ unwords [ + "Doc" ++ name ++ ".*", + "Lex" ++ name ++ ".*", + "Par" ++ name ++ ".*", +---- "Layout" ++ name ++ ".*", +---- "Skel" ++ name ++ ".*", +---- "Print" ++ name ++ ".*", + "Test" ++ name ++ ".*", +---- "Abs" ++ name ++ ".*", + "Test" ++ name, + "ErrM.*", +---- name ++ ".dtd", +---- "XML" ++ name ++ ".*", + "Makefile*" + ] + ] + + +testfile :: Bool -> String -> Bool -> CF -> String +testfile inDir name xml cf = makeA where + + makeA = let lay = hasLayout cf + xpr = if xml then "XPrint a, " else "" + in unlines + ["-- automatically generated by BNF Converter", + "module Main where\n", + "", + "import Trees", + "import Profile", + "import System.IO ( stdin, hGetContents )", + "import System.Environment ( getArgs, getProgName )", + "", + "import " ++ alexFileM inDir name, + "import " ++ happyFileM inDir name, +---- "import " ++ templateFileM inDir name, +---- "import " ++ printerFileM inDir name, +---- "import " ++ absFileM inDir name, +---- if lay then ("import " ++ layoutFileM inDir name) else "", +---- if xml then ("import " ++ xmlFileM inDir name) else "", + "import " ++ errFileM inDir name, + "", + "type ParseFun = [Token] -> Err CFTree", + "", + "myLLexer = " ++ if lay then "resolveLayout True . myLexer" + else "myLexer", + "", + "runFile :: ParseFun -> FilePath -> IO ()", + "runFile p f = readFile f >>= run p", + "", + "run :: ParseFun -> String -> IO ()", + "run p s = do", + " let ts = myLLexer s", + " let etree = p ts", + " case etree of", + " Ok tree -> do", + " case postParse tree of", + " Bad s -> do", + " putStrLn \"\\nParse Failed... CFTree:\\n\"", + " putStrLn $ prCFTree tree", + " putStrLn s", + " Ok tree -> do", + " putStrLn \"\\nParse Successful!\"", + " putStrLn $ \"\\n[Abstract Syntax]\\n\\n\" ++ prt tree", + " Bad s -> do", + " putStrLn s", + " putStrLn \"\\nParse failed... tokenization:\"", + " print ts", + "", + "main :: IO ()", + "main = do args <- getArgs", + " case args of", + " [] -> hGetContents stdin >>= run " ++ firstParser, + " [f] -> runFile " ++ firstParser ++ " f", + " _ -> do progName <- getProgName", + " putStrLn $ progName ++ \": excess arguments.\"" + ] + where firstParser = 'p' : firstEntry cf diff --git a/src/formats/xml/CFtoXML.hs b/src/formats/xml/CFtoXML.hs new file mode 100644 --- /dev/null +++ b/src/formats/xml/CFtoXML.hs @@ -0,0 +1,216 @@ +{- + BNF Converter: XML generator + Copyright (C) 2004 Author: Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoXML ---- (cf2DTD, cf2XML) + where + +import CF +import Utils +import CFtoTemplate +import Data.List (intersperse, nub) +import Data.Char(toLower) + +type Coding = Bool ---- change to at least three values + +makeXML :: FilePath -> Coding -> CF -> IO () +makeXML name typ cf = do + writeFileRep (name ++ ".dtd") $ cf2DTD typ name cf + let absmod = "XML" ++ name + writeFileRep (absmod ++ ".hs") $ cf2XMLPrinter typ name absmod cf + +-- derive a DTD from a BNF grammar. AR 21/8/2004 +cf2DTD :: Coding -> String -> CF -> String +cf2DTD typ name cf = unlines [ + tag ("?xml version=\"1.0\" standalone=\"yes\"?"), + "" + ] + +tag s = "<" ++ s ++ ">" +element t ts = + tag ("!ELEMENT " ++ t ++ " " ++ alts ts) +attlist t a = + tag ("!ATTLIST " ++ t ++ " " ++ a ++ " CDATA #REQUIRED") +elemAtt t a ts = element t ts ++++ attlist t a +elemt t = elemAtt t "name" +elemc cat fs = unlines $ element cat (map snd fs) : [element f [] | (f,_) <- fs] +elemEmp t = elemAtt t "value" [] +alts ts = + if null ts then "EMPTY" else parenth (unwords (intersperse "|" ts)) + + +-- choose between these two encodings: + +elemData b = if b then elemDataConstr else elemDataNotyp +efunDef b = if b then efunDefConstr else efunDefNotyp +endtagDef b = if b then endtagDefConstr else endtagDefNotyp + +-- coding 0: ---- not finished +-- to show both types and constructors as tags; +-- lengthy, but validation guarantees type correctness +-- flag -xmlt +elemDataConstrs cf (cat,fcs) = elemc cat ([(f,rhsCat cf (f:cs)) | (f,cs) <- fcs]) +efunDefConstrs = "elemFun i t x = [replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]" +endtagDefConstrs = "endtag f c = tag (\"/\" ++ c)" + +-- coding 1: +-- to show constructors as empty tags; +-- shorter than 0, but validation still guarantees type correctness +-- flag -xmlt +elemDataConstr cf (cat,fcs) = elemc cat ([(f,rhsCat cf (f:cs)) | (f,cs) <- fcs]) +efunDefConstr = "elemFun i t x = [replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]" +endtagDefConstr = "endtag f c = tag (\"/\" ++ c)" + +-- coding 2: +-- constructors as tags, no types. +-- clumsy DTD, but nice trees. Validation guarantees type correctness +-- flag -xml +elemDataNotyp cf (cat,fcs) = unlines [element f [rhsCatNot cf cs] | (f,cs) <- fcs] +efunDefNotyp = "elemFun i t x = [replicate (i+i) ' ' ++ tag x]" +endtagDefNotyp = "endtag f c = tag (\"/\" ++ f)" + + +-- to show constructors as attributes; +-- nice, but validation does not guarantee type correctness. +-- Therefore rejected. +-- elemDataAttr cf (cat,fcs) = elemt cat (nub [rhsCat cf cs | (_,cs) <- fcs]) +-- efunDefAttr = "elemFun i t x = [replicate (i+i) ' ' ++ tag (t ++ \" name = \" ++ x)]" + + +rhsCat cf cs = parenth (concat (intersperse ", " (map (symbCat cf) cs))) +rhsCatNot cf cs = if null cs then "EMPTY" else concat (intersperse ", " (map (symbCatNot cf) cs)) + +symbCat cf c + | isList c = normCatOfList c ++ if isEmptyListCat cf c then "*" else "+" + | otherwise = c + +symbCatNot cf c + | isList c = funs (normCatOfList c) ++ if isEmptyListCat cf c then "*" else "+" + | otherwise = funs c + where + funs k = case lookup k (cf2data cf) of + Just [] -> "EMPTY" + Just fcs -> parenth $ unwords $ intersperse "|" $ map fst fcs + _ -> parenth k ---- + +parenth s = "(" ++ s ++ ")" + +-- derive an XML printer from a BNF grammar +cf2XMLPrinter :: Bool -> String -> String -> CF -> String +cf2XMLPrinter typ name absMod cf = unlines [ + prologue typ name absMod, + integerRule cf, + doubleRule cf, + stringRule cf, + if hasIdent cf then identRule cf else "", + unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf], + rules cf + ] + + +prologue :: Bool -> String -> String -> String +prologue b name absMod = unlines [ + "module " ++ absMod +++ "where\n", + "-- pretty-printer generated by the BNF converter\n", + "import Abs" ++ name, + "import Data.Char", + "", + "-- the top-level printing method", + "printXML :: XPrint a => a -> String", + "printXML = render . prt 0", + "", + "render = unlines", + "", + "-- the printer class does the job", + "class XPrint a where", + " prt :: Int -> a -> [String]", + " prtList :: Int -> [a] -> [String]", + " prtList i = concat . map (prt i)", + "", + "instance XPrint a => XPrint [a] where", + " prt = prtList", + "", + "tag t = \"<\" ++ t ++ \">\"", + "etag t = \"<\" ++ t ++ \"/>\"", + "elemTok i t x = [replicate (i+i) ' ' ++ tag (t ++ \" value = \" ++ show x ++ \" /\")]", + "elemTokS i t x = elemTok i t (show x)", + efunDef b, + endtagDef b, + "" + ] + +integerRule cf = showsPrintRule cf "Integer" +doubleRule cf = showsPrintRule cf "Double" +stringRule cf = showsPrintRule cf "Char" ++++ " prtList i xs = elemTok i \"String\" xs" + +showsPrintRule cf t = unlines $ [ + "instance XPrint " ++ t ++ " where", + " prt i x = elemTokS i" +++ "\"" ++ t ++ "\"" +++ "x" + ] + +identRule cf = ownPrintRule cf "Ident" + +ownPrintRule cf t = unlines $ [ + "instance XPrint " ++ t ++ " where", + " prt i (" ++ t ++ posn ++ ") = elemTok i" +++ "\"" ++ t ++ "\"" +++ "x" + ] + where + posn = if isPositionCat cf t then " (_,x)" else " x" + +rules :: CF -> String +rules cf = unlines $ + map (\(s,xs) -> case_fun s (map toArgs xs)) $ cf2data cf + where + toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons) + names [] _ = [] + names (x:xs) n + | elem x xs = (x ++ show n) : names xs (n+1) + | otherwise = x : names xs n + var ('[':xs) = var (init xs) ++ "s" + var "Ident" = "id" + var "Integer" = "n" + var "String" = "str" + var "Char" = "c" + var "Double" = "d" + var xs = map toLower xs + checkRes s + | elem s reservedHaskell = s ++ "'" + | otherwise = s + reservedHaskell = ["case","class","data","default","deriving","do","else","if", + "import","in","infix","infixl","infixr","instance","let","module", + "newtype","of","then","type","where","as","qualified","hiding"] + ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf) + +--- case_fun :: Cat -> [(Constructor,Rule)] -> String +case_fun cat xs = unlines [ + "instance XPrint" +++ cat +++ "where", + " prt i" +++ "e = case e of", + unlines $ map (\ ((c,xx),r) -> + " " ++ c +++ unwords xx +++ "-> concat $ " +++ + "elemFun i \"" ++ cat ++ "\" \"" ++ c ++ "\"" +++ + unwords [": prt (i+1)" +++ x | x <- xx] +++ ":" +++ + "[[replicate (i+i) ' ' ++ endtag \"" ++ c ++ "\" \"" ++ cat ++ "\"]]" + ) xs + ] diff --git a/test/src/system-tests-c.hs b/test/src/system-tests-c.hs new file mode 100644 --- /dev/null +++ b/test/src/system-tests-c.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +module Main where + +import Filesystem.Path (basename) +import Filesystem.Path.CurrentOS (decodeString, encodeString) +import Text.Printf (printf) +import Shelly +import Prelude hiding (FilePath) +import Data.Text.Lazy (Text) +import Control.Exception (assert) +import Paths_BNFC +import SystemTesting (systemTestMain, Backend, assertExists) + +default (Text) + +cBackend :: Backend +cBackend bnfcBin cfFile testFile = + shelly $ print_commands True $ withTmpDir $ \temp -> do + cd temp + -- Preconditions: testing for the existence of the input files + assertExists cfFile + assertExists testFile + -- TODO test existance and executability of bnf + bnfc "-m" "-c" cfFile + make + -- Now we run the test programme, passing the content of + -- the test source file on stdin + -- Note that we don't print stdout because it can be very verbose + -- and we only rely on the status code returned by the test + -- program to decide if the test passes or fails + readfile testFile >>= setStdin + test + where make = cmd "make" + bnfc = cmd bnfcBin + testProg = decodeString ("Test" ++ (encodeString $ basename cfFile)) + test = cmd ("." testProg) + +-- Main is defined in SystemTesting, we just pass our backend as a parameter +main = systemTestMain cBackend diff --git a/test/src/system-tests-cpp-no-stl.hs b/test/src/system-tests-cpp-no-stl.hs new file mode 100644 --- /dev/null +++ b/test/src/system-tests-cpp-no-stl.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +module Main where + +import Filesystem.Path (basename) +import Filesystem.Path.CurrentOS (decodeString, encodeString) +import Text.Printf (printf) +import Shelly +import Prelude hiding (FilePath) +import Data.Text.Lazy (Text) +import Control.Exception (assert) +import Paths_BNFC +import SystemTesting (systemTestMain, Backend, assertExists) + +default (Text) + +cBackend :: Backend +cBackend bnfcBin cfFile testFile = + shelly $ print_commands True $ withTmpDir $ \temp -> do + cd temp + -- Preconditions: testing for the existence of the input files + assertExists cfFile + assertExists testFile + -- TODO test existance and executability of bnf + bnfc "-m" "-cpp_no_stl" cfFile + make + -- Now we run the test programme, passing the content of + -- the test source file on stdin + -- Note that we don't print stdout because it can be very verbose + -- and we only rely on the status code returned by the test + -- program to decide if the test passes or fails + readfile testFile >>= setStdin + test + where make = cmd "make" + bnfc = cmd bnfcBin + testProg = decodeString ("Test" ++ (encodeString $ basename cfFile)) + test = cmd ("." testProg) + +-- Main is defined in SystemTesting, we just pass our backend as a parameter +main = systemTestMain cBackend diff --git a/test/src/system-tests-cpp.hs b/test/src/system-tests-cpp.hs new file mode 100644 --- /dev/null +++ b/test/src/system-tests-cpp.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +module Main where + +import Filesystem.Path (basename) +import Filesystem.Path.CurrentOS (decodeString, encodeString) +import Text.Printf (printf) +import Shelly +import Prelude hiding (FilePath) +import Data.Text.Lazy (Text) +import Control.Exception (assert) +import Paths_BNFC +import SystemTesting (systemTestMain, Backend, assertExists) + +default (Text) + +cBackend :: Backend +cBackend bnfcBin cfFile testFile = + shelly $ print_commands True $ withTmpDir $ \temp -> do + cd temp + -- Preconditions: testing for the existence of the input files + assertExists cfFile + assertExists testFile + -- TODO test existance and executability of bnf + bnfc "-m" "-cpp" cfFile + make + -- Now we run the test programme, passing the content of + -- the test source file on stdin + -- Note that we don't print stdout because it can be very verbose + -- and we only rely on the status code returned by the test + -- program to decide if the test passes or fails + readfile testFile >>= setStdin + test + where make = cmd "make" + bnfc = cmd bnfcBin + testProg = decodeString ("Test" ++ (encodeString $ basename cfFile)) + test = cmd ("." testProg) + +-- Main is defined in SystemTesting, we just pass our backend as a parameter +main = systemTestMain cBackend diff --git a/test/src/system-tests-haskell.hs b/test/src/system-tests-haskell.hs new file mode 100644 --- /dev/null +++ b/test/src/system-tests-haskell.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +module Main where + +import Filesystem.Path (basename) +import Filesystem.Path.CurrentOS (decodeString, encodeString) +import Text.Printf (printf) +import Shelly +import Prelude hiding (FilePath) +import Data.Text.Lazy (Text) +import Control.Exception (assert) +import Paths_BNFC +import SystemTesting (systemTestMain, Backend, assertExists) + +default (Text) + +haskellBackend :: Backend +haskellBackend bnfcBin cfFile testFile = + shelly $ print_commands True $ withTmpDir $ \temp -> do + cd temp + -- Preconditions: testing for the existence of the input files + assertExists cfFile + assertExists testFile + -- TODO test existance and executability of bnf + bnfc "-m" "-haskell" cfFile + make + -- Now we run the test programme, passing the content of + -- the test source file on stdin + -- Note that we don't print stdout because it can be very verbose + -- and we only rely on the status code returned by the test + -- program to decide if the test passes or fails + readfile testFile >>= setStdin + test + where make = cmd "make" + bnfc = cmd bnfcBin + testProg = decodeString ("Test" ++ (encodeString $ basename cfFile)) + test = cmd ("." testProg) + +-- Main is defined in SystemTesting, we just pass our backend as a parameter +main = systemTestMain haskellBackend diff --git a/test/src/system-tests-java.hs b/test/src/system-tests-java.hs new file mode 100644 --- /dev/null +++ b/test/src/system-tests-java.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +module Main where + +import Filesystem.Path (basename) +import Filesystem.Path.CurrentOS (decodeString, encodeString) +import Text.Printf (printf) +import Shelly +import Prelude hiding (FilePath) +import Data.Text.Lazy (Text) +import Control.Exception (assert) +import Paths_BNFC +import SystemTesting (systemTestMain, Backend, assertExists) + +default (Text) + +javaBackend :: Backend +javaBackend bnfcBin cfFile testFile = + shelly $ print_commands True $ withTmpDir $ \temp -> do + cd temp + -- Preconditions: testing for the existence of the input files + assertExists cfFile + assertExists testFile + -- TODO test existance and executability of bnf + bnfc "-m" "-java" cfFile + make + -- Now we run the test programme, passing the content of + -- the test source file on stdin + -- Note that we don't print stdout because it can be very verbose + -- and we only rely on the status code returned by the test + -- program to decide if the test passes or fails + readfile testFile >>= setStdin + java testProg + where make = cmd "make" + bnfc = cmd bnfcBin + java = cmd "java" + testProg = basename cfFile "Test" + +-- Main is defined in SystemTesting, we just pass our backend as a parameter +main = systemTestMain javaBackend + diff --git a/test/src/unit-tests.hs b/test/src/unit-tests.hs new file mode 100644 --- /dev/null +++ b/test/src/unit-tests.hs @@ -0,0 +1,24 @@ +module Main where + +import Test.HUnit +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit + +import qualified Common.Makefile as Makefile + +main = defaultMain tests + +tests = + [ testGroup "Makefile" + [ testCase "Simple make rule" testRule1 + , testCase "Rule without recipe" testRule2 + , testCase "Documentation rules" testDocRule]] + +testRule1 = "main: file1 file2\n\tdo something\n\n" + @=? Makefile.mkRule "main" ["file1","file2"] ["do something"] "" + +testRule2 = "main: program.exe\n\n" + @=? Makefile.mkRule "main" ["program.exe"] [] "" + +testDocRule = "doc: test.pdf\n\ntest.pdf: test.tex\n\tpdflatex test.tex\n\n" + @=? Makefile.mkDoc "test.tex" ""