ebnf-bff 0.1.0.0 → 0.1.1.0

raw patch · 11 files changed

+220/−149 lines, 11 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.md +6/−3
• changelog.md +9/−0
• ebnf-bff.cabal +6/−5
• ebnf-parse/ebnf-parse.hs +22/−21
• src/Text/EBNF.hs +2/−3
• src/Text/EBNF/Build/Parser.hs +5/−6
• src/Text/EBNF/Build/Parser/Except.hs +66/−29
• src/Text/EBNF/Build/Parser/Parts.hs +63/−54
• src/Text/EBNF/Helper.hs +3/−3
• src/Text/EBNF/Informal.hs +23/−24
• src/Text/EBNF/SyntaxTree.hs +15/−1

@@ -16,11 +16,14 @@ ```  #### Installing from cabal-**Project is not yet hosted on Hackage (TODO)** +```+sudo cabal install ebnf-bff --global+```+ ### Usage -**help text:**+**help text for `ebnf-parse`:** ``` ebnf-parse written by fionan haralddottir, available under the MIT licence. this program is part of the ebnf-bff cabal package@@ -60,7 +63,7 @@  ### Todos: -* Clean up the project enough to put on Hackage+* Clean up the project * 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

@@ -0,0 +1,9 @@+0.1.1.0+* Fixed bug that caused grouping sequences to no parse (`a = ("a")` would fail on the first bracket)++* Refactored code according to hslint++****+0.1.0.0++* Initial version

@@ -1,5 +1,5 @@ name:                ebnf-bff-version:             0.1.0.0+version:             0.1.1.0 synopsis:            Parser combinators & EBNF, BFFs! description:         A library & program that builds parsers from ISO EBNF using Parsec license:             MIT@@ -7,9 +7,10 @@ author:              Lokidottir maintainer:          ma302fh@gold.ac.uk -- copyright:-category:            Text+category:            Text, Metalanguage, EBNF, Parsing build-type:          Simple-extra-source-files:  README.md+extra-source-files:  README.md,+                     changelog.md cabal-version:       >=1.10  source-repository head@@ -27,7 +28,7 @@                        Text.EBNF.Build.Parser.Except   -- other-modules:   -- other-extensions:-  build-depends:       base >=4.7 && <4.8,+  build-depends:       base <= 4.9,                        parsec >=3.1 && <3.2,                        aeson >= 0.8 && < 0.9,                        text >= 1.2 && < 1.3@@ -36,7 +37,7 @@   -- ghc-options: -O2  executable ebnf-parse-  build-depends:       base >=4.7 && <4.8,+  build-depends:       base <= 4.9,                        parsec >=3.1 && <3.2,                        ebnf-bff >= 0.1,                        aeson >= 0.8 && < 0.9,

