BNFC-meta 0.3.0.2 → 0.3.0.3
raw patch · 18 files changed
+2825/−2825 lines, 18 filessetup-changed
Files
- BNFC-meta.cabal +1/−1
- Language/Haskell/TH/Hide.hs +27/−27
- Language/LBNF/CF.hs +672/−672
- Language/LBNF/CFtoAbstract.hs +71/−71
- Language/LBNF/CFtoAlex2.hs +308/−308
- Language/LBNF/CFtoHappy.hs +361/−361
- Language/LBNF/CFtoLayout.hs +302/−302
- Language/LBNF/CFtoPrinter.hs +156/−156
- Language/LBNF/CFtoQQ.hs +39/−39
- Language/LBNF/GetCF.hs +274/−274
- Language/LBNF/Runtime.hs +143/−143
- Language/LBNF/TypeChecker.hs +147/−147
- Language/LBNF/Utils.hs +111/−111
- Setup.lhs +2/−2
- examples/ghc6/jll/JavaletteLight.hs +59/−59
- examples/ghc6/jll/UseJll.hs +46/−46
- examples/ghc7/jll/JavaletteLight.hs +60/−60
- examples/ghc7/jll/UseJll.hs +46/−46
BNFC-meta.cabal view
@@ -1,5 +1,5 @@ Name: BNFC-meta-version: 0.3.0.2+version: 0.3.0.3 cabal-Version: >= 1.6 build-type: Simple license: GPL-2
Language/Haskell/TH/Hide.hs view
@@ -1,27 +1,27 @@-module Language.Haskell.TH.Hide(export) where-import Data.List(partition)-import Language.Haskell.TH--export :: [Name] -> [Dec] -> Q [Dec]-export el = buildClause el . partition whereable where- whereable :: Dec -> Bool- whereable d = case d of- (FunD _ _) -> True- (ValD _ _ _) -> True- (SigD _ _) -> True- (PragmaD _) -> True- _ -> False--buildClause el (wh,tl) = do- v <- valD - (splitTup tupP [varP n | n <- el]) - (normalB $ splitTup tupE [varE n | n <- el])- (map return wh)- return $ v : tl-- -splitTup :: ([a] -> a) -> [a] -> a -splitTup tup ls = case splitAt 60 ls of- (_,[]) -> tup ls- (first,rest) -> tup $ first ++ [splitTup tup rest]-+module Language.Haskell.TH.Hide(export) where +import Data.List(partition) +import Language.Haskell.TH + +export :: [Name] -> [Dec] -> Q [Dec] +export el = buildClause el . partition whereable where + whereable :: Dec -> Bool + whereable d = case d of + (FunD _ _) -> True + (ValD _ _ _) -> True + (SigD _ _) -> True + (PragmaD _) -> True + _ -> False + +buildClause el (wh,tl) = do + v <- valD + (splitTup tupP [varP n | n <- el]) + (normalB $ splitTup tupE [varE n | n <- el]) + (map return wh) + return $ v : tl + + +splitTup :: ([a] -> a) -> [a] -> a +splitTup tup ls = case splitAt 60 ls of + (_,[]) -> tup ls + (first,rest) -> tup $ first ++ [splitTup tup rest] +
Language/LBNF/CF.hs view
@@ -1,672 +1,672 @@--{-- 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 Language.LBNF.CF (- -- Types.- CF,- RHS,- Rule, funRule, isTokenRule,- Pragma(..),- Reg(..),- 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)- typed_literals,- 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.- 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- ruleTokens,- 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- isNormal,- isAqFun,- hasIdent,- hasLayout,- hasAq,- rename,- renameAq,- renameAqt,- unAq,- unAqs,- aqSyntax,- -- resolveAq,- layoutPragmas,- derivations,- checkRule,- visibleNames,- quoterName,- quoters,-{-- CFP, -- CF with profiles- RuleP,- FunP, - Prof,- cf2cfpRule,- cf2cfp,- cfp2cf,- trivialProf,- rulesOfCFP,- funRuleP, ruleGroupsP, allCatsP, allEntryPointsP--}- ) where--import Language.LBNF.Utils (prParenth,(+++))-import Data.List (nub, intersperse, partition, sort,sort,group)-import Data.Char-import Language.LBNF.Grammar (Reg())----- A context free grammar consists of a set of rules and some extended --- information (e.g. pragmas, literals, symbols, keywords)--- data CF = MkCF {--- rulesOfCF :: CF -> [Rule]--- , infoOfCF :: CFG f -> Info--- , pragmasOfCF :: CFG f -> [Pragma]--- }-type CF = (Exts,[Rule])--rulesOfCF :: CF -> [Rule]-rulesOfCF = snd--infoOfCF :: CFG f -> Info-infoOfCF = snd . fst--pragmasOfCF :: CFG f -> [Pragma]-pragmasOfCF = fst . fst----- A rule consists of a function name, a main category and a sequence of--- terminals and non-terminals.--- function_name . Main_Cat ::= sequence--isTokenRule :: Rule -> Bool-isTokenRule = either (const False) (const True) . rhsRule--funRule :: Rule -> Fun-funRule = fst--oldRHS = either id (const [])--rhsRule :: Rule -> RHS-rhsRule = snd . snd---type RHS = Either [Either Cat String] (Reg,String)-type Rule = (Fun, (Cat, RHS))---- polymorphic types for common type signatures for CF and CFP-type Rul f = Rule -- (f, (Cat, [Either Cat String]))-type CFG f = CF -- (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- deriving (Eq)--instance Show Exp where- showsPrec p e =- case listView e of- Right es ->- showString "["- . foldr (.) id (intersperse (showString ", ") $ map shows es)- . showString "]"- Left (App x []) -> showString x- Left (App "(:)" [e1,e2]) ->- showParen (p>0)- $ showsPrec 1 e1- . showString " : "- . shows e2- Left (App x es) ->- showParen (p>1)- $ foldr (.) id- $ intersperse (showString " ")- $ showString x : map (showsPrec 2) es- Left (LitInt n) -> shows n- Left (LitDouble x) -> shows x- Left (LitChar c) -> shows c- Left (LitString s) -> shows s- where- listView (App "[]" []) = Right []- listView (App "(:)" [e1,e2])- | Right es <- listView e2 = Right $ e1:es- listView e = Left e---- pragmas 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- | Derive [String]- | FunDef String [String] Exp- | AntiQuote String String String- -- ...- deriving (Show, Eq)--ruleTokens :: CF -> [(String,Reg)]-ruleTokens cf = [(token,reg) | (fun,(c,Right (reg,token))) <- rulesOfCF cf]- -tokenPragmas :: CF -> [(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- )--derivations :: CF -> [String]-derivations cf = case concat [ss|Derive ss <- pragmasOfCF cf] of- [] -> ["Show", "Eq", "Ord"]- x -> x- - -hasLayout :: CF -> Bool-hasLayout cf = case layoutPragmas cf of- (t,ws,_) -> t || not (null ws) -- (True,[],_) means: top-level layout only--hasAq :: CF -> Bool-hasAq cf = case [(b,a) | AntiQuote b i a <- pragmasOfCF cf] of- [] -> False- _ -> True--aqSyntax :: CF -> Maybe (String,String,String)-aqSyntax cf = case [(b,i,a) | AntiQuote b i a <- pragmasOfCF cf] of- [] -> Nothing- [t] -> Just t- many -> error "aqSyntax: Multiple antiquote pragmas"-{--resolveAq cf@((ps,(i,t,y,z)),rs0) = maybe cf addAqRules $ aqSyntax cf where- addAqRules (b,a) = ((map renamePragma ps,(newi,nub $ "[":"]":t,y,(map rename z))),rs) where- rs = map renameRule (rulesOfCF cf) ++ newRules ++ concat (map newType - newi = nub $ "String":i- newRules = map mkNewRule $ filter isNormal $ allCats cf- mkNewRule s = (renameAq s,(rename s,map Right b ++ [Left $ "String"] ++ map Right a))- renameRule (fun,(cat,itms)) = (rename fun,(rename cat, map renameItem itms))- renameItem = either (Left . rename) (Right . id)-- renamePragma p = case p of- EntryPoints cs -> EntryPoints $ map rename cs- _ -> p- newType s = [- (rename s,(rename s,[Left $ s])),- (s++"__AQ",(rename s,map Right b ++ [Left $ "String"] ++ map Right a))- ]--}--rename s = case s of- "_" -> s- "$" -> s- "#" -> s- "(:)" -> s- "(:[])" -> s- "[]" -> s- ('$':s) -> "AQ___" ++ s- ('[':l) -> '[' : rename (init l) ++ "]" - _ -> "AQ_" ++ normCat s ++ number s--renameAqt s = case s of- ('[':l) -> '[' : renameAqt (init l) ++ "]"- _ -> "AQ___" ++ normCat s ++ number s--renameAq s = case s of- ('[':l) -> '[' : renameAq (init l) ++ "]"- _ -> "AQ__" ++ normCat s ++ number s--number = reverse . takeWhile isDigit . reverse--unAq s = case s of - 'A':'Q':'_':r -> Just r- _ -> Nothing --unAqs s = case s of - 'A':'Q':'_':'_':'_':r -> Just r- 'A':'Q':'_':'_':r -> Just r- _ -> Nothing ---- 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,Either [Cat] String)])---- 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----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]------ 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 <- oldRHS (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]--typed_literals :: CF -> [(Fun,Cat)]-typed_literals cf = map (\x -> (x,x)) lits ++ owns- where - (lits,_,_,_) = infoOfCF cf- owns = map (\(x,_) -> (x,x)) (tokenPragmas cf) -- ++ rulets- rulets = [(fun,c) | (fun,(c,Right reg)) <- rulesOfCF cf]--literals :: CF -> [Cat]-literals cf = lits ++ owns- where - (lits,_,_,_) = infoOfCF cf- owns = map fst $ tokenPragmas cf ++ ruleTokens 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])------- 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),- not (isAqFun f)])) - | cat <- allNormalCats cf] - where- mkData :: Rule -> (Fun,Either [Cat] (String))- mkData (f,(_,Left its)) = (normFun f,Left [normCat c | Left c <- its, c /= internalCat])- mkData (f,(_,Right (r,tok))) = (normFun f,Right tok)--{----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,Left [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) || isAqFun c)--isParsable :: Rul f -> Bool-isParsable (_,(_, Left (Left "#":_))) = False-isParsable (_,(_, Left (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, isAqFun :: 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)--isAqFun ('$':_) = True-isAqFun _ = 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, Left ts)) = (f, (c, Left $ xs : x : sep)) where- (x,sep,xs) = (head ts, init (tail ts), last ts) -revSepListRule x = x--- invariant: test in findAllReversibleCats have been performed--findAllReversibleCats :: CF -> [Cat]-findAllReversibleCats cf = [c | (c,r) <- ruleGroups cf, isRev c r] where- isRev c rs = case rs of- [r1,r2] | isList c -> if isConsFun (funRule r2) - then tryRev r2 r1- else if isConsFun (funRule r1) - then tryRev r1 r2- else False- _ -> False- tryRev :: Rule -> Rule -> Bool- tryRev (f,(_,Left (ts@(x:_:xs)))) r = isEmptyNilRule r && - isConsFun f && isNonterm x && isNonterm (last ts)- tryRev _ _ = False--isEmptyNilRule (f,(_,Left ts)) = isNilFun f && null ts-isEmptyNilRule _ = False--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 -> Rule -> Either Rule 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) $ transRHS rhs) ---- c = normCat cat- cs = [normCat c | Left c <- transRHS 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 || isAqFun f)- badSpecial = elem c specialCatsP && not (isCoercion f)-- badMissing = not (null missing)- missing = filter nodef [c | Left c <- transRHS 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 <- transRHS 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 || isAqFun f)- transRHS :: RHS -> [Either Cat String]- transRHS = either id (const [])--isPositionCat :: CFG f -> Cat -> Bool-isPositionCat cf cat = or [b | TokenReg name b _ <- pragmasOfCF cf, name == cat]---visibleNames :: CF -> [String]-visibleNames cf = "myLexer":"tokens":map ('p':) eps ++ map ('q':) eps ++ map initLower eps where- eps = quoters cf--quoterName :: String -> String-quoterName = initLower -- FIXME: List cats--quoters :: CF -> [String]-quoters = map identCat . allEntryPoints -- FIXME: List cats--initLower :: String -> String-initLower [] = error "initLower : Empty list"-initLower (c:cs) = toLower c : cs+{-#Language PatternGuards#-} +{- + 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 Language.LBNF.CF ( + -- Types. + CF, + RHS, + Rule, funRule, isTokenRule, + Pragma(..), + Reg(..), + 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) + typed_literals, + 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. + 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 + ruleTokens, + 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 + isNormal, + isAqFun, + hasIdent, + hasLayout, + hasAq, + rename, + renameAq, + renameAqt, + unAq, + unAqs, + aqSyntax, + -- resolveAq, + layoutPragmas, + derivations, + checkRule, + visibleNames, + quoterName, + quoters, +{- + CFP, -- CF with profiles + RuleP, + FunP, + Prof, + cf2cfpRule, + cf2cfp, + cfp2cf, + trivialProf, + rulesOfCFP, + funRuleP, ruleGroupsP, allCatsP, allEntryPointsP +-} + ) where + +import Language.LBNF.Utils (prParenth,(+++)) +import Data.List (nub, intersperse, partition, sort,sort,group) +import Data.Char +import Language.LBNF.Grammar (Reg()) + + +-- A context free grammar consists of a set of rules and some extended +-- information (e.g. pragmas, literals, symbols, keywords) +-- data CF = MkCF { +-- rulesOfCF :: CF -> [Rule] +-- , infoOfCF :: CFG f -> Info +-- , pragmasOfCF :: CFG f -> [Pragma] +-- } +type CF = (Exts,[Rule]) + +rulesOfCF :: CF -> [Rule] +rulesOfCF = snd + +infoOfCF :: CFG f -> Info +infoOfCF = snd . fst + +pragmasOfCF :: CFG f -> [Pragma] +pragmasOfCF = fst . fst + + +-- A rule consists of a function name, a main category and a sequence of +-- terminals and non-terminals. +-- function_name . Main_Cat ::= sequence + +isTokenRule :: Rule -> Bool +isTokenRule = either (const False) (const True) . rhsRule + +funRule :: Rule -> Fun +funRule = fst + +oldRHS = either id (const []) + +rhsRule :: Rule -> RHS +rhsRule = snd . snd + + +type RHS = Either [Either Cat String] (Reg,String) +type Rule = (Fun, (Cat, RHS)) + +-- polymorphic types for common type signatures for CF and CFP +type Rul f = Rule -- (f, (Cat, [Either Cat String])) +type CFG f = CF -- (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 + deriving (Eq) + +instance Show Exp where + showsPrec p e = + case listView e of + Right es -> + showString "[" + . foldr (.) id (intersperse (showString ", ") $ map shows es) + . showString "]" + Left (App x []) -> showString x + Left (App "(:)" [e1,e2]) -> + showParen (p>0) + $ showsPrec 1 e1 + . showString " : " + . shows e2 + Left (App x es) -> + showParen (p>1) + $ foldr (.) id + $ intersperse (showString " ") + $ showString x : map (showsPrec 2) es + Left (LitInt n) -> shows n + Left (LitDouble x) -> shows x + Left (LitChar c) -> shows c + Left (LitString s) -> shows s + where + listView (App "[]" []) = Right [] + listView (App "(:)" [e1,e2]) + | Right es <- listView e2 = Right $ e1:es + listView e = Left e + +-- pragmas 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 + | Derive [String] + | FunDef String [String] Exp + | AntiQuote String String String + -- ... + deriving (Show, Eq) + +ruleTokens :: CF -> [(String,Reg)] +ruleTokens cf = [(token,reg) | (fun,(c,Right (reg,token))) <- rulesOfCF cf] + +tokenPragmas :: CF -> [(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 + ) + +derivations :: CF -> [String] +derivations cf = case concat [ss|Derive ss <- pragmasOfCF cf] of + [] -> ["Show", "Eq", "Ord"] + x -> x + + +hasLayout :: CF -> Bool +hasLayout cf = case layoutPragmas cf of + (t,ws,_) -> t || not (null ws) -- (True,[],_) means: top-level layout only + +hasAq :: CF -> Bool +hasAq cf = case [(b,a) | AntiQuote b i a <- pragmasOfCF cf] of + [] -> False + _ -> True + +aqSyntax :: CF -> Maybe (String,String,String) +aqSyntax cf = case [(b,i,a) | AntiQuote b i a <- pragmasOfCF cf] of + [] -> Nothing + [t] -> Just t + many -> error "aqSyntax: Multiple antiquote pragmas" +{- +resolveAq cf@((ps,(i,t,y,z)),rs0) = maybe cf addAqRules $ aqSyntax cf where + addAqRules (b,a) = ((map renamePragma ps,(newi,nub $ "[":"]":t,y,(map rename z))),rs) where + rs = map renameRule (rulesOfCF cf) ++ newRules ++ concat (map newType + newi = nub $ "String":i + newRules = map mkNewRule $ filter isNormal $ allCats cf + mkNewRule s = (renameAq s,(rename s,map Right b ++ [Left $ "String"] ++ map Right a)) + renameRule (fun,(cat,itms)) = (rename fun,(rename cat, map renameItem itms)) + renameItem = either (Left . rename) (Right . id) + + renamePragma p = case p of + EntryPoints cs -> EntryPoints $ map rename cs + _ -> p + newType s = [ + (rename s,(rename s,[Left $ s])), + (s++"__AQ",(rename s,map Right b ++ [Left $ "String"] ++ map Right a)) + ] +-} + +rename s = case s of + "_" -> s + "$" -> s + "#" -> s + "(:)" -> s + "(:[])" -> s + "[]" -> s + ('$':s) -> "AQ___" ++ s + ('[':l) -> '[' : rename (init l) ++ "]" + _ -> "AQ_" ++ normCat s ++ number s + +renameAqt s = case s of + ('[':l) -> '[' : renameAqt (init l) ++ "]" + _ -> "AQ___" ++ normCat s ++ number s + +renameAq s = case s of + ('[':l) -> '[' : renameAq (init l) ++ "]" + _ -> "AQ__" ++ normCat s ++ number s + +number = reverse . takeWhile isDigit . reverse + +unAq s = case s of + 'A':'Q':'_':r -> Just r + _ -> Nothing + +unAqs s = case s of + 'A':'Q':'_':'_':'_':r -> Just r + 'A':'Q':'_':'_':r -> Just r + _ -> Nothing + +-- 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,Either [Cat] String)]) + +-- 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 + + + +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] + + + +-- 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 <- oldRHS (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] + +typed_literals :: CF -> [(Fun,Cat)] +typed_literals cf = map (\x -> (x,x)) lits ++ owns + where + (lits,_,_,_) = infoOfCF cf + owns = map (\(x,_) -> (x,x)) (tokenPragmas cf) -- ++ rulets + rulets = [(fun,c) | (fun,(c,Right reg)) <- rulesOfCF cf] + +literals :: CF -> [Cat] +literals cf = lits ++ owns + where + (lits,_,_,_) = infoOfCF cf + owns = map fst $ tokenPragmas cf ++ ruleTokens 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]) + + + + +-- 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), + not (isAqFun f)])) + | cat <- allNormalCats cf] + where + mkData :: Rule -> (Fun,Either [Cat] (String)) + mkData (f,(_,Left its)) = (normFun f,Left [normCat c | Left c <- its, c /= internalCat]) + mkData (f,(_,Right (r,tok))) = (normFun f,Right tok) + +{- +--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,Left [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) || isAqFun c) + +isParsable :: Rul f -> Bool +isParsable (_,(_, Left (Left "#":_))) = False +isParsable (_,(_, Left (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, isAqFun :: 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) + +isAqFun ('$':_) = True +isAqFun _ = 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, Left ts)) = (f, (c, Left $ xs : x : sep)) where + (x,sep,xs) = (head ts, init (tail ts), last ts) +revSepListRule x = x +-- invariant: test in findAllReversibleCats have been performed + +findAllReversibleCats :: CF -> [Cat] +findAllReversibleCats cf = [c | (c,r) <- ruleGroups cf, isRev c r] where + isRev c rs = case rs of + [r1,r2] | isList c -> if isConsFun (funRule r2) + then tryRev r2 r1 + else if isConsFun (funRule r1) + then tryRev r1 r2 + else False + _ -> False + tryRev :: Rule -> Rule -> Bool + tryRev (f,(_,Left (ts@(x:_:xs)))) r = isEmptyNilRule r && + isConsFun f && isNonterm x && isNonterm (last ts) + tryRev _ _ = False + +isEmptyNilRule (f,(_,Left ts)) = isNilFun f && null ts +isEmptyNilRule _ = False + +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 -> Rule -> Either Rule 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) $ transRHS rhs) --- + c = normCat cat + cs = [normCat c | Left c <- transRHS 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 || isAqFun f) + badSpecial = elem c specialCatsP && not (isCoercion f) + + badMissing = not (null missing) + missing = filter nodef [c | Left c <- transRHS 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 <- transRHS 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 || isAqFun f) + transRHS :: RHS -> [Either Cat String] + transRHS = either id (const []) + +isPositionCat :: CFG f -> Cat -> Bool +isPositionCat cf cat = or [b | TokenReg name b _ <- pragmasOfCF cf, name == cat] + + +visibleNames :: CF -> [String] +visibleNames cf = "myLexer":"tokens":map ('p':) eps ++ map ('q':) eps ++ map initLower eps where + eps = quoters cf + +quoterName :: String -> String +quoterName = initLower -- FIXME: List cats + +quoters :: CF -> [String] +quoters = map identCat . allEntryPoints -- FIXME: List cats + +initLower :: String -> String +initLower [] = error "initLower : Empty list" +initLower (c:cs) = toLower c : cs
Language/LBNF/CFtoAbstract.hs view
@@ -1,72 +1,72 @@-{-# LANGUAGE TemplateHaskell #-}-{-- 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 Language.LBNF.CFtoAbstract (absRules,absTokens) where--import Language.Haskell.TH--import Language.LBNF.CF--absRules :: CF -> Q [Dec]-absRules cf0 = sequence $ - map (prData $ map mkName $ derivations cf0) $ cf2data cf0-----absTokens :: CF -> Q [Dec]-absTokens cf0 = sequence $ - map (prSpecialData (map mkName $ derivations cf0) cf0) (specialCats cf0)----fixname :: String -> TypeQ-fixname ('[':xs) = appT listT $ conT $ mkName $ init xs-fixname xs = conT $ mkName xs- -prData :: [Name] -> Data -> Q Dec-prData deriv (cat,rules) = - dataD (return []) (mkName cat) [] (map cons rules) deriv where- cons (fun,cats) = normalC (mkName fun) $ either (map typ) (const str) cats- typ = strictType notStrict . fixname- str = [typ "String"]---- deriv = [''Eq,''Ord,''Show]--prSpecialData :: [Name] -> CF -> Cat -> Q Dec-prSpecialData deriv cf cat =- newtypeD (return []) (mkName cat) [] con deriv where- con = normalC (mkName cat) $ [typ]- typ = strictType notStrict $ contentSpec cf cat---contentSpec :: CF -> Cat -> Q Type-contentSpec cf cat = if isPositionCat cf cat - then [t|((Int,Int),String)|] - else [t|String|]----- aqName :: Bool -> String -> Name--- aqName False s = ----- transl cf = return []-+{-# LANGUAGE TemplateHaskell #-} +{- + 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 Language.LBNF.CFtoAbstract (absRules,absTokens) where + +import Language.Haskell.TH + +import Language.LBNF.CF + +absRules :: CF -> Q [Dec] +absRules cf0 = sequence $ + map (prData $ map mkName $ derivations cf0) $ cf2data cf0 + + + + +absTokens :: CF -> Q [Dec] +absTokens cf0 = sequence $ + map (prSpecialData (map mkName $ derivations cf0) cf0) (specialCats cf0) + + + +fixname :: String -> TypeQ +fixname ('[':xs) = appT listT $ conT $ mkName $ init xs +fixname xs = conT $ mkName xs + +prData :: [Name] -> Data -> Q Dec +prData deriv (cat,rules) = + dataD (return []) (mkName cat) [] (map cons rules) deriv where + cons (fun,cats) = normalC (mkName fun) $ either (map typ) (const str) cats + typ = strictType notStrict . fixname + str = [typ "String"] + +-- deriv = [''Eq,''Ord,''Show] + +prSpecialData :: [Name] -> CF -> Cat -> Q Dec +prSpecialData deriv cf cat = + newtypeD (return []) (mkName cat) [] con deriv where + con = normalC (mkName cat) $ [typ] + typ = strictType notStrict $ contentSpec cf cat + + +contentSpec :: CF -> Cat -> Q Type +contentSpec cf cat = if isPositionCat cf cat + then [t|((Int,Int),String)|] + else [t|String|] + + +-- aqName :: Bool -> String -> Name +-- aqName False s = + + +-- transl cf = return [] + -- lifts cf = return []
Language/LBNF/CFtoAlex2.hs view
@@ -1,308 +1,308 @@-{-- 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 Language.LBNF.CFtoAlex2 (abstractAlex, cf2alex2, concreteAlex) where--import Language.LBNF.CF-import Text.Alex.Quote-import Data.List---- For RegToAlex, see below.-import Language.LBNF.Grammar(Reg(..), Ident(..))-import Data.Char--abstractAlex = compileAlex . parseAlex . cf2alex2--concreteAlex :: CF -> String-concreteAlex = parseAlex . cf2alex2--cf2alex2 ::CF -> String-cf2alex2 cf = - unlines $ concat $ intersperse [""] [- cMacros,- rMacros cf,- restOfAlex False cf- ]- -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 = [.] -- 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 (\c -> isLatin1 c && isAlphaNum c) s- rest = case r of- [] -> []- (c:xs) -> s : esc xs- where s = '\\':show (ord c)--restOfAlex :: Bool -> CF -> [String]-restOfAlex shareStrings 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 :: String -> String",- "share = " ++ if shareStrings then "shareString" else "id",- "",- "data Tok =", - " TS !String !Int -- reserved words and symbols",- " | TL !String -- string literals", - " | TI !String -- integer literals",- " | TV !String -- identifiers",- " | TD !String -- double precision float literals",- " | TC !String -- character literals",- 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 _ (TI s) -> s",- " PT _ (TV s) -> s",- " PT _ (TD s) -> s",- " PT _ (TC s) -> s",- userDefTokenPrint, - " _ -> 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 = " ++ (show $ sorted2tree $ zip (sort resws) [1..]),- " where b s n = let bs = s",- " in B bs (TS bs n)",- "",- "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.",- "-------------------------------------------------------------------",- "",- "",- "alexStartPos :: Posn",- "alexStartPos = Pn 0 1 1",- "",- "tokens :: String -> [Token]",- "tokens str = go (alexStartPos, '\\n', [], str)",- " where",- " go :: AlexInput -> [Token]",- " go inp@(pos, _, _, str) =",- " case alexScan inp 0 of",- " AlexEOF -> []",- " AlexError (pos, _, _, _) -> [Err pos]",- " AlexSkip inp' len -> go inp'",- " AlexToken inp' len act -> act pos (take len str) : (go inp')",- "",- "",- "alexInputPrevChar :: AlexInput -> Char",- "alexInputPrevChar (p, c, _, s) = c",- "}"- ]- where- 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) <- toks]- userDefTokenConstrs = unlines $- [" | T_" ++ name ++ " !String" | (name,_) <- toks]- userDefTokenPrint = unlines $- [" PT _ (T_" ++ name ++ " s) -> s" | (name,_) <- toks]- toks = tokenPragmas cf ++ ruleTokens cf-- ident =- "$l $i* { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }" - --ifC "Ident" "<ident> ::= ^l ^i* { ident p = PT p . eitherResIdent TV }" -- resws = reservedWords cf ++ symbols cf---data BTree = N | B String Int BTree BTree --instance Show BTree where- showsPrec _ N = showString "N"- showsPrec n (B s k l r) = wrap (showString "b " . shows s . showChar ' '. shows k . showChar ' '- . showsPrec 1 l . showChar ' '- . showsPrec 1 r)- where wrap f = if n > 0 then showChar '(' . f . showChar ')' else f--sorted2tree :: [(String,Int)] -> BTree-sorted2tree [] = N-sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2) where- (t1,((x,n):t2)) = splitAt (length xs `div` 2) xs------------------------------------------------------------------------- Inlined version of @RegToAlex@.--- Syntax has changed...------------------------------------------------------------------------ modified from pretty-printer generated by the BNF converter---- the top-level printing method-printRegAlex :: Reg -> String-printRegAlex = render . prt 0---- you may want to change render and parenth--render :: [String] -> String-render = rend 0- where rend :: Int -> [String] -> String- rend i ss = case ss of- "[" :ts -> cons "[" $ rend i ts- "(" :ts -> cons "(" $ rend i ts- t : "," :ts -> cons t $ space "," $ rend i ts- t : ")" :ts -> cons t $ cons ")" $ rend i ts- t : "]" :ts -> cons t $ cons "]" $ rend i ts- t :ts -> space t $ rend i ts- _ -> ""-- cons s t = s ++ t- new i s = s- space t s = if null s then t else t ++ " " ++ s--parenth :: [String] -> [String]-parenth ss = ["("] ++ ss ++ [")"]---- the printer class does the job-class Print a where- prt :: Int -> a -> [String]- prtList :: [a] -> [String]- prtList = concat . map (prt 0)--instance Print a => Print [a] where- prt _ = prtList--instance Print Char where- prt _ c = if isAlphaNum c && isLatin1 c then [[c]] else ['\\':show (ord c)]- prtList s = map (concat . prt 0) s--prPrec :: Int -> Int -> [String] -> [String]-prPrec i j = if j<i then parenth else id--instance Print Ident where- prt _ (Ident i) = [i]--instance Print Reg where- prt i e = case e of- RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])- RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])- RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])- RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])- RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])- ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])- REps -> prPrec i 3 (["/\\n"])- 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"]])--+{- + 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 Language.LBNF.CFtoAlex2 (abstractAlex, cf2alex2, concreteAlex) where + +import Language.LBNF.CF +import Text.Alex.Quote +import Data.List + +-- For RegToAlex, see below. +import Language.LBNF.Grammar(Reg(..), Ident(..)) +import Data.Char + +abstractAlex = compileAlex . parseAlex . cf2alex2 + +concreteAlex :: CF -> String +concreteAlex = parseAlex . cf2alex2 + +cf2alex2 ::CF -> String +cf2alex2 cf = + unlines $ concat $ intersperse [""] [ + cMacros, + rMacros cf, + restOfAlex False cf + ] + +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 = [.] -- 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 (\c -> isLatin1 c && isAlphaNum c) s + rest = case r of + [] -> [] + (c:xs) -> s : esc xs + where s = '\\':show (ord c) + +restOfAlex :: Bool -> CF -> [String] +restOfAlex shareStrings 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 :: String -> String", + "share = " ++ if shareStrings then "shareString" else "id", + "", + "data Tok =", + " TS !String !Int -- reserved words and symbols", + " | TL !String -- string literals", + " | TI !String -- integer literals", + " | TV !String -- identifiers", + " | TD !String -- double precision float literals", + " | TC !String -- character literals", + 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 _ (TI s) -> s", + " PT _ (TV s) -> s", + " PT _ (TD s) -> s", + " PT _ (TC s) -> s", + userDefTokenPrint, + " _ -> 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 = " ++ (show $ sorted2tree $ zip (sort resws) [1..]), + " where b s n = let bs = s", + " in B bs (TS bs n)", + "", + "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.", + "-------------------------------------------------------------------", + "", + "", + "alexStartPos :: Posn", + "alexStartPos = Pn 0 1 1", + "", + "tokens :: String -> [Token]", + "tokens str = go (alexStartPos, '\\n', [], str)", + " where", + " go :: AlexInput -> [Token]", + " go inp@(pos, _, _, str) =", + " case alexScan inp 0 of", + " AlexEOF -> []", + " AlexError (pos, _, _, _) -> [Err pos]", + " AlexSkip inp' len -> go inp'", + " AlexToken inp' len act -> act pos (take len str) : (go inp')", + "", + "", + "alexInputPrevChar :: AlexInput -> Char", + "alexInputPrevChar (p, c, _, s) = c", + "}" + ] + where + 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) <- toks] + userDefTokenConstrs = unlines $ + [" | T_" ++ name ++ " !String" | (name,_) <- toks] + userDefTokenPrint = unlines $ + [" PT _ (T_" ++ name ++ " s) -> s" | (name,_) <- toks] + toks = tokenPragmas cf ++ ruleTokens cf + + ident = + "$l $i* { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }" + --ifC "Ident" "<ident> ::= ^l ^i* { ident p = PT p . eitherResIdent TV }" + + resws = reservedWords cf ++ symbols cf + + +data BTree = N | B String Int BTree BTree + +instance Show BTree where + showsPrec _ N = showString "N" + showsPrec n (B s k l r) = wrap (showString "b " . shows s . showChar ' '. shows k . showChar ' ' + . showsPrec 1 l . showChar ' ' + . showsPrec 1 r) + where wrap f = if n > 0 then showChar '(' . f . showChar ')' else f + +sorted2tree :: [(String,Int)] -> BTree +sorted2tree [] = N +sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2) where + (t1,((x,n):t2)) = splitAt (length xs `div` 2) xs + + +------------------------------------------------------------------- +-- Inlined version of @RegToAlex@. +-- Syntax has changed... +------------------------------------------------------------------- + +-- modified from pretty-printer generated by the BNF converter + +-- the top-level printing method +printRegAlex :: Reg -> String +printRegAlex = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend 0 + where rend :: Int -> [String] -> String + rend i ss = case ss of + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + + cons s t = s ++ t + new i s = s + space t s = if null s then t else t ++ " " ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ c = if isAlphaNum c && isLatin1 c then [[c]] else ['\\':show (ord c)] + prtList s = map (concat . prt 0) s + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j<i then parenth else id + +instance Print Ident where + prt _ (Ident i) = [i] + +instance Print Reg where + prt i e = case e of + RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg]) + RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg]) + RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg]) + RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]]) + RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]]) + ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]]) + REps -> prPrec i 3 (["/\\n"]) + 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"]]) + +
Language/LBNF/CFtoHappy.hs view
@@ -1,361 +1,361 @@-{-- 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 Language.LBNF.CFtoHappy - (- cf2Happy- ,HappyMode(..)- ,abstractHappy, concreteHappy- )- where--import Language.LBNF.CF-import Language.Haskell.TH(Dec,Q,Loc(..))--import Text.Happy.Quote-import Data.List (intersperse, sort)-import Data.Char----- Type declarations--type Rules = [Rul]-type Rul = (NonTerminal,[(Rule,Pattern,Action)])-type NonTerminal = String-type Pattern = [Either String String]-data Action = MkAction (Maybe String) [(Bool,Cat,MetaVar)]-type MetaVar = String------ default naming---moduleName = "HappyParser"-tokenName = "Token"--appEPAllL = "appEPAllL myLocation "-appEPAll = "appEPAll myLocation "-fromToken = "fromToken myLocation "-fromPositionToken = "fromPositionToken myLocation "-fromLitteral = "fromLit myLocation "---- Happy mode--data HappyMode = Standard | GLR deriving Eq--abstractHappy :: Loc -> CF -> Q [Dec]-abstractHappy m = compileHappy' . parseHappyInfo . cf2Happy m where- compileHappy' (c,i) = do- happyWarn i- compileHappy c--concreteHappy :: Loc -> CF -> String-concreteHappy m = parseHappy . cf2Happy m----- generates happy code. -cf2Happy :: Loc -> CF -> String-cf2Happy l cf- = unlines - [declarations Standard (allEntryPoints cf),- tokens (symbols cf ++ reservedWords cf),- specialToks cf,- delimiter,- specialRules l cf,- prRules l (rulesForHappy cf),- finalize l cf]----- 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 { ParseMonad }",- "%tokentype { " ++ tokenName ++ " }"]- where generateP [] = []- generateP (n:ns) = concat ["%name p",n' ," ",n' ,"\n%name q",n' ," QQ_",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,[(Rule,Pattern,Action)])-constructRule cf rules nt = (nt,[(r,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) -> [(Bool,Cat,MetaVar)] -> Action-generateAction nt f ms = MkAction (if isCoercion f then Nothing else Just f) ms---- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal--generatePatterns :: CF -> Rule -> (Pattern,[(Bool,Cat,MetaVar)])-generatePatterns cf r = case rhsRule r of- Left [] -> ([Right "{- empty -}"],[])- Left its -> ((map mkIt its), metas its) - Right (_,tok) -> ([Right $ "L_" ++ tok],[(False,funRule r,"$1")])- where- mkIt i = case i of- Left c -> Left c- Right s -> Right $ convert s- metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its]- revIf c m = (not (isConsFun (funRule r)) && elem c revs,c,m) - revs = reversibleCats cf----- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string.----prRules :: Loc -> Rules -> String-prRules l rs = unlines . map prOne $ rs- where- prOne (nt,[]) = ""- prOne r@(nt,_) = - prTypeSig n (normCat nt) ++ prRule l r ++ - prTypeSig qqn "BNFC_QQType" ++ prRuleQ l r- where qqn = qqCat nt- n = identCat nt--qqCat = ("QQ_"++). identCat- -qualify "" f = f-qualify _ f@"[]" = f-qualify m f = m ++ "." ++ f--prTypeSig :: String -> String -> String-prTypeSig cat typ = unwords [cat, "::", "{", typ, "}\n"]--prRule :: Loc -> Rul -> String-prRule _ (_,[]) = ""-prRule m (nt,((_,p,a):ls)) = - unwords [identCat nt, ":" , prPattern p, "{", prAction a, "}", "\n" ++ pr ls] ++ "\n"- where - pr [] = []- pr ((_,p,a):ls) = - unlines [(concat $ intersperse " " [" |", prPattern p, "{", prAction a , "}"])] ++ pr ls- prAction :: Action -> String- prAction (MkAction fun []) = maybe "" pf fun where- pf f = f- prAction (MkAction fun ms) = maybe (thrd $ head ms) pf fun where- thrd (_,_,m) = m- pf f - | isAqFun f = "% fail \"Can not parse anti-quoted expressions\""- | otherwise - = f++" "++unwords ["("++(if b then "reverse $ " else "")++m1++")"|(b,c,m1) <- ms]- ---prRuleQ :: Loc -> Rul -> String-prRuleQ _ (_,[]) = ""-prRuleQ m (nt,((rul,p,a):ls)) = - unwords [qqCat nt, ":" , prPatternQ (isAqAction a) p, "{", prActionQ rul a, "}", "\n" ++ pr ls] ++ "\n"- where - pr [] = []- pr ((rulx,p,a):ls) = - unlines [(concat $ intersperse " " [" |", prPatternQ (isAqAction a) p, "{", prActionQ rulx a , "}"])] ++ pr ls where- prActionQ :: Rule -> Action -> String- prActionQ rulz (MkAction fun []) = maybe "" pf fun where- pf f = appEPAll ++" \"" ++ f++"\" []"- prActionQ rulz (MkAction fun ms) = maybe (thrd $ head ms) pf fun where- thrd (_,_,m) = m- pf f - | isAqFun f = fun ++ " " ++ unwords (map (\(b,c,m) -> m) ms)- | isTokenRule rulz = fromToken ++ "\""++f++"\" $1"- | otherwise = constr++" ["++- (concat $ intersperse "," [m1|(_,c,m1) <- ms])- ++ "]" - where - fun = case tail f of- [] | isTokenRule rulz -> "stringAq"- | otherwise -> "printAq"- x -> x- constr = case f of- "flip (:)" -> appEPAllL- "(:)" -> appEPAll ++"\":\" "- "(:[])" -> appEPAllL- _ -> appEPAll ++"\""++f++"\" " - - {-- expspats - | isTokenRule rul = fromToken ++ "\""++f++"\" $1"- | otherwise = constr++" ["++- (concat $ intersperse "," [m1|(_,c,m1) <- ms])- ++ "]"---}-isAqAction (MkAction mf _) = maybe False isAqFun mf--prPattern = prPatternQ True-prPatternQ aq = unwords . (map $ either (if aq then identCat else qqCat) id)----- Finally, some haskell code.--finalize :: Loc -> CF -> String-finalize l cf = unlines $- [- "{",- "\nhappyError :: [" ++ tokenName ++ "] -> ParseMonad a",- "happyError ts =", - " fail $ \"syntax error at \" ++ tokenPos ts ++ ",- " case ts of",- " [] -> []",- " [Err _] -> \" due to lexer error\"", - " _ -> \" before \" ++ unwords (map prToken (take 4 ts))",- "",- "myLexer = " ++ (if hasLayout cf then "resolveLayout True . " else "") ++ "tokens",- "",- "myLocation = (\""++loc_package l++"\",\""++loc_module l++"\")",- ""- ] ++ definedRules cf ++ [ "}" ]--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 :: Loc -> CF -> String-specialRules l cf = unlines $- map aux (typed_literals cf)- where - -- m = loc_module l- aux (fun,cat) =- case cat of--- "Ident" -> "Ident :: { (Ident } : L_ident { (Ident $1,fromToken \"Ident\" $1) }" --- "String" -> "String :: { (String,BNFC_QQType) } : L_quoted { fromString $1 }" -- FIXME: Why not read?--- "Integer" -> "Integer :: { (Integer,BNFC_QQType) } \nInteger : "++iaq++"L_integ { fromLit (read $1) }"--- "Double" -> "Double :: { (Double,BNFC_QQType) } : L_doubl { fromLit (read $1) }"--- "Char" -> "Char :: { (Char,BNFC_QQType) } : L_charac { fromLit (read $1) }"--- own -> own ++ " :: { (" ++ own ++ ",BNFC_QQType) } : L_" ++ own ++ --- " { (" ++ own ++ " ("++ posn ++ "$1),fromToken \""++own++"\" $1)}"- "Ident" -> unlines- [ "Ident :: { Ident } : L_ident { Ident $1 }"- , "QQ_Ident :: { BNFC_QQType } : L_ident { "++fromToken ++"\"Ident\" $1 }"- ] ++ aqrule "Ident"- "String" -> unlines- [ "String :: { String } : L_quoted { $1 }" - , "QQ_String :: { BNFC_QQType }"- , "QQ_String : L_quoted { fromString myLocation $1 }"- ] ++ aqrule "String"- "Integer" -> unlines- [ "Integer :: { Integer } : L_integ { (read $1) :: Integer }"- , "QQ_Integer :: { BNFC_QQType }"- , "QQ_Integer : L_integ { "++fromLitteral++"(read $1 :: Integer) }"- ] ++ aqrule "Integer"- "Double" -> unlines- [ "Double :: { Double } : L_doubl { (read $1) :: Double }"- , "QQ_Double :: { BNFC_QQType }"- , "QQ_Double : L_doubl { "++fromLitteral++" (read $1 :: Double) }"- ] ++ aqrule "Double"- "Char" -> unlines- [ "Char :: { Char } : L_charac { (read $1) :: Char }"- , "QQ_Char :: { BNFC_QQType }"- , "QQ_Char : L_charac { "++fromLitteral++" (read $1 :: Char) }"- ] ++ aqrule "Char"- "AqToken" -> unlines- ["AqToken :: { AqToken } : L_AqToken { AqToken $1 }"]- _ -> unlines- [ cat ++ " :: { " ++ cat ++ "} : L_" ++ fun ++ " { " ++ fun ++ " ("++ posn ++ "$1)}"- , "QQ_"++cat ++ " :: { BNFC_QQType }"- , "QQ_"++cat ++ " : L_" ++ fun ++ " {"++fromToken' ++" \""++ fun ++"\" ("++ posn ++ " $1 ) }"- ] ++ aqrule cat- where- posn = if isPositionCat cf cat then "mkPosToken " else ""- fromToken' = if isPositionCat cf cat then fromPositionToken else fromToken- isPos = isPositionCat cf cat- aqrule = maybe (const "") rule $ aqSyntax cf - rule (b,i,a) = twoRules where- open = "'"++b++"' " ++ body - closed t = "'"++b++t++"' " ++ body- body = "AqToken { global_aq $2 } "- twoRules typ = "\n | "++ open ++ "\n | " ++ closed typ---+{- + 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 Language.LBNF.CFtoHappy + ( + cf2Happy + ,HappyMode(..) + ,abstractHappy, concreteHappy + ) + where + +import Language.LBNF.CF +import Language.Haskell.TH(Dec,Q,Loc(..)) + +import Text.Happy.Quote +import Data.List (intersperse, sort) +import Data.Char + + +-- Type declarations + +type Rules = [Rul] +type Rul = (NonTerminal,[(Rule,Pattern,Action)]) +type NonTerminal = String +type Pattern = [Either String String] +data Action = MkAction (Maybe String) [(Bool,Cat,MetaVar)] +type MetaVar = String + + + +-- default naming + + +moduleName = "HappyParser" +tokenName = "Token" + +appEPAllL = "appEPAllL myLocation " +appEPAll = "appEPAll myLocation " +fromToken = "fromToken myLocation " +fromPositionToken = "fromPositionToken myLocation " +fromLitteral = "fromLit myLocation " + +-- Happy mode + +data HappyMode = Standard | GLR deriving Eq + +abstractHappy :: Loc -> CF -> Q [Dec] +abstractHappy m = compileHappy' . parseHappyInfo . cf2Happy m where + compileHappy' (c,i) = do + happyWarn i + compileHappy c + +concreteHappy :: Loc -> CF -> String +concreteHappy m = parseHappy . cf2Happy m + + +-- generates happy code. +cf2Happy :: Loc -> CF -> String +cf2Happy l cf + = unlines + [declarations Standard (allEntryPoints cf), + tokens (symbols cf ++ reservedWords cf), + specialToks cf, + delimiter, + specialRules l cf, + prRules l (rulesForHappy cf), + finalize l cf] + + +-- 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 { ParseMonad }", + "%tokentype { " ++ tokenName ++ " }"] + where generateP [] = [] + generateP (n:ns) = concat ["%name p",n' ," ",n' ,"\n%name q",n' ," QQ_",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,[(Rule,Pattern,Action)]) +constructRule cf rules nt = (nt,[(r,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) -> [(Bool,Cat,MetaVar)] -> Action +generateAction nt f ms = MkAction (if isCoercion f then Nothing else Just f) ms + +-- Generate patterns and a set of metavariables indicating +-- where in the pattern the non-terminal + +generatePatterns :: CF -> Rule -> (Pattern,[(Bool,Cat,MetaVar)]) +generatePatterns cf r = case rhsRule r of + Left [] -> ([Right "{- empty -}"],[]) + Left its -> ((map mkIt its), metas its) + Right (_,tok) -> ([Right $ "L_" ++ tok],[(False,funRule r,"$1")]) + where + mkIt i = case i of + Left c -> Left c + Right s -> Right $ convert s + metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its] + revIf c m = (not (isConsFun (funRule r)) && elem c revs,c,m) + revs = reversibleCats cf + + +-- We have now constructed the patterns and actions, +-- so the only thing left is to merge them into one string. + + + +prRules :: Loc -> Rules -> String +prRules l rs = unlines . map prOne $ rs + where + prOne (nt,[]) = "" + prOne r@(nt,_) = + prTypeSig n (normCat nt) ++ prRule l r ++ + prTypeSig qqn "BNFC_QQType" ++ prRuleQ l r + where qqn = qqCat nt + n = identCat nt + +qqCat = ("QQ_"++). identCat + +qualify "" f = f +qualify _ f@"[]" = f +qualify m f = m ++ "." ++ f + +prTypeSig :: String -> String -> String +prTypeSig cat typ = unwords [cat, "::", "{", typ, "}\n"] + +prRule :: Loc -> Rul -> String +prRule _ (_,[]) = "" +prRule m (nt,((_,p,a):ls)) = + unwords [identCat nt, ":" , prPattern p, "{", prAction a, "}", "\n" ++ pr ls] ++ "\n" + where + pr [] = [] + pr ((_,p,a):ls) = + unlines [(concat $ intersperse " " [" |", prPattern p, "{", prAction a , "}"])] ++ pr ls + prAction :: Action -> String + prAction (MkAction fun []) = maybe "" pf fun where + pf f = f + prAction (MkAction fun ms) = maybe (thrd $ head ms) pf fun where + thrd (_,_,m) = m + pf f + | isAqFun f = "% fail \"Can not parse anti-quoted expressions\"" + | otherwise + = f++" "++unwords ["("++(if b then "reverse $ " else "")++m1++")"|(b,c,m1) <- ms] + + + +prRuleQ :: Loc -> Rul -> String +prRuleQ _ (_,[]) = "" +prRuleQ m (nt,((rul,p,a):ls)) = + unwords [qqCat nt, ":" , prPatternQ (isAqAction a) p, "{", prActionQ rul a, "}", "\n" ++ pr ls] ++ "\n" + where + pr [] = [] + pr ((rulx,p,a):ls) = + unlines [(concat $ intersperse " " [" |", prPatternQ (isAqAction a) p, "{", prActionQ rulx a , "}"])] ++ pr ls where + prActionQ :: Rule -> Action -> String + prActionQ rulz (MkAction fun []) = maybe "" pf fun where + pf f = appEPAll ++" \"" ++ f++"\" []" + prActionQ rulz (MkAction fun ms) = maybe (thrd $ head ms) pf fun where + thrd (_,_,m) = m + pf f + | isAqFun f = fun ++ " " ++ unwords (map (\(b,c,m) -> m) ms) + | isTokenRule rulz = fromToken ++ "\""++f++"\" $1" + | otherwise = constr++" ["++ + (concat $ intersperse "," [m1|(_,c,m1) <- ms]) + ++ "]" + where + fun = case tail f of + [] | isTokenRule rulz -> "stringAq" + | otherwise -> "printAq" + x -> x + constr = case f of + "flip (:)" -> appEPAllL + "(:)" -> appEPAll ++"\":\" " + "(:[])" -> appEPAllL + _ -> appEPAll ++"\""++f++"\" " + + {- + expspats + | isTokenRule rul = fromToken ++ "\""++f++"\" $1" + | otherwise = constr++" ["++ + (concat $ intersperse "," [m1|(_,c,m1) <- ms]) + ++ "]" + +-} +isAqAction (MkAction mf _) = maybe False isAqFun mf + +prPattern = prPatternQ True +prPatternQ aq = unwords . (map $ either (if aq then identCat else qqCat) id) + + +-- Finally, some haskell code. + +finalize :: Loc -> CF -> String +finalize l cf = unlines $ + [ + "{", + "\nhappyError :: [" ++ tokenName ++ "] -> ParseMonad a", + "happyError ts =", + " fail $ \"syntax error at \" ++ tokenPos ts ++ ", + " case ts of", + " [] -> []", + " [Err _] -> \" due to lexer error\"", + " _ -> \" before \" ++ unwords (map prToken (take 4 ts))", + "", + "myLexer = " ++ (if hasLayout cf then "resolveLayout True . " else "") ++ "tokens", + "", + "myLocation = (\""++loc_package l++"\",\""++loc_module l++"\")", + "" + ] ++ definedRules cf ++ [ "}" ] + +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 :: Loc -> CF -> String +specialRules l cf = unlines $ + map aux (typed_literals cf) + where + -- m = loc_module l + aux (fun,cat) = + case cat of +-- "Ident" -> "Ident :: { (Ident } : L_ident { (Ident $1,fromToken \"Ident\" $1) }" +-- "String" -> "String :: { (String,BNFC_QQType) } : L_quoted { fromString $1 }" -- FIXME: Why not read? +-- "Integer" -> "Integer :: { (Integer,BNFC_QQType) } \nInteger : "++iaq++"L_integ { fromLit (read $1) }" +-- "Double" -> "Double :: { (Double,BNFC_QQType) } : L_doubl { fromLit (read $1) }" +-- "Char" -> "Char :: { (Char,BNFC_QQType) } : L_charac { fromLit (read $1) }" +-- own -> own ++ " :: { (" ++ own ++ ",BNFC_QQType) } : L_" ++ own ++ +-- " { (" ++ own ++ " ("++ posn ++ "$1),fromToken \""++own++"\" $1)}" + "Ident" -> unlines + [ "Ident :: { Ident } : L_ident { Ident $1 }" + , "QQ_Ident :: { BNFC_QQType } : L_ident { "++fromToken ++"\"Ident\" $1 }" + ] ++ aqrule "Ident" + "String" -> unlines + [ "String :: { String } : L_quoted { $1 }" + , "QQ_String :: { BNFC_QQType }" + , "QQ_String : L_quoted { fromString myLocation $1 }" + ] ++ aqrule "String" + "Integer" -> unlines + [ "Integer :: { Integer } : L_integ { (read $1) :: Integer }" + , "QQ_Integer :: { BNFC_QQType }" + , "QQ_Integer : L_integ { "++fromLitteral++"(read $1 :: Integer) }" + ] ++ aqrule "Integer" + "Double" -> unlines + [ "Double :: { Double } : L_doubl { (read $1) :: Double }" + , "QQ_Double :: { BNFC_QQType }" + , "QQ_Double : L_doubl { "++fromLitteral++" (read $1 :: Double) }" + ] ++ aqrule "Double" + "Char" -> unlines + [ "Char :: { Char } : L_charac { (read $1) :: Char }" + , "QQ_Char :: { BNFC_QQType }" + , "QQ_Char : L_charac { "++fromLitteral++" (read $1 :: Char) }" + ] ++ aqrule "Char" + "AqToken" -> unlines + ["AqToken :: { AqToken } : L_AqToken { AqToken $1 }"] + _ -> unlines + [ cat ++ " :: { " ++ cat ++ "} : L_" ++ fun ++ " { " ++ fun ++ " ("++ posn ++ "$1)}" + , "QQ_"++cat ++ " :: { BNFC_QQType }" + , "QQ_"++cat ++ " : L_" ++ fun ++ " {"++fromToken' ++" \""++ fun ++"\" ("++ posn ++ " $1 ) }" + ] ++ aqrule cat + where + posn = if isPositionCat cf cat then "mkPosToken " else "" + fromToken' = if isPositionCat cf cat then fromPositionToken else fromToken + isPos = isPositionCat cf cat + aqrule = maybe (const "") rule $ aqSyntax cf + rule (b,i,a) = twoRules where + open = "'"++b++"' " ++ body + closed t = "'"++b++t++"' " ++ body + body = "AqToken { global_aq $2 } " + twoRules typ = "\n | "++ open ++ "\n | " ++ closed typ + + +
Language/LBNF/CFtoLayout.hs view
@@ -1,302 +1,302 @@-{-#LANGUAGE TemplateHaskell#-}--{-- 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 Language.LBNF.CFtoLayout(cf2Layout) where--import Data.List (sort)-import Data.Maybe (isNothing, fromJust)-import Language.LBNF.CF hiding (rename)--import Language.Haskell.TH-import Language.Haskell.TH.Syntax---- TODO: avoid using SYB-import Data.Generics as SYB---- Generic renaming function-rename :: SYB.Data a => [(Name,Name)] -> a -> a-rename table = everywhere (mkT step)- where- step :: Name -> Name- step x = maybe x id (lookup x table)---- Dummy data types and functions-data Token = - Err Posn |- PT Posn Tok -data Tok = TS !String Int-data Posn = Pn Int Int Int----layoutOpen' = "{"-layoutClose' = "}"-layoutSep' = ";"--cf2Layout :: CF -> Q [Dec]-cf2Layout cf = - let - (top,lay,stop) = layoutPragmas cf - mkRename = rename $ zip- (id [''Token, 'Err, ''Posn, 'PT, ''Tok, 'TS, 'Pn ])- (map mkName ["Token", "Err", "Posn", "PT", "Tok", "TS", "Pn"])- in fmap mkRename [d|---- Generated by the BNF Converter---- local parameters-- topLayout = $(lift top)- layoutWords = $(lift lay)- layoutStopWords = $(lift stop)-- -- layout separators- - layoutOpen = $(lift layoutOpen')- layoutClose = $(lift layoutClose')- layoutSep = $(lift 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]- -> [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.- - reservedwords = $(lift $ zip resws ([1..] :: [Int]))- - sToken :: Position -> String -> Token- sToken p s = PT p (TS s i)- where i = maybe (error $ "not a reserved word: " ++ show s) id (lookup s reservedwords)- -- where- -- i = case s of- -- [ " " ++ show s ++ " -> " ++ show i- -- | (s, i) <- - -- ] ++- -- _ -> 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 $ $(varE $ mkName "prToken") t- |]- - where- resws = sort (reservedWords cf ++ symbols cf)+{-#LANGUAGE TemplateHaskell#-} + +{- + 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 Language.LBNF.CFtoLayout(cf2Layout) where + +import Data.List (sort) +import Data.Maybe (isNothing, fromJust) +import Language.LBNF.CF hiding (rename) + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +-- TODO: avoid using SYB +import Data.Generics as SYB + +-- Generic renaming function +rename :: SYB.Data a => [(Name,Name)] -> a -> a +rename table = everywhere (mkT step) + where + step :: Name -> Name + step x = maybe x id (lookup x table) + +-- Dummy data types and functions +data Token = + Err Posn | + PT Posn Tok +data Tok = TS !String Int +data Posn = Pn Int Int Int + +data Block = Implicit Int + | Explicit + +layoutOpen' = "{" +layoutClose' = "}" +layoutSep' = ";" + +cf2Layout :: CF -> Q [Dec] +cf2Layout cf = + let + (top,lay,stop) = layoutPragmas cf + mkRename = rename $ zip + (id [''Token, 'Err, ''Posn, 'PT, ''Tok, 'TS, 'Pn, ''Block, 'Implicit, 'Explicit]) + (map mkName ["Token", "Err", "Posn", "PT", "Tok", "TS", "Pn", "Block", "Implicit","Explicit"]) + in fmap mkRename $ + fmap (DataD [] (mkName "Block") [] [NormalC (mkName "Implicit") [(NotStrict,ConT ''Int)], + NormalC (mkName "Explicit") []] [''Show]:) + [d| + +-- Generated by the BNF Converter + +-- local parameters + + topLayout = $(lift top) + layoutWords = $(lift lay) + layoutStopWords = $(lift stop) + + -- layout separators + + layoutOpen = $(lift layoutOpen') + layoutClose = $(lift layoutClose') + layoutSep = $(lift 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 + + 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] + -> [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. + + reservedwords = $(lift $ zip resws ([1..] :: [Int])) + + sToken :: Position -> String -> Token + sToken p s = PT p (TS s i) + where i = maybe (error $ "not a reserved word: " ++ show s) id (lookup s reservedwords) + -- where + -- i = case s of + -- [ " " ++ show s ++ " -> " ++ show i + -- | (s, i) <- + -- ] ++ + -- _ -> 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 $ $(varE $ mkName "prToken") t + |] + + where + resws = sort (reservedWords cf ++ symbols cf)
Language/LBNF/CFtoPrinter.hs view
@@ -1,156 +1,156 @@-{-# LANGUAGE TemplateHaskell #-}-{-- 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 Language.LBNF.CFtoPrinter (cf2Printer) where--import Language.LBNF.CF-import Language.LBNF.Utils-import Language.LBNF.Runtime-import Data.List (intersperse)-import Data.Char(toLower)--import Language.Haskell.TH-import Language.Haskell.TH.Syntax--cf2Printer :: CF -> Q [Dec]-cf2Printer cf = sequence $ concat [- if hasIdent cf then [identRule cf] else [],- [ownPrintRule cf own | (own,_) <- tokenPragmas cf],- rules cf- ]--{--showsPrintRule cf t = unlines $ [- "instance Print " ++ t ++ " where",- " prt _ x = doc (shows x)",- ifList cf t- ]--}--identRule cf = ownPrintRule cf "Ident"--ownPrintRule :: CF -> String -> DecQ-ownPrintRule cf own = do- i <- newName "i"- let - posn = if isPositionCat cf own - then conP (mkName own) [tupP [wildP, varP i]]- else conP (mkName own) [varP i]- body = normalB [|doc (showString $(varE i))|]- prtc = funD ('prt) [clause [wildP, posn] body []]- instanceD (cxt []) (appT (conT $ ''Print) $ conT $ mkName own) [prtc]- -{-unlines $ [- "instance Print " ++ own ++ " where",- " prt _ (" ++ own ++ posn ++ ") = doc (showString i)",- ifList cf own- ]- where- posn = if isPositionCat cf own then " (_,i)" else " i"--}--- copy and paste from CFtoTemplate--rules :: CF -> [Q Dec]-rules cf = - map (\(s,xs) -> case_fun s (map toArgs xs) (ifList cf s)) $ cf2data cf- where - toArgs (cons,Left args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons)- toArgs (cons,Right reg) = ((cons, names ["s"] (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 -> [(Con,Rule)] -> Q Dec-case_fun cat xs lst =- instanceD (cxt []) (appT (conT ''Print) $ conT $ mkName cat) $- [newName "i" >>= \i -> newName "x" >>= prtc i] ++ lst where- prtc i n = funD ('prt) [clause [varP i,varP n] (body) []] where- body = normalB $ caseE (varE n) $- map mtch xs- mtch ((c,xx),r) = match - (conP (mkName c) [varP (mkName x)|x <- xx])- (normalB - [| prPrec - $(varE i) - $(litE $ IntegerL $ toInteger $ precCat $ fst r) - $(mkRhs xx (snd r))- |])- []- -{--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 -> String -> [DecQ]-ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where- nil cat = [(listP [],mkRhs [] its) | - (f,(c,its)) <- rulesOfCF cf, isNilFun f , normCatOfList c == cat]- one cat = [(listP [varP $ mkName "x"], mkRhs ["x"] its) | - (f,(c,its)) <- rulesOfCF cf, isOneFun f , normCatOfList c == cat]- cons cat = [(conP '(:) [varP $ mkName "x",varP $ mkName "xs"], mkRhs ["x","xs"] its) | - (f,(c,its)) <- rulesOfCF cf, isConsFun f , normCatOfList c == cat]- mkListRule [] = []- mkListRule rs = [do- es <- newName "es"- funD 'prtList [clause [varP es] (normalB $ caseE (varE es) $ map mtch rs) []]]- mtch (p,e) = match p (normalB e) []---mkRhs :: [String] -> Either [Either String String] a -> ExpQ-mkRhs args (Left its) = [| concatD $(listE $ 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 $(lift (s :: String))) |] : mk args items- mk _ _ = []- prt' :: String -> String -> ExpQ- prt' c arg = [| prt $(lift $ precCat c) $(varE $ mkName arg) |]-mkRhs args (Right reg) = [|doc (showString $(varE $ mkName "s"))|]-- {-- "(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)--}+{-# LANGUAGE TemplateHaskell #-} +{- + 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 Language.LBNF.CFtoPrinter (cf2Printer) where + +import Language.LBNF.CF +import Language.LBNF.Utils +import Language.LBNF.Runtime +import Data.List (intersperse) +import Data.Char(toLower) + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +cf2Printer :: CF -> Q [Dec] +cf2Printer cf = sequence $ concat [ + if hasIdent cf then [identRule cf] else [], + [ownPrintRule cf own | (own,_) <- tokenPragmas cf], + rules cf + ] + +{- +showsPrintRule cf t = unlines $ [ + "instance Print " ++ t ++ " where", + " prt _ x = doc (shows x)", + ifList cf t + ] +-} + +identRule cf = ownPrintRule cf "Ident" + +ownPrintRule :: CF -> String -> DecQ +ownPrintRule cf own = do + i <- newName "i" + let + posn = if isPositionCat cf own + then conP (mkName own) [tupP [wildP, varP i]] + else conP (mkName own) [varP i] + body = normalB [|doc (showString $(varE i))|] + prtc = funD ('prt) [clause [wildP, posn] body []] + instanceD (cxt []) (appT (conT $ ''Print) $ conT $ mkName own) [prtc] + +{-unlines $ [ + "instance Print " ++ own ++ " where", + " prt _ (" ++ own ++ posn ++ ") = doc (showString i)", + ifList cf own + ] + where + posn = if isPositionCat cf own then " (_,i)" else " i" +-} +-- copy and paste from CFtoTemplate + +rules :: CF -> [Q Dec] +rules cf = + map (\(s,xs) -> case_fun s (map toArgs xs) (ifList cf s)) $ cf2data cf + where + toArgs (cons,Left args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons) + toArgs (cons,Right reg) = ((cons, names ["s"] (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 -> [(Con,Rule)] -> Q Dec +case_fun cat xs lst = + instanceD (cxt []) (appT (conT ''Print) $ conT $ mkName cat) $ + [newName "i" >>= \i -> newName "x" >>= prtc i] ++ lst where + prtc i n = funD ('prt) [clause [varP i,varP n] (body) []] where + body = normalB $ caseE (varE n) $ + map mtch xs + mtch ((c,xx),r) = match + (conP (mkName c) [varP (mkName x)|x <- xx]) + (normalB + [| prPrec + $(varE i) + $(litE $ IntegerL $ toInteger $ precCat $ fst r) + $(mkRhs xx (snd r)) + |]) + [] + +{- +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 -> String -> [DecQ] +ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where + nil cat = [(listP [],mkRhs [] its) | + (f,(c,its)) <- rulesOfCF cf, isNilFun f , normCatOfList c == cat] + one cat = [(listP [varP $ mkName "x"], mkRhs ["x"] its) | + (f,(c,its)) <- rulesOfCF cf, isOneFun f , normCatOfList c == cat] + cons cat = [(conP '(:) [varP $ mkName "x",varP $ mkName "xs"], mkRhs ["x","xs"] its) | + (f,(c,its)) <- rulesOfCF cf, isConsFun f , normCatOfList c == cat] + mkListRule [] = [] + mkListRule rs = [do + es <- newName "es" + funD 'prtList [clause [varP es] (normalB $ caseE (varE es) $ map mtch rs) []]] + mtch (p,e) = match p (normalB e) [] + + +mkRhs :: [String] -> Either [Either String String] a -> ExpQ +mkRhs args (Left its) = [| concatD $(listE $ 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 $(lift (s :: String))) |] : mk args items + mk _ _ = [] + prt' :: String -> String -> ExpQ + prt' c arg = [| prt $(lift $ precCat c) $(varE $ mkName arg) |] +mkRhs args (Right reg) = [|doc (showString $(varE $ mkName "s"))|] + + {- + "(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) +-}
Language/LBNF/CFtoQQ.hs view
@@ -1,39 +1,39 @@-{-# LANGUAGE TemplateHaskell #-}-module Language.LBNF.CFtoQQ(cf2qq) where--import Data.Char (toLower)--import Language.Haskell.TH as TH-import Language.Haskell.TH.Syntax(lift)-import Language.Haskell.TH.Quote--- import Language.Haskell.TH.Lift--import Language.LBNF.Compiletime(printTree, stringAq, parseToQuoter)-import Language.LBNF.CF(quoterName, CF, quoters, aqSyntax)--cf2qq :: CF -> Q [Dec]-cf2qq cf = do- aqToken <- maybe (return []) (deriveAq cf) (aqSyntax cf)- qqs <- sequence $ map mkQQ eps- return $ aqToken ++ qqs- where- eps = quoters cf---deriveAq cf (_,i,a) = do- v <- newName "a"- let nAqToken = mkName "AqToken"- nAqFun = mkName "global_aq"- d <-funD nAqFun [clause [conP nAqToken [varP v]] (normalB $ aqDec (varE v)) []] - return $ [d] where- aqDec v = - [| stringAq (drop $(lie) . reverse . drop $(lae) . reverse $ printTree $(v)) |]- (lie, lae) = (lift $ length i + 1 ,lift $ length a + 1)--mkQQ s = funD qqName [clause [] (normalB qqe) []] where- qqe = [|parseToQuoter ($(varE qName) . $(varE tokName)) |]- qqName = mkName $ quoterName s- qName = mkName $ 'q':s- tokName = mkName "myLexer"--+{-# LANGUAGE TemplateHaskell #-} +module Language.LBNF.CFtoQQ(cf2qq) where + +import Data.Char (toLower) + +import Language.Haskell.TH as TH +import Language.Haskell.TH.Syntax(lift) +import Language.Haskell.TH.Quote +-- import Language.Haskell.TH.Lift + +import Language.LBNF.Compiletime(printTree, stringAq, parseToQuoter) +import Language.LBNF.CF(quoterName, CF, quoters, aqSyntax) + +cf2qq :: CF -> Q [Dec] +cf2qq cf = do + aqToken <- maybe (return []) (deriveAq cf) (aqSyntax cf) + qqs <- sequence $ map mkQQ eps + return $ aqToken ++ qqs + where + eps = quoters cf + + +deriveAq cf (_,i,a) = do + v <- newName "a" + let nAqToken = mkName "AqToken" + nAqFun = mkName "global_aq" + d <-funD nAqFun [clause [conP nAqToken [varP v]] (normalB $ aqDec (varE v)) []] + return $ [d] where + aqDec v = + [| stringAq (drop $(lie) . reverse . drop $(lae) . reverse $ printTree $(v)) |] + (lie, lae) = (lift $ length i + 1 ,lift $ length a + 1) + +mkQQ s = funD qqName [clause [] (normalB qqe) []] where + qqe = [|parseToQuoter ($(varE qName) . $(varE tokName)) |] + qqName = mkName $ quoterName s + qName = mkName $ 'q':s + tokName = mkName "myLexer" + +
Language/LBNF/GetCF.hs view
@@ -1,274 +1,274 @@-{-- 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 Language.LBNF.GetCF where--import Control.Monad ( when )--import Language.LBNF.CF-import Language.LBNF.Utils--- import Language.LBNF.ParBNF-import Language.LBNF.Grammar(pGrammar, tokens)--import Data.List(nub,partition)-import qualified Language.LBNF.Grammar as Abs-import Language.LBNF.Runtime-import Data.Char-import Language.LBNF.TypeChecker--type TempRHS = Either [Either String String] Reg-type TempRule = (Fun,(Cat,TempRHS))--getCF :: String -> (CF, [String])-getCF = getCFofG . pGrammar . tokens--getCFofG :: ParseMonad Abs.Grammar -> (CF, [String])-getCFofG g = (cf,msgs ++ msgs1) where-- (cf,msgs1) = ((exts,ruls2),msgs2)- (ruls2,msgs2) = untag $ map (checkRule cf0) $ rulesOfCF cf0- untag :: ([Either Rule String]) -> ([Rule],[String])- untag ls = ([c | Left c <- ls], [r| Right r <- ls])- -- isRule = either (const True) (const False)- cf0 :: CF- (cf0@(exts,_),msgs) = (revs . srt . conv $ g)- srt :: [Either (Either Pragma TempRule) String] -> (CF, [String])- srt rs = let - rules = [fixRuleTokens n r | (n,Left (Right r)) <- zip [1..] rs]- literals = nub [lit | Left xs <- map (snd . snd) rules,- (Left lit) <- xs,- elem lit specialCatsP]- - pragma = [r | Left (Left r) <- rs]- tokens = [i | TokenReg i _ _ <- pragma]- errors = [s | Right s <- rs, not (null s)]- (symbols,keywords) = partition notIdent reservedWords- notIdent s = null s || not (isIdentAlpha (head s)) || any (not . isIdentRest) s- isIdentAlpha c = isLatin1 c && isAlpha c- isIdentRest c = isIdentAlpha c || isDigit c || c == '_' || c == '\''- reservedWords = nub [t | (_,(_,Left its)) <- rules, Right t <- its] ++ - concatMap (reservedLiteralAQ [ (b,i,a) | AntiQuote b i a <- pragma ]) (literals ++ tokens)- cats = []- in (((pragma,(literals,symbols,keywords,cats)),rules),errors)- - revs :: (CF, [String]) -> (CF, [String])- revs (cf@((pragma,(literals,symbols,keywords,_)),rules),errors) =- (((pragma,- (literals,symbols,keywords,findAllReversibleCats (cf))),rules),errors)--fixRuleTokens :: Int -> TempRule -> Rule-fixRuleTokens n (f,(c,rhs)) = - (f,(c,either Left (\r -> Right (r,"RTL_"++show n)) rhs))---- --conv :: ParseMonad Abs.Grammar -> [Either (Either Pragma TempRule) String]-conv (Bad s) = [Right s]-conv (Ok (Abs.Grammar defs)) = map Left $ concatMap (transDef defs) defs--reservedLiteralAQ [] l = []-reservedLiteralAQ [(b,i,a)] l = [b ++ l]-reservedLiteralAQ _ l = error "multiple antiquote pragmas"--isAqLabel x = case x of- (Abs.Aq s) -> True--- Abs.LabP Abs.Aq _ -> True--- Abs.LabPF Abs.Aq _ _ -> True--- Abs.LabF Abs.Aq _ -> True--- _ -> False--transDef :: [Abs.Def] -> Abs.Def -> [Either Pragma TempRule]-transDef defs x = case x of--- Abs.Rule label cat items | isAqLabel label -> []- Abs.Rule label cat items -> - [Right (transLabel label,(transCat cat, transRHS 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 $ Left "#":(map transItem items))))]- Abs.Separator size ident str -> map Right $ separatorRules size ident str- Abs.Terminator size ident str -> map Right $ terminatorRules size ident str- Abs.Coercions ident int -> map (Right) $ coercionRules ident int- Abs.Rules ident strs -> map (Right) $ ebnfRules ident strs- Abs.Layout ss -> [Left $ Layout ss]- Abs.LayoutStop ss -> [Left $ LayoutStop ss]- Abs.LayoutTop -> [Left $ LayoutTop]- Abs.Derive ss -> [Left $ Derive [s|Abs.Ident s<-ss]]--- Abs.Function f xs e -> [Left $ FunDef (transIdent f) (map transArg xs) (transExp e)]- Abs.AntiQuote b i a ->- [Left $ AntiQuote b i a] - ++ [Left $ TokenReg "AqToken" False $ aqToken i a]- ++ aqRules (b,i,a) (getCats defs) where- reg = aqToken a--aqToken :: String -> String -> Abs.Reg-aqToken i s@(c:cs) = Abs.RSeq (Abs.RSeqs i) $ Abs.RSeq (Abs.RStar $ foldr1 Abs.RAlt $ map clause prefixes) $ Abs.RSeqs s where- prefixes = scanr (:) [c] . reverse $ cs- clause (d:ds) = subclause (reverse ds) (Abs.RMinus Abs.RAny $ Abs.RChar d)- subclause [] x = x- subclause (e:es) x = Abs.RSeq (Abs.RChar e) (subclause es x)--getCats :: [Abs.Def] -> [Cat]-getCats = nub . concatMap (\x -> case x of- Abs.Rule _ cat _ -> [transCat cat]- Abs.Internal _ cat _ -> [transCat cat]- _ -> [])--aqRHS :: [Abs.Item] -> Cat-aqRHS xs = case filter filt xs of- [Abs.NTerminal cat] -> transCat cat- _ -> error "anti-quotation rules must have exactly one non-terminal"- where- filt x =case x of- Abs.Terminal str -> False- Abs.NTerminal cat -> True---toks x = case x of- Abs.Token (Abs.Ident ident) reg -> [ident]- Abs.PosToken (Abs.Ident ident) reg -> [ident]- _ -> []--aqRules :: (String,String,String) -> [String] -> [Either Pragma TempRule]-aqRules (b,i,a) = concatMap aqRule where- aqRule cat = map Right [- (aqFun,(cat, Left [Right b,Left "AqToken"])),- (aqFun,(cat, Left [Right (b++normCat cat), Left "AqToken"]))- ]--aqFun = "$global_aq"---- addSpecials :: (String,String,String) -> [Either Pragma Rule] -> [Either Pragma Rule]--- addSpecials (b,i,a) rs = rs ++ concatMap special literals where- --- special aqs@('A':'Q':'_':s) = map Right [(aqs,(aqs,[Left s])),--- (renameAq s,(rename s, [Right b,Left "AqToken"])),--- (renameAqt s,(rename s, [Right (b++s), Left "AqToken"]))--- ]--- rules = [r | (Right r) <- rs]--- literals = nub [lit | xs <- map (snd . snd) rules,--- (Left lit) <- xs,--- elem lit (map rename specialCatsP)]--- \end{hack}----separatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [TempRule]-separatorRules size c s = if null s then terminatorRules size c s else ifEmpty [- ("(:[])", (cs,Left [Left c'])),- ("(:)", (cs,Left [Left c', Right s, Left cs]))- ]- where - c' = transCat c- cs = "[" ++ c' ++ "]"- ifEmpty rs = if (size == Abs.MNonempty) then rs else (("[]", (cs,Left [])) : rs)--terminatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [TempRule]-terminatorRules size c s = [- ifEmpty,- ("(:)", (cs,Left $ 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 $ [Left c'] ++ if null s then [] else [Right s]))- else ("[]", (cs,Left []))--coercionRules :: Abs.Ident -> Integer -> [TempRule]-coercionRules (Abs.Ident c) n = - ("_", (c, Left [Left (c ++ "1")])) :- [("_", (c ++ show (i-1), Left [Left (c ++ show i)])) | i <- [2..n]] ++- [("_", (c ++ show n, Left [Right "(", Left c, Right ")"]))]-- -ebnfRules :: Abs.Ident -> [Abs.RHS] -> [TempRule]-ebnfRules (Abs.Ident c) rhss = - [(mkFun k c rhs, (c, transRHS rhs)) | (k, rhs) <- zip [1 :: Int ..] rhss]- where- mkFun :: Int -> String -> Abs.RHS -> String- mkFun k c i = case i of- (Abs.RHS [Abs.Terminal s]) -> c' ++ "_" ++ mkName k s- (Abs.RHS [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---transRHS :: Abs.RHS -> TempRHS-transRHS (Abs.RHS its) = Left $ map transItem its-transRHS (Abs.TRHS r) = Right r----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-transLabel y = let g = transLabelId y in g- where- transLabelId x = case x of- Abs.Id id -> transIdent id- Abs.Wild -> "_"- Abs.ListE -> "[]"- Abs.ListCons -> "(:)"- Abs.ListOne -> "(:[])"- Abs.Aq (Abs.JIdent i) -> "$" ++ transIdent i- Abs.Aq _ -> "$"--- 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 "[]" []---+{- + 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 Language.LBNF.GetCF where + +import Control.Monad ( when ) + +import Language.LBNF.CF +import Language.LBNF.Utils +-- import Language.LBNF.ParBNF +import Language.LBNF.Grammar(pGrammar, tokens) + +import Data.List(nub,partition) +import qualified Language.LBNF.Grammar as Abs +import Language.LBNF.Runtime +import Data.Char +import Language.LBNF.TypeChecker + +type TempRHS = Either [Either String String] Reg +type TempRule = (Fun,(Cat,TempRHS)) + +getCF :: String -> (CF, [String]) +getCF = getCFofG . pGrammar . tokens + +getCFofG :: ParseMonad Abs.Grammar -> (CF, [String]) +getCFofG g = (cf,msgs ++ msgs1) where + + (cf,msgs1) = ((exts,ruls2),msgs2) + (ruls2,msgs2) = untag $ map (checkRule cf0) $ rulesOfCF cf0 + untag :: ([Either Rule String]) -> ([Rule],[String]) + untag ls = ([c | Left c <- ls], [r| Right r <- ls]) + -- isRule = either (const True) (const False) + cf0 :: CF + (cf0@(exts,_),msgs) = (revs . srt . conv $ g) + srt :: [Either (Either Pragma TempRule) String] -> (CF, [String]) + srt rs = let + rules = [fixRuleTokens n r | (n,Left (Right r)) <- zip [1..] rs] + literals = nub [lit | Left xs <- map (snd . snd) rules, + (Left lit) <- xs, + elem lit specialCatsP] + + pragma = [r | Left (Left r) <- rs] + tokens = [i | TokenReg i _ _ <- pragma] + errors = [s | Right s <- rs, not (null s)] + (symbols,keywords) = partition notIdent reservedWords + notIdent s = null s || not (isIdentAlpha (head s)) || any (not . isIdentRest) s + isIdentAlpha c = isLatin1 c && isAlpha c + isIdentRest c = isIdentAlpha c || isDigit c || c == '_' || c == '\'' + reservedWords = nub [t | (_,(_,Left its)) <- rules, Right t <- its] ++ + concatMap (reservedLiteralAQ [ (b,i,a) | AntiQuote b i a <- pragma ]) (literals ++ tokens) + cats = [] + in (((pragma,(literals,symbols,keywords,cats)),rules),errors) + + revs :: (CF, [String]) -> (CF, [String]) + revs (cf@((pragma,(literals,symbols,keywords,_)),rules),errors) = + (((pragma, + (literals,symbols,keywords,findAllReversibleCats (cf))),rules),errors) + +fixRuleTokens :: Int -> TempRule -> Rule +fixRuleTokens n (f,(c,rhs)) = + (f,(c,either Left (\r -> Right (r,"RTL_"++show n)) rhs)) + + + + + +conv :: ParseMonad Abs.Grammar -> [Either (Either Pragma TempRule) String] +conv (Bad s) = [Right s] +conv (Ok (Abs.Grammar defs)) = map Left $ concatMap (transDef defs) defs + +reservedLiteralAQ [] l = [] +reservedLiteralAQ [(b,i,a)] l = [b ++ l] +reservedLiteralAQ _ l = error "multiple antiquote pragmas" + +isAqLabel x = case x of + (Abs.Aq s) -> True +-- Abs.LabP Abs.Aq _ -> True +-- Abs.LabPF Abs.Aq _ _ -> True +-- Abs.LabF Abs.Aq _ -> True +-- _ -> False + +transDef :: [Abs.Def] -> Abs.Def -> [Either Pragma TempRule] +transDef defs x = case x of +-- Abs.Rule label cat items | isAqLabel label -> [] + Abs.Rule label cat items -> + [Right (transLabel label,(transCat cat, transRHS 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 $ Left "#":(map transItem items))))] + Abs.Separator size ident str -> map Right $ separatorRules size ident str + Abs.Terminator size ident str -> map Right $ terminatorRules size ident str + Abs.Coercions ident int -> map (Right) $ coercionRules ident int + Abs.Rules ident strs -> map (Right) $ ebnfRules ident strs + Abs.Layout ss -> [Left $ Layout ss] + Abs.LayoutStop ss -> [Left $ LayoutStop ss] + Abs.LayoutTop -> [Left $ LayoutTop] + Abs.Derive ss -> [Left $ Derive [s|Abs.Ident s<-ss]] +-- Abs.Function f xs e -> [Left $ FunDef (transIdent f) (map transArg xs) (transExp e)] + Abs.AntiQuote b i a -> + [Left $ AntiQuote b i a] + ++ [Left $ TokenReg "AqToken" False $ aqToken i a] + ++ aqRules (b,i,a) (getCats defs) where + reg = aqToken a + +aqToken :: String -> String -> Abs.Reg +aqToken i s@(c:cs) = Abs.RSeq (Abs.RSeqs i) $ Abs.RSeq (Abs.RStar $ foldr1 Abs.RAlt $ map clause prefixes) $ Abs.RSeqs s where + prefixes = scanr (:) [c] . reverse $ cs + clause (d:ds) = subclause (reverse ds) (Abs.RMinus Abs.RAny $ Abs.RChar d) + subclause [] x = x + subclause (e:es) x = Abs.RSeq (Abs.RChar e) (subclause es x) + +getCats :: [Abs.Def] -> [Cat] +getCats = nub . concatMap (\x -> case x of + Abs.Rule _ cat _ -> [transCat cat] + Abs.Internal _ cat _ -> [transCat cat] + _ -> []) + +aqRHS :: [Abs.Item] -> Cat +aqRHS xs = case filter filt xs of + [Abs.NTerminal cat] -> transCat cat + _ -> error "anti-quotation rules must have exactly one non-terminal" + where + filt x =case x of + Abs.Terminal str -> False + Abs.NTerminal cat -> True + + +toks x = case x of + Abs.Token (Abs.Ident ident) reg -> [ident] + Abs.PosToken (Abs.Ident ident) reg -> [ident] + _ -> [] + +aqRules :: (String,String,String) -> [String] -> [Either Pragma TempRule] +aqRules (b,i,a) = concatMap aqRule where + aqRule cat = map Right [ + (aqFun,(cat, Left [Right b,Left "AqToken"])), + (aqFun,(cat, Left [Right (b++normCat cat), Left "AqToken"])) + ] + +aqFun = "$global_aq" + +-- addSpecials :: (String,String,String) -> [Either Pragma Rule] -> [Either Pragma Rule] +-- addSpecials (b,i,a) rs = rs ++ concatMap special literals where + +-- special aqs@('A':'Q':'_':s) = map Right [(aqs,(aqs,[Left s])), +-- (renameAq s,(rename s, [Right b,Left "AqToken"])), +-- (renameAqt s,(rename s, [Right (b++s), Left "AqToken"])) +-- ] +-- rules = [r | (Right r) <- rs] +-- literals = nub [lit | xs <- map (snd . snd) rules, +-- (Left lit) <- xs, +-- elem lit (map rename specialCatsP)] +-- \end{hack} + + + +separatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [TempRule] +separatorRules size c s = if null s then terminatorRules size c s else ifEmpty [ + ("(:[])", (cs,Left [Left c'])), + ("(:)", (cs,Left [Left c', Right s, Left cs])) + ] + where + c' = transCat c + cs = "[" ++ c' ++ "]" + ifEmpty rs = if (size == Abs.MNonempty) then rs else (("[]", (cs,Left [])) : rs) + +terminatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [TempRule] +terminatorRules size c s = [ + ifEmpty, + ("(:)", (cs,Left $ 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 $ [Left c'] ++ if null s then [] else [Right s])) + else ("[]", (cs,Left [])) + +coercionRules :: Abs.Ident -> Integer -> [TempRule] +coercionRules (Abs.Ident c) n = + ("_", (c, Left [Left (c ++ "1")])) : + [("_", (c ++ show (i-1), Left [Left (c ++ show i)])) | i <- [2..n]] ++ + [("_", (c ++ show n, Left [Right "(", Left c, Right ")"]))] + + +ebnfRules :: Abs.Ident -> [Abs.RHS] -> [TempRule] +ebnfRules (Abs.Ident c) rhss = + [(mkFun k c rhs, (c, transRHS rhs)) | (k, rhs) <- zip [1 :: Int ..] rhss] + where + mkFun :: Int -> String -> Abs.RHS -> String + mkFun k c i = case i of + (Abs.RHS [Abs.Terminal s]) -> c' ++ "_" ++ mkName k s + (Abs.RHS [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 + + +transRHS :: Abs.RHS -> TempRHS +transRHS (Abs.RHS its) = Left $ map transItem its +transRHS (Abs.TRHS r) = Right r + + + +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 +transLabel y = let g = transLabelId y in g + where + transLabelId x = case x of + Abs.Id id -> transIdent id + Abs.Wild -> "_" + Abs.ListE -> "[]" + Abs.ListCons -> "(:)" + Abs.ListOne -> "(:[])" + Abs.Aq (Abs.JIdent i) -> "$" ++ transIdent i + Abs.Aq _ -> "$" +-- 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 "[]" [] + + +
Language/LBNF/Runtime.hs view
@@ -1,144 +1,144 @@-{-#LANGUAGE TemplateHaskell #-}--module Language.LBNF.Runtime(- -- * Happy and Alex runtimes- -- ord- -- , listArray- -- , (!)- -- , Array- -- , parseToQuoter- ParseMonad(..)- , err- - -- * Pretty printing runtimes- , printTree- , doc- , concatD- , Print(..)- , prPrec- , PrintPlain(..)-- -- * Quasi quoting runtimes- --, Q- --, BNFC_QQType, appEPAll, appEPAllL, fromLit, fromString, fromToken- --, Lift (..)- ) where----import Control.Monad (MonadPlus(..), liftM, foldM, (>=>))----import Data.Char------------------------- Lexing, Parsing---------------------data ParseMonad a = Ok a | Bad String- deriving (Read, Show, Eq, Ord)--instance Monad ParseMonad where- return = Ok- fail = Bad- Ok a >>= f = f a- Bad s >>= f = Bad s--instance Functor ParseMonad where- fmap = liftM----instance MonadPlus ParseMonad where--- mzero = Bad "Err.mzero"--- mplus (Bad _) y = y--- mplus x _ = x--err :: (String -> a) -> ParseMonad a -> a-err e b = case b of - Bad s -> e s- Ok x -> x----------------- PRINTING--------------printTree :: Print a => a -> String-printTree = render . prt 0--type Doc = [ShowS] -> [ShowS]--doc :: ShowS -> Doc-doc = (:)--render :: Doc -> String-render d = rend 0 (map ($ "") $ d []) "" where- rend i ss = case ss of- "[" :ts -> showChar '[' . rend i ts- "(" :ts -> showChar '(' . rend i ts- "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts- "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts- "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts- ";" :ts -> showChar ';' . new i . rend i ts- t : "," :ts -> showString t . space "," . rend i ts- t : ")" :ts -> showString t . showChar ')' . rend i ts- t : "]" :ts -> showString t . showChar ']' . rend i ts- t :ts -> space t . rend i ts- _ -> id- new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace- space t = showString t . (\s -> if null s then "" else (' ':s))--parenth :: Doc -> Doc-parenth ss = doc (showChar '(') . ss . doc (showChar ')')--concatS :: [ShowS] -> ShowS-concatS = foldr (.) id--concatD :: [Doc] -> Doc-concatD = foldr (.) id--replicateS :: Int -> ShowS -> ShowS-replicateS n f = concatS (replicate n f)---- the printer class does the job-class Print a where- prt :: Int -> a -> Doc- prtList :: [a] -> Doc- prtList = concatD . map (prt 0)--instance Print a => Print [a] where- prt _ = prtList--instance Print Char where- prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')- prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')--mkEsc :: Char -> Char -> ShowS-mkEsc q s = case s of- _ | s == q -> showChar '\\' . showChar s- '\\'-> showString "\\\\"- '\n' -> showString "\\n"- '\t' -> showString "\\t"- _ -> showChar s--prPrec :: Int -> Int -> Doc -> Doc-prPrec i j = if j<i then parenth else id---instance Print Integer where- prt _ x = doc (shows x)- prtList es = case es of- [] -> (concatD [])- [x] -> (concatD [prt 0 x])- x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])---instance Print Double where- prt _ x = doc (shows x)--newtype PrintPlain = MkPrintPlain String--instance Print PrintPlain where+{-#LANGUAGE TemplateHaskell #-} + +module Language.LBNF.Runtime( + -- * Happy and Alex runtimes + -- ord + -- , listArray + -- , (!) + -- , Array + -- , parseToQuoter + ParseMonad(..) + , err + + -- * Pretty printing runtimes + , printTree + , doc + , concatD + , Print(..) + , prPrec + , PrintPlain(..) + + -- * Quasi quoting runtimes + --, Q + --, BNFC_QQType, appEPAll, appEPAllL, fromLit, fromString, fromToken + --, Lift (..) + ) where + + + +import Control.Monad (MonadPlus(..), liftM, foldM, (>=>)) + + + +import Data.Char + + + +------------------ +-- Lexing, Parsing +------------------ + +data ParseMonad a = Ok a | Bad String + deriving (Read, Show, Eq, Ord) + +instance Monad ParseMonad where + return = Ok + fail = Bad + Ok a >>= f = f a + Bad s >>= f = Bad s + +instance Functor ParseMonad where + fmap = liftM + +--instance MonadPlus ParseMonad where +-- mzero = Bad "Err.mzero" +-- mplus (Bad _) y = y +-- mplus x _ = x + +err :: (String -> a) -> ParseMonad a -> a +err e b = case b of + Bad s -> e s + Ok x -> x + + +----------- +-- PRINTING +----------- + +printTree :: Print a => a -> String +printTree = render . prt 0 + +type Doc = [ShowS] -> [ShowS] + +doc :: ShowS -> Doc +doc = (:) + +render :: Doc -> String +render d = rend 0 (map ($ "") $ d []) "" where + rend i ss = case ss of + "[" :ts -> showChar '[' . rend i ts + "(" :ts -> showChar '(' . rend i ts + "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts + "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts + "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts + ";" :ts -> showChar ';' . new i . rend i ts + t : "," :ts -> showString t . space "," . rend i ts + t : ")" :ts -> showString t . showChar ')' . rend i ts + t : "]" :ts -> showString t . showChar ']' . rend i ts + t :ts -> space t . rend i ts + _ -> id + new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace + space t = showString t . (\s -> if null s then "" else (' ':s)) + +parenth :: Doc -> Doc +parenth ss = doc (showChar '(') . ss . doc (showChar ')') + +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +concatD :: [Doc] -> Doc +concatD = foldr (.) id + +replicateS :: Int -> ShowS -> ShowS +replicateS n f = concatS (replicate n f) + +-- the printer class does the job +class Print a where + prt :: Int -> a -> Doc + prtList :: [a] -> Doc + prtList = concatD . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') + prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') + +mkEsc :: Char -> Char -> ShowS +mkEsc q s = case s of + _ | s == q -> showChar '\\' . showChar s + '\\'-> showString "\\\\" + '\n' -> showString "\\n" + '\t' -> showString "\\t" + _ -> showChar s + +prPrec :: Int -> Int -> Doc -> Doc +prPrec i j = if j<i then parenth else id + + +instance Print Integer where + prt _ x = doc (shows x) + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + + +instance Print Double where + prt _ x = doc (shows x) + +newtype PrintPlain = MkPrintPlain String + +instance Print PrintPlain where prt _ (MkPrintPlain s) = doc $ showString s
Language/LBNF/TypeChecker.hs view
@@ -1,147 +1,147 @@--module Language.LBNF.TypeChecker where--import Control.Monad-import Data.List-import Data.Char--import Language.LBNF.CF-import Language.LBNF.Runtime--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 :: ParseMonad a -> (String -> ParseMonad a) -> ParseMonad 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 (Left args) = FunT [ mkBase t | Left t <- args, t /= internalCat ]- (mkBase cat)- mkType cat (Right reg) = FunT [ BaseT "String" ] (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 -> ParseMonad 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 -> ParseMonad ()-checkDefinitions cf@((ps,_),_) =- do checkContext ctx- sequence_ [ checkDefinition ctx f xs e | FunDef f xs e <- ps ]- where- ctx = buildContext cf--checkContext :: Context -> ParseMonad ()-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 -> ParseMonad ()-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 -> ParseMonad ([(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 -> ParseMonad 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 ++ "."-+ +module Language.LBNF.TypeChecker where + +import Control.Monad +import Data.List +import Data.Char + +import Language.LBNF.CF +import Language.LBNF.Runtime + +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 :: ParseMonad a -> (String -> ParseMonad a) -> ParseMonad 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 (Left args) = FunT [ mkBase t | Left t <- args, t /= internalCat ] + (mkBase cat) + mkType cat (Right reg) = FunT [ BaseT "String" ] (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 -> ParseMonad 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 -> ParseMonad () +checkDefinitions cf@((ps,_),_) = + do checkContext ctx + sequence_ [ checkDefinition ctx f xs e | FunDef f xs e <- ps ] + where + ctx = buildContext cf + +checkContext :: Context -> ParseMonad () +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 -> ParseMonad () +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 -> ParseMonad ([(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 -> ParseMonad 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 ++ "." +
Language/LBNF/Utils.hs view
@@ -1,112 +1,112 @@-{-- 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 Language.LBNF.Utils where--import Control.Monad (unless)--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'---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+{- + 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 Language.LBNF.Utils where + +import Control.Monad (unless) + +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' + + +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
Setup.lhs view
@@ -1,3 +1,3 @@-> import Distribution.Simple-> main :: IO ()+> import Distribution.Simple +> main :: IO () > main = defaultMain
examples/ghc6/jll/JavaletteLight.hs view
@@ -1,59 +1,59 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}--module JavaletteLight where--import Language.LBNF(lbnf, dumpCode, bnfc)-import Language.LBNF.Compiletime-import qualified Language.LBNF.Grammar----bnfc [$lbnf|---- This is a new pragma. The rest of the grammar is original JL.-antiquote "[" ":" ":]" ;---- Javalette Light: a simple subset of C, covering--- programs with a single zero-argument function.--- example: koe.jll--- ordinary rules--Fun. Prog ::= Typ Ident "(" ")" "{" [Stm] "}" ;--SDecl. Stm ::= Typ Ident ";" ;-SAss. Stm ::= Ident "=" Expr ";" ;-SIncr. Stm ::= Ident "++" ";" ;-SWhile. Stm ::= "while" "(" Expr ")" "{" [Stm] "}" ;--ELt. Expr0 ::= Expr1 "<" Expr1 ;-EPlus. Expr1 ::= Expr1 "+" Expr2 ;-ETimes. Expr2 ::= Expr2 "*" Expr3 ;-EVar. Expr3 ::= Ident ;-EInt. Expr3 ::= Integer ;-EDouble. Expr3 ::= Double ;--[]. [Stm] ::= ;-(:). [Stm] ::= Stm [Stm] ;---- coercions--_. Stm ::= Stm ";" ;--_. Expr ::= Expr0 ;-_. Expr0 ::= Expr1 ;-_. Expr1 ::= Expr2 ;-_. Expr2 ::= Expr3 ;-_. Expr3 ::= "(" Expr ")" ;--TInt. Typ ::= "int" ;-TDouble. Typ ::= "double" ;---- pragmas--comment "/*" "*/" ;-comment "//" ;--entrypoints Prog, Stm, Expr ;- |]--+{-# LANGUAGE QuasiQuotes, TemplateHaskell #-} + +module JavaletteLight where + +import Language.LBNF(lbnf, dumpCode, bnfc) +import Language.LBNF.Compiletime +import qualified Language.LBNF.Grammar + + + +bnfc [$lbnf| + +-- This is a new pragma. The rest of the grammar is original JL. +antiquote "[" ":" ":]" ; + +-- Javalette Light: a simple subset of C, covering +-- programs with a single zero-argument function. +-- example: koe.jll +-- ordinary rules + +Fun. Prog ::= Typ Ident "(" ")" "{" [Stm] "}" ; + +SDecl. Stm ::= Typ Ident ";" ; +SAss. Stm ::= Ident "=" Expr ";" ; +SIncr. Stm ::= Ident "++" ";" ; +SWhile. Stm ::= "while" "(" Expr ")" "{" [Stm] "}" ; + +ELt. Expr0 ::= Expr1 "<" Expr1 ; +EPlus. Expr1 ::= Expr1 "+" Expr2 ; +ETimes. Expr2 ::= Expr2 "*" Expr3 ; +EVar. Expr3 ::= Ident ; +EInt. Expr3 ::= Integer ; +EDouble. Expr3 ::= Double ; + +[]. [Stm] ::= ; +(:). [Stm] ::= Stm [Stm] ; + +-- coercions + +_. Stm ::= Stm ";" ; + +_. Expr ::= Expr0 ; +_. Expr0 ::= Expr1 ; +_. Expr1 ::= Expr2 ; +_. Expr2 ::= Expr3 ; +_. Expr3 ::= "(" Expr ")" ; + +TInt. Typ ::= "int" ; +TDouble. Typ ::= "double" ; + +-- pragmas + +comment "/*" "*/" ; +comment "//" ; + +entrypoints Prog, Stm, Expr ; + |] + +
examples/ghc6/jll/UseJll.hs view
@@ -1,46 +1,46 @@-{-# LANGUAGE QuasiQuotes #-}-import JavaletteLight-import Language.LBNF.Runtime -- overloaded pretty-printing function-import Prelude hiding (exp)--{- This Javalette Light program is parsed at compile time, -and replaced by it's abstract syntax representation.-The 'holes' in square brackets are anti-quoted Haskell -expression. --The QuasiQuoter prog is generated from the grammar in JavaletteLight.hs-(it corresponds to the category Prog).--}---prg x v e = [$prog|-int f() {- int a; - [:SWhile (EInt 10 :: Expr) [x]:]- int a;- int [:v:];- int tmp;- while (n < [Expr:e:]) {- n = n + 1;- tmp = a + b;- a = b;- b = tmp;- }-}-|] --st v = [$stm| [:v:] = 1; |]-pr = prg (st (Ident "n")) (Ident "n") [$expr|n|]-main = putStr $ printTree pr---eval vs = eval' where- eval' [$expr| [:a:] < [:b:] |] = if eval' a < eval' b then 1 else 0- eval' [$expr| [:a:] + [:b:] |] = eval' a + eval' b- eval' [$expr| [:a:] * [:b:] |] = eval' a * eval' b- eval' [$expr| [Integer: n:] |] = fromInteger n- eval' [$expr| [Double: n:] |] = n- eval' [$expr| [Ident: v:] |] = varval v- varval v = maybe (error $ "undefined variable" ++ printTree v) id $ flip lookup vs v--h = eval [(Ident "a",5)] [$expr|a+2+3*4|]+{-# LANGUAGE QuasiQuotes #-} +import JavaletteLight +import Language.LBNF.Runtime -- overloaded pretty-printing function +import Prelude hiding (exp) + +{- This Javalette Light program is parsed at compile time, +and replaced by it's abstract syntax representation. +The 'holes' in square brackets are anti-quoted Haskell +expression. + +The QuasiQuoter prog is generated from the grammar in JavaletteLight.hs +(it corresponds to the category Prog). +-} + + +prg x v e = [$prog| +int f() { + int a; + [:SWhile (EInt 10 :: Expr) [x]:] + int a; + int [:v:]; + int tmp; + while (n < [Expr:e:]) { + n = n + 1; + tmp = a + b; + a = b; + b = tmp; + } +} +|] + +st v = [$stm| [:v:] = 1; |] +pr = prg (st (Ident "n")) (Ident "n") [$expr|n|] +main = putStr $ printTree pr + + +eval vs = eval' where + eval' [$expr| [:a:] < [:b:] |] = if eval' a < eval' b then 1 else 0 + eval' [$expr| [:a:] + [:b:] |] = eval' a + eval' b + eval' [$expr| [:a:] * [:b:] |] = eval' a * eval' b + eval' [$expr| [Integer: n:] |] = fromInteger n + eval' [$expr| [Double: n:] |] = n + eval' [$expr| [Ident: v:] |] = varval v + varval v = maybe (error $ "undefined variable" ++ printTree v) id $ flip lookup vs v + +h = eval [(Ident "a",5)] [$expr|a+2+3*4|]
examples/ghc7/jll/JavaletteLight.hs view
@@ -1,60 +1,60 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}--module JavaletteLight where--import Language.LBNF(lbnf, dumpCode, bnfc)-import Language.LBNF.Compiletime-import qualified Language.LBNF.Grammar-----bnfc [lbnf|---- This is a new pragma. The rest of the grammar is original JL.-antiquote "[" ":" ":]" ;---- Javalette Light: a simple subset of C, covering--- programs with a single zero-argument function.--- example: koe.jll--- ordinary rules--Fun. Prog ::= Typ Ident "(" ")" "{" [Stm] "}" ;--SDecl. Stm ::= Typ Ident ";" ;-SAss. Stm ::= Ident "=" Expr ";" ;-SIncr. Stm ::= Ident "++" ";" ;-SWhile. Stm ::= "while" "(" Expr ")" "{" [Stm] "}" ;--ELt. Expr0 ::= Expr1 "<" Expr1 ;-EPlus. Expr1 ::= Expr1 "+" Expr2 ;-ETimes. Expr2 ::= Expr2 "*" Expr3 ;-EVar. Expr3 ::= Ident ;-EInt. Expr3 ::= Integer ;-EDouble. Expr3 ::= Double ;--[]. [Stm] ::= ;-(:). [Stm] ::= Stm [Stm] ;---- coercions--_. Stm ::= Stm ";" ;--_. Expr ::= Expr0 ;-_. Expr0 ::= Expr1 ;-_. Expr1 ::= Expr2 ;-_. Expr2 ::= Expr3 ;-_. Expr3 ::= "(" Expr ")" ;--TInt. Typ ::= "int" ;-TDouble. Typ ::= "double" ;---- pragmas--comment "/*" "*/" ;-comment "//" ;--entrypoints Prog, Stm, Expr ;- |]--+{-# LANGUAGE QuasiQuotes, TemplateHaskell #-} + +module JavaletteLight where + +import Language.LBNF(lbnf, dumpCode, bnfc) +import Language.LBNF.Compiletime +import qualified Language.LBNF.Grammar + + + + +bnfc [lbnf| + +-- This is a new pragma. The rest of the grammar is original JL. +antiquote "[" ":" ":]" ; + +-- Javalette Light: a simple subset of C, covering +-- programs with a single zero-argument function. +-- example: koe.jll +-- ordinary rules + +Fun. Prog ::= Typ Ident "(" ")" "{" [Stm] "}" ; + +SDecl. Stm ::= Typ Ident ";" ; +SAss. Stm ::= Ident "=" Expr ";" ; +SIncr. Stm ::= Ident "++" ";" ; +SWhile. Stm ::= "while" "(" Expr ")" "{" [Stm] "}" ; + +ELt. Expr0 ::= Expr1 "<" Expr1 ; +EPlus. Expr1 ::= Expr1 "+" Expr2 ; +ETimes. Expr2 ::= Expr2 "*" Expr3 ; +EVar. Expr3 ::= Ident ; +EInt. Expr3 ::= Integer ; +EDouble. Expr3 ::= Double ; + +[]. [Stm] ::= ; +(:). [Stm] ::= Stm [Stm] ; + +-- coercions + +_. Stm ::= Stm ";" ; + +_. Expr ::= Expr0 ; +_. Expr0 ::= Expr1 ; +_. Expr1 ::= Expr2 ; +_. Expr2 ::= Expr3 ; +_. Expr3 ::= "(" Expr ")" ; + +TInt. Typ ::= "int" ; +TDouble. Typ ::= "double" ; + +-- pragmas + +comment "/*" "*/" ; +comment "//" ; + +entrypoints Prog, Stm, Expr ; + |] + +
examples/ghc7/jll/UseJll.hs view
@@ -1,46 +1,46 @@-{-# LANGUAGE QuasiQuotes #-}-import JavaletteLight-import Language.LBNF.Runtime -- overloaded pretty-printing function-import Prelude hiding (exp)--{- This Javalette Light program is parsed at compile time, -and replaced by it's abstract syntax representation.-The 'holes' in square brackets are anti-quoted Haskell -expression. --The QuasiQuoter prog is generated from the grammar in JavaletteLight.hs-(it corresponds to the category Prog).--}---prg x v e = [prog|-int f() {- int a; - [:SWhile (EInt 10 :: Expr) [x]:]- int a;- int [:v:];- int tmp;- while (n < [Expr:e:]) {- n = n + 1;- tmp = a + b;- a = b;- b = tmp;- }-}-|] --st v = [stm| [:v:] = 1; |]-pr = prg (st (Ident "n")) (Ident "n") [expr|n|]-main = putStr $ printTree pr---eval vs = eval' where- varval v = maybe (error $ "undefined variable" ++ printTree v) id $ flip lookup vs v- eval' [expr| [:a:] < [:b:] |] = if eval' a < eval' b then 1 else 0- eval' [expr| [:a:] + [:b:] |] = eval' a + eval' b- eval' [expr| [:a:] * [:b:] |] = eval' a * eval' b- eval' [expr| [Integer: n:] |] = fromInteger n- eval' [expr| [Double: n:] |] = n- eval' [expr| [Ident: v:] |] = varval v--h = eval [(Ident "a",5)] [expr|a+2+3*4|]+{-# LANGUAGE QuasiQuotes #-} +import JavaletteLight +import Language.LBNF.Runtime -- overloaded pretty-printing function +import Prelude hiding (exp) + +{- This Javalette Light program is parsed at compile time, +and replaced by it's abstract syntax representation. +The 'holes' in square brackets are anti-quoted Haskell +expression. + +The QuasiQuoter prog is generated from the grammar in JavaletteLight.hs +(it corresponds to the category Prog). +-} + + +prg x v e = [prog| +int f() { + int a; + [:SWhile (EInt 10 :: Expr) [x]:] + int a; + int [:v:]; + int tmp; + while (n < [Expr:e:]) { + n = n + 1; + tmp = a + b; + a = b; + b = tmp; + } +} +|] + +st v = [stm| [:v:] = 1; |] +pr = prg (st (Ident "n")) (Ident "n") [expr|n|] +main = putStr $ printTree pr + + +eval vs = eval' where + varval v = maybe (error $ "undefined variable" ++ printTree v) id $ flip lookup vs v + eval' [expr| [:a:] < [:b:] |] = if eval' a < eval' b then 1 else 0 + eval' [expr| [:a:] + [:b:] |] = eval' a + eval' b + eval' [expr| [:a:] * [:b:] |] = eval' a * eval' b + eval' [expr| [Integer: n:] |] = fromInteger n + eval' [expr| [Double: n:] |] = n + eval' [expr| [Ident: v:] |] = varval v + +h = eval [(Ident "a",5)] [expr|a+2+3*4|]