content: -- parse the ISO BNF grammar for DOL
  
  import Common.Parsec
  
  import Control.Monad
  import Data.List
  
  import qualified Data.Set as Set
  
  import Text.ParserCombinators.Parsec
  
  data Term =
      Terminal String
    | NT String
    | Alt [Term]
    | Seq [Term]
    | Option Term
    | Many Term Bool
  
  data Rule = Rule { lhs :: String, rhs :: Term }
  
  lhss :: [Rule] -> [String]
  lhss = sort . map lhs
  
  nts :: Bool -> Term -> Set.Set String
  nts b trm = let unite = Set.unions . map (nts b) in case trm of
    Terminal s -> if b || isPrefixOf "($<$" s then Set.empty
      else Set.singleton . init $ tail s
    NT s -> if b then Set.singleton s else Set.empty
    Alt l -> unite l
    Seq l -> unite l
    Option t -> nts b t
    Many t _ -> nts b t
  
  terms :: Bool -> [Rule] -> Set.Set String
  terms b = Set.unions . map (nts b . rhs)
  
  terminals = 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 $ letter <:> many (letter <|> digit <|> oneOf "-_")
  
  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
  