module Main where

import Char (isSpace)
import System (getArgs)

-- The Word's Smallest Compiler Compiler. AR 27/1/2003.
-- The grammar file syntax is the same as in BNFC, except that
-- every rule must be on one line, and there are no predefined categories.

main :: IO ()
main = do
  file:_ <- getArgs
  cfTop file


-- the type of context-free grammars

type CF   = [Rule]
type Rule = (Fun, (Cat, [Either Cat Tok]))

type Cat = String
type Tok = String
type Fun = String
type Str = [Tok]

firstCat :: CF -> Cat
firstCat = fst . snd . head

rulesForCat :: CF -> Cat -> [Rule]
rulesForCat cf cat = [r | r@(_,(c,_)) <- cf, c==cat] 


-- the type of syntax trees

newtype Tree = Tree (Fun,[Tree])


-- parser for non-left-recursive grammars

pTree :: CF -> Cat -> Parser Tok Tree
pTree cf cat = foldr (|||) fails (map pRule (rulesForCat cf cat))
  where
    pRule (fun, (_,its)) = pIts its *** (\trees -> Tree (fun,trees))
    pIts (Left  c : ts) = (pTree cf c ... pIts ts) *** (uncurry (:))
    pIts (Right s : ts) = (lit s      ... pIts ts) *** snd
    pIts [] = succeed []


-- to print syntax trees

prTree :: Tree -> String
prTree (Tree ("_",[t])) = prTree t -- coercion
prTree (Tree (fun,[])) = fun 
prTree (Tree (fun,trees)) = unwords (fun : map pr2 trees) where
  pr2 t@(Tree (_,ts)) = if (null ts) then (prTree t) else ("(" ++ prTree t ++ ")")


-- grammar parser: one rule/line, format fun. C ::= (C | "s")* ";"

getCF :: String -> CF
getCF = concat . map (getcf . init . words) . filter isRule . lines where
  getcf (fun : cat : "::=" : its) = return (init fun, (cat, map mkIt its))
  getcf ww = []
  mkIt ('"':w@(_:_)) = Right (init w)
  mkIt w             = Left  w
  isRule line = not (all isSpace line || take 2 line == "--")

-- top loop: read a grammar from a file and parse strings

cfTop :: FilePath -> IO ()
cfTop file = do
  s <- readFile file
  let cf = getCF s
      cat = firstCat cf
      parser = pTree cf cat
  putStrLn $ show (length cf) ++ " rules"
  loopP cat parser

loopP :: Cat -> Parser Tok Tree -> IO ()
loopP cat parser = do
  putStr $ cat ++ "> "
  s <- getLine
  if s == "." then return () else do
    putStrLn $ unlines $ map prTree $ parseResults parser $ words s
    loopP cat parser


-- auxiliary: parser combinators à la Wadler and Hutton

type Parser a b = [a] -> [(b,[a])]

parseResults :: Parser a b -> [a] -> [b]
parseResults p s = [x | (x,r) <- p s, null r]

(...) :: Parser a b -> Parser a c -> Parser a (b,c)
(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t]

(|||) :: Parser a b -> Parser a b -> Parser a b
(p ||| q) s = p s ++ q s

lit :: (Eq a) => a -> Parser a a
lit x (c:cs) = [(x,cs) | x == c]
lit _ _ = []

(***) :: Parser a b -> (b -> c) -> Parser a c
(p *** f) s = [(f x,r) | (x,r) <- p s] 

succeed :: b -> Parser a b
succeed v s = [(v,s)]

fails :: Parser a b
fails s = []