diff --git a/AbsBNF.hs b/AbsBNF.hs new file mode 100644 --- /dev/null +++ b/AbsBNF.hs @@ -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) + diff --git a/BNF.cf b/BNF.cf new file mode 100644 --- /dev/null +++ b/BNF.cf @@ -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 "{-" "-}" ; + + diff --git a/BNFC.cabal b/BNFC.cabal new file mode 100644 --- /dev/null +++ b/BNFC.cabal @@ -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 Aarne Ranta +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 diff --git a/CF.hs b/CF.hs new file mode 100644 --- /dev/null +++ b/CF.hs @@ -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 diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/ErrM.hs b/ErrM.hs new file mode 100644 --- /dev/null +++ b/ErrM.hs @@ -0,0 +1,26 @@ +-- BNF Converter: Error Monad +-- Copyright (C) 2004 Author: Aarne Ranta + +-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE. +module ErrM where + +-- the Error monad: like Maybe type with error msgs + +import Control.Monad (MonadPlus(..), liftM) + +data Err a = Ok a | Bad String + deriving (Read, Show, Eq, Ord) + +instance Monad Err where + return = Ok + fail = Bad + Ok a >>= f = f a + Bad s >>= f = Bad s + +instance Functor Err where + fmap = liftM + +instance MonadPlus Err where + mzero = Bad "Err.mzero" + mplus (Bad _) y = y + mplus x _ = x diff --git a/GetCF.hs b/GetCF.hs new file mode 100644 --- /dev/null +++ b/GetCF.hs @@ -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 "[]" [] + diff --git a/LexBNF.x b/LexBNF.x new file mode 100644 --- /dev/null +++ b/LexBNF.x @@ -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 +} diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 * ? * 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 Prepend to the Haskell module names." + putStrLn " Dots in the module name create hierarchical modules." + putStrLn " -alex1 Use Alex 1.1 as Haskell lexer tool" + putStrLn " -alex2 Use Alex 2 as Haskell lexer tool (default)" + putStrLn " -sharestrings Use string sharing in Alex 2 lexer" + putStrLn " -bytestrings Use byte string in Alex 2 lexer" + putStrLn " -glr Output Happy GLR parser" + putStrLn " -xml Also generate a DTD and an XML printer" + putStrLn " -xmlt DTD and an XML printer, another encoding" + putStrLn "" + putStrLn "Special options for the C++ STL back-end:" + putStrLn " -l Add and set line_number field for all syntax classes" + putStrLn " -p Use as the C++ namespace" + putStrLn "" + putStrLn "Special options for the Java 1.5 back-end:" + putStrLn " -p Prepend to the Java package name" + putStrLn "" + putStrLn "Special options for the C# backend:" + putStrLn " -p Use as the C# namespace" + putStrLn " -vs Generate Visual Studio solution/project files" + putStrLn " -wcf Add support for Windows Communication Foundation, by" + putStrLn " marking abstract syntax classes as DataContracts" + exitFailure +-- putStrLn " : -gf write GF files" + + +checkUsage _ [] = True +checkUsage True (True:xs) = False +checkUsage False (True:xs) = checkUsage True xs +checkUsage old (x:xs) = checkUsage old xs diff --git a/MultiView.hs b/MultiView.hs new file mode 100644 --- /dev/null +++ b/MultiView.hs @@ -0,0 +1,137 @@ +{- + BNF Converter: Abstract syntax + Copyright (C) 2004 Author: Markus Forsberg, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +module MultiView where + +import 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 (/='_') diff --git a/ParBNF.hs b/ParBNF.hs new file mode 100644 --- /dev/null +++ b/ParBNF.hs @@ -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 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- $Id: ParBNF.hs,v 1.14 2007/01/08 17:54:31 aarne Exp $ + + +{-# LINE 28 "GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + + +{-# LINE 49 "GenericTemplate.hs" #-} + + +{-# LINE 59 "GenericTemplate.hs" #-} + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + + + + + + + + + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 170 "GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError_ tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/PrintBNF.hs b/PrintBNF.hs new file mode 100644 --- /dev/null +++ b/PrintBNF.hs @@ -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 (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + + +instance Print Double where + prt _ x = doc (shows x) + + +instance Print Ident where + prt _ (Ident i) = doc (showString i) + prtList es = case es of + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + + + +instance Print LGrammar where + prt i e = case e of + LGr ldefs -> prPrec i 0 (concatD [prt 0 ldefs]) + + +instance Print LDef where + prt i e = case e of + DefAll def -> prPrec i 0 (concatD [prt 0 def]) + DefSome ids def -> prPrec i 0 (concatD [prt 0 ids , doc (showString ":") , prt 0 def]) + LDefView ids -> prPrec i 0 (concatD [doc (showString "views") , prt 0 ids]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Grammar where + prt i e = case e of + Grammar defs -> prPrec i 0 (concatD [prt 0 defs]) + + +instance Print Def where + prt i e = case e of + Rule label cat items -> prPrec i 0 (concatD [prt 0 label , doc (showString ".") , prt 0 cat , doc (showString "::=") , prt 0 items]) + Comment str -> prPrec i 0 (concatD [doc (showString "comment") , prt 0 str]) + Comments str0 str -> prPrec i 0 (concatD [doc (showString "comment") , prt 0 str0 , prt 0 str]) + Internal label cat items -> prPrec i 0 (concatD [doc (showString "internal") , prt 0 label , doc (showString ".") , prt 0 cat , doc (showString "::=") , prt 0 items]) + Token id reg -> prPrec i 0 (concatD [doc (showString "token") , prt 0 id , prt 0 reg]) + PosToken id reg -> prPrec i 0 (concatD [doc (showString "position") , doc (showString "token") , prt 0 id , prt 0 reg]) + Entryp ids -> prPrec i 0 (concatD [doc (showString "entrypoints") , prt 0 ids]) + Separator minimumsize cat str -> prPrec i 0 (concatD [doc (showString "separator") , prt 0 minimumsize , prt 0 cat , prt 0 str]) + Terminator minimumsize cat str -> prPrec i 0 (concatD [doc (showString "terminator") , prt 0 minimumsize , prt 0 cat , prt 0 str]) + Coercions id n -> prPrec i 0 (concatD [doc (showString "coercions") , prt 0 id , prt 0 n]) + Rules id rhss -> prPrec i 0 (concatD [doc (showString "rules") , prt 0 id , doc (showString "::=") , prt 0 rhss]) + Function id args exp -> prPrec i 0 (concatD [doc (showString "define") , prt 0 id , prt 0 args , doc (showString "=") , prt 0 exp]) + Layout strs -> prPrec i 0 (concatD [doc (showString "layout") , prt 0 strs]) + LayoutStop strs -> prPrec i 0 (concatD [doc (showString "layout") , doc (showString "stop") , prt 0 strs]) + LayoutTop -> prPrec i 0 (concatD [doc (showString "layout") , doc (showString "toplevel")]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs]) + +instance Print Item where + prt i e = case e of + Terminal str -> prPrec i 0 (concatD [prt 0 str]) + NTerminal cat -> prPrec i 0 (concatD [prt 0 cat]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print Cat where + prt i e = case e of + ListCat cat -> prPrec i 0 (concatD [doc (showString "[") , prt 0 cat , doc (showString "]")]) + IdCat id -> prPrec i 0 (concatD [prt 0 id]) + + +instance Print Label where + prt i e = case e of + LabNoP labelid -> prPrec i 0 (concatD [prt 0 labelid]) + LabP labelid profitems -> prPrec i 0 (concatD [prt 0 labelid , prt 0 profitems]) + LabPF labelid0 labelid profitems -> prPrec i 0 (concatD [prt 0 labelid0 , prt 0 labelid , prt 0 profitems]) + LabF labelid0 labelid -> prPrec i 0 (concatD [prt 0 labelid0 , prt 0 labelid]) + + +instance Print LabelId where + prt i e = case e of + Id id -> prPrec i 0 (concatD [prt 0 id]) + Wild -> prPrec i 0 (concatD [doc (showString "_")]) + ListE -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "]")]) + ListCons -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ":") , doc (showString ")")]) + ListOne -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ":") , doc (showString "[") , doc (showString "]") , doc (showString ")")]) + + +instance Print ProfItem where + prt i e = case e of + ProfIt intlists ns -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "[") , prt 0 intlists , doc (showString "]") , doc (showString ",") , doc (showString "[") , prt 0 ns , doc (showString "]") , doc (showString ")")]) + + prtList es = case es of + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print IntList where + prt i e = case e of + Ints ns -> prPrec i 0 (concatD [doc (showString "[") , prt 0 ns , doc (showString "]")]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print Arg where + prt i e = case e of + Arg id -> prPrec i 0 (concatD [prt 0 id]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print Exp where + prt i e = case e of + Cons exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString ":") , prt 0 exp]) + App id exps -> prPrec i 1 (concatD [prt 0 id , prt 2 exps]) + Var id -> prPrec i 2 (concatD [prt 0 id]) + LitInt n -> prPrec i 2 (concatD [prt 0 n]) + LitChar c -> prPrec i 2 (concatD [prt 0 c]) + LitString str -> prPrec i 2 (concatD [prt 0 str]) + LitDouble d -> prPrec i 2 (concatD [prt 0 d]) + List exps -> prPrec i 2 (concatD [doc (showString "[") , prt 0 exps , doc (showString "]")]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 2 x]) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 2 x , prt 2 xs]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print RHS where + prt i e = case e of + RHS items -> prPrec i 0 (concatD [prt 0 items]) + + prtList es = case es of + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs]) + +instance Print MinimumSize where + prt i e = case e of + MNonempty -> prPrec i 0 (concatD [doc (showString "nonempty")]) + MEmpty -> prPrec i 0 (concatD []) + + +instance Print Reg where + prt i e = case e of + RSeq reg0 reg -> prPrec i 2 (concatD [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concatD [prt 1 reg0 , doc (showString "|") , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concatD [prt 2 reg0 , doc (showString "-") , prt 2 reg]) + RStar reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "*")]) + RPlus reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "+")]) + ROpt reg -> prPrec i 3 (concatD [prt 3 reg , doc (showString "?")]) + REps -> prPrec i 3 (concatD [doc (showString "eps")]) + RChar c -> prPrec i 3 (concatD [prt 0 c]) + RAlts str -> prPrec i 3 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")]) + RSeqs str -> prPrec i 3 (concatD [doc (showString "{") , prt 0 str , doc (showString "}")]) + RDigit -> prPrec i 3 (concatD [doc (showString "digit")]) + RLetter -> prPrec i 3 (concatD [doc (showString "letter")]) + RUpper -> prPrec i 3 (concatD [doc (showString "upper")]) + RLower -> prPrec i 3 (concatD [doc (showString "lower")]) + RAny -> prPrec i 3 (concatD [doc (showString "char")]) + + + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/env runghc + +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain diff --git a/TypeChecker.hs b/TypeChecker.hs new file mode 100644 --- /dev/null +++ b/TypeChecker.hs @@ -0,0 +1,146 @@ + +module TypeChecker where + +import Control.Monad +import Data.List +import Data.Char + +import CF +import ErrM + +data Base = BaseT String + | ListT Base + deriving (Eq) + +data Type = FunT [Base] Base + deriving (Eq) + +instance Show Base where + show (BaseT x) = x + show (ListT t) = "[" ++ show t ++ "]" + +instance Show Type where + show (FunT ts t) = unwords $ map show ts ++ ["->", show t] + +data Context = Ctx { ctxLabels :: [(String, Type)] + , ctxTokens :: [String] + } + +catchErr :: Err a -> (String -> Err a) -> Err a +catchErr (Bad s) f = f s +catchErr (Ok x) _ = Ok x + +buildContext :: CF -> Context +buildContext cf@(_,rules) = + Ctx + [ (f, mkType cat args) | (f,(cat,args)) <- rules + , not (isCoercion f) + , not (isNilCons f) + ] + ("Ident" : tokenNames cf) + where + + mkType cat args = FunT [ mkBase t | Left t <- args, t /= internalCat ] + (mkBase cat) + mkBase t + | isList t = ListT $ mkBase $ normCatOfList t + | otherwise = BaseT $ normCat t + +isToken :: String -> Context -> Bool +isToken x ctx = elem x $ ctxTokens ctx + +extendContext :: Context -> [(String,Type)] -> Context +extendContext ctx xs = ctx { ctxLabels = xs ++ ctxLabels ctx } + +lookupCtx :: String -> Context -> Err Type +lookupCtx x ctx + | isToken x ctx = return $ FunT [BaseT "String"] (BaseT x) + | otherwise = + case lookup x $ ctxLabels ctx of + Nothing -> fail $ "Undefined symbol '" ++ x ++ "'." + Just t -> return t + +checkDefinitions :: CF -> Err () +checkDefinitions cf@((ps,_),_) = + do checkContext ctx + sequence_ [ checkDefinition ctx f xs e | FunDef f xs e <- ps ] + where + ctx = buildContext cf + +checkContext :: Context -> Err () +checkContext ctx = + mapM_ checkEntry $ groupSnd $ ctxLabels ctx + where + -- This is a very handy function which transforms a lookup table + -- with duplicate keys to a list valued lookup table with no duplicate + -- keys. + groupSnd :: Ord a => [(a,b)] -> [(a,[b])] + groupSnd = + map ((fst . head) /\ map snd) + . groupBy ((==) **.* fst) + . sortBy (compare **.* fst) + + (f /\ g) x = (f x, g x) + (f **.* g) x y = f (g x) (g y) + + checkEntry (f,ts) = + case nub ts of + [_] -> return () + ts' -> + fail $ "The symbol '" ++ f ++ "' is used at conflicting types:\n" ++ + unlines (map ((" " ++) . show) ts') + +checkDefinition :: Context -> String -> [String] -> Exp -> Err () +checkDefinition ctx f xs e = + do checkDefinition' dummyConstructors ctx f xs e + return () + +data ListConstructors = LC + { nil :: Base -> String + , cons :: Base -> String + } + +dummyConstructors :: ListConstructors +dummyConstructors = LC (const "[]") (const "(:)") + +checkDefinition' :: ListConstructors -> Context -> String -> [String] -> Exp -> Err ([(String,Base)],(Exp,Base)) +checkDefinition' list ctx f xs e = + do unless (isLower $ head f) $ fail "Defined functions must start with a lowercase letter." + t@(FunT ts t') <- lookupCtx f ctx `catchErr` \_ -> + fail $ "'" ++ f ++ "' must be used in a rule." + let expect = length ts + given = length xs + unless (expect == given) $ fail $ "'" ++ f ++ "' is used with type " ++ show t ++ " but defined with " ++ show given ++ " argument" ++ plural given ++ "." + e' <- checkExp list (extendContext ctx $ zip xs (map (FunT []) ts)) e t' + return (zip xs ts, (e', t')) + `catchErr` \err -> fail $ "In the definition " ++ unwords (f : xs ++ ["=",show e,";"]) ++ "\n " ++ err + where + plural 1 = "" + plural _ = "s" + +checkExp :: ListConstructors -> Context -> Exp -> Base -> Err Exp +checkExp list ctx (App "[]" []) (ListT t) = return (App (nil list t) []) +checkExp _ _ (App "[]" _) _ = fail $ "[] is applied to too many arguments." +checkExp list ctx (App "(:)" [e,es]) (ListT t) = + do e' <- checkExp list ctx e t + es' <- checkExp list ctx es (ListT t) + return $ App (cons list t) [e',es'] +checkExp _ _ (App "(:)" es) _ = fail $ "(:) takes 2 arguments, but has been given " ++ show (length es) ++ "." +checkExp list ctx e@(App x es) t = + do FunT ts t' <- lookupCtx x ctx + es' <- matchArgs ctx es ts + unless (t == t') $ fail $ show e ++ " has type " ++ show t' ++ ", but something of type " ++ show t ++ " was expected." + return $ App x es' + where + matchArgs ctx es ts + | expect /= given = fail $ "'" ++ x ++ "' takes " ++ show expect ++ " arguments, but has been given " ++ show given ++ "." + | otherwise = zipWithM (checkExp list ctx) es ts + where + expect = length ts + given = length es +checkExp _ _ e@(LitInt _) (BaseT "Integer") = return e +checkExp _ _ e@(LitDouble _) (BaseT "Double") = return e +checkExp _ _ e@(LitChar _) (BaseT "Char") = return e +checkExp _ _ e@(LitString _) (BaseT "String") = return e +checkExp _ _ e t = fail $ show e ++ " does not have type " ++ show t ++ "." + diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -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 diff --git a/dist/build/bnfc/bnfc-tmp/LexBNF.hs b/dist/build/bnfc/bnfc-tmp/LexBNF.hs new file mode 100644 --- /dev/null +++ b/dist/build/bnfc/bnfc-tmp/LexBNF.hs @@ -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 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +{-# LINE 35 "templates/GenericTemplate.hs" #-} + +{-# LINE 45 "templates/GenericTemplate.hs" #-} + + +data AlexAddr = AlexA# Addr# + +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetChar input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input' + + (AlexLastSkip input len, _) -> + + + + AlexSkip input len + + (AlexLastAcc k input len, _) -> + + + + AlexToken input len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + let + new_acc = check_accs (alex_accept `quickIndex` (I# (s))) + in + new_acc `seq` + case alexGetChar input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + let + base = alexIndexInt32OffAddr alex_base s + (I# (ord_c)) = ord c + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if (offset >=# 0#) && (check ==# ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + -1# -> (new_acc, input) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user orig_input (len +# 1#) + new_input new_s new_acc + + where + check_accs [] = last_acc + check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) + check_accs (AlexAccPred a pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkipPred pred : rest) + | pred user orig_input (I# (len)) input + = AlexLastSkip input (I# (len)) + check_accs (_ : rest) = check_accs rest + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc a user + = AlexAcc a + | AlexAccSkip + | AlexAccPred a (AlexAccPred user) + | AlexAccSkipPred (AlexAccPred user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + +-- used by wrappers +iUnbox (I# (i)) = i diff --git a/formats/CFtoLatex.hs b/formats/CFtoLatex.hs new file mode 100644 --- /dev/null +++ b/formats/CFtoLatex.hs @@ -0,0 +1,276 @@ +{- + BNF Converter: Latex Generator + Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoLatex (cfToLatex)where + +import CF +import AbsBNF (Reg (..)) +import Utils +import List (nub,intersperse) + +cfToLatex :: String -> CF -> String +cfToLatex name cf = unlines [ + "\\batchmode", + beginDocument name, + macros, + introduction, + prtTerminals name cf, + prtBNF name cf, + endDocument + ] + +introduction :: String +introduction = concat + [ + "\nThis document was automatically generated by ", + "the {\\em BNF-Converter}.", + " It was generated together with the lexer, the parser, and the", + " abstract syntax module, which guarantees that the document", + " matches with the implementation of the language (provided no", + " hand-hacking has taken place).\n" + ] + +prtTerminals :: String -> CF -> String +prtTerminals name cf = unlines [ + "\\section*{The lexical structure of " ++ name ++ "}", + identSection cf, + "\\subsection*{Literals}", + prtLiterals name cf, + unlines (map prtOwnToken (tokenPragmas cf)), + "\\subsection*{Reserved words and symbols}", + prtReserved name cf, + prtSymb name cf, + "\\subsection*{Comments}", + prtComments $ comments cf + ] + +identSection cf = if not (hasIdent cf) then [] else + unlines [ + "\\subsection*{Identifiers}", + prtIdentifiers + ] + +prtIdentifiers :: String +prtIdentifiers = unlines + [ + "Identifiers \\nonterminal{Ident} are unquoted strings beginning with a letter,", + "followed by any combination of letters, digits, and the characters {\\tt \\_ '},", + "reserved words excluded." + ] + +prtLiterals :: String -> CF -> String +prtLiterals name cf = + unlines $ map stringLit $ + filter (`notElem` ["Ident"]) $ + literals cf + +stringLit :: String -> String +stringLit cat = unlines $ case cat of + "Char" -> ["Character literals \\nonterminal{Char}\\ have the form", + "\\terminal{'}$c$\\terminal{'}, where $c$ is any single character.", + "" + ] + "String" -> ["String literals \\nonterminal{String}\\ have the form", + "\\terminal{\"}$x$\\terminal{\"}, where $x$ is any sequence of any characters", + "except \\terminal{\"}\\ unless preceded by \\verb6\\6.", + ""] + "Integer" -> ["Integer literals \\nonterminal{Int}\\ are nonempty sequences of digits.", + ""] + "Double" -> ["Double-precision float literals \\nonterminal{Double}\\ have the structure", + "indicated by the regular expression" +++ + "$\\nonterminal{digit}+ \\mbox{{\\it `.'}} \\nonterminal{digit}+ (\\mbox{{\\it `e'}} \\mbox{{\\it `-'}}? \\nonterminal{digit}+)?$ i.e.\\", + "two sequences of digits separated by a decimal point, optionally", + "followed by an unsigned or negative exponent.", + ""] + _ -> [] + +prtOwnToken (name,reg) = unlines + [name +++ "literals are recognized by the regular expression", + "\\(" ++ + latexRegExp reg ++ + "\\)" + ] + +prtComments :: ([(String,String)],[String]) -> String +prtComments (xs,ys) = concat + [ + if (null ys) then + "There are no single-line comments in the grammar. \\\\" + else + "Single-line comments begin with " ++ sing ++". \\\\", + if (null xs) then + "There are no multiple-line comments in the grammar." + else + "Multiple-line comments are enclosed with " ++ mult ++"." + ] + where + sing = concat $ intersperse ", " $ map (symbol.prt) ys + mult = concat $ intersperse ", " $ + map (\(x,y) -> (symbol (prt x)) + ++ " and " ++ + (symbol (prt y))) xs + +prtSymb :: String -> CF -> String +prtSymb name cf = case symbols cf of + [] -> "\nThere are no symbols in " ++ name ++ ".\\\\\n" + xs -> "The symbols used in " ++ name ++ " are the following: \\\\\n" + ++ + (tabular 3 $ three $ map (symbol.prt) xs) + +prtReserved :: String -> CF -> String +prtReserved name cf = case reservedWords cf of + [] -> stringRes name ++ + "\nThere are no reserved words in " ++ name ++ ".\\\\\n" + xs -> stringRes name ++ + (tabular 3 $ three $ map (reserved.prt) xs) + +stringRes :: String -> String +stringRes name = concat + ["The set of reserved words is the set of terminals ", + "appearing in the grammar. Those reserved words ", + "that consist of non-letter characters are called symbols, and ", + "they are treated in a different way from those that ", + "are similar to identifiers. The lexer ", + "follows rules familiar from languages ", + "like Haskell, C, and Java, including longest match ", + "and spacing conventions.", + "\n\n", + "The reserved words used in " ++ name ++ " are the following: \\\\\n"] + +three :: [String] -> [[String]] +three [] = [] +three [x] = [[x,[],[]]] +three [x,y] = [[x,y,[]]] +three (x:y:z:xs) = [x,y,z] : three xs + +prtBNF :: String -> CF -> String +prtBNF name cf = unlines [ + "\\section*{The syntactic structure of " ++ name ++"}", + "Non-terminals are enclosed between $\\langle$ and $\\rangle$. ", + "The symbols " ++ arrow ++ " (production), " ++ + delimiter ++" (union) ", + "and " ++ empty ++ " (empty rule) belong to the BNF notation. ", + "All other symbols are terminals.\\\\", + prtRules (ruleGroups cf) + ] + +prtRules :: [(Cat,[Rule])] -> String +prtRules [] = [] +prtRules ((c,[]):xs) + = tabular 3 [[nonterminal c,arrow,[]]] ++ prtRules xs +prtRules ((c,(r:rs)):xs) + = tabular 3 ([[nonterminal c,arrow,prtSymbols $ rhsRule r]] ++ + [[[],delimiter,prtSymbols (rhsRule y)] | y <- rs]) ++ + prtRules xs + +prtSymbols :: [Either Cat String] -> String +prtSymbols [] = empty +prtSymbols xs = foldr (+++) [] (map p xs) + where p (Left r) = nonterminal r --- (prt r) + p (Right r) = terminal (prt r) + +prt :: String -> String +prt [] = [] +prt (c:xs) + | elem c "$&%#_{}^" = "\\" ++ [c] ++ prt xs + | elem c "+=|<>-" = "{$" ++ [c] ++ "$}" ++ prt xs + | c == '\\' = "$\\backslash$" + | c == '~' = "\\~{}" + | otherwise = c : prt xs + +macros :: String +macros = + "\\newcommand{\\emptyP}{\\mbox{$\\epsilon$}}" ++++ + "\\newcommand{\\terminal}[1]{\\mbox{{\\texttt {#1}}}}" ++++ + "\\newcommand{\\nonterminal}[1]{\\mbox{$\\langle \\mbox{{\\sl #1 }} \\! \\rangle$}}" ++++ + "\\newcommand{\\arrow}{\\mbox{::=}}" ++++ + "\\newcommand{\\delimit}{\\mbox{$|$}}" ++++ + "\\newcommand{\\reserved}[1]{\\mbox{{\\texttt {#1}}}}" ++++ + "\\newcommand{\\literal}[1]{\\mbox{{\\texttt {#1}}}}" ++++ + "\\newcommand{\\symb}[1]{\\mbox{{\\texttt {#1}}}}" + +reserved :: String -> String +reserved s = "{\\reserved{" ++ s ++ "}}" + +literal :: String -> String +literal s = "{\\literal{" ++ s ++ "}}" + +empty :: String +empty = "{\\emptyP}" + +symbol :: String -> String +symbol s = "{\\symb{" ++ s ++ "}}" + +tabular :: Int -> [[String]] -> String +tabular n xs = "\n\\begin{tabular}{" ++ concat (replicate n "l") ++ "}\n" ++ + concat (map (\(a:as) -> foldr (+++) "\\\\\n" (a:(map ('&':) as))) xs) ++ + "\\end{tabular}\\\\\n" + +terminal :: String -> String +terminal s = "{\\terminal{" ++ s ++ "}}" + +nonterminal :: String -> String +nonterminal s = "{\\nonterminal{" ++ identCat (mkId s) ++ "}}" where + mkId = map mk + mk c = case c of + '_' -> '-' --- + _ -> c + + +arrow :: String +arrow = " {\\arrow} " + +delimiter :: String +delimiter = " {\\delimit} " + +beginDocument :: String -> String +beginDocument name = + "%This Latex file is machine-generated by the BNF-converter\n" ++++ + "\\documentclass[a4paper,11pt]{article}" ++++ + "\\author{BNF-converter}" ++++ + "\\title{The Language " ++ name ++ "}" ++++ + -- "\\usepackage{isolatin1}" ++++ + "\\setlength{\\parindent}{0mm}" ++++ + "\\setlength{\\parskip}{1mm}" ++++ + "\\begin{document}\n" ++++ + "\\maketitle\n" + +endDocument :: String +endDocument = + "\n\\end{document}\n" + +latexRegExp :: Reg -> String +latexRegExp = rex (0 :: Int) where + rex i e = case e of + RSeq reg0 reg -> ifPar i 2 $ rex 2 reg0 +++ rex 2 reg + RAlt reg0 reg -> ifPar i 1 $ rex 1 reg0 +++ "\\mid" +++ rex 1 reg + RMinus reg0 reg -> ifPar i 1 $ rex 2 reg0 +++ "-" +++ rex 2 reg + RStar reg -> rex 3 reg ++ "*" + RPlus reg -> rex 3 reg ++ "+" + ROpt reg -> rex 3 reg ++ "?" + REps -> "\\epsilon" + RChar c -> "\\mbox{`" ++ prt [c] ++ "'}" + RAlts str -> "[" ++ "\\mbox{``" ++ prt str ++ "''}" ++ "]" + RSeqs str -> "\\{" ++ "\\mbox{``" ++ prt str ++ "''}" ++ "\\}" + RDigit -> "{\\nonterminal{digit}}" + RLetter -> "{\\nonterminal{letter}}" + RUpper -> "{\\nonterminal{upper}}" + RLower -> "{\\nonterminal{lower}}" + RAny -> "{\\nonterminal{anychar}}" + ifPar i j s = if i > j then "(" ++ s ++ ")" else s diff --git a/formats/NamedVariables.hs b/formats/NamedVariables.hs new file mode 100644 --- /dev/null +++ b/formats/NamedVariables.hs @@ -0,0 +1,109 @@ + +{- + BNF Converter: Named instance variables + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +{- + ************************************************************** + BNF Converter Module + + Description : This module provides support for languages which need + named instance variables. (IE Java, C, C++) It provides + a data type to represent the name mapping and utility + functions to work with it. + + Variables are grouped and numbered in a nice way. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + ************************************************************** +-} + +module NamedVariables where + +import CF +import 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) diff --git a/formats/OOAbstract.hs b/formats/OOAbstract.hs new file mode 100644 --- /dev/null +++ b/formats/OOAbstract.hs @@ -0,0 +1,129 @@ +{- + BNF Converter: Datastructure for object-oriented abstract syntax generators + Copyright (C) 2006 Author: Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module defines a data structure that is + used for generating abstract syntax in cpp_stl. + It should be used in other STL modules as well, + and could be used for object-oriented languages + in general, to avoid duplicated work. + + Author : Aarne Ranta (aarne@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 29 August, 2006 + + Modified : 29 August, 2006 / Aarne Ranta + + + ************************************************************** +-} + +module OOAbstract where + +import CF +import Utils((+++),(++++)) +import NamedVariables +import 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 diff --git a/formats/c-sharp/CAbstoCSharpAbs.hs b/formats/c-sharp/CAbstoCSharpAbs.hs new file mode 100644 --- /dev/null +++ b/formats/c-sharp/CAbstoCSharpAbs.hs @@ -0,0 +1,277 @@ +{- + BNF Converter: C# Abstract Syntax Generator + Copyright (C) 2006-2007 Author: Johan Broberg + + Modified from CFtoSTLAbs + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C# Abstract Syntax + tree classes. It uses the Visitor design + pattern. + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 22 November, 2006 + + Modified : 21 January, 2007 by Johan Broberg + + ************************************************************** +-} + +module CAbstoCSharpAbs (cabs2csharpabs) where + +import OOAbstract +import CF +import Utils((+++),(++++)) +import NamedVariables +import 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(" ++ identifier namespace cat ++ ".Visitor v, A arg);", + prVisitor namespace funs, + " }" + ] + +prVisitor :: Namespace -> [Cat] -> String +prVisitor namespace funs = unlinesInline [ + " ", + " public interface Visitor", + " {", + unlinesInline (map prVisitFun funs), + " }" + ] + where + prVisitFun f = " R Visit(" ++ identifier namespace f ++ " p, A arg);" + +prCon :: Namespace -> Bool -> (Cat,CSharpAbsRule) -> String +prCon namespace useWCF (c,(f,cs)) = unlinesInline [ + prDataContract useWCF [], + " public class " ++ f ++ ext, + " {", + -- Instance variables + unlines [prInstVar typ var | (typ,_,var,_) <- cs], + prConstructor namespace (f,cs), + unlinesInline [prProperty typ var prop | (typ,_,var,prop) <- cs], + prEquals namespace f propnames, + prHashCode namespace f propnames, + -- print Accept method, override keyword needed for classes inheriting an abstract class + prAccept namespace c (if isAlsoCategory f c then Nothing else (Just " override")), + -- if this label is also a category, we need to print the Visitor interface + -- (if not, it was already printed in the abstract class) + if isAlsoCategory f c then prVisitor namespace [c] else "", + " }" + ] + where + -- This handles the case where a LBNF label is the same as the category. + ext = if isAlsoCategory f c then "" else " : " ++ identifier namespace (identCat c) + propnames = [prop | (_, _, _, prop) <- cs] + prInstVar typ var = unlinesInline [ + " private " ++ identifier namespace (typename typ) +++ var ++ ";" + ] + prProperty typ var prop = unlinesInline [ + " ", + prDataMember useWCF, + " public " ++ identifier namespace (typename typ) +++ prop, + " {", + " get", + " {", + " return this." ++ var ++ ";", + " }", + " set", + " {", + " this." ++ var ++ " = value;", + " }", + " }" + ] + +-- Creates the Equals() methods +prEquals :: Namespace -> Fun -> [String] -> String +prEquals namespace c vars = unlinesInline [ + " ", + " public override bool Equals(Object obj)", + " {", + " if(this == obj)", + " {", + " return true;", + " }", + " if(obj is " ++ identifier namespace c ++ ")", + " {", + " return this.Equals((" ++ identifier namespace c ++ ")obj);", + " }", + " return base.Equals(obj);", + " }", + " ", + " public bool Equals(" ++ identifier namespace c ++ " obj)", + " {", + " if(this == obj)", + " {", + " return true;", + " }", + " return " ++ prEqualsVars vars ++ ";", + " }" + ] + where + prEqualsVars [] = "true" + prEqualsVars vs = concat $ intersperse " && " $ map equalVar vs + equalVar v = "this." ++ v ++ ".Equals(obj." ++ v ++ ")" + +-- Creates the GetHashCode() method. +prHashCode :: Namespace -> Fun -> [String] -> String +prHashCode namespace c vars = unlinesInline [ + " ", + " public override int GetHashCode()", + " {", + " return " ++ prHashVars vars ++ ";", + " }" + ] + where + aPrime = 37 + prHashVars [] = show aPrime + prHashVars (v:vs) = prHashVars' (hashVar v) vs + prHashVars' r [] = r + prHashVars' r (v:vs) = prHashVars' (show aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashVar v) vs + hashVar var = "this." ++ var ++ ".GetHashCode()" + +prList :: Namespace -> (Cat,Bool) -> String +prList namespace (c,_) = unlinesInline [ + " public class " ++ c ++ " : List<" ++ identifier namespace (typename bas) ++ ">", + " {", + " }" + ] + where + bas = drop 4 c -- drop List + +-- The standard Accept method for the Visitor pattern +prAccept :: Namespace -> Cat -> Maybe String -> String +prAccept namespace cat maybeOverride = unlinesInline [ + " ", + " public" ++ fromMaybe "" maybeOverride ++ " R Accept(" ++ identifier namespace cat ++ ".Visitor visitor, A arg)", + " {", + " return visitor.Visit(this, arg);", + " }" + ] + +-- The constructor assigns the parameters to the corresponding instance variables. +prConstructor :: Namespace -> CSharpAbsRule -> String +prConstructor namespace (f,cs) = unlinesInline [ + " public " ++ f ++ "(" ++ conargs ++ ")", + " {", + unlinesInline [" " ++ c ++ " = " ++ p ++ ";" | (c,p) <- zip cvs pvs], + " }" + ] + where + cvs = [c | (_,_,c,_) <- cs] + pvs = ["p" ++ show i | ((x,st,_,_),i) <- zip cs [1..]] + conargs = concat $ intersperse ", " + [identifier namespace (typename x) +++ v | ((x,_,_,_),v) <- zip cs pvs] diff --git a/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs b/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs new file mode 100644 --- /dev/null +++ b/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs @@ -0,0 +1,97 @@ +{- + BNF Converter: C# Abstract Visit Skeleton Generator + + Copyright (C) 2006 Author: Johan Broberg + + Modified from CAbstoCSharpVisitSkeleton + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates an Abstract Visit Skeleton for C#. + This can be useful if you often make changes to your + grammar and want to keep your own changes (not having to + merge with the new visit skeleton each time), while still + getting compile errors if your code is no longer correct. + The generated file uses the Visitor design pattern. + + This could have been generated from within + CAbstoVisitSkeleton, but that would have made it more + difficult to actually use it (and the visit skeleton). + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 19 December, 2006 + + Modified : 19 December, 2006 by Johan Broberg + + ************************************************************** +-} + +module CAbstoCSharpAbstractVisitSkeleton (cabs2csharpAbstractVisitSkeleton) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import List +import OOAbstract hiding (basetypes) +import CSharpUtils +import CAbstoCSharpAbs + +--Produces .cs file +cabs2csharpAbstractVisitSkeleton :: Namespace -> CAbs -> String +cabs2csharpAbstractVisitSkeleton namespace cabs = unlines [ + "/*** BNFC-Generated Abstract Visitor Design Pattern Skeleton. ***/", + "/* This implements the common visitor design pattern.", + " Replace the R and A parameters with the desired return", + " and context types.*/", + "", + "namespace " ++ namespace ++ ".VisitSkeleton", + "{", + " #region Classes", + unlinesInlineMap (prCon namespace) (signatures cabs), + " #endregion", + " ", + " #region Token types", + unlinesInlineMap (prBasic namespace) (tokentypes cabs), + " #endregion", + "}" + ] + +prBasic namespace c = unlinesInline [ + " public abstract class Abstract" ++ c ++ "Visitor : " ++ identifier namespace c ++ ".Visitor", + " {", + " public abstract R Visit(" ++ identifier namespace (typename c) +++ varname c ++ ", A arg);", + " }" + ] + +prCon :: Namespace -> (Cat, [CAbsRule]) -> String +prCon namespace (c,fs) = unlinesInline [ + " public abstract class Abstract" ++ c ++ "Visitor : " ++ identifier namespace c ++ ".Visitor", + " {", + unlinesInlineMap (prVisit namespace) fs, + " }" + ] + +prVisit :: Namespace -> (Fun, [(Cat, Bool, String)]) -> String +prVisit namespace (f,cs) = unlinesInline [ + " public abstract R Visit(" ++ identifier namespace f +++ varname f ++ ", A arg);" + ] diff --git a/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs b/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs new file mode 100644 --- /dev/null +++ b/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs @@ -0,0 +1,118 @@ +{- + BNF Converter: C# Visit Skeleton Generator + + Copyright (C) 2006 Author: Johan Broberg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C# Visit Skeleton. + The generated file uses the Visitor design pattern. + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 30 November, 2006 + + Modified : 21 January, 2007 by Johan Broberg + + ************************************************************** +-} + +module CAbstoCSharpVisitSkeleton (cabs2csharpvisitskeleton) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import List +import OOAbstract hiding (basetypes) +import CSharpUtils +import CAbstoCSharpAbs + +--Produces .cs file +cabs2csharpvisitskeleton :: Namespace -> CAbs -> String +cabs2csharpvisitskeleton namespace cabs = unlines [ + "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/", + "/* This implements the common visitor design pattern. To make sure that", + " compile errors occur when code in the Visitor don't match the abstract", + " syntaxt, the \"abstract visit skeleton\" is used.", + " ", + " Replace the R and A parameters with the desired return", + " and context types.*/", + "", + "namespace " ++ namespace ++ ".VisitSkeleton", + "{", + " #region Classes", + unlinesInlineMap (prCon namespace) (signatures cabs), + " #endregion", + " ", + " #region Token types", + unlinesInlineMap (prBasic namespace) (tokentypes cabs), + " #endregion", + "}" + ] + +prBasic namespace c = unlinesInline [ + " public class " ++ c ++ "Visitor : Abstract" ++ c ++ "Visitor", + " {", + " public override R Visit(" ++ identifier namespace (typename c) +++ varname c ++ ", A arg)", + " {", + " /* Code for " ++ c ++ " Goes Here */", + " return default(R);", + " }", + " }" + ] + +prCon :: Namespace -> (Cat, [CAbsRule]) -> String +prCon namespace (c,fs) = unlinesInline [ + " public class " ++ c ++ "Visitor : Abstract" ++ c ++ "Visitor", + " {", + unlinesInlineMap (prVisit namespace) (map cabsrule2csharpabsrule fs), + " }" + ] + + +prVisit :: Namespace -> CSharpAbsRule -> String +prVisit namespace (f,cs) = unlinesInline [ + " public override R Visit(" ++ identifier namespace f +++ varname f ++ ", A arg)", + " {", + " /* Code For " ++ f ++ " Goes Here */", + unlinesInline $ map (prVisitArg namespace (varname f)) cs, + " return default(R);", + " }" + ] + +prVisitArg :: Namespace -> String -> (Cat, Bool, VariableName, PropertyName) -> String +prVisitArg namespace vname (cat, isPt, var, prop) + | cat `elem` (map fst basetypes) = " // " ++ vname ++ "." ++ prop + -- var /= "list_" is a dummy fix to make sure that a category named "List" doesn't get interpreted as a List. + -- this isn't very good though, and should be fixed somehow. + | "list" `isPrefixOf` var && var /= "list_" = listAccept + | otherwise = " " ++ vname ++ "." ++ prop ++ ".Accept(new " ++ cat ++ "Visitor(), arg);" + where + listtype = typename (drop 4 cat) + listAccept = unlinesInline [ + " foreach(" ++ identifier namespace listtype ++ " x in " ++ vname ++ "." ++ prop ++ ")", + " {", + if listtype `notElem` (map snd basetypes) + then " x.Accept(new " ++ listtype ++ "Visitor(), arg);" + else " // x", + " }" + ] diff --git a/formats/c-sharp/CFtoCSharpPrinter.hs b/formats/c-sharp/CFtoCSharpPrinter.hs new file mode 100644 --- /dev/null +++ b/formats/c-sharp/CFtoCSharpPrinter.hs @@ -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 ++ "_" diff --git a/formats/c-sharp/CFtoGPLEX.hs b/formats/c-sharp/CFtoGPLEX.hs new file mode 100644 --- /dev/null +++ b/formats/c-sharp/CFtoGPLEX.hs @@ -0,0 +1,221 @@ +{- + BNF Converter: C# GPLEX Generator + Copyright (C) 2006 Author: Johan Broberg + + Modified from CFtoFlex + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the GPLEX file. + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 23 November, 2006 + + Modified : 17 December, 2006 by Johan Broberg + + ************************************************************** +-} + +module CFtoGPLEX (cf2gplex) where + +import CF +import RegToGPLEX +import Utils((+++), (++++)) +import NamedVariables +import List +import CSharpUtils + +--The environment must be returned for the parser to use. +cf2gplex :: Namespace -> CF -> (String, SymEnv) +cf2gplex namespace cf = (unlines [ + prelude namespace, + cMacros, + prettyprinter $ (lexSymbols env) ++ (gplex namespace cf env'), + "%%" + ], env') + where + env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) + env' = env ++ (makeSymEnv (fst (unzip (tokenPragmas cf))) (length env)) + -- GPPG doesn't seem to like tokens beginning with an underscore, so they (the underscores, nothing else) have been removed. + makeSymEnv [] _ = [] + makeSymEnv (s:symbs) n = (s, "SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) + +prelude :: Namespace -> String +prelude namespace = unlines [ + "/* This GPLex file was machine-generated by the BNF converter */", + "", + "%namespace " ++ namespace, + "", + "%{", + " /// ", + " /// Buffer for escaped characters in strings.", + " /// ", + " private System.Text.StringBuilder strBuffer = new System.Text.StringBuilder();", + "", + " /// ", + " /// Change to enable output - useful for debugging purposes", + " /// ", + " public bool Trace = false;", + "", + " /// ", + " /// Culture-independent IFormatProvider for numbers. ", + " /// This is just a \"wrapper\" for System.Globalization.NumberFormatInfo.InvariantInfo.", + " /// ", + " /// ", + " /// This should be used when parsing numbers. Otherwise the parser might fail: ", + " /// culture en-US uses a dot as decimal separator, while for example sv-SE uses a comma. ", + " /// BNFC uses dot as decimal separator for Double values, so if your culture is sv-SE ", + " /// the parse will fail if this InvariantInfo isn't used.", + " /// ", + " private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;", + "", + " /// ", + " /// Convenience method to create scanner AND initialize it correctly.", + " /// As long as you don't want to enable trace output, this is all you ", + " /// need to call and give to the parser to be able to parse.", + " /// ", + " public static Scanner CreateScanner(Stream stream)", + " {", + " Scanner scanner = new Scanner(stream);", + " scanner.Begin();", + " return scanner;", + " }", + "", + " /// ", + " /// Sets the scanner to the correct initial state (YYINITIAL). ", + " /// You should call this method prior to calling parser.Parse().", + " /// ", + " public void Begin()", + " {", + " BEGIN(YYINITIAL);", + " }", + "", + " /// ", + " /// Convenience method to \"reset\" the buffer for escaped characters in strings.", + " /// ", + " private void BufferReset()", + " {", + " this.strBuffer = new System.Text.StringBuilder();", + " }", + "", + "%}", + "" + ] + +--For now all categories are included. +--Optimally only the ones that are used should be generated. +cMacros :: String +cMacros = unlines + [ + "alpha [a-zA-Z]", + "alphaCapital [A-Z]", + "alphaSmall [a-z]", + "digit [0-9]", + "ident [a-zA-Z0-9'_]", + -- start states, must be defined one at a time + "%s YYINITIAL", + "%s COMMENT", + "%s CHAR", + "%s CHARESC", + "%s CHAREND", + "%s STRING", + "%s ESCAPED", + "%%" + ] + +lexSymbols :: SymEnv -> [(String, String)] +lexSymbols ss = map transSym ss + where + transSym (s,r) = + ("\"" ++ s' ++ "\"" , "if(Trace) System.Console.Error.WriteLine(yytext); return (int)Tokens." ++ r ++ ";") + where + s' = escapeChars s + +gplex :: Namespace -> CF -> SymEnv -> [(String, String)] +gplex namespace cf env = concat [ + lexComments (comments cf), + userDefTokens, + ifC "String" strStates, + ifC "Char" charStates, + ifC "Double" [("{digit}+\".\"{digit}+(\"e\"(\\-)?{digit}+)?" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.double_ = Double.Parse(yytext, InvariantFormatInfo); return (int)Tokens.DOUBLE_;")], + ifC "Integer" [("{digit}+" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.int_ = Int32.Parse(yytext, InvariantFormatInfo); return (int)Tokens.INTEGER_;")], + ifC "Ident" [("{alpha}{ident}*" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.string_ = yytext; return (int)Tokens.IDENT_;")], + [("[ \\t\\r\\n\\f]" , "/* ignore white space. */;")], + [("." , "return (int)Tokens.error;")] + ] + where + ifC cat s = if isUsedCat cf cat then s else [] + userDefTokens = map tokenline (tokenPragmas cf) + where + tokenline (name, exp) = ("" ++ printRegGPLEX exp , action name) + action n = "if(Trace) System.Console.Error.WriteLine(yytext); yylval." ++ varName (normCat n) ++ " = new " ++ identifier namespace n ++ "(yytext); return (int)Tokens." ++ sName n ++ ";" + sName n = case lookup n env of + Just x -> x + Nothing -> n + -- These handle escaped characters in Strings. + strStates = [ + ("\"\\\"\"" , "BEGIN(STRING);"), + ("\\\\" , "BEGIN(ESCAPED);"), + ("\\\"" , "yylval.string_ = this.strBuffer.ToString(); BufferReset(); BEGIN(YYINITIAL); return (int)Tokens.STRING_;"), + ("." , "this.strBuffer.Append(yytext);"), + ("n" , "this.strBuffer.Append(\"\\n\"); BEGIN(STRING);"), + ("\\\"" , "this.strBuffer.Append(\"\\\"\"); BEGIN(STRING);"), + ("\\\\" , "this.strBuffer.Append(\"\\\\\"); BEGIN(STRING);"), + ("t" , "this.strBuffer.Append(\"\\t\"); BEGIN(STRING);"), + ("." , "this.strBuffer.Append(yytext); BEGIN(STRING);") + ] + -- These handle escaped characters in Chars. + charStates = [ + ("\"'\"" , "BEGIN(CHAR);"), + ("\\\\" , "BEGIN(CHARESC);"), + ("[^']" , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"), + ("n" , "BEGIN(CHAREND); yylval.char_ = '\\n'; return (int)Tokens.CHAR_;"), + ("t" , "BEGIN(CHAREND); yylval.char_ = '\\t'; return (int)Tokens.CHAR_;"), + ("." , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"), + ("\"'\"" , "BEGIN(YYINITIAL);") + ] + +lexComments :: ([(String, String)], [String]) -> [(String, String)] +lexComments (m,s) = (map lexSingleComment s) ++ (concatMap lexMultiComment m) + +lexSingleComment :: String -> (String, String) +lexSingleComment c = + ("\"" ++ c ++ "\"[^\\n]*\\n" , "/* BNFC single-line comment */;") + +--There might be a possible bug here if a language includes 2 multi-line comments. +--They could possibly start a comment with one character and end it with another. +--However this seems rare. +lexMultiComment :: (String, String) -> [(String, String)] +lexMultiComment (b,e) = [ + ("\"" ++ b ++ "\"" , "BEGIN(COMMENT);"), + ("\"" ++ e ++ "\"" , "BEGIN(YYINITIAL);"), + ("." , "/* BNFC multi-line comment */;"), + ("[\\n]" , "/* BNFC multi-line comment */;") + ] + +-- Used to print the lexer rules; makes sure that all rules are equally indented, to make the GPLEX file a little more readable. +prettyprinter :: [(String, String)] -> String +prettyprinter xs = unlines $ map prettyprinter' xs + where + padlength = 1 + (last $ sort $ map length $ map fst xs) + prettyprinter' (x, y) = x ++ replicate (padlength - length x) ' ' ++ y diff --git a/formats/c-sharp/CFtoGPPG.hs b/formats/c-sharp/CFtoGPPG.hs new file mode 100644 --- /dev/null +++ b/formats/c-sharp/CFtoGPPG.hs @@ -0,0 +1,275 @@ +{- + BNF Converter: C# GPPG Generator + Copyright (C) 2006 Author: Johan Broberg + + Modified from CFtoBisonSTL. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the GPPG input file. + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 24 November, 2006 + + Modified : 17 December, 2006 by Johan Broberg + + ************************************************************** +-} + +module CFtoGPPG (cf2gppg) where + +import CF +import 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_", + ifC "Char" "%token CHAR_", + ifC "Integer" "%token INTEGER_", + ifC "Double" "%token DOUBLE_", + ifC "Ident" "%token IDENT_" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + +--The following functions are a (relatively) straightforward translation +--of the ones in CFtoHappy.hs +rulesForGPPG :: Namespace -> CF -> SymEnv -> Rules +rulesForGPPG namespace cf env = (map mkOne $ ruleGroups cf) ++ posRules where + mkOne (cat,rules) = constructRule namespace cf env rules cat + posRules = map mkPos $ positionCats cf + mkPos cat = (cat, [(maybe cat id (lookup cat env), + "$$ = new " ++ cat ++ "($1);")]) + +-- For every non-terminal, we construct a set of rules. +constructRule :: Namespace -> + CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule namespace cf env rules nt = + (nt,[(p,(generateAction namespace nt (ruleName r) b m) +++ result) | + r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True,revSepListRule r0) + else (False,r0), + let (p,m) = generatePatterns cf env r b]) + where + ruleName r = case funRule r of + ---- "(:)" -> identCat nt + ---- "(:[])" -> identCat nt + z -> z + revs = reversibleCats cf + eps = allEntryPoints cf + isEntry nt = if elem nt eps then True else False + result = if isEntry nt then (resultName (normCat (identCat nt))) ++ "= $$;" else "" + +-- Generates a string containing the semantic action. +-- This was copied from CFtoCup15, with only a few small modifications +generateAction :: Namespace -> NonTerminal -> Fun -> Bool -> [(MetaVar, Bool)] + -> Action +generateAction namespace nt f rev mbs + | isNilFun f = "$$ = new " ++ identifier namespace c ++ "();" + | isOneFun f = "$$ = new " ++ identifier namespace c ++ "(); $$.Add(" ++ p_1 ++ ");" + | isConsFun f && not rev = "$$ = " ++ p_2 ++ "; " ++ p_2 ++ ".Insert(0, " ++ p_1 ++ ");" + | isConsFun f && rev = "$$ = " ++ p_1 ++ "; " ++ p_1 ++ ".Add(" ++ p_2 ++ ");" + | isCoercion f = "$$ = " ++ p_1 ++ ";" + | isDefinedRule f = "$$ = " ++ f ++ "_" ++ "(" ++ concat (intersperse "," ms) ++ ");" + | otherwise = "$$ = new " ++ identifier namespace c ++ "(" ++ concat (intersperse "," ms) ++ ");" + where + c = if isNilFun f || isOneFun f || isConsFun f + then identCat (normCat nt) else f + ms = map fst mbs + p_1 = ms!!0 + p_2 = ms!!1 + + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal +generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)]) +generatePatterns cf env r revv = case rhsRule r of + [] -> ("/* empty */",[]) + its -> (unwords (map mkIt its), metas its) + where + mkIt i = case i of + Left c -> case lookup c env of + -- This used to be x, but that didn't work if we had a symbol "String" in env, and tried to use a normal String - it would use the symbol... + Just x | not (isPositionCat cf c) && c `notElem` (map fst basetypes) -> x + _ -> typeName (identCat c) + Right s -> case lookup s env of + Just x -> x + Nothing -> s + metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its] + + -- notice: reversibility with push_back vectors is the opposite + -- of right-recursive lists! + revert c = (head c == '[') && + not (isConsFun (funRule r)) && notElem c revs + revs = reversibleCats cf + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. + +prRules :: Rules -> String +prRules [] = [] +prRules ((nt, []):rs) = prRules rs --internal rule +prRules ((nt,((p,a):ls)):rs) = + (unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ ", a , "}"])]) ++ pr ls + +--Some helper functions. +resultName :: String -> String +resultName s = "YY_RESULT_" ++ s ++ "_" + +--slightly stronger than the NamedVariable version. +varName :: String -> String +varName s = (map toLower (identCat s)) ++ "_" + +typeName :: String -> String +typeName "Ident" = "IDENT_" +typeName "String" = "STRING_" +typeName "Char" = "CHAR_" +typeName "Integer" = "INTEGER_" +typeName "Double" = "DOUBLE_" +typeName x = x diff --git a/formats/c-sharp/CSharpTop.hs b/formats/c-sharp/CSharpTop.hs new file mode 100644 --- /dev/null +++ b/formats/c-sharp/CSharpTop.hs @@ -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 [ + "", + "", + " ", + " Debug", + " AnyCPU", + " 8.0.50727", + " 2.0", + " " ++ guid ++ "", + " Library", + " Properties", + " " ++ namespace ++ "", + " " ++ namespace ++ "", + " ", + " ", + " ", + " ", + " true", + " full", + " false", + " bin\\Debug\\", + " DEBUG;TRACE", + " prompt", + " 4", + " ", + " ", + " pdbonly", + " true", + " bin\\Release\\", + " TRACE", + " prompt", + " 4", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " False", + " bin\\ShiftReduceParser.dll", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + "" + ] + +csharptest :: Namespace -> CF -> String +csharptest namespace cf = unlines [ + "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/", + "/* */", + "/* This test will parse a file, print the abstract syntax tree, and then */", + "/* pretty-print the result. */", + "/* */", + "/****************************************************************************/", + "using System;", + "using System.IO;", + "using " ++ namespace ++ ".Absyn;", + "", + "namespace " ++ namespace, + "{", + " public class Test", + " {", + " public static void Main(string[] args)", + " {", + " if (args.Length > 0)", + " {", + " Stream stream = File.OpenRead(args[0]);", + " /* The default entry point is used. For other options see class Parser */", + " Parser parser = new Parser();", + " Scanner scanner = Scanner.CreateScanner(stream);", + " // Uncomment to enable trace information:", + " // parser.Trace shows what the parser is doing", + " // parser.Trace = true;", + " // scanner.Trace prints the tokens as they are parsed, one token per line", + " // scanner.Trace = true;", + " parser.scanner = scanner;", + " try", + " {", + " " ++ def ++ " parse_tree = parser.Parse" ++ def ++ "();", + " if (parse_tree != null)", + " {", + " Console.Out.WriteLine(\"Parse Successful!\");", + " Console.Out.WriteLine(\"\");", + " Console.Out.WriteLine(\"[Abstract Syntax]\");", + " Console.Out.WriteLine(\"{0}\", PrettyPrinter.Show(parse_tree));", + " Console.Out.WriteLine(\"\");", + " Console.Out.WriteLine(\"[Linearized Tree]\");", + " Console.Out.WriteLine(\"{0}\", PrettyPrinter.Print(parse_tree));", + " }", + " else", + " {", + " Console.Out.WriteLine(\"Parse NOT Successful!\");", + " }", + " }", + " catch(Exception e)", + " {", + " Console.Out.WriteLine(\"Parse NOT Successful:\");", + " Console.Out.WriteLine(e.Message);", + " Console.Out.WriteLine(\"\");", + " Console.Out.WriteLine(\"Stack Trace:\");", + " Console.Out.WriteLine(e.StackTrace);", + " }", + " }", + " else", + " {", + " Console.Out.WriteLine(\"You must specify a filename!\");", + " }", + " }", + " }", + "}" + ] + where + def = head (allEntryPoints cf) + +filepathtonamespace :: FilePath -> Namespace +filepathtonamespace file = take (length file - 3) (basename file) + +projectguid :: IO String +projectguid = do + maybeFilePath <- findDirectory + guid <- maybe getBadGUID getGoodGUID maybeFilePath + return guid + where + getBadGUID :: IO String + getBadGUID = do + putStrLn "-----------------------------------------------------------------------------" + putStrLn "Could not find Visual Studio tool uuidgen.exe to generate project GUID!" + putStrLn "You might want to put this tool in your PATH." + putStrLn "-----------------------------------------------------------------------------" + return "{00000000-0000-0000-0000-000000000000}" + getGoodGUID :: FilePath -> IO String + getGoodGUID filepath = do + let filepath' = "\"" ++ filepath ++ "\"" + (hIn, hOut, hErr, processHandle) <- runInteractiveCommand filepath' + guid <- hGetLine hOut + return ('{' : init guid ++ "}") + findDirectory :: IO (Maybe FilePath) + findDirectory = do + -- This works with Visual Studio 2005. + -- We will probably have to be modify this to include another environment variable name for Orcas. + -- I doubt there is any need to support VS2003? (I doubt they have patched it up to have 2.0 support?) + toolpath <- catch (getEnv "VS80COMNTOOLS") (\_ -> return "C:\\Program Files\\Microsoft Visual Studio 8\\Common7\\Tools") + exists <- doesDirectoryExist toolpath + if exists + then return (Just (toolpath ++ "\\uuidgen.exe")) + -- this handles the case when the user was clever enough to add the directory to his/her PATH + else findExecutable "uuidgen.exe" diff --git a/formats/c-sharp/CSharpUtils.hs b/formats/c-sharp/CSharpUtils.hs new file mode 100644 --- /dev/null +++ b/formats/c-sharp/CSharpUtils.hs @@ -0,0 +1,154 @@ +{- + BNF Converter: Utility Functions for C# + Copyright (C) 2006 Author: Johan Broberg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module provides utility functions for the + C# format. + + Author : Johan Broberg (johan@pontemonti.com) + + License : GPL (GNU General Public License) + + Created : 23 November, 2006 + + Modified : 21 January, 2007 by Johan Broberg + + ************************************************************** +-} + +module CSharpUtils where + +import CF +import Control.Monad.ST +-- Control.Monad.State +import 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)) + diff --git a/formats/c-sharp/RegToGPLEX.hs b/formats/c-sharp/RegToGPLEX.hs new file mode 100644 --- /dev/null +++ b/formats/c-sharp/RegToGPLEX.hs @@ -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 prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["[^.]"]) + RChar c -> prPrec i 3 (prt 0 [mkEsc [c]]) + RAlts str -> prPrec i 3 (concat [["["], prt 0 $ mkEsc str, ["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) $ mkEsc str)) + RDigit -> prPrec i 3 (concat [["{digit}"]]) + RLetter -> prPrec i 3 (concat [["{alpha}"]]) + RUpper -> prPrec i 3 (concat [["{alphaCapital}"]]) + RLower -> prPrec i 3 (concat [["{alphaSmall}"]]) + RAny -> prPrec i 3 (concat [["."]]) + +-- Handle special characters in regular expressions. +mkEsc :: String -> String +mkEsc = concatMap escChar + where escChar c + | c `elem` "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" = '\\':[c] + | otherwise = [c] diff --git a/formats/c/CFtoBisonC.hs b/formats/c/CFtoBisonC.hs new file mode 100644 --- /dev/null +++ b/formats/c/CFtoBisonC.hs @@ -0,0 +1,275 @@ +{- + BNF Converter: C Bison generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Bison input file. + Note that because of the way bison stores results + the programmer can increase performance by limiting + the number of entry points in their grammar. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 6 August, 2003 + + Modified : 6 August, 2003 + + + ************************************************************** +-} + + +module CFtoBisonC (cf2Bison) where + +import CF +import 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 ", + "#include ", + "#include ", + "#include \"Absyn.h\"", + "#define initialize_lexer " ++ name ++ "_initialize_lexer", + "extern int yyparse(void);", + "extern int yylex(void);", + "extern int initialize_lexer(FILE * inp);", + "void yyerror(const char *str)", + "{", + " fprintf(stderr,\"error: %s\\n\",str);", + "}", + "", + -- M.F. 2004-09-17 changed allEntryPoints to allCatsIdNorm. Seems to fix the [Ty2] bug. + unlines $ map (parseMethod name) (allCatsIdNorm cf), -- (allEntryPoints cf), + concatMap reverseList (filter isList (allCats cf)), + "%}" + ] + +--This generates a parser method for each entry point. +parseMethod :: String -> Cat -> String +parseMethod name cat = +-- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm +-- then "" +-- else + unlines + [ + cat' +++ (resultName cat') +++ "= 0;", + cat' ++ " p" ++ cat' ++ "(FILE *inp)", + "{", + " initialize_lexer(inp);", + " if (yyparse())", + " { /* Failure */", + " return 0;", + " }", + " else", + " { /* Success */", + " return" +++ (resultName cat') ++ ";", + " }", + "}" + ] + where + cat' = identCat (normCat cat) + +--This method generates list reversal functions for each list type. +reverseList :: Cat -> String +reverseList c = unlines + [ + c' ++ " reverse" ++ c' ++ "(" ++ c' +++ "l)", + "{", + " " ++ c' +++"prev = 0;", + " " ++ c' +++"tmp = 0;", + " while (l)", + " {", + " tmp = l->" ++ v ++ ";", + " l->" ++ v +++ "= prev;", + " prev = l;", + " l = tmp;", + " }", + " return prev;", + "}" + ] + where + c' = identCat (normCat c) + v = (map toLower c') ++ "_" + +--The union declaration is special to Bison/Yacc and gives the type of yylval. +--For efficiency, we may want to only include used categories here. +union :: [Cat] -> String +union cats = unlines + [ + "%union", + "{", + " int int_;", + " char char_;", + " double double_;", + " char* string_;", + concatMap mkPointer cats, + "}" + ] + where --This is a little weird because people can make [Exp2] etc. + mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion. + " " ++ (identCat (normCat s)) +++ (varName (normCat s)) ++ ";\n" + mkPointer s | normCat s == s = --normal cat + " " ++ (identCat (normCat s)) +++ (varName (normCat s)) ++ ";\n" + mkPointer s = "" + +--declares non-terminal types. +declarations :: CF -> String +declarations cf = concatMap (typeNT cf) (allCats cf) + where --don't define internal rules + typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n" + typeNT cf nt = "" + +--declares terminal types. +tokens :: [UserDef] -> SymEnv -> String +tokens user ts = concatMap (declTok user) ts + where + declTok u (s,r) = if elem s u + then "%token " ++ r ++ " /* " ++ s ++ " */\n" + else "%token " ++ r ++ " /* " ++ s ++ " */\n" + +specialToks :: CF -> String +specialToks cf = concat [ + ifC "String" "%token _STRING_\n", + ifC "Char" "%token _CHAR_\n", + ifC "Integer" "%token _INTEGER_\n", + ifC "Double" "%token _DOUBLE_\n", + ifC "Ident" "%token _IDENT_\n" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + +--The following functions are a (relatively) straightforward translation +--of the ones in CFtoHappy.hs +rulesForBison :: String -> CF -> SymEnv -> Rules +rulesForBison name cf env = map mkOne $ ruleGroups cf where + mkOne (cat,rules) = constructRule cf env rules cat + +-- For every non-terminal, we construct a set of rules. +constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule cf env rules nt = (nt,[(p,(generateAction (normCat (identCat nt)) (ruleName r) b m) +++ result) | + r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True,revSepListRule r0) + else (False,r0), + let (p,m) = generatePatterns cf env r]) + where + ruleName r = case funRule r of + "(:)" -> identCat nt + z -> z + revs = reversibleCats cf + eps = allEntryPoints cf + isEntry nt = if elem nt eps then True else False + result = if isEntry nt then (resultName (normCat (identCat nt))) ++ "= $$;" else "" + +-- Generates a string containing the semantic action. +generateAction :: NonTerminal -> Fun -> Bool -> [MetaVar] -> Action +generateAction nt f b ms = + if isCoercion f + then (unwords ms) ++ ";" + else if isNilFun f + then "0;" + else if isOneFun f + then concat ["make_", nt, "(", (concat (intersperse ", " ms')), ", 0);"] + else concat ["make_", normCat f, "(", (concat (intersperse ", " ms')), ");"] + where + ms' = if b then reverse ms else ms + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal +generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar]) +generatePatterns cf env r = case rhsRule r of + [] -> ("/* empty */",[]) + its -> (unwords (map mkIt its), metas its) + where + mkIt i = case i of + Left c -> case lookup c env of + Just x -> x + Nothing -> typeName (identCat c) + Right s -> case lookup s env of + Just x -> x + Nothing -> s + metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its] + revIf c m = if (not (isConsFun (funRule r)) && elem c revs) + then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")") + else m -- no reversal in the left-recursive Cons rule itself + revs = reversibleCats cf + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. + +prRules :: Rules -> String +prRules [] = [] +prRules ((nt, []):rs) = prRules rs --internal rule +prRules ((nt,((p,a):ls)):rs) = + (unwords [nt', ":" , p, "{ $$ =", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ $$ =", a , "}"])]) ++ pr ls + +--Some helper functions. +resultName :: String -> String +resultName s = "YY_RESULT_" ++ s ++ "_" + +--slightly stronger than the NamedVariable version. +varName :: String -> String +varName s = (map toLower (identCat s)) ++ "_" + +typeName :: String -> String +typeName "Ident" = "_IDENT_" +typeName "String" = "_STRING_" +typeName "Char" = "_CHAR_" +typeName "Integer" = "_INTEGER_" +typeName "Double" = "_DOUBLE_" +typeName x = x diff --git a/formats/c/CFtoCAbs.hs b/formats/c/CFtoCAbs.hs new file mode 100644 --- /dev/null +++ b/formats/c/CFtoCAbs.hs @@ -0,0 +1,329 @@ +{- + BNF Converter: C Abstract syntax + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C Abstract Syntax + tree classes. It generates both a Header file + and an Implementation file, and Appel's C + method. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 15 September, 2003 + + Modified : 15 September, 2003 + + + ************************************************************** +-} + +module CFtoCAbs (cf2CAbs) where + +import CF +import Utils((+++),(++++)) +import NamedVariables +import 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 ", + "#include ", + "#include \"Absyn.h\"", + "" + ] + +--This is not represented in the implementation. +--This is not represented in the implementation. +prDataC :: [UserDef] -> Data -> String +prDataC user (cat, rules) = concatMap (prRuleC user cat) rules + +--Classes for rules vary based on the type of rule. +prRuleC user c (fun, cats) = + if isNilFun fun || isOneFun fun + then "" --these are not represented in the AbSyn + else if isConsFun fun + then --this is the linked list case. + unlines + [ + "/******************** " ++ c' ++ " ********************/", + prListFuncs user c', + "" + ] + else --a standard rule + unlines + [ + "/******************** " ++ fun' ++ " ********************/", + prConstructorC user c fun' vs cats, + "" + ] + where + vs = getVars cats + fun' = identCat (normCat fun) + c' = identCat (normCat c) + +--These are all built-in list functions. +--Later we could include things like lookup,insert,delete,etc. +prListFuncs :: [UserDef] -> String -> String +prListFuncs user c = unlines + [ + c ++ " make_" ++ c ++"(" ++ m ++ " p1" ++ ", " ++ c ++ " p2)", + "{", + " " ++ c ++ " tmp = (" ++ c ++ ") malloc(sizeof(*tmp));", + " if (!tmp)", + " {", + " fprintf(stderr, \"Error: out of memory when allocating " ++ c ++ "!\\n\");", + " exit(1);", + " }", + " tmp->" ++ m' ++ " = " ++ "p1;", + " tmp->" ++ v ++ " = " ++ "p2;", + " return tmp;", + "}" + ] + where + v = (map toLower c) ++ "_" + m = drop 4 c + m' = drop 4 v + +--The constructor just assigns the parameters to the corresponding instance variables. +prConstructorC :: [UserDef] -> String -> String -> [IVar] -> [Cat] -> String +prConstructorC user cat c vs cats = + unlines + [ + cat' ++ " make_" ++ c ++"(" ++ (interleave types params) ++ ")", + "{", + " " ++ cat' ++ " tmp = (" ++ cat' ++ ") malloc(sizeof(*tmp));", + " if (!tmp)", + " {", + " fprintf(stderr, \"Error: out of memory when allocating " ++ c ++ "!\\n\");", + " exit(1);", + " }", + " tmp->kind = is_" ++ c ++ ";", + prAssigns c vs params, + " return tmp;", + "}" + ] + where + cat' = identCat (normCat cat) + (types, params) = unzip (prParams cats (length cats) ((length cats)+1)) + interleave _ [] = [] + interleave (x:[]) (y:[]) = x +++ y + interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys) + +--Prints the constructor's parameters. +prParams :: [Cat] -> Int -> Int -> [(String,String)] +prParams [] _ _ = [] +prParams (c:cs) n m = (identCat c,"p" ++ (show (m-n))) + : (prParams cs (n-1) m) + +--Prints the assignments of parameters to instance variables. +--This algorithm peeks ahead in the list so we don't use map or fold +prAssigns :: String -> [IVar] -> [String] -> String +prAssigns _ [] _ = [] +prAssigns _ _ [] = [] +prAssigns c ((t,n):vs) (p:ps) = + if n == 1 then + case findIndices (\x -> case x of (l,r) -> l == t) vs of + [] -> " tmp->u." ++ c' ++ "_." ++ (varName t) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps) + z -> " tmp->u." ++ c' ++ "_." ++ ((varName t) ++ (showNum n)) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps) + else " tmp->u." ++ c' ++ "_." ++ ((varName t) ++ (showNum n)) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps) + where + c' = map toLower c + +{- **** Helper Functions **** -} + +--Checks if something is a basic or user-defined type. +isBasic :: [UserDef] -> String -> Bool +isBasic user x = + if elem x user + then True + else case x of + "Integer" -> True + "Char" -> True + "String" -> True + "Double" -> True + "Ident" -> True + _ -> False + +memName s = (map toLower s) ++ "_" diff --git a/formats/c/CFtoCPrinter.hs b/formats/c/CFtoCPrinter.hs new file mode 100644 --- /dev/null +++ b/formats/c/CFtoCPrinter.hs @@ -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 ", + "#include ", + "#include ", + "", + "int _n_;", + "char* buf_;", + "int cur_;", + "int buf_size;", + "" + ] + printBasics = unlines + [ + "void ppInteger(Integer n, int i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%d\", n);", + " bufAppendS(tmp);", + "}", + "void ppDouble(Double d, int i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%g\", d);", + " bufAppendS(tmp);", + "}", + "void ppChar(Char c, int i)", + "{", + " bufAppendC('\\'');", + " bufAppendC(c);", + " bufAppendC('\\'');", + "}", + "void ppString(String s, int i)", + "{", + " bufAppendC('\\\"');", + " bufAppendS(s);", + " bufAppendC('\\\"');", + "}", + "void ppIdent(String s, int i)", + "{", + " renderS(s);", + "}", + "" + ] + showBasics = unlines + [ + "void shInteger(Integer i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%d\", i);", + " bufAppendS(tmp);", + "}", + "void shDouble(Double d)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%g\", d);", + " bufAppendS(tmp);", + "}", + "void shChar(Char c)", + "{", + " bufAppendC('\\'');", + " bufAppendC(c);", + " bufAppendC('\\'');", + "}", + "void shString(String s)", + "{", + " bufAppendC('\\\"');", + " bufAppendS(s);", + " bufAppendC('\\\"');", + "}", + "void shIdent(String s)", + "{", + " bufAppendC('\\\"');", + " bufAppendS(s);", + " bufAppendC('\\\"');", + "}", + "" + ] + footer = unlines + [ + "void bufAppendS(const char* s)", + "{", + " int len = strlen(s);", + " int n;", + " while (cur_ + len > buf_size)", + " {", + " buf_size *= 2; /* Double the buffer size */", + " resizeBuffer();", + " }", + " for(n = 0; n < len; n++)", + " {", + " buf_[cur_ + n] = s[n];", + " }", + " cur_ += len;", + " buf_[cur_] = 0;", + "}", + "void bufAppendC(const char c)", + "{", + " if (cur_ == buf_size)", + " {", + " buf_size *= 2; /* Double the buffer size */", + " resizeBuffer();", + " }", + " buf_[cur_] = c;", + " cur_++;", + " buf_[cur_] = 0;", + "}", + "void bufReset(void)", + "{", + " cur_ = 0;", + " buf_size = BUFFER_INITIAL;", + " resizeBuffer();", + " memset(buf_, 0, buf_size);", + "}", + "void resizeBuffer(void)", + "{", + " char* temp = (char*) malloc(buf_size);", + " if (!temp)", + " {", + " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");", + " exit(1);", + " }", + " if (buf_)", + " {", + " strncpy(temp, buf_, buf_size); /* peteg: strlcpy is safer, but not POSIX/ISO C. */", + " free(buf_);", + " }", + " buf_ = temp;", + "}", + "char *buf_;", + "int cur_, buf_size;", + "" + ] + + +{- **** Pretty Printer Methods **** -} + +--An entry point to begin printing +prPrintFun :: Cat -> String +prPrintFun ep | normCat ep == ep = unlines + [ + "char* print" ++ ep' ++ "(" ++ ep' ++ " p)", + "{", + " _n_ = 0;", + " bufReset();", + " pp" ++ ep' ++ "(p, 0);", + " return buf_;", + "}" + ] + where + ep' = identCat ep +prPrintFun _ = "" + +--Generates methods for the Pretty Printer +prPrintData :: [UserDef] -> (Cat, [Rule]) -> String +prPrintData user (cat, rules) = + if isList cat + then unlines + [ + "void pp" ++ cl ++ "("++ cl +++ vname ++ ", int i)", + "{", + " while(" ++ vname ++ "!= 0)", + " {", + " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)", + " {", + visitMember, + optsep, + " " ++ vname +++ "= 0;", + " }", + " else", + " {", + visitMember, + " render" ++ sc ++ "(" ++ sep ++ ");", + " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", + " }", + " }", + "}", + "" + ] --Not a list: + else unlines + [ + "void pp" ++ cl ++ "(" ++ cl ++ " _p_, int _i_)", + "{", + " switch(_p_->kind)", + " {", + concatMap (prPrintRule user) rules, + " default:", + " fprintf(stderr, \"Error: bad kind field when printing " ++ cat ++ "!\\n\");", + " exit(1);", + " }", + "}\n" + ] + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl + visitMember = " pp" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_, 0);" + (sc, sep) = if length sep' == 1 + then ("C", "'" ++ escapeChars sep' ++ "'") + else ("S", "\"" ++ escapeChars sep' ++ "\"") + sep' = getCons rules + optsep = if hasOneFunc rules then "" else (" render" ++ sc ++ "(" ++ sep ++ ");") + +--Pretty Printer methods for a rule. +prPrintRule :: [UserDef] -> Rule -> String +prPrintRule user r@(fun, (c, cats)) | not (isCoercion fun) = unlines + [ + " case is_" ++ fun ++ ":", + lparen, + cats', + rparen, + " break;\n" + ] + where + p = precRule r + (lparen, rparen) = + (" if (_i_ > " ++ (show p) ++ ") renderC(_L_PAREN);", + " if (_i_ > " ++ (show p) ++ ") renderC(_R_PAREN);") + cats' = (concatMap (prPrintCat user fun) (zip3 (fixOnes (numVars [] cats)) cats (map getPrec cats))) + getPrec (Right s) = (0 :: Int) + getPrec (Left c) = precCat c +prPrintRule _ (fun, cats) = "" + +--This goes on to recurse to the instance variables. +prPrintCat :: [UserDef] -> String -> (Either Cat String, Either Cat String, Int) -> String +prPrintCat user fnm (c,o,p) = case c of + (Right t) -> " render" ++ sc ++ "(" ++ t' ++ ");\n" + where + (sc,t') = if length t == 1 + then ("C", "'" ++ (escapeChars t) ++ "'") + else ("S", "\"" ++ (escapeChars t) ++ "\"") + (Left nt) -> if isBasic user nt + then " pp" ++ (basicFunName nt) ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ", " ++ (show p) ++ ");\n" + else if nt == "#_" --Internal category + then " /* Internal Category */\n" + else " pp" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ", " ++ (show p) ++ ");\n" + where + v = map toLower (identCat (normCat fnm)) + o' = case o of + Right x -> x + Left x -> normCat (identCat x) + +{- **** Abstract Syntax Tree Printer **** -} + +--An entry point to begin printing +prShowFun :: Cat -> String +prShowFun ep | normCat ep == ep = unlines + [ + "char* show" ++ ep' ++ "(" ++ ep' ++ " p)", + "{", + " _n_ = 0;", + " bufReset();", + " sh" ++ ep' ++ "(p);", + " return buf_;", + "}" + ] + where + ep' = identCat ep +prShowFun _ = "" + +--This prints the functions for Abstract Syntax tree printing. +prShowData :: [UserDef] -> (Cat, [Rule]) -> String +prShowData user (cat, rules) = + if isList cat + then unlines + [ + "void sh" ++ cl ++ "("++ cl +++ vname ++ ")", + "{", + " while(" ++ vname ++ "!= 0)", + " {", + " if (" ++ vname ++ "->" ++ vname ++ "_)", + " {", + visitMember, + " bufAppendS(\", \");", + " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", + " }", + " else", + " {", + visitMember, + " " ++ vname ++ " = 0;", + " }", + " }", + "}", + "" + ] --Not a list: + else unlines + [ + "void sh" ++ cl ++ "(" ++ cl ++ " _p_)", + "{", + " switch(_p_->kind)", + " {", + concatMap (prShowRule user) rules, + " default:", + " fprintf(stderr, \"Error: bad kind field when showing " ++ cat ++ "!\\n\");", + " exit(1);", + " }", + "}\n" + ] + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl + visitMember = " sh" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);" + +--Pretty Printer methods for a rule. +prShowRule :: [UserDef] -> Rule -> String +prShowRule user r@(fun, (c, cats)) | not (isCoercion fun) = unlines + [ + " case is_" ++ fun ++ ":", + lparen, + " bufAppendS(\"" ++ fun ++ "\");\n", + optspace, + cats', + rparen, + " break;\n" + ] + where + (optspace, lparen, rparen) = if allTerms cats + then ("","","") + else (" bufAppendC(' ');\n", " bufAppendC('(');\n"," bufAppendC(')');\n") + cats' = if allTerms cats + then "" + else concat (insertSpaces (map (prShowCat user fun) (zip (fixOnes (numVars [] cats)) cats))) + insertSpaces [] = [] + insertSpaces (x:[]) = [x] + insertSpaces (x:xs) = if x == "" + then insertSpaces xs + else (x : [" bufAppendC(' ');\n"]) ++ (insertSpaces xs) + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs +prShowRule _ (fun, cats) = "" + +--This goes on to recurse to the instance variables. +prShowCat :: [UserDef] -> String -> (Either Cat String, Either Cat String) -> String +prShowCat user fnm (c,o) = case c of + (Right t) -> "" + (Left nt) -> if isBasic user nt + then " sh" ++ (basicFunName nt) ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n" + else if nt == "#_" --Internal category + then " /* Internal Category */\n" + else if ((normCat nt) /= nt) + then " sh" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n" + else concat + [ + " bufAppendC('[');\n", + " sh" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n", + " bufAppendC(']');\n" + ] + where + v = map toLower (identCat (normCat fnm)) + o' = case o of + Right x -> x + Left x -> normCat (identCat x) + +{- **** Helper Functions Section **** -} + + +--Just checks if something is a basic or user-defined type. +--This is because you don't -> a basic non-pointer type. +isBasic :: [UserDef] -> String -> Bool +isBasic user v = + if elem (init v) user' + then True + else if "integer_" `isPrefixOf` v then True + else if "char_" `isPrefixOf` v then True + else if "string_" `isPrefixOf` v then True + else if "double_" `isPrefixOf` v then True + else if "ident_" `isPrefixOf` v then True + else False + where + user' = map (map toLower) user + +--The visit-function name of a basic type +basicFunName :: String -> String +basicFunName v = + if "integer_" `isPrefixOf` v then "Integer" + else if "char_" `isPrefixOf` v then "Char" + else if "string_" `isPrefixOf` v then "String" + else if "double_" `isPrefixOf` v then "Double" + else if "ident_" `isPrefixOf` v then "Ident" + else "Ident" --User-defined type + +--Just sets the coercion level for parentheses in the Pretty Printer. +setI :: Int -> String +setI n = "_i_ = " ++ (show n) ++ "; " + +--Gets the separator for a list. +getCons :: [Rule] -> String +getCons [] = error $ "FIXME: CFtoCPrinter/getCons: No separator for a list." +getCons ((f, (c, cats)):rs) = + if isConsFun f + then seper cats + else getCons rs + where + seper [] = [] + seper ((Right x):xs) = x + seper ((Left x):xs) = seper xs + +--Checks if the list has a non-empty rule. +hasOneFunc :: [Rule] -> Bool +hasOneFunc [] = False +hasOneFunc ((f, (c, cats)):rs) = + if (isOneFun f) + then True + else hasOneFunc rs + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) + +--An extremely simple renderCer for terminals. +prRender :: String +prRender = unlines + [ + "/* You may wish to change the renderC functions */", + "void renderC(Char c)", + "{", + " if (c == '{')", + " {", + " bufAppendC('\\n');", + " indent();", + " bufAppendC(c);", + " _n_ = _n_ + 2;", + " bufAppendC('\\n');", + " indent();", + " }", + " else if (c == '(' || c == '[')", + " bufAppendC(c);", + " else if (c == ')' || c == ']')", + " {", + " backup();", + " bufAppendC(c);", + " bufAppendC(' ');", + " }", + " else if (c == '}')", + " {", + " _n_ = _n_ - 2;", + " backup();", + " backup();", + " bufAppendC(c);", + " bufAppendC('\\n\');", + " indent();", + " }", + " else if (c == ',')", + " {", + " backup();", + " bufAppendC(c);", + " bufAppendC(' ');", + " }", + " else if (c == ';')", + " {", + " backup();", + " bufAppendC(c);", + " bufAppendC('\\n');", + " indent();", + " }", + " else if (c == 0) return;", + " else", + " {", + " bufAppendC(c);", + " bufAppendC(' ');", + " }", + "}", + "void renderS(String s)", + "{", + " if(strlen(s) > 0)", + " {", + " bufAppendS(s);", + " bufAppendC(' ');", + " }", + "}", + "void indent(void)", + "{", + " int n = _n_;", + " while (n > 0)", + " {", + " bufAppendC(' ');", + " n--;", + " }", + "}", + "void backup(void)", + "{", + " if (buf_[cur_ - 1] == ' ')", + " {", + " buf_[cur_ - 1] = 0;", + " cur_--;", + " }", + "}" + ] diff --git a/formats/c/CFtoCSkel.hs b/formats/c/CFtoCSkel.hs new file mode 100644 --- /dev/null +++ b/formats/c/CFtoCSkel.hs @@ -0,0 +1,240 @@ +{- + BNF Converter: C Skeleton generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C Skeleton functions. + + The generated files follow Appel's case method. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 9 August, 2003 + + Modified : 12 August, 2003 + + + ************************************************************** +-} + +module CFtoCSkel (cf2CSkel) where + +import CF +import Utils ( (+++) ) +import NamedVariables +import 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 diff --git a/formats/c/CFtoFlexC.hs b/formats/c/CFtoFlexC.hs new file mode 100644 --- /dev/null +++ b/formats/c/CFtoFlexC.hs @@ -0,0 +1,189 @@ +{- + BNF Converter: C flex generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Flex file. It is + similar to JLex but with a few peculiarities. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 5 August, 2003 + + Modified : 10 August, 2003 + + + ************************************************************** +-} +module CFtoFlexC (cf2flex) where + +import CF +import RegToFlex +-- import Utils((+++), (++++)) +import NamedVariables +import List + +--The environment must be returned for the parser to use. +cf2flex :: String -> CF -> (String, SymEnv) +cf2flex name cf = (unlines + [ + prelude name, + cMacros, + lexSymbols env, + restOfFlex cf env' + ], env') + where + env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) + env' = env ++ (makeSymEnv (fst (unzip (tokenPragmas cf))) (length env)) + makeSymEnv [] _ = [] + makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) + +prelude :: String -> String +prelude name = unlines + [ + "/* -*- c -*- This FLex file was machine-generated by the BNF converter */", + "%option noyywrap", + "%{", + "#define yylval " ++ name ++ "lval", + "#define YY_BUFFER_APPEND " ++ name ++ "_BUFFER_APPEND", + "#define YY_BUFFER_RESET " ++ name ++ "_BUFFER_RESET", + "#define initialize_lexer " ++ name ++ "_initialize_lexer", + "#include ", + "#include \"Parser.h\"", + "#define YY_BUFFER_LENGTH 4096", + "char YY_PARSED_STRING[YY_BUFFER_LENGTH];", + "void YY_BUFFER_APPEND(char *s)", + "{", + " strcat(YY_PARSED_STRING, s); //Do something better here!", + "}", + "void YY_BUFFER_RESET(void)", + "{", + " int x;", + " for(x = 0; x < YY_BUFFER_LENGTH; x++)", + " YY_PARSED_STRING[x] = 0;", + "}", + "", + "%}" + ] + +--For now all categories are included. +--Optimally only the ones that are used should be generated. +cMacros :: String +cMacros = unlines + [ + "LETTER [a-zA-Z]", + "CAPITAL [A-Z]", + "SMALL [a-z]", + "DIGIT [0-9]", + "IDENT [a-zA-Z0-9'_]", + "%START YYINITIAL COMMENT CHAR CHARESC CHAREND STRING ESCAPED", + "%%" + ] + +lexSymbols :: SymEnv -> String +lexSymbols ss = concatMap transSym ss + where + transSym (s,r) = + "\"" ++ s' ++ "\" \t return " ++ r ++ ";\n" + where + s' = escapeChars s + +restOfFlex :: CF -> SymEnv -> String +restOfFlex cf env = concat + [ + lexComments (comments cf), + userDefTokens, + ifC "String" strStates, + ifC "Char" chStates, + ifC "Double" "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t yylval.double_ = atof(yytext); return _DOUBLE_;\n", + ifC "Integer" "{DIGIT}+ \t yylval.int_ = atoi(yytext); return _INTEGER_;\n", + ifC "Ident" "{LETTER}{IDENT}* \t yylval.string_ = strdup(yytext); return _IDENT_;\n" + , "[ \\t\\r\\n\\f] \t /* ignore white space. */;\n", + ". \t return _ERROR_;\n", + "%%\n", + footer + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + userDefTokens = unlines $ + ["" ++ printRegFlex exp ++ + " \t yylval.string_ = strdup(yytext); return " ++ sName name ++ ";" + | (name, exp) <- tokenPragmas cf] + where + sName n = case lookup n env of + Just x -> x + Nothing -> n + strStates = unlines --These handle escaped characters in Strings. + [ + "\"\\\"\" \t BEGIN STRING;", + "\\\\ \t BEGIN ESCAPED;", + "\\\" \t yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return _STRING_;", + ". \t YY_BUFFER_APPEND(yytext);", + "n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;", + "\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;", + "\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;", + "t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;", + ". \t YY_BUFFER_APPEND(yytext); BEGIN STRING;" + ] + chStates = unlines --These handle escaped characters in Chars. + [ + "\"'\" \tBEGIN CHAR;", + "\\\\ \t BEGIN CHARESC;", + "[^'] \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;", + "n \t BEGIN CHAREND; yylval.char_ = '\\n'; return _CHAR_;", + "t \t BEGIN CHAREND; yylval.char_ = '\\t'; return _CHAR_;", + ". \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;", + "\"'\" \t BEGIN YYINITIAL;" + ] + footer = "void initialize_lexer(FILE *inp) { yyin = inp; BEGIN YYINITIAL; }" + +lexComments :: ([(String, String)], [String]) -> String +lexComments (m,s) = + (unlines (map lexSingleComment s)) + ++ (unlines (map lexMultiComment m)) + +lexSingleComment :: String -> String +lexSingleComment c = + "\"" ++ c ++ "\"[^\\n]*\\n \t /* BNFC single-line comment */;" + +--There might be a possible bug here if a language includes 2 multi-line comments. +--They could possibly start a comment with one character and end it with another. +--However this seems rare. +lexMultiComment :: (String, String) -> String +lexMultiComment (b,e) = unlines [ + "\"" ++ b ++ "\" \t BEGIN COMMENT;", + "\"" ++ e ++ "\" \t BEGIN YYINITIAL;", + ". \t /* BNFC multi-line comment */;", + "[\\n] \t /* BNFC multi-line comment */;" + ] + +lexReserved :: String -> String +lexReserved s = "\"" ++ s ++ "\" \t yylval.string_ = strdup(yytext); return TS;" + + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) diff --git a/formats/c/CTop.hs b/formats/c/CTop.hs new file mode 100644 --- /dev/null +++ b/formats/c/CTop.hs @@ -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 ", + "#include ", + "", + "#include \"Parser.h\"", + "#include \"Printer.h\"", + "#include \"Absyn.h\"", + "", + "int main(int argc, char ** argv)", + "{", + " FILE *input;", + " " ++ def ++ " parse_tree;", + " if (argc > 1) ", + " {", + " input = fopen(argv[1], \"r\");", + " if (!input)", + " {", + " fprintf(stderr, \"Error opening input file.\\n\");", + " exit(1);", + " }", + " }", + " else input = stdin;", + " /* The default entry point is used. For other options see Parser.h */", + " parse_tree = p" ++ def ++ "(input);", + " if (parse_tree)", + " {", + " printf(\"\\nParse Succesful!\\n\");", + " printf(\"\\n[Abstract Syntax]\\n\");", + " printf(\"%s\\n\\n\", show" ++ def ++ "(parse_tree));", + " printf(\"[Linearized Tree]\\n\");", + " printf(\"%s\\n\\n\", print" ++ def ++ "(parse_tree));", + " return 0;", + " }", + " return 1;", + "}", + "" + ] + where + def = head (allEntryPoints cf) + +mkHeaderFile :: CF -> [Cat] -> [Cat] -> [(a, String)] -> String +mkHeaderFile cf cats eps env = unlines + [ + "#ifndef PARSER_HEADER_FILE", + "#define PARSER_HEADER_FILE", + "", + "#include \"Absyn.h\"", + "", + "typedef union", + "{", + " int int_;", + " char char_;", + " double double_;", + " char* string_;", + (concatMap mkVar cats) ++ "} YYSTYPE;", + "", + "#define _ERROR_ 258", + mkDefines (259::Int) env, + "extern YYSTYPE yylval;", + concatMap mkFunc eps, + "", + "#endif" + ] + where + mkVar s | (normCat s == s) = " " ++ (identCat s) +++ (map toLower (identCat s)) ++ "_;\n" + mkVar _ = "" + mkDefines n [] = mkString n + mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) + mkString n = if isUsedCat cf "String" + then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) + else mkChar n + mkChar n = if isUsedCat cf "Char" + then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1) + else mkInteger n + mkInteger n = if isUsedCat cf "Integer" + then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1) + else mkDouble n + mkDouble n = if isUsedCat cf "Double" + then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1) + else mkIdent n + mkIdent n = if isUsedCat cf "Ident" + then ("#define _IDENT_ " ++ show n ++ "\n") + else "" + mkFunc s | (normCat s == s) = (identCat s) ++ " p" ++ (identCat s) ++ "(FILE *inp);\n" + mkFunc _ = "" + diff --git a/formats/cpp/CFtoBison.hs b/formats/cpp/CFtoBison.hs new file mode 100644 --- /dev/null +++ b/formats/cpp/CFtoBison.hs @@ -0,0 +1,352 @@ +{- + BNF Converter: Bison generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + BNF Converter: C++ Bison generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Bison input file. + Note that because of the way bison stores results + the programmer can increase performance by limiting + the number of entry points in their grammar. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 6 August, 2003 + + Modified : 6 August, 2003 + + + ************************************************************** +-} + + +module CFtoBison (cf2Bison) where + +import CF +import 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 ", + "#include ", + "#include ", + "#include ", + "#include \"Absyn.H\"", + "int yyparse(void);", + "int yylex(void);", + "int yy_mylinenumber;", --- hack to get line number. AR 2006 + "int initialize_lexer(FILE * inp);", + "int yywrap(void)", + "{", + " return 1;", + "}", + "void yyerror(const char *str)", + "{", + " std::cout << \"line \" << yy_mylinenumber + 1 << std::endl ;", + " fprintf(stderr,\"error: %s\\n\",str);", + "}", + "", + definedRules cf, + unlines $ map (parseMethod name) (allCatsIdNorm cf), -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug. + concatMap reverseList (filter isList (allCats cf)), + "%}" + ] + +definedRules :: CF -> String +definedRules cf@((pr,_),_) = + unlines [ rule f xs e | FunDef f xs e <- pr ] + where + ctx = buildContext cf + + list = LC (const "[]") (\t -> "List" ++ unBase t) + where + unBase (ListT t) = unBase t + unBase (BaseT x) = normCat x + + rule f xs e = + case checkDefinition' list ctx f xs e of + Bad err -> error $ "Panic! This should have been caught already:\n" ++ err + Ok (args,(e',t)) -> unlines + [ cppType t ++ " " ++ f ++ "_ (" ++ + concat (intersperse ", " $ map cppArg args) ++ ") {" + , " return " ++ cppExp e' ++ ";" + , "}" + ] + where + + cppType :: Base -> String + cppType (ListT (BaseT x)) = "List" ++ normCat x ++ " *" + cppType (ListT t) = cppType t ++ " *" + cppType (BaseT x) + | isToken x ctx = "String" + | otherwise = normCat x ++ " *" + + cppArg :: (String, Base) -> String + cppArg (x,t) = cppType t ++ " " ++ x ++ "_" + + cppExp :: Exp -> String + cppExp (App "[]" []) = "0" + cppExp (App x []) + | elem x xs = x ++ "_" -- argument + cppExp (App t [e]) + | isToken t ctx = cppExp e + cppExp (App x es) + | isUpper (head x) = call ("new " ++ x) es + | otherwise = call (x ++ "_") es + cppExp (LitInt n) = show n + cppExp (LitDouble x) = show x + cppExp (LitChar c) = show c + cppExp (LitString s) = show s + + call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")" + + +--This generates a parser method for each entry point. +parseMethod :: String -> Cat -> String +parseMethod name cat = + -- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm + -- then "" + -- else + unlines + [ + cat' ++ "*" +++ (resultName cat') +++ "= 0;", + cat' ++"* p" ++ cat' ++ "(FILE *inp)", + "{", + " initialize_lexer(inp);", + " if (yyparse())", + " { /* Failure */", + " return 0;", + " }", + " else", + " { /* Success */", + " return" +++ (resultName cat') ++ ";", + " }", + "}" + ] + where + cat' = identCat (normCat cat) + +--This method generates list reversal functions for each list type. +reverseList :: Cat -> String +reverseList c = unlines + [ + c' ++ "* reverse" ++ c' ++ "(" ++ c' +++ "*l)", + "{", + " " ++ c' +++"*prev = 0;", + " " ++ c' +++"*tmp = 0;", + " while (l)", + " {", + " tmp = l->" ++ v ++ ";", + " l->" ++ v +++ "= prev;", + " prev = l;", + " l = tmp;", + " }", + " return prev;", + "}" + ] + where + c' = identCat (normCat c) + v = (map toLower c') ++ "_" + +--The union declaration is special to Bison/Yacc and gives the type of yylval. +--For efficiency, we may want to only include used categories here. +union :: [Cat] -> String +union cats = unlines + [ + "%union", + "{", + " int int_;", + " char char_;", + " double double_;", + " char* string_;", + concatMap mkPointer cats, + "}" + ] + where --This is a little weird because people can make [Exp2] etc. + mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion. + " " ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n" + mkPointer s | normCat s == s = --normal cat + " " ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n" + mkPointer s = "" + +--declares non-terminal types. +declarations :: CF -> String +declarations cf = concatMap (typeNT cf) (allCats cf) + where --don't define internal rules + typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n" + typeNT cf nt = "" + +--declares terminal types. +tokens :: [UserDef] -> SymEnv -> String +tokens user ts = concatMap (declTok user) ts + where + declTok u (s,r) = if elem s u + then "%token " ++ r ++ " // " ++ s ++ "\n" + else "%token " ++ r ++ " // " ++ s ++ "\n" + +specialToks :: CF -> String +specialToks cf = concat [ + ifC "String" "%token _STRING_\n", + ifC "Char" "%token _CHAR_\n", + ifC "Integer" "%token _INTEGER_\n", + ifC "Double" "%token _DOUBLE_\n", + ifC "Ident" "%token _IDENT_\n" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + +--The following functions are a (relatively) straightforward translation +--of the ones in CFtoHappy.hs +rulesForBison :: String -> CF -> SymEnv -> Rules +rulesForBison name cf env = map mkOne $ ruleGroups cf where + mkOne (cat,rules) = constructRule cf env rules cat + +-- For every non-terminal, we construct a set of rules. +constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule cf env rules nt = (nt,[(p,(generateAction (ruleName r) b m) +++ result) | + r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True,revSepListRule r0) + else (False,r0), + let (p,m) = generatePatterns cf env r]) + where + ruleName r = case funRule r of + "(:)" -> identCat nt + "(:[])" -> identCat nt + z -> z + revs = reversibleCats cf + eps = allEntryPoints cf + isEntry nt = if elem nt eps then True else False + result = if isEntry nt then (resultName (normCat (identCat nt))) ++ "= $$;" else "" + +-- Generates a string containing the semantic action. +generateAction :: Fun -> Bool -> [MetaVar] -> Action +generateAction f b ms = + if isCoercion f + then (unwords ms) ++ ";" + else if f == "[]" + then "0;" + else if isDefinedRule f + then concat [ f, "_", "(", concat $ intersperse ", " ms', ");" ] + else concat ["new ", normCat f, "(", (concat (intersperse ", " ms')), ");"] + where + ms' = if b then reverse ms else ms + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal +generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar]) +generatePatterns cf env r = case rhsRule r of + [] -> ("/* empty */",[]) + its -> (unwords (map mkIt its), metas its) + where + mkIt i = case i of + Left c -> case lookup c env of + Just x -> x + Nothing -> typeName (identCat c) + Right s -> case lookup s env of + Just x -> x + Nothing -> s + metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its] + revIf c m = if (not (isConsFun (funRule r)) && elem c revs) + then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")") + else m -- no reversal in the left-recursive Cons rule itself + revs = reversibleCats cf + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. + +prRules :: Rules -> String +prRules [] = [] +prRules ((nt, []):rs) = prRules rs --internal rule +prRules ((nt,((p,a):ls)):rs) = + (unwords [nt', ":" , p, "{ $$ =", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ $$ =", a , "}"])]) ++ pr ls + +--Some helper functions. +resultName :: String -> String +resultName s = "YY_RESULT_" ++ s ++ "_" + +--slightly stronger than the NamedVariable version. +varName :: String -> String +varName s = (map toLower (identCat s)) ++ "_" + +typeName :: String -> String +typeName "Ident" = "_IDENT_" +typeName "String" = "_STRING_" +typeName "Char" = "_CHAR_" +typeName "Integer" = "_INTEGER_" +typeName "Double" = "_DOUBLE_" +typeName x = x diff --git a/formats/cpp/CFtoCPPAbs.hs b/formats/cpp/CFtoCPPAbs.hs new file mode 100644 --- /dev/null +++ b/formats/cpp/CFtoCPPAbs.hs @@ -0,0 +1,443 @@ +{- + BNF Converter: C++ abstract syntax generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C++ Abstract Syntax + tree classes. It generates both a Header file + and an Implementation file, and uses the Visitor + design pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 4 August, 2003 + + Modified : 22 May, 2004 / Antti-Juhani Kaijanaho + + + ************************************************************** +-} + +module CFtoCPPAbs (cf2CPPAbs) where + +import CF +import Utils((+++),(++++)) +import NamedVariables +import 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 ", + "#include \"Absyn.H\"" + ] + +--This is not represented in the implementation. +prDataC :: [UserDef] -> Data -> String +prDataC user (cat, rules) = concatMap (prRuleC user cat) rules + +--Classes for rules vary based on the type of rule. +prRuleC user c (fun, cats) = + if isNilFun fun || isOneFun fun + then "" --these are not represented in the AbSyn + else if isConsFun fun + then --this is the linked list case. + unlines + [ + "/******************** " ++ c' ++ " ********************/", + prConstructorC user c' vs cats, + prCopyC user c' vs, + prDestructorC user c' vs, + prListFuncs user c', + prAcceptC c', + prCloneC user c' vs, + "" + ] + else --a standard rule + unlines + [ + "/******************** " ++ fun' ++ " ********************/", + prConstructorC user fun' vs cats, + prCopyC user fun' vs, + prDestructorC user fun' vs, + prAcceptC fun, + prCloneC user fun' vs, + "" + ] + where + vs = getVars cats + fun' = identCat (normCat fun) + c' = identCat (normCat c) + +--These are all built-in list functions. +--Later we could include things like lookup,insert,delete,etc. +prListFuncs :: [UserDef] -> String -> String +prListFuncs user c = unlines + [ + c ++ "::" ++ c ++ "(" ++ m +++ mstar ++ "p)", + "{", + " " ++ m' ++ " = p;", + " " ++ v ++ "= 0;", + "}", + c ++ "*" +++ c ++ "::" ++ "reverse()", + "{", + " if (" ++ v +++ "== 0) return this;", + " else", + " {", + " " ++ c ++ " *tmp =" +++ v ++ "->reverse(this);", + " " ++ v +++ "= 0;", + " return tmp;", + " }", + "}", + "", + c ++ "*" +++ c ++ "::" ++ "reverse(" ++ c ++ "* prev)", + "{", + " if (" ++ v +++ "== 0)", + " {", + " " ++ v +++ "= prev;", + " return this;", + " }", + " else", + " {", + " " ++ c +++ "*tmp =" +++ v ++ "->reverse(this);", + " " ++ v +++ "= prev;", + " return tmp;", + " }", + "}" + ] + where + v = (map toLower c) ++ "_" + m = drop 4 c + mstar = if isBasic user m then "" else "*" + m' = drop 4 v + +--The standard accept function for the Visitor pattern +prAcceptC :: String -> String +prAcceptC ty = + "\nvoid " ++ ty ++ "::accept(Visitor *v) { v->visit" ++ ty ++ "(this); }" + +--The constructor just assigns the parameters to the corresponding instance variables. +prConstructorC :: [UserDef] -> String -> [IVar] -> [Cat] -> String +prConstructorC user c vs cats = + c ++ "::" ++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" +++ + prAssigns vs params ++ "}" + where + (types, params) = unzip (prParams cats (length cats) ((length cats)+1)) + interleave _ [] = [] + interleave (x:[]) (y:[]) = x +++ (optstar x) ++ y + interleave (x:xs) (y:ys) = x +++ (optstar x) ++ y ++ "," +++ (interleave xs ys) + optstar x = if isBasic user x + then "" + else "*" + +--Print copy constructor and copy assignment +prCopyC :: [UserDef] -> String -> [IVar] -> String +prCopyC user c vs = + c ++ "::" ++ c ++ "(const" +++ c +++ "& other) {" +++ + concatMap doV vs ++++ + "}" ++++ + c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other) {" ++++ + " " ++ c +++ "tmp(other);" ++++ + " swap(tmp);" ++++ + " return *this;" ++++ + "}" ++++ + "void" +++ c ++ "::swap(" ++ c +++ "& other) {" ++++ + concatMap swapV vs ++++ + "}\n" + where doV :: IVar -> String + doV v@(t, _) + | isBasic user t = " " ++ vn v ++ " = other." ++ vn v ++ ";\n" + | otherwise = " " ++ vn v ++ " = other." ++ vn v ++ "->clone();\n" + vn :: IVar -> String + vn (t, 0) = varName t + vn (t, n) = varName t ++ show n + swapV :: IVar -> String + swapV v = " std::swap(" ++ vn v ++ ", other." ++ vn v ++ ");\n" + +--The cloner makes a new deep copy of the object +prCloneC :: [UserDef] -> String -> [IVar] -> String +prCloneC user c vs = + c +++ "*" ++ c ++ "::clone() const {" ++++ + " return new" +++ c ++ "(*this);\n}" + +--The destructor deletes all a class's members. +prDestructorC :: [UserDef] -> String -> [IVar] -> String +prDestructorC user c vs = + c ++ "::~" ++ c ++"()" +++ "{" +++ + (concatMap prDeletes vs) ++ "}" + where + prDeletes :: (String, Int) -> String + prDeletes (t, n) = if isBasic user t + then "" + else if n == 0 + then "delete(" ++ (varName t) ++ "); " + else "delete(" ++ (varName t) ++ (show n) ++ "); " + +--Prints the constructor's parameters. +prParams :: [Cat] -> Int -> Int -> [(String,String)] +prParams [] _ _ = [] +prParams (c:cs) n m = (identCat c,"p" ++ (show (m-n))) + : (prParams cs (n-1) m) + +--Prints the assignments of parameters to instance variables. +--This algorithm peeks ahead in the list so we don't use map or fold +prAssigns :: [IVar] -> [String] -> String +prAssigns [] _ = [] +prAssigns _ [] = [] +prAssigns ((t,n):vs) (p:ps) = + if n == 1 then + case findIndices (\x -> case x of (l,r) -> l == t) vs of + [] -> (varName t) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + z -> ((varName t) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + else ((varName t) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + + +{- **** Helper Functions **** -} + +--Checks if something is a basic or user-defined type. +isBasic :: [UserDef] -> String -> Bool +isBasic user x = + if elem x user + then True + else case x of + "Integer" -> True + "Char" -> True + "String" -> True + "Double" -> True + "Ident" -> True + _ -> False diff --git a/formats/cpp/CFtoCPPPrinter.hs b/formats/cpp/CFtoCPPPrinter.hs new file mode 100644 --- /dev/null +++ b/formats/cpp/CFtoCPPPrinter.hs @@ -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 ", + "#include ", + "#include ", + "", + "/* Certain applications may improve performance by changing the buffer size */", + "#define BUFFER_INITIAL 2000", + "/* You may wish to change _L_PAREN or _R_PAREN */", + "#define _L_PAREN '('", + "#define _R_PAREN ')'", + "", + "class PrintAbsyn : public Visitor", + "{", + " protected:", + " int _n_, _i_;", + " /* The following are simple heuristics for rendering terminals */", + " /* You may wish to change them */", + " void render(Char c);", + " void render(String s);", + " void indent(void);", + " void backup(void);", + " public:", + " PrintAbsyn(void);", + " ~PrintAbsyn(void);", + " char* print(Visitable* v);" + ] + classFooter = unlines + [ + " void visitInteger(Integer i);", + " void visitDouble(Double d);", + " void visitChar(Char c);", + " void visitString(String s);", + " void visitIdent(String s);", + " protected:", + " void inline bufAppend(const char* s)", + " {", + " int len = strlen(s);", + " while (cur_ + len > buf_size)", + " {", + " buf_size *= 2; /* Double the buffer size */", + " resizeBuffer();", + " }", + " for(int n = 0; n < len; n++)", + " {", + " buf_[cur_ + n] = s[n];", + " }", + " cur_ += len;", + " buf_[cur_] = 0;", + " }", + " void inline bufAppend(const char c)", + " {", + " if (cur_ == buf_size)", + " {", + " buf_size *= 2; /* Double the buffer size */", + " resizeBuffer();", + " }", + " buf_[cur_] = c;", + " cur_++;", + " buf_[cur_] = 0;", + " }", + " void inline bufReset(void)", + " {", + " cur_ = 0;", + " buf_size = BUFFER_INITIAL;", + " resizeBuffer();", + " memset(buf_, 0, buf_size);", + " }", + " void inline resizeBuffer(void)", + " {", + " char* temp = (char*) malloc(buf_size);", + " if (!temp)", + " {", + " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");", + " exit(1);", + " }", + " if (buf_)", + " {", + " strcpy(temp, buf_);", + " free(buf_);", + " }", + " buf_ = temp;", + " }", + " char *buf_;", + " int cur_, buf_size;", + "};", + "" + ] + showHeader = unlines + [ + "", + "class ShowAbsyn : public Visitor", + "{", + " public:", + " ShowAbsyn(void);", + " ~ShowAbsyn(void);", + " char* show(Visitable* v);" + ] + footer = unlines + [ + "", + "#endif" + ] + +--Prints all the required method names and their parameters. +prDataH :: (Cat, [Rule]) -> String +prDataH (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then concat [" void visit", cl, "(", cl, "* p);\n"] + else abstract ++ (concatMap prRuleH rules) + where + cl = identCat (normCat cat) + abstract = case lookup cat rules of + Just x -> "" + Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n" + +--Prints all the methods to visit a rule. +prRuleH :: Rule -> String +prRuleH (fun, (c, cats)) | isProperLabel fun = concat + [" void visit", fun, "(", fun, " *p);\n"] +prRuleH (fun, cats) = "" + +{- **** Implementation (.C) File Methods **** -} + +--This makes the .C file by a similar method. +mkCFile :: CF -> [(Cat,[Rule])] -> String +mkCFile cf groups = concat + [ + header, + prRender, + printEntries, + concatMap (prPrintData user) groups, + printBasics, + showEntries, + concatMap (prShowData user) groups, + showBasics + ] + where + user = fst (unzip (tokenPragmas cf)) + header = unlines + [ + "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/", + "", + "#include \"Printer.H\"", + "" + ] + printEntries = unlines + [ + "PrintAbsyn::PrintAbsyn(void)", + "{", + " _i_ = 0; _n_ = 0;", + " buf_ = 0;", + " bufReset();", + "}", + "", + "PrintAbsyn::~PrintAbsyn(void)", + "{", + "}", + "", + "char* PrintAbsyn::print(Visitable *v)", + "{", + " _i_ = 0; _n_ = 0;", + " bufReset();", + " v->accept(this);", + " return buf_;", + "}" + ] + showEntries = unlines + [ + "ShowAbsyn::ShowAbsyn(void)", + "{", + " buf_ = 0;", + " bufReset();", + "}", + "", + "ShowAbsyn::~ShowAbsyn(void)", + "{", + "}", + "", + "char* ShowAbsyn::show(Visitable *v)", + "{", + " bufReset();", + " v->accept(this);", + " return buf_;", + "}" + ] + printBasics = unlines + [ + "void PrintAbsyn::visitInteger(Integer i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%d\", i);", + " bufAppend(tmp);", + "}", + "void PrintAbsyn::visitDouble(Double d)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%g\", d);", + " bufAppend(tmp);", + "}", + "void PrintAbsyn::visitChar(Char c)", + "{", + " bufAppend('\\'');", + " bufAppend(c);", + " bufAppend('\\'');", + "}", + "void PrintAbsyn::visitString(String s)", + "{", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "void PrintAbsyn::visitIdent(String s)", + "{", + " render(s);", + "}", + "" + ] + showBasics = unlines + [ + "void ShowAbsyn::visitInteger(Integer i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%d\", i);", + " bufAppend(tmp);", + "}", + "void ShowAbsyn::visitDouble(Double d)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%g\", d);", + " bufAppend(tmp);", + "}", + "void ShowAbsyn::visitChar(Char c)", + "{", + " bufAppend('\\'');", + " bufAppend(c);", + " bufAppend('\\'');", + "}", + "void ShowAbsyn::visitString(String s)", + "{", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "void ShowAbsyn::visitIdent(String s)", + "{", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "" + ] + +{- **** Pretty Printer Methods **** -} + +--Generates methods for the Pretty Printer +prPrintData :: [UserDef] -> (Cat, [Rule]) -> String +prPrintData user (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then unlines + [ + "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")", + "{", + " while(" ++ vname ++ "!= 0)", + " {", + " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)", + " {", + visitMember, + optsep, + " " ++ vname +++ "= 0;", + " }", + " else", + " {", + visitMember, + " render(" ++ sep ++ ");", + " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", + " }", + " }", + "}", + "" + ] --Not a list: + else abstract ++ (concatMap (prPrintRule user) rules) + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl ++ "_" + visitMember = if isBasic user member + then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" + else " " ++ vname ++ "->" ++ member ++ "->accept(this);" + sep = if (length sep') == 1 + then "'" ++ (escapeChars sep') ++ "'" + else "\"" ++ (escapeChars sep') ++ "\"" + sep' = getCons rules + optsep = if hasOneFunc rules then "" else (" render(" ++ sep ++ ");") + abstract = case lookup cat rules of + Just x -> "" + Nothing -> "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl ++ "*p) {} //abstract class\n\n" + +--Pretty Printer methods for a rule. +prPrintRule :: [UserDef] -> Rule -> String +prPrintRule user r@(fun, (c, cats)) | isProperLabel fun = unlines + [ + "void PrintAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")", + "{", + " int oldi = _i_;", + lparen, + cats', + rparen, + " _i_ = oldi;", + "}\n" + ] + where + p = precRule r + (lparen, rparen) = + (" if (oldi > " ++ (show p) ++ ") render(_L_PAREN);\n", + " if (oldi > " ++ (show p) ++ ") render(_R_PAREN);\n") + cats' = (concatMap (prPrintCat user fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats))) + fnm = "p" --old names could cause conflicts + getPrec (Right s) = 0 + getPrec (Left c) = precCat c +prPrintRule _ (fun, cats) = "" + +--This goes on to recurse to the instance variables. +prPrintCat :: [UserDef] -> String -> (Either Cat String, Int) -> String +prPrintCat user fnm (c,p) = case c of + (Right t) -> " render(" ++ t' ++ ");\n" + where + t' = if length t == 1 + then "'" ++ (escapeChars t) ++ "'" + else "\"" ++ (escapeChars t) ++ "\"" + (Left nt) -> if isBasic user nt + then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" + else if "list" `isPrefixOf` nt + then " if(" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}" + else " " ++ accept ++ "\n" + where + accept = if nt == "#_" --Internal category + then "/* Internal Category */\n" + else (setI p) ++ fnm ++ "->" ++ nt ++ "->accept(this);" + +{- **** Abstract Syntax Tree Printer **** -} + +--This prints the functions for Abstract Syntax tree printing. +prShowData :: [UserDef] -> (Cat, [Rule]) -> String +prShowData user (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then unlines + [ + "void ShowAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")", + "{", + " while(" ++ vname ++ "!= 0)", + " {", + " if (" ++ vname ++ "->" ++ vname ++ "_)", + " {", + visitMember, + " bufAppend(\", \");", + " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;", + " }", + " else", + " {", + visitMember, + " " ++ vname ++ " = 0;", + " }", + " }", + "}", + "" + ] --Not a list: + else abstract ++ (concatMap (prShowRule user) rules) + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl ++ "_" + visitMember = if isBasic user member + then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" + else " " ++ vname ++ "->" ++ member ++ "->accept(this);" + abstract = case lookup cat rules of + Just x -> "" + Nothing -> "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ "* p) {} //abstract class\n\n" + +--This prints all the methods for Abstract Syntax tree rules. +prShowRule :: [UserDef] -> Rule -> String +prShowRule user (fun, (c, cats)) | isProperLabel fun = concat + [ + "void ShowAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")\n", + "{\n", + lparen, + " bufAppend(\"" ++ fun ++ "\");\n", + optspace, + cats', + rparen, + "}\n" + ] + where + (optspace, lparen, rparen) = if allTerms cats + then ("","","") + else (" bufAppend(' ');\n", " bufAppend('(');\n"," bufAppend(')');\n") + cats' = if allTerms cats + then "" + else concat (insertSpaces (map (prShowCat user fnm) (fixOnes (numVars [] cats)))) + insertSpaces [] = [] + insertSpaces (x:[]) = [x] + insertSpaces (x:xs) = if x == "" + then insertSpaces xs + else (x : [" bufAppend(' ');\n"]) ++ (insertSpaces xs) + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs + fnm = "p" --other names could cause conflicts +prShowRule _ (fun, cats) = "" + +--This recurses to the instance variables of a class. +prShowCat :: [UserDef] -> String -> Either Cat String -> String +prShowCat user fnm c = + case c of + (Right t) -> "" + (Left nt) -> + if isBasic user nt + then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" + else if nt == "#_" --internal category + then "/* Internal Category */\n" + else if ((normCat nt) /= nt) + then accept + else concat + [ + " bufAppend('[');\n", + " if (" ++ fnm ++ "->" ++ nt ++ ")" ++ accept, + " bufAppend(']');\n" + ] + where + accept = " " ++ fnm ++ "->" ++ nt ++ "->accept(this);\n" + +{- **** Helper Functions Section **** -} + + +--Just checks if something is a basic or user-defined type. +--This is because you don't -> a basic non-pointer type. +isBasic :: [UserDef] -> String -> Bool +isBasic user v = + if elem (init v) user' + then True + else if "integer_" `isPrefixOf` v then True + else if "char_" `isPrefixOf` v then True + else if "string_" `isPrefixOf` v then True + else if "double_" `isPrefixOf` v then True + else if "ident_" `isPrefixOf` v then True + else False + where + user' = map (map toLower) user + +--The visit-function name of a basic type +funName :: String -> String +funName v = + if "integer_" `isPrefixOf` v then "Integer" + else if "char_" `isPrefixOf` v then "Char" + else if "string_" `isPrefixOf` v then "String" + else if "double_" `isPrefixOf` v then "Double" + else if "ident_" `isPrefixOf` v then "Ident" + else "Ident" --User-defined type + +--Just sets the coercion level for parentheses in the Pretty Printer. +setI :: Int -> String +setI n = "_i_ = " ++ (show n) ++ "; " + +--Gets the separator for a list. +getCons :: [Rule] -> String +getCons ((f, (c, cats)):rs) = + if isConsFun f + then seper cats + else getCons rs + where + seper [] = [] + seper ((Right x):xs) = x + seper ((Left x):xs) = seper xs + +--Checks if the list has a non-empty rule. +hasOneFunc :: [Rule] -> Bool +hasOneFunc [] = False +hasOneFunc ((f, (c, cats)):rs) = + if (isOneFun f) + then True + else hasOneFunc rs + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) + +--An extremely simple renderer for terminals. +prRender :: String +prRender = unlines + [ + "//You may wish to change render", + "void PrintAbsyn::render(Char c)", + "{", + " if (c == '{')", + " {", + " bufAppend('\\n');", + " indent();", + " bufAppend(c);", + " _n_ = _n_ + 2;", + " bufAppend('\\n');", + " indent();", + " }", + " else if (c == '(' || c == '[')", + " bufAppend(c);", + " else if (c == ')' || c == ']')", + " {", + " backup();", + " bufAppend(c);", + " bufAppend(' ');", + " }", + " else if (c == '}')", + " {", + " _n_ = _n_ - 2;", + " backup();", + " backup();", + " bufAppend(c);", + " bufAppend('\\n\');", + " indent();", + " }", + " else if (c == ',')", + " {", + " backup();", + " bufAppend(c);", + " bufAppend(' ');", + " }", + " else if (c == ';')", + " {", + " backup();", + " bufAppend(c);", + " bufAppend('\\n');", + " indent();", + " }", + " else if (c == 0) return;", + " else", + " {", + " bufAppend(c);", + " bufAppend(' ');", + " }", + "}", + "void PrintAbsyn::render(String s)", + "{", + " if(strlen(s) > 0)", + " {", + " bufAppend(s);", + " bufAppend(' ');", + " }", + "}", + "void PrintAbsyn::indent()", + "{", + " int n = _n_;", + " while (n > 0)", + " {", + " bufAppend(' ');", + " n--;", + " }", + "}", + "void PrintAbsyn::backup()", + "{", + " if (buf_[cur_ - 1] == ' ')", + " {", + " buf_[cur_ - 1] = 0;", + " cur_--;", + " }", + "}" + ] diff --git a/formats/cpp/CFtoCVisitSkel.hs b/formats/cpp/CFtoCVisitSkel.hs new file mode 100644 --- /dev/null +++ b/formats/cpp/CFtoCVisitSkel.hs @@ -0,0 +1,259 @@ +{- + BNF Converter: C++ Skeleton generation + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C++ Skeleton functions. + + The generated files use the Visitor design pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 9 August, 2003 + + Modified : 12 August, 2003 + + + ************************************************************** +-} + +module CFtoCVisitSkel (cf2CVisitSkel) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import 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 diff --git a/formats/cpp/CFtoFlex.hs b/formats/cpp/CFtoFlex.hs new file mode 100644 --- /dev/null +++ b/formats/cpp/CFtoFlex.hs @@ -0,0 +1,191 @@ +{- + BNF Converter: Flex generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Flex file. It is + similar to JLex but with a few peculiarities. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 5 August, 2003 + + Modified : 22 August, 2006 by Aarne Ranta + + + ************************************************************** +-} +module CFtoFlex (cf2flex) where + +import CF +import RegToFlex +import Utils((+++), (++++)) +import NamedVariables +import List +import STLUtils + +--The environment must be returned for the parser to use. +cf2flex :: Maybe String -> String -> CF -> (String, SymEnv) +cf2flex inPackage name cf = (unlines + [ + prelude inPackage name, + cMacros, + lexSymbols env, + restOfFlex inPackage cf env' + ], env') + where + env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) + env' = env ++ (makeSymEnv (fst (unzip (tokenPragmas cf))) (length env)) + makeSymEnv [] _ = [] + makeSymEnv (s:symbs) n = (s, nsDefine inPackage "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) + +prelude :: Maybe String -> String -> String +prelude inPackage name = unlines + [ + maybe "" (\ns -> "%option prefix=\"" ++ ns ++ "yy\"") inPackage, + "/* This FLex file was machine-generated by the BNF converter */", + "%{", + "#include ", + "#include \"Parser.H\"", + "#define YY_BUFFER_LENGTH 4096", + "extern int " ++ nsString inPackage ++ "yy_mylinenumber ;", --- hack to get line number. AR 2006 + "static char YY_PARSED_STRING[YY_BUFFER_LENGTH];", + "static void YY_BUFFER_APPEND(char *s)", + "{", + " strcat(YY_PARSED_STRING, s); //Do something better here!", + "}", + "static void YY_BUFFER_RESET(void)", + "{", + " for(int x = 0; x < YY_BUFFER_LENGTH; x++)", + " YY_PARSED_STRING[x] = 0;", + "}", + "", + "%}" + ] + +--For now all categories are included. +--Optimally only the ones that are used should be generated. +cMacros :: String +cMacros = unlines + [ + "LETTER [a-zA-Z]", + "CAPITAL [A-Z]", + "SMALL [a-z]", + "DIGIT [0-9]", + "IDENT [a-zA-Z0-9'_]", + "%START YYINITIAL COMMENT CHAR CHARESC CHAREND STRING ESCAPED", + "%%" + ] + +lexSymbols :: SymEnv -> String +lexSymbols ss = concatMap transSym ss + where + transSym (s,r) = + "\"" ++ s' ++ "\" \t return " ++ r ++ ";\n" + where + s' = escapeChars s + +restOfFlex :: Maybe String -> CF -> SymEnv -> String +restOfFlex inPackage cf env = concat + [ + lexComments inPackage (comments cf), + userDefTokens, + ifC "String" strStates, + ifC "Char" chStates, + ifC "Double" ("{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t " ++ ns ++ "yylval.double_ = atof(yytext); return " ++ nsDefine inPackage "_DOUBLE_" ++ ";\n"), + ifC "Integer" ("{DIGIT}+ \t " ++ ns ++ "yylval.int_ = atoi(yytext); return " ++ nsDefine inPackage "_INTEGER_" ++ ";\n"), + ifC "Ident" ("{LETTER}{IDENT}* \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ nsDefine inPackage "_IDENT_" ++ ";\n"), + "\\n ++" ++ ns ++ "yy_mylinenumber ;\n", + "[ \\t\\r\\n\\f] \t /* ignore white space. */;\n", + ". \t return " ++ nsDefine inPackage "_ERROR_" ++ ";\n", + "%%\n", + footer + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + ns = nsString inPackage + userDefTokens = unlines $ + ["" ++ printRegFlex exp ++ + " \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ sName name ++ ";" + | (name, exp) <- tokenPragmas cf] + where + sName n = case lookup n env of + Just x -> x + Nothing -> n + strStates = unlines --These handle escaped characters in Strings. + [ + "\"\\\"\" \t BEGIN STRING;", + "\\\\ \t BEGIN ESCAPED;", + "\\\" \t " ++ ns ++ "yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return " ++ nsDefine inPackage "_STRING_" ++ ";", + ". \t YY_BUFFER_APPEND(yytext);", + "n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;", + "\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;", + "\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;", + "t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;", + ". \t YY_BUFFER_APPEND(yytext); BEGIN STRING;" + ] + chStates = unlines --These handle escaped characters in Chars. + [ + "\"'\" \tBEGIN CHAR;", + "\\\\ \t BEGIN CHARESC;", + "[^'] \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";", + "n \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\n'; return " ++ nsDefine inPackage "_CHAR_" ++ ";", + "t \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\t'; return " ++ nsDefine inPackage "_CHAR_" ++ ";", + ". \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";", + "\"'\" \t BEGIN YYINITIAL;" + ] + footer = unlines + [ + "int " ++ ns ++ "initialize_lexer(FILE *inp) { yyin = inp; BEGIN YYINITIAL; }", + "int yywrap(void) { return 1; }" + ] + + +lexComments :: Maybe String -> ([(String, String)], [String]) -> String +lexComments inPackage (m,s) = + (unlines (map (lexSingleComment inPackage) s)) + ++ (unlines (map (lexMultiComment inPackage) m)) + +lexSingleComment :: Maybe String -> String -> String +lexSingleComment inPackage c = + "\"" ++ c ++ "\"[^\\n]*\\n ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC single-line comment */;" + +--There might be a possible bug here if a language includes 2 multi-line comments. +--They could possibly start a comment with one character and end it with another. +--However this seems rare. +lexMultiComment :: Maybe String -> (String, String) -> String +lexMultiComment inPackage (b,e) = unlines [ + "\"" ++ b ++ "\" \t BEGIN COMMENT;", + "\"" ++ e ++ "\" \t BEGIN YYINITIAL;", + ". \t /* BNFC multi-line comment */;", + "[\\n] ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC multi-line comment */;" + ---- "\\n ++yy_mylinenumber ;" + ] + + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) diff --git a/formats/cpp/CPPTop.hs b/formats/cpp/CPPTop.hs new file mode 100644 --- /dev/null +++ b/formats/cpp/CPPTop.hs @@ -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 ", + "#include \"Parser.H\"", + "#include \"Printer.H\"", + "#include \"Absyn.H\"", + "", + "int main(int argc, char ** argv)", + "{", + " FILE *input;", + " if (argc > 1) ", + " {", + " input = fopen(argv[1], \"r\");", + " if (!input)", + " {", + " fprintf(stderr, \"Error opening input file.\\n\");", + " exit(1);", + " }", + " }", + " else input = stdin;", + " /* The default entry point is used. For other options see Parser.H */", + " " ++ def ++ " *parse_tree = p" ++ def ++ "(input);", + " if (parse_tree)", + " {", + " printf(\"\\nParse Succesful!\\n\");", + " printf(\"\\n[Abstract Syntax]\\n\");", + " ShowAbsyn *s = new ShowAbsyn();", + " printf(\"%s\\n\\n\", s->show(parse_tree));", + " printf(\"[Linearized Tree]\\n\");", + " PrintAbsyn *p = new PrintAbsyn();", + " printf(\"%s\\n\\n\", p->print(parse_tree));", + " return 0;", + " }", + " return 1;", + "}", + "" + ] + where + def = head (allEntryPoints cf) + +mkHeaderFile cf cats eps env = unlines + [ + "#ifndef PARSER_HEADER_FILE", + "#define PARSER_HEADER_FILE", + "", + concatMap mkForwardDec cats, + "typedef union", + "{", + " int int_;", + " char char_;", + " double double_;", + " char* string_;", + (concatMap mkVar cats) ++ "} YYSTYPE;", + "", + "#define _ERROR_ 258", + mkDefines (259 :: Int) env, + "extern YYSTYPE yylval;", + concatMap mkFunc eps, + "", + "#endif" + ] + where + mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n" + mkForwardDec _ = "" + mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n" + mkVar _ = "" + mkDefines n [] = mkString n + mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) + mkString n = if isUsedCat cf "String" + then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) + else mkChar n + mkChar n = if isUsedCat cf "Char" + then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1) + else mkInteger n + mkInteger n = if isUsedCat cf "Integer" + then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1) + else mkDouble n + mkDouble n = if isUsedCat cf "Double" + then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1) + else mkIdent n + mkIdent n = if isUsedCat cf "Ident" + then ("#define _IDENT_ " ++ show n ++ "\n") + else "" + mkFunc s | (normCat s == s) = (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(FILE *inp);\n" + mkFunc _ = "" diff --git a/formats/cpp/RegToFlex.hs b/formats/cpp/RegToFlex.hs new file mode 100644 --- /dev/null +++ b/formats/cpp/RegToFlex.hs @@ -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 prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["[^.]"]) + RChar c -> prPrec i 3 (prt 0 [mkEsc [c]]) + RAlts str -> prPrec i 3 (concat [["["], prt 0 $ mkEsc str, ["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) $ mkEsc str)) + RDigit -> prPrec i 3 (concat [["{DIGIT}"]]) + RLetter -> prPrec i 3 (concat [["{LETTER}"]]) + RUpper -> prPrec i 3 (concat [["{CAPITAL}"]]) + RLower -> prPrec i 3 (concat [["{SMALL}"]]) + RAny -> prPrec i 3 (concat [["."]]) + +-- Handle special characters in regular expressions. +mkEsc :: String -> String +mkEsc = concatMap escChar + where escChar c + | c `elem` "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" = '\\':[c] + | otherwise = [c] diff --git a/formats/cpp_stl/CFtoBisonSTL.hs b/formats/cpp_stl/CFtoBisonSTL.hs new file mode 100644 --- /dev/null +++ b/formats/cpp_stl/CFtoBisonSTL.hs @@ -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 ", + "#include ", + "#include ", + "#include ", + "#include \"Absyn.H\"", + "typedef struct yy_buffer_state *YY_BUFFER_STATE;", + "int yyparse(void);", + "int yylex(void);", + "YY_BUFFER_STATE " ++ ns ++ "yy_scan_string(const char *str);", + "void " ++ ns ++ "yy_delete_buffer(YY_BUFFER_STATE buf);", + "int " ++ ns ++ "yy_mylinenumber;", --- hack to get line number. AR 2006 + "int " ++ ns ++ "initialize_lexer(FILE * inp);", + "int " ++ ns ++ "yywrap(void)", + "{", + " return 1;", + "}", + "void " ++ ns ++ "yyerror(const char *str)", + "{", + " std::cout << \"line \" << " ++ ns ++ "yy_mylinenumber << std::endl ;", + " fprintf(stderr,\"error: %s\\n\",str);", + "}", + "", + definedRules cf, + nsStart inPackage, + unlines $ map (parseMethod inPackage name) (allCatsIdNorm cf ++ positionCats cf), -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug. + nsEnd inPackage, + "%}" + ] + where + ns = nsString inPackage + +definedRules :: CF -> String +definedRules cf@((pr,_),_) = + unlines [ rule f xs e | FunDef f xs e <- pr ] + where + ctx = buildContext cf + + list = LC (const "[]") (\t -> "List" ++ unBase t) + where + unBase (ListT t) = unBase t + unBase (BaseT x) = normCat x + + rule f xs e = + case checkDefinition' list ctx f xs e of + Bad err -> error $ "Panic! This should have been caught already:\n" ++ err + Ok (args,(e',t)) -> unlines + [ cppType t ++ " " ++ f ++ "_ (" ++ + concat (intersperse ", " $ map cppArg args) ++ ") {" + , " return " ++ cppExp e' ++ ";" + , "}" + ] + where + + cppType :: Base -> String + cppType (ListT (BaseT x)) = "List" ++ normCat x ++ " *" + cppType (ListT t) = cppType t ++ " *" + cppType (BaseT x) + | isToken x ctx = "String" + | otherwise = normCat x ++ " *" + + cppArg :: (String, Base) -> String + cppArg (x,t) = cppType t ++ " " ++ x ++ "_" + + cppExp :: Exp -> String + cppExp (App "[]" []) = "0" + cppExp (App x []) + | elem x xs = x ++ "_" -- argument + cppExp (App t [e]) + | isToken t ctx = cppExp e + cppExp (App x es) + | isUpper (head x) = call ("new " ++ x) es + | otherwise = call (x ++ "_") es + cppExp (LitInt n) = show n + cppExp (LitDouble x) = show x + cppExp (LitChar c) = show c + cppExp (LitString s) = show s + + call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")" + + +--This generates a parser method for each entry point. +parseMethod :: Maybe String -> String -> Cat -> String +parseMethod inPackage name cat = + -- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm + -- then "" + -- else + unlines + [ + "static " ++ cat' ++ "*" +++ (resultName cat') +++ "= 0;", + cat' ++"* p" ++ cat' ++ "(FILE *inp)", + "{", + " " ++ ns ++ "yy_mylinenumber = 1;", -- O.F. + " " ++ ns ++ "initialize_lexer(inp);", + " if (yyparse())", + " { /* Failure */", + " return 0;", + " }", + " else", + " { /* Success */", + " return" +++ (resultName cat') ++ ";", + " }", + "}", + cat' ++"* p" ++ cat' ++ "(const char *str)", + "{", + " YY_BUFFER_STATE buf;", + " int result;", + " " ++ ns ++ "yy_mylinenumber = 1;", + " " ++ ns ++ "initialize_lexer(0);", + " buf = " ++ ns ++ "yy_scan_string(str);", + " result = yyparse();", + " " ++ ns ++ "yy_delete_buffer(buf);", + " if (result)", + " { /* Failure */", + " return 0;", + " }", + " else", + " { /* Success */", + " return" +++ (resultName cat') ++ ";", + " }", + "}" + ] + where + cat' = identCat (normCat cat) + ns = nsString inPackage + + +--The union declaration is special to Bison/Yacc and gives the type of yylval. +--For efficiency, we may want to only include used categories here. +union :: Maybe String -> [Cat] -> String +union inPackage cats = unlines + [ + "%union", + "{", + " int int_;", + " char char_;", + " double double_;", + " char* string_;", + concatMap mkPointer cats, + "}" + ] + where --This is a little weird because people can make [Exp2] etc. + mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion. + " " ++ scope ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n" + mkPointer s | normCat s == s = --normal cat + " " ++ scope ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n" + mkPointer s = "" + scope = nsScope inPackage + +--declares non-terminal types. +declarations :: CF -> String +declarations cf = concatMap (typeNT cf) (positionCats cf ++ allCats cf) + where --don't define internal rules + typeNT cf nt | (isPositionCat cf nt || rulesForCat cf nt /= []) = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n" + typeNT cf nt = "" + +--declares terminal types. +tokens :: [UserDef] -> SymEnv -> String +tokens user ts = concatMap (declTok user) ts + where + declTok u (s,r) = if elem s u + then "%token " ++ r ++ " // " ++ s ++ "\n" + else "%token " ++ r ++ " // " ++ s ++ "\n" + +specialToks :: CF -> String +specialToks cf = concat [ + ifC "String" "%token _STRING_\n", + ifC "Char" "%token _CHAR_\n", + ifC "Integer" "%token _INTEGER_\n", + ifC "Double" "%token _DOUBLE_\n", + ifC "Ident" "%token _IDENT_\n" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + +--The following functions are a (relatively) straightforward translation +--of the ones in CFtoHappy.hs +rulesForBison :: Bool -> Maybe String -> String -> CF -> SymEnv -> Rules +rulesForBison ln inPackage name cf env = (map mkOne $ ruleGroups cf) ++ posRules where + mkOne (cat,rules) = constructRule ln inPackage cf env rules cat + posRules = map mkPos $ positionCats cf + mkPos cat = (cat, [(maybe cat id (lookup cat env), + "$$ = new " ++ cat ++ "($1," ++ nsString inPackage ++ "yy_mylinenumber) ; YY_RESULT_" ++ + cat ++ "_= $$ ;")]) + +-- For every non-terminal, we construct a set of rules. +constructRule :: + Bool -> Maybe String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule ln inPackage cf env rules nt = + (nt,[(p,(generateAction ln inPackage nt (ruleName r) b m) +++ result) | + r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True,revSepListRule r0) + else (False,r0), + let (p,m) = generatePatterns cf env r b]) + where + ruleName r = case funRule r of + ---- "(:)" -> identCat nt + ---- "(:[])" -> identCat nt + z -> z + revs = reversibleCats cf + eps = allEntryPoints cf + isEntry nt = if elem nt eps then True else False + result = if isEntry nt then (nsScope inPackage ++ resultName (normCat (identCat nt))) ++ "= $$;" else "" + +-- Generates a string containing the semantic action. +generateAction :: Bool -> Maybe String -> NonTerminal -> Fun -> Bool -> [(MetaVar,Bool)] -> Action +generateAction ln inPackage cat f b mbs = + reverses ++ + if isCoercion f + then "$$ = " ++ (unwords ms) ++ ";" + else if (f == "[]") + then concat ["$$ = ","new ", scope, identCatV cat, "();"] + else if (f == "(:[])") + then concat ["$$ = ","new ", scope, identCatV cat, "() ; $$->push_back($1);"] + else if (f == "(:)" && b) + then "$1->push_back("++ lastms ++ ") ; $$ = $1 ;" + else if (f == "(:)") + then lastms ++ "->push_back($1) ; $$ = " ++ lastms ++ " ;" ---- not left rec + else if isDefinedRule f + then concat ["$$ = ", scope, f, "_", "(", concat $ intersperse ", " ms', ");" ] + else concat + ["$$ = ", "new ", scope, f, "(", (concat (intersperse ", " ms')), ");" ++ addLn ln] + where + ms = map fst mbs + ms' = ms + addLn ln = if ln then " $$->line_number = " ++ nsString inPackage ++ "yy_mylinenumber;" else "" -- O.F. + lastms = last ms + identCatV cat = reverse $ dropWhile isDigit $ reverse $ identCat cat + reverses = unwords [ + "std::reverse(" ++ m ++"->begin(),"++m++"->end()) ;" | + (m,True) <- mbs] + scope = nsScope inPackage + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal +generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)]) +generatePatterns cf env r revv = case rhsRule r of + [] -> ("/* empty */",[]) + its -> (unwords (map mkIt its), metas its) + where + mkIt i = case i of + Left c -> case lookup c env of + Just x | not (isPositionCat cf c) -> x + _ -> typeName (identCat c) + Right s -> case lookup s env of + Just x -> x + Nothing -> s + metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its] + + -- notice: reversibility with push_back vectors is the opposite + -- of right-recursive lists! + revert c = (head c == '[') && + not (isConsFun (funRule r)) && notElem c revs + revs = reversibleCats cf + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. + +prRules :: Rules -> String +prRules [] = [] +prRules ((nt, []):rs) = prRules rs --internal rule +prRules ((nt,((p,a):ls)):rs) = + (unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ ", a , "}"])]) ++ pr ls + +--Some helper functions. +resultName :: String -> String +resultName s = "YY_RESULT_" ++ s ++ "_" + +--slightly stronger than the NamedVariable version. +varName :: String -> String +varName s = (map toLower (identCat s)) ++ "_" + +typeName :: String -> String +typeName "Ident" = "_IDENT_" +typeName "String" = "_STRING_" +typeName "Char" = "_CHAR_" +typeName "Integer" = "_INTEGER_" +typeName "Double" = "_DOUBLE_" +typeName x = x + + diff --git a/formats/cpp_stl/CFtoCVisitSkelSTL.hs b/formats/cpp_stl/CFtoCVisitSkelSTL.hs new file mode 100644 --- /dev/null +++ b/formats/cpp_stl/CFtoCVisitSkelSTL.hs @@ -0,0 +1,148 @@ +{- + BNF Converter: C++ Skeleton generation + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C++ Skeleton functions. + + The generated files use the Visitor design pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 9 August, 2003 + + Modified : 29 August, 2006 Aarne Ranta + + + ************************************************************** +-} + +module CFtoCVisitSkelSTL (cf2CVisitSkel) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import 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 ++ ");") + diff --git a/formats/cpp_stl/CFtoSTLAbs.hs b/formats/cpp_stl/CFtoSTLAbs.hs new file mode 100644 --- /dev/null +++ b/formats/cpp_stl/CFtoSTLAbs.hs @@ -0,0 +1,275 @@ +{- + BNF Converter: C++ abstract syntax generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the C++ Abstract Syntax + tree classes. It generates both a Header file + and an Implementation file, and uses the Visitor + design pattern. It uses STL (Standard Template Library). + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 4 August, 2003 + + Modified : 22 May, 2004 / Antti-Juhani Kaijanaho + 29 August, 2006 / Aarne Ranta + + ************************************************************** +-} + +module CFtoSTLAbs (cf2CPPAbs) where + +import OOAbstract +import CF +import Utils((+++),(++++)) +import NamedVariables +import 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", + "#include", + "", + "//C++ Abstract Syntax Interface generated by the BNF Converter.", + nsStart inPackage, + "/******************** TypeDef Section ********************/", + "", + unlines ["typedef " ++ d ++ " " ++ c ++ ";" | (c,d) <- basetypes], + "", + unlines ["typedef std::string " ++ s ++ ";" | s <- tokentypes cf], + "", + "/******************** Forward Declarations ********************/", + "", + unlines ["class " ++ c ++ ";" | c <- classes, notElem c (defineds cf)], + "", + "/******************** Visitor Interfaces ********************/", + prVisitor cf, + "", + prVisitable, + "", + "/******************** Abstract Syntax Classes ********************/", + "", + unlines [prAbs ln c | c <- absclasses cf], + "", + unlines [prCon (c,r) | (c,rs) <- signatures cf, r <- rs], + "", + unlines [prList c | c <- listtypes cf], + nsEnd inPackage, + "#endif" + ] + where + classes = allClasses cf + hdef = nsDefine inPackage "ABSYN_HEADER" + +-- auxiliaries + +prVisitable :: String +prVisitable = unlines [ + "class Visitable", + "{", + " public:", + -- all classes with virtual methods require a virtual destructor + " virtual ~Visitable() {}", + " virtual void accept(Visitor *v) = 0;", + "};" + ] + +prVisitor :: CAbs -> String +prVisitor cf = unlines [ + "class Visitor", + "{", + "public:", + " virtual ~Visitor() {}", + unlines + [" virtual void visit"++c++"("++c++" *p) = 0;" | c <- allClasses cf, + notElem c (defineds cf)], + "", + unlines + [" virtual void visit"++c++"(" ++c++" x) = 0;" | c <- allNonClasses cf], + "};" + ] + +prAbs :: Bool -> Cat -> String +prAbs ln c = unlines [ + "class " ++c++ " : public Visitable", + "{", + "public:", + " virtual " ++ c ++ " *clone() const = 0;", + if ln then " int line_number;" else "", + "};" + ] + +prCon :: (Cat,CAbsRule) -> String +prCon (c,(f,cs)) = unlines [ + "class " ++f++ " : public " ++ c, + "{", + "public:", + unlines + [" "++ typ +++ pointerIf st var ++ ";" | (typ,st,var) <- cs], + " " ++ f ++ "(const " ++ f ++ " &);", + " " ++ f ++ " &operator=(const " ++f++ " &);", + " " ++ f ++ "(" ++ conargs ++ ");", + -- Typ *p1, PIdent *p2, ListStm *p3); + " ~" ++f ++ "();", + " virtual void accept(Visitor *v);", + " virtual " ++f++ " *clone() const;", + " void swap(" ++f++ " &);", + "};" + ] + where + conargs = concat $ intersperse ", " + [x +++ pointerIf st ("p" ++ show i) | ((x,st,_),i) <- zip cs [1..]] + +prList :: (Cat,Bool) -> String +prList (c,b) = unlines [ + "class " ++c++ " : public Visitable, public std::vector<" ++bas++ ">", + "{", + "public:", + " virtual void accept(Visitor *v);", + " virtual " ++ c ++ " *clone() const;", + "};" + ] + where + bas = drop 4 c ++ -- drop List + if b then "*" else "" + + +-- **** Implementation (.C) File Functions **** -- + +mkCFile :: Maybe String -> CAbs -> String +mkCFile inPackage cf = unlines $ [ + "//C++ Abstract Syntax Implementation generated by the BNF Converter.", + "#include ", + "#include ", + "#include ", + "#include ", + "#include \"Absyn.H\"", + nsStart inPackage, + unlines [prConC r | (_,rs) <- signatures cf, r <- rs], + unlines [prListC c | (c,_) <- listtypes cf], + nsEnd inPackage + ] + +prConC :: CAbsRule -> String +prConC fcs@(f,cs) = unlines [ + "/******************** " ++ f ++ " ********************/", + prConstructorC fcs, + prCopyC fcs, + prDestructorC fcs, + prAcceptC f, + prCloneC f, + "" + ] + +prListC :: Cat -> String +prListC c = unlines [ + "/******************** " ++ c ++ " ********************/", + "", + prAcceptC c, + "", + prCloneC c + ] + + +--The standard accept function for the Visitor pattern +prAcceptC :: Cat -> String +prAcceptC ty = unlines [ + "void " ++ ty ++ "::accept(Visitor *v)", + "{", + " v->visit" ++ ty ++ "(this);", + "}" + ] + +--The cloner makes a new deep copy of the object +prCloneC :: Cat -> String +prCloneC c = unlines [ + c +++ "*" ++ c ++ "::clone() const", + "{", + " return new" +++ c ++ "(*this);", + "}" + ] + +--The constructor assigns the parameters to the corresponding instance variables. +prConstructorC :: CAbsRule -> String +prConstructorC (f,cs) = unlines [ + f ++ "::" ++ f ++ "(" ++ conargs ++ ")", + "{", + unlines [" " ++ c ++ " = " ++ p ++ ";" | (c,p) <- zip cvs pvs], + "}" + ] + where + cvs = [c | (_,_,c) <- cs] + pvs = ["p" ++ show i | ((x,st,_),i) <- zip cs [1..]] + conargs = concat $ intersperse ", " + [x +++ pointerIf st v | ((x,st,_),v) <- zip cs pvs] + + +--Copy constructor and copy assignment +prCopyC :: CAbsRule -> String +prCopyC (c,cs) = unlines [ + c ++ "::" ++ c ++ "(const" +++ c +++ "& other)", + "{", + unlines [" " ++ cv ++ " = other." ++ cloneIf st cv ++ ";" | (_,st,cv) <- cs], + "}", + "", + c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other)", + "{", + " " ++ c +++ "tmp(other);", + " swap(tmp);", + " return *this;", + "}", + "", + "void" +++ c ++ "::swap(" ++ c +++ "& other)", + "{", + unlines [" std::swap(" ++ cv ++ ", other." ++ cv ++ ");" | (_,_,cv) <- cs], + "}" + ] + where + cloneIf st cv = if st then (cv ++ "->clone()") else cv + +--The destructor deletes all a class's members. +prDestructorC :: CAbsRule -> String +prDestructorC (c,cs) = unlines [ + c ++ "::~" ++ c ++"()", + "{", + unlines [" delete(" ++ cv ++ ");" | (_,isPointer,cv) <- cs, isPointer], + "}" + ] diff --git a/formats/cpp_stl/CFtoSTLPrinter.hs b/formats/cpp_stl/CFtoSTLPrinter.hs new file mode 100644 --- /dev/null +++ b/formats/cpp_stl/CFtoSTLPrinter.hs @@ -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 ", + "#include ", + "#include ", + "", + nsStart inPackage, + "/* Certain applications may improve performance by changing the buffer size */", + "#define " ++ nsDefine inPackage "BUFFER_INITIAL" ++ " 2000", + "/* You may wish to change _L_PAREN or _R_PAREN */", + "#define " ++ nsDefine inPackage "_L_PAREN" ++ " '('", + "#define " ++ nsDefine inPackage "_R_PAREN" ++ " ')'", + "", + "class PrintAbsyn : public Visitor", + "{", + " protected:", + " int _n_, _i_;", + " /* The following are simple heuristics for rendering terminals */", + " /* You may wish to change them */", + " void render(Char c);", + " void render(String s);", + " void indent(void);", + " void backup(void);", + " public:", + " PrintAbsyn(void);", + " ~PrintAbsyn(void);", + " char* print(Visitable* v);" + ] + hdef = nsDefine inPackage "PRINTER_HEADER" + classFooter = unlines $ + [ + " void visitInteger(Integer i);", + " void visitDouble(Double d);", + " void visitChar(Char c);", + " void visitString(String s);", + " void visitIdent(String s);" + ] ++ [" void visit" ++ t ++ "(String s);" | t <- tokenNames cf] ++ + [ + " protected:", + " void inline bufAppend(const char* s)", + " {", + " int len = strlen(s);", + " while (cur_ + len > buf_size)", + " {", + " buf_size *= 2; /* Double the buffer size */", + " resizeBuffer();", + " }", + " for(int n = 0; n < len; n++)", + " {", + " buf_[cur_ + n] = s[n];", + " }", + " cur_ += len;", + " buf_[cur_] = 0;", + " }", + " void inline bufAppend(const char c)", + " {", + " if (cur_ == buf_size)", + " {", + " buf_size *= 2; /* Double the buffer size */", + " resizeBuffer();", + " }", + " buf_[cur_] = c;", + " cur_++;", + " buf_[cur_] = 0;", + " }", + " void inline bufReset(void)", + " {", + " cur_ = 0;", + " buf_size = " ++ nsDefine inPackage "BUFFER_INITIAL" ++ ";", + " resizeBuffer();", + " memset(buf_, 0, buf_size);", + " }", + " void inline resizeBuffer(void)", + " {", + " char* temp = (char*) malloc(buf_size);", + " if (!temp)", + " {", + " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");", + " exit(1);", + " }", + " if (buf_)", + " {", + " strcpy(temp, buf_);", + " free(buf_);", + " }", + " buf_ = temp;", + " }", + " char *buf_;", + " int cur_, buf_size;", + "};", + "" + ] + showHeader = unlines + [ + "", + "class ShowAbsyn : public Visitor", + "{", + " public:", + " ShowAbsyn(void);", + " ~ShowAbsyn(void);", + " char* show(Visitable* v);" + ] + footer = unlines + [ + nsEnd inPackage, + "", + "#endif" + ] + +--Prints all the required method names and their parameters. +prDataH :: (Cat, [Rule]) -> String +prDataH (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then concat [" void visit", cl, "(", cl, "* p);\n"] + else abstract ++ (concatMap prRuleH rules) + where + cl = identCat (normCat cat) + abstract = case lookup cat rules of + Just x -> "" + Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n" + +--Prints all the methods to visit a rule. +prRuleH :: Rule -> String +prRuleH (fun, (c, cats)) | isProperLabel fun = concat + [" void visit", fun, "(", fun, " *p);\n"] +prRuleH (fun, cats) = "" + +{- **** Implementation (.C) File Methods **** -} + +--This makes the .C file by a similar method. +mkCFile :: Maybe String -> CF -> [(Cat,[Rule])] -> String +mkCFile inPackage cf groups = concat + [ + header, + nsStart inPackage ++ "\n", + prRender, + printEntries, + concatMap (prPrintData inPackage cf user) groups, + printBasics, + printTokens, + showEntries, + concatMap (prShowData user) groups, + showBasics, + showTokens, + nsEnd inPackage ++ "\n" + ] + where + user0 = fst (unzip (tokenPragmas cf)) + (userPos,user) = partition (isPositionCat cf) user0 + header = unlines + [ + "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/", + "", + "#include ", + "#include \"Printer.H\"", + "" + ] + printEntries = unlines + [ + "PrintAbsyn::PrintAbsyn(void)", + "{", + " _i_ = 0; _n_ = 0;", + " buf_ = 0;", + " bufReset();", + "}", + "", + "PrintAbsyn::~PrintAbsyn(void)", + "{", + "}", + "", + "char* PrintAbsyn::print(Visitable *v)", + "{", + " _i_ = 0; _n_ = 0;", + " bufReset();", + " v->accept(this);", + " return buf_;", + "}" + ] + showEntries = unlines + [ + "ShowAbsyn::ShowAbsyn(void)", + "{", + " buf_ = 0;", + " bufReset();", + "}", + "", + "ShowAbsyn::~ShowAbsyn(void)", + "{", + "}", + "", + "char* ShowAbsyn::show(Visitable *v)", + "{", + " bufReset();", + " v->accept(this);", + " return buf_;", + "}" + ] + printBasics = unlines + [ + "void PrintAbsyn::visitInteger(Integer i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%d\", i);", + " bufAppend(tmp);", + "}", + "void PrintAbsyn::visitDouble(Double d)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%g\", d);", + " bufAppend(tmp);", + "}", + "void PrintAbsyn::visitChar(Char c)", + "{", + " bufAppend('\\'');", + " bufAppend(c);", + " bufAppend('\\'');", + "}", + "void PrintAbsyn::visitString(String s_)", + "{", + " const char *s = s_.c_str() ;", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "void PrintAbsyn::visitIdent(String s_)", + "{", + " const char *s = s_.c_str() ;", + " render(s);", + "}", + "" + ] + + printTokens = unlines + [unlines [ + "void PrintAbsyn::visit" ++ t ++ "(String s_)", + "{", + " const char *s = s_.c_str() ;", + " render(s);", + "}", + "" + ] | t <- tokenNames cf + ] + + showBasics = unlines + [ + "void ShowAbsyn::visitInteger(Integer i)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%d\", i);", + " bufAppend(tmp);", + "}", + "void ShowAbsyn::visitDouble(Double d)", + "{", + " char tmp[16];", + " sprintf(tmp, \"%g\", d);", + " bufAppend(tmp);", + "}", + "void ShowAbsyn::visitChar(Char c)", + "{", + " bufAppend('\\'');", + " bufAppend(c);", + " bufAppend('\\'');", + "}", + "void ShowAbsyn::visitString(String s_)", + "{", + " const char *s = s_.c_str() ;", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "void ShowAbsyn::visitIdent(String s_)", + "{", + " const char *s = s_.c_str() ;", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "" + ] + + showTokens = unlines + [unlines [ + "void ShowAbsyn::visit" ++ t ++ "(String s_)", + "{", + " const char *s = s_.c_str() ;", + " bufAppend('\\\"');", + " bufAppend(s);", + " bufAppend('\\\"');", + "}", + "" + ] | t <- tokenNames cf + ] + + +{- **** Pretty Printer Methods **** -} + +--Generates methods for the Pretty Printer +prPrintData :: Maybe String -> CF -> [UserDef] -> (Cat, [Rule]) -> String +prPrintData inPackage cf user (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then unlines + [ + "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")", + "{", + " for ("++ cl ++"::const_iterator i = " ++ + vname++"->begin() ; i != " ++vname ++"->end() ; ++i)", + " {", + if isBase user vname + then " visit" ++ baseName cl ++ "(*i) ;" + else " (*i)->accept(this);", + optsep, + " }", + "}", + "" + ] --Not a list: + -- a position token + else if isPositionCat cf cat then unlines [ + "void PrintAbsyn::visit" ++ cat ++ "(" ++ cat ++ "* p)", + "{", + " visitIdent(p->string_);", + "}" + ] + else abstract ++ (concatMap (prPrintRule inPackage user) rules) + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl ++ "_" + visitMember = if isBasic user member + then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" + else " " ++ vname ++ "->" ++ member ++ "->accept(this);" + sep = if (length sep') == 1 + then "'" ++ (escapeChars sep') ++ "'" + else "\"" ++ (escapeChars sep') ++ "\"" + sep' = getCons rules + optsep = + (if hasOneFunc rules + then " if (i != " ++ vname ++ "->end() - 1) " + else " " + ) ++ "render(" ++ sep ++ ");" + abstract = case lookup cat rules of + Just x -> "" + Nothing -> "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl ++ "*p) {} //abstract class\n\n" + +--Pretty Printer methods for a rule. +prPrintRule :: Maybe String -> [UserDef] -> Rule -> String +prPrintRule inPackage user r@(fun, (c, cats)) | isProperLabel fun = unlines + [ + "void PrintAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")", + "{", + " int oldi = _i_;", + lparen, + cats', + rparen, + " _i_ = oldi;", + "}\n" + ] + where + p = precRule r + (lparen, rparen) = + (" if (oldi > " ++ (show p) ++ ") render(" ++ nsDefine inPackage "_L_PAREN" ++ ");\n", + " if (oldi > " ++ (show p) ++ ") render(" ++ nsDefine inPackage "_R_PAREN" ++ ");\n") + cats' = (concatMap (prPrintCat user fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats))) + fnm = "p" --old names could cause conflicts + getPrec (Right s) = 0 + getPrec (Left c) = precCat c +prPrintRule _ _ (fun, cats) = "" + +--This goes on to recurse to the instance variables. +prPrintCat :: [UserDef] -> String -> (Either Cat String, Int) -> String +prPrintCat user fnm (c,p) = case c of + (Right t) -> " render(" ++ t' ++ ");\n" + where + t' = if length t == 1 + then "'" ++ (escapeChars t) ++ "'" + else "\"" ++ (escapeChars t) ++ "\"" + (Left nt) -> if isBasic user nt + then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" + else if "list" `isPrefixOf` nt + then " if(" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}" + else " " ++ accept ++ "\n" + where + accept = if nt == "#_" --Internal category + then "/* Internal Category */\n" + else (setI p) ++ fnm ++ "->" ++ nt ++ "->accept(this);" + +{- **** Abstract Syntax Tree Printer **** -} + +--This prints the functions for Abstract Syntax tree printing. +prShowData :: [UserDef] -> (Cat, [Rule]) -> String +prShowData user (cat, rules) = + if "List" `isPrefixOf` (identCat cat) + then unlines + [ + "void ShowAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")", + "{", + " for ("++ cl ++"::const_iterator i = " ++ + vname++"->begin() ; i != " ++vname ++"->end() ; ++i)", + " {", + if isBase user vname + then " visit" ++ baseName cl ++ "(*i) ;" + else " (*i)->accept(this);", + " if (i != " ++ vname ++ "->end() - 1) bufAppend(\", \");", + " }", + "}", + "" + ] --Not a list: + else abstract ++ (concatMap (prShowRule user) rules) + where + cl = identCat (normCat cat) + ecl = identCat (normCatOfList cat) + vname = map toLower cl + member = map toLower ecl ++ "_" + visitMember = if isBasic user member + then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");" + else " " ++ vname ++ "->" ++ member ++ "->accept(this);" + abstract = case lookup cat rules of + Just x -> "" + Nothing -> "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ "* p) {} //abstract class\n\n" + +--This prints all the methods for Abstract Syntax tree rules. +prShowRule :: [UserDef] -> Rule -> String +prShowRule user (fun, (c, cats)) | isProperLabel fun = concat + [ + "void ShowAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")\n", + "{\n", + lparen, + " bufAppend(\"" ++ fun ++ "\");\n", + optspace, + cats', + rparen, + "}\n" + ] + where + (optspace, lparen, rparen) = if allTerms cats + then ("","","") + else (" bufAppend(' ');\n", " bufAppend('(');\n"," bufAppend(')');\n") + cats' = if allTerms cats + then "" + else concat (insertSpaces (map (prShowCat user fnm) (fixOnes (numVars [] cats)))) + insertSpaces [] = [] + insertSpaces (x:[]) = [x] + insertSpaces (x:xs) = if x == "" + then insertSpaces xs + else (x : [" bufAppend(' ');\n"]) ++ (insertSpaces xs) + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs + fnm = "p" --other names could cause conflicts +prShowRule _ (fun, cats) = "" + +--This recurses to the instance variables of a class. +prShowCat :: [UserDef] -> String -> Either Cat String -> String +prShowCat user fnm c = + case c of + (Right t) -> "" + (Left nt) -> + if isBasic user nt + then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n" + else if nt == "#_" --internal category + then "/* Internal Category */\n" + else if ((normCat nt) /= nt) + then accept + else concat + [ + " bufAppend('[');\n", + " if (" ++ fnm ++ "->" ++ nt ++ ")" ++ accept, + " bufAppend(']');\n" + ] + where + accept = " " ++ fnm ++ "->" ++ nt ++ "->accept(this);\n" + +{- **** Helper Functions Section **** -} + + +--Just checks if something is a basic or user-defined type. +--This is because you don't -> a basic non-pointer type. +isBasic :: [UserDef] -> String -> Bool +isBasic user v = + if elem (init v) user' + then True + else if "integer_" `isPrefixOf` v then True + else if "char_" `isPrefixOf` v then True + else if "string_" `isPrefixOf` v then True + else if "double_" `isPrefixOf` v then True + else if "ident_" `isPrefixOf` v then True + else False + where + user' = map (map toLower) user + +-- from listident to ident_ +isBase user vn = isBasic user (baseName vn ++ "_") +-- from ListIdent to Ident +baseName cl = drop 4 cl + + +--The visit-function name of a basic type +funName :: String -> String +funName v = + if "integer_" `isPrefixOf` v then "Integer" + else if "char_" `isPrefixOf` v then "Char" + else if "string_" `isPrefixOf` v then "String" + else if "double_" `isPrefixOf` v then "Double" + else if "ident_" `isPrefixOf` v then "Ident" + else "Ident" --User-defined type + +--Just sets the coercion level for parentheses in the Pretty Printer. +setI :: Int -> String +setI n = "_i_ = " ++ (show n) ++ "; " + +--Gets the separator for a list. +getCons :: [Rule] -> String +getCons ((f, (c, cats)):rs) = + if isConsFun f + then seper cats + else getCons rs + where + seper [] = [] + seper ((Right x):xs) = x + seper ((Left x):xs) = seper xs + +--Checks if the list has a non-empty rule. +hasOneFunc :: [Rule] -> Bool +hasOneFunc [] = False +hasOneFunc ((f, (c, cats)):rs) = + if (isOneFun f) + then True + else hasOneFunc rs + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars [] = [] +escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs)) +escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs)) +escapeChars (x:xs) = x : (escapeChars xs) + +--An extremely simple renderer for terminals. +prRender :: String +prRender = unlines + [ + "//You may wish to change render", + "void PrintAbsyn::render(Char c)", + "{", + " if (c == '{')", + " {", + " bufAppend('\\n');", + " indent();", + " bufAppend(c);", + " _n_ = _n_ + 2;", + " bufAppend('\\n');", + " indent();", + " }", + " else if (c == '(' || c == '[')", + " bufAppend(c);", + " else if (c == ')' || c == ']')", + " {", + " backup();", + " bufAppend(c);", + " bufAppend(' ');", + " }", + " else if (c == '}')", + " {", + " _n_ = _n_ - 2;", + " backup();", + " backup();", + " bufAppend(c);", + " bufAppend('\\n\');", + " indent();", + " }", + " else if (c == ',')", + " {", + " backup();", + " bufAppend(c);", + " bufAppend(' ');", + " }", + " else if (c == ';')", + " {", + " backup();", + " bufAppend(c);", + " bufAppend('\\n');", + " indent();", + " }", + " else if (c == 0) return;", + " else", + " {", + " bufAppend(c);", + " bufAppend(' ');", + " }", + "}", + "void PrintAbsyn::render(String s_)", + "{", + " const char *s = s_.c_str() ;", + " if(strlen(s) > 0)", + " {", + " bufAppend(s);", + " bufAppend(' ');", + " }", + "}", + "void PrintAbsyn::indent()", + "{", + " int n = _n_;", + " while (n > 0)", + " {", + " bufAppend(' ');", + " n--;", + " }", + "}", + "void PrintAbsyn::backup()", + "{", + " if (buf_[cur_ - 1] == ' ')", + " {", + " buf_[cur_ - 1] = 0;", + " cur_--;", + " }", + "}" + ] diff --git a/formats/cpp_stl/STLTop.hs b/formats/cpp_stl/STLTop.hs new file mode 100644 --- /dev/null +++ b/formats/cpp_stl/STLTop.hs @@ -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 ", + "#include \"Parser.H\"", + "#include \"Printer.H\"", + "#include \"Absyn.H\"", + "", + "int main(int argc, char ** argv)", + "{", + " FILE *input;", + " if (argc > 1) ", + " {", + " input = fopen(argv[1], \"r\");", + " if (!input)", + " {", + " fprintf(stderr, \"Error opening input file.\\n\");", + " exit(1);", + " }", + " }", + " else input = stdin;", + " /* The default entry point is used. For other options see Parser.H */", + " " ++ scope ++ def ++ " *parse_tree = " ++ scope ++ "p" ++ def ++ "(input);", + " if (parse_tree)", + " {", + " printf(\"\\nParse Succesful!\\n\");", + " printf(\"\\n[Abstract Syntax]\\n\");", + " " ++ scope ++ "ShowAbsyn *s = new " ++ scope ++ "ShowAbsyn();", + " printf(\"%s\\n\\n\", s->show(parse_tree));", + " printf(\"[Linearized Tree]\\n\");", + " " ++ scope ++ "PrintAbsyn *p = new " ++ scope ++ "PrintAbsyn();", + " printf(\"%s\\n\\n\", p->print(parse_tree));", + " return 0;", + " }", + " return 1;", + "}", + "" + ] + where + def = head (allEntryPoints cf) + scope = nsScope inPackage + +mkHeaderFile inPackage cf cats eps env = unlines + [ + "#ifndef " ++ hdef, + "#define " ++ hdef, + "", + "#include", + "#include", + "", + nsStart inPackage, + concatMap mkForwardDec cats, + "typedef union", + "{", + " int int_;", + " char char_;", + " double double_;", + " char* string_;", + (concatMap mkVar cats) ++ "} YYSTYPE;", + "", + concatMap mkFuncs eps, + nsEnd inPackage, + "", + "#define " ++ nsDefine inPackage "_ERROR_" ++ " 258", + mkDefines (259 :: Int) env, + "extern " ++ nsScope inPackage ++ "YYSTYPE " ++ nsString inPackage ++ "yylval;", + "", + "#endif" + ] + where + hdef = nsDefine inPackage "PARSER_HEADER_FILE" + mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n" + mkForwardDec _ = "" + mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n" + mkVar _ = "" + mkDefines n [] = mkString n + mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) -- "nsDefine inPackage s" not needed (see cf2flex::makeSymEnv) + mkString n = if isUsedCat cf "String" + then ("#define " ++ nsDefine inPackage "_STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) + else mkChar n + mkChar n = if isUsedCat cf "Char" + then ("#define " ++ nsDefine inPackage "_CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1) + else mkInteger n + mkInteger n = if isUsedCat cf "Integer" + then ("#define " ++ nsDefine inPackage "_INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1) + else mkDouble n + mkDouble n = if isUsedCat cf "Double" + then ("#define " ++ nsDefine inPackage "_DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1) + else mkIdent n + mkIdent n = if isUsedCat cf "Ident" + then ("#define " ++ nsDefine inPackage "_IDENT_ " ++ show n ++ "\n") + else "" + mkFuncs s | (normCat s == s) = (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(FILE *inp);\n" ++ + (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(const char *str);\n" + mkFuncs _ = "" diff --git a/formats/f-sharp/FSharpTop.hs b/formats/f-sharp/FSharpTop.hs new file mode 100644 --- /dev/null +++ b/formats/f-sharp/FSharpTop.hs @@ -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" + ] + diff --git a/formats/haskell-gadt/CFtoAbstractGADT.hs b/formats/haskell-gadt/CFtoAbstractGADT.hs new file mode 100644 --- /dev/null +++ b/formats/haskell-gadt/CFtoAbstractGADT.hs @@ -0,0 +1,147 @@ +{- + BNF Converter: GADT Abstract syntax Generator + Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoAbstractGADT (cf2Abstract) where + +import CF +import Utils((+++),(++++)) +import List(intersperse,nub) + +import HaskellGADTCommon + +import Data.Maybe (catMaybes) + +-- to produce a Haskell module +cf2Abstract :: Bool -> String -> CF -> String -> String +cf2Abstract byteStrings name cf composOpMod = unlines $ [ + "{-# OPTIONS_GHC -fglasgow-exts #-}", + "module" +++ name +++ "(" ++ concat (intersperse ", " exports) ++ ")" +++ "where", + "", + "import " ++ composOpMod, + "", + "import Data.Monoid", + (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""), + "", + "-- Haskell module generated by the BNF converter", + ""] + ++ prDummyTypes cf + ++ [""] + ++ prTreeType byteStrings cf + ++ [""] + ++ prCompos cf + ++ [""] + ++ prShow cf + ++ [""] + ++ prEq cf + ++ [""] + ++ prOrd cf + where exports = ["Tree(..)"] + ++ getTreeCats cf + ++ ["johnMajorEq"] + ++ ["module " ++ composOpMod] + +getTreeCats :: CF -> [String] +getTreeCats cf = nub $ filter (not . isList) $ map consCat $ cf2cons cf + +prDummyTypes :: CF -> [String] +prDummyTypes cf = concatMap prDummyType $ getTreeCats cf + where + prDummyType cat = ["data" +++ t, "type" +++ cat +++ "= Tree" +++ t ] + where t = mkRealType cat + +mkRealType :: Cat -> String +mkRealType cat = cat ++ "_" -- FIXME: make sure that there is no such category already + +prTreeType :: Bool -> CF -> [String] +prTreeType byteStrings cf = ["data Tree :: * -> * where"] ++ map ((" "++) . prTreeCons) (cf2cons cf) + where + prTreeCons c + | isPositionCat cf cat = fun +++ ":: ((Int,Int),"++stringType++") -> Tree" +++ mkRealType cat + | otherwise = fun +++ "::" +++ concat [c +++ "-> " | (c,_) <- consVars c] ++ "Tree" +++ mkRealType cat + where (cat,fun) = (consCat c, consFun c) + stringType + | byteStrings = "BS.ByteString" + | otherwise = "String" + +prCompos :: CF -> [String] +prCompos cf = + ["instance Compos Tree where", + " compos r a f t = case t of"] + ++ map (" "++) (concatMap prComposCons cs + ++ if not (all isRecursive cs) then ["_ -> r t"] else []) + where + cs = cf2cons cf + prComposCons c + | isRecursive c = [consFun c +++ unwords (map snd (consVars c)) +++ "->" +++ rhs c] + | otherwise = [] + isRecursive c = any (isTreeType cf) (map fst (consVars c)) + rhs c = "r" +++ consFun c +++ unwords (map prRec (consVars c)) + where prRec (cat,var) | not (isTreeType cf cat) = "`a`" +++ "r" +++ var + | isList cat = "`a` foldr (a . a (r (:)) . f) (r [])" +++ var + | otherwise = "`a`" +++ "f" +++ var + +prShow :: CF -> [String] +prShow cf = ["instance Show (Tree c) where", + " showsPrec n t = case t of"] + ++ map (" "++) (map prShowCons cs) + ++ [" where opar n = if n > 0 then showChar '(' else id", + " cpar n = if n > 0 then showChar ')' else id"] + where + cs = cf2cons cf + prShowCons c | null vars = fun +++ "->" +++ "showString" +++ show fun + | otherwise = fun +++ unwords (map snd vars) +++ "->" + +++ "opar n . showString" +++ show fun + +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | (_,x) <- vars] + +++ ". cpar n" + where (fun, vars) = (consFun c, consVars c) + +prEq :: CF -> [String] +prEq cf = ["instance Eq (Tree c) where (==) = johnMajorEq", + "", + "johnMajorEq :: Tree a -> Tree b -> Bool"] + ++ map (prEqCons) (cf2cons cf) + ++ ["johnMajorEq _ _ = False"] + where prEqCons c + | null vars = "johnMajorEq" +++ fun +++ fun +++ "=" +++ "True" + | otherwise = "johnMajorEq" +++ "(" ++ fun +++ unwords vars ++ ")" + +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "=" + +++ (concat $ intersperse " && " $ zipWith (\x y -> x +++ "==" +++ y) vars vars') + where (fun, vars) = (consFun c, map snd (consVars c)) + vars' = map (++"_") vars + +prOrd :: CF -> [String] +prOrd cf = ["instance Ord (Tree c) where", + " compare x y = compare (index x) (index y) `mappend` compareSame x y"] ++ + ["index :: Tree c -> Int"] ++ + zipWith (\ c i -> mkIndex c i) cs [0..] ++ + ["compareSame :: Tree c -> Tree c -> Ordering"] ++ + map mkCompareSame cs ++ + ["compareSame x y = error \"BNFC error:\" compareSame"] + where cs = cf2cons cf + mkCompareSame c + | null vars = "compareSame" +++ fun +++ fun +++ "=" +++ "EQ" + | otherwise = "compareSame" +++ "(" ++ fun +++ unwords vars ++ ")" + +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "=" + +++ foldr1 (\x y -> "mappend (" ++ x ++") ("++y++")") cc + where (fun, vars) = (consFun c, map snd (consVars c)) + vars' = map (++"_") vars + cc = zipWith (\x y -> "compare"+++x+++y) vars vars' + mkIndex c i = "index" +++ "(" ++ consFun c + +++ unwords (replicate (length (consVars c)) "_") ++ ")" + +++ "=" +++ show i diff --git a/formats/haskell-gadt/CFtoPrinterGADT.hs b/formats/haskell-gadt/CFtoPrinterGADT.hs new file mode 100644 --- /dev/null +++ b/formats/haskell-gadt/CFtoPrinterGADT.hs @@ -0,0 +1,167 @@ +{- + BNF Converter: GADT Pretty-printer generator + Copyright (C) 2004-2005 Author: Aarne Ranta, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoPrinterGADT (cf2Printer) where + +import CF +import Utils +import CFtoTemplate +import 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 Cat -> [String] +ifList cf cat = prPrtList cf ("["++cat++"]") -- FIXME: hackish + +prPrt :: CF -> [String] +prPrt cf = ["instance Print (Tree c) where", + " prt _i e = case e of" + ] ++ map prPrtCons (cf2cons cf) + where + prPrtCons c = " " ++ consFun c +++ unwords (vars c) +++ "->" +++ + "prPrec _i" +++ show (consPrec c) +++ rhs + -- for token rules, just print the string argument unquoted + where rhs | isToken c = let [v] = vars c in "(doc (showString " ++ v ++ "))" + | otherwise = mkRhs (vars c) (consRhs c) + vars = map snd . consVars + isToken c = consCat c `elem` specialCats cf + +prPrtList :: CF -> Cat -> [String] +prPrtList cf cat = mkListRule (nil ++ one ++ cons) + where + nil = [" [] -> " ++ mkRhs [] its | + (f,(_,its)) <- rules, isNilFun f] + one = [" [x] -> " ++ mkRhs ["x"] its | + (f,(_,its)) <- rules, isOneFun f] + cons = [" x:xs -> " ++ mkRhs ["x","xs"] its | + (f,(_,its)) <- rules, isConsFun f] + mkListRule [] = [] + mkListRule rs = ["instance Print" +++ cat +++ "where", + " prt _" +++ "es = case es of"] ++ rs + rules = rulesForCat cf cat + +mkRhs :: [String] -> [Either Cat String] -> String +mkRhs args its = + "(concatD [" ++ unwords (intersperse "," (mk args its)) ++ "])" + where + mk args (Left "#" : items) = mk args items + mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items + mk args (Right s : items) = ("doc (showString" +++ show s ++ ")") : mk args items + mk _ _ = [] + prt c = "prt" +++ show (precCat c) + diff --git a/formats/haskell-gadt/CFtoTemplateGADT.hs b/formats/haskell-gadt/CFtoTemplateGADT.hs new file mode 100644 --- /dev/null +++ b/formats/haskell-gadt/CFtoTemplateGADT.hs @@ -0,0 +1,65 @@ +{- + BNF Converter: GADT Template Generator + Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +module CFtoTemplateGADT ( + cf2Template + ) where + +import CF +import Utils((+++)) +import List (delete,groupBy) + +import HaskellGADTCommon + +type ModuleName = String + +cf2Template :: ModuleName -> ModuleName -> ModuleName -> CF -> String +cf2Template skelName absName errName cf = unlines $ + [ + "module "++ skelName ++ " where", + "", + "-- Haskell module generated by the BNF converter", + "", + "import " ++ absName, + "import " ++ errName, + "type Result = Err String\n", + "failure :: Show a => a -> Result", + "failure x = Bad $ \"Undefined case: \" ++ show x", + "", + "transTree :: Tree c -> Result", + "transTree t = case t of"] + ++ map prConsCase (cf2cons cf) + ++ [""] + ++ concatMap ((++[""]) . uncurry prCatTrans) (catCons cf) + +prConsCase :: Constructor -> String +prConsCase c = + " " ++ consFun c +++ unwords (map snd (consVars c)) +++ "-> failure t" + +catCons :: CF -> [(Cat,[Constructor])] +catCons cf = [ (consCat (head cs),cs) | cs <- groupBy catEq $ cf2cons cf] + +catEq :: Constructor -> Constructor -> Bool +catEq c1 c2 = consCat c1 == consCat c2 + +prCatTrans :: Cat -> [Constructor] -> [String] +prCatTrans cat cs = ["trans" ++ cat +++ "::" +++ cat +++ "-> Result", + "trans" ++ cat +++ "t = case t of"] + ++ map prConsCase cs diff --git a/formats/haskell-gadt/HaskellGADTCommon.hs b/formats/haskell-gadt/HaskellGADTCommon.hs new file mode 100644 --- /dev/null +++ b/formats/haskell-gadt/HaskellGADTCommon.hs @@ -0,0 +1,83 @@ +{- + BNF Converter: Haskell GADT back-end common stuff + Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module HaskellGADTCommon (Constructor(..), cf2cons, isTreeType) where + +import CF + +import Char + +data Constructor = Constructor { + consCat :: Cat, + consFun :: Fun, + consPrec :: Int, + consVars :: [(Cat,String)], + consRhs :: [Either Cat String] + } + +-- | Get category, function, and rhs categories paired with variable names. +cf2cons :: CF -> [Constructor] +cf2cons cf = [ Constructor { consCat = cat, + consFun = fun, + consPrec = precFun cf fun, + consVars = zip cats (mkVars cats), + consRhs = rhsFun cf fun} + | (cat,rules) <- cf2data cf, (fun,cats) <- rules] + ++ [ Constructor { consCat = cat, + consFun = cat, + consPrec = 0, + consVars = [("String","str")], + consRhs = [Left "String"]} + | cat <- specialCats cf] + where mkVars cats = mkUnique (map catToVar cats) (0 :: Int) + mkUnique [] _ = [] + mkUnique (x:xs) n | elem x xs || n > 0 = (x ++ show n) : mkUnique xs (n+1) + | otherwise = x : mkUnique xs n + +-- | Make a variable name for a category. +catToVar :: Cat -> String +catToVar = checkRes . var + where var cat | isList cat = var (normCatOfList cat) ++ "s" + var "Ident" = "i" + var "Integer" = "n" + var "String" = "str" + var "Char" = "c" + var "Double" = "d" + var xs = map toLower xs + checkRes s | elem s reservedHaskell = s ++ "'" + | otherwise = s + reservedHaskell = ["case","class","data","default","deriving","do","else","if", + "import","in","infix","infixl","infixr","instance","let","module", + "newtype","of","then","type","where","as","qualified","hiding"] + +-- | Get the rule for a function. +ruleFun :: CF -> Fun -> Rule +ruleFun cf f = head $ filter (\r -> funRule r == f) $ rulesOfCF cf + +-- | Get the precedence of a function. +precFun :: CF -> Fun -> Int +precFun cf f = precRule $ ruleFun cf f + +-- | Get the RHS of a function +rhsFun :: CF -> Fun -> [Either Cat String] +rhsFun cf f = rhsRule $ ruleFun cf f + +isTreeType :: CF -> Cat -> Bool +isTreeType cf c | isList c = isTreeType cf (catOfList c) + | otherwise = c `elem` (allCats cf ++ specialCats cf) diff --git a/formats/haskell-gadt/HaskellTopGADT.hs b/formats/haskell-gadt/HaskellTopGADT.hs new file mode 100644 --- /dev/null +++ b/formats/haskell-gadt/HaskellTopGADT.hs @@ -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 }" + ] diff --git a/formats/haskell2/CFtoAbstract.hs b/formats/haskell2/CFtoAbstract.hs new file mode 100644 --- /dev/null +++ b/formats/haskell2/CFtoAbstract.hs @@ -0,0 +1,51 @@ +{- + BNF Converter: Abstract syntax Generator + Copyright (C) 2004 Author: Markus Forberg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoAbstract (cf2Abstract) where + +import CF +import Utils((+++),(++++)) +import List(intersperse) + +-- to produce a Haskell module +cf2Abstract :: Bool -> String -> CF -> String +cf2Abstract byteStrings name cf = unlines $ + ("module "++name +++ "where\n") : + "-- Haskell module generated by the BNF converter\n" : + (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "") : + (map (prSpecialData byteStrings cf) (specialCats cf) ++ map prData (cf2data cf)) + +prData :: Data -> String +prData (cat,rules) = + "data" +++ cat +++ "=\n " ++ + concat (intersperse "\n | " (map prRule rules)) ++++ + " deriving (Eq,Ord,Show)\n" + where + prRule (fun,cats) = unwords (fun:cats) + +prSpecialData :: Bool -> CF -> Cat -> String +prSpecialData byteStrings cf cat = + unwords ["newtype",cat,"=",cat,contentSpec byteStrings cf cat,"deriving (Eq,Ord,Show)"] + +contentSpec :: Bool -> CF -> Cat -> String +contentSpec byteStrings cf cat = if isPositionCat cf cat then "((Int,Int),"++stringType++")" else stringType + where + stringType + | byteStrings = "BS.ByteString" + | otherwise = "String" diff --git a/formats/haskell2/CFtoAlex.hs b/formats/haskell2/CFtoAlex.hs new file mode 100644 --- /dev/null +++ b/formats/haskell2/CFtoAlex.hs @@ -0,0 +1,230 @@ +{- + BNF Converter: Alex 1.1 Generator + Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +module CFtoAlex (cf2alex) where + +import CF +import RegToAlex +import List + +cf2alex :: String -> String -> CF -> String +cf2alex name errMod cf = unlines $ concat $ intersperse [""] [ + prelude name errMod, + cMacros, + rMacros cf, + restOfAlex cf + ] + +prelude :: String -> String -> [String] +prelude name errMod = [ + "-- This Alex file was machine-generated by the BNF converter", + "%{", + "module " ++ name ++ " where", + "", + "import Alex", + "import " ++ errMod, + "%}" + ] +{- ---- +cf2alex :: String -> CF -> String +cf2alex name cf = unlines $ concat $ intersperse [""] [ + prelude name, + cMacros, + rMacros cf, + restOfAlex cf + ] + +prelude :: String -> [String] +prelude name = [ + "-- This Alex file was machine-generated by the BNF converter", + "%{", + "module Lex" ++ name ++ " where", + "", + "import Alex", + "import ErrM", + "%}" + ] +-} +cMacros :: [String] +cMacros = [ + "{ ^l = [a-zA-Z^192-^255] # [^215 ^247]} -- isolatin1 letter", + "{ ^c = [A-Z^192-^221] # [^215]} -- capital isolatin1 letter", + "{ ^s = [a-z^222-^255] # [^247]} -- small isolatin1 letter", + "{ ^d = [0-9] } -- digit", + "{ ^i = [^l^d^'^_] } -- identifier character", + "{ ^u = [^0-^255] } -- universal: any character" + ] + +rMacros :: CF -> [String] +rMacros cf = + let symbs = symbols cf + in + (if null symbs then [] else [ + "{ %s = -- reserved words consisting of special symbols", + " " ++ unwords (intersperse "|" (map mkEsc symbs)), + "}" + ]) + where + mkEsc = unwords . map ( f . (:[])) + f s = if all isSpec s then '^':s else s + isSpec = flip elem "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" + +restOfAlex :: CF -> [String] +restOfAlex cf = [ + "\"tokens_lx\"/\"tokens_acts\":-", + lexComments (comments cf), + "<> ::= ^w+", + pTSpec (symbols cf,[]), -- modif Markus 12/02 - 2002 + + userDefTokenTypes, + identAndRes, + + ifC "String" " ::= ^\" ([^u # [^\"^\\^n]] | (^\\ (^\" | ^\\ | ^' | n | t)))* ^\"" ++ + "%{ string p = PT p . TL . unescapeInitTail %}", + ifC "Char" " ::= ^\' (^u # [^\'^\\] | ^\\ [^\\ ^\' n t]) ^' %{ char p = PT p . TC %}", + ifC "Integer" " ::= ^d+ %{ int p = PT p . TI %}", + ifC "Double" + " ::= ^d+ ^. ^d+ (e (^-)? ^d+)? %{ double p = PT p . TD %}", + "", + "%{ ", + "", + "data Tok =", + " TS String -- reserved words", + " | TL String -- string literals", + " | TI String -- integer literals", + " | TV String -- identifiers", + " | TD String -- double precision float literals", + " | TC String -- character literals", + userDefTokenConstrs, + " deriving (Eq,Show)", + "", + "data Token = ", + " PT Posn Tok", + " | Err Posn", + " deriving Show", + "", + "tokenPos (PT (Pn _ l _) _ :_) = \"line \" ++ show l", + "tokenPos (Err (Pn _ l _) :_) = \"line \" ++ show l", + "tokenPos _ = \"end of file\"", + "", + "posLineCol (Pn _ l c) = (l,c)", + "mkPosToken t@(PT p _) = (posLineCol p, prToken t)", + "", + "prToken t = case t of", + " PT _ (TS s) -> s", + " PT _ (TI s) -> s", + " PT _ (TV s) -> s", + " PT _ (TD s) -> s", + " PT _ (TC s) -> s", + userDefTokenPrint, + " _ -> show t", + "", + "tokens:: String -> [Token]", + "tokens inp = scan tokens_scan inp", + "", + "tokens_scan:: Scan Token", + "tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx", + " where", + " stop_act p \"\" = []", + " stop_act p inp = [Err p]", + "", + "eitherResIdent :: (String -> Tok) -> String -> Tok", + "eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where", + " isResWord s = isInTree s $", + " " ++ (show $ sorted2tree $ sort resws), + "", + "data BTree = N | B String BTree BTree deriving (Show)", + "", + "isInTree :: String -> BTree -> Bool", + "isInTree x tree = case tree of", + " N -> False", + " B a left right", + " | x < a -> isInTree x left", + " | x > a -> isInTree x right", + " | x == a -> True", + "", + "unescapeInitTail :: String -> String", + "unescapeInitTail = unesc . tail where", + " unesc s = case s of", + " '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs", + " '\\\\':'n':cs -> '\\n' : unesc cs", + " '\\\\':'t':cs -> '\\t' : unesc cs", + " '\"':[] -> []", + " c:cs -> c : unesc cs", + " _ -> []", + "%}" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + lexComments ([],[]) = [] + lexComments (xs,s1:ys) = "<> ::= " ++ ('^':intersperse '^' s1) ++ " [.]* ^n\n" ++ lexComments (xs,ys) + lexComments (([l1,l2],[r1,r2]):xs,[]) = concat $ + [ + "<> ::= ", + ('^':l1:' ':'^':l2:" ([^u # ^"), + (l2:"] | ^"), + (r1:" [^u # ^"), + (r2:"])* (^"), + (r1:")+ ^"), + (r2:"\n"), + lexComments (xs,[]) + ] + lexComments ((_:xs),[]) = lexComments (xs,[]) +--- lexComments (xs,(_:ys)) = lexComments (xs,ys) + pTSpec ([],[]) = "" + pTSpec xp = + " ::= " ++ aux xp ++ "%{ pTSpec p = PT p . TS %}" + aux (xs,[]) = " %s " + aux ([],ys) = " %r " + aux (xs,ys) = " %s | %r " + resWs = + "[" ++ concat (intersperse "," [show s | s <- resws]) ++ "]" + --- show s can be strange for isolatin1 characters + --- precompile to search tree! + + userDefTokenTypes = unlines $ + [" ::= " ++ printRegAlex exp ++ + "%{ mk_" ++ name ++ " p = PT p . eitherResIdent T_" ++ name ++ " %}" + | (name,exp) <- tokenPragmas cf] + userDefTokenConstrs = unlines $ + [" | T_" ++ name ++ " String" | (name,_) <- tokenPragmas cf] + userDefTokenPrint = unlines $ + [" PT _ (T_" ++ name ++ " s) -> s" | (name,_) <- tokenPragmas cf] + + identAndRes = --This has to be there for Reserved Words. Michael + " ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" + --ifC "Ident" " ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" + + resws = reservedWords cf + +data BTree = N | B String BTree BTree deriving (Show) + +isInTree :: String -> BTree -> Bool +isInTree x tree = case tree of + N -> False + B a left right + | x < a -> isInTree x left + | x > a -> isInTree x right + | x == a -> True + +sorted2tree :: [String] -> BTree +sorted2tree [] = N +sorted2tree xs = B x (sorted2tree t1) (sorted2tree t2) where + (t1,(x:t2)) = splitAt (length xs `div` 2) xs diff --git a/formats/haskell2/CFtoAlex2.hs b/formats/haskell2/CFtoAlex2.hs new file mode 100644 --- /dev/null +++ b/formats/haskell2/CFtoAlex2.hs @@ -0,0 +1,338 @@ +{- + BNF Converter: Alex 2.0 Generator + Copyright (C) 2004 Author: Peter Gammie + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +------------------------------------------------------------------- +-- | +-- Module : CFtoAlex2 +-- Copyright : (C)opyright 2003, {aarne,markus,peteg} at cs dot chalmers dot se +-- License : GPL (see COPYING for details) +-- +-- Maintainer : {markus,aarne} at cs dot chalmers dot se +-- Stability : alpha +-- Portability : Haskell98 +-- +-- Hacked version of @CFtoAlex@ to cope with Alex2. +-- +------------------------------------------------------------------- +module CFtoAlex2 (cf2alex2) where + +import CF +import 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" " ::= ^l ^i* { ident p = PT p . eitherResIdent TV }" + + resws = reservedWords cf ++ symbols cf + + +data BTree = N | B String Int BTree BTree + +instance Show BTree where + showsPrec _ N = showString "N" + showsPrec n (B s k l r) = wrap (showString "b " . shows s . showChar ' '. shows k . showChar ' ' + . showsPrec 1 l . showChar ' ' + . showsPrec 1 r) + where wrap f = if n > 0 then showChar '(' . f . showChar ')' else f + +sorted2tree :: [(String,Int)] -> BTree +sorted2tree [] = N +sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2) where + (t1,((x,n):t2)) = splitAt (length xs `div` 2) xs + + +------------------------------------------------------------------- +-- Inlined version of @RegToAlex@. +-- Syntax has changed... +------------------------------------------------------------------- + +-- modified from pretty-printer generated by the BNF converter + +-- the top-level printing method +printRegAlex :: Reg -> String +printRegAlex = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend 0 + where rend :: Int -> [String] -> String + rend i ss = case ss of + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + + cons s t = s ++ t + new i s = s + space t s = if null s then t else t ++ " " ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ c = if isAlphaNum c then [[c]] else ['\\':[c]] + prtList s = map (concat . prt 0) s + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["$"]) + RChar c -> prPrec i 3 (concat [prt 0 c]) + RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) + RDigit -> prPrec i 3 (concat [["$d"]]) + RLetter -> prPrec i 3 (concat [["$l"]]) + RUpper -> prPrec i 3 (concat [["$c"]]) + RLower -> prPrec i 3 (concat [["$s"]]) + RAny -> prPrec i 3 (concat [["$u"]]) diff --git a/formats/haskell2/CFtoHappy.hs b/formats/haskell2/CFtoHappy.hs new file mode 100644 --- /dev/null +++ b/formats/haskell2/CFtoHappy.hs @@ -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 = "" + diff --git a/formats/haskell2/CFtoLayout.hs b/formats/haskell2/CFtoLayout.hs new file mode 100644 --- /dev/null +++ b/formats/haskell2/CFtoLayout.hs @@ -0,0 +1,270 @@ +{- + BNF Converter: Layout handling Generator + Copyright (C) 2004 Author: Aarne Ranta + Copyright (C) 2005 Bjorn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoLayout where + +import Data.List (sort) +import CF + +layoutOpen = "{" +layoutClose = "}" +layoutSep = ";" + +cf2Layout :: Bool -> Bool -> String -> String -> CF -> String +cf2Layout alex1 inDir layName lexName cf = + let + (top,lay,stop) = layoutPragmas cf + in unlines $ [ + "module " ++ layName ++ " where", + "", + "import " ++ lexName, + if alex1 then "import Alex" else "", + "", + "import Data.Maybe (isNothing, fromJust)", + "", + "-- Generated by the BNF Converter", + "", + "-- local parameters", + "", + "topLayout = " ++ show top, + "layoutWords = " ++ show lay, + "layoutStopWords = " ++ show stop, + "", + "-- layout separators", + "", + "layoutOpen = " ++ show layoutOpen, + "layoutClose = " ++ show layoutClose, + "layoutSep = " ++ show layoutSep, + "", + "-- | Replace layout syntax with explicit layout tokens.", + "resolveLayout :: Bool -- ^ Whether to use top-level layout.", + " -> [Token] -> [Token]", + "resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]", + " where", + " -- Do top-level layout if the function parameter and the grammar say so.", + " tl = tp && topLayout", + "", + " res :: Maybe Token -- ^ The previous token, if any.", + " -> [Block] -- ^ A stack of layout blocks.", + " -> [Token] -> [Token]", + "", + " -- The stack should never be empty.", + " res _ [] ts = error $ \"Layout error: stack empty. Tokens: \" ++ show ts", + "", + " res _ st (t0:ts)", + " -- We found an open brace in the input,", + " -- put an explicit layout block on the stack.", + " -- This is done even if there was no layout word,", + " -- to keep opening and closing braces.", + " | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts", + "", + " res _ st (t0:ts)", + " -- Start a new layout block if the first token is a layout word", + " | isLayout t0 =", + " case ts of", + " -- Explicit layout, just move on. The case above", + " -- will push an explicit layout block.", + " t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts", + " -- at end of file, the start column doesn't matter", + " _ -> let col = if null ts then column t0 else column (head ts)", + " -- insert an open brace after the layout word", + " b:ts' = addToken (nextPos t0) layoutOpen ts", + " -- save the start column", + " st' = Implicit col:st ", + " in moveAlong st' [t0,b] ts'", + "", + " -- If we encounter a closing brace, exit the first explicit layout block.", + " | isLayoutClose t0 = ", + " let st' = drop 1 (dropWhile isImplicit st)", + " in if null st' ", + " then error $ \"Layout error: Found \" ++ layoutClose ++ \" at (\" ", + " ++ show (line t0) ++ \",\" ++ show (column t0) ", + " ++ \") without an explicit layout block.\"", + " else moveAlong st' [t0] ts", + "", + " -- We are in an implicit layout block", + " res pt st@(Implicit n:ns) (t0:ts)", + "", + " -- End of implicit block by a layout stop word", + " | isStop t0 = ", + " -- Exit the current block and all implicit blocks ", + " -- more indented than the current token", + " let (ebs,ns') = span (`moreIndent` column t0) ns", + " moreIndent (Implicit x) y = x > y", + " moreIndent Explicit _ = False", + " -- the number of blocks exited", + " b = 1 + length ebs", + " bs = replicate b layoutClose", + " -- Insert closing braces after the previous token.", + " (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)", + " in moveAlong ns' ts1 ts2", + "", + " -- End of an implicit layout block", + " | newLine && column t0 < n = ", + " -- Insert a closing brace after the previous token.", + " let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)", + " -- Repeat, with the current block removed from the stack", + " in moveAlong ns [b] (t0':ts')", + "", + " -- Encounted a new line in an implicit layout block.", + " | newLine && column t0 == n = ", + " -- Insert a semicolon after the previous token.", + " -- unless we are the beginning of the file,", + " -- or the previous token is a semicolon or open brace.", + " if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt) ", + " then moveAlong st [t0] ts", + " else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts)", + " in moveAlong st [b,t0'] ts'", + " where newLine = case pt of", + " Nothing -> True", + " Just t -> line t /= line t0", + "", + " -- Nothing to see here, move along.", + " res _ st (t:ts) = moveAlong st [t] ts", + "", + " -- At EOF: skip explicit blocks.", + " res (Just t) (Explicit:bs) [] | null bs = []", + " | otherwise = res (Just t) bs []", + "", + " -- If we are using top-level layout, insert a semicolon after", + " -- the last token, if there isn't one already", + " res (Just t) [Implicit n] []", + " | isTokenIn [layoutSep] t = []", + " | otherwise = addToken (nextPos t) layoutSep []", + "", + " -- At EOF in an implicit, non-top-level block: close the block", + " res (Just t) (Implicit n:bs) [] =", + " let c = addToken (nextPos t) layoutClose []", + " in moveAlong bs c []", + "", + " -- This should only happen if the input is empty.", + " res Nothing st [] = []", + "", + " -- | Move on to the next token.", + " moveAlong :: [Block] -- ^ The layout stack.", + " -> [Token] -- ^ Any tokens just processed.", + " -> [Token] -- ^ the rest of the tokens.", + " -> [Token]", + " moveAlong st [] ts = error $ \"Layout error: moveAlong got [] as old tokens\"", + " moveAlong st ot ts = ot ++ res (Just $ last ot) st ts", + "", + "data Block = Implicit Int -- ^ An implicit layout block with its start column.", + " | Explicit ", + " deriving Show", + "", + "type Position = Posn", + "", + "-- | Check if s block is implicit.", + "isImplicit :: Block -> Bool", + "isImplicit (Implicit _) = True", + "isImplicit _ = False", + "", + "-- | Insert a number of tokens at the begninning of a list of tokens.", + "addTokens :: Position -- ^ Position of the first new token.", + " -> [String] -- ^ Token symbols.", + " -> [Token] -- ^ The rest of the tokens. These will have their", + " -- positions updated to make room for the new tokens .", + " -> [Token] ", + "addTokens p ss ts = foldr (addToken p) ts ss", + "", + "-- | Insert a new symbol token at the begninning of a list of tokens.", + "addToken :: Position -- ^ Position of the new token.", + " -> String -- ^ Symbol in the new token.", + " -> [Token] -- ^ The rest of the tokens. These will have their", + " -- positions updated to make room for the new token.", " -> [Token]", + "addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts", + "", + "-- | Get the position immediately to the right of the given token.", + "-- If no token is given, gets the first position in the file.", + "afterPrev :: Maybe Token -> Position", + "afterPrev = maybe (Pn 0 1 1) nextPos", + "", + "-- | Get the position immediately to the right of the given token.", + "nextPos :: Token -> Position ", + "nextPos t = Pn (g + s) l (c + s + 1) ", + " where Pn g l c = position t", + " s = tokenLength t", + "", + "-- | Add to the global and column positions of a token.", + "-- The column position is only changed if the token is on", + "-- the same line as the given position.", + "incrGlobal :: Position -- ^ If the token is on the same line", + " -- as this position, update the column position.", + " -> Int -- ^ Number of characters to add to the position.", + " -> Token -> Token", + "incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) =", + " if l /= l0 then PT (Pn (g + i) l c) t", + " else PT (Pn (g + i) l (c + i)) t", + "incrGlobal _ _ p = error $ \"cannot add token at \" ++ show p", + "", + "-- | Create a symbol token.", + "sToken :: Position -> String -> Token", + "sToken p s = PT p (TS s i)", + " where", + " i = case s of"] ++ + [ " " ++ show s ++ " -> " ++ show i + | (s, i) <- zip resws [1..] + ] ++ + [" _ -> error $ \"not a reserved word: \" ++ show s", + "", + "-- | Get the position of a token.", + "position :: Token -> Position", + "position t = case t of", + " PT p _ -> p", + " Err p -> p", + "", + "-- | Get the line number of a token.", + "line :: Token -> Int", + "line t = case position t of Pn _ l _ -> l", + "", + "-- | Get the column number of a token.", + "column :: Token -> Int", + "column t = case position t of Pn _ _ c -> c", + "", + "-- | Check if a token is one of the given symbols.", + "isTokenIn :: [String] -> Token -> Bool", + "isTokenIn ts t = case t of", + " PT _ (TS r _) | elem r ts -> True", + " _ -> False", + "", + "-- | Check if a word is a layout start token.", + "isLayout :: Token -> Bool", + "isLayout = isTokenIn layoutWords", + "", + "-- | Check if a token is a layout stop token.", + "isStop :: Token -> Bool", + "isStop = isTokenIn layoutStopWords", + "", + "-- | Check if a token is the layout open token.", + "isLayoutOpen :: Token -> Bool", + "isLayoutOpen = isTokenIn [layoutOpen]", + "", + "-- | Check if a token is the layout close token.", + "isLayoutClose :: Token -> Bool", + "isLayoutClose = isTokenIn [layoutClose]", + "", + "-- | Get the number of characters in the token.", + "tokenLength :: Token -> Int", + "tokenLength t = length $ prToken t", + + "" + ] + where + resws = sort (reservedWords cf ++ symbols cf) diff --git a/formats/haskell2/CFtoPrinter.hs b/formats/haskell2/CFtoPrinter.hs new file mode 100644 --- /dev/null +++ b/formats/haskell2/CFtoPrinter.hs @@ -0,0 +1,189 @@ +{- + BNF Converter: Pretty-printer generator + Copyright (C) 2004 Author: Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoPrinter (cf2Printer) where + +import CF +import Utils +import CFtoTemplate +import 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 String +rules cf = unlines $ + map (\(s,xs) -> case_fun s (map toArgs xs) ++ ifList cf s) $ cf2data cf + where + toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons) + names [] _ = [] + names (x:xs) n + | elem x xs = (x ++ show n) : names xs (n+1) + | otherwise = x : names xs n + var ('[':xs) = var (init xs) ++ "s" + var "Ident" = "id" + var "Integer" = "n" + var "String" = "str" + var "Char" = "c" + var "Double" = "d" + var xs = map toLower xs + checkRes s + | elem s reservedHaskell = s ++ "'" + | otherwise = s + reservedHaskell = ["case","class","data","default","deriving","do","else","if", + "import","in","infix","infixl","infixr","instance","let","module", + "newtype","of","then","type","where","as","qualified","hiding"] + ruleOf s = maybe undefined id $ lookup s (rulesOfCF cf) + +--- case_fun :: Cat -> [(Constructor,Rule)] -> String +case_fun cat xs = unlines [ + "instance Print" +++ cat +++ "where", + " prt i" +++ "e = case e of", + unlines $ map (\ ((c,xx),r) -> + " " ++ c +++ unwords xx +++ "->" +++ + "prPrec i" +++ show (precCat (fst r)) +++ mkRhs xx (snd r)) xs + ] + +ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where + nil cat = [" [] -> " ++ mkRhs [] its | + (f,(c,its)) <- rulesOfCF cf, isNilFun f , normCatOfList c == cat] + one cat = [" [x] -> " ++ mkRhs ["x"] its | + (f,(c,its)) <- rulesOfCF cf, isOneFun f , normCatOfList c == cat] + cons cat = [" x:xs -> " ++ mkRhs ["x","xs"] its | + (f,(c,its)) <- rulesOfCF cf, isConsFun f , normCatOfList c == cat] + mkListRule [] = "" + mkListRule rs = unlines $ (" prtList" +++ "es = case es of"):rs + + +mkRhs args its = + "(concatD [" ++ unwords (intersperse "," (mk args its)) ++ "])" + where + mk args (Left "#" : items) = mk args items + mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items + mk args (Right s : items) = ("doc (showString" +++ show s ++ ")") : mk args items + mk _ _ = [] + prt c = "prt" +++ show (precCat c) + diff --git a/formats/haskell2/CFtoTemplate.hs b/formats/haskell2/CFtoTemplate.hs new file mode 100644 --- /dev/null +++ b/formats/haskell2/CFtoTemplate.hs @@ -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] + diff --git a/formats/haskell2/HaskellTop.hs b/formats/haskell2/HaskellTop.hs new file mode 100644 --- /dev/null +++ b/formats/haskell2/HaskellTop.hs @@ -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)" + ] diff --git a/formats/haskell2/MkErrM.hs b/formats/haskell2/MkErrM.hs new file mode 100644 --- /dev/null +++ b/formats/haskell2/MkErrM.hs @@ -0,0 +1,51 @@ +{- + BNF Converter: Haskell error monad + Copyright (C) 2004-2007 Author: Markus Forberg, Peter Gammie, + Aarne Ranta, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} +module MkErrM where + +errM :: String -> b -> String +errM errMod _ = unlines + [ + "-- BNF Converter: Error Monad", + "-- Copyright (C) 2004 Author: Aarne Ranta", + "", + "-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.", + "module " ++ errMod ++ " where", + "", + "-- the Error monad: like Maybe type with error msgs", + "", + "import Control.Monad (MonadPlus(..), liftM)", + "", + "data Err a = Ok a | Bad String", + " deriving (Read, Show, Eq, Ord)", + "", + "instance Monad Err where", + " return = Ok", + " fail = Bad", + " Ok a >>= f = f a", + " Bad s >>= f = Bad s", + "", + "instance Functor Err where", + " fmap = liftM", + "", + "instance MonadPlus Err where", + " mzero = Bad \"Err.mzero\"", + " mplus (Bad _) y = y", + " mplus x _ = x" + ] diff --git a/formats/haskell2/MkSharedString.hs b/formats/haskell2/MkSharedString.hs new file mode 100644 --- /dev/null +++ b/formats/haskell2/MkSharedString.hs @@ -0,0 +1,67 @@ +{- + BNF Converter: Haskell string sharing + Copyright (C) 2004-2007 Author: Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} +module MkSharedString where + +sharedString :: String -> Bool -> b -> String +sharedString shareMod byteString _ = unlines $ + if byteString + then + [ + "module " ++ shareMod ++ " (shareString) where", + "", + "import Data.Map as M", + "import Data.IORef", + "import qualified Data.ByteString.Char8 as BS", + "import System.IO.Unsafe (unsafePerformIO)", + "", + "{-# NOINLINE stringPoolRef #-}", + "stringPoolRef :: IORef (M.Map BS.ByteString BS.ByteString)", + "stringPoolRef = unsafePerformIO $ newIORef M.empty", + "", + "{-# NOINLINE shareString #-}", + "shareString :: BS.ByteString -> BS.ByteString", + "shareString s = unsafePerformIO $ do", + " stringPool <- readIORef stringPoolRef", + " case M.lookup s stringPool of", + " Just s' -> return s'", + " Nothing -> do let s' = BS.copy s", + " writeIORef stringPoolRef $! M.insert s' s' stringPool", + " return s'" + ] + else + [ + "module " ++ shareMod ++ " (shareString) where", + "", + "import Data.HashTable as H", + "import System.IO.Unsafe (unsafePerformIO)", + "", + "{-# NOINLINE stringPool #-}", + "stringPool :: HashTable String String", + "stringPool = unsafePerformIO $ new (==) hashString", + "", + "{-# NOINLINE shareString #-}", + "shareString :: String -> String", + "shareString s = unsafePerformIO $ do", + " mv <- H.lookup stringPool s", + " case mv of", + " Just s' -> return s'", + " Nothing -> do", + " H.insert stringPool s s", + " return s" + ] diff --git a/formats/haskell2/RegToAlex.hs b/formats/haskell2/RegToAlex.hs new file mode 100644 --- /dev/null +++ b/formats/haskell2/RegToAlex.hs @@ -0,0 +1,88 @@ +{- + BNF Converter: Regular expression pretty printer + Copyright (C) 2004 Author: BNF Converter, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module RegToAlex (printRegAlex) where + +-- modified from pretty-printer generated by the BNF converter + +import AbsBNF +import Char + +-- the top-level printing method +printRegAlex :: Reg -> String +printRegAlex = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend (0::Int) where + rend i ss = case ss of + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + cons s t = s ++ t + new i s = s + space t s = if null s then t else t ++ " " ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ c = if isAlphaNum c then [[c]] else ['^':[c]] + prtList s = map (concat . prt 0) s + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["$"]) + RChar c -> prPrec i 3 (concat [prt 0 c]) + RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) + RDigit -> prPrec i 3 (concat [["^d"]]) + RLetter -> prPrec i 3 (concat [["^l"]]) + RUpper -> prPrec i 3 (concat [["^c"]]) + RLower -> prPrec i 3 (concat [["^s"]]) + RAny -> prPrec i 3 (concat [["^u"]]) + + + diff --git a/formats/java/CFtoCup.hs b/formats/java/CFtoCup.hs new file mode 100644 --- /dev/null +++ b/formats/java/CFtoCup.hs @@ -0,0 +1,282 @@ +{- + BNF Converter: Java Cup Generator + Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the CUP input file. It + follows the same basic structure of CFtoHappy. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 26 April, 2003 + + Modified : 2 September, 2003 + + + ************************************************************** +-} +module CFtoCup ( cf2Cup ) where + +import CF +import List (intersperse, isPrefixOf) +import Data.Char (isUpper) +import NamedVariables +import TypeChecker -- We need to (re-)typecheck to figure out list instances in + -- defined rules. +import ErrM +import Utils ( (+++) ) + +-- Type declarations +type Rules = [(NonTerminal,[(Pattern,Action)])] +type NonTerminal = String +type Pattern = String +type Action = String +type MetaVar = String + +--The environment comes from the CFtoJLex +cf2Cup :: String -> String -> CF -> SymEnv -> String +cf2Cup packageBase packageAbsyn cf env = unlines + [ + header, + declarations packageAbsyn (allCats cf), + tokens env, + specialToks cf, + specialRules cf, + prEntryPoint cf, + prRules (rulesForCup packageAbsyn cf env) + ] + where + header :: String + header = unlines + ["// -*- Java -*- This Cup file was machine-generated by BNFC", + "package" +++ packageBase ++ ";", + "", + "import java_cup.runtime.*;", + "import" +++ packageAbsyn ++ ".*;", + "", + "parser code {:", + parseMethod packageAbsyn (firstEntry cf), + definedRules packageAbsyn cf, + -- unlines $ map (parseMethod packageAbsyn) (allEntryPoints cf), + "public void syntax_error(Symbol cur_token)", + "{", + "\treport_error(\"Syntax Error, trying to recover and continue parse...\", cur_token);", + "}", + "", + "public void unrecovered_syntax_error(Symbol cur_token) throws java.lang.Exception", + "{", + "\tthrow new Exception(\"Unrecoverable Syntax Error\");", + "}", + "", + ":}" + ] + +definedRules :: String -> CF -> String +definedRules packageAbsyn cf@((pr,_),_) = + unlines [ rule f xs e | FunDef f xs e <- pr ] + where + ctx = buildContext cf + + list = LC (const "null") (\t -> "List" ++ unBase t) + where + unBase (ListT t) = unBase t + unBase (BaseT x) = normCat x + + rule f xs e = + case checkDefinition' list ctx f xs e of + Bad err -> error $ "Panic! This should have been caught already:\n" ++ err + Ok (args,(e',t)) -> unlines + [ "public " ++ javaType t ++ " " ++ f ++ "_ (" ++ + concat (intersperse ", " $ map javaArg args) ++ ") {" + , " return " ++ javaExp e' ++ ";" + , "}" + ] + where + + javaType :: Base -> String + javaType (ListT (BaseT x)) = packageAbsyn ++ ".List" ++ normCat x + javaType (ListT t) = javaType t + javaType (BaseT x) + | isToken x ctx = "String" + | otherwise = packageAbsyn ++ "." ++ normCat x + + javaArg :: (String, Base) -> String + javaArg (x,t) = javaType t ++ " " ++ x ++ "_" + + javaExp :: Exp -> String + javaExp (App "null" []) = "null" + javaExp (App x []) + | elem x xs = x ++ "_" -- argument + javaExp (App t [e]) + | isToken t ctx = call ("new String") [e] + javaExp (App x es) + | isUpper (head x) = call ("new " ++ packageAbsyn ++ "." ++ x) es + | otherwise = call (x ++ "_") es + javaExp (LitInt n) = "new Integer(" ++ show n ++ ")" + javaExp (LitDouble x) = "new Double(" ++ show x ++ ")" + javaExp (LitChar c) = "new Character(" ++ show c ++ ")" + javaExp (LitString s) = "new String(" ++ show s ++ ")" + + call x es = x ++ "(" ++ concat (intersperse ", " $ map javaExp es) ++ ")" + +-- peteg: FIXME JavaCUP can only cope with one entry point AFAIK. +prEntryPoint :: CF -> String +prEntryPoint cf = unlines ["", "start with " ++ firstEntry cf ++ ";", ""] +-- [ep] -> unlines ["", "start with " ++ ep ++ ";", ""] +-- eps -> error $ "FIXME multiple entry points." ++ show eps + +--This generates a parser method for each entry point. +parseMethod :: String -> Cat -> String +parseMethod packageAbsyn cat = + if normCat cat /= cat + then "" + else unlines + [ + " public" +++ packageAbsyn ++ "." ++ cat' +++ "p" ++ cat' ++ "()" + ++ " throws Exception", + " {", + "\tSymbol res = parse();", + "\treturn (" ++ packageAbsyn ++ "." ++ cat' ++ ") res.value;", + " }" + ] + where cat' = identCat (normCat cat) + +--non-terminal types +declarations :: String -> [NonTerminal] -> String +declarations packageAbsyn ns = unlines (map (typeNT packageAbsyn) ns) + where + typeNT _nm nt = "nonterminal" +++ packageAbsyn ++ "." + ++ identCat (normCat nt) +++ identCat nt ++ ";" + +--terminal types +tokens :: SymEnv -> String +tokens ts = unlines (map declTok ts) + where + declTok (s,r) = "terminal" +++ r ++ "; // " ++ s + +specialToks :: CF -> String +specialToks cf = unlines [ + ifC "String" "terminal String _STRING_;", + ifC "Char" "terminal Character _CHAR_;", + ifC "Integer" "terminal Integer _INTEGER_;", + ifC "Double" "terminal Double _DOUBLE_;", + ifC "Ident" "terminal String _IDENT_;" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + +-- This handles user defined tokens +-- FIXME +specialRules:: CF -> String +specialRules cf = + unlines ["terminal String " ++ name ++ ";" | (name, _) <- tokenPragmas cf] + +--The following functions are a (relatively) straightforward translation +--of the ones in CFtoHappy.hs +rulesForCup :: String -> CF -> SymEnv -> Rules +rulesForCup packageAbsyn cf env = map mkOne $ ruleGroups cf where + mkOne (cat,rules) = constructRule packageAbsyn cf env rules cat + +-- For every non-terminal, we construct a set of rules. A rule is a sequence of +-- terminals and non-terminals, and an action to be performed. +constructRule :: String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule packageAbsyn cf env rules nt = + (nt, [(p,generateAction packageAbsyn nt (funRule r) (revM b m)) + | r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True, revSepListRule r0) + else (False, r0) + (p,m) = generatePatterns cf env r]) + where + --this basically reverses revSepListRule for the parameters + revM False m = m + revM True (h:c:t) = (t ++ [c] ++ [h]) + revs = reversibleCats cf + +-- Generates a string containing the semantic action. +generateAction :: String -> NonTerminal -> Fun -> [MetaVar] -> Action +generateAction packageAbsyn nt f ms = + if isNilFun f + then "RESULT = null;" + else if isOneFun f + then "RESULT = new " ++ packageAbsyn ++ "." ++ identCat (normCat nt) ++ + (concat $ ["("] ++ ms ++ [",null);"]) + else + (unwords $ + (if isCoercion f then [unwords revLists, "RESULT = "] + else if isDefinedRule f then [unwords revLists, "RESULT = parser." ++ f ++ "_"] + else [unwords revLists, "RESULT = new " ++ packageAbsyn ++ "." ++ f'] + )) + ++ (concat $ ["("] ++ ms'' ++ [");"]) + where + f' = if isConsFun f then identCat (normCat nt) + else f + (revLists, ms') = revMs [] [] ms + ms'' = reverse ms' + revMs ls ns [] = (ls,ns) + revMs ls ns (m:ms) = if "list_" `isPrefixOf` m + then revMs (("if (" ++ m' ++ " != null) " ++ m' ++ " = " ++ m' ++ ".reverse(); ") : ls) + (m' : ns) ms + else revMs ls (m:ns) ms + where m' = drop 5 m --remove the list marker + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal +generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar]) +generatePatterns cf env r = case rhsRule r of + [] -> (" /* empty */ ",[]) + its -> (mkIt env 1 its, metas its) + where + mkIt _env _n [] = [] + mkIt env n (i:is) = case i of + Left c -> c' ++ ":p_" ++ (show (n :: Int)) +++ (mkIt env (n+1) is) + where + c' = case c of + "Ident" -> "_IDENT_" + "Integer" -> "_INTEGER_" + "Char" -> "_CHAR_" + "Double" -> "_DOUBLE_" + "String" -> "_STRING_" + _ -> identCat c + Right s -> case (lookup s env) of + (Just x) -> x +++ (mkIt env (n+1) is) + (Nothing) -> (mkIt env n is) + metas its = intersperse "," [revIf c ("p_" ++ (show i)) | (i,Left c) <- zip [1 :: Int ..] its] + --This is slightly messy, but it marks lists for reversal. + revIf c m = if (not (isConsFun (funRule r)) && elem c revs) + then "list_" ++ m -- ("(reverse " ++ m ++ ")") --not yet! + else m -- no reversal in the left-recursive Cons rule itself + revs = reversibleCats cf + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. +prRules :: Rules -> String +prRules [] = [] +prRules ((nt, []):rs) = prRules rs --internal rule +prRules ((nt,((p,a):ls)):rs) = + (unwords [nt', "::=", p, "{:", a, ":}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{:", a , ":}"])]) ++ pr ls + diff --git a/formats/java/CFtoJLex.hs b/formats/java/CFtoJLex.hs new file mode 100644 --- /dev/null +++ b/formats/java/CFtoJLex.hs @@ -0,0 +1,174 @@ +{- + BNF Converter: Java JLex generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the JLex input file. This + file is quite different than Alex or Flex. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 25 April, 2003 + + Modified : 2 September, 2003 + + + ************************************************************** +-} + +module CFtoJLex ( cf2jlex ) where + +import CF +import RegToJLex +import Utils ( (+++) ) +import NamedVariables +import List + +--The environment must be returned for the parser to use. +cf2jlex :: String -> String -> CF -> (String, SymEnv) +cf2jlex packageBase packageAbsyn cf = (unlines $ concat $ + [ + prelude packageBase packageAbsyn, + cMacros, + lexSymbols env, + restOfJLex cf + ], env) + where + env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) + makeSymEnv [] _ = [] + makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) + +prelude :: String -> String -> [String] +prelude packageBase packageAbsyn = + [ + "// This JLex file was machine-generated by the BNF converter", + "package" +++ packageBase ++ ";", + "", + "import java_cup.runtime.*;", + "import " ++ packageAbsyn ++ ".*;", + "%%", + "%cup", + "%full", + "%line", + "%{", + " String pstring = new String();", + " public int line_num() { return (yyline+1); }", + " public String buff() { return new String(yy_buffer,yy_buffer_index,10).trim(); }", + "%}" + ] + +--For now all categories are included. +--Optimally only the ones that are used should be generated. +cMacros :: [String] +cMacros = [ + "LETTER = ({CAPITAL}|{SMALL})", + "CAPITAL = [A-Z\\xC0-\\xD6\\xD8-\\xDE]", + "SMALL = [a-z\\xDF-\\xF6\\xF8-\\xFF]", + "DIGIT = [0-9]", + "IDENT = ({LETTER}|{DIGIT}|['_])", + "%state COMMENT", + "%state CHAR", + "%state CHARESC", + "%state CHAREND", + "%state STRING", + "%state ESCAPED", + "%%" + ] + +lexSymbols :: SymEnv -> [String] +lexSymbols ss = map transSym ss + where + transSym (s,r) = + "" ++ (escapeChars s) ++ " { return new Symbol(sym." + ++ r ++ "); }" + +restOfJLex :: CF -> [String] +restOfJLex cf = + [ + lexComments (comments cf), + userDefTokens, + ifC "String" strStates, + ifC "Char" chStates, + ifC "Double" "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }", + ifC "Integer" "{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }", + ifC "Ident" "{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, new String(yytext())); }" + , "[ \\t\\r\\n\\f] { /* ignore white space. */ }" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + userDefTokens = unlines $ + ["" ++ printRegJLex exp +++ + "{ return new Symbol(sym." ++ name ++ ", yytext()); }" + | (name, exp) <- tokenPragmas cf] + strStates = unlines --These handle escaped characters in Strings. + [ + "\"\\\"\" { yybegin(STRING); }", + "\\\\ { yybegin(ESCAPED); }", + "\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo); }", + ". { pstring += yytext(); }", + "n { pstring += \"\\n\"; yybegin(STRING); }", + "\\\" { pstring += \"\\\"\"; yybegin(STRING); }", + "\\\\ { pstring += \"\\\\\"; yybegin(STRING); }", + "t { pstring += \"\\t\"; yybegin(STRING); }", + ". { pstring += yytext(); yybegin(STRING); }" + ] + chStates = unlines --These handle escaped characters in Chars. + [ + "\"'\" { yybegin(CHAR); }", + "\\\\ { yybegin(CHARESC); }", + "[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", + "n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }", + "t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }", + ". { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", + "\"'\" {yybegin(YYINITIAL);}" + ] + + + + +lexComments :: ([(String, String)], [String]) -> String +lexComments (m,s) = + (unlines (map lexSingleComment s)) + ++ (unlines (map lexMultiComment m)) + +lexSingleComment :: String -> String +lexSingleComment c = + "\"" ++ c ++ "\"[^\\n]*\\n { /* BNFC single-line comment */ }" + +--There might be a possible bug here if a language includes 2 multi-line comments. +--They could possibly start a comment with one character and end it with another. +--However this seems rare. +lexMultiComment :: (String, String) -> String +lexMultiComment (b,e) = unlines [ + "\"" ++ b ++ "\" { yybegin(COMMENT); }", + "\"" ++ e ++ "\" { yybegin(YYINITIAL); }", + ". { }", + "[\\n] { }" + ] + +-- lexReserved :: String -> String +-- lexReserved s = "\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }" + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars = concatMap escapeChar diff --git a/formats/java/CFtoJavaAbs.hs b/formats/java/CFtoJavaAbs.hs new file mode 100644 --- /dev/null +++ b/formats/java/CFtoJavaAbs.hs @@ -0,0 +1,238 @@ +{- + BNF Converter: Java Abstract Syntax + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Java Abstract Syntax + It uses the NamedVariables module for variable + naming. It returns a list of file names, and the + contents to be written into that file. (In Java + public classes must go in their own file.) + + The generated classes also support the Visitor + Design Pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 24 April, 2003 + + Modified : 2 September, 2003 + + + ************************************************************** +-} + +module CFtoJavaAbs (cf2JavaAbs) where + +import CF +import Utils((+++),(++++)) +import NamedVariables hiding (IVar, getVars, varName) +import 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 diff --git a/formats/java/CFtoJavaPrinter.hs b/formats/java/CFtoJavaPrinter.hs new file mode 100644 --- /dev/null +++ b/formats/java/CFtoJavaPrinter.hs @@ -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 ++ "_" diff --git a/formats/java/CFtoJavaSkeleton.hs b/formats/java/CFtoJavaSkeleton.hs new file mode 100644 --- /dev/null +++ b/formats/java/CFtoJavaSkeleton.hs @@ -0,0 +1,124 @@ +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Skeleton Function + using Appel's method, not the Visitor Pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 29 April, 2003 + + Modified : 2 September, 2003 + + + ************************************************************** +-} +module CFtoJavaSkeleton (cf2JavaSkeleton) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import 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 ++ ");" diff --git a/formats/java/CFtoVisitSkel.hs b/formats/java/CFtoVisitSkel.hs new file mode 100644 --- /dev/null +++ b/formats/java/CFtoVisitSkel.hs @@ -0,0 +1,173 @@ +{- + BNF Converter: Java Vistor skeleton generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates a Skeleton function + which uses the Visitor Design Pattern, which + users may find more familiar than Appel's + method. + + Author : Michael Pellauer (pellauer@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 4 August, 2003 + + Modified : 2 September, 2003 + + + ************************************************************** +-} +module CFtoVisitSkel (cf2VisitSkel) where + +import CF +import Utils ((+++), (++++)) +import NamedVariables +import 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 diff --git a/formats/java/JavaTop.hs b/formats/java/JavaTop.hs new file mode 100644 --- /dev/null +++ b/formats/java/JavaTop.hs @@ -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) diff --git a/formats/java/RegToJLex.hs b/formats/java/RegToJLex.hs new file mode 100644 --- /dev/null +++ b/formats/java/RegToJLex.hs @@ -0,0 +1,86 @@ +module RegToJLex (printRegJLex, escapeChar) where + +-- modified from pretty-printer generated by the BNF converter + +import AbsBNF +import Char + +-- the top-level printing method +printRegJLex :: Reg -> String +printRegJLex = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend (0 :: Int) where + rend i ss = case ss of + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + cons s t = s ++ t + new i s = s + space t s = if null s then t else t ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ c = [escapeChar c] + prtList s = map (concat . prt 0) s + +escapeChar :: Char -> String +escapeChar '^' = "\\x5E" -- special case, since \^ is a control character escape +escapeChar x | x `elem` jlexReserved = '\\' : [x] +escapeChar x = [x] + +-- Characters that must be escaped in JLex regular expressions +jlexReserved :: [Char] +jlexReserved = ['?', '*', '+', '|', '(', ')', '^', '$', '.', '[', ']', '{', '}', '"', '\\'] + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + + -- JLex does not support set difference + --RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RMinus reg0 REps -> prt i reg0 -- REps is identity for set difference + RMinus RAny reg@(RChar _) -> prPrec i 3 (concat [["[^"],prt 0 reg,["]"]]) + RMinus RAny (RAlts str) -> prPrec i 3 (concat [["[^"],prt 0 str,["]"]]) + -- FIXME: maybe we could add cases for char - RDigit, RLetter etc. + RMinus reg0 reg -> error $ "JLex does not support general set difference" + + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["[^.]"]) + RChar c -> prPrec i 3 (concat [prt 0 c]) + RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) + RDigit -> prPrec i 3 (concat [["{DIGIT}"]]) + RLetter -> prPrec i 3 (concat [["{LETTER}"]]) + RUpper -> prPrec i 3 (concat [["{CAPITAL}"]]) + RLower -> prPrec i 3 (concat [["{SMALL}"]]) + RAny -> prPrec i 3 (concat [["."]]) + + + diff --git a/formats/java1.5/CFtoAbstractVisitor.hs b/formats/java1.5/CFtoAbstractVisitor.hs new file mode 100644 --- /dev/null +++ b/formats/java1.5/CFtoAbstractVisitor.hs @@ -0,0 +1,60 @@ +{- + BNF Converter: Java 1.5 Abstract Vistor generator + Copyright (C) 2006 Bjorn Bringert + Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoAbstractVisitor (cf2AbstractVisitor) where + +import CF +import CFtoJavaAbs15 (typename) +import Utils ((+++), (++++)) +import NamedVariables +import 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 implements AllVisitor {", + concatMap (prData packageAbsyn user) groups, + "}"] + where + user = fst (unzip (tokenPragmas cf)) + groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ] + +--Traverses a category based on its type. +prData :: String -> [UserDef] -> (Cat, [Rule]) -> String +prData packageAbsyn user (cat, rules) = + unlines $ ["/* " ++ identCat cat ++ " */"] + ++ map (prRule packageAbsyn user cat) rules + ++ [" public R visitDefault(" ++ q ++ " p, A arg) {", + " throw new IllegalArgumentException(this.getClass().getName() + \": \" + p);", + " }"] + where q = packageAbsyn ++ "." ++ identCat cat + +--traverses a standard rule. +prRule :: String -> [UserDef] -> Cat -> Rule -> String +prRule packageAbsyn user cat (fun, (_, cats)) + | not (isCoercion fun || isDefinedRule fun) = + " public R visit(" ++ cls ++ " p, A arg) { return visitDefault(p, arg); }" + where cls = packageAbsyn ++ "." ++ fun +prRule _ _ _ _ = "" + diff --git a/formats/java1.5/CFtoAllVisitor.hs b/formats/java1.5/CFtoAllVisitor.hs new file mode 100644 --- /dev/null +++ b/formats/java1.5/CFtoAllVisitor.hs @@ -0,0 +1,51 @@ +{- + BNF Converter: Java 1.5 All Visitor generator + Copyright (C) 2006 Bjorn Bringert + Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoAllVisitor (cf2AllVisitor) where + +import CF +import CFtoJavaAbs15 (typename) +import Utils ((+++), (++++)) +import NamedVariables +import 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 extends", + concat $ intersperse ",\n" $ map (" "++) is, + "{}"] + where + groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ] + is = map (prInterface packageAbsyn) groups + header = unlines [ + + ] + +prInterface :: String -> (Cat, [Rule]) -> String +prInterface packageAbsyn (cat, rules) = + q ++ ".Visitor" + where q = packageAbsyn ++ "." ++ identCat cat diff --git a/formats/java1.5/CFtoComposVisitor.hs b/formats/java1.5/CFtoComposVisitor.hs new file mode 100644 --- /dev/null +++ b/formats/java1.5/CFtoComposVisitor.hs @@ -0,0 +1,117 @@ +{- + BNF Converter: Java 1.5 Compositional Vistor generator + Copyright (C) 2006 Bjorn Bringert + Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoComposVisitor (cf2ComposVisitor) where + +import CF +import CFtoJavaAbs15 (typename) +import Utils ((+++), (++++)) +import NamedVariables +import 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 implements", + concat $ intersperse ",\n" $ map (" "++) is, + "{" + ] + + +prInterface :: String -> (Cat, [Rule]) -> String +prInterface packageAbsyn (cat, rules) = + q ++ ".Visitor<" ++ q ++ ",A>" + where q = packageAbsyn ++ "." ++ identCat cat + +commaList :: [String] -> String +commaList = concat . intersperse ", " + +--Traverses a category based on its type. +prData :: String -> [UserDef] -> (Cat, [Rule]) -> String +prData packageAbsyn user (cat, rules) = + unlines [ + "/* " ++ identCat cat ++ " */", + concatMap (prRule packageAbsyn user cat) rules + ] +--traverses a standard rule. +prRule :: String -> [UserDef] -> Cat -> Rule -> String +prRule packageAbsyn user cat (fun, (_, cats)) + | not (isCoercion fun || isDefinedRule fun) = unlines + [ + " public " ++ identCat cat ++ " visit(" ++ cls ++ " p, A arg)", + " {", + unlines (map (" "++) visitVars), + " return new " ++ cls ++ "(" ++ commaList children ++ ");", + " }" + ] + where + cats' = if allTerms cats + then [] + else [ (c,v) | + (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)), c /= internalCat ] + cls = packageAbsyn ++ "." ++ fun + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs + children = map snd cats' + visitVars = concatMap (uncurry (prCat user)) cats' +prRule _ _ _ _ = "" + +--Traverses a class's instance variables. +prCat :: [UserDef] + -> Cat -- ^ Variable category + -> String -- ^ Variable name + -> [String] -- ^ Code for visiting the variable +prCat user cat nt + | isBasicType user varType || (isListType varType && isBasicType user et) = [decl var] + | isListType varType = listAccept + | otherwise = [decl (var ++ ".accept(this, arg)")] + where + var = "p." ++ nt + varType = typename (normCat (identCat cat)) user + accept = var ++ ".accept(this, arg);" + et = typename (normCatOfList cat) user + decl v = varType +++ nt +++ "=" +++ v ++ ";" + listAccept = [decl ("new"+++varType++"()"), + "for (" ++ et ++ " x : " ++ var ++ ") {", + " " ++ nt ++ ".add(x.accept(this,arg));", + "}"] + +isListType :: String -> Bool +isListType nt = "List" `isPrefixOf` nt + +--Just checks if something is a basic or user-defined type. +isBasicType :: [UserDef] -> String -> Bool +isBasicType user v = v `elem` (user ++ ["Integer","Character","String","Double"]) + diff --git a/formats/java1.5/CFtoCup15.hs b/formats/java1.5/CFtoCup15.hs new file mode 100644 --- /dev/null +++ b/formats/java1.5/CFtoCup15.hs @@ -0,0 +1,274 @@ +{- + BNF Converter: Java 1.5 Cup Generator + Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer, + Bjorn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the CUP input file. It + follows the same basic structure of CFtoHappy. + + Author : Michael Pellauer (pellauer@cs.chalmers.se), + Bjorn Bringert (bringert@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 26 April, 2003 + + Modified : 5 Aug, 2004 + + + ************************************************************** +-} +module CFtoCup15 ( cf2Cup ) where + +import CF +import List (intersperse, isPrefixOf) +import NamedVariables +import Utils ( (+++) ) +import TypeChecker -- We need to (re-)typecheck to figure out list instances in + -- defined rules. +import ErrM + +import Data.Char + +-- Type declarations +type Rules = [(NonTerminal,[(Pattern,Action)])] +type NonTerminal = String +type Pattern = String +type Action = String +type MetaVar = String + +--The environment comes from the CFtoJLex +cf2Cup :: String -> String -> CF -> SymEnv -> String +cf2Cup packageBase packageAbsyn cf env = unlines + [ + header, + declarations packageAbsyn (allCats cf), + tokens env, + specialToks cf, + specialRules cf, + prEntryPoint cf, + prRules (rulesForCup packageAbsyn cf env) + ] + where + header :: String + header = unlines + ["// -*- Java -*- This Cup file was machine-generated by BNFC", + "package" +++ packageBase ++ ";", + "", + "parser code {:", + parseMethod packageAbsyn (firstEntry cf), + "public > A cons_(B x, A xs) { xs.addFirst(x); return xs; }", + definedRules packageAbsyn cf, + -- unlines $ map (parseMethod packageAbsyn) (allEntryPoints cf), + "public void syntax_error(java_cup.runtime.Symbol cur_token)", + "{", + "\treport_error(\"Syntax Error, trying to recover and continue parse...\", cur_token);", + "}", + "", + "public void unrecovered_syntax_error(java_cup.runtime.Symbol cur_token) throws java.lang.Exception", + "{", + "\tthrow new Exception(\"Unrecoverable Syntax Error\");", + "}", + "", + ":}" + ] + +definedRules :: String -> CF -> String +definedRules packageAbsyn cf@((pr,_),_) = + unlines [ rule f xs e | FunDef f xs e <- pr ] + where + ctx = buildContext cf + + list = LC (\t -> "List" ++ unBase t) (const "cons") + where + unBase (ListT t) = unBase t + unBase (BaseT x) = normCat x + + rule f xs e = + case checkDefinition' list ctx f xs e of + Bad err -> error $ "Panic! This should have been caught already:\n" ++ err + Ok (args,(e',t)) -> unlines + [ "public " ++ javaType t ++ " " ++ f ++ "_ (" ++ + concat (intersperse ", " $ map javaArg args) ++ ") {" + , " return " ++ javaExp e' ++ ";" + , "}" + ] + where + + javaType :: Base -> String + javaType (ListT (BaseT x)) = packageAbsyn ++ ".List" ++ normCat x + javaType (ListT t) = javaType t + javaType (BaseT x) + | isToken x ctx = "String" + | otherwise = packageAbsyn ++ "." ++ normCat x + + javaArg :: (String, Base) -> String + javaArg (x,t) = javaType t ++ " " ++ x ++ "_" + + javaExp :: Exp -> String + javaExp (App "null" []) = "null" + javaExp (App x []) + | elem x xs = x ++ "_" -- argument + javaExp (App t [e]) + | isToken t ctx = call ("new String") [e] + javaExp (App x es) + | isUpper (head x) = call ("new " ++ packageAbsyn ++ "." ++ x) es + | otherwise = call (x ++ "_") es + javaExp (LitInt n) = "new Integer(" ++ show n ++ ")" + javaExp (LitDouble x) = "new Double(" ++ show x ++ ")" + javaExp (LitChar c) = "new Character(" ++ show c ++ ")" + javaExp (LitString s) = "new String(" ++ show s ++ ")" + + call x es = x ++ "(" ++ concat (intersperse ", " $ map javaExp es) ++ ")" + + +-- peteg: FIXME JavaCUP can only cope with one entry point AFAIK. +prEntryPoint :: CF -> String +prEntryPoint cf = unlines ["", "start with " ++ firstEntry cf ++ ";", ""] +-- [ep] -> unlines ["", "start with " ++ ep ++ ";", ""] +-- eps -> error $ "FIXME multiple entry points." ++ show eps + +--This generates a parser method for each entry point. +parseMethod :: String -> Cat -> String +parseMethod packageAbsyn cat = + if normCat cat /= cat + then "" + else unlines + [ + " public" +++ packageAbsyn ++ "." ++ cat' +++ "p" ++ cat' ++ "()" + ++ " throws Exception", + " {", + "\tjava_cup.runtime.Symbol res = parse();", + "\treturn (" ++ packageAbsyn ++ "." ++ cat' ++ ") res.value;", + " }" + ] + where cat' = identCat (normCat cat) + +--non-terminal types +declarations :: String -> [NonTerminal] -> String +declarations packageAbsyn ns = unlines (map (typeNT packageAbsyn) ns) + where + typeNT _nm nt = "nonterminal" +++ packageAbsyn ++ "." + ++ identCat (normCat nt) +++ identCat nt ++ ";" + +--terminal types +tokens :: SymEnv -> String +tokens ts = unlines (map declTok ts) + where + declTok (s,r) = "terminal" +++ r ++ "; // " ++ s + +specialToks :: CF -> String +specialToks cf = unlines [ + ifC "String" "terminal String _STRING_;", + ifC "Char" "terminal Character _CHAR_;", + ifC "Integer" "terminal Integer _INTEGER_;", + ifC "Double" "terminal Double _DOUBLE_;", + ifC "Ident" "terminal String _IDENT_;" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + +-- This handles user defined tokens +-- FIXME +specialRules:: CF -> String +specialRules cf = + unlines ["terminal String " ++ name ++ ";" | (name, _) <- tokenPragmas cf] + +--The following functions are a (relatively) straightforward translation +--of the ones in CFtoHappy.hs +rulesForCup :: String -> CF -> SymEnv -> Rules +rulesForCup packageAbsyn cf env = map mkOne $ ruleGroups cf where + mkOne (cat,rules) = constructRule packageAbsyn cf env rules cat + +-- For every non-terminal, we construct a set of rules. A rule is a sequence of +-- terminals and non-terminals, and an action to be performed. +constructRule :: String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule packageAbsyn cf env rules nt = + (nt, [(p,generateAction packageAbsyn nt (funRule r) (revM b m) b) + | r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True, revSepListRule r0) + else (False, r0) + (p,m) = generatePatterns cf env r]) + where + revM False m = m + revM True [h,t] = [t,h] + revs = reversibleCats cf + +-- Generates a string containing the semantic action. +generateAction :: String -> NonTerminal -> Fun -> [MetaVar] + -> Bool -- ^ Whether the list should be reversed or not. + -- Only used if this is a list rule. + -> Action +generateAction packageAbsyn nt f ms rev + | isNilFun f = "RESULT = new " ++ c ++ "();" + | isOneFun f = "RESULT = new " ++ c ++ "(); RESULT.addLast(" ++ p_1 ++ ");" + | isConsFun f = "RESULT = " ++ p_2 ++ "; " + ++ p_2 ++ "." ++ add ++ "(" ++ p_1 ++ ");" + | isCoercion f = "RESULT = " ++ p_1 ++ ";" + | isDefinedRule f = "RESULT = parser." ++ f ++ "_" + ++ "(" ++ concat (intersperse "," ms) ++ ");" + | otherwise = "RESULT = new " ++ c + ++ "(" ++ concat (intersperse "," ms) ++ ");" + where + c = packageAbsyn ++ "." ++ + if isNilFun f || isOneFun f || isConsFun f + then identCat (normCat nt) else f + p_1 = ms!!0 + p_2 = ms!!1 + add = if rev then "addLast" else "addFirst" + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal +generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar]) +generatePatterns cf env r = case rhsRule r of + [] -> (" /* empty */ ",[]) + its -> (mkIt env 1 its, metas its) + where + mkIt _env _n [] = [] + mkIt env n (i:is) = case i of + Left c -> c' ++ ":p_" ++ (show (n :: Int)) +++ (mkIt env (n+1) is) + where + c' = case c of + "Ident" -> "_IDENT_" + "Integer" -> "_INTEGER_" + "Char" -> "_CHAR_" + "Double" -> "_DOUBLE_" + "String" -> "_STRING_" + _ -> identCat c + Right s -> case (lookup s env) of + (Just x) -> x +++ (mkIt env (n+1) is) + (Nothing) -> (mkIt env n is) + metas its = ["p_" ++ show i | (i,Left c) <- zip [1 :: Int ..] its] + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. +prRules :: Rules -> String +prRules [] = [] +prRules ((nt, []):rs) = prRules rs --internal rule +prRules ((nt,((p,a):ls)):rs) = + (unwords [nt', "::=", p, "{:", a, ":}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs + where + nt' = identCat nt + pr [] = [] + pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{:", a , ":}"])]) ++ pr ls + diff --git a/formats/java1.5/CFtoFoldVisitor.hs b/formats/java1.5/CFtoFoldVisitor.hs new file mode 100644 --- /dev/null +++ b/formats/java1.5/CFtoFoldVisitor.hs @@ -0,0 +1,104 @@ +{- + BNF Converter: Java 1.5 Fold Vistor generator + Copyright (C) 2006 Bjorn Bringert + Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoFoldVisitor (cf2FoldVisitor) where + +import CF +import CFtoJavaAbs15 (typename) +import Utils ((+++), (++++)) +import NamedVariables +import 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 implements AllVisitor {", + " public abstract R leaf(A arg);", + " public abstract R combine(R x, R y, A arg);", + "", + concatMap (prData packageAbsyn user) groups, + "}"] + where + user = fst (unzip (tokenPragmas cf)) + groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ] + +--Traverses a category based on its type. +prData :: String -> [UserDef] -> (Cat, [Rule]) -> String +prData packageAbsyn user (cat, rules) = + unlines [ + "/* " ++ identCat cat ++ " */", + concatMap (prRule packageAbsyn user cat) rules + ] + +--traverses a standard rule. +prRule :: String -> [UserDef] -> Cat -> Rule -> String +prRule packageAbsyn user cat (fun, (_, cats)) + | not (isCoercion fun || isDefinedRule fun) = unlines $ + [" public R visit(" ++ cls ++ " p, A arg) {", + " R r = leaf(arg);"] + ++ map (" "++) visitVars + ++ [" return r;", + " }"] + where + cats' = if allTerms cats + then [] + else [ (c,v) | + (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)), c /= internalCat ] + cls = packageAbsyn ++ "." ++ fun + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs + children = map snd cats' + visitVars = concatMap (uncurry (prCat user)) cats' +prRule _ _ _ _ = "" + +--Traverses a class's instance variables. +prCat :: [UserDef] + -> Cat -- ^ Variable category + -> String -- ^ Variable name + -> [String] -- ^ Code for visiting the variable +prCat user cat nt + | isBasicType user varType || (isListType varType && isBasicType user et) = [] + | isListType varType = listAccept + | otherwise = ["r = combine(" ++ var ++ ".accept(this, arg), r, arg);"] + where + var = "p." ++ nt + varType = typename (normCat (identCat cat)) user + et = typename (normCatOfList cat) user + listAccept = ["for (" ++ et ++ " x : " ++ var ++ ") {", + " r = combine(x.accept(this,arg), r, arg);", + "}"] + +isListType :: String -> Bool +isListType nt = "List" `isPrefixOf` nt + +--Just checks if something is a basic or user-defined type. +isBasicType :: [UserDef] -> String -> Bool +isBasicType user v = v `elem` (user ++ ["Integer","Character","String","Double"]) + diff --git a/formats/java1.5/CFtoJLex15.hs b/formats/java1.5/CFtoJLex15.hs new file mode 100644 --- /dev/null +++ b/formats/java1.5/CFtoJLex15.hs @@ -0,0 +1,175 @@ +{- + BNF Converter: Java JLex generator + Copyright (C) 2004 Author: Michael Pellauer + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the JLex input file. This + file is quite different than Alex or Flex. + + Author : Michael Pellauer (pellauer@cs.chalmers.se), + Bjorn Bringert (bringert@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 25 April, 2003 + + Modified : 4 Nov, 2004 + + + ************************************************************** +-} + +module CFtoJLex15 ( cf2jlex ) where + +import CF +import RegToJLex +import Utils ( (+++) ) +import NamedVariables +import List + +--The environment must be returned for the parser to use. +cf2jlex :: String -> String -> CF -> (String, SymEnv) +cf2jlex packageBase packageAbsyn cf = (unlines $ concat $ + [ + prelude packageBase packageAbsyn, + cMacros, + lexSymbols env, + restOfJLex cf + ], env) + where + env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int) + makeSymEnv [] _ = [] + makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1)) + +prelude :: String -> String -> [String] +prelude packageBase packageAbsyn = + [ + "// This JLex file was machine-generated by the BNF converter", + "package" +++ packageBase ++ ";", + "", + "import java_cup.runtime.*;", + "%%", + "%cup", + "%unicode", + "%line", + "%public", + "%{", + " String pstring = new String();", + " public int line_num() { return (yyline+1); }", + " public String buff() { return new String(yy_buffer,yy_buffer_index,10).trim(); }", + "%}" + ] + +--For now all categories are included. +--Optimally only the ones that are used should be generated. +cMacros :: [String] +cMacros = [ + "LETTER = ({CAPITAL}|{SMALL})", + "CAPITAL = [A-Z\\xC0-\\xD6\\xD8-\\xDE]", + "SMALL = [a-z\\xDF-\\xF6\\xF8-\\xFF]", + "DIGIT = [0-9]", + "IDENT = ({LETTER}|{DIGIT}|['_])", + "%state COMMENT", + "%state CHAR", + "%state CHARESC", + "%state CHAREND", + "%state STRING", + "%state ESCAPED", + "%%" + ] + +lexSymbols :: SymEnv -> [String] +lexSymbols ss = map transSym ss + where + transSym (s,r) = + "" ++ (escapeChars s) ++ " { return new Symbol(sym." + ++ r ++ "); }" + +restOfJLex :: CF -> [String] +restOfJLex cf = + [ + lexComments (comments cf), + userDefTokens, + ifC "String" strStates, + ifC "Char" chStates, + ifC "Double" "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }", + ifC "Integer" "{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }", + ifC "Ident" "{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, yytext().intern()); }" + , "[ \\t\\r\\n\\f] { /* ignore white space. */ }" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + userDefTokens = unlines $ + ["" ++ printRegJLex exp +++ + "{ return new Symbol(sym." ++ name ++ ", yytext().intern()); }" + | (name, exp) <- tokenPragmas cf] + strStates = unlines --These handle escaped characters in Strings. + [ + "\"\\\"\" { yybegin(STRING); }", + "\\\\ { yybegin(ESCAPED); }", + "\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo.intern()); }", + ". { pstring += yytext(); }", + "n { pstring += \"\\n\"; yybegin(STRING); }", + "\\\" { pstring += \"\\\"\"; yybegin(STRING); }", + "\\\\ { pstring += \"\\\\\"; yybegin(STRING); }", + "t { pstring += \"\\t\"; yybegin(STRING); }", + ". { pstring += yytext(); yybegin(STRING); }" + ] + chStates = unlines --These handle escaped characters in Chars. + [ + "\"'\" { yybegin(CHAR); }", + "\\\\ { yybegin(CHARESC); }", + "[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", + "n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }", + "t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }", + ". { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", + "\"'\" {yybegin(YYINITIAL);}" + ] + + + + +lexComments :: ([(String, String)], [String]) -> String +lexComments (m,s) = + (unlines (map lexSingleComment s)) + ++ (unlines (map lexMultiComment m)) + +lexSingleComment :: String -> String +lexSingleComment c = + "\"" ++ c ++ "\"[^\\n]*\\n { /* BNFC single-line comment */ }" + +--There might be a possible bug here if a language includes 2 multi-line comments. +--They could possibly start a comment with one character and end it with another. +--However this seems rare. +lexMultiComment :: (String, String) -> String +lexMultiComment (b,e) = unlines [ + "\"" ++ b ++ "\" { yybegin(COMMENT); }", + "\"" ++ e ++ "\" { yybegin(YYINITIAL); }", + ". { }", + "[\\n] { }" + ] + +-- lexReserved :: String -> String +-- lexReserved s = "\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }" + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars = concatMap escapeChar diff --git a/formats/java1.5/CFtoJavaAbs15.hs b/formats/java1.5/CFtoJavaAbs15.hs new file mode 100644 --- /dev/null +++ b/formats/java1.5/CFtoJavaAbs15.hs @@ -0,0 +1,263 @@ +{- + BNF Converter: Java 1.5 Abstract Syntax + Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates the Java Abstract Syntax + It uses the NamedVariables module for variable + naming. It returns a list of file names, and the + contents to be written into that file. (In Java + public classes must go in their own file.) + + The generated classes also support the Visitor + Design Pattern. + + Author : Michael Pellauer (pellauer@cs.chalmers.se), + Bjorn Bringert (bringert@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 24 April, 2003 + + Modified : 16 June, 2004 + + + ************************************************************** +-} + +module CFtoJavaAbs15 (cf2JavaAbs, typename) where + +import CF +import Utils((+++),(++++)) +import NamedVariables hiding (IVar, getVars, varName) +import 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 accept(" + ++ cls ++ ".Visitor v, A arg);", + prVisitor packageAbsyn funs, + "}" + ])] + where cls = identCat cat + +prVisitor :: String -> [String] -> String +prVisitor packageAbsyn funs = + unlines [ + " public interface Visitor {", + unlines (map prVisitFun funs), + " }" + ] + where + prVisitFun f = " public R visit(" ++ packageAbsyn ++ "." ++ f ++ " p, A arg);" + +--Generates classes for a rule, depending on what type of rule it is. +prRule :: String -- ^ Header + -> String -- ^ Abstract syntax package name + -> [String] -- ^ Names of all constructors in the category + -> [UserDef] -> String -> (Fun, [Cat]) -> Maybe (String, String) +prRule h packageAbsyn funs user c (fun, cats) = + if isNilFun fun || isOneFun fun + then Nothing --these are not represented in the AbSyn + else if isConsFun fun + then Just $ (fun', --this is the linked list case. + unlines + [ + h, + "public class" +++ fun' +++ "extends java.util.LinkedList<"++ et ++"> {", + "}" + ]) + else Just $ (fun, --a standard rule + unlines + [ + h, + "public class" +++ fun ++ ext +++ "{", + (prInstVars vs), + prConstructor fun user vs cats, + prAccept packageAbsyn c fun, + prEquals packageAbsyn fun vs, + prHashCode packageAbsyn fun vs, + if isAlsoCategory then prVisitor packageAbsyn funs else "", + "}" + ]) + where + vs = getVars cats user + fun' = identCat (normCat c) + isAlsoCategory = fun == c + --This handles the case where a LBNF label is the same as the category. + ext = if isAlsoCategory then "" else " extends" +++ (identCat c) + et = typename (normCatOfList c) user + + +--The standard accept function for the Visitor pattern +prAccept :: String -> String -> String -> String +prAccept pack cat _ = "\n public R accept(" ++ pack ++ "." ++ cat + ++ ".Visitor v, A arg) { return v.visit(this, arg); }\n" + +-- Creates the equals() method. +prEquals :: String -> String -> [IVar] -> String +prEquals pack fun vs = + unlines $ map (" "++) $ ["public boolean equals(Object o) {", + " if (this == o) return true;", + " if (o instanceof " ++ fqn ++ ") {"] + ++ (if null vs + then [" return true;"] + else [" " ++ fqn +++ "x = ("++fqn++")o;", + " return " ++ checkKids ++ ";"]) ++ + [" }", + " return false;", + "}"] + where + fqn = pack++"."++fun + checkKids = concat $ intersperse " && " $ map checkKid vs + checkKid iv = "this." ++ v ++ ".equals(x." ++ v ++ ")" + where v = iVarName iv + +-- Creates the equals() method. +prHashCode :: String -> String -> [IVar] -> String +prHashCode pack fun vs = + unlines $ map (" "++) ["public int hashCode() {", + " return " ++ hashKids vs ++ ";", + "}" + ] + where + aPrime = 37 + hashKids [] = show aPrime + hashKids (v:vs) = hashKids_ (hashKid v) vs + hashKids_ r [] = r + hashKids_ r (v:vs) = hashKids_ (show aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashKid v) vs + hashKid iv = "this." ++ iVarName iv ++ ".hashCode()" + + +--A class's instance variables. +prInstVars :: [IVar] -> String +prInstVars [] = [] +prInstVars vars@((t,n,nm):vs) = + " public" +++ "final" +++ t +++ uniques ++ ";" ++++ + (prInstVars vs') + where + (uniques, vs') = prUniques t vars + --these functions group the types together nicely + prUniques :: String -> [IVar] -> (String, [IVar]) + prUniques t vs = (prVars (findIndices (\x -> case x of (y,_,_) -> y == t) vs) vs, remType t vs) + prVars (x:[]) vs = iVarName (vs!!x) + prVars (x:xs) vs = iVarName (vs!!x) ++ "," +++ prVars xs vs + remType :: String -> [IVar] -> [IVar] + remType _ [] = [] + remType t ((t2,n,nm):ts) = if t == t2 + then (remType t ts) + else (t2,n,nm) : (remType t ts) + +iVarName :: IVar -> String +iVarName (t,n,nm) = varName t nm ++ showNum n + +--The constructor just assigns the parameters to the corresponding instance variables. +prConstructor :: String -> [UserDef] -> [IVar] -> [Cat] -> String +prConstructor c u vs cats = + " public" +++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" +++ + prAssigns vs params ++ "}" + where + (types, params) = unzip (prParams cats u (length cats) ((length cats)+1)) + interleave _ [] = [] + interleave (x:[]) (y:[]) = x +++ y + interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys) + +--Prints the parameters to the constructors. +prParams :: [Cat] -> [UserDef] -> Int -> Int -> [(String,String)] +prParams [] _ _ _ = [] +prParams (c:cs) u n m = (identCat c',"p" ++ (show (m-n))) + : (prParams cs u (n-1) m) + where + c' = typename c u + +--This algorithm peeks ahead in the list so we don't use map or fold +prAssigns :: [IVar] -> [String] -> String +prAssigns [] _ = [] +prAssigns _ [] = [] +prAssigns ((t,n,nm):vs) (p:ps) = + if n == 1 then + case findIndices (\x -> case x of (l,r,_) -> l == t) vs of + [] -> (varName t nm) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + z -> ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + else ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps) + +--Different than the standard NamedVariables version because of the user-defined +--types. +getVars :: [Cat] -> [UserDef] -> [IVar] +getVars cs user = reverse $ singleToZero $ foldl addVar [] (map identCat cs) + where + addVar is c = (c', n, nm):is + where c' = typename c user + nm = if c == c' then Nothing else Just c + n = maximum (1:[n'+1 | (t,n',_) <- is, t == c']) + singleToZero is = [(t,n',nm) | (t,n,nm) <- is, + let n' = if length (filter (hasType t) is) == 1 + then 0 else n] + hasType t (t',_,_) = t == t' + +varName :: String -- ^ Category + -> Maybe String -- ^ Java type name + -> String -- ^ Variable name +varName c jt = (map toLower c') ++ "_" + where + c' = fromMaybe c jt + +--This makes up for the fact that there's no typedef in Java +typename :: String -> [UserDef] -> String +typename t user = + if t == "Ident" + then "String" + else if t == "Char" + then "Character" + else if elem t user + then "String" + else t diff --git a/formats/java1.5/CFtoJavaPrinter15.hs b/formats/java1.5/CFtoJavaPrinter15.hs new file mode 100644 --- /dev/null +++ b/formats/java1.5/CFtoJavaPrinter15.hs @@ -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 ++ "_" diff --git a/formats/java1.5/CFtoVisitSkel15.hs b/formats/java1.5/CFtoVisitSkel15.hs new file mode 100644 --- /dev/null +++ b/formats/java1.5/CFtoVisitSkel15.hs @@ -0,0 +1,141 @@ +{- + BNF Converter: Java Vistor skeleton generator + Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- + ************************************************************** + BNF Converter Module + + Description : This module generates a Skeleton function + which uses the Visitor Design Pattern, which + users may find more familiar than Appel's + method. + + Author : Michael Pellauer (pellauer@cs.chalmers.se), + Bjorn Bringert (bringert@cs.chalmers.se) + + License : GPL (GNU General Public License) + + Created : 4 August, 2003 + + Modified : 16 June, 2004 + + + ************************************************************** +-} +module CFtoVisitSkel15 (cf2VisitSkel) where + +import CF +import CFtoJavaAbs15 (typename) +import Utils ((+++), (++++)) +import NamedVariables +import 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 implements " + ++ identCat cat ++ ".Visitor", + " {", + concatMap (prRule packageAbsyn user) rules, + " }" + ] + +--traverses a standard rule. +prRule :: String -> [UserDef] -> Rule -> String +prRule packageAbsyn user (fun, (c, cats)) | not (isCoercion fun || isDefinedRule fun) = unlines + [ + " public R visit(" ++ packageAbsyn ++ "." ++ fun ++ " p, A arg)", + " {", + " /* Code For " ++ fun ++ " Goes Here */", + "", + concatMap (uncurry (prCat user)) cats', + " return null;", + " }" + ] + where + cats' = if allTerms cats + then [] + else [ (c,v) | + (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)) ] + allTerms [] = True + allTerms ((Left z):zs) = False + allTerms (z:zs) = allTerms zs +prRule user nm (fun, cats) = "" + +--Traverses a class's instance variables. +prCat :: [UserDef] + -> Cat -- ^ Variable category + -> String -- ^ Variable name + -> String -- ^ Code for visiting the variable +prCat user cat nt | isBasic user nt = " //" ++ var ++ ";\n" + | "list" `isPrefixOf` nt = listAccept + | otherwise = " " ++ accept ++ "\n" + where + var = "p." ++ nt + varType = typename (normCat (identCat cat)) user + accept = var ++ ".accept(new " ++ varType ++ "Visitor(), arg);" + et = typename (normCatOfList cat) user + listAccept = unlines [" for (" ++ et ++ " x : " ++ var ++ ") {", + " }"] + +--Just checks if something is a basic or user-defined type. +--This is because you don't -> a basic non-pointer type. +isBasic :: [UserDef] -> String -> Bool +isBasic user v = + if elem (init v) user' + then True + else if "integer_" `isPrefixOf` v then True + else if "char_" `isPrefixOf` v then True + else if "string_" `isPrefixOf` v then True + else if "double_" `isPrefixOf` v then True + else if "ident_" `isPrefixOf` v then True + else False + where + user' = map (map toLower) user diff --git a/formats/java1.5/JavaTop15.hs b/formats/java1.5/JavaTop15.hs new file mode 100644 --- /dev/null +++ b/formats/java1.5/JavaTop15.hs @@ -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) diff --git a/formats/ocaml/CFtoOCamlAbs.hs b/formats/ocaml/CFtoOCamlAbs.hs new file mode 100644 --- /dev/null +++ b/formats/ocaml/CFtoOCamlAbs.hs @@ -0,0 +1,63 @@ +{- + BNF Converter: OCaml Abstract Syntax Generator + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- based on BNFC Haskell backend + +module CFtoOCamlAbs (cf2Abstract) where + +import CF +import Utils((+++),(++++)) +import List(intersperse) +import OCamlUtil + +-- to produce an OCaml module +cf2Abstract :: String -> CF -> String +cf2Abstract name cf = unlines $ + "(* OCaml module generated by the BNF converter *)\n\n" : + mutualRecDefs (map (prSpecialData cf) (specialCats cf) ++ map prData (cf2data cf)) + +-- allow mutual recursion so that we do not have to sort the type definitions in +-- dependency order +mutualRecDefs :: [String] -> [String] +mutualRecDefs ss = case ss of + [] -> [] + [x] -> ["type" +++ x] + x:xs -> ("type" +++ x) : map ("and" +++) xs + + + +prData :: Data -> String +prData (cat,rules) = + fixType cat +++ "=\n " ++ + concat (intersperse "\n | " (map prRule rules)) ++ + "\n" + +prRule (fun,[]) = fun +prRule (fun,cats) = fun +++ "of" +++ mkTupleType cats + +mkTupleType [c] = fixType c +mkTupleType (c:cs) = fixType c +++ "*" +++ mkTupleType cs + +prSpecialData :: CF -> Cat -> String +prSpecialData cf cat = fixType cat +++ "=" +++ cat +++ "of" +++ contentSpec cf cat +-- unwords ["newtype",cat,"=",cat,contentSpec cf cat,"deriving (Eq,Ord,Show)"] + +contentSpec :: CF -> Cat -> String +contentSpec cf cat = -- if isPositionCat cf cat then "((Int,Int),String)" else "String" + if isPositionCat cf cat then "((int * int) * string)" else "string" diff --git a/formats/ocaml/CFtoOCamlLex.hs b/formats/ocaml/CFtoOCamlLex.hs new file mode 100644 --- /dev/null +++ b/formats/ocaml/CFtoOCamlLex.hs @@ -0,0 +1,230 @@ +{- + BNF Converter: ocamllex Generator + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + +-- based on BNFC Haskell backend + +module CFtoOCamlLex (cf2ocamllex) where + +import 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 prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["\"\""]) -- special construct for eps in ocamllex? + RChar c -> prPrec i 3 (concat [prt 0 c]) + RAlts str -> prPrec i 3 (concat [["["],prt 0 (concatMap show str),["]"]]) + RSeqs str -> prPrec i 2 (concat (map (prt 0) str)) + RDigit -> prPrec i 3 (concat [["digit"]]) + RLetter -> prPrec i 3 (concat [["letter"]]) + RUpper -> prPrec i 3 (concat [["upper"]]) + RLower -> prPrec i 3 (concat [["lower"]]) + RAny -> prPrec i 3 (concat [["univ"]]) diff --git a/formats/ocaml/CFtoOCamlPrinter.hs b/formats/ocaml/CFtoOCamlPrinter.hs new file mode 100644 --- /dev/null +++ b/formats/ocaml/CFtoOCamlPrinter.hs @@ -0,0 +1,200 @@ +{- + BNF Converter: Pretty-printer generator + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- based on BNFC Haskell backend + +module CFtoOCamlPrinter (cf2Printer) where + +import CF +import Utils +import CFtoTemplate +import 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 String +rules cf = unlines $ mutualDefs $ + map (\(s,xs) -> case_fun s (map toArgs xs) ++ ifList cf s) $ cf2data cf + where + toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons) + names [] _ = [] + names (x:xs) n + | elem x xs = (x ++ show n) : names xs (n+1) + | otherwise = x : names xs n + var ('[':xs) = var (init xs) ++ "s" + var "Ident" = "id" + var "Integer" = "n" + var "String" = "str" + var "Char" = "c" + var "Double" = "d" + var xs = map toLower xs + checkRes s + | elem s reservedOCaml = s ++ "'" + | otherwise = s + ruleOf s = maybe undefined id $ lookup s (rulesOfCF cf) + +--- case_fun :: Cat -> [(Constructor,Rule)] -> String +case_fun cat xs = unlines [ +-- "instance Print" +++ cat +++ "where", + prtFun cat +++"(i:int)" +++ "(e:" ++ fixType cat ++ ") : doc = match e with", + unlines $ insertBar $ map (\ ((c,xx),r) -> + " " ++ c +++ mkTuple xx +++ "->" +++ + "prPrec i" +++ show (precCat (fst r)) +++ mkRhs xx (snd r)) xs + ] + +ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where + nil cat = [" [] -> " ++ mkRhs [] its | + (f,(c,its)) <- rulesOfCF cf, isNilFun f , normCatOfList c == cat] + one cat = [" | [x] -> " ++ mkRhs ["x"] its | + (f,(c,its)) <- rulesOfCF cf, isOneFun f , normCatOfList c == cat] + cons cat = [" | x::xs -> " ++ mkRhs ["x","xs"] its | + (f,(c,its)) <- rulesOfCF cf, isConsFun f , normCatOfList c == cat] + mkListRule [] = "" + mkListRule rs = unlines $ ("and prt" ++ fixTypeUpper cat ++ "ListBNFC" +++ "_ es : doc = match es with"):rs + + +mkRhs args its = + "(concatD [" ++ unwords (intersperse ";" (mk args its)) ++ "])" + where + mk args (Left "#" : items) = mk args items + mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items + mk args (Right s : items) = ("render " ++ show s) : mk args items + mk _ _ = [] + prt c = prtFun c +++ show (precCat c) + +prtFun :: Cat -> String +prtFun c = case c of + '[':xs -> case break (== ']') xs of + (t,"]") -> prtFun t ++ "ListBNFC" + _ -> c -- should not occur (this means an invariant of the type Cat is broken) + _ -> if precCat c > 0 -- precedence-level cats are not in abstract syntax + then "prt" ++ (fixTypeUpper $ reverse (dropWhile isDigit (reverse c))) + else "prt" ++ (fixTypeUpper c) + diff --git a/formats/ocaml/CFtoOCamlShow.hs b/formats/ocaml/CFtoOCamlShow.hs new file mode 100644 --- /dev/null +++ b/formats/ocaml/CFtoOCamlShow.hs @@ -0,0 +1,153 @@ +{- + BNF Converter: Non-pretty-printer generator (no "deriving Show" in OCaml...) + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- there is no "deriving Show" in OCaml, although there are solutions based +-- on camlp4. Here we generate our own "show module". + + +module CFtoOCamlShow (cf2show) where + +import CF +import Utils +import CFtoTemplate +import 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) + diff --git a/formats/ocaml/CFtoOCamlTemplate.hs b/formats/ocaml/CFtoOCamlTemplate.hs new file mode 100644 --- /dev/null +++ b/formats/ocaml/CFtoOCamlTemplate.hs @@ -0,0 +1,73 @@ +{- + BNF Converter: Template Generator + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- based on BNFC Haskell backend + + +module CFtoOCamlTemplate ( + cf2Template + ) where + +import CF +import 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] + diff --git a/formats/ocaml/CFtoOCamlTest.hs b/formats/ocaml/CFtoOCamlTest.hs new file mode 100644 --- /dev/null +++ b/formats/ocaml/CFtoOCamlTest.hs @@ -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 ();;", + "" + ] + + diff --git a/formats/ocaml/CFtoOCamlYacc.hs b/formats/ocaml/CFtoOCamlYacc.hs new file mode 100644 --- /dev/null +++ b/formats/ocaml/CFtoOCamlYacc.hs @@ -0,0 +1,232 @@ +{- + BNF Converter: ocamlyacc Generator + Copyright (C) 2005 Author: Kristofer Johannisson + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +-- based on BNFC Haskell backend + + +module CFtoOCamlYacc + ( + cf2ocamlyacc, terminal + ) + where + +import CF +import 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" -> "" + "Integer" -> "" + "Double" -> "" + "Char" -> "" + own -> "" ) + +++ "TOK_" ++ cat + + +entryPoints :: String -> CF -> String +entryPoints absName cf = unlines $ + ("%start" +++ + concat (intersperse " " (map epName eps))) + : + (map typing eps) + where eps = (nub $ map normCat (allEntryPoints cf)) + typing :: Cat -> String + typing c = "%type" +++ "<" ++ qualify c ++ ">" +++ epName c + qualify c = if c `elem` ["Integer","Double","Char","String", + "[Integer]","[Double]","[Char]","[String]"] + then fixType c + else absName ++ "." ++ fixType c + +epName :: Cat -> String +epName c = "p" ++ capitalize (nonterminal c) + where capitalize s = case s of + [] -> [] + c:cs -> toUpper c : cs + +entryPointRules :: CF -> String +entryPointRules cf = unlines $ map mkRule (nub $ map normCat (allEntryPoints cf)) + where + mkRule :: String -> String + mkRule s = unlines [ + epName s ++ " : " ++ nonterminal s ++ " TOK_EOF { $1 }", + " | error { raise (BNFC_Util.Parse_error (Parsing.symbol_start_pos (), Parsing.symbol_end_pos ())) };" + ] + +rules :: CF -> String +rules cf = unlines [ + entryPointRules cf, + (unlines $ map (prOne . mkOne) (ruleGroups cf)), + specialRules cf + ] + where + mkOne (cat,rules) = constructRule cf rules cat + prOne (nt,[]) = [] -- nt has only internal use + prOne (nt,((p,a):ls)) = + unwords [nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ ";\n" + where + nt' = nonterminal nt + pr [] = [] + pr ((p,a):ls) = + unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls + + + +-- For every non-terminal, we construct a set of rules. A rule is a sequence of +-- terminals and non-terminals, and an action to be performed +-- As an optimization, a pair of list rules [C] ::= "" | C k [C] +-- is left-recursivized into [C] ::= "" | [C] C k. +-- This could be generalized to cover other forms of list rules. +constructRule :: CF -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) +constructRule cf rules nt = (nt,[(p,generateAction nt (funRule r) (mkFlip b m)) | + r0 <- rules, + let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs + then (True,revSepListRule r0) + else (False,r0), + let (p,m) = generatePatterns cf r]) + where + revs = reversibleCats cf + mkFlip doit xs = case xs of + a:b:rest | doit -> b:a:rest + _ -> xs + + + +-- Generates a string containing the semantic action. +-- An action can for example be: Sum $1 $2, that is, construct an AST +-- with the constructor Sum applied to the two metavariables $1 and $2. +generateAction :: NonTerminal -> Fun -> [MetaVar] -> Action +generateAction nt f ms = (if isCoercion f then "" else f') +++ mkTuple ms + where f' = case f of -- ocaml cons is somehow not a standard infix oper, right? + "(:[])" -> "(fun x -> [x])" + "(:)" -> "(fun (x,xs) -> x::xs)" + _ -> f + + +generatePatterns :: CF -> Rule -> (Pattern,[MetaVar]) +generatePatterns cf r = case rhsRule r of + [] -> ("/* empty */",[]) + its -> (unwords (map mkIt its), metas its) + where + mkIt i = case i of + Left c -> nonterminal c + Right s -> terminal cf s + metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its] + revIf c m = if (not (isConsFun (funRule r)) && elem c revs) + then ("(List.rev " ++ m ++ ")") + else m -- no reversal in the left-recursive Cons rule itself + revs = reversibleCats cf + + + + + +specialRules :: CF -> String +specialRules cf = unlines $ + map aux (literals cf) + where + aux cat = + case cat of + "Ident" -> "ident : TOK_Ident { Ident $1 };" + "String" -> "string : TOK_String { $1 };" + "Integer" -> "int : TOK_Integer { $1 };" + "Double" -> "float : TOK_Double { $1 };" + "Char" -> "char : TOK_Char { $1 };" + own -> (fixType own) ++ " : TOK_" ++ own ++ + " { " ++ own ++ " ("++ posn ++ "$1)};" + -- PCC: take "own" as type name? (manual says newtype) + where -- ignore position categories for now + posn = "" -- if isPositionCat cf cat then "mkPosToken " else "" + + + diff --git a/formats/ocaml/OCamlTop.hs b/formats/ocaml/OCamlTop.hs new file mode 100644 --- /dev/null +++ b/formats/ocaml/OCamlTop.hs @@ -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" + ] + diff --git a/formats/ocaml/OCamlUtil.hs b/formats/ocaml/OCamlUtil.hs new file mode 100644 --- /dev/null +++ b/formats/ocaml/OCamlUtil.hs @@ -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 diff --git a/formats/profile/CFtoHappyProfile.hs b/formats/profile/CFtoHappyProfile.hs new file mode 100644 --- /dev/null +++ b/formats/profile/CFtoHappyProfile.hs @@ -0,0 +1,223 @@ +{- + BNF Converter: Happy Generator + Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module CFtoHappyProfile + ( + cf2HappyProfileS + ) + where + +import CF +--import Lexer +import 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 "" diff --git a/formats/profile/ProfileTop.hs b/formats/profile/ProfileTop.hs new file mode 100644 --- /dev/null +++ b/formats/profile/ProfileTop.hs @@ -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 diff --git a/formats/xml/CFtoXML.hs b/formats/xml/CFtoXML.hs new file mode 100644 --- /dev/null +++ b/formats/xml/CFtoXML.hs @@ -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\"?"), + "" + ] + +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 + ]