BNFC-meta 0.3.0.4 → 0.3.0.5
raw patch · 18 files changed
+2825/−2827 lines, 18 filesdep ~arraydep ~template-haskellsetup-changed
Dependency ranges changed: array, template-haskell
Files
- BNFC-meta.cabal +3/−3
- 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 +303/−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 +108/−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.4+version: 0.3.0.5 cabal-Version: >= 1.6 build-type: Simple license: GPL-2@@ -26,8 +26,8 @@ Library Build-Depends: base>=4.2&&<5- , array>=0.3 && <0.5- , template-haskell >=2.4&&<2.8+ , array==0.4.*+ , template-haskell >=2.4&&<2.9 , haskell-src-meta >= 0.5 && < 1.0 , happy-meta >= 0.2.0.4 && < 0.3 , alex-meta >= 0.3.0.3 && < 0.4
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 @@-{-#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 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,303 @@-{-#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 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]:)+ (makedecs top lay stop cf) ++-- | makedecs +makedecs :: Bool -> [String] -> [String] -> CF -> Q [Dec]+makedecs top lay stop cf = [d|+++ 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,109 @@-{- - 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 = '/'+++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|]