-- Parser for McKeeman's X, above the level of expression

import Parser
import Data.Char	-- for isAlpha, etc
import System(getArgs)

-- ------------------- TOKENS ------------------------

letter = char isAlpha

white, identifier, integer :: Parser String

white = some (char (`elem` " \t\n")) `orelse` nil

identifier = do
		c <- letter
		cs <- some (char isAlphaNum) `orelse` nil
		return (c:cs)

integer = some (char isDigit)

keyword s = do
		white
		string s
		white

eof :: Parser ()
eof = do	
		b<-isPresent next
		if b then zero else return ()

-- ------------- SYNTACTIC CATEGORIES ----------------------

data Cat = Prog [Cat]
	 | If [Cat]
	 | Do [Cat]
	 | Cond Expr [Cat]
	 | Assign [Var] [Expr]
	 | Call [Var] Name [Expr]
	 | Bad
	   deriving Show

data Expr = Expr Name deriving Show
type Var = Name
type Name = String

program :: Parser Cat
program = do
		white
		xs<-stmts
		eof
		return (Prog xs)
	  `orelse` return Bad

stmts = seplist stmt (keyword ";")

stmt = selection `orelse` iteration `orelse` assignment

selection = do
		keyword "if"
		as<-alts
		keyword "fi"
		return (If as)

iteration = do
		keyword "do"
		as<-alts
		keyword "od"
		return (Do as)

alts = seplist alt (keyword "::")

alt = do
		g<-expr
		keyword "?"
		xs<-stmts
		return (Cond g xs)

expr = do
		i<-identifier
		return (Expr i)

exprs = seplist expr (keyword ",")

vars = do
		vs<-seplist identifier (keyword ",")
		return vs

assignment = (do
		vs<-vars
		keyword ":="
		p<-identifier
		keyword ":="
               	es<-(exprs `orelse` nil)
		return (Call vs p es))
     `orelse`(do
		vs<-vars
		keyword ":="
		es<-exprs
		return (Assign vs es))

-- --------------- INTERACTIVE TESTING -----------------------

{- Read programs, one per line, and print their parses.
   Interrupt to terminate. 

   Hugs usage (assuming this code is in Xparse.hs
  	hugs Xparse.hs
  	tests
  	<one X program per line>
   GHC usage--warning ghci does raw IO by default
  	ghci Xparse.hs
  	tests
  	<one X program per line>
-}

tests = do 
		s<-getLine
		print [fst x| x<-apply program s]
		tests ::IO ()

-- --------------- STANDALONE PARSER -------------------------

{- Hugs usage, to parse an X program named p.x
  	runhugs Xparse.hs p.x
   GHC usage
  	ghc --make Xparse.hs
        ./a.out p.x
-}

main = do
	[f]<-getArgs
	src<-readFile f
	print[fst x| x<-apply program src]