-- MainASTvizStart.hs
--
-- Parses an example input language, creates an AST, and
-- then illustrates a pass over the AST that generates
-- a dot file.
--
-- compilation:
--      ghc --make MainASTvizStart.hs -o astviz
--
-- usage:
--      ./astviz < infile
--      ./astviz < infile > outfile.dot
--
{-|   Context Free Grammar

S'    ::= Slist EOF
Slist ::= epsilon | S Slist
S     ::= “print” COLOR_LITERAL


COLOR_LITERAL tokens can be "Meggy.Color.BLUE" and "Meggy.Color.RED".
RED 1, BLUE 5


            Nullable    FIRST                       FOLLOW
            --------    -----                       ------
S'           no         {EOF, "print}               {}

Slist        yes        {"print"}                   {EOF}

S            no         {"print"}                   {EOF, "print"}

-}

module Main where

-- needed for isAlpha, isSpace, and span(?)
import Data.Char

----------------------------------------------------------
-- Abstract Syntax Tree Datatype
data AST 
        = StmList [AST]
        | PrintStm Int
    deriving Show

----------------------------------------------------------
main = do
  file_as_str <- getContents
  let out =  astdotviz $ parser $ lexer file_as_str
  putStr out

----------------------------------------------------------
-- Generation of dot code to help visualize the AST.
-- Numbering nodes using pre-order.
astdotviz :: AST -> String
astdotviz ast = dotstr where (_,dotstr) = astdotviz_rec 0 1 ast

-- The first input integer is the parent id.
-- The second input integer is the next id to use.
-- The returned id is the last id that was used in this subtree.
astdotviz_rec :: Int -> Int -> AST -> (Int,String)
astdotviz_rec pid myid astnode =
    let
        prefix = (show myid) ++ " [label = \""
        suffix = "\"];\n"
    in
        case astnode of
            (StmList stms) ->
                let (maxChild,subTreeStr) =
                        visitChildren myid (myid+1) stms
                in
                    (maxChild,subTreeStr++prefix++"StmtList"++suffix)
            
            (PrintStm n) -> (myid, prefix++"PrintStm "++(show n)++suffix)
    
-- Here visiting children ASTs in order and passing the parent id
-- and next id to use to the next child.
-- Can be used by any astnode that contains a list of AST nodes as
-- its child.
visitChildren :: Int -> Int -> [AST] -> (Int,String)
visitChildren pid myid [] = (myid,"")
visitChildren pid myid (x:xs) =
    let (xmax,xstr) = astdotviz_rec pid myid x
        (maxid,str) = visitChildren pid (xmax+1) xs
    in  (maxid,xstr++str)


----------------------------------------------------------
-- lexer for example
data Token
      = TokenEOF
      | TokenPrintkw
      | TokenColor Int
      | UnknownChar Char
    deriving (Show,Eq)
    
lexer :: String -> [Token]
lexer [] = [TokenEOF]
lexer ('M':cs) = lexKW ('M':cs)
lexer ('p':cs) = lexKW ('p':cs)
lexer (c:cs) 
      | isSpace c = lexer cs
      | True      = UnknownChar c : lexer cs

lexKW cs =
   case span isAlphaOrDot cs of
      ("print",rest)              -> TokenPrintkw    : lexer rest
      ("Meggy.Color.BLUE",rest)   -> TokenColor 5    : lexer rest
      ("Meggy.Color.RED",rest)    -> TokenColor 1    : lexer rest
      (str,rest)       -> error (str ++ " is not a known token.")

isAlphaOrDot c
    | isAlpha c = True
    | c == '.'  = True
    | True      = False

----------------------------------------------------------
-- predictive parser that creates an AST

parser :: [Token] -> AST
parser ts = ast where (ast,_) = parseSprime ts


-- S'    ::= Slist EOF
parseSprime :: [Token] -> (AST,[Token])
parseSprime (TokenEOF:ts)     = parseSlist (TokenPrintkw:ts)
parseSprime (TokenPrintkw:ts) = parseSlist (TokenPrintkw:ts)
parseSprime (t:ts) 
    = error ("Parse error: expected EOF or print and got " ++ (show t))

-- Slist ::= epsilon | S Slist
parseSlist :: [Token] -> (AST,[Token])
parseSlist (TokenEOF:ts)        = (StmList [],ts)
parseSlist (TokenPrintkw:ts)    =
    let (stm,ts1)               = parseS (TokenPrintkw:ts)
        (StmList stms,ts2)      = parseSlist ts1
    in
        (StmList (stm:stms), ts2)


-- S     ::= “print” COLOR_LITERAL EOL
parseS :: [Token] -> (AST,[Token])
parseS ts =
    let ts1         = match ts TokenPrintkw
        (c,ts2)     = matchAndGrabColor ts1
    in
        (PrintStm c, ts2)


-- match expected token, otherwise throw exception
-- Works for all tokens that don't have extra data associated with them.
match :: [Token] -> Token -> [Token]
match (given:ts) expect = if given==expect then ts 
                          else error ("Parse error: expected " 
                                      ++ (show expect)
                                      ++ ", but found "
                                      ++ (show given))

-- Check that have an color token and grab the value and
-- return value and rest of token list.
matchAndGrabColor :: [Token] -> (Int,[Token])
matchAndGrabColor ((TokenColor c):ts) = (c,ts)
matchAndGrabColor ts 
    = error ("Parse error: expected a color token " ++ (show ts))