0a146bb31945dd13e6f7ad35818f6842ec91ff53nd-- parse the ISO BNF grammar for DOL

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd

0a146bb31945dd13e6f7ad35818f6842ec91ff53ndimport Common.Parsec

7db9f691a00ead175b03335457ca296a33ddf31bnd

0a146bb31945dd13e6f7ad35818f6842ec91ff53ndimport Control.Monad

3577f1d38e53397f6b431c02011f875316b2f070ndimport Data.List

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd

0a146bb31945dd13e6f7ad35818f6842ec91ff53ndimport qualified Data.Set as Set

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd

0a146bb31945dd13e6f7ad35818f6842ec91ff53ndimport Text.ParserCombinators.Parsec

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd

0a146bb31945dd13e6f7ad35818f6842ec91ff53nddata Term =

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd Terminal String

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd | NT String

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd | Alt [Term]

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd | Seq [Term]

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd | Option Term

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd | Many Term Bool

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd

0a146bb31945dd13e6f7ad35818f6842ec91ff53nddata Rule = Rule { lhs :: String, rhs :: Term }

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd

0a146bb31945dd13e6f7ad35818f6842ec91ff53ndlhss :: [Rule] -> [String]

0a146bb31945dd13e6f7ad35818f6842ec91ff53ndlhss = sort . map lhs

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd

3a5c8a7c39f03520463a70cf3f90091dc3a1eb32ndnts :: Bool -> Term -> Set.Set String

0a146bb31945dd13e6f7ad35818f6842ec91ff53ndnts b trm = let unite = Set.unions . map (nts b) in case trm of

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd Terminal s -> if b || isPrefixOf "($<$" s then Set.empty

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd else Set.singleton . init $ tail s

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd NT s -> if b then Set.singleton s else Set.empty

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd Alt l -> unite l

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd Seq l -> unite l

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd Option t -> nts b t

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd Many t _ -> nts b t

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd

0a146bb31945dd13e6f7ad35818f6842ec91ff53ndterms :: Bool -> [Rule] -> Set.Set String

0a146bb31945dd13e6f7ad35818f6842ec91ff53ndterms b = Set.unions . map (nts b . rhs)

0a146bb31945dd13e6f7ad35818f6842ec91ff53nd

0a146bb31945dd13e6f7ad35818f6842ec91ff53ndterminals = terms False

undeclared rs = Set.difference (terms True rs) . Set.fromList $ lhss rs

startsyms rs = Set.difference (Set.fromList $ lhss rs) $ terms True rs

doubles = map head . filter ((> 1) . length) . group . lhss

ppRule :: Rule -> String

ppRule (Rule s t) =

take (max 20 $ length s) (s ++ repeat ' ') ++ " = " ++ (case t of

Alt (f : l) -> ppTerm f

++ concatMap ((("\n" ++ replicate 21 ' ' ++ "| ") ++) . ppTerm) l

_ -> ppTerm t) ++ " ;"

ppRules :: [Rule] -> String

ppRules = unlines . map ppRule

ppTerm :: Term -> String

ppTerm = pppTerm False

pppTerm :: Bool -> Term -> String

pppTerm p trm = case trm of

Terminal s -> s

NT s -> s

Alt l -> let s = intercalate " | " $ map ppTerm l

in if p then "( " ++ s ++ " )" else s

Seq l -> intercalate " , " $ map (pppTerm True) l

Option t -> "[ " ++ ppTerm t ++ " ]"

Many t b -> "{ " ++ ppTerm t ++ " }" ++ if b then "" else "-"

nt :: CharParser st String

nt = tok $ many1 letter

primTerm :: CharParser st Term

primTerm = fmap Terminal (tok sQuoted)

<|> fmap (Terminal . (++ "$>$)"))

(try (string "($<$") <++> manyTill anyChar

(tok . try $ string "$>$)"))

<|> fmap NT nt

<|> (tok (char '(') >> pTerm << tok (char ')'))

<|> fmap Option (tok (char '[') >> pTerm << tok (char ']'))

<|> fmap (\ (t, b) -> Many t (b == "}"))

(pair (tok (char '{') >> pTerm)

(tok (try (string "}-") <|> string "}")))

seqTerm :: CharParser st Term

seqTerm = fmap

(\ l -> case l of

[t] -> t

_ -> Seq l)

. sepBy1 primTerm . tok $ char ','

pTerm :: CharParser st Term

pTerm = fmap

(\ l -> case l of

[t] -> t

_ -> Alt l)

. sepBy1 seqTerm . tok $ char '|'

pRule :: CharParser st Rule

pRule = liftM2 Rule (nt << tok (char '=')) $ pTerm << tok (char ';')

tok :: CharParser st a -> CharParser st a

tok p = p << spaces

main :: IO ()

main = do

str <- getContents

case parse (spaces >> many1 pRule << eof) "" str of

Right e -> do

let prn f = print $ f e

prn length

prn lhss

prn doubles

prn undeclared

prn startsyms

prn terminals

putStr $ ppRules e

Left e -> print e