diff --git a/BNFC-meta.cabal b/BNFC-meta.cabal --- a/BNFC-meta.cabal +++ b/BNFC-meta.cabal @@ -1,36 +1,56 @@ -Name: BNFC-meta -version: 0.3.0.5 +Name: BNFC-meta +version: 0.6.1 cabal-Version: >= 1.6 build-type: Simple license: GPL-2 license-file: LICENSE -author: Jonas Duregård -maintainer: Jonas Duregård (jonas.duregard@chalmers.se) -category: Development -synopsis: Deriving Quasi-Quoters from BNF Grammars -description: This package provides a comfortable way of defining quasi-quoters. +author: Jonas Duregård +maintainer: Artem Pelenitsyn +category: Development, parsing, text, language +synopsis: Deriving Parsers and Quasi-Quoters from BNF Grammars +description: This package provides a very simple way of defining a compiler + front-end for a language by embedding a BNF grammar directly into a Haskell + source file. + Specifically, given a quasi-quoted LBNF grammar (as used by the BNF Converter) - it generates (using Template Haskell) an LALR parser and pretty pretty printer - for the language. The parser is then used to define a quasi-quoter. With a simple - pragma, the user can define a universal syntax for anti-quoting. This means that - any grammar non-terminal can be replaced by a quoted Haskell expression of the - appropriate type. A few examples are included in the source tarball. + it generates (using Template Haskell) a LALR parser and pretty pretty printer + for the language. The parser is then used to automatically define a + quasi-quoter for the defined language so it can also be seamlessly embedded + in Haskell source code. With a + simple addition to the gramwmar, the user can define a universal syntax for + anti-quoting. This + means that any grammar non-terminal can be replaced by a quoted Haskell + expression of the appropriate type. A few example languages are included in + the source tarball. + . + The LBNF grammar formalism is described thoroughly in the BNF Converter + documentation: + . + This library and the additions it makes to LBNF is described in a + 2011 Haskell Symposium paper titled \"Embedded Parser Generators\": + extra-source-files: - examples/ghc7/jll/JavaletteLight.hs - examples/ghc7/jll/UseJll.hs - examples/ghc6/jll/JavaletteLight.hs - examples/ghc6/jll/UseJll.hs + examples/jll/JavaletteLight.hs + examples/jll/UseJll.hs + examples/typesafe/Example.hs + examples/typesafe/Typesafe.hs Bootstrap/Bootstrap.hs +source-repository head + type: git + location: https://github.com/ulysses4ever/BNFC-meta + + Library Build-Depends: base>=4.2&&<5 - , array==0.4.* - , template-haskell >=2.4&&<2.9 + , array>=0.4&&<0.6 + , fail >=4.9&&<5 + , template-haskell >=2.12 && < 2.16 , haskell-src-meta >= 0.5 && < 1.0 , happy-meta >= 0.2.0.4 && < 0.3 - , alex-meta >= 0.3.0.3 && < 0.4 + , alex-meta >= 0.3.0.5 && < 0.4 , syb >= 0.2 && <1.0 Exposed-modules: Language.LBNF diff --git a/Bootstrap/Bootstrap.hs b/Bootstrap/Bootstrap.hs --- a/Bootstrap/Bootstrap.hs +++ b/Bootstrap/Bootstrap.hs @@ -25,13 +25,16 @@ import System.FilePath -package = "BNFC-meta-0.2.1" +-- This was required for some reason but I don't recall why /Jonas +package = "BNFC-meta-0.6" nfile = file ++ ".new.bak" file = ".." "Language" "LBNF" "Grammar.hs" bfile = file ++ ".bak" bbfile = bfile ++ ".bak" +-- Running this code will generate a new LBNF quasi-quoter file using +-- an existing installation of BNFC-meta. It's all very meta. main = do c <- getCode ("Language.LBNF.Grammar") g doesFileExist bfile >>= \b -> when b $ copyFile bfile bbfile 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 @@ -2,6 +2,7 @@ import Data.List(partition) import Language.Haskell.TH +-- Takes a list of declaration and puts them all in a where-clause, exporting only some of them by pattern-matching on a tuple. export :: [Name] -> [Dec] -> Q [Dec] export el = buildClause el . partition whereable where whereable :: Dec -> Bool @@ -19,7 +20,7 @@ (map return wh) return $ v : tl - +-- GHC has a limit on tuple size... splitTup :: ([a] -> a) -> [a] -> a splitTup tup ls = case splitAt 60 ls of (_,[]) -> tup ls diff --git a/Language/LBNF.hs b/Language/LBNF.hs --- a/Language/LBNF.hs +++ b/Language/LBNF.hs @@ -1,8 +1,16 @@ {-# OPTIONS_GHC -fno-warn-missing-fields #-} + +-- | Contains the main language definition routines of BNFC-meta. module Language.LBNF ( - lbnf -- QuasiQuoter for LBNF - , bnfc -- Parser meta-generator function - , dumpAlex, dumpHappy, dumpHappyM, dumpCode, getCode -- Debug / code generation + -- * Main language definition routines + lbnf + , bnfc + -- * Debugging functions + , dumpCode + , getCode + , dumpAlex + , dumpHappy +-- , dumpHappyM , module Language.LBNF.Compiletime -- , module Language.LBNF.Grammar ) where @@ -26,10 +34,16 @@ import Data.List(isPrefixOf, intersperse) - +-- | QuasiQuoter for LBNF. Usage: @[lbnf| \|]@ +-- +-- The spliced code is an expression of type 'Grammar'. lbnf :: QuasiQuoter lbnf = grammar +-- | Typical usage (as a top level declaration): @bnfc [lbnf|\|]@ +-- +-- The spliced code contains a parser, a pretty-printer and a Quasi-Quoter for +-- the language defined by the grammar. bnfc :: Grammar -> Q [Dec] bnfc = compile . toCF @@ -72,7 +86,8 @@ (filter isNormal (allCats cf)) ++ if hasIdent cf then ["Ident(..)"] else [] - +-- | Equivalent to 'bnfc' with the side-effect of dumping the parser +-- definition into a file named "dump.y" dumpHappy :: Grammar -> Q [Dec] dumpHappy g = location >>= \l -> dumpHappyM g (loc_module l, loc_package l) >> bnfc g @@ -82,17 +97,23 @@ runIO $ writeFile "dump.y" $ cf2Happy (Loc {loc_module = m, loc_package = p}) cf -- compile cf +-- | Equivalent to 'bnfc' with the side-effect of dumping the lexer +-- definition into a file named dump.x dumpAlex :: Grammar -> Q [Dec] dumpAlex g = do let cf = toCF g runIO $ writeFile "dump.x" $ cf2alex2 cf compile cf +-- | Equivalent to 'bnfc' with the side-effect of dumping ALL the spliced code +-- into a file named dump.hs dumpCode :: Grammar -> Q [Dec] dumpCode g = do runIO $ getCode ("Main") g >>= writeFile "dump.hs" bnfc g +-- | Computes the Haskell source code that would be spliced by a grammar and +-- wraps it into a compilable Haskell module. getCode :: String -> Grammar -> IO String getCode m g = do let cf = toCF g diff --git a/Language/LBNF/CFtoAbstract.hs b/Language/LBNF/CFtoAbstract.hs --- a/Language/LBNF/CFtoAbstract.hs +++ b/Language/LBNF/CFtoAbstract.hs @@ -24,37 +24,46 @@ import Language.LBNF.CF -absRules :: CF -> Q [Dec] -absRules cf0 = sequence $ - map (prData $ map mkName $ derivations cf0) $ cf2data cf0 +absRules :: CF -> Q [Dec] +absRules cf0 = sequence $ + map (prData $ mkDerivClause $ map mkName $ derivations cf0) $ cf2data cf0 + where + mkDerivClause :: [Name] -> [Q DerivClause] + mkDerivClause names = return $ return $ DerivClause Nothing (map ConT names) absTokens :: CF -> Q [Dec] absTokens cf0 = sequence $ - map (prSpecialData (map mkName $ derivations cf0) cf0) (specialCats cf0) - + map (prSpecialData (mkDerivClause $ map mkName $ derivations cf0) cf0) (specialCats cf0) + where + mkDerivClause :: [Name] -> [DerivClause] + mkDerivClause names = return $ DerivClause Nothing (map ConT names) fixname :: String -> TypeQ fixname ('[':xs) = appT listT $ conT $ mkName $ init xs fixname xs = conT $ mkName xs -prData :: [Name] -> Data -> Q Dec +prData :: [DerivClauseQ] -> Data -> Q Dec prData deriv (cat,rules) = - dataD (return []) (mkName cat) [] (map cons rules) deriv where + dataD (return []) (mkName cat) [] Nothing (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 +prSpecialData :: [DerivClause] -> CF -> Cat -> Q Dec +prSpecialData deriv cf cat = do + let con = normalC (mkName cat) $ [typ] + typ = strictType notStrict $ contentSpec cf cat + ctxt1 <- (return []) + con1 <- con + return (NewtypeD ctxt1 (mkName cat) [] Nothing con1 deriv) +-- got rid of newtypeD by replacing it with its definition in 2.10.0.0, and then +-- forcing the parameters of NewtypeD to match up with the new types in 2.12.0.0 contentSpec :: CF -> Cat -> Q Type diff --git a/Language/LBNF/CFtoHappy.hs b/Language/LBNF/CFtoHappy.hs --- a/Language/LBNF/CFtoHappy.hs +++ b/Language/LBNF/CFtoHappy.hs @@ -109,8 +109,6 @@ 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),"\'"] @@ -122,11 +120,7 @@ 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, @@ -140,9 +134,7 @@ 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 @@ -221,7 +213,7 @@ 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) + | isAqFun f = fun ++ " " ++ unwords (map (\(b,c,m) -> if b then "(reverse "++m++")" else m) ms) | isTokenRule rulz = fromToken ++ "\""++f++"\" $1" | otherwise = constr++" ["++ (concat $ intersperse "," [m1|(_,c,m1) <- ms]) @@ -237,14 +229,8 @@ "(:[])" -> 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 @@ -282,10 +268,7 @@ | 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)) @@ -308,13 +291,7 @@ -- 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 }" diff --git a/Language/LBNF/CFtoLayout.hs b/Language/LBNF/CFtoLayout.hs --- a/Language/LBNF/CFtoLayout.hs +++ b/Language/LBNF/CFtoLayout.hs @@ -67,63 +67,43 @@ (id [''Token, 'Err, ''Posn, 'PT, ''Tok, 'TS, 'Pn, ''Block, 'Implicit, 'Explicit]) (map mkName ["Token", "Err", "Posn", "PT", "Tok", "TS", "Pn", "Block", "Implicit","Explicit"]) in fmap mkRename $ - fmap (DataD [] (mkName "Block") [] [NormalC (mkName "Implicit") [(NotStrict,ConT ''Int)], - NormalC (mkName "Explicit") []] [''Show]:) - (makedecs top lay stop cf) + fmap (DataD [] (mkName "Block") [] Nothing [NormalC (mkName "Implicit") [(Bang NoSourceUnpackedness NoSourceStrictness ,ConT ''Int)], + NormalC (mkName "Explicit") []] + ([DerivClause Nothing [ConT ''Show]]) :) + (makedecs top lay stop (sort (reservedWords cf ++ symbols cf))) + +-- Hack to make haddock work +makedecs :: Bool -> [String] -> [String] -> [String] -> Q [Dec] +makedecs top lay stop resws = [d| --- | makedecs -makedecs :: Bool -> [String] -> [String] -> CF -> Q [Dec] -makedecs top lay stop cf = [d| topLayout = $(lift top) layoutWords = $(lift lay) layoutStopWords = $(lift stop) - -- layout separators - layoutOpen = $(lift layoutOpen') layoutClose = $(lift layoutClose') layoutSep = $(lift layoutSep') - -- | Replace layout syntax with explicit layout tokens. - --resolveLayout :: Bool -- ^ Whether to use top-level layout. - -- -> [Token] -> [Token] + resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit] where - -- Do top-level layout if the function parameter and the grammar say so. tl = tp && topLayout - - --res :: Maybe Token -- ^ The previous token, if any. - -- -> [Block] -- ^ A stack of layout blocks. - -- -> [Token] -> [Token] - - -- The stack should never be empty. res _ [] ts = error $ "Layout error: stack empty. Tokens: " ++ show ts res _ st (t0:ts) - -- We found an open brace in the input, - -- put an explicit layout block on the stack. - -- This is done even if there was no layout word, - -- to keep opening and closing braces. | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts res _ st (t0:ts) - -- Start a new layout block if the first token is a layout word | isLayout t0 = case ts of - -- Explicit layout, just move on. The case above - -- will push an explicit layout block. t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts - -- at end of file, the start column doesn't matter _ -> let col = if null ts then column t0 else column (head ts) - -- insert an open brace after the layout word b:ts' = addToken (nextPos t0) layoutOpen ts - -- save the start column st' = Implicit col:st in moveAlong st' [t0,b] ts' - -- If we encounter a closing brace, exit the first explicit layout block. | isLayoutClose t0 = let st' = drop 1 (dropWhile isImplicit st) in if null st' @@ -132,35 +112,22 @@ ++ ") 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) @@ -169,135 +136,83 @@ 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 . + + addTokens :: Position + -> [String] + -> [Token] -> [Token] addTokens p ss ts = foldr (addToken p) ts ss - - -- | Insert a new symbol token at the begninning of a list of tokens. - addToken :: Position -- ^ Position of the new token. - -> String -- ^ Symbol in the new token. - -> [Token] -- ^ The rest of the tokens. These will have their - -- positions updated to make room for the new token.", " -> [Token] + + addToken :: Position + -> String + -> [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])) + + reservedwords = $(resnum) 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) + where resnum = lift $ zip resws ([1..] :: [Int]) + diff --git a/Language/LBNF/Compiletime.hs b/Language/LBNF/Compiletime.hs --- a/Language/LBNF/Compiletime.hs +++ b/Language/LBNF/Compiletime.hs @@ -1,7 +1,10 @@ {-#LANGUAGE TemplateHaskell#-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} +-- | Contains things needed by BNFC-meta language definitions and +-- by the code generated from those. Typical users don't need to browse this +-- module. module Language.LBNF.Compiletime( - -- * Happy and Alex runtimes + -- * Happy and Alex HappyStk(..) , utf8Encode , Posn(Pn) @@ -11,7 +14,8 @@ , listArray , (!) , Array - -- * Pretty printing runtimes + + -- * Pretty printing , printTree , doc , concatD @@ -19,13 +23,17 @@ , prPrec , PrintPlain(..) - -- * Quasi quoting runtimes + -- * Quasi quoting , parseToQuoter, parseToMonQuoter , ParseMonad(..) , errq , Q , BNFC_QQType(..), appEPAll, appEPAllL, fromString, fromLit, fromToken, fromPositionToken , Lift (..) + , LocType + , Literal(..) + , IsChar(..) + -- ** Helper functions for defining Anti-quotation , printAq , stringAq diff --git a/Language/LBNF/Runtime.hs b/Language/LBNF/Runtime.hs --- a/Language/LBNF/Runtime.hs +++ b/Language/LBNF/Runtime.hs @@ -1,5 +1,6 @@ {-#LANGUAGE TemplateHaskell #-} - +-- | Contains things that are typically needed in modules that use +-- languages defined using BNFC-meta. module Language.LBNF.Runtime( -- * Happy and Alex runtimes -- ord @@ -7,28 +8,26 @@ -- , (!) -- , Array -- , parseToQuoter + ParseMonad(..) , err -- * Pretty printing runtimes , printTree + , Doc , 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 Control.Monad (MonadPlus(..), liftM, foldM, (>=>), ap) +import Control.Applicative ( Applicative(..) ) +import qualified Control.Monad.Fail as Fail import Data.Char @@ -38,23 +37,32 @@ -- Lexing, Parsing ------------------ +-- * The result of a parse. 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 Fail.MonadFail ParseMonad where + fail = Bad + instance Functor ParseMonad where fmap = liftM +instance Applicative ParseMonad where + (<*>) = ap + pure = return + --instance MonadPlus ParseMonad where -- mzero = Bad "Err.mzero" -- mplus (Bad _) y = y -- mplus x _ = x +-- * An eliminator for a parse result. Takes a function that recovers from any +-- parse errors. Typical usage: @err error (pCategory (tokens s)) :: Category@ err :: (String -> a) -> ParseMonad a -> a err e b = case b of Bad s -> e s @@ -65,6 +73,7 @@ -- PRINTING ----------- +-- * Overloaded pretty-printer printTree :: Print a => a -> String printTree = render . prt 0 @@ -83,8 +92,8 @@ "}" :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 -> showString t . rend i (")":ts) + t : "]" :ts -> showString t . rend i ("]":ts) t :ts -> space t . rend i ts _ -> id new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace diff --git a/examples/ghc6/jll/JavaletteLight.hs b/examples/ghc6/jll/JavaletteLight.hs deleted file mode 100644 --- a/examples/ghc6/jll/JavaletteLight.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/examples/ghc6/jll/UseJll.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/examples/ghc7/jll/JavaletteLight.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/examples/ghc7/jll/UseJll.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# 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|] diff --git a/examples/jll/JavaletteLight.hs b/examples/jll/JavaletteLight.hs new file mode 100644 --- /dev/null +++ b/examples/jll/JavaletteLight.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell #-} + +module JavaletteLight where + +import Language.LBNF.Compiletime + +import Language.LBNF(lbnf, dumpCode, bnfc) +bnfc [lbnf| + +Fun. Prog ::= Typ Ident "(" ")" "{" [Stm] "}" ; + +SDecl. Stm ::= Typ Ident ";" ; +SAss. Stm ::= Ident "=" Expr ";" ; +SIncr. Stm ::= Ident "++" ";" ; +SWhile. Stm ::= "while" "(" Expr ")" "{" [Stm] "}" ; +SFunApp. Stm ::= Ident "(" [Expr] ")" ";" ; +_. Stm ::= Stm ";" ; + +ELt. Expr0 ::= Expr1 "<" Expr1 ; +EPlus. Expr1 ::= Expr1 "+" Expr2 ; +ETimes. Expr2 ::= Expr2 "*" Expr3 ; +EVar. Expr3 ::= Ident ; +EInt. Expr3 ::= Integer ; +EDouble. Expr3 ::= Double ; +$. Expr3 ::= "$" Ident; +[]. [Stm] ::= ; +(:). [Stm] ::= Stm [Stm] ; + +separator Expr "," ; + + + + +_. Expr ::= Expr0 ; +_. Expr0 ::= Expr1 ; +_. Expr1 ::= Expr2 ; +_. Expr2 ::= Expr3 ; +_. Expr3 ::= "(" Expr ")" ; + +TInt. Typ ::= "int" ; +TDouble. Typ ::= "double" ; +|] + + diff --git a/examples/jll/UseJll.hs b/examples/jll/UseJll.hs new file mode 100644 --- /dev/null +++ b/examples/jll/UseJll.hs @@ -0,0 +1,29 @@ +{-# 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). +-} + +printing' :: Expr -> Prog +printing' e = [prog| + int main ( ) { + print ( $e ) ; + } + |] + +printing e = Fun TInt (Ident "main") [SFunApp (Ident "print") [e]] + +print10 :: Prog +print10 = printing' [expr| 5 + 5 |] + +main :: IO () +main = do + print print10 diff --git a/examples/typesafe/Example.hs b/examples/typesafe/Example.hs new file mode 100644 --- /dev/null +++ b/examples/typesafe/Example.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE QuasiQuotes #-} +import Typesafe +import Language.LBNF.Runtime(printTree) -- overloaded pretty-printing function +import Prelude hiding (exp) + + +-- All variables are meta-variables. +-- Variables must be declared in the function parameters +-- Boolean and numeric variables are type checked by Haskell. +prg n tmp x = [prog| +f() { + n = 0; + x := True ; + tmp = 0; + while ( tmp < 10 ) { + tmp++; + n = n * n; + } +} +|] + +main = putStr $ printTree $ fresh vars prg where + vars = (map return ['a'..'z']) ++ ['v' : show n |n <- [0..]] + + + +class Variable a where + fromString :: String -> a + +instance Variable NVar where + fromString = NVar . Ident + +instance Variable BVar where + fromString = BVar . Ident + + +class Fresh a where + fresh :: [String] -> a -> Prog + +instance Fresh Prog where + fresh _ e = e + +instance (Variable a, Fresh b) => Fresh (a -> b) where + fresh (s:ss) g = fresh ss $ g (fromString s) + + diff --git a/examples/typesafe/Typesafe.hs b/examples/typesafe/Typesafe.hs new file mode 100644 --- /dev/null +++ b/examples/typesafe/Typesafe.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + + +module Typesafe where + +import Language.LBNF + + +bnfc [lbnf| + +antiquote "[" ":" ":]" ; + + +Fun. Prog ::= Ident "(" ")" "{" [Stm] "}" ; + +SBAss. Stm ::= BVar ":=" BExp ";" ; +SAss. Stm ::= NVar "=" Exp ";" ; + +SIncr. Stm ::= NVar "++" ";" ; +SWhile. Stm ::= "while" "(" BExp ")" "{" [Stm] "}" ; +SBlock. Stm ::= "{" [Stm] "}" ; + + + +EAnd. BExp0 ::= BExp "&" BExp1 ; +ENeg. BExp1 ::= "!" BExp1 ; +ELt. BExp1 ::= Exp "<" Exp ; +ETruth. BExp1 ::= Truth ; +EBVar. BExp1 ::= BVar ; + +EPlus. Exp0 ::= Exp0 "+" Exp1 ; +ETimes. Exp1 ::= Exp1 "*" Exp2 ; +EInt. Exp2 ::= Integer ; +EVar. Exp2 ::= NVar ; + + +TTrue. Truth ::= "True" ; +TFalse. Truth ::= "False" ; + +[]. [Stm] ::= ; +(:). [Stm] ::= Stm [Stm] ; + +internal BVar. BVar ::= Ident ; +$ . BVar ::= Ident ; + +internal NVar. NVar ::= Ident ; +$. NVar ::= Ident ; + + + +-- coercions + +_. Stm ::= Stm ";" ; + +_. Exp ::= Exp0 ; +_. Exp0 ::= Exp1 ; +_. Exp1 ::= Exp2 ; +_. Exp2 ::= "[" Exp "]" ; +-- _. Exp2 ::= Exp3 ; + + +_. BExp ::= BExp0 ; +_. BExp0 ::= BExp1 ; +_. BExp1 ::= "(" BExp ")" ; + + + +-- pragmas + +comment "/*" "*/" ; +comment "//" ; + +entrypoints Prog, Stm, Exp, BExp ; + |] + + + +