BNFC (empty) → 2.4.1.1
raw patch · 93 files changed
+21546/−0 lines, 93 filesdep +arraydep +basedep +directorysetup-changed
Dependencies added: array, base, directory, haskell98, mtl, process
Files
- AbsBNF.hs +112/−0
- BNF.cf +148/−0
- BNFC.cabal +140/−0
- CF.hs +566/−0
- COPYING +340/−0
- ErrM.hs +26/−0
- GetCF.hs +242/−0
- LexBNF.x +134/−0
- Main.hs +194/−0
- MultiView.hs +137/−0
- ParBNF.hs +1658/−0
- PrintBNF.hs +244/−0
- Setup.lhs +6/−0
- TypeChecker.hs +146/−0
- Utils.hs +125/−0
- dist/build/bnfc/bnfc-tmp/LexBNF.hs +341/−0
- formats/CFtoLatex.hs +276/−0
- formats/NamedVariables.hs +109/−0
- formats/OOAbstract.hs +129/−0
- formats/c-sharp/CAbstoCSharpAbs.hs +277/−0
- formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs +97/−0
- formats/c-sharp/CAbstoCSharpVisitSkeleton.hs +118/−0
- formats/c-sharp/CFtoCSharpPrinter.hs +472/−0
- formats/c-sharp/CFtoGPLEX.hs +221/−0
- formats/c-sharp/CFtoGPPG.hs +275/−0
- formats/c-sharp/CSharpTop.hs +367/−0
- formats/c-sharp/CSharpUtils.hs +154/−0
- formats/c-sharp/RegToGPLEX.hs +73/−0
- formats/c/CFtoBisonC.hs +275/−0
- formats/c/CFtoCAbs.hs +329/−0
- formats/c/CFtoCPrinter.hs +648/−0
- formats/c/CFtoCSkel.hs +240/−0
- formats/c/CFtoFlexC.hs +189/−0
- formats/c/CTop.hs +217/−0
- formats/cpp/CFtoBison.hs +352/−0
- formats/cpp/CFtoCPPAbs.hs +443/−0
- formats/cpp/CFtoCPPPrinter.hs +625/−0
- formats/cpp/CFtoCVisitSkel.hs +259/−0
- formats/cpp/CFtoFlex.hs +191/−0
- formats/cpp/CPPTop.hs +208/−0
- formats/cpp/RegToFlex.hs +73/−0
- formats/cpp_stl/CFtoBisonSTL.hs +373/−0
- formats/cpp_stl/CFtoCVisitSkelSTL.hs +148/−0
- formats/cpp_stl/CFtoSTLAbs.hs +275/−0
- formats/cpp_stl/CFtoSTLPrinter.hs +676/−0
- formats/cpp_stl/STLTop.hs +223/−0
- formats/f-sharp/FSharpTop.hs +208/−0
- formats/haskell-gadt/CFtoAbstractGADT.hs +147/−0
- formats/haskell-gadt/CFtoPrinterGADT.hs +167/−0
- formats/haskell-gadt/CFtoTemplateGADT.hs +65/−0
- formats/haskell-gadt/HaskellGADTCommon.hs +83/−0
- formats/haskell-gadt/HaskellTopGADT.hs +387/−0
- formats/haskell2/CFtoAbstract.hs +51/−0
- formats/haskell2/CFtoAlex.hs +230/−0
- formats/haskell2/CFtoAlex2.hs +338/−0
- formats/haskell2/CFtoHappy.hs +280/−0
- formats/haskell2/CFtoLayout.hs +270/−0
- formats/haskell2/CFtoPrinter.hs +189/−0
- formats/haskell2/CFtoTemplate.hs +106/−0
- formats/haskell2/HaskellTop.hs +356/−0
- formats/haskell2/MkErrM.hs +51/−0
- formats/haskell2/MkSharedString.hs +67/−0
- formats/haskell2/RegToAlex.hs +88/−0
- formats/java/CFtoCup.hs +282/−0
- formats/java/CFtoJLex.hs +174/−0
- formats/java/CFtoJavaAbs.hs +238/−0
- formats/java/CFtoJavaPrinter.hs +384/−0
- formats/java/CFtoJavaSkeleton.hs +124/−0
- formats/java/CFtoVisitSkel.hs +173/−0
- formats/java/JavaTop.hs +313/−0
- formats/java/RegToJLex.hs +86/−0
- formats/java1.5/CFtoAbstractVisitor.hs +60/−0
- formats/java1.5/CFtoAllVisitor.hs +51/−0
- formats/java1.5/CFtoComposVisitor.hs +117/−0
- formats/java1.5/CFtoCup15.hs +274/−0
- formats/java1.5/CFtoFoldVisitor.hs +104/−0
- formats/java1.5/CFtoJLex15.hs +175/−0
- formats/java1.5/CFtoJavaAbs15.hs +263/−0
- formats/java1.5/CFtoJavaPrinter15.hs +379/−0
- formats/java1.5/CFtoVisitSkel15.hs +141/−0
- formats/java1.5/JavaTop15.hs +285/−0
- formats/ocaml/CFtoOCamlAbs.hs +63/−0
- formats/ocaml/CFtoOCamlLex.hs +230/−0
- formats/ocaml/CFtoOCamlPrinter.hs +200/−0
- formats/ocaml/CFtoOCamlShow.hs +153/−0
- formats/ocaml/CFtoOCamlTemplate.hs +73/−0
- formats/ocaml/CFtoOCamlTest.hs +66/−0
- formats/ocaml/CFtoOCamlYacc.hs +232/−0
- formats/ocaml/OCamlTop.hs +207/−0
- formats/ocaml/OCamlUtil.hs +71/−0
- formats/profile/CFtoHappyProfile.hs +223/−0
- formats/profile/ProfileTop.hs +234/−0
- formats/xml/CFtoXML.hs +217/−0
+ AbsBNF.hs view
@@ -0,0 +1,112 @@+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)+
+ BNF.cf view
@@ -0,0 +1,148 @@+{-+ 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 "{-" "-}" ;++
+ BNFC.cabal view
@@ -0,0 +1,140 @@+Name: BNFC+Version: 2.4.1.1+cabal-version: >= 1.2+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).+License: GPL+License-File: COPYING+Maintainer: Markus Forsberg <markus.forsberg@gu.se> Aarne Ranta <aarne@chalmers.se>+Homepage: http://www.cse.chalmers.se/research/group/Language-technology/BNFC/+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, + 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:+ an abstract syntax as a Haskell/C++/C module or Java directory,+ a case skeleton for the abstract syntax in the same language,+ an Alex, JLex, or Flex lexer generator file,+ 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.+Extra-source-files: BNF.cf ++Executable bnfc+ Build-Depends: haskell98, base>=4 && <5, mtl, directory, array, process+ 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+ Other-modules:+ LexBNF,+ ParBNF,+ AbsBNF,+ PrintBNF,+ Utils,+ CF,+ ErrM,+ MultiView,+ TypeChecker,+ GetCF,+ NamedVariables,+ OOAbstract,+ CFtoLatex,+ CFtoXML,+ -- Haskell+ HaskellTop,+ RegToAlex,+ CFtoTemplate,+ CFtoAlex2,+ CFtoAlex,+ CFtoHappy,+ CFtoPrinter,+ CFtoAbstract,+ CFtoLayout,+ MkErrM,+ MkSharedString,+ -- Profile+ ProfileTop,+ CFtoHappyProfile,+ -- Haskell GADT+ HaskellTopGADT,+ HaskellGADTCommon,+ CFtoPrinterGADT,+ CFtoTemplateGADT,+ CFtoAbstractGADT,+ -- O'Caml+ OCamlTop,+ OCamlUtil,+ CFtoOCamlTest,+ CFtoOCamlShow,+ CFtoOCamlPrinter,+ CFtoOCamlTemplate,+ CFtoOCamlAbs,+ CFtoOCamlYacc,+ CFtoOCamlLex,+ -- C+ CTop,+ CFtoCPrinter,+ CFtoCSkel,+ CFtoBisonC,+ CFtoFlexC,+ CFtoCAbs,+ CFtoCVisitSkel,+ -- C+++ CPPTop,+ RegToFlex,+ CFtoFlex,+ CFtoBison,+ CFtoCPPPrinter,+ CFtoCPPAbs,+ -- C++ STL+ STLTop,+ CFtoSTLPrinter,+ CFtoCVisitSkelSTL,+ CFtoBisonSTL,+ CFtoSTLAbs,+ -- C#+ CSharpTop,+ RegToGPLEX,+ CFtoGPLEX,+ CSharpUtils,+ CFtoCSharpPrinter,+ CAbstoCSharpAbs,+ CAbstoCSharpAbstractVisitSkeleton,+ CAbstoCSharpVisitSkeleton,+ CFtoGPPG,+ -- Java+ JavaTop,+ RegToJLex,+ CFtoCup,+ CFtoVisitSkel,+ CFtoJavaSkeleton,+ CFtoJavaPrinter,+ CFtoJavaAbs,+ CFtoJLex,+ -- Java 1.5+ JavaTop15,+ CFtoJavaAbs15,+ CFtoAllVisitor,+ CFtoFoldVisitor,+ CFtoAbstractVisitor,+ CFtoComposVisitor,+ CFtoVisitSkel15,+ CFtoJavaPrinter15,+ CFtoJLex15,+ CFtoCup15,+ -- F-sharp+ FSharpTop
+ CF.hs view
@@ -0,0 +1,566 @@+{-# 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 List (nub, intersperse, partition, sort,sort,group)+import 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
+ COPYING view
@@ -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.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ 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.++ <signature of Ty Coon>, 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.
+ ErrM.hs view
@@ -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
+ GetCF.hs view
@@ -0,0 +1,242 @@+{-+ 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 Directory ( doesFileExist, renameFile )+import Monad ( when )++import CF+import Utils+import ParBNF+import List(nub,partition)+import qualified AbsBNF as Abs+-- import LexBNF+import ErrM+import 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 "[]" []+
+ LexBNF.x view
@@ -0,0 +1,134 @@+-- -*- 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+}
+ Main.hs view
@@ -0,0 +1,194 @@+{-+ 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+import Char+import Data.List (elemIndex)++title = unlines [+ "The BNF Converter, 2.4.1.1", + "(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+ [] -> 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 <makeoption>* <language>? <special>* file.cf"+ 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 <name> Prepend <name> 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 <namespace> Use <namespace> as the C++ namespace"+ putStrLn ""+ putStrLn "Special options for the Java 1.5 back-end:"+ putStrLn " -p <package> Prepend <package> to the Java package name"+ putStrLn ""+ putStrLn "Special options for the C# backend:"+ putStrLn " -p <namespace> Use <namespace> 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
+ MultiView.hs view
@@ -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 Directory ( doesFileExist, renameFile )++import qualified CF as CF+import Utils+import ParBNF+import PrintBNF+import List(nub,partition)+import AbsBNF+-- import LexBNF+import ErrM+import 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 (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 (/='_')
+ ParBNF.hs view
@@ -0,0 +1,1658 @@+{-# OPTIONS -fglasgow-exts -cpp #-}+{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}+module ParBNF where+import AbsBNF+import LexBNF+import ErrM+import 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 "<built-in>" #-}+{-# LINE 1 "<command line>" #-}+{-# 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.
+ PrintBNF.hs view
@@ -0,0 +1,244 @@+{-# OPTIONS -fno-warn-incomplete-patterns #-}+module PrintBNF where++-- pretty-printer generated by the BNF converter++import AbsBNF+import Char++-- the top-level printing method+printTree :: Print a => a -> String+printTree = render . prt 0++type Doc = [ShowS] -> [ShowS]++doc :: ShowS -> Doc+doc = (:)++render :: Doc -> String+render d = rend 0 (map ($ "") $ d []) "" where+ rend i ss = case ss of+ "[" :ts -> showChar '[' . rend i ts+ "(" :ts -> showChar '(' . rend i ts+ "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts+ "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts+ "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts+ ";" :ts -> showChar ';' . new i . rend i ts+ t : "," :ts -> showString t . space "," . rend i ts+ t : ")" :ts -> showString t . showChar ')' . rend i ts+ t : "]" :ts -> showString t . showChar ']' . rend i ts+ t :ts -> space t . rend i ts+ _ -> id+ new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace+ space t = showString t . (\s -> if null s then "" else (' ':s))++parenth :: Doc -> Doc+parenth ss = doc (showChar '(') . ss . doc (showChar ')')++concatS :: [ShowS] -> ShowS+concatS = foldr (.) id++concatD :: [Doc] -> Doc+concatD = foldr (.) id++replicateS :: Int -> ShowS -> ShowS+replicateS n f = concatS (replicate n f)++-- the printer class does the job+class Print a where+ prt :: Int -> a -> Doc+ prtList :: [a] -> Doc+ prtList = concatD . map (prt 0)++instance Print a => Print [a] where+ prt _ = prtList++instance Print Char where+ prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')+ prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')++mkEsc :: Char -> Char -> ShowS+mkEsc q s = case s of+ _ | s == q -> showChar '\\' . showChar s+ '\\'-> showString "\\\\"+ '\n' -> showString "\\n"+ '\t' -> showString "\\t"+ _ -> showChar s++prPrec :: Int -> Int -> Doc -> Doc+prPrec i j = if j<i then parenth else id+++instance Print Integer where+ prt _ x = doc (shows x)+ prtList es = case es of+ [] -> (concatD [])+ [x] -> (concatD [prt 0 x])+ x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])+++instance Print Double where+ prt _ x = doc (shows x)+++instance Print Ident where+ prt _ (Ident i) = doc (showString i)+ 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")])+++
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/env runghc++> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain
+ TypeChecker.hs view
@@ -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@(_,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 ++ "."+
+ Utils.hs view
@@ -0,0 +1,125 @@+{-+ 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
+ dist/build/bnfc/bnfc-tmp/LexBNF.hs view
@@ -0,0 +1,341 @@+{-# OPTIONS -fglasgow-exts -cpp #-}+{-# LINE 3 "LexBNF.x" #-}++{-# OPTIONS -fno-warn-incomplete-patterns #-}+module LexBNF where++++#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+import Data.Char (ord)+import Data.Array.Base (unsafeAt)+#else+import Array+import Char (ord)+#endif+#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts+#else+import GlaExts+#endif+alex_base :: AlexAddr+alex_base = AlexA# "\x01\x00\x00\x00\x15\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x18\x00\x00\x00\x19\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x45\x00\x00\x00\x1b\x00\x00\x00\x1c\x00\x00\x00\x1d\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\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_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_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_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_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" #-}+++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++alex_action_3 = tok (\p s -> PT p (TS $ 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)) +alex_action_7 = tok (\p s -> PT p (TI $ share s)) +alex_action_8 = tok (\p s -> PT p (TD $ share s)) +{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine++{-# LINE 35 "templates/GenericTemplate.hs" #-}++{-# LINE 45 "templates/GenericTemplate.hs" #-}+++data AlexAddr = AlexA# Addr#++#if __GLASGOW_HASKELL__ < 503+uncheckedShiftL# = shiftL#+#endif++{-# INLINE alexIndexInt16OffAddr #-}+alexIndexInt16OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+ narrow16Int# i+ where+ i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+ high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ low = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 2#+#else+ indexInt16OffAddr# arr off+#endif++++++{-# INLINE alexIndexInt32OffAddr #-}+alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN+ narrow32Int# i+ where+ i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`+ (b2 `uncheckedShiftL#` 16#) `or#`+ (b1 `uncheckedShiftL#` 8#) `or#` b0)+ b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))+ b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))+ b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ b0 = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 4#+#else+ indexInt32OffAddr# arr off+#endif++++++#if __GLASGOW_HASKELL__ < 503+quickIndex arr i = arr ! i+#else+-- GHC >= 503, unsafeAt is available from Data.Array.Base.+quickIndex = unsafeAt+#endif+++++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+ = AlexEOF+ | AlexError !AlexInput+ | AlexSkip !AlexInput !Int+ | AlexToken !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input (I# (sc))+ = alexScanUser undefined input (I# (sc))++alexScanUser user input (I# (sc))+ = case alex_scan_tkn user input 0# input sc AlexNone of+ (AlexNone, input') ->+ case alexGetChar input of+ Nothing -> ++++ AlexEOF+ Just _ ->++++ AlexError input'++ (AlexLastSkip input len, _) ->++++ AlexSkip input len++ (AlexLastAcc k input len, _) ->++++ AlexToken input len k+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user orig_input len input s last_acc =+ input `seq` -- strict in the input+ let + new_acc = check_accs (alex_accept `quickIndex` (I# (s)))+ in+ new_acc `seq`+ case alexGetChar input of+ Nothing -> (new_acc, input)+ Just (c, new_input) -> ++++ let+ base = alexIndexInt32OffAddr alex_base s+ (I# (ord_c)) = ord c+ offset = (base +# ord_c)+ check = alexIndexInt16OffAddr alex_check offset+ + new_s = if (offset >=# 0#) && (check ==# ord_c)+ then alexIndexInt16OffAddr alex_table offset+ else alexIndexInt16OffAddr alex_deflt s+ in+ case new_s of + -1# -> (new_acc, input)+ -- on an error, we want to keep the input *before* the+ -- character that failed, not after.+ _ -> alex_scan_tkn user orig_input (len +# 1#) + new_input new_s new_acc++ where+ check_accs [] = last_acc+ check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))+ check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))+ check_accs (AlexAccPred a pred : rest)+ | pred user orig_input (I# (len)) input+ = AlexLastAcc a input (I# (len))+ check_accs (AlexAccSkipPred pred : rest)+ | pred user orig_input (I# (len)) input+ = AlexLastSkip input (I# (len))+ check_accs (_ : rest) = check_accs rest++data AlexLastAcc a+ = AlexNone+ | AlexLastAcc a !AlexInput !Int+ | AlexLastSkip !AlexInput !Int++data AlexAcc a user+ = AlexAcc a+ | AlexAccSkip+ | AlexAccPred a (AlexAccPred user)+ | AlexAccSkipPred (AlexAccPred user)++type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool++-- -----------------------------------------------------------------------------+-- Predicates on a rule++alexAndPred p1 p2 user in1 len in2+ = p1 user in1 len in2 && p2 user in1 len in2++--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input++--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input++--alexRightContext :: Int -> AlexAccPred _+alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of+ (AlexNone, _) -> False+ _ -> True+ -- TODO: there's no need to find the longest+ -- match when checking the right context, just+ -- the first match will do.++-- used by wrappers+iUnbox (I# (i)) = i
+ formats/CFtoLatex.hs view
@@ -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 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
+ formats/NamedVariables.hs view
@@ -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 Char (toLower)+import 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)
+ formats/OOAbstract.hs view
@@ -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 List+import 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
+ formats/c-sharp/CAbstoCSharpAbs.hs view
@@ -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 List+import 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<R,A>(" ++ identifier namespace cat ++ ".Visitor<R,A> v, A arg);",+ prVisitor namespace funs,+ " }"+ ]++prVisitor :: Namespace -> [Cat] -> String+prVisitor namespace funs = unlinesInline [+ " ",+ " public interface Visitor<R,A>",+ " {",+ 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<R,A>(" ++ identifier namespace cat ++ ".Visitor<R,A> 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]
+ formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs view
@@ -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 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<R,A> : " ++ identifier namespace c ++ ".Visitor<R,A>",+ " {",+ " 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<R,A> : " ++ identifier namespace c ++ ".Visitor<R,A>",+ " {",+ 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);"+ ]
+ formats/c-sharp/CAbstoCSharpVisitSkeleton.hs view
@@ -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 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<R,A> : Abstract" ++ c ++ "Visitor<R,A>",+ " {",+ " 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<R,A> : Abstract" ++ c ++ "Visitor<R,A>",+ " {",+ 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<R,A>(), 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<R,A>(), arg);"+ else " // x",+ " }"+ ]
+ formats/c-sharp/CFtoCSharpPrinter.hs view
@@ -0,0 +1,472 @@+{-+ 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 List+import 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 ++ "_"
+ formats/c-sharp/CFtoGPLEX.hs view
@@ -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 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,+ "",+ "%{",+ " /// <summary>",+ " /// Buffer for escaped characters in strings.",+ " /// </summary>",+ " private System.Text.StringBuilder strBuffer = new System.Text.StringBuilder();",+ "",+ " /// <summary>",+ " /// Change to enable output - useful for debugging purposes",+ " /// </summary>",+ " public bool Trace = false;",+ "",+ " /// <summary>",+ " /// Culture-independent IFormatProvider for numbers. ",+ " /// This is just a \"wrapper\" for System.Globalization.NumberFormatInfo.InvariantInfo.",+ " /// </summary>",+ " /// <remarks>",+ " /// 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.",+ " /// </remarks>",+ " private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;",+ "",+ " /// <summary>",+ " /// 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.",+ " /// </summary>",+ " public static Scanner CreateScanner(Stream stream)",+ " {",+ " Scanner scanner = new Scanner(stream);",+ " scanner.Begin();",+ " return scanner;",+ " }",+ "",+ " /// <summary>",+ " /// Sets the scanner to the correct initial state (YYINITIAL). ",+ " /// You should call this method prior to calling parser.Parse().",+ " /// </summary>",+ " public void Begin()",+ " {",+ " BEGIN(YYINITIAL);",+ " }",+ "",+ " /// <summary>",+ " /// Convenience method to \"reset\" the buffer for escaped characters in strings.",+ " /// </summary>",+ " 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) = + ("<YYINITIAL>\"" ++ 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" [("<YYINITIAL>{digit}+\".\"{digit}+(\"e\"(\\-)?{digit}+)?" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.double_ = Double.Parse(yytext, InvariantFormatInfo); return (int)Tokens.DOUBLE_;")],+ ifC "Integer" [("<YYINITIAL>{digit}+" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.int_ = Int32.Parse(yytext, InvariantFormatInfo); return (int)Tokens.INTEGER_;")],+ ifC "Ident" [("<YYINITIAL>{alpha}{ident}*" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.string_ = yytext; return (int)Tokens.IDENT_;")],+ [("<YYINITIAL>[ \\t\\r\\n\\f]" , "/* ignore white space. */;")],+ [("<YYINITIAL>." , "return (int)Tokens.error;")]+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else []+ userDefTokens = map tokenline (tokenPragmas cf)+ where+ tokenline (name, exp) = ("<YYINITIAL>" ++ 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 = [+ ("<YYINITIAL>\"\\\"\"" , "BEGIN(STRING);"),+ ("<STRING>\\\\" , "BEGIN(ESCAPED);"),+ ("<STRING>\\\"" , "yylval.string_ = this.strBuffer.ToString(); BufferReset(); BEGIN(YYINITIAL); return (int)Tokens.STRING_;"),+ ("<STRING>." , "this.strBuffer.Append(yytext);"),+ ("<ESCAPED>n" , "this.strBuffer.Append(\"\\n\"); BEGIN(STRING);"),+ ("<ESCAPED>\\\"" , "this.strBuffer.Append(\"\\\"\"); BEGIN(STRING);"),+ ("<ESCAPED>\\\\" , "this.strBuffer.Append(\"\\\\\"); BEGIN(STRING);"),+ ("<ESCAPED>t" , "this.strBuffer.Append(\"\\t\"); BEGIN(STRING);"),+ ("<ESCAPED>." , "this.strBuffer.Append(yytext); BEGIN(STRING);")+ ]+ -- These handle escaped characters in Chars.+ charStates = [+ ("<YYINITIAL>\"'\"" , "BEGIN(CHAR);"),+ ("<CHAR>\\\\" , "BEGIN(CHARESC);"),+ ("<CHAR>[^']" , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"),+ ("<CHARESC>n" , "BEGIN(CHAREND); yylval.char_ = '\\n'; return (int)Tokens.CHAR_;"),+ ("<CHARESC>t" , "BEGIN(CHAREND); yylval.char_ = '\\t'; return (int)Tokens.CHAR_;"),+ ("<CHARESC>." , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"),+ ("<CHAREND>\"'\"" , "BEGIN(YYINITIAL);")+ ]++lexComments :: ([(String, String)], [String]) -> [(String, String)]+lexComments (m,s) = (map lexSingleComment s) ++ (concatMap lexMultiComment m)++lexSingleComment :: String -> (String, String)+lexSingleComment c = + ("<YYINITIAL>\"" ++ 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) = [+ ("<YYINITIAL>\"" ++ b ++ "\"" , "BEGIN(COMMENT);"),+ ("<COMMENT>\"" ++ e ++ "\"" , "BEGIN(YYINITIAL);"),+ ("<COMMENT>." , "/* BNFC multi-line comment */;"),+ ("<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
+ formats/c-sharp/CFtoGPPG.hs view
@@ -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 List (intersperse, isPrefixOf)+import NamedVariables hiding (varName)+import 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_> STRING_",+ ifC "Char" "%token<char_> CHAR_",+ ifC "Integer" "%token<int_> INTEGER_",+ ifC "Double" "%token<double_> DOUBLE_",+ ifC "Ident" "%token<string_> 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
+ formats/c-sharp/CSharpTop.hs view
@@ -0,0 +1,367 @@+{-+ 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+import GetCF+import Char+import System+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 [+ "<?xml version=\"1.0\" encoding=\"utf-8\"?>",+ "<Project DefaultTargets=\"Build\" xmlns=\"http://schemas.microsoft.com/developer/msbuild/2003\">",+ " <PropertyGroup>",+ " <Configuration Condition=\" '$(Configuration)' == '' \">Debug</Configuration>",+ " <Platform Condition=\" '$(Platform)' == '' \">AnyCPU</Platform>",+ " <ProductVersion>8.0.50727</ProductVersion>",+ " <SchemaVersion>2.0</SchemaVersion>",+ " <ProjectGuid>" ++ guid ++ "</ProjectGuid>",+ " <OutputType>Library</OutputType>",+ " <AppDesignerFolder>Properties</AppDesignerFolder>",+ " <RootNamespace>" ++ namespace ++ "</RootNamespace>",+ " <AssemblyName>" ++ namespace ++ "</AssemblyName>",+ " <StartupObject>",+ " </StartupObject>",+ " </PropertyGroup>",+ " <PropertyGroup Condition=\" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' \">",+ " <DebugSymbols>true</DebugSymbols>",+ " <DebugType>full</DebugType>",+ " <Optimize>false</Optimize>",+ " <OutputPath>bin\\Debug\\</OutputPath>",+ " <DefineConstants>DEBUG;TRACE</DefineConstants>",+ " <ErrorReport>prompt</ErrorReport>",+ " <WarningLevel>4</WarningLevel>",+ " </PropertyGroup>",+ " <PropertyGroup Condition=\" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' \">",+ " <DebugType>pdbonly</DebugType>",+ " <Optimize>true</Optimize>",+ " <OutputPath>bin\\Release\\</OutputPath>",+ " <DefineConstants>TRACE</DefineConstants>",+ " <ErrorReport>prompt</ErrorReport>",+ " <WarningLevel>4</WarningLevel>",+ " </PropertyGroup>",+ " <Import Project=\"$(MSBuildBinPath)\\Microsoft.CSharp.targets\" />",+ " <!-- To modify your build process, add your task inside one of the targets below and uncomment it. ",+ " Other similar extension points exist, see Microsoft.Common.targets.",+ " <Target Name=\"BeforeBuild\">",+ " </Target>",+ " <Target Name=\"AfterBuild\">",+ " </Target>",+ " -->",+ " <ItemGroup>",+ " <Compile Include=\"AbstractVisitSkeleton.cs\" />",+ " <Compile Include=\"Absyn.cs\" />",+ " <Compile Include=\"Parser.cs\" />",+ " <Compile Include=\"Printer.cs\" />",+ " <Compile Include=\"Scanner.cs\" />",+ " <Compile Include=\"Test.cs\" />",+ " <Compile Include=\"VisitSkeleton.cs\" />",+ " </ItemGroup>",+ " <ItemGroup>",+ " <Reference Include=\"ShiftReduceParser, Version=0.0.0.0, Culture=neutral, processorArchitecture=MSIL\">",+ " <SpecificVersion>False</SpecificVersion>",+ " <HintPath>bin\\ShiftReduceParser.dll</HintPath>",+ " </Reference>",+ " </ItemGroup>",+ " <ItemGroup>",+ " <None Include=\"" ++ namespace ++ ".cf\" />",+ " <None Include=\"" ++ namespace ++ ".l\" />",+ " <None Include=\"" ++ namespace ++ ".y\" />",+ " <None Include=\"" ++ namespace ++ ".tex\" />",+ " <None Include=\"run-gp.bat\" />",+ " </ItemGroup>",+ " <PropertyGroup>",+ " <PreBuildEvent>",+ " </PreBuildEvent>",+ " </PropertyGroup>",+ "</Project>"+ ]++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"
+ formats/c-sharp/CSharpUtils.hs view
@@ -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 Char (toLower)+import Data.Maybe+import 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))+
+ formats/c-sharp/RegToGPLEX.hs view
@@ -0,0 +1,73 @@+module RegToGPLEX (printRegGPLEX) where++-- modified from RegToFlex++import AbsBNF+import 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<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> 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]
+ formats/c/CFtoBisonC.hs view
@@ -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 List (intersperse, isPrefixOf)+import NamedVariables hiding (varName)+import 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 <stdlib.h>",+ "#include <stdio.h>",+ "#include <string.h>",+ "#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<string_> " ++ r ++ " /* " ++ s ++ " */\n"+ else "%token " ++ r ++ " /* " ++ s ++ " */\n"++specialToks :: CF -> String+specialToks cf = concat [ + ifC "String" "%token<string_> _STRING_\n",+ ifC "Char" "%token<char_> _CHAR_\n",+ ifC "Integer" "%token<int_> _INTEGER_\n",+ ifC "Double" "%token<double_> _DOUBLE_\n",+ ifC "Ident" "%token<string_> _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
+ formats/c/CFtoCAbs.hs view
@@ -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 List+import 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 <stdio.h>",+ "#include <stdlib.h>",+ "#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) ++ "_"
+ formats/c/CFtoCPrinter.hs view
@@ -0,0 +1,648 @@+{-+ 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 List+import 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 <stdio.h>",+ "#include <string.h>",+ "#include <stdlib.h>",+ "",+ "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_--;",+ " }",+ "}"+ ]
+ formats/c/CFtoCSkel.hs view
@@ -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 List ( isPrefixOf )+import 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
+ formats/c/CFtoFlexC.hs view
@@ -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 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 <string.h>",+ "#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) = + "<YYINITIAL>\"" ++ 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" "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t yylval.double_ = atof(yytext); return _DOUBLE_;\n",+ ifC "Integer" "<YYINITIAL>{DIGIT}+ \t yylval.int_ = atoi(yytext); return _INTEGER_;\n",+ ifC "Ident" "<YYINITIAL>{LETTER}{IDENT}* \t yylval.string_ = strdup(yytext); return _IDENT_;\n"+ , "<YYINITIAL>[ \\t\\r\\n\\f] \t /* ignore white space. */;\n",+ "<YYINITIAL>. \t return _ERROR_;\n",+ "%%\n",+ footer+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""+ userDefTokens = unlines $+ ["<YYINITIAL>" ++ 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.+ [+ "<YYINITIAL>\"\\\"\" \t BEGIN STRING;",+ "<STRING>\\\\ \t BEGIN ESCAPED;",+ "<STRING>\\\" \t yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return _STRING_;",+ "<STRING>. \t YY_BUFFER_APPEND(yytext);",+ "<ESCAPED>n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;",+ "<ESCAPED>\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;",+ "<ESCAPED>\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;",+ "<ESCAPED>t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;",+ "<ESCAPED>. \t YY_BUFFER_APPEND(yytext); BEGIN STRING;"+ ]+ chStates = unlines --These handle escaped characters in Chars.+ [+ "<YYINITIAL>\"'\" \tBEGIN CHAR;",+ "<CHAR>\\\\ \t BEGIN CHARESC;",+ "<CHAR>[^'] \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;",+ "<CHARESC>n \t BEGIN CHAREND; yylval.char_ = '\\n'; return _CHAR_;",+ "<CHARESC>t \t BEGIN CHAREND; yylval.char_ = '\\t'; return _CHAR_;",+ "<CHARESC>. \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;",+ "<CHAREND>\"'\" \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 = + "<YYINITIAL>\"" ++ 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 [+ "<YYINITIAL>\"" ++ b ++ "\" \t BEGIN COMMENT;",+ "<COMMENT>\"" ++ e ++ "\" \t BEGIN YYINITIAL;",+ "<COMMENT>. \t /* BNFC multi-line comment */;",+ "<COMMENT>[\\n] \t /* BNFC multi-line comment */;"+ ]+ +lexReserved :: String -> String+lexReserved s = "<YYINITIAL>\"" ++ 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)
+ formats/c/CTop.hs view
@@ -0,0 +1,217 @@+{-+ 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+import GetCF+import Char+import System++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 <stdio.h>",+ "#include <stdlib.h>",+ "",+ "#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 _ = ""+
+ formats/cpp/CFtoBison.hs view
@@ -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 List (intersperse, isPrefixOf)+import NamedVariables hiding (varName)+import 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 <stdlib.h>",+ "#include <stdio.h>",+ "#include <string.h>",+ "#include <iostream>",+ "#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<string_> " ++ r ++ " // " ++ s ++ "\n"+ else "%token " ++ r ++ " // " ++ s ++ "\n"++specialToks :: CF -> String+specialToks cf = concat [ + ifC "String" "%token<string_> _STRING_\n",+ ifC "Char" "%token<char_> _CHAR_\n",+ ifC "Integer" "%token<int_> _INTEGER_\n",+ ifC "Double" "%token<double_> _DOUBLE_\n",+ ifC "Ident" "%token<string_> _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
+ formats/cpp/CFtoCPPAbs.hs view
@@ -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 List+import 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 <algorithm>",+ "#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
+ formats/cpp/CFtoCPPPrinter.hs view
@@ -0,0 +1,625 @@+{- + **************************************************************+ 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 List+import 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 <stdio.h>",+ "#include <string.h>",+ "#include <stdlib.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 ')'",+ "",+ "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_--;",+ " }",+ "}"+ ]
+ formats/cpp/CFtoCVisitSkel.hs view
@@ -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 List+import 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
+ formats/cpp/CFtoFlex.hs view
@@ -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 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 <string.h>",+ "#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) = + "<YYINITIAL>\"" ++ 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" ("<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t " ++ ns ++ "yylval.double_ = atof(yytext); return " ++ nsDefine inPackage "_DOUBLE_" ++ ";\n"),+ ifC "Integer" ("<YYINITIAL>{DIGIT}+ \t " ++ ns ++ "yylval.int_ = atoi(yytext); return " ++ nsDefine inPackage "_INTEGER_" ++ ";\n"),+ ifC "Ident" ("<YYINITIAL>{LETTER}{IDENT}* \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ nsDefine inPackage "_IDENT_" ++ ";\n"),+ "\\n ++" ++ ns ++ "yy_mylinenumber ;\n",+ "<YYINITIAL>[ \\t\\r\\n\\f] \t /* ignore white space. */;\n",+ "<YYINITIAL>. \t return " ++ nsDefine inPackage "_ERROR_" ++ ";\n",+ "%%\n",+ footer+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""+ ns = nsString inPackage+ userDefTokens = unlines $+ ["<YYINITIAL>" ++ 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.+ [+ "<YYINITIAL>\"\\\"\" \t BEGIN STRING;",+ "<STRING>\\\\ \t BEGIN ESCAPED;",+ "<STRING>\\\" \t " ++ ns ++ "yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return " ++ nsDefine inPackage "_STRING_" ++ ";",+ "<STRING>. \t YY_BUFFER_APPEND(yytext);",+ "<ESCAPED>n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;",+ "<ESCAPED>\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;",+ "<ESCAPED>\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;",+ "<ESCAPED>t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;",+ "<ESCAPED>. \t YY_BUFFER_APPEND(yytext); BEGIN STRING;"+ ]+ chStates = unlines --These handle escaped characters in Chars.+ [+ "<YYINITIAL>\"'\" \tBEGIN CHAR;",+ "<CHAR>\\\\ \t BEGIN CHARESC;",+ "<CHAR>[^'] \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";",+ "<CHARESC>n \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\n'; return " ++ nsDefine inPackage "_CHAR_" ++ ";",+ "<CHARESC>t \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\t'; return " ++ nsDefine inPackage "_CHAR_" ++ ";",+ "<CHARESC>. \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";",+ "<CHAREND>\"'\" \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 = + "<YYINITIAL>\"" ++ 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 [+ "<YYINITIAL>\"" ++ b ++ "\" \t BEGIN COMMENT;",+ "<COMMENT>\"" ++ e ++ "\" \t BEGIN YYINITIAL;",+ "<COMMENT>. \t /* BNFC multi-line comment */;",+ "<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)
+ formats/cpp/CPPTop.hs view
@@ -0,0 +1,208 @@+{-+ 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+import GetCF+import Char+import System++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 <stdio.h>",+ "#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 _ = ""
+ formats/cpp/RegToFlex.hs view
@@ -0,0 +1,73 @@+module RegToFlex (printRegFlex) where++-- modified from pretty-printer generated by the BNF converter++import AbsBNF+import 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<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> 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]
+ formats/cpp_stl/CFtoBisonSTL.hs view
@@ -0,0 +1,373 @@+{-+ 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 List (intersperse, isPrefixOf)+import NamedVariables hiding (varName)+import 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 <stdlib.h>",+ "#include <stdio.h>",+ "#include <string.h>",+ "#include <iostream>",+ "#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<string_> " ++ r ++ " // " ++ s ++ "\n"+ else "%token " ++ r ++ " // " ++ s ++ "\n"++specialToks :: CF -> String+specialToks cf = concat [ + ifC "String" "%token<string_> _STRING_\n",+ ifC "Char" "%token<char_> _CHAR_\n",+ ifC "Integer" "%token<int_> _INTEGER_\n",+ ifC "Double" "%token<double_> _DOUBLE_\n",+ ifC "Ident" "%token<string_> _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++
+ formats/cpp_stl/CFtoCVisitSkelSTL.hs view
@@ -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 List+import 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 ++ ");")+
+ formats/cpp_stl/CFtoSTLAbs.hs view
@@ -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 List+import 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<string>",+ "#include<vector>",+ "",+ "//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 <algorithm>",+ "#include <string>",+ "#include <iostream>",+ "#include <vector>",+ "#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],+ "}"+ ]
+ formats/cpp_stl/CFtoSTLPrinter.hs view
@@ -0,0 +1,676 @@+{- + **************************************************************+ 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 List+import 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 <stdio.h>",+ "#include <string.h>",+ "#include <stdlib.h>",+ "",+ 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 <string>",+ "#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_--;",+ " }",+ "}"+ ]
+ formats/cpp_stl/STLTop.hs view
@@ -0,0 +1,223 @@+{-+ 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+import GetCF+import Char+import System+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 <stdio.h>",+ "#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<vector>",+ "#include<string>",+ "",+ 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 _ = ""
+ formats/f-sharp/FSharpTop.hs view
@@ -0,0 +1,208 @@+{-+ 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 Char+import Data.Maybe (fromMaybe,maybe)+import System+import 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"+ ]+
+ formats/haskell-gadt/CFtoAbstractGADT.hs view
@@ -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 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
+ formats/haskell-gadt/CFtoPrinterGADT.hs view
@@ -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 List (intersperse)+import 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<i then parenth else id",+ ""+ ]++integerRule cf = showsPrintRule cf "Integer"+doubleRule cf = showsPrintRule cf "Double"++showsPrintRule cf t = unlines $ [+ "instance Print " ++ t ++ " where",+ " prt _ x = doc (shows x)",+ ""] ++ ifList cf t++ownPrintRule cf own = unlines $ [+ "instance Print " ++ own ++ " where",+ " prt _ (" ++ own ++ posn ++ ") = doc (showString i)",+ ""] ++ ifList cf own+ where+ posn = if isPositionCat cf own then " (_,i)" else " i"++ifList :: CF -> 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)+
+ formats/haskell-gadt/CFtoTemplateGADT.hs view
@@ -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 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
+ formats/haskell-gadt/HaskellGADTCommon.hs view
@@ -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 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)
+ formats/haskell-gadt/HaskellTopGADT.hs view
@@ -0,0 +1,387 @@+{- + 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 +import GetCF +import Utils + +import Char +import Data.Maybe (fromMaybe,maybe) +import System +import 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 IO ( stdin, hGetContents )", + "import System ( 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 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 }" + ]
+ formats/haskell2/CFtoAbstract.hs view
@@ -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 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"
+ formats/haskell2/CFtoAlex.hs view
@@ -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 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" "<string> ::= ^\" ([^u # [^\"^\\^n]] | (^\\ (^\" | ^\\ | ^' | n | t)))* ^\"" +++ "%{ string p = PT p . TL . unescapeInitTail %}",+ ifC "Char" "<char> ::= ^\' (^u # [^\'^\\] | ^\\ [^\\ ^\' n t]) ^' %{ char p = PT p . TC %}",+ ifC "Integer" "<int> ::= ^d+ %{ int p = PT p . TI %}",+ ifC "Double" + "<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 =+ "<pTSpec> ::= " ++ 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 $+ ["<mk_" ++ name ++ "> ::= " ++ 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+ "<ident> ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" + --ifC "Ident" "<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
+ formats/haskell2/CFtoAlex2.hs view
@@ -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 List++-- For RegToAlex, see below.+import AbsBNF+import 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" "<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<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> 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"]])
+ formats/haskell2/CFtoHappy.hs view
@@ -0,0 +1,280 @@+{-+ 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 List (intersperse, sort)+import 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 = ""+
+ formats/haskell2/CFtoLayout.hs view
@@ -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)
+ formats/haskell2/CFtoPrinter.hs view
@@ -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 List (intersperse)+import 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<i then parenth else id",+ ""+ ]++integerRule cf = showsPrintRule cf "Integer"+doubleRule cf = showsPrintRule cf "Double"++showsPrintRule cf t = unlines $ [+ "instance Print " ++ t ++ " where",+ " prt _ x = doc (shows x)",+ ifList cf t+ ]++identRule byteStrings cf = ownPrintRule byteStrings cf "Ident"++ownPrintRule byteStrings cf own = unlines $ [+ "instance Print " ++ own ++ " where",+ " prt _ (" ++ own ++ posn ++ ") = doc (showString ("++stringUnpack++" i))",+ ifList cf own+ ]+ where+ posn = if isPositionCat cf own then " (_,i)" else " i"+ + stringUnpack | byteStrings = "BS.unpack"+ | otherwise = ""++-- copy and paste from CFtoTemplate++rules :: CF -> 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)+
+ formats/haskell2/CFtoTemplate.hs view
@@ -0,0 +1,106 @@+{-+ 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 Char+import 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]+
+ formats/haskell2/HaskellTop.hs view
@@ -0,0 +1,356 @@+{- + 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 +import GetCF +import Utils + +import Char +import Data.Maybe (fromMaybe,maybe) +import System +import 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 IO ( stdin, hGetContents )", + "import System ( 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 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)" + ]
+ formats/haskell2/MkErrM.hs view
@@ -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"+ ]
@@ -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"+ ]
+ formats/haskell2/RegToAlex.hs view
@@ -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 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<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> 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"]])+++
+ formats/java/CFtoCup.hs view
@@ -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 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+
+ formats/java/CFtoJLex.hs view
@@ -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 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) = + "<YYINITIAL>" ++ (escapeChars s) ++ " { return new Symbol(sym." + ++ r ++ "); }"++restOfJLex :: CF -> [String]+restOfJLex cf =+ [+ lexComments (comments cf),+ userDefTokens,+ ifC "String" strStates,+ ifC "Char" chStates,+ ifC "Double" "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }",+ ifC "Integer" "<YYINITIAL>{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }",+ ifC "Ident" "<YYINITIAL>{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, new String(yytext())); }"+ , "<YYINITIAL>[ \\t\\r\\n\\f] { /* ignore white space. */ }"+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""+ userDefTokens = unlines $+ ["<YYINITIAL>" ++ printRegJLex exp +++ + "{ return new Symbol(sym." ++ name ++ ", yytext()); }"+ | (name, exp) <- tokenPragmas cf]+ strStates = unlines --These handle escaped characters in Strings.+ [+ "<YYINITIAL>\"\\\"\" { yybegin(STRING); }",+ "<STRING>\\\\ { yybegin(ESCAPED); }",+ "<STRING>\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo); }",+ "<STRING>. { pstring += yytext(); }",+ "<ESCAPED>n { pstring += \"\\n\"; yybegin(STRING); }",+ "<ESCAPED>\\\" { pstring += \"\\\"\"; yybegin(STRING); }",+ "<ESCAPED>\\\\ { pstring += \"\\\\\"; yybegin(STRING); }",+ "<ESCAPED>t { pstring += \"\\t\"; yybegin(STRING); }",+ "<ESCAPED>. { pstring += yytext(); yybegin(STRING); }"+ ]+ chStates = unlines --These handle escaped characters in Chars.+ [+ "<YYINITIAL>\"'\" { yybegin(CHAR); }",+ "<CHAR>\\\\ { yybegin(CHARESC); }",+ "<CHAR>[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }",+ "<CHARESC>n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }",+ "<CHARESC>t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }",+ "<CHARESC>. { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }",+ "<CHAREND>\"'\" {yybegin(YYINITIAL);}"+ ]+++++lexComments :: ([(String, String)], [String]) -> String+lexComments (m,s) = + (unlines (map lexSingleComment s)) + ++ (unlines (map lexMultiComment m))++lexSingleComment :: String -> String+lexSingleComment c = + "<YYINITIAL>\"" ++ 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 [+ "<YYINITIAL>\"" ++ b ++ "\" { yybegin(COMMENT); }",+ "<COMMENT>\"" ++ e ++ "\" { yybegin(YYINITIAL); }",+ "<COMMENT>. { }",+ "<COMMENT>[\\n] { }"+ ]+ +-- lexReserved :: String -> String+-- lexReserved s = "<YYINITIAL>\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }"++--Helper function that escapes characters in strings+escapeChars :: String -> String+escapeChars = concatMap escapeChar
+ formats/java/CFtoJavaAbs.hs view
@@ -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 List+import 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
+ formats/java/CFtoJavaPrinter.hs view
@@ -0,0 +1,384 @@+{-+ 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 List+import 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 ++ "_"
+ formats/java/CFtoJavaSkeleton.hs view
@@ -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 List+import 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 ++ ");"
+ formats/java/CFtoVisitSkel.hs view
@@ -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 List+import 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
+ formats/java/JavaTop.hs view
@@ -0,0 +1,313 @@+{-+ 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 Directory ( createDirectory )+import 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+import GetCF ( tryReadCF, writeFileRep )+import Char+import 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)
+ formats/java/RegToJLex.hs view
@@ -0,0 +1,86 @@+module RegToJLex (printRegJLex, escapeChar) where++-- modified from pretty-printer generated by the BNF converter++import AbsBNF+import 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<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> 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 [["."]])+++
+ formats/java1.5/CFtoAbstractVisitor.hs view
@@ -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 List+import 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<R,A> implements AllVisitor<R,A> {",+ 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 _ _ _ _ = ""+
+ formats/java1.5/CFtoAllVisitor.hs view
@@ -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 List+import 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<R,A> 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<R,A>"+ where q = packageAbsyn ++ "." ++ identCat cat
+ formats/java1.5/CFtoComposVisitor.hs view
@@ -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 List+import 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<A> 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"])+
+ formats/java1.5/CFtoCup15.hs view
@@ -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 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 <B,A extends java.util.LinkedList<? super B>> 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+
+ formats/java1.5/CFtoFoldVisitor.hs view
@@ -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 List+import 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<R,A> implements AllVisitor<R,A> {",+ " 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"])+
+ formats/java1.5/CFtoJLex15.hs view
@@ -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 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) = + "<YYINITIAL>" ++ (escapeChars s) ++ " { return new Symbol(sym." + ++ r ++ "); }"++restOfJLex :: CF -> [String]+restOfJLex cf =+ [+ lexComments (comments cf),+ userDefTokens,+ ifC "String" strStates,+ ifC "Char" chStates,+ ifC "Double" "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }",+ ifC "Integer" "<YYINITIAL>{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }",+ ifC "Ident" "<YYINITIAL>{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, yytext().intern()); }"+ , "<YYINITIAL>[ \\t\\r\\n\\f] { /* ignore white space. */ }"+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""+ userDefTokens = unlines $+ ["<YYINITIAL>" ++ printRegJLex exp +++ + "{ return new Symbol(sym." ++ name ++ ", yytext().intern()); }"+ | (name, exp) <- tokenPragmas cf]+ strStates = unlines --These handle escaped characters in Strings.+ [+ "<YYINITIAL>\"\\\"\" { yybegin(STRING); }",+ "<STRING>\\\\ { yybegin(ESCAPED); }",+ "<STRING>\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo.intern()); }",+ "<STRING>. { pstring += yytext(); }",+ "<ESCAPED>n { pstring += \"\\n\"; yybegin(STRING); }",+ "<ESCAPED>\\\" { pstring += \"\\\"\"; yybegin(STRING); }",+ "<ESCAPED>\\\\ { pstring += \"\\\\\"; yybegin(STRING); }",+ "<ESCAPED>t { pstring += \"\\t\"; yybegin(STRING); }",+ "<ESCAPED>. { pstring += yytext(); yybegin(STRING); }"+ ]+ chStates = unlines --These handle escaped characters in Chars.+ [+ "<YYINITIAL>\"'\" { yybegin(CHAR); }",+ "<CHAR>\\\\ { yybegin(CHARESC); }",+ "<CHAR>[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }",+ "<CHARESC>n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }",+ "<CHARESC>t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }",+ "<CHARESC>. { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }",+ "<CHAREND>\"'\" {yybegin(YYINITIAL);}"+ ]+++++lexComments :: ([(String, String)], [String]) -> String+lexComments (m,s) = + (unlines (map lexSingleComment s)) + ++ (unlines (map lexMultiComment m))++lexSingleComment :: String -> String+lexSingleComment c = + "<YYINITIAL>\"" ++ 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 [+ "<YYINITIAL>\"" ++ b ++ "\" { yybegin(COMMENT); }",+ "<COMMENT>\"" ++ e ++ "\" { yybegin(YYINITIAL); }",+ "<COMMENT>. { }",+ "<COMMENT>[\\n] { }"+ ]+ +-- lexReserved :: String -> String+-- lexReserved s = "<YYINITIAL>\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }"++--Helper function that escapes characters in strings+escapeChars :: String -> String+escapeChars = concatMap escapeChar
+ formats/java1.5/CFtoJavaAbs15.hs view
@@ -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 List+import Char(toLower, isDigit)+import 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,A> R accept(" + ++ cls ++ ".Visitor<R,A> v, A arg);",+ prVisitor packageAbsyn funs,+ "}"+ ])]+ where cls = identCat cat++prVisitor :: String -> [String] -> String+prVisitor packageAbsyn funs = + unlines [+ " public interface Visitor <R,A> {",+ 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,A> R accept(" ++ pack ++ "." ++ cat + ++ ".Visitor<R,A> 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
+ formats/java1.5/CFtoJavaPrinter15.hs view
@@ -0,0 +1,379 @@+{-+ 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 List+import 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 ++ "_"
+ formats/java1.5/CFtoVisitSkel15.hs view
@@ -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 List+import 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<R,A> implements "+ ++ identCat cat ++ ".Visitor<R,A>",+ " {",+ 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<R,A>(), 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
+ formats/java1.5/JavaTop15.hs view
@@ -0,0 +1,285 @@+{-+ 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 Directory ( createDirectory )+import 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+import GetCF ( tryReadCF, writeFileRep )+import Char+import 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)
+ formats/ocaml/CFtoOCamlAbs.hs view
@@ -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 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"
+ formats/ocaml/CFtoOCamlLex.hs view
@@ -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 List+import 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<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> 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"]])
+ formats/ocaml/CFtoOCamlPrinter.hs view
@@ -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 List (intersperse)+import 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<i then parenth d else d",+ ""+ ]++charRule cf = unlines [+ "let rec prtChar (_:int) (c:char) : doc = render (\"'\" ^ Char.escaped c ^ \"'\")",+ ifList cf "Char",+ ""+ ]++integerRule cf = unlines [+ "let rec prtInt (_:int) (i:int) : doc = render (string_of_int i)",+ ifList cf "Integer",+ ""+ ]++doubleRule cf = unlines [+ "let rec prtFloat (_:int) (f:float) : doc = render (sprintf \"%f\" f)",+ ifList cf "Double",+ ""+ ]+ +stringRule cf = unlines [+ "let rec prtString (_:int) (s:string) : doc = render (\"\\\"\" ^ String.escaped s ^ \"\\\"\")",+ ifList cf "String",+ ""+ ]++identRule cf = ownPrintRule cf "Ident"++ownPrintRule cf own = unlines $ [+ "let rec" +++ prtFun own +++ "_ (" ++ own ++ posn ++ ") : doc = render i",+ ifList cf own+ ]+ 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) ++ 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)+
+ formats/ocaml/CFtoOCamlShow.hs view
@@ -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 List (intersperse)+import 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)+
+ formats/ocaml/CFtoOCamlTemplate.hs view
@@ -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 Char+import 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]+
+ formats/ocaml/CFtoOCamlTest.hs view
@@ -0,0 +1,66 @@+{-+ 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 ();;",+ ""+ ]++
+ formats/ocaml/CFtoOCamlYacc.hs view
@@ -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 List (intersperse,nub)+import 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>"+ "String" -> "<string>"+ "Integer" -> "<int>"+ "Double" -> "<float>"+ "Char" -> "<char>"+ own -> "<string>" ) + +++ "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 ""+++
+ formats/ocaml/OCamlTop.hs view
@@ -0,0 +1,207 @@+{-+ 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 Char+import Data.Maybe (fromMaybe,maybe)+import System+import 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"+ ]+
+ formats/ocaml/OCamlUtil.hs view
@@ -0,0 +1,71 @@+{-+ 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 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
+ formats/profile/CFtoHappyProfile.hs view
@@ -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 List (intersperse)+import 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 ""
+ formats/profile/ProfileTop.hs view
@@ -0,0 +1,234 @@+{-+ 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+import GetCF+import Utils++import Char+import System+import 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 IO ( stdin, hGetContents )",+ "import System ( 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
+ formats/xml/CFtoXML.hs view
@@ -0,0 +1,217 @@+{-+ 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 List (intersperse, nub)+import 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\"?"),+ "<!DOCTYPE " ++ name ++ " [",+ elemEmp "Integer",+ elemEmp "Double",+ elemEmp "String",+ if hasIdent cf then elemEmp "Ident" else "",+ unlines [elemEmp own | (own,_) <- tokenPragmas cf],+ unlines (map (elemData typ cf) (cf2data cf)),+ "]>"+ ]++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 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+ ]