@@ -24,7 +24,7 @@     appends "=" to all elements in a list, just for differentiating     between arguments that are followed by input. -}-e l = map (\a -> a ++ "=") l+e = map (++ "=")  helpArg     =   ["-h", "--help", "-help"] grammarArg  = e ["-g", "--grammar"]@@ -64,7 +64,7 @@         Necessary arguments checked and defaults added, checking         for integrity of arguments beyond this point     -}-    | not . (\a -> elem a formats)+    | not . (`elem` formats)           . getArgData formatArgs $ args =              die "error: format not supported (json|plaintext|xml)"     {-@@ -85,15 +85,15 @@     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+                       . fromMaybe (length args)+                       . findIndex (`elem` sourceArgs) $ args) args     let primaryRule = getArgData primArgs args-    let showPipe = case (getArgData formatArgs args) of+    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+    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 @@ -101,7 +101,7 @@     sourcePaths <- pollSourcePaths sourcePaths'     grammarContent <- readFile grammarFile     {- get grammar -}-    case (parse syntax grammarFile grammarContent) of+    case parse syntax grammarFile grammarContent of         Left err -> die . show $ err         Right st ->             {-@@ -110,7 +110,7 @@                 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+            if eleml ebnfastArgs args then                 output outputLoc . showPipe $ st                 else do                     parser' <- ioTryBuild st@@ -123,10 +123,10 @@ jsonST st = BSC.unpack . encode $ st  xmlST :: SyntaxTree -> String-xmlST st = show st+xmlST = show  showST :: SyntaxTree -> String-showST st = show st+showST = show  {-     returns the full, recursed list of source files to be read@@ -136,8 +136,8 @@ pollSourcePaths paths =     let t = tail paths         h = head paths-    in ifM (return $ paths == []) (return [])-        (ifM (doesFileExist $ h)+    in ifM (return $ null paths) (return [])+        (ifM (doesFileExist h)             (do              sp <- pollSourcePaths t              return (h:sp))@@ -150,33 +150,34 @@                 (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+output "stdout" str = putStrLn str+output file str     = 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+    let argument = fromJust . find (\a -> any (`isPrefixOf` a) arglist) $ args+        dropnum = (1 +) . fromJust . elemIndex '=' $ argument     in drop dropnum argument  {--    Perform elem on a list, if any element in the first list are elements+    Perform elem on a list, if or 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+eleml p t = any (`elem` t) p  {--    if any of the elements of the first argument are prefixes of any+    if or of the elements of the first argument are prefixes of or     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+prelargs p t = any (\c -> any (isPrefixOf c) 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+removeprel p = filter (\c -> not . any (`isPrefixOf` c) $ p)  helptext =     unlines [

@@ -1,7 +1,6 @@-module Text.EBNF where+module Text.EBNF (syntax) where  import Text.EBNF.Informal (syntax)  main :: IO()-main = do-    putStrLn "this library is queer"+main = putStrLn "this library is queer"

@@ -3,10 +3,9 @@ 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 Text.Parsec.String import System.IO import Data.Either @@ -23,7 +22,7 @@     generated by EBNF.Informal that is not relevant. -} discard :: SyntaxTree -> SyntaxTree-discard st = prune (\a -> elem (identifier a) list) st+discard = prune (\a -> identifier a `elem` list)                 where                     list = [ "irrelevent"                            , "concatenate symbol"@@ -36,7 +35,7 @@ -} ioTryBuild :: SyntaxTree -> IO [GrammarRule] ioTryBuild st =-    case (generateReport st) of+    case generateReport st of         {-             The tree has no detectable errors, continue             with the program as normal.@@ -48,10 +47,10 @@             building process.         -}         Warning warns -> do-            hPutStrLn stderr . show $ (Warning warns)+            hPrint stderr $ 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 []+        Failed fails  -> (die . show $ Failed fails) >> return []

@@ -3,6 +3,7 @@ import Text.Parsec.Pos import Text.EBNF.SyntaxTree import Text.EBNF.Helper+import Data.Function import Data.List  {-@@ -10,63 +11,99 @@     warnings or invalid structures in EBNF grammars -} -data FailData = FailData {failtype :: String, description :: String, pos :: SourcePos}+data FailData = FailData {+                    failtype :: String,+                    description :: String,+                    pos :: SourcePos+                    } deriving (Eq)   instance Show FailData where-    show fd = concat [(show $ pos fd), " ", (failtype fd), ":", (description fd)]+    show fd = concat [failtype fd, " in " , show $ pos fd, ":\n", description fd]   data Report = Clean             | Warning {warnings :: [FailData]}-            | Failed {failures :: [FailData]}+            | Failed {failures :: [FailData]} deriving (Eq)   instance Show Report where-    show Clean       = ""-    show (Warning w) = ""-    show (Failed f)  = ""+    show Clean       = "Clean Report"+    show (Warning w) = intercalate "\n" . map show $ w+    show (Failed f)  = intercalate "\n" . map show $ f   concatReports :: [Report] -> Report-concatReports reps = foldl combineReports (Clean) reps+concatReports = foldl combineReports Clean  -{--    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+{-|+    Combining reports is a symmetric operation where @Clean@s+    are overridden by @Warning@s and @Failed@s, whereas @Warning@s+    are overridden only by @Failed@s. -} 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')+combineReports a Clean = combineReports Clean a+combineReports (Warning w) (Failed f) = Failed (sortBy (compare `on` pos) $ f ++ w)+combineReports (Failed f) (Warning w) = combineReports (Warning w) (Failed f)+combineReports (Failed f) (Failed f')   = Failed (sortBy (compare `on` pos) $ f ++ f')+combineReports (Warning w) (Warning w') = Warning (sortBy (compare `on` pos) $ w ++ w')   {-|     Will analyse a syntax tree, returning reports to be combined-    together+    together. -} generateReport :: SyntaxTree -> Report-generateReport st = concatReports $ map ($ st) reports+generateReport st = concatReports . map (($ st) . reporter) $ reports  -reports :: [(SyntaxTree -> Report)]-reports = [reportNeverTerminating]+reports :: [SyntaxTree -> Report]+reports = [] -- [neverTerminating] +reporter :: (SyntaxTree -> Report) -> SyntaxTree -> Report+reporter fn st = let rep = fn st+                     reps = map fn $ children st+                 in concatReports (rep:reps)  {-|-    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.+    @Failed@ when a repeat sequence with only optional sequences or has+    an optional sequence as it's first subsequence++    @Warning@ when a repeat sequence contains a definitions list that+    contains an optional sequence.++    @Clean@ otherwise -}-reportNeverTerminating :: SyntaxTree -> Report-reportNeverTerminating st =-    let rep = (\_ -> Clean) st-        reps = map reportNeverTerminating . children $ st-    in concatReports $ rep:reps+neverTerminating :: SyntaxTree -> Report+neverTerminating (SyntaxTree _ _ _ []) = Clean+neverTerminating st+    | opInRepeat        = Failed [reportf]+    | hasOptionalInTail = Warning [reportw]+    | otherwise            = Clean+        where+            reportf =+                FailData "failure"+                         "sequence will never terminate (repeat sequence only contains or favours optionals)"+                         (position st)+            reportw =+                FailData "warning"+                         "sequence may never terminate (contains optional sequence in a repeat sequence)"+                         (position st)+            opInRepeat = (isRepeatSeq && isOnlyOptionals) || opIsFirstInDef+            opIsFirstInDef = isRepeatSeq && ((identifier . head . children . head $ children st) == "optional sequence")+            {- Optional sequence is in a repeat sequence -}+            isRepeatSeq = identifier st == "repeated sequence"+            hasOptionalInTail = any (\a -> identifier (sk a) == "optional sequence")+                                . tail' . children . head . children $ st+            isOnlyOptionals = all (\a -> identifier (sk a) == "optional sequence")+                              . children . head . children $ st+            {- skip term -> factor -> primary -}+            sk :: SyntaxTree -> SyntaxTree+            sk st' = st'++tail' :: [a] -> [a]+tail' [] = []+tail' a = tail a

@@ -7,17 +7,16 @@ import Data.Maybe  - {-|-    For each instance of a SyntaxTree with the identifier raiseIdentifier,+    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)+        parts = partition (\a -> identifier a == raiseIdentifier) (map raise . children $ st)         ch = map raise . snd $ parts-        ch' = concat . map children . fst $ parts+        ch' = concatMap children . fst $ parts  {-|     The identifier for syntax trees that have no content and need@@ -25,29 +24,32 @@ -} raiseIdentifier = "&raise" +{-|+    Prunes any @nulltree@s+-} cleanup :: SyntaxTree -> SyntaxTree-cleanup st = prune (\a -> a == nulltree) st+cleanup = prune (== nulltree) +{-|+    Represents an EBNF grammar rule+-} 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..+    to be replaced by Maybe later. -} nullGrammar = GrammarRule "" (\_ -> return nulltree)  grToTuple :: GrammarRule -> (String, ConstructedParser)-grToTuple gr = (rulename $ gr, rule $ gr)+grToTuple gr = (rulename gr, rule gr)  {-|     lookup for grammars.@@ -57,50 +59,53 @@   {-|-    builds a rule from syntax tree that represents a valid EBNF+    Builds a rule from syntax tree that represents a valid EBNF     file. -} buildSyntax :: SyntaxTree -> [Either String GrammarRule]-buildSyntax st = map (buildSyntaxRule) (children st)+buildSyntax st = map buildSyntaxRule (children st) +{-|+    Builds a single syntax rule+-} buildSyntaxRule :: SyntaxTree -> Either String GrammarRule-buildSyntaxRule st = if (deflist /= nulltree) then+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))+                         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+                                rulename = getRulename st                                 deflistBuilt = buildDefList deflist-                                deflist = maybe nulltree id-                                          . find (\a -> (identifier a) == "definitions list")+                                deflist = fromMaybe nulltree+                                          . find (\a -> identifier a == "definitions list")                                           . children $ st  {-|-    for a SyntaxTree that represents a whole rule, finds the+    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 =+getRulename :: SyntaxTree -> Identifier+getRulename st =      maybe "&failed" content-     . find (\a -> (identifier a) == "meta identifier")+     . find (\a -> identifier a == "meta identifier")      . children $ st  {-|-    build a definitions list, a list of parsers to+    Builds a definitions list, a list of parsers to     try one at a time until one succeeds. -} buildDefList :: SyntaxTree -> ConstructedParser-buildDefList st = (\a -> do+buildDefList st = \a -> do     pos <- getPosition     let deflist' = map (\b -> b a) deflist     ch <- choice deflist'-    return $ cleanup . raise $ (SyntaxTree raiseIdentifier "" pos [ch]))+    return $ cleanup . raise $ SyntaxTree raiseIdentifier "" pos [ch]         where             deflist = map buildSingleDef-                      . filter (\a -> (identifier a) == "single definition")+                      . filter (\a -> identifier a == "single definition")                       . children $ st  {-@@ -109,11 +114,11 @@     writer for EBNF. -} buildSingleDef :: SyntaxTree -> ConstructedParser-buildSingleDef st = (\a -> do+buildSingleDef st = \a -> do     pos <- getPosition     let termlist' = map (\b -> b a) termlist     ch <- mapM (>>= return) termlist'-    return (SyntaxTree raiseIdentifier "" pos ch))+    return $ SyntaxTree raiseIdentifier "" pos ch     where         termlist = map buildSyntacticTerm                    . filter (\a -> identifier a == "syntactic term")@@ -122,63 +127,65 @@ buildSyntacticTerm :: SyntaxTree -> ConstructedParser buildSyntacticTerm st     | isJust-      . find (\a -> (identifier a) == "syntactic exception")+      . find (\a -> identifier a == "syntactic exception")       . children $ st = buildSTWithException st     | otherwise       = buildSTWithoutException st  buildSTWithException :: SyntaxTree -> ConstructedParser-buildSTWithException st = (\a -> do+buildSTWithException st = \a -> do     notFollowedBy (except a)-    factor a)+    factor a         where             except = buildSyntacticFactor                      . fromJust-                     . find (\a -> (identifier a) == "syntactic exception")+                     . find (\a -> identifier a == "syntactic exception")                      . children $ st             factor = buildSTWithoutException st  buildSTWithoutException :: SyntaxTree -> ConstructedParser-buildSTWithoutException st = (\a -> factor a)+buildSTWithoutException st = factor     where         factor = buildSyntacticFactor                  . fromJust-                 . find (\a -> (identifier a) == "syntactic factor")+                 . find (\a -> identifier a == "syntactic factor")                  . children $ st  buildSyntacticFactor :: SyntaxTree -> ConstructedParser-buildSyntacticFactor st = (\a -> do+buildSyntacticFactor st = \a -> do     pos <- getPosition     ch <- count num . primary $ a-    return (SyntaxTree raiseIdentifier "" pos ch))+    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+        num     = read num' :: Int+            where+                num' = case find (\a -> identifier a == "integer")+                       . children $ st of+                           Nothing -> "1"+                           Just a  -> content a  buildSyntacticPrimary :: SyntaxTree -> ConstructedParser buildSyntacticPrimary st =     let ch = head . children $ st-    in case (identifier ch) of+    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+        "special sequence"  -> \_ -> 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+        "empty sequence"    -> \_ -> return nulltree -- I /know/ it's awful+        otherwise           -> \_ -> 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))+    option nulltree . deflist         where             deflist =                 buildDefList@@ -186,12 +193,15 @@                 . find (\a -> identifier a == "definitions list")                 . children $ st +{-|+    A sequence that will parse 0 or more times+-} buildRepeatedSequence :: SyntaxTree -> ConstructedParser buildRepeatedSequence st =-    (\a -> do+    \a -> do     pos <- getPosition     ch <- many (deflist a)-    return (SyntaxTree raiseIdentifier "" pos ch))+    return $ SyntaxTree raiseIdentifier "" pos ch         where             deflist =                 buildDefList@@ -206,17 +216,16 @@                           . children $ st  buildMetaIdentifier :: SyntaxTree -> ConstructedParser-buildMetaIdentifier st = (\a -> do+buildMetaIdentifier st = \a -> do         let parser = fromJust . lookupGrammar iden $ a-        st <- parser a-        return st)+        parser a             where                 iden = content st  buildTerminalString :: SyntaxTree -> ConstructedParser-buildTerminalString st = (\a -> do+buildTerminalString st = \a -> do     pos <- getPosition     text <- string str-    return (SyntaxTree "&string" text pos []))+    return $ SyntaxTree "&string" text pos []         where-            str = (content st)+            str = content st

@@ -19,11 +19,11 @@ insertWhere :: (a -> Bool) -> a -> [a] -> [a] insertWhere _ element []      = [element] insertWhere predicate element list-    | (predicate (head list)) = (element:list)-    | otherwise               = insertWhere predicate element (tail 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

@@ -24,7 +24,7 @@ strip' :: String -> String strip' str     | str == "" = ""-    | not . (\a -> elem a stripWSList) . head $ str = str+    | not . (`elem` stripWSList) . head $ str = str     | otherwise = strip' . tail $ str  stripWSList = " \t\n\v\f"@@ -75,12 +75,10 @@ definitionsList = do     pos <- getPosition     defA <- singleDefinition-    list <- many (do+    list <- many $ do         primST (string "|" <|> string "!" <|> string "/") "definition separator symbol"-        defB <- singleDefinition-        return defB-        )-    return (SyntaxTree "definitions list" "" pos (defA:list))+        singleDefinition+    return $ SyntaxTree "definitions list" "" pos (defA:list)  singleDefinition :: Parser SyntaxTree singleDefinition = do@@ -94,7 +92,7 @@         termInList <- syntacticTerm         return [blInListA, concatSym, blInListB, termInList])     blPost <- irrelevent-    return (SyntaxTree "single definition" "" pos ([blPre, termA] ++ (concat list) ++ [blPost]))+    return (SyntaxTree "single definition" "" pos ([blPre, termA] ++ concat list ++ [blPost]))  syntacticTerm :: Parser SyntaxTree syntacticTerm = do@@ -141,10 +139,10 @@ syntacticPrimary = do     pos <- getPosition     blPre <- irrelevent-    ch <- optionalSequence+    ch <- groupedSequence+      <|> optionalSequence       <|> repeatedSequence       <|> specialSequence-      <|> groupedSequence       <|> metaIdentifier       <|> terminalString       <|> emptySequence@@ -180,8 +178,8 @@ terminalString :: Parser SyntaxTree terminalString = do     pos <- getPosition-    termstr <- (quotedString '"') <|> (quotedString '\'')-    return (SyntaxTree "terminal string" termstr pos [])+    termstr <- quotedString '"' <|> quotedString '\''+    return $ SyntaxTree "terminal string" termstr pos []  specialSequence :: Parser SyntaxTree specialSequence = do@@ -199,16 +197,16 @@ escapedChar' :: Char -> Parser String escapedChar' c = do     esc <- many (string "\\\\")-    ch <- string (['\\', c])-    return ((concat esc) ++ ch)+    ch <- string ['\\', c]+    return $ concat esc ++ ch  metaIdentifier :: Parser SyntaxTree metaIdentifier = do     pos <- getPosition-    ident <- (do+    ident <- do         h <- letter <|> char '_'-        t <- many (letter <|> space <|> digit <|> (char '_'))-        return (h:t))+        t <- many $ letter <|> space <|> digit <|> char '_'+        return (h:t)     return (SyntaxTree "meta identifier" (strip ident) pos [])  @@ -219,7 +217,7 @@ irrelevent :: Parser SyntaxTree irrelevent = do     pos <- getPosition-    ch <- many (comment <|> whitespaceST)+    ch <- try $ many (comment <|> whitespaceST)     return (SyntaxTree "irrelevent" "" pos ch)  nullParser :: Parser SyntaxTree@@ -230,7 +228,7 @@ comment :: Parser SyntaxTree comment = do     pos <- getPosition-    string "(*"+    try $ string "(*"     ch <- manyTill anyCharSW (try (string "*)"))     return (SyntaxTree "comment" (concat ch) pos []) @@ -243,7 +241,7 @@ commentCharacterST :: Parser SyntaxTree commentCharacterST = do     pos <- getPosition-    ch <- manyTill anyChar (eofStr <|> (tryRS(string "*)")))+    ch <- manyTill anyChar $ eofStr <|> tryRS (string "*)")     return (SyntaxTree "comment character" ch pos [])  whitespaceST :: Parser SyntaxTree@@ -266,8 +264,9 @@     where         codes = "0abfnrtv\"&\'\\"         replacements = "\0\a\b\f\n\r\t\v\"\&\'\\"-        escape code replace = char code >> return replace +escape :: Char -> Char -> Parser Char+escape code replace = char code >> return replace  tryRS :: Parser a -> Parser String tryRS par = do@@ -283,7 +282,7 @@ 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))+                        esc' = uncurry zip esc+                    in if (a == '\\') && (elem b . fst $ esc) then+                        (fromJust . lookup b $ esc'):unescape xs+                        else a:unescape (b:xs)

@@ -4,11 +4,13 @@ -} import Text.EBNF.Helper import Text.Parsec.Pos-import Data.List+import Data.List as List import Data.Tuple import Data.Ord+import Data.Maybe import Data.Aeson.Types import Data.Text (pack)+import qualified Data.Foldable as Fold  type Identifier = String type Content    = String@@ -19,6 +21,18 @@                  position   :: !SourcePos,                  children   :: ![SyntaxTree]                  } deriving (Show, Eq)++flattenSyntaxTree :: SyntaxTree -> [SyntaxTree]+flattenSyntaxTree st = st:flattened+    where+        flattened = concat . map flattenSyntaxTree . children $ st++findST :: (SyntaxTree -> Bool) -> SyntaxTree -> Maybe SyntaxTree+findST p st | p st        = Just st+            | isJust ch   = fromJust ch+            | otherwise   = Nothing+                where+                    ch = find (\a -> isJust a) . map (findST p) $ children st  instance Ord SyntaxTree where     compare (SyntaxTree _ _ pos _) (SyntaxTree _ _ pos' _) = compare pos pos'