diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Lokidottir + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,73 @@ +# ebnf-bff ![](https://travis-ci.org/Lokidottir/ebnf-bff.svg?branch=master) + +## Parser combinators & EBNF, BFFs! + +Currently barebones, but (most of) the help text is relevant (no --prune-ids yet). + +### Installing + +#### Installing (Linux) +As standard for installing haskell programs, you must have `ghc` and `cabal` installed + +```bash +git clone https://github.com/Lokidottir/ebnf-bff +cd ebnf-bff +sudo cabal install --only-dependencies --global && sudo cabal install --global +``` + +#### Installing from cabal +**Project is not yet hosted on Hackage (TODO)** + +### Usage + +**help text:** +``` +ebnf-parse written by fionan haralddottir, available under the MIT licence. +this program is part of the ebnf-bff cabal package + +this is a program that parses an ISO standard EBNF grammar and outputs an +abstract syntax tree in the format: + +identifier: +content: +position: + line: + col: + name: +children: [] + +Use: + ebnf-parse [OPTIONS] +Flags: + -h --help | show this text. + -p --primary-rule=rulename | the rule to be applied to the whole of each + source file. + -g --grammar=filename | load the EBNF grammar from the given file + -o --output=[filename|stdout] | output the AST to the given file or stdout + (--output=stdout). + --format=[json|xml|plaintext] | the format for the AST, defaults to + json. + --export-ebnf-ast | instead of parsing given files, parse the + EBNF grammar and output a raw AST of the + grammar (still uses --prune-ids, --format + flags). + --prune-ids=[comma delim list] | removes any subtrees from the tree that + have an identifier from the given list + -s --source-files | all arguments after this flag will be + assumed to be file names or directories + for files to be parsed by the given grammar. +``` + +### Todos: + +* Clean up the project enough to put on Hackage +* Remove dependency to Aeson, for reducing the build times. +* EBNF grammar analysis & reporting of potentially dangerous structures + (such as parsing infinite empty strings, parsec already does this + but we can give a source code location) +* Better error messages on failed parsing of EBNF grammar +* EBNF as defined in EBNF (properly) + +### Licence + +This project is under the MIT licence. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ebnf-bff.cabal b/ebnf-bff.cabal new file mode 100644 --- /dev/null +++ b/ebnf-bff.cabal @@ -0,0 +1,47 @@ +name: ebnf-bff +version: 0.1.0.0 +synopsis: Parser combinators & EBNF, BFFs! +description: A library & program that builds parsers from ISO EBNF using Parsec +license: MIT +license-file: LICENSE +author: Lokidottir +maintainer: ma302fh@gold.ac.uk +-- copyright: +category: Text +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/Lokidottir/ebnf-bff + +library + exposed-modules: Text.EBNF, + Text.EBNF.Informal, + Text.EBNF.SyntaxTree, + Text.EBNF.Helper, + Text.EBNF.Build.Parser, + Text.EBNF.Build.Parser.Transforms, + Text.EBNF.Build.Parser.Parts, + Text.EBNF.Build.Parser.Except + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <4.8, + parsec >=3.1 && <3.2, + aeson >= 0.8 && < 0.9, + text >= 1.2 && < 1.3 + hs-source-dirs: src + default-language: Haskell2010 + -- ghc-options: -O2 + +executable ebnf-parse + build-depends: base >=4.7 && <4.8, + parsec >=3.1 && <3.2, + ebnf-bff >= 0.1, + aeson >= 0.8 && < 0.9, + bytestring >= 0.10 && < 0.11, + directory >= 1.2 && < 1.3, + cond >= 0.4 && < 0.5 + main-is: ebnf-parse/ebnf-parse.hs + default-language: Haskell2010 diff --git a/ebnf-parse/ebnf-parse.hs b/ebnf-parse/ebnf-parse.hs new file mode 100644 --- /dev/null +++ b/ebnf-parse/ebnf-parse.hs @@ -0,0 +1,216 @@ +import Text.EBNF hiding (main) +import Text.EBNF.Informal (syntax) +import Text.EBNF.SyntaxTree +import Text.EBNF.Helper +import Text.EBNF.Build.Parser +import Text.Parsec +import Data.List +import Data.Aeson +import Data.Aeson.Encode +import Data.Maybe +import qualified Data.ByteString.Lazy.Char8 as BSC +import System.Environment +import System.IO +import System.Exit +import System.Directory +import Control.Conditional + + +main :: IO() +main = getArgs >>= processArgs + + +{- + appends "=" to all elements in a list, just for differentiating + between arguments that are followed by input. +-} +e l = map (\a -> a ++ "=") l + +helpArg = ["-h", "--help", "-help"] +grammarArg = e ["-g", "--grammar"] +outArgs = e ["-o", "--output"] +primArgs = e ["-p", "--primary-rule"] +sourceArgs = ["-s", "--source-files"] +formatArgs = e ["--format"] +formats = ["json", "plaintext", "xml"] +ebnfastArgs = ["--export-ebnf-ast"] + +{- + check arguments and report errors in arguments for main' +-} +processArgs :: [String] -> IO() +processArgs args + | eleml helpArg args = + -- help text expected + putStrLn helptext + | not . prelargs grammarArg $ args = + -- no grammar specified + die "error: no grammar was provided (--grammar|-g=)" + | (not . prelargs primArgs $ args) && + (not . eleml ebnfastArgs $ args) = + -- there is no primary rule and we're not outputting the EBNF AST + die "error: no primary rule provided (--primary-rule|-p=)" + | (not . eleml sourceArgs $ args) && + (not . eleml ebnfastArgs $ args) = + -- there are no source files and we're not outputting the EBNF AST + die "error: no source files provided (--source-files|-s ...)" + | not . prelargs outArgs $ args = + -- add default + processArgs ("--output=stdout":args) + | not . prelargs formatArgs $ args = + -- add default + processArgs ("--format=json":args) + {- + Necessary arguments checked and defaults added, checking + for integrity of arguments beyond this point + -} + | not . (\a -> elem a formats) + . getArgData formatArgs $ args = + die "error: format not supported (json|plaintext|xml)" + {- + All arguments are present and all defaults are solved or + provided by the user, this case is where the program is + run + -} + | otherwise = + main' args + +{- + what would be main if main wasn't being used for getting the + arguments for this function. this function does not check for + missing or poorly formatted arguments. +-} +main' :: [String] -> IO() +main' args = do + let outputLoc = getArgData outArgs args + let grammarFile = getArgData grammarArg args + let sourcePaths' = drop ((1 +) + . maybe (length args) id + . findIndex (\a -> elem a sourceArgs) $ args) args + let primaryRule = getArgData primArgs args + let showPipe = case (getArgData formatArgs args) of + "json" -> jsonST + "xml" -> xmlST + otherwise -> showST + let parserf = \gr fname fc -> + case (parse ((fromJust $ lookupGrammar primaryRule gr) gr) fname fc) of + Left err -> (die . show $ err) >> return "" + Right st -> return $ showPipe st + + {- pure section over -} + sourcePaths <- pollSourcePaths sourcePaths' + grammarContent <- readFile grammarFile + {- get grammar -} + case (parse syntax grammarFile grammarContent) of + Left err -> die . show $ err + Right st -> + {- + grammar was successfully parsed, if the --export-ebnf-ast + flag is present then we output the syntax tree of the EBNF, + otherwise we are going to evaluate it and turn it into a + parser then parse the source files with the parser. + -} + if (eleml ebnfastArgs args) then + output outputLoc . showPipe $ st + else do + parser' <- ioTryBuild st + shownTrees <- mapM (\a -> readFile a >>= parserf parser' a) sourcePaths + output outputLoc (concat shownTrees) + return () + return () + +jsonST :: SyntaxTree -> String +jsonST st = BSC.unpack . encode $ st + +xmlST :: SyntaxTree -> String +xmlST st = show st + +showST :: SyntaxTree -> String +showST st = show st + +{- + returns the full, recursed list of source files to be read + and parsed. +-} +pollSourcePaths :: [String] -> IO [String] +pollSourcePaths paths = + let t = tail paths + h = head paths + in ifM (return $ paths == []) (return []) + (ifM (doesFileExist $ h) + (do + sp <- pollSourcePaths t + return (h:sp)) + (ifM (doesDirectoryExist h) + (do + dircontent <- getDirectoryContents h + sp' <- pollSourcePaths dircontent + sp <- pollSourcePaths t + return (sp' ++ sp)) + (die ("error: '" ++ h ++ "' is not a file or directory") >> return []))) + +output :: String -> String -> IO() +output file str = if (file == "stdout") then putStrLn str else writeFile file str + +{- get the data from the given arguments -} +getArgData arglist args = + let argument = fromJust . find (\a -> or . map (\b -> isPrefixOf b a) $ arglist) $ args + dropnum = (1 +) . fromJust . findIndex (\a -> a == '=') $ argument + in drop dropnum argument + +{- + Perform elem on a list, if any element in the first list are elements + of the second list then the function returns True, otherwise False +-} +eleml p t = or . map (\c -> elem c t) $ p + +{- + if any of the elements of the first argument are prefixes of any + of the elements of the second argument then the function returns + True, otherwise false. +-} +prelargs p t = or . map (\c -> or . map (\d -> isPrefixOf c d) $ t) $ p + + +{- + removes elements from an array that whose prefixes are from a given + list. useful for filtering arguments for recursive processing. +-} +removeprel p t = filter (\c -> not . or . map (\d -> isPrefixOf d c) $ p) $ t + +helptext = + unlines [ + "ebnf-parse written by fionan haralddottir, available under the MIT licence.", + "this program is part of the ebnf-bff cabal package", + "", + "this is a program that parses an ISO standard EBNF grammar and outputs an", + "abstract syntax tree in the format:", + "", + "identifier: ", + "content: ", + "position:", + " line: ", + " col: ", + " name: ", + "children: []", + "", + "Use:", + " ebnf-parse [OPTIONS]", + "Flags:", + " -h --help | show this text.", + " -p --primary-rule=rulename | the rule to be applied to the whole of each", + " source file.", + " -g --grammar=filename | load the EBNF grammar from the given file", + " -o --output=[filename|stdout] | output the AST to the given file or stdout", + " (--output=stdout).", + " --format=[json|xml|plaintext] | the format for the AST, defaults to", + " json.", + " --export-ebnf-ast | instead of parsing given files, parse the", + " EBNF grammar and output a raw AST of the", + " grammar (still uses --prune-ids, --format", + " flags).", + " --prune-ids=[comma delim list] | removes any subtrees from the tree that", + " have an identifier from the given list", + " -s --source-files | all arguments after this flag will be", + " assumed to be file names or directories", + " for files to be parsed by the given grammar."] diff --git a/src/Text/EBNF.hs b/src/Text/EBNF.hs new file mode 100644 --- /dev/null +++ b/src/Text/EBNF.hs @@ -0,0 +1,7 @@ +module Text.EBNF where + +import Text.EBNF.Informal (syntax) + +main :: IO() +main = do + putStrLn "this library is queer" diff --git a/src/Text/EBNF/Build/Parser.hs b/src/Text/EBNF/Build/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/EBNF/Build/Parser.hs @@ -0,0 +1,57 @@ +module Text.EBNF.Build.Parser (build, ioTryBuild, lookupGrammar) where + +import Text.EBNF.SyntaxTree +import Text.EBNF.Informal (syntax) +import Text.EBNF.Helper +import Text.Parsec.String +import Text.EBNF.Informal (nullParser) +import Text.EBNF.Build.Parser.Parts +import Text.EBNF.Build.Parser.Except +import System.IO +import Data.Either + +{-| + given a syntax tree for a valid EBNF grammar, returns a + association list with the key as the meta identifier. +-} +build :: SyntaxTree -> [GrammarRule] +build st = rights . buildSyntax $ st + + +{-| + transform that discards the information in a EBNF AST + generated by EBNF.Informal that is not relevant. +-} +discard :: SyntaxTree -> SyntaxTree +discard st = prune (\a -> elem (identifier a) list) st + where + list = [ "irrelevent" + , "concatenate symbol" + , "definition separator symbol" + , "defining symbol" + , "terminator symbol"] + +{-| + IO function, outputs errors if build fails. +-} +ioTryBuild :: SyntaxTree -> IO [GrammarRule] +ioTryBuild st = + case (generateReport st) of + {- + The tree has no detectable errors, continue + with the program as normal. + -} + Clean -> return $ build st + {- + The tree has one or more non-critical errors, + print these to stderr and continue with the + building process. + -} + Warning warns -> do + hPutStrLn stderr . show $ (Warning warns) + return $ build st + {- + The tree has one or more critical errors, the + program exits with an error code. + -} + Failed fails -> (die . show $ (Failed fails)) >> return [] diff --git a/src/Text/EBNF/Build/Parser/Except.hs b/src/Text/EBNF/Build/Parser/Except.hs new file mode 100644 --- /dev/null +++ b/src/Text/EBNF/Build/Parser/Except.hs @@ -0,0 +1,72 @@ +module Text.EBNF.Build.Parser.Except where + +import Text.Parsec.Pos +import Text.EBNF.SyntaxTree +import Text.EBNF.Helper +import Data.List + +{- + A number of exception structures for reporting + warnings or invalid structures in EBNF grammars +-} + +data FailData = FailData {failtype :: String, description :: String, pos :: SourcePos} + + +instance Show FailData where + show fd = concat [(show $ pos fd), " ", (failtype fd), ":", (description fd)] + + +data Report = Clean + | Warning {warnings :: [FailData]} + | Failed {failures :: [FailData]} + + +instance Show Report where + show Clean = "" + show (Warning w) = "" + show (Failed f) = "" + + +concatReports :: [Report] -> Report +concatReports reps = foldl combineReports (Clean) reps + + +{- + Combining reports is a symmetric operation where Cleans + are overridden by warnings and failures, whereas warnings + are overridden only by failures. At the end the +-} +combineReports :: Report -> Report -> Report +combineReports Clean Clean = Clean +combineReports Clean a = a +combineReports a Clean = a +combineReports (Warning w) (Failed f) = Failed (sortBy (\a b -> compare (pos a) (pos b)) $ f ++ w) +combineReports (Failed f) (Warning w) = Failed (sortBy (\a b -> compare (pos a) (pos b)) $ f ++ w) +combineReports (Failed f) (Failed f') = Failed (sortBy (\a b -> compare (pos a) (pos b)) $ f ++ f') +combineReports (Warning w) (Warning w') = Warning (sortBy (\a b -> compare (pos a) (pos b)) $ w ++ w') + + +{-| + Will analyse a syntax tree, returning reports to be combined + together +-} +generateReport :: SyntaxTree -> Report +generateReport st = concatReports $ map ($ st) reports + + +reports :: [(SyntaxTree -> Report)] +reports = [reportNeverTerminating] + + +{-| + A never terminating parser is one that can parse an infinite + amount of empty strings, such parsers can be achieved with + @{[identifer]}@ pattern rules, which can parse indefinitely + but never terminate. +-} +reportNeverTerminating :: SyntaxTree -> Report +reportNeverTerminating st = + let rep = (\_ -> Clean) st + reps = map reportNeverTerminating . children $ st + in concatReports $ rep:reps diff --git a/src/Text/EBNF/Build/Parser/Parts.hs b/src/Text/EBNF/Build/Parser/Parts.hs new file mode 100644 --- /dev/null +++ b/src/Text/EBNF/Build/Parser/Parts.hs @@ -0,0 +1,222 @@ +module Text.EBNF.Build.Parser.Parts where + +import Text.EBNF.SyntaxTree +import Text.Parsec.String +import Text.Parsec +import Data.List +import Data.Maybe + + + +{-| + For each instance of a SyntaxTree with the identifier raiseIdentifier, + merge it's children with it's parent's children. +-} +raise :: SyntaxTree -> SyntaxTree +raise st = replaceChildren (sort $ ch ++ ch') st + where + parts = partition (\a -> (identifier a) == raiseIdentifier) (map raise . children $ st) + ch = map raise . snd $ parts + ch' = concat . map children . fst $ parts + +{-| + The identifier for syntax trees that have no content and need + their children risen to the children of the syntax tree's parent. +-} +raiseIdentifier = "&raise" + +cleanup :: SyntaxTree -> SyntaxTree +cleanup st = prune (\a -> a == nulltree) st + +data GrammarRule = GrammarRule { + rulename :: String, + rule :: ConstructedParser + } + +{-| + ConstructedParser is the type of the parser as generated, + which takes a list of GrammarRules and returns a syntax + tree. +-} +type ConstructedParser = ([GrammarRule] -> Parser SyntaxTree) + +{-| + Null grammar rule, bad form but useful for early version. + to be replaced by Maybe later.. +-} +nullGrammar = GrammarRule "" (\_ -> return nulltree) + +grToTuple :: GrammarRule -> (String, ConstructedParser) +grToTuple gr = (rulename $ gr, rule $ gr) + +{-| + lookup for grammars. +-} +lookupGrammar :: String -> [GrammarRule] -> Maybe ConstructedParser +lookupGrammar rn grs = lookup rn . map grToTuple $ grs + + +{-| + builds a rule from syntax tree that represents a valid EBNF + file. +-} +buildSyntax :: SyntaxTree -> [Either String GrammarRule] +buildSyntax st = map (buildSyntaxRule) (children st) + +buildSyntaxRule :: SyntaxTree -> Either String GrammarRule +buildSyntaxRule st = if (deflist /= nulltree) then + Right $ GrammarRule rulename (\a -> do + st' <- deflistBuilt a + return $ cleanup . raise . replaceIdentifier rulename $ st') + else Left $ ("error: could not find a definitions list at " ++ (show $ position st)) + where + {- The meta identifier of the rule that is being built -} + rulename = pollRulename st + deflistBuilt = buildDefList deflist + deflist = maybe nulltree id + . find (\a -> (identifier a) == "definitions list") + . children $ st + +{-| + for a SyntaxTree that represents a whole rule, finds the + first meta identifier. does not recurse into the tree's + children. +-} +pollRulename :: SyntaxTree -> Identifier +pollRulename st = + maybe "&failed" content + . find (\a -> (identifier a) == "meta identifier") + . children $ st + +{-| + build a definitions list, a list of parsers to + try one at a time until one succeeds. +-} +buildDefList :: SyntaxTree -> ConstructedParser +buildDefList st = (\a -> do + pos <- getPosition + let deflist' = map (\b -> b a) deflist + ch <- choice deflist' + return $ cleanup . raise $ (SyntaxTree raiseIdentifier "" pos [ch])) + where + deflist = map buildSingleDef + . filter (\a -> (identifier a) == "single definition") + . children $ st + +{- + A single definition is a concatinator seperated list ("a, b, c") + rather than just a single parser as the name suggests, blame the + writer for EBNF. +-} +buildSingleDef :: SyntaxTree -> ConstructedParser +buildSingleDef st = (\a -> do + pos <- getPosition + let termlist' = map (\b -> b a) termlist + ch <- mapM (>>= return) termlist' + return (SyntaxTree raiseIdentifier "" pos ch)) + where + termlist = map buildSyntacticTerm + . filter (\a -> identifier a == "syntactic term") + . children $ st + +buildSyntacticTerm :: SyntaxTree -> ConstructedParser +buildSyntacticTerm st + | isJust + . find (\a -> (identifier a) == "syntactic exception") + . children $ st = buildSTWithException st + | otherwise = buildSTWithoutException st + +buildSTWithException :: SyntaxTree -> ConstructedParser +buildSTWithException st = (\a -> do + notFollowedBy (except a) + factor a) + where + except = buildSyntacticFactor + . fromJust + . find (\a -> (identifier a) == "syntactic exception") + . children $ st + factor = buildSTWithoutException st + +buildSTWithoutException :: SyntaxTree -> ConstructedParser +buildSTWithoutException st = (\a -> factor a) + where + factor = buildSyntacticFactor + . fromJust + . find (\a -> (identifier a) == "syntactic factor") + . children $ st + +buildSyntacticFactor :: SyntaxTree -> ConstructedParser +buildSyntacticFactor st = (\a -> do + pos <- getPosition + ch <- count num . primary $ a + return (SyntaxTree raiseIdentifier "" pos ch)) + where + primary = buildSyntacticPrimary + . fromJust + . find (\a -> identifier a == "syntactic primary") + . children $ st + num = read (case (find (\a -> identifier a == "integer") + . children $ st) of + Nothing -> "1" + Just a -> content a) :: Int + +buildSyntacticPrimary :: SyntaxTree -> ConstructedParser +buildSyntacticPrimary st = + let ch = head . children $ st + in case (identifier ch) of + "optional sequence" -> buildOptionalSequence ch + "repeated sequence" -> buildRepeatedSequence ch + "grouped sequence" -> buildGroupedSequence ch + "special sequence" -> (\_ -> do return nulltree) -- I /know/ it's awful + "meta identifier" -> buildMetaIdentifier ch + "terminal string" -> buildTerminalString ch + "empty sequence" -> (\_ -> do return nulltree) -- I /know/ it's awful + otherwise -> (\_ -> do return nulltree) -- I /know/ it's awful + +{-| + A sequence that does not have to be parsed +-} +buildOptionalSequence :: SyntaxTree -> ConstructedParser +buildOptionalSequence st = + (\a -> option nulltree (deflist a)) + where + deflist = + buildDefList + . fromJust + . find (\a -> identifier a == "definitions list") + . children $ st + +buildRepeatedSequence :: SyntaxTree -> ConstructedParser +buildRepeatedSequence st = + (\a -> do + pos <- getPosition + ch <- many (deflist a) + return (SyntaxTree raiseIdentifier "" pos ch)) + where + deflist = + buildDefList + . fromJust + . find (\a -> identifier a == "definitions list") + . children $ st + +buildGroupedSequence :: SyntaxTree -> ConstructedParser +buildGroupedSequence st = buildDefList + . fromJust + . find (\a -> identifier a == "definitions list") + . children $ st + +buildMetaIdentifier :: SyntaxTree -> ConstructedParser +buildMetaIdentifier st = (\a -> do + let parser = fromJust . lookupGrammar iden $ a + st <- parser a + return st) + where + iden = content st + +buildTerminalString :: SyntaxTree -> ConstructedParser +buildTerminalString st = (\a -> do + pos <- getPosition + text <- string str + return (SyntaxTree "&string" text pos [])) + where + str = (content st) diff --git a/src/Text/EBNF/Build/Parser/Transforms.hs b/src/Text/EBNF/Build/Parser/Transforms.hs new file mode 100644 --- /dev/null +++ b/src/Text/EBNF/Build/Parser/Transforms.hs @@ -0,0 +1,3 @@ +module Text.EBNF.Build.Parser.Transforms where + +import Text.EBNF.SyntaxTree diff --git a/src/Text/EBNF/Helper.hs b/src/Text/EBNF/Helper.hs new file mode 100644 --- /dev/null +++ b/src/Text/EBNF/Helper.hs @@ -0,0 +1,32 @@ +module Text.EBNF.Helper where + +import Text.Parsec +import Text.Parsec.String +import Text.Parsec.Char +import Data.List +import System.IO +import System.Exit + +syntacticExceptionCombinator factor term = do + notFollowedBy (try term) + factor + +betweenSame c = between c c + +{-| + +-} +insertWhere :: (a -> Bool) -> a -> [a] -> [a] +insertWhere _ element [] = [element] +insertWhere predicate element list + | (predicate (head list)) = (element:list) + | otherwise = insertWhere predicate element (tail list) + + +{- + die does not exist in the version of the base package used, implementation copied + from the System.Exit source at: + https://hackage.haskell.org/package/base-4.8.1.0/docs/src/System.Exit.html#die +-} +die :: String -> IO a +die err = hPutStrLn stderr err >> exitFailure diff --git a/src/Text/EBNF/Informal.hs b/src/Text/EBNF/Informal.hs new file mode 100644 --- /dev/null +++ b/src/Text/EBNF/Informal.hs @@ -0,0 +1,289 @@ +module Text.EBNF.Informal where + +import Text.EBNF.Helper +import Text.EBNF.SyntaxTree +import Text.Parsec +import Text.Parsec.String +import Text.Parsec.Char +import Data.List +import Data.Maybe +{- + An implementation of an EBNF parser from the ISO EBNF informal + definitions. + + TODO: better error messages +-} + +{- + Implementation of MissingH's stripr function to lower the number + of dependencies. +-} +strip :: String -> String +strip str = reverse . strip' . reverse $ str + +strip' :: String -> String +strip' str + | str == "" = "" + | not . (\a -> elem a stripWSList) . head $ str = str + | otherwise = strip' . tail $ str + +stripWSList = " \t\n\v\f" + +primST :: Parser String -> String -> Parser SyntaxTree +primST par name = do + pos <- getPosition + text <- par + return (SyntaxTree name text pos []) + +{- + TODO: parsers for less verbose sourse code + primChild | parser that will parse for a single child + primChildren | parser that will parse for many children + primTerminal | parser that will parse for a string (primST) +-} + + +{-| + Syntax parser, parses an entire syntax +-} +syntax :: Parser SyntaxTree +syntax = do + pos <- getPosition + ch <- many1 syntaxRule + return (SyntaxTree "syntax" "" pos ch) + +{-| + Syntax rule parser, parses a single syntax rule +-} +syntaxRule :: Parser SyntaxTree +syntaxRule = do + pos <- getPosition + ch <- do + blPre <- irrelevent + meta <- metaIdentifier + blA <- irrelevent + eq <- primST (string "=") "defining symbol" + blB <- irrelevent + defL <- definitionsList + blC <- irrelevent + ter <- primST (string ";" <|> string ".") "terminator symbol" + blPost <- irrelevent + return [blPre, meta, blA, eq, blB, defL, blC, ter, blPost] + return (SyntaxTree "syntax rule" "" pos ch) + +definitionsList :: Parser SyntaxTree +definitionsList = do + pos <- getPosition + defA <- singleDefinition + list <- many (do + primST (string "|" <|> string "!" <|> string "/") "definition separator symbol" + defB <- singleDefinition + return defB + ) + return (SyntaxTree "definitions list" "" pos (defA:list)) + +singleDefinition :: Parser SyntaxTree +singleDefinition = do + pos <- getPosition + blPre <- irrelevent + termA <- syntacticTerm + list <- many (do + blInListA <- irrelevent + concatSym <- primST (string ",") "concatenate symbol" + blInListB <- irrelevent + termInList <- syntacticTerm + return [blInListA, concatSym, blInListB, termInList]) + blPost <- irrelevent + return (SyntaxTree "single definition" "" pos ([blPre, termA] ++ (concat list) ++ [blPost])) + +syntacticTerm :: Parser SyntaxTree +syntacticTerm = do + pos <- getPosition + blPre <- irrelevent + factor <- syntacticFactor + exceptBl <- option [] (do + blInListA <- irrelevent + exceptSym <- primST (string "-") "except symbol" + blInListB <- irrelevent + exception <- syntacticException + return [blInListA, exceptSym, blInListB, exception] + ) + blPost <- irrelevent + return (SyntaxTree "syntactic term" "" pos ([blPre, factor] ++ exceptBl ++ [blPost])) + +{-| + A syntactic exception is a syntactic factor that is checked for + self-reference in this implementation. +-} +syntacticException :: Parser SyntaxTree +syntacticException = do + st <- syntacticFactor + return (replaceIdentifier "syntactic exception" st) + +syntacticFactor :: Parser SyntaxTree +syntacticFactor = do + pos <- getPosition + blPre <- irrelevent + repeatBlock <- option [] (do + repeatSym <- primST (string "*") "repetition symbol" + blInListA <- irrelevent + integer <- primST (many1 digit) "integer" + return [repeatSym, blInListA, integer]) + blA <- irrelevent + prim <- syntacticPrimary + blPost <- irrelevent + return (SyntaxTree "syntactic factor" "" pos ((blPre:repeatBlock) ++ [blA, prim, blPost])) + +{-| + +-} +syntacticPrimary :: Parser SyntaxTree +syntacticPrimary = do + pos <- getPosition + blPre <- irrelevent + ch <- optionalSequence + <|> repeatedSequence + <|> specialSequence + <|> groupedSequence + <|> metaIdentifier + <|> terminalString + <|> emptySequence + return (SyntaxTree "syntactic primary" "" pos [ch]) + +emptySequence :: Parser SyntaxTree +emptySequence = nullParser + +optionalSequence :: Parser SyntaxTree +optionalSequence = do + pos <- getPosition + string "[" <|> string "(/" + block <- definitionsList + string "]" <|> string "/)" + return (SyntaxTree "optional sequence" "" pos [block]) + +repeatedSequence :: Parser SyntaxTree +repeatedSequence = do + pos <- getPosition + string "(:" <|> string "{" + block <- definitionsList + string ":)" <|> string "}" + return (SyntaxTree "repeated sequence" "" pos [block]) + +groupedSequence :: Parser SyntaxTree +groupedSequence = do + pos <- getPosition + string "(" + block <- definitionsList + string ")" + return (SyntaxTree "grouped sequence" "" pos [block]) + +terminalString :: Parser SyntaxTree +terminalString = do + pos <- getPosition + termstr <- (quotedString '"') <|> (quotedString '\'') + return (SyntaxTree "terminal string" termstr pos []) + +specialSequence :: Parser SyntaxTree +specialSequence = do + pos <- getPosition + specialSeq <- quotedString '?' + return (SyntaxTree "special sequence" specialSeq pos []) + +quotedString :: Char -> Parser String +quotedString quoter = do + char quoter + cont <- many (syntacticExceptionCombinator anyCharSW (string [quoter])) + char quoter + return (concat cont) + +escapedChar' :: Char -> Parser String +escapedChar' c = do + esc <- many (string "\\\\") + ch <- string (['\\', c]) + return ((concat esc) ++ ch) + +metaIdentifier :: Parser SyntaxTree +metaIdentifier = do + pos <- getPosition + ident <- (do + h <- letter <|> char '_' + t <- many (letter <|> space <|> digit <|> (char '_')) + return (h:t)) + return (SyntaxTree "meta identifier" (strip ident) pos []) + + +{-| + Parser for irrelevent data, things like whitespace and comments. still + parsed and added to the tree but grouped together +-} +irrelevent :: Parser SyntaxTree +irrelevent = do + pos <- getPosition + ch <- many (comment <|> whitespaceST) + return (SyntaxTree "irrelevent" "" pos ch) + +nullParser :: Parser SyntaxTree +nullParser = do + pos <- getPosition + return (SyntaxTree "null" "" pos []) + +comment :: Parser SyntaxTree +comment = do + pos <- getPosition + string "(*" + ch <- manyTill anyCharSW (try (string "*)")) + return (SyntaxTree "comment" (concat ch) pos []) + +commentSymbol :: Parser SyntaxTree +commentSymbol = do + pos <- getPosition + ch <- comment <|> terminalString <|> specialSequence <|> commentCharacterST + return (SyntaxTree "comment symbol" "" pos [ch]) + +commentCharacterST :: Parser SyntaxTree +commentCharacterST = do + pos <- getPosition + ch <- manyTill anyChar (eofStr <|> (tryRS(string "*)"))) + return (SyntaxTree "comment character" ch pos []) + +whitespaceST :: Parser SyntaxTree +whitespaceST = do + pos <- getPosition + ch <- string " " + <|> string "\n" + <|> string "\f" + <|> string "\v" + <|> string "\t" + return (SyntaxTree "whitespace" ch pos []) + +anyCharSW :: Parser String +anyCharSW = do + c <- escapedChar <|> anyChar + return [c] + +escapedChar :: Parser Char +escapedChar = char '\\' >> choice (zipWith escape codes replacements) + where + codes = "0abfnrtv\"&\'\\" + replacements = "\0\a\b\f\n\r\t\v\"\&\'\\" + escape code replace = char code >> return replace + + +tryRS :: Parser a -> Parser String +tryRS par = do + try par + return "" + +eofStr :: Parser String +eofStr = do + try eof + return "" + +unescape :: String -> String +unescape [] = [] +unescape [a] = [a] +unescape (a:b:xs) = let esc = ("0abfnrtv\"&'\\", "\0\a\b\f\n\r\t\v\"\&\'\\") + esc' = zip (fst esc) (snd esc) + in if ((a == '\\') && (elem b . fst $ esc)) then + (fromJust . lookup b $ esc'):(unescape xs) + else a:(unescape (b:xs)) diff --git a/src/Text/EBNF/SyntaxTree.hs b/src/Text/EBNF/SyntaxTree.hs new file mode 100644 --- /dev/null +++ b/src/Text/EBNF/SyntaxTree.hs @@ -0,0 +1,136 @@ +module Text.EBNF.SyntaxTree where +{- + Syntax Tree module for data type and related functions +-} +import Text.EBNF.Helper +import Text.Parsec.Pos +import Data.List +import Data.Tuple +import Data.Ord +import Data.Aeson.Types +import Data.Text (pack) + +type Identifier = String +type Content = String + +data SyntaxTree = SyntaxTree { + identifier :: !Identifier, + content :: !Content, + position :: !SourcePos, + children :: ![SyntaxTree] + } deriving (Show, Eq) + +instance Ord SyntaxTree where + compare (SyntaxTree _ _ pos _) (SyntaxTree _ _ pos' _) = compare pos pos' + +instance ToJSON SyntaxTree where + toJSON (SyntaxTree i c p ch) = (object [(pack "identifier") .= i, + (pack "content") .= c, + (pack "position") .= (toJSON p), + (pack "children") .= (map (toJSON) ch)]) + + +instance ToJSON SourcePos where + toJSON pos = (object [(pack "name") .= (sourceName pos), + (pack "line") .= (sourceLine pos), + (pack "col") .= (sourceColumn pos)]) +{-| + returns a syntax tree similar to the one passed but with + the given identifier. +-} +replaceIdentifier :: Identifier -> SyntaxTree -> SyntaxTree +replaceIdentifier i st = (SyntaxTree + (i) + (content st) + (position st) + (children st)) + +{-| + returns a syntax tree similar to the one passed but with + the given content. +-} +replaceContent :: Content -> SyntaxTree -> SyntaxTree +replaceContent c st = (SyntaxTree + (identifier st) + (c) + (position st) + (children st)) + +{-| + returns a syntax tree similar to the one passed but with + the given position. +-} +replacePosition :: SourcePos -> SyntaxTree -> SyntaxTree +replacePosition p st = (SyntaxTree + (identifier st) + (content st) + (p) + (children st)) + +{-| + returns a syntax tree similar to the one passed but with + the given children. +-} +replaceChildren :: [SyntaxTree] -> SyntaxTree -> SyntaxTree +replaceChildren ch st = (SyntaxTree + (identifier st) + (content st) + (position st) + (ch)) + +{-| + inserts a syntax tree as a child, list is sorted by source code + position +-} +insert :: SyntaxTree -> SyntaxTree -> SyntaxTree +insert st st' = SyntaxTree (identifier st) + (content st) + (position st) + (insertWhere (\a -> a > st') st' (children st)) + +{-| + removes any children of `st` that equal `st'` +-} +remove :: SyntaxTree -> SyntaxTree -> SyntaxTree +remove st st' = SyntaxTree (identifier st) + (content st) + (position st) + (filter (\a -> a /= st') (children st)) + +{-| + the content of the syntax tree is merged with it's parent + if the predicate is met. +-} +collapse :: (SyntaxTree -> Bool) -> SyntaxTree -> SyntaxTree +collapse predicate (SyntaxTree i c p ch) = + (SyntaxTree i c' p ch') + where + ch' = map (collapse predicate) ch + c' = concat (map content ch') + +{-| + prune will remove any children of `tree` that satisfy `predicate`, + recursively +-} +prune :: (SyntaxTree -> Bool) -> SyntaxTree -> SyntaxTree +prune predicate (SyntaxTree i c p ch) = + SyntaxTree i c p (map (prune predicate) (filter (not . predicate) ch)) + +{-| + prune any children of `st` whose identifier begins with an underscore. + might be useful for preventing syntax trees from being polluted by + base cases of single characters by annotating the EBNF definition of + single-char base cases such as single letters as `_letters_ = ...` +-} +pruneUnderscored :: SyntaxTree -> SyntaxTree +pruneUnderscored st = prune (\a -> ((head (identifier a)) == '_')) st + +{- +pruneIdentifier :: SyntaxTree -> Identifier -> SyntaxTree +pruneIdentifier st identifier = prune (\s -> ) st +-} +isTerminal :: SyntaxTree -> Bool +isTerminal (SyntaxTree _ _ _ []) = True +isTerminal (SyntaxTree _ _ _ _) = False + +nulltree = SyntaxTree "" "" (newPos "" 0 0) []