ebnf-bff-0.1.0.0: src/Text/EBNF/Build/Parser/Parts.hs

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)