packages feed

ebnf-bff (empty) → 0.1.0.0

raw patch · 13 files changed

+1176/−0 lines, 13 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, cond, directory, ebnf-bff, parsec, text

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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: <string>+content: <string>+position:+    line: <int>+    col: <int>+    name: <string>+children: [<syntax tree>]++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ebnf-bff.cabal view
@@ -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
+ ebnf-parse/ebnf-parse.hs view
@@ -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=<filename>)"+    | (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=<rule>)"+    | (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: <string>",+        "content: <string>",+        "position:",+        "    line: <int>",+        "    col: <int>",+        "    name: <string>",+        "children: [<syntax tree>]",+        "",+        "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."]
+ src/Text/EBNF.hs view
@@ -0,0 +1,7 @@+module Text.EBNF where++import Text.EBNF.Informal (syntax)++main :: IO()+main = do+    putStrLn "this library is queer"
+ src/Text/EBNF/Build/Parser.hs view
@@ -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 []
+ src/Text/EBNF/Build/Parser/Except.hs view
@@ -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
+ src/Text/EBNF/Build/Parser/Parts.hs view
@@ -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)
+ src/Text/EBNF/Build/Parser/Transforms.hs view
@@ -0,0 +1,3 @@+module Text.EBNF.Build.Parser.Transforms where++import Text.EBNF.SyntaxTree
+ src/Text/EBNF/Helper.hs view
@@ -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
+ src/Text/EBNF/Informal.hs view
@@ -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))
+ src/Text/EBNF/SyntaxTree.hs view
@@ -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) []