diff --git a/BNFC-meta.cabal b/BNFC-meta.cabal --- a/BNFC-meta.cabal +++ b/BNFC-meta.cabal @@ -1,5 +1,5 @@ Name: BNFC-meta -version: 0.3.0.2 +version: 0.3.0.3 cabal-Version: >= 1.6 build-type: Simple license: GPL-2 diff --git a/Language/Haskell/TH/Hide.hs b/Language/Haskell/TH/Hide.hs --- a/Language/Haskell/TH/Hide.hs +++ b/Language/Haskell/TH/Hide.hs @@ -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] + diff --git a/Language/LBNF/CF.hs b/Language/LBNF/CF.hs --- a/Language/LBNF/CF.hs +++ b/Language/LBNF/CF.hs @@ -1,672 +1,672 @@ - -{- - BNF Converter: Abstract syntax - Copyright (C) 2004 Author: Markus Forberg, Michael Pellauer, Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module Language.LBNF.CF ( - -- Types. - CF, - RHS, - Rule, funRule, isTokenRule, - Pragma(..), - Reg(..), - Exp(..), - Literal, - Symbol, - KeyWord, - Cat, - Fun, - Tree(..), - prTree, -- print an abstract syntax tree - Data, -- describes the abstract syntax of a grammar - cf2data, -- translates a grammar to a Data object. - -- cf2dataLists, -- translates to a Data with List categories included. - -- Literal categories, constants, - firstCat, -- the first value category in the grammar. - firstEntry, -- the first entry or the first value category - specialCats, -- ident - specialCatsP, -- all literals - specialData, -- special data - isCoercion, -- wildcards in grammar (avoid syntactic clutter) - isDefinedRule, -- defined rules (allows syntactic sugar) - isProperLabel, -- not coercion or defined rule - allCats, -- all categories of a grammar - allCatsIdNorm, - allEntryPoints, -- those categories that are entry points to the parser - reservedWords, -- get the keywords of a grammar. - symbols, -- get all symbols - literals, -- get all literals of a grammar. (e.g. String, Double) - typed_literals, - reversibleCats, -- categories that is left-recursive transformable. - findAllReversibleCats, -- find all reversible categories - identCat, -- transforms '[C]' to ListC (others, unchanged). - valCat, -- The value category of a rule. - isParsable, -- Checks if the rule is parsable. - rulesOfCF, -- All rules of a grammar. - rulesForCat, -- rules for a given category - ruleGroups, -- Categories are grouped with their rules. - ruleGroupsInternals, --As above, but includes internal cats. - notUniqueFuns, -- Returns a list of function labels that are not unique. - badInheritence, -- Returns a list of all function labels that can cause problems in languages with inheritence. - isList, -- Checks if a category is a list category. - -- Information functions for list functions. - isNilFun, -- empty list function? ([]) - isOneFun, -- one element list function? (:[]) - isConsFun, -- constructor function? (:) - isNilCons, -- either three of above? - isEmptyListCat, -- checks if the list permits [] - revSepListRule, -- reverse a rule, if it is of form C t [C]. - rhsRule, -- The list of Terminals/NonTerminals of a rule. - normCat, -- Removes precendence information. C1 => C, [C2] => [C] - normCatOfList, -- Removes precendence information and enclosed List. C1 => C, C2 => C - catOfList, -- Removes enclosed list: [C1] => C1 - comments, -- translates the pragmas into two list containing the s./m. comments - ruleTokens, - tokenPragmas, -- user-defined regular expression tokens - tokenNames, -- The names of all user-defined tokens - precCat, -- get the precendence level of a Cat C1 => 1, C => 0 - precLevels, -- get all precendence levels in the grammar, sorted in increasing order. - precRule, -- get the precendence level of the value category of a rule. - precCF, -- Check if the CF consists of precendence levels. - isUsedCat, - internalCat, -- the symbol # - isPositionCat, -- category that has a position in AST - isNormal, - isAqFun, - hasIdent, - hasLayout, - hasAq, - rename, - renameAq, - renameAqt, - unAq, - unAqs, - aqSyntax, - -- resolveAq, - layoutPragmas, - derivations, - checkRule, - visibleNames, - quoterName, - quoters, -{- - CFP, -- CF with profiles - RuleP, - FunP, - Prof, - cf2cfpRule, - cf2cfp, - cfp2cf, - trivialProf, - rulesOfCFP, - funRuleP, ruleGroupsP, allCatsP, allEntryPointsP --} - ) where - -import Language.LBNF.Utils (prParenth,(+++)) -import Data.List (nub, intersperse, partition, sort,sort,group) -import Data.Char -import Language.LBNF.Grammar (Reg()) - - --- A context free grammar consists of a set of rules and some extended --- information (e.g. pragmas, literals, symbols, keywords) --- data CF = MkCF { --- rulesOfCF :: CF -> [Rule] --- , infoOfCF :: CFG f -> Info --- , pragmasOfCF :: CFG f -> [Pragma] --- } -type CF = (Exts,[Rule]) - -rulesOfCF :: CF -> [Rule] -rulesOfCF = snd - -infoOfCF :: CFG f -> Info -infoOfCF = snd . fst - -pragmasOfCF :: CFG f -> [Pragma] -pragmasOfCF = fst . fst - - --- A rule consists of a function name, a main category and a sequence of --- terminals and non-terminals. --- function_name . Main_Cat ::= sequence - -isTokenRule :: Rule -> Bool -isTokenRule = either (const False) (const True) . rhsRule - -funRule :: Rule -> Fun -funRule = fst - -oldRHS = either id (const []) - -rhsRule :: Rule -> RHS -rhsRule = snd . snd - - -type RHS = Either [Either Cat String] (Reg,String) -type Rule = (Fun, (Cat, RHS)) - --- polymorphic types for common type signatures for CF and CFP -type Rul f = Rule -- (f, (Cat, [Either Cat String])) -type CFG f = CF -- (Exts,[Rul f]) - -type Exts = ([Pragma],Info) --- Info is information extracted from the CF, for easy access. --- Literals - Char, String, Ident, Integer, Double --- Strings are quoted strings, and Ident are unquoted. --- Symbols - symbols in the grammar, e.g. '*', '->'. --- KeyWord - reserved words, e.g. 'if' 'while' -type Info = ([Literal],[Symbol],[KeyWord],[Cat]) - --- Expressions for function definitions -data Exp = App String [Exp] - | LitInt Integer - | LitDouble Double - | LitChar Char - | LitString String - deriving (Eq) - -instance Show Exp where - showsPrec p e = - case listView e of - Right es -> - showString "[" - . foldr (.) id (intersperse (showString ", ") $ map shows es) - . showString "]" - Left (App x []) -> showString x - Left (App "(:)" [e1,e2]) -> - showParen (p>0) - $ showsPrec 1 e1 - . showString " : " - . shows e2 - Left (App x es) -> - showParen (p>1) - $ foldr (.) id - $ intersperse (showString " ") - $ showString x : map (showsPrec 2) es - Left (LitInt n) -> shows n - Left (LitDouble x) -> shows x - Left (LitChar c) -> shows c - Left (LitString s) -> shows s - where - listView (App "[]" []) = Right [] - listView (App "(:)" [e1,e2]) - | Right es <- listView e2 = Right $ e1:es - listView e = Left e - --- pragmas for single line comments and for multiple-line comments. -data Pragma = CommentS String - | CommentM (String,String) - | TokenReg String Bool Reg - | EntryPoints [Cat] - | Layout [String] - | LayoutStop [String] - | LayoutTop - | Derive [String] - | FunDef String [String] Exp - | AntiQuote String String String - -- ... - deriving (Show, Eq) - -ruleTokens :: CF -> [(String,Reg)] -ruleTokens cf = [(token,reg) | (fun,(c,Right (reg,token))) <- rulesOfCF cf] - -tokenPragmas :: CF -> [(String,Reg)] -tokenPragmas cf = [(name,exp) | TokenReg name _ exp <- pragmasOfCF cf] - -tokenNames :: CF -> [String] -tokenNames cf = fst (unzip (tokenPragmas cf)) - -layoutPragmas :: CF -> (Bool,[String],[String]) -layoutPragmas cf = let ps = pragmasOfCF cf in ( - not (null [() | LayoutTop <- ps]), -- if there's layout betw top-level - concat [ss | Layout ss <- ps], -- layout-block starting words - concat [ss | LayoutStop ss <- ps] -- layout-block ending words - ) - -derivations :: CF -> [String] -derivations cf = case concat [ss|Derive ss <- pragmasOfCF cf] of - [] -> ["Show", "Eq", "Ord"] - x -> x - - -hasLayout :: CF -> Bool -hasLayout cf = case layoutPragmas cf of - (t,ws,_) -> t || not (null ws) -- (True,[],_) means: top-level layout only - -hasAq :: CF -> Bool -hasAq cf = case [(b,a) | AntiQuote b i a <- pragmasOfCF cf] of - [] -> False - _ -> True - -aqSyntax :: CF -> Maybe (String,String,String) -aqSyntax cf = case [(b,i,a) | AntiQuote b i a <- pragmasOfCF cf] of - [] -> Nothing - [t] -> Just t - many -> error "aqSyntax: Multiple antiquote pragmas" -{- -resolveAq cf@((ps,(i,t,y,z)),rs0) = maybe cf addAqRules $ aqSyntax cf where - addAqRules (b,a) = ((map renamePragma ps,(newi,nub $ "[":"]":t,y,(map rename z))),rs) where - rs = map renameRule (rulesOfCF cf) ++ newRules ++ concat (map newType - newi = nub $ "String":i - newRules = map mkNewRule $ filter isNormal $ allCats cf - mkNewRule s = (renameAq s,(rename s,map Right b ++ [Left $ "String"] ++ map Right a)) - renameRule (fun,(cat,itms)) = (rename fun,(rename cat, map renameItem itms)) - renameItem = either (Left . rename) (Right . id) - - renamePragma p = case p of - EntryPoints cs -> EntryPoints $ map rename cs - _ -> p - newType s = [ - (rename s,(rename s,[Left $ s])), - (s++"__AQ",(rename s,map Right b ++ [Left $ "String"] ++ map Right a)) - ] --} - -rename s = case s of - "_" -> s - "$" -> s - "#" -> s - "(:)" -> s - "(:[])" -> s - "[]" -> s - ('$':s) -> "AQ___" ++ s - ('[':l) -> '[' : rename (init l) ++ "]" - _ -> "AQ_" ++ normCat s ++ number s - -renameAqt s = case s of - ('[':l) -> '[' : renameAqt (init l) ++ "]" - _ -> "AQ___" ++ normCat s ++ number s - -renameAq s = case s of - ('[':l) -> '[' : renameAq (init l) ++ "]" - _ -> "AQ__" ++ normCat s ++ number s - -number = reverse . takeWhile isDigit . reverse - -unAq s = case s of - 'A':'Q':'_':r -> Just r - _ -> Nothing - -unAqs s = case s of - 'A':'Q':'_':'_':'_':r -> Just r - 'A':'Q':'_':'_':r -> Just r - _ -> Nothing - --- Literal: Char, String, Ident, Integer, Double -type Literal = Cat -type Symbol = String -type KeyWord = String - --- Cat is the Non-terminals of the grammar. -type Cat = String --- Fun is the function name of a rule. -type Fun = String - -internalCat :: Cat -internalCat = "#" - --- Abstract syntax tree. -newtype Tree = Tree (Fun,[Tree]) - --- The abstract syntax of a grammar. -type Data = (Cat, [(Fun,Either [Cat] String)]) - --- firstCat returns the first Category appearing in the grammar. -firstCat :: CF -> Cat -firstCat = valCat . head . rulesOfCF - -firstEntry :: CF -> Cat -firstEntry cf = case allEntryPoints cf of - (x:_) -> x - _ -> firstCat cf - - - -notUniqueFuns :: CF -> [Fun] -notUniqueFuns cf = let xss = group $ sort [ f | (f,_) <- rulesOfCF cf, - not (isNilCons f || isCoercion f)] - in [ head xs | xs <- xss, length xs > 1] - -badInheritence :: CF -> [Cat] -badInheritence cf = concatMap checkGroup (ruleGroups cf) - where - checkGroup (cat, rs) = if (length rs <= 1) - then [] - else case lookup cat rs of - Nothing -> [] - Just x -> [cat] - - - --- extract the comment pragmas. -commentPragmas :: [Pragma] -> [Pragma] -commentPragmas = filter isComment - where isComment (CommentS _) = True - isComment (CommentM _) = True - isComment _ = False - --- returns all normal rules that constructs the given Cat. -rulesForCat :: CF -> Cat -> [Rule] -rulesForCat cf cat = [normRuleFun r | r <- rulesOfCF cf, isParsable r, valCat r == cat] - ---This version doesn't exclude internal rules. -rulesForCat' :: CF -> Cat -> [Rule] -rulesForCat' cf cat = [normRuleFun r | r <- rulesOfCF cf, valCat r == cat] - -valCat :: Rul f -> Cat -valCat = fst . snd - --- Get all categories of a grammar. -allCats :: CF -> [Cat] -allCats = nub . map valCat . rulesOfCF -- no cats w/o production - --- Gets all normalized identified Categories -allCatsIdNorm :: CF -> [Cat] -allCatsIdNorm = nub . map identCat . map normCat . allCats - --- category is used on an rhs -isUsedCat :: CF -> Cat -> Bool -isUsedCat cf cat = elem cat [c | r <- (rulesOfCF cf), Left c <- oldRHS (rhsRule r)] - --- entry points to parser ---- -allEntryPoints :: CF -> [Cat] -allEntryPoints cf = case concat [cats | EntryPoints cats <- pragmasOfCF cf] of - [] -> allCats cf - cs -> cs - --- group all categories with their rules. -ruleGroups :: CF -> [(Cat,[Rule])] -ruleGroups cf = [(c, rulesForCat cf c) | c <- allCats cf] - --- group all categories with their rules including internal rules. -ruleGroupsInternals :: CF -> [(Cat,[Rule])] -ruleGroupsInternals cf = [(c, rulesForCat' cf c) | c <- allCats cf] - -typed_literals :: CF -> [(Fun,Cat)] -typed_literals cf = map (\x -> (x,x)) lits ++ owns - where - (lits,_,_,_) = infoOfCF cf - owns = map (\(x,_) -> (x,x)) (tokenPragmas cf) -- ++ rulets - rulets = [(fun,c) | (fun,(c,Right reg)) <- rulesOfCF cf] - -literals :: CF -> [Cat] -literals cf = lits ++ owns - where - (lits,_,_,_) = infoOfCF cf - owns = map fst $ tokenPragmas cf ++ ruleTokens cf - -symbols :: CFG f -> [String] -symbols cf = syms - where (_,syms,_,_) = infoOfCF cf - -reservedWords :: CFG f -> [String] -reservedWords cf = sort keywords - where (_,_,keywords,_) = infoOfCF cf - -reversibleCats :: CFG f -> [Cat] -reversibleCats cf = cats - where (_,_,_,cats) = infoOfCF cf - --- Comments can be defined by the 'comment' pragma -comments :: CF -> ([(String,String)],[String]) -comments cf = case commentPragmas (pragmasOfCF cf) of - xs -> ([p | CommentM p <- xs], - [s | CommentS s <- xs]) - - - - --- built-in categories (corresponds to lexer) - --- if the gramamr uses the predefined Ident type -hasIdent :: CF -> Bool -hasIdent cf = isUsedCat cf "Ident" - --- these need new datatypes -specialCats :: CF -> [Cat] -specialCats cf = (if hasIdent cf then ("Ident":) else id) (map fst (tokenPragmas cf)) - --- the parser needs these -specialCatsP :: [Cat] -specialCatsP = words "Ident Integer String Char Double" - --- to print parse trees -prTree :: Tree -> String -prTree (Tree (fun,[])) = fun -prTree (Tree (fun,trees)) = fun +++ unwords (map pr2 trees) where - pr2 t@(Tree (_,ts)) = (if (null ts) then id else prParenth) (prTree t) - --- abstract syntax trees: data type definitions - -cf2data :: CF -> [Data] -cf2data cf = - [(cat, nub (map mkData [r | r@(f,_) <- rulesOfCF cf, - not (isDefinedRule f), - not (isCoercion f), eqCat cat (valCat r), - not (isAqFun f)])) - | cat <- allNormalCats cf] - where - mkData :: Rule -> (Fun,Either [Cat] (String)) - mkData (f,(_,Left its)) = (normFun f,Left [normCat c | Left c <- its, c /= internalCat]) - mkData (f,(_,Right (r,tok))) = (normFun f,Right tok) - -{- ---This version includes lists in the returned data. ---Michael 4/03 -cf2dataLists :: CF -> [Data] -cf2dataLists cf = - [(cat, nub (map mkData [r | r@(f,_) <- rulesOfCF cf, - not (isDefinedRule f), - not (isCoercion f), eqCat cat (valCat r)])) - | cat <- (filter (\x -> not $ isDigit $ last x) (allCats cf))] - where - mkData (f,(_,its)) = (normFun f,[normCat c | Left c <- its, c /= internalCat]) --} - -specialData :: CF -> [Data] -specialData cf = [(c,[(c,Left [arg c])]) | c <- specialCats cf] where - arg c = case c of - _ -> "String" - -allNormalCats :: CF -> [Cat] -allNormalCats = filter isNormal . allCats - --- to deal with coercions - --- the Haskell convention: the wildcard _ is not a constructor - -isCoercion :: Fun -> Bool -isCoercion = (== "_") - -isDefinedRule :: Fun -> Bool -isDefinedRule (x:_) = isLower x - -isProperLabel :: Fun -> Bool -isProperLabel f = not (isCoercion f || isDefinedRule f) - --- categories C1, C2,... (one digit in end) are variants of C - -eqCat :: Cat -> Cat -> Bool -eqCat c c1 = catCat c == catCat c1 - -normCat :: Cat -> Cat -normCat c = case c of - '[':cs -> "[" ++ norm (init cs) ++ "]" - _ -> unList $ norm c -- to be deprecated - where - norm = reverse . dropWhile isDigit . reverse - -normCatOfList :: Cat -> Cat -normCatOfList = normCat . catOfList - --- for Happy and Latex --- When given a list Cat, i.e. '[C]', it removes the square brackets, --- and adds the prefix List, i.e. 'ListC'. -identCat :: Cat -> Cat -identCat c = case c of - '[':cs -> "List" ++ identCat (init cs) - _ -> c - -normFun :: Fun -> Fun -normFun = id -- takeWhile (not . isDigit) - -normRuleFun :: Rule -> Rule -normRuleFun (f,p) = (normFun f, p) - -isNormal :: Cat -> Bool -isNormal c = not (isList c || isDigit (last c) || isAqFun c) - -isParsable :: Rul f -> Bool -isParsable (_,(_, Left (Left "#":_))) = False -isParsable (_,(_, Left (Left "$":_))) = False -isParsable _ = True - -isList :: Cat -> Bool -isList c = head c == '[' - -unList :: Cat -> Cat -unList c = c - -catOfList :: Cat -> Cat -catOfList c = case c of - '[':_:_ -> init (tail c) - _ -> c - -isNilFun, isOneFun, isConsFun, isNilCons, isAqFun :: Fun -> Bool -isNilCons f = isNilFun f || isOneFun f || isConsFun f -isNilFun f = f == "[]" -isOneFun f = f == "(:[])" -isConsFun f = f == "(:)" - -isEmptyListCat :: CF -> Cat -> Bool -isEmptyListCat cf c = elem "[]" $ map fst $ rulesForCat' cf c - -isNonterm = either (const True) (const False) - -isAqFun ('$':_) = True -isAqFun _ = False - --- used in Happy to parse lists of form 'C t [C]' in reverse order --- applies only if the [] rule has no terminals -revSepListRule :: Rul f -> Rul f -revSepListRule r@(f,(c, Left ts)) = (f, (c, Left $ xs : x : sep)) where - (x,sep,xs) = (head ts, init (tail ts), last ts) -revSepListRule x = x --- invariant: test in findAllReversibleCats have been performed - -findAllReversibleCats :: CF -> [Cat] -findAllReversibleCats cf = [c | (c,r) <- ruleGroups cf, isRev c r] where - isRev c rs = case rs of - [r1,r2] | isList c -> if isConsFun (funRule r2) - then tryRev r2 r1 - else if isConsFun (funRule r1) - then tryRev r1 r2 - else False - _ -> False - tryRev :: Rule -> Rule -> Bool - tryRev (f,(_,Left (ts@(x:_:xs)))) r = isEmptyNilRule r && - isConsFun f && isNonterm x && isNonterm (last ts) - tryRev _ _ = False - -isEmptyNilRule (f,(_,Left ts)) = isNilFun f && null ts -isEmptyNilRule _ = False - -precCat :: Cat -> Int -precCat = snd . analyseCat - -precRule :: Rule -> Int -precRule = precCat . valCat - -precLevels :: CF -> [Int] -precLevels cf = sort $ nub $ [ precCat c | c <- allCats cf] - -precCF :: CF -> Bool -precCF cf = length (precLevels cf) > 1 - -catCat :: Cat -> Cat -catCat = fst . analyseCat - -analyseCat :: Cat -> (Cat,Int) -analyseCat c = if (isList c) then list c else noList c - where - list cat = let (rc,n) = noList (init (tail cat)) in ("[" ++ rc ++ "]",n) - noList cat = case span isDigit (reverse cat) of - ([],c') -> (reverse c', 0) - (d,c') -> (reverse c', read (reverse d)) - --- we should actually check that --- (1) coercions are always between variants --- (2) no other digits are used - -checkRule :: CF -> Rule -> Either Rule String -checkRule cf r@(f,(cat,rhs)) - | badCoercion = Right $ "Bad coercion in rule" +++ s - | badNil = Right $ "Bad empty list rule" +++ s - | badOne = Right $ "Bad one-element list rule" +++ s - | badCons = Right $ "Bad list construction rule" +++ s - | badList = Right $ "Bad list formation rule" +++ s - | badSpecial = Right $ "Bad special category rule" +++ s - | badTypeName = Right $ "Bad type name" +++ unwords badtypes +++ "in" +++ s - | badFunName = Right $ "Bad constructor name" +++ f +++ "in" +++ s - | badMissing = Right $ "No production for" +++ unwords missing ++ - ", appearing in rule" +++ s - | otherwise = Left r - where - s = f ++ "." +++ cat +++ "::=" +++ unwords (map (either id show) $ transRHS rhs) --- - c = normCat cat - cs = [normCat c | Left c <- transRHS rhs] - badCoercion = isCoercion f && not ([c] == cs) - badNil = isNilFun f && not (isList c && null cs) - badOne = isOneFun f && not (isList c && cs == [catOfList c]) - badCons = isConsFun f && not (isList c && cs == [catOfList c, c]) - badList = isList c && - not (isCoercion f || isNilFun f || isOneFun f || isConsFun f || isAqFun f) - badSpecial = elem c specialCatsP && not (isCoercion f) - - badMissing = not (null missing) - missing = filter nodef [c | Left c <- transRHS rhs] - nodef t = notElem t defineds - defineds = - "#" : map fst (tokenPragmas cf) ++ specialCatsP ++ map valCat (rulesOfCF cf) - badTypeName = not (null badtypes) - badtypes = filter isBadType $ cat : [c | Left c <- transRHS rhs] - isBadType c = not (isUpper (head c) || isList c || c == "#") - badFunName = not (all (\c -> isAlphaNum c || c == '_') f {-isUpper (head f)-} - || isCoercion f || isNilFun f || isOneFun f || isConsFun f || isAqFun f) - transRHS :: RHS -> [Either Cat String] - transRHS = either id (const []) - -isPositionCat :: CFG f -> Cat -> Bool -isPositionCat cf cat = or [b | TokenReg name b _ <- pragmasOfCF cf, name == cat] - - -visibleNames :: CF -> [String] -visibleNames cf = "myLexer":"tokens":map ('p':) eps ++ map ('q':) eps ++ map initLower eps where - eps = quoters cf - -quoterName :: String -> String -quoterName = initLower -- FIXME: List cats - -quoters :: CF -> [String] -quoters = map identCat . allEntryPoints -- FIXME: List cats - -initLower :: String -> String -initLower [] = error "initLower : Empty list" -initLower (c:cs) = toLower c : cs +{-#Language PatternGuards#-} +{- + BNF Converter: Abstract syntax + Copyright (C) 2004 Author: Markus Forberg, Michael Pellauer, Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Language.LBNF.CF ( + -- Types. + CF, + RHS, + Rule, funRule, isTokenRule, + Pragma(..), + Reg(..), + Exp(..), + Literal, + Symbol, + KeyWord, + Cat, + Fun, + Tree(..), + prTree, -- print an abstract syntax tree + Data, -- describes the abstract syntax of a grammar + cf2data, -- translates a grammar to a Data object. + -- cf2dataLists, -- translates to a Data with List categories included. + -- Literal categories, constants, + firstCat, -- the first value category in the grammar. + firstEntry, -- the first entry or the first value category + specialCats, -- ident + specialCatsP, -- all literals + specialData, -- special data + isCoercion, -- wildcards in grammar (avoid syntactic clutter) + isDefinedRule, -- defined rules (allows syntactic sugar) + isProperLabel, -- not coercion or defined rule + allCats, -- all categories of a grammar + allCatsIdNorm, + allEntryPoints, -- those categories that are entry points to the parser + reservedWords, -- get the keywords of a grammar. + symbols, -- get all symbols + literals, -- get all literals of a grammar. (e.g. String, Double) + typed_literals, + reversibleCats, -- categories that is left-recursive transformable. + findAllReversibleCats, -- find all reversible categories + identCat, -- transforms '[C]' to ListC (others, unchanged). + valCat, -- The value category of a rule. + isParsable, -- Checks if the rule is parsable. + rulesOfCF, -- All rules of a grammar. + rulesForCat, -- rules for a given category + ruleGroups, -- Categories are grouped with their rules. + ruleGroupsInternals, --As above, but includes internal cats. + notUniqueFuns, -- Returns a list of function labels that are not unique. + badInheritence, -- Returns a list of all function labels that can cause problems in languages with inheritence. + isList, -- Checks if a category is a list category. + -- Information functions for list functions. + isNilFun, -- empty list function? ([]) + isOneFun, -- one element list function? (:[]) + isConsFun, -- constructor function? (:) + isNilCons, -- either three of above? + isEmptyListCat, -- checks if the list permits [] + revSepListRule, -- reverse a rule, if it is of form C t [C]. + rhsRule, -- The list of Terminals/NonTerminals of a rule. + normCat, -- Removes precendence information. C1 => C, [C2] => [C] + normCatOfList, -- Removes precendence information and enclosed List. C1 => C, C2 => C + catOfList, -- Removes enclosed list: [C1] => C1 + comments, -- translates the pragmas into two list containing the s./m. comments + ruleTokens, + tokenPragmas, -- user-defined regular expression tokens + tokenNames, -- The names of all user-defined tokens + precCat, -- get the precendence level of a Cat C1 => 1, C => 0 + precLevels, -- get all precendence levels in the grammar, sorted in increasing order. + precRule, -- get the precendence level of the value category of a rule. + precCF, -- Check if the CF consists of precendence levels. + isUsedCat, + internalCat, -- the symbol # + isPositionCat, -- category that has a position in AST + isNormal, + isAqFun, + hasIdent, + hasLayout, + hasAq, + rename, + renameAq, + renameAqt, + unAq, + unAqs, + aqSyntax, + -- resolveAq, + layoutPragmas, + derivations, + checkRule, + visibleNames, + quoterName, + quoters, +{- + CFP, -- CF with profiles + RuleP, + FunP, + Prof, + cf2cfpRule, + cf2cfp, + cfp2cf, + trivialProf, + rulesOfCFP, + funRuleP, ruleGroupsP, allCatsP, allEntryPointsP +-} + ) where + +import Language.LBNF.Utils (prParenth,(+++)) +import Data.List (nub, intersperse, partition, sort,sort,group) +import Data.Char +import Language.LBNF.Grammar (Reg()) + + +-- A context free grammar consists of a set of rules and some extended +-- information (e.g. pragmas, literals, symbols, keywords) +-- data CF = MkCF { +-- rulesOfCF :: CF -> [Rule] +-- , infoOfCF :: CFG f -> Info +-- , pragmasOfCF :: CFG f -> [Pragma] +-- } +type CF = (Exts,[Rule]) + +rulesOfCF :: CF -> [Rule] +rulesOfCF = snd + +infoOfCF :: CFG f -> Info +infoOfCF = snd . fst + +pragmasOfCF :: CFG f -> [Pragma] +pragmasOfCF = fst . fst + + +-- A rule consists of a function name, a main category and a sequence of +-- terminals and non-terminals. +-- function_name . Main_Cat ::= sequence + +isTokenRule :: Rule -> Bool +isTokenRule = either (const False) (const True) . rhsRule + +funRule :: Rule -> Fun +funRule = fst + +oldRHS = either id (const []) + +rhsRule :: Rule -> RHS +rhsRule = snd . snd + + +type RHS = Either [Either Cat String] (Reg,String) +type Rule = (Fun, (Cat, RHS)) + +-- polymorphic types for common type signatures for CF and CFP +type Rul f = Rule -- (f, (Cat, [Either Cat String])) +type CFG f = CF -- (Exts,[Rul f]) + +type Exts = ([Pragma],Info) +-- Info is information extracted from the CF, for easy access. +-- Literals - Char, String, Ident, Integer, Double +-- Strings are quoted strings, and Ident are unquoted. +-- Symbols - symbols in the grammar, e.g. '*', '->'. +-- KeyWord - reserved words, e.g. 'if' 'while' +type Info = ([Literal],[Symbol],[KeyWord],[Cat]) + +-- Expressions for function definitions +data Exp = App String [Exp] + | LitInt Integer + | LitDouble Double + | LitChar Char + | LitString String + deriving (Eq) + +instance Show Exp where + showsPrec p e = + case listView e of + Right es -> + showString "[" + . foldr (.) id (intersperse (showString ", ") $ map shows es) + . showString "]" + Left (App x []) -> showString x + Left (App "(:)" [e1,e2]) -> + showParen (p>0) + $ showsPrec 1 e1 + . showString " : " + . shows e2 + Left (App x es) -> + showParen (p>1) + $ foldr (.) id + $ intersperse (showString " ") + $ showString x : map (showsPrec 2) es + Left (LitInt n) -> shows n + Left (LitDouble x) -> shows x + Left (LitChar c) -> shows c + Left (LitString s) -> shows s + where + listView (App "[]" []) = Right [] + listView (App "(:)" [e1,e2]) + | Right es <- listView e2 = Right $ e1:es + listView e = Left e + +-- pragmas for single line comments and for multiple-line comments. +data Pragma = CommentS String + | CommentM (String,String) + | TokenReg String Bool Reg + | EntryPoints [Cat] + | Layout [String] + | LayoutStop [String] + | LayoutTop + | Derive [String] + | FunDef String [String] Exp + | AntiQuote String String String + -- ... + deriving (Show, Eq) + +ruleTokens :: CF -> [(String,Reg)] +ruleTokens cf = [(token,reg) | (fun,(c,Right (reg,token))) <- rulesOfCF cf] + +tokenPragmas :: CF -> [(String,Reg)] +tokenPragmas cf = [(name,exp) | TokenReg name _ exp <- pragmasOfCF cf] + +tokenNames :: CF -> [String] +tokenNames cf = fst (unzip (tokenPragmas cf)) + +layoutPragmas :: CF -> (Bool,[String],[String]) +layoutPragmas cf = let ps = pragmasOfCF cf in ( + not (null [() | LayoutTop <- ps]), -- if there's layout betw top-level + concat [ss | Layout ss <- ps], -- layout-block starting words + concat [ss | LayoutStop ss <- ps] -- layout-block ending words + ) + +derivations :: CF -> [String] +derivations cf = case concat [ss|Derive ss <- pragmasOfCF cf] of + [] -> ["Show", "Eq", "Ord"] + x -> x + + +hasLayout :: CF -> Bool +hasLayout cf = case layoutPragmas cf of + (t,ws,_) -> t || not (null ws) -- (True,[],_) means: top-level layout only + +hasAq :: CF -> Bool +hasAq cf = case [(b,a) | AntiQuote b i a <- pragmasOfCF cf] of + [] -> False + _ -> True + +aqSyntax :: CF -> Maybe (String,String,String) +aqSyntax cf = case [(b,i,a) | AntiQuote b i a <- pragmasOfCF cf] of + [] -> Nothing + [t] -> Just t + many -> error "aqSyntax: Multiple antiquote pragmas" +{- +resolveAq cf@((ps,(i,t,y,z)),rs0) = maybe cf addAqRules $ aqSyntax cf where + addAqRules (b,a) = ((map renamePragma ps,(newi,nub $ "[":"]":t,y,(map rename z))),rs) where + rs = map renameRule (rulesOfCF cf) ++ newRules ++ concat (map newType + newi = nub $ "String":i + newRules = map mkNewRule $ filter isNormal $ allCats cf + mkNewRule s = (renameAq s,(rename s,map Right b ++ [Left $ "String"] ++ map Right a)) + renameRule (fun,(cat,itms)) = (rename fun,(rename cat, map renameItem itms)) + renameItem = either (Left . rename) (Right . id) + + renamePragma p = case p of + EntryPoints cs -> EntryPoints $ map rename cs + _ -> p + newType s = [ + (rename s,(rename s,[Left $ s])), + (s++"__AQ",(rename s,map Right b ++ [Left $ "String"] ++ map Right a)) + ] +-} + +rename s = case s of + "_" -> s + "$" -> s + "#" -> s + "(:)" -> s + "(:[])" -> s + "[]" -> s + ('$':s) -> "AQ___" ++ s + ('[':l) -> '[' : rename (init l) ++ "]" + _ -> "AQ_" ++ normCat s ++ number s + +renameAqt s = case s of + ('[':l) -> '[' : renameAqt (init l) ++ "]" + _ -> "AQ___" ++ normCat s ++ number s + +renameAq s = case s of + ('[':l) -> '[' : renameAq (init l) ++ "]" + _ -> "AQ__" ++ normCat s ++ number s + +number = reverse . takeWhile isDigit . reverse + +unAq s = case s of + 'A':'Q':'_':r -> Just r + _ -> Nothing + +unAqs s = case s of + 'A':'Q':'_':'_':'_':r -> Just r + 'A':'Q':'_':'_':r -> Just r + _ -> Nothing + +-- Literal: Char, String, Ident, Integer, Double +type Literal = Cat +type Symbol = String +type KeyWord = String + +-- Cat is the Non-terminals of the grammar. +type Cat = String +-- Fun is the function name of a rule. +type Fun = String + +internalCat :: Cat +internalCat = "#" + +-- Abstract syntax tree. +newtype Tree = Tree (Fun,[Tree]) + +-- The abstract syntax of a grammar. +type Data = (Cat, [(Fun,Either [Cat] String)]) + +-- firstCat returns the first Category appearing in the grammar. +firstCat :: CF -> Cat +firstCat = valCat . head . rulesOfCF + +firstEntry :: CF -> Cat +firstEntry cf = case allEntryPoints cf of + (x:_) -> x + _ -> firstCat cf + + + +notUniqueFuns :: CF -> [Fun] +notUniqueFuns cf = let xss = group $ sort [ f | (f,_) <- rulesOfCF cf, + not (isNilCons f || isCoercion f)] + in [ head xs | xs <- xss, length xs > 1] + +badInheritence :: CF -> [Cat] +badInheritence cf = concatMap checkGroup (ruleGroups cf) + where + checkGroup (cat, rs) = if (length rs <= 1) + then [] + else case lookup cat rs of + Nothing -> [] + Just x -> [cat] + + + +-- extract the comment pragmas. +commentPragmas :: [Pragma] -> [Pragma] +commentPragmas = filter isComment + where isComment (CommentS _) = True + isComment (CommentM _) = True + isComment _ = False + +-- returns all normal rules that constructs the given Cat. +rulesForCat :: CF -> Cat -> [Rule] +rulesForCat cf cat = [normRuleFun r | r <- rulesOfCF cf, isParsable r, valCat r == cat] + +--This version doesn't exclude internal rules. +rulesForCat' :: CF -> Cat -> [Rule] +rulesForCat' cf cat = [normRuleFun r | r <- rulesOfCF cf, valCat r == cat] + +valCat :: Rul f -> Cat +valCat = fst . snd + +-- Get all categories of a grammar. +allCats :: CF -> [Cat] +allCats = nub . map valCat . rulesOfCF -- no cats w/o production + +-- Gets all normalized identified Categories +allCatsIdNorm :: CF -> [Cat] +allCatsIdNorm = nub . map identCat . map normCat . allCats + +-- category is used on an rhs +isUsedCat :: CF -> Cat -> Bool +isUsedCat cf cat = elem cat [c | r <- (rulesOfCF cf), Left c <- oldRHS (rhsRule r)] + +-- entry points to parser ---- +allEntryPoints :: CF -> [Cat] +allEntryPoints cf = case concat [cats | EntryPoints cats <- pragmasOfCF cf] of + [] -> allCats cf + cs -> cs + +-- group all categories with their rules. +ruleGroups :: CF -> [(Cat,[Rule])] +ruleGroups cf = [(c, rulesForCat cf c) | c <- allCats cf] + +-- group all categories with their rules including internal rules. +ruleGroupsInternals :: CF -> [(Cat,[Rule])] +ruleGroupsInternals cf = [(c, rulesForCat' cf c) | c <- allCats cf] + +typed_literals :: CF -> [(Fun,Cat)] +typed_literals cf = map (\x -> (x,x)) lits ++ owns + where + (lits,_,_,_) = infoOfCF cf + owns = map (\(x,_) -> (x,x)) (tokenPragmas cf) -- ++ rulets + rulets = [(fun,c) | (fun,(c,Right reg)) <- rulesOfCF cf] + +literals :: CF -> [Cat] +literals cf = lits ++ owns + where + (lits,_,_,_) = infoOfCF cf + owns = map fst $ tokenPragmas cf ++ ruleTokens cf + +symbols :: CFG f -> [String] +symbols cf = syms + where (_,syms,_,_) = infoOfCF cf + +reservedWords :: CFG f -> [String] +reservedWords cf = sort keywords + where (_,_,keywords,_) = infoOfCF cf + +reversibleCats :: CFG f -> [Cat] +reversibleCats cf = cats + where (_,_,_,cats) = infoOfCF cf + +-- Comments can be defined by the 'comment' pragma +comments :: CF -> ([(String,String)],[String]) +comments cf = case commentPragmas (pragmasOfCF cf) of + xs -> ([p | CommentM p <- xs], + [s | CommentS s <- xs]) + + + + +-- built-in categories (corresponds to lexer) + +-- if the gramamr uses the predefined Ident type +hasIdent :: CF -> Bool +hasIdent cf = isUsedCat cf "Ident" + +-- these need new datatypes +specialCats :: CF -> [Cat] +specialCats cf = (if hasIdent cf then ("Ident":) else id) (map fst (tokenPragmas cf)) + +-- the parser needs these +specialCatsP :: [Cat] +specialCatsP = words "Ident Integer String Char Double" + +-- to print parse trees +prTree :: Tree -> String +prTree (Tree (fun,[])) = fun +prTree (Tree (fun,trees)) = fun +++ unwords (map pr2 trees) where + pr2 t@(Tree (_,ts)) = (if (null ts) then id else prParenth) (prTree t) + +-- abstract syntax trees: data type definitions + +cf2data :: CF -> [Data] +cf2data cf = + [(cat, nub (map mkData [r | r@(f,_) <- rulesOfCF cf, + not (isDefinedRule f), + not (isCoercion f), eqCat cat (valCat r), + not (isAqFun f)])) + | cat <- allNormalCats cf] + where + mkData :: Rule -> (Fun,Either [Cat] (String)) + mkData (f,(_,Left its)) = (normFun f,Left [normCat c | Left c <- its, c /= internalCat]) + mkData (f,(_,Right (r,tok))) = (normFun f,Right tok) + +{- +--This version includes lists in the returned data. +--Michael 4/03 +cf2dataLists :: CF -> [Data] +cf2dataLists cf = + [(cat, nub (map mkData [r | r@(f,_) <- rulesOfCF cf, + not (isDefinedRule f), + not (isCoercion f), eqCat cat (valCat r)])) + | cat <- (filter (\x -> not $ isDigit $ last x) (allCats cf))] + where + mkData (f,(_,its)) = (normFun f,[normCat c | Left c <- its, c /= internalCat]) +-} + +specialData :: CF -> [Data] +specialData cf = [(c,[(c,Left [arg c])]) | c <- specialCats cf] where + arg c = case c of + _ -> "String" + +allNormalCats :: CF -> [Cat] +allNormalCats = filter isNormal . allCats + +-- to deal with coercions + +-- the Haskell convention: the wildcard _ is not a constructor + +isCoercion :: Fun -> Bool +isCoercion = (== "_") + +isDefinedRule :: Fun -> Bool +isDefinedRule (x:_) = isLower x + +isProperLabel :: Fun -> Bool +isProperLabel f = not (isCoercion f || isDefinedRule f) + +-- categories C1, C2,... (one digit in end) are variants of C + +eqCat :: Cat -> Cat -> Bool +eqCat c c1 = catCat c == catCat c1 + +normCat :: Cat -> Cat +normCat c = case c of + '[':cs -> "[" ++ norm (init cs) ++ "]" + _ -> unList $ norm c -- to be deprecated + where + norm = reverse . dropWhile isDigit . reverse + +normCatOfList :: Cat -> Cat +normCatOfList = normCat . catOfList + +-- for Happy and Latex +-- When given a list Cat, i.e. '[C]', it removes the square brackets, +-- and adds the prefix List, i.e. 'ListC'. +identCat :: Cat -> Cat +identCat c = case c of + '[':cs -> "List" ++ identCat (init cs) + _ -> c + +normFun :: Fun -> Fun +normFun = id -- takeWhile (not . isDigit) + +normRuleFun :: Rule -> Rule +normRuleFun (f,p) = (normFun f, p) + +isNormal :: Cat -> Bool +isNormal c = not (isList c || isDigit (last c) || isAqFun c) + +isParsable :: Rul f -> Bool +isParsable (_,(_, Left (Left "#":_))) = False +isParsable (_,(_, Left (Left "$":_))) = False +isParsable _ = True + +isList :: Cat -> Bool +isList c = head c == '[' + +unList :: Cat -> Cat +unList c = c + +catOfList :: Cat -> Cat +catOfList c = case c of + '[':_:_ -> init (tail c) + _ -> c + +isNilFun, isOneFun, isConsFun, isNilCons, isAqFun :: Fun -> Bool +isNilCons f = isNilFun f || isOneFun f || isConsFun f +isNilFun f = f == "[]" +isOneFun f = f == "(:[])" +isConsFun f = f == "(:)" + +isEmptyListCat :: CF -> Cat -> Bool +isEmptyListCat cf c = elem "[]" $ map fst $ rulesForCat' cf c + +isNonterm = either (const True) (const False) + +isAqFun ('$':_) = True +isAqFun _ = False + +-- used in Happy to parse lists of form 'C t [C]' in reverse order +-- applies only if the [] rule has no terminals +revSepListRule :: Rul f -> Rul f +revSepListRule r@(f,(c, Left ts)) = (f, (c, Left $ xs : x : sep)) where + (x,sep,xs) = (head ts, init (tail ts), last ts) +revSepListRule x = x +-- invariant: test in findAllReversibleCats have been performed + +findAllReversibleCats :: CF -> [Cat] +findAllReversibleCats cf = [c | (c,r) <- ruleGroups cf, isRev c r] where + isRev c rs = case rs of + [r1,r2] | isList c -> if isConsFun (funRule r2) + then tryRev r2 r1 + else if isConsFun (funRule r1) + then tryRev r1 r2 + else False + _ -> False + tryRev :: Rule -> Rule -> Bool + tryRev (f,(_,Left (ts@(x:_:xs)))) r = isEmptyNilRule r && + isConsFun f && isNonterm x && isNonterm (last ts) + tryRev _ _ = False + +isEmptyNilRule (f,(_,Left ts)) = isNilFun f && null ts +isEmptyNilRule _ = False + +precCat :: Cat -> Int +precCat = snd . analyseCat + +precRule :: Rule -> Int +precRule = precCat . valCat + +precLevels :: CF -> [Int] +precLevels cf = sort $ nub $ [ precCat c | c <- allCats cf] + +precCF :: CF -> Bool +precCF cf = length (precLevels cf) > 1 + +catCat :: Cat -> Cat +catCat = fst . analyseCat + +analyseCat :: Cat -> (Cat,Int) +analyseCat c = if (isList c) then list c else noList c + where + list cat = let (rc,n) = noList (init (tail cat)) in ("[" ++ rc ++ "]",n) + noList cat = case span isDigit (reverse cat) of + ([],c') -> (reverse c', 0) + (d,c') -> (reverse c', read (reverse d)) + +-- we should actually check that +-- (1) coercions are always between variants +-- (2) no other digits are used + +checkRule :: CF -> Rule -> Either Rule String +checkRule cf r@(f,(cat,rhs)) + | badCoercion = Right $ "Bad coercion in rule" +++ s + | badNil = Right $ "Bad empty list rule" +++ s + | badOne = Right $ "Bad one-element list rule" +++ s + | badCons = Right $ "Bad list construction rule" +++ s + | badList = Right $ "Bad list formation rule" +++ s + | badSpecial = Right $ "Bad special category rule" +++ s + | badTypeName = Right $ "Bad type name" +++ unwords badtypes +++ "in" +++ s + | badFunName = Right $ "Bad constructor name" +++ f +++ "in" +++ s + | badMissing = Right $ "No production for" +++ unwords missing ++ + ", appearing in rule" +++ s + | otherwise = Left r + where + s = f ++ "." +++ cat +++ "::=" +++ unwords (map (either id show) $ transRHS rhs) --- + c = normCat cat + cs = [normCat c | Left c <- transRHS rhs] + badCoercion = isCoercion f && not ([c] == cs) + badNil = isNilFun f && not (isList c && null cs) + badOne = isOneFun f && not (isList c && cs == [catOfList c]) + badCons = isConsFun f && not (isList c && cs == [catOfList c, c]) + badList = isList c && + not (isCoercion f || isNilFun f || isOneFun f || isConsFun f || isAqFun f) + badSpecial = elem c specialCatsP && not (isCoercion f) + + badMissing = not (null missing) + missing = filter nodef [c | Left c <- transRHS rhs] + nodef t = notElem t defineds + defineds = + "#" : map fst (tokenPragmas cf) ++ specialCatsP ++ map valCat (rulesOfCF cf) + badTypeName = not (null badtypes) + badtypes = filter isBadType $ cat : [c | Left c <- transRHS rhs] + isBadType c = not (isUpper (head c) || isList c || c == "#") + badFunName = not (all (\c -> isAlphaNum c || c == '_') f {-isUpper (head f)-} + || isCoercion f || isNilFun f || isOneFun f || isConsFun f || isAqFun f) + transRHS :: RHS -> [Either Cat String] + transRHS = either id (const []) + +isPositionCat :: CFG f -> Cat -> Bool +isPositionCat cf cat = or [b | TokenReg name b _ <- pragmasOfCF cf, name == cat] + + +visibleNames :: CF -> [String] +visibleNames cf = "myLexer":"tokens":map ('p':) eps ++ map ('q':) eps ++ map initLower eps where + eps = quoters cf + +quoterName :: String -> String +quoterName = initLower -- FIXME: List cats + +quoters :: CF -> [String] +quoters = map identCat . allEntryPoints -- FIXME: List cats + +initLower :: String -> String +initLower [] = error "initLower : Empty list" +initLower (c:cs) = toLower c : cs diff --git a/Language/LBNF/CFtoAbstract.hs b/Language/LBNF/CFtoAbstract.hs --- a/Language/LBNF/CFtoAbstract.hs +++ b/Language/LBNF/CFtoAbstract.hs @@ -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 [] diff --git a/Language/LBNF/CFtoAlex2.hs b/Language/LBNF/CFtoAlex2.hs --- a/Language/LBNF/CFtoAlex2.hs +++ b/Language/LBNF/CFtoAlex2.hs @@ -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" " ::= ^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 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" " ::= ^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 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"]]) + + diff --git a/Language/LBNF/CFtoHappy.hs b/Language/LBNF/CFtoHappy.hs --- a/Language/LBNF/CFtoHappy.hs +++ b/Language/LBNF/CFtoHappy.hs @@ -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 + + + diff --git a/Language/LBNF/CFtoLayout.hs b/Language/LBNF/CFtoLayout.hs --- a/Language/LBNF/CFtoLayout.hs +++ b/Language/LBNF/CFtoLayout.hs @@ -1,302 +1,302 @@ -{-#LANGUAGE TemplateHaskell#-} - -{- - BNF Converter: Layout handling Generator - Copyright (C) 2004 Author: Aarne Ranta - Copyright (C) 2005 Bjorn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - - - - - - - -module Language.LBNF.CFtoLayout(cf2Layout) where - -import Data.List (sort) -import Data.Maybe (isNothing, fromJust) -import Language.LBNF.CF hiding (rename) - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - --- TODO: avoid using SYB -import Data.Generics as SYB - --- Generic renaming function -rename :: SYB.Data a => [(Name,Name)] -> a -> a -rename table = everywhere (mkT step) - where - step :: Name -> Name - step x = maybe x id (lookup x table) - --- Dummy data types and functions -data Token = - Err Posn | - PT Posn Tok -data Tok = TS !String Int -data Posn = Pn Int Int Int - - - -layoutOpen' = "{" -layoutClose' = "}" -layoutSep' = ";" - -cf2Layout :: CF -> Q [Dec] -cf2Layout cf = - let - (top,lay,stop) = layoutPragmas cf - mkRename = rename $ zip - (id [''Token, 'Err, ''Posn, 'PT, ''Tok, 'TS, 'Pn ]) - (map mkName ["Token", "Err", "Posn", "PT", "Tok", "TS", "Pn"]) - in fmap mkRename [d| - --- Generated by the BNF Converter - --- local parameters - - topLayout = $(lift top) - layoutWords = $(lift lay) - layoutStopWords = $(lift stop) - - -- layout separators - - layoutOpen = $(lift layoutOpen') - layoutClose = $(lift layoutClose') - layoutSep = $(lift layoutSep') - - -- | Replace layout syntax with explicit layout tokens. - --resolveLayout :: Bool -- ^ Whether to use top-level layout. - -- -> [Token] -> [Token] - resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit] - where - -- Do top-level layout if the function parameter and the grammar say so. - tl = tp && topLayout - - --res :: Maybe Token -- ^ The previous token, if any. - -- -> [Block] -- ^ A stack of layout blocks. - -- -> [Token] -> [Token] - - -- The stack should never be empty. - res _ [] ts = error $ "Layout error: stack empty. Tokens: " ++ show ts - - res _ st (t0:ts) - -- We found an open brace in the input, - -- put an explicit layout block on the stack. - -- This is done even if there was no layout word, - -- to keep opening and closing braces. - | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts - - res _ st (t0:ts) - -- Start a new layout block if the first token is a layout word - | isLayout t0 = - case ts of - -- Explicit layout, just move on. The case above - -- will push an explicit layout block. - t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts - -- at end of file, the start column doesn't matter - _ -> let col = if null ts then column t0 else column (head ts) - -- insert an open brace after the layout word - b:ts' = addToken (nextPos t0) layoutOpen ts - -- save the start column - st' = Implicit col:st - in moveAlong st' [t0,b] ts' - - -- If we encounter a closing brace, exit the first explicit layout block. - | isLayoutClose t0 = - let st' = drop 1 (dropWhile isImplicit st) - in if null st' - then error $ "Layout error: Found " ++ layoutClose ++ " at (" - ++ show (line t0) ++ "," ++ show (column t0) - ++ ") without an explicit layout block." - else moveAlong st' [t0] ts - - -- We are in an implicit layout block - res pt st@(Implicit n:ns) (t0:ts) - - -- End of implicit block by a layout stop word - | isStop t0 = - -- Exit the current block and all implicit blocks - -- more indented than the current token - let (ebs,ns') = span (`moreIndent` column t0) ns - moreIndent (Implicit x) y = x > y - moreIndent Explicit _ = False - -- the number of blocks exited - b = 1 + length ebs - bs = replicate b layoutClose - -- Insert closing braces after the previous token. - (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts) - in moveAlong ns' ts1 ts2 - - -- End of an implicit layout block - | newLine && column t0 < n = - -- Insert a closing brace after the previous token. - let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts) - -- Repeat, with the current block removed from the stack - in moveAlong ns [b] (t0':ts') - - -- Encounted a new line in an implicit layout block. - | newLine && column t0 == n = - -- Insert a semicolon after the previous token. - -- unless we are the beginning of the file, - -- or the previous token is a semicolon or open brace. - if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt) - then moveAlong st [t0] ts - else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts) - in moveAlong st [b,t0'] ts' - where newLine = case pt of - Nothing -> True - Just t -> line t /= line t0 - - -- Nothing to see here, move along. - res _ st (t:ts) = moveAlong st [t] ts - - -- At EOF: skip explicit blocks. - res (Just t) (Explicit:bs) [] | null bs = [] - | otherwise = res (Just t) bs [] - - -- If we are using top-level layout, insert a semicolon after - -- the last token, if there isn't one already - res (Just t) [Implicit n] [] - | isTokenIn [layoutSep] t = [] - | otherwise = addToken (nextPos t) layoutSep [] - - -- At EOF in an implicit, non-top-level block: close the block - res (Just t) (Implicit n:bs) [] = - let c = addToken (nextPos t) layoutClose [] - in moveAlong bs c [] - - -- This should only happen if the input is empty. - res Nothing st [] = [] - - -- | Move on to the next token. - --moveAlong :: [Block] -- ^ The layout stack. - -- -> [Token] -- ^ Any tokens just processed. - -- -> [Token] -- ^ the rest of the tokens. - -- -> [Token] - moveAlong st [] ts = error $ "Layout error: moveAlong got [] as old tokens" - moveAlong st ot ts = ot ++ res (Just $ last ot) st ts - - data Block = Implicit Int -- ^ An implicit layout block with its start column. - | Explicit - deriving Show - - type Position = Posn - - -- | Check if s block is implicit. - isImplicit :: Block -> Bool - isImplicit (Implicit _) = True - isImplicit _ = False - - -- | Insert a number of tokens at the begninning of a list of tokens. - addTokens :: Position -- ^ Position of the first new token. - -> [String] -- ^ Token symbols. - -> [Token] -- ^ The rest of the tokens. These will have their - -- positions updated to make room for the new tokens . - -> [Token] - addTokens p ss ts = foldr (addToken p) ts ss - - -- | Insert a new symbol token at the begninning of a list of tokens. - addToken :: Position -- ^ Position of the new token. - -> String -- ^ Symbol in the new token. - -> [Token] -- ^ The rest of the tokens. These will have their - -- positions updated to make room for the new token.", " -> [Token] - -> [Token] - addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts - - -- | Get the position immediately to the right of the given token. - -- If no token is given, gets the first position in the file. - -- afterPrev :: Maybe Token -> Position - afterPrev = maybe (Pn 0 1 1) nextPos - - -- | Get the position immediately to the right of the given token. - -- nextPos :: Token -> Position - nextPos t = Pn (g + s) l (c + s + 1) - where Pn g l c = position t - s = tokenLength t - - -- | Add to the global and column positions of a token. - -- The column position is only changed if the token is on - -- the same line as the given position. - -- incrGlobal :: Position -- ^ If the token is on the same line - -- -- as this position, update the column position. - -- -> Int -- ^ Number of characters to add to the position. - -- -> Token -> Token - incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) = - if l /= l0 then PT (Pn (g + i) l c) t - else PT (Pn (g + i) l (c + i)) t - incrGlobal _ _ p = error $ "cannot add token at " ++ show p - - -- | Create a symbol token. - - reservedwords = $(lift $ zip resws ([1..] :: [Int])) - - sToken :: Position -> String -> Token - sToken p s = PT p (TS s i) - where i = maybe (error $ "not a reserved word: " ++ show s) id (lookup s reservedwords) - -- where - -- i = case s of - -- [ " " ++ show s ++ " -> " ++ show i - -- | (s, i) <- - -- ] ++ - -- _ -> error $ "not a reserved word: " ++ show s - - -- | Get the position of a token. - -- position :: Token -> Position - position t = case t of - PT p _ -> p - Err p -> p - - -- | Get the line number of a token. - -- line :: Token -> Int - line t = case position t of Pn _ l _ -> l - - -- | Get the column number of a token. - -- column :: Token -> Int - column t = case position t of Pn _ _ c -> c - - -- | Check if a token is one of the given symbols. - -- isTokenIn :: [String] -> Token -> Bool - isTokenIn ts t = case t of - PT _ (TS r _) | elem r ts -> True - _ -> False - - -- | Check if a word is a layout start token. - -- isLayout :: Token -> Bool - isLayout = isTokenIn layoutWords - - -- | Check if a token is a layout stop token. - -- isStop :: Token -> Bool - isStop = isTokenIn layoutStopWords - - -- | Check if a token is the layout open token. - -- isLayoutOpen :: Token -> Bool - isLayoutOpen = isTokenIn [layoutOpen] - - -- | Check if a token is the layout close token. - -- isLayoutClose :: Token -> Bool - isLayoutClose = isTokenIn [layoutClose] - - -- | Get the number of characters in the token. - -- tokenLength :: Token -> Int - tokenLength t = length $ $(varE $ mkName "prToken") t - |] - - where - resws = sort (reservedWords cf ++ symbols cf) +{-#LANGUAGE TemplateHaskell#-} + +{- + BNF Converter: Layout handling Generator + Copyright (C) 2004 Author: Aarne Ranta + Copyright (C) 2005 Bjorn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + + + + + + + +module Language.LBNF.CFtoLayout(cf2Layout) where + +import Data.List (sort) +import Data.Maybe (isNothing, fromJust) +import Language.LBNF.CF hiding (rename) + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +-- TODO: avoid using SYB +import Data.Generics as SYB + +-- Generic renaming function +rename :: SYB.Data a => [(Name,Name)] -> a -> a +rename table = everywhere (mkT step) + where + step :: Name -> Name + step x = maybe x id (lookup x table) + +-- Dummy data types and functions +data Token = + Err Posn | + PT Posn Tok +data Tok = TS !String Int +data Posn = Pn Int Int Int + +data Block = Implicit Int + | Explicit + +layoutOpen' = "{" +layoutClose' = "}" +layoutSep' = ";" + +cf2Layout :: CF -> Q [Dec] +cf2Layout cf = + let + (top,lay,stop) = layoutPragmas cf + mkRename = rename $ zip + (id [''Token, 'Err, ''Posn, 'PT, ''Tok, 'TS, 'Pn, ''Block, 'Implicit, 'Explicit]) + (map mkName ["Token", "Err", "Posn", "PT", "Tok", "TS", "Pn", "Block", "Implicit","Explicit"]) + in fmap mkRename $ + fmap (DataD [] (mkName "Block") [] [NormalC (mkName "Implicit") [(NotStrict,ConT ''Int)], + NormalC (mkName "Explicit") []] [''Show]:) + [d| + +-- Generated by the BNF Converter + +-- local parameters + + topLayout = $(lift top) + layoutWords = $(lift lay) + layoutStopWords = $(lift stop) + + -- layout separators + + layoutOpen = $(lift layoutOpen') + layoutClose = $(lift layoutClose') + layoutSep = $(lift layoutSep') + + -- | Replace layout syntax with explicit layout tokens. + --resolveLayout :: Bool -- ^ Whether to use top-level layout. + -- -> [Token] -> [Token] + resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit] + where + -- Do top-level layout if the function parameter and the grammar say so. + tl = tp && topLayout + + --res :: Maybe Token -- ^ The previous token, if any. + -- -> [Block] -- ^ A stack of layout blocks. + -- -> [Token] -> [Token] + + -- The stack should never be empty. + res _ [] ts = error $ "Layout error: stack empty. Tokens: " ++ show ts + + res _ st (t0:ts) + -- We found an open brace in the input, + -- put an explicit layout block on the stack. + -- This is done even if there was no layout word, + -- to keep opening and closing braces. + | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts + + res _ st (t0:ts) + -- Start a new layout block if the first token is a layout word + | isLayout t0 = + case ts of + -- Explicit layout, just move on. The case above + -- will push an explicit layout block. + t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts + -- at end of file, the start column doesn't matter + _ -> let col = if null ts then column t0 else column (head ts) + -- insert an open brace after the layout word + b:ts' = addToken (nextPos t0) layoutOpen ts + -- save the start column + st' = Implicit col:st + in moveAlong st' [t0,b] ts' + + -- If we encounter a closing brace, exit the first explicit layout block. + | isLayoutClose t0 = + let st' = drop 1 (dropWhile isImplicit st) + in if null st' + then error $ "Layout error: Found " ++ layoutClose ++ " at (" + ++ show (line t0) ++ "," ++ show (column t0) + ++ ") without an explicit layout block." + else moveAlong st' [t0] ts + + -- We are in an implicit layout block + res pt st@(Implicit n:ns) (t0:ts) + + -- End of implicit block by a layout stop word + | isStop t0 = + -- Exit the current block and all implicit blocks + -- more indented than the current token + let (ebs,ns') = span (`moreIndent` column t0) ns + moreIndent (Implicit x) y = x > y + moreIndent Explicit _ = False + -- the number of blocks exited + b = 1 + length ebs + bs = replicate b layoutClose + -- Insert closing braces after the previous token. + (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts) + in moveAlong ns' ts1 ts2 + + -- End of an implicit layout block + | newLine && column t0 < n = + -- Insert a closing brace after the previous token. + let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts) + -- Repeat, with the current block removed from the stack + in moveAlong ns [b] (t0':ts') + + -- Encounted a new line in an implicit layout block. + | newLine && column t0 == n = + -- Insert a semicolon after the previous token. + -- unless we are the beginning of the file, + -- or the previous token is a semicolon or open brace. + if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt) + then moveAlong st [t0] ts + else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts) + in moveAlong st [b,t0'] ts' + where newLine = case pt of + Nothing -> True + Just t -> line t /= line t0 + + -- Nothing to see here, move along. + res _ st (t:ts) = moveAlong st [t] ts + + -- At EOF: skip explicit blocks. + res (Just t) (Explicit:bs) [] | null bs = [] + | otherwise = res (Just t) bs [] + + -- If we are using top-level layout, insert a semicolon after + -- the last token, if there isn't one already + res (Just t) [Implicit n] [] + | isTokenIn [layoutSep] t = [] + | otherwise = addToken (nextPos t) layoutSep [] + + -- At EOF in an implicit, non-top-level block: close the block + res (Just t) (Implicit n:bs) [] = + let c = addToken (nextPos t) layoutClose [] + in moveAlong bs c [] + + -- This should only happen if the input is empty. + res Nothing st [] = [] + + -- | Move on to the next token. + --moveAlong :: [Block] -- ^ The layout stack. + -- -> [Token] -- ^ Any tokens just processed. + -- -> [Token] -- ^ the rest of the tokens. + -- -> [Token] + moveAlong st [] ts = error $ "Layout error: moveAlong got [] as old tokens" + moveAlong st ot ts = ot ++ res (Just $ last ot) st ts + + type Position = Posn + + -- | Check if s block is implicit. + isImplicit :: Block -> Bool + isImplicit (Implicit _) = True + isImplicit _ = False + + -- | Insert a number of tokens at the begninning of a list of tokens. + addTokens :: Position -- ^ Position of the first new token. + -> [String] -- ^ Token symbols. + -> [Token] -- ^ The rest of the tokens. These will have their + -- positions updated to make room for the new tokens . + -> [Token] + addTokens p ss ts = foldr (addToken p) ts ss + + -- | Insert a new symbol token at the begninning of a list of tokens. + addToken :: Position -- ^ Position of the new token. + -> String -- ^ Symbol in the new token. + -> [Token] -- ^ The rest of the tokens. These will have their + -- positions updated to make room for the new token.", " -> [Token] + -> [Token] + addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts + + -- | Get the position immediately to the right of the given token. + -- If no token is given, gets the first position in the file. + -- afterPrev :: Maybe Token -> Position + afterPrev = maybe (Pn 0 1 1) nextPos + + -- | Get the position immediately to the right of the given token. + -- nextPos :: Token -> Position + nextPos t = Pn (g + s) l (c + s + 1) + where Pn g l c = position t + s = tokenLength t + + -- | Add to the global and column positions of a token. + -- The column position is only changed if the token is on + -- the same line as the given position. + -- incrGlobal :: Position -- ^ If the token is on the same line + -- -- as this position, update the column position. + -- -> Int -- ^ Number of characters to add to the position. + -- -> Token -> Token + incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) = + if l /= l0 then PT (Pn (g + i) l c) t + else PT (Pn (g + i) l (c + i)) t + incrGlobal _ _ p = error $ "cannot add token at " ++ show p + + -- | Create a symbol token. + + reservedwords = $(lift $ zip resws ([1..] :: [Int])) + + sToken :: Position -> String -> Token + sToken p s = PT p (TS s i) + where i = maybe (error $ "not a reserved word: " ++ show s) id (lookup s reservedwords) + -- where + -- i = case s of + -- [ " " ++ show s ++ " -> " ++ show i + -- | (s, i) <- + -- ] ++ + -- _ -> error $ "not a reserved word: " ++ show s + + -- | Get the position of a token. + -- position :: Token -> Position + position t = case t of + PT p _ -> p + Err p -> p + + -- | Get the line number of a token. + -- line :: Token -> Int + line t = case position t of Pn _ l _ -> l + + -- | Get the column number of a token. + -- column :: Token -> Int + column t = case position t of Pn _ _ c -> c + + -- | Check if a token is one of the given symbols. + -- isTokenIn :: [String] -> Token -> Bool + isTokenIn ts t = case t of + PT _ (TS r _) | elem r ts -> True + _ -> False + + -- | Check if a word is a layout start token. + -- isLayout :: Token -> Bool + isLayout = isTokenIn layoutWords + + -- | Check if a token is a layout stop token. + -- isStop :: Token -> Bool + isStop = isTokenIn layoutStopWords + + -- | Check if a token is the layout open token. + -- isLayoutOpen :: Token -> Bool + isLayoutOpen = isTokenIn [layoutOpen] + + -- | Check if a token is the layout close token. + -- isLayoutClose :: Token -> Bool + isLayoutClose = isTokenIn [layoutClose] + + -- | Get the number of characters in the token. + -- tokenLength :: Token -> Int + tokenLength t = length $ $(varE $ mkName "prToken") t + |] + + where + resws = sort (reservedWords cf ++ symbols cf) diff --git a/Language/LBNF/CFtoPrinter.hs b/Language/LBNF/CFtoPrinter.hs --- a/Language/LBNF/CFtoPrinter.hs +++ b/Language/LBNF/CFtoPrinter.hs @@ -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) +-} diff --git a/Language/LBNF/CFtoQQ.hs b/Language/LBNF/CFtoQQ.hs --- a/Language/LBNF/CFtoQQ.hs +++ b/Language/LBNF/CFtoQQ.hs @@ -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" + + diff --git a/Language/LBNF/GetCF.hs b/Language/LBNF/GetCF.hs --- a/Language/LBNF/GetCF.hs +++ b/Language/LBNF/GetCF.hs @@ -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 "[]" [] + + + diff --git a/Language/LBNF/Runtime.hs b/Language/LBNF/Runtime.hs --- a/Language/LBNF/Runtime.hs +++ b/Language/LBNF/Runtime.hs @@ -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 (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 (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 diff --git a/Language/LBNF/TypeChecker.hs b/Language/LBNF/TypeChecker.hs --- a/Language/LBNF/TypeChecker.hs +++ b/Language/LBNF/TypeChecker.hs @@ -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 ++ "." + diff --git a/Language/LBNF/Utils.hs b/Language/LBNF/Utils.hs --- a/Language/LBNF/Utils.hs +++ b/Language/LBNF/Utils.hs @@ -1,112 +1,112 @@ -{- - BNF Converter: Abstract syntax - Copyright (C) 2004 Author: Aarne Ranta - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module Language.LBNF.Utils where - -import Control.Monad (unless) - -infixr 5 +++ -infixr 5 ++++ -infixr 5 +++++ -infixr 2 ||| -infixr 5 ... -infixr 3 *** - - --- printing operations - -a +++ b = a ++ " " ++ b -a ++++ b = a ++ "\n" ++ b -a +++++ b = a ++ "\n\n" ++ b - -prParenth s = if s == "" then "" else "(" ++ s ++ ")" - - --- parser combinators a` la Wadler and Hutton - -type Parser a b = [a] -> [(b,[a])] - -(...) :: Parser a b -> Parser a c -> Parser a (b,c) -(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t] - -(|||) :: Parser a b -> Parser a b -> Parser a b -(p ||| q) s = p s ++ q s - -lit :: (Eq a) => a -> Parser a a -lit x (c:cs) = [(x,cs) | x == c] -lit _ _ = [] - -(***) :: Parser a b -> (b -> c) -> Parser a c -(p *** f) s = [(f x,r) | (x,r) <- p s] - -succeed :: b -> Parser a b -succeed v s = [(v,s)] - -fails :: Parser a b -fails s = [] - --- to get parse results - -parseResults :: Parser a b -> [a] -> [b] -parseResults p s = [x | (x,r) <- p s, null r] - - --- * List utilities - --- | Replace all occurences of a value by another value -replace :: Eq a => - a -- ^ Value to replace - -> a -- ^ Value to replace it with - -> [a] -> [a] -replace x y xs = [ if z == x then y else z | z <- xs] - --- | Split a list on the first occurence of a value. --- Does not include the value that was split on in either --- of the returned lists. -split :: Eq a => a -> [a] -> ([a],[a]) -split x xs = let (ys, zs) = break (==x) xs - in (ys, drop 1 zs) - --- | Split a list on every occurence of a value. --- If the value does not occur in the list, --- the result is the singleton list containing the input list. --- Thus the returned list is never the empty list. -splitAll :: Eq a => a -> [a] -> [[a]] -splitAll _ [] = [[]] -splitAll x xs = let (ys, zs) = break (==x) xs - in ys : case zs of - [] -> [] - _:zs' -> splitAll x zs' - - -pathSep :: Char -pathSep = '/' - --- | Like the prelude function 'inits' but for path names. --- For example: --- > pathInits "foo/bar" = ["foo","foo/bar"] --- > pathInits "foo/bar/baz.hs" = ["foo","foo/bar","foo/bar/baz.hs"] -pathInits :: String -> [String] -pathInits "" = [] -pathInits xs = let (ys,zs) = split pathSep xs - in ys : map ((ys ++ [pathSep]) ++) (pathInits zs) - --- | Like basename(1), remove all leading directories from a path name. -basename :: String -> String +{- + BNF Converter: Abstract syntax + Copyright (C) 2004 Author: Aarne Ranta + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Language.LBNF.Utils where + +import Control.Monad (unless) + +infixr 5 +++ +infixr 5 ++++ +infixr 5 +++++ +infixr 2 ||| +infixr 5 ... +infixr 3 *** + + +-- printing operations + +a +++ b = a ++ " " ++ b +a ++++ b = a ++ "\n" ++ b +a +++++ b = a ++ "\n\n" ++ b + +prParenth s = if s == "" then "" else "(" ++ s ++ ")" + + +-- parser combinators a` la Wadler and Hutton + +type Parser a b = [a] -> [(b,[a])] + +(...) :: Parser a b -> Parser a c -> Parser a (b,c) +(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t] + +(|||) :: Parser a b -> Parser a b -> Parser a b +(p ||| q) s = p s ++ q s + +lit :: (Eq a) => a -> Parser a a +lit x (c:cs) = [(x,cs) | x == c] +lit _ _ = [] + +(***) :: Parser a b -> (b -> c) -> Parser a c +(p *** f) s = [(f x,r) | (x,r) <- p s] + +succeed :: b -> Parser a b +succeed v s = [(v,s)] + +fails :: Parser a b +fails s = [] + +-- to get parse results + +parseResults :: Parser a b -> [a] -> [b] +parseResults p s = [x | (x,r) <- p s, null r] + + +-- * List utilities + +-- | Replace all occurences of a value by another value +replace :: Eq a => + a -- ^ Value to replace + -> a -- ^ Value to replace it with + -> [a] -> [a] +replace x y xs = [ if z == x then y else z | z <- xs] + +-- | Split a list on the first occurence of a value. +-- Does not include the value that was split on in either +-- of the returned lists. +split :: Eq a => a -> [a] -> ([a],[a]) +split x xs = let (ys, zs) = break (==x) xs + in (ys, drop 1 zs) + +-- | Split a list on every occurence of a value. +-- If the value does not occur in the list, +-- the result is the singleton list containing the input list. +-- Thus the returned list is never the empty list. +splitAll :: Eq a => a -> [a] -> [[a]] +splitAll _ [] = [[]] +splitAll x xs = let (ys, zs) = break (==x) xs + in ys : case zs of + [] -> [] + _:zs' -> splitAll x zs' + + +pathSep :: Char +pathSep = '/' + +-- | Like the prelude function 'inits' but for path names. +-- For example: +-- > pathInits "foo/bar" = ["foo","foo/bar"] +-- > pathInits "foo/bar/baz.hs" = ["foo","foo/bar","foo/bar/baz.hs"] +pathInits :: String -> [String] +pathInits "" = [] +pathInits xs = let (ys,zs) = split pathSep xs + in ys : map ((ys ++ [pathSep]) ++) (pathInits zs) + +-- | Like basename(1), remove all leading directories from a path name. +basename :: String -> String basename = last . splitAll pathSep diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,3 @@ -> import Distribution.Simple -> main :: IO () +> import Distribution.Simple +> main :: IO () > main = defaultMain diff --git a/examples/ghc6/jll/JavaletteLight.hs b/examples/ghc6/jll/JavaletteLight.hs --- a/examples/ghc6/jll/JavaletteLight.hs +++ b/examples/ghc6/jll/JavaletteLight.hs @@ -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 ; + |] + + diff --git a/examples/ghc6/jll/UseJll.hs b/examples/ghc6/jll/UseJll.hs --- a/examples/ghc6/jll/UseJll.hs +++ b/examples/ghc6/jll/UseJll.hs @@ -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|] diff --git a/examples/ghc7/jll/JavaletteLight.hs b/examples/ghc7/jll/JavaletteLight.hs --- a/examples/ghc7/jll/JavaletteLight.hs +++ b/examples/ghc7/jll/JavaletteLight.hs @@ -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 ; + |] + + diff --git a/examples/ghc7/jll/UseJll.hs b/examples/ghc7/jll/UseJll.hs --- a/examples/ghc7/jll/UseJll.hs +++ b/examples/ghc7/jll/UseJll.hs @@ -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|]