module Text.EBNF.Build.Parser.Parts where
import Text.EBNF.SyntaxTree
import Text.Parsec.String
import Text.Parsec
import Data.List
import Data.Maybe
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' = concatMap children . fst $ parts
raiseIdentifier = "&raise"
cleanup :: SyntaxTree -> SyntaxTree
cleanup = prune (== nulltree)
data GrammarRule = GrammarRule {
rulename :: String,
rule :: ConstructedParser
}
type ConstructedParser = ([GrammarRule] -> Parser SyntaxTree)
nullGrammar = GrammarRule "" (\_ -> return nulltree)
grToTuple :: GrammarRule -> (String, ConstructedParser)
grToTuple gr = (rulename gr, rule gr)
lookupGrammar :: String -> [GrammarRule] -> Maybe ConstructedParser
lookupGrammar rn grs = lookup rn . map grToTuple $ grs
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
rulename = getRulename st
deflistBuilt = buildDefList deflist
deflist = fromMaybe nulltree
. find (\a -> identifier a == "definitions list")
. children $ st
getRulename :: SyntaxTree -> Identifier
getRulename st =
maybe "&failed" content
. find (\a -> identifier a == "meta identifier")
. children $ st
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
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 = factor
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 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
"optional sequence" -> buildOptionalSequence ch
"repeated sequence" -> buildRepeatedSequence ch
"grouped sequence" -> buildGroupedSequence ch
"special sequence" -> \_ -> return nulltree
"meta identifier" -> buildMetaIdentifier ch
"terminal string" -> buildTerminalString ch
"empty sequence" -> \_ -> return nulltree
otherwise -> \_ -> return nulltree
buildOptionalSequence :: SyntaxTree -> ConstructedParser
buildOptionalSequence st =
option nulltree . deflist
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
parser a
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