-- MainOnePass.hs
--
-- One pass compiler example from lecture 12.
--
-- compilation:
--      ghc --make MainOnePass.hs -o onepass
--
-- usage:
--      ./onepass < infile
--      ./onepass < infile > outfile
--
{-|   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

{-| (1) Null compiler 
main = do
  file_as_str <- getContents
  let out = file_as_str
  putStr out
-}

{-| (2) Calling the lexer
main = do
  file_as_str <- getContents
  let out = lexer file_as_str
  print out
-}



{-| (3) Calling the parser that just returns duplicates input.
main = do
  file_as_str <- getContents
  let out = parser $ lexer file_as_str
  putStr out
-}


{-| (4) Calling the parser that does translation plugging in 
        appropriate values for colors. -}
main = do
  file_as_str <- getContents
  let out = parserCodeGen $ lexer file_as_str
  putStr out


----------------------------------------------------------
-- 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 just parrots the input back

parser :: [Token] -> String
parser ts = str where (str,_) = parseSprime ts


-- S'    ::= Slist EOF
parseSprime :: [Token] -> (String,[Token])
parseSprime (TokenEOF:ts)     = parseSlist (TokenEOF: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] -> (String,[Token])
parseSlist (TokenEOF:ts)        = ("",ts)
parseSlist (TokenPrintkw:ts)    =
    let (strS,ts1)      = parseS (TokenPrintkw:ts)
        (strSlist,ts2)  = parseSlist ts1
    in
        (strS ++ strSlist, ts2)


-- S     ::= “print” COLOR_LITERAL EOL
parseS :: [Token] -> (String,[Token])
parseS ts =
    let ts1         = match ts TokenPrintkw
        (c,ts2)     = matchAndGrabColor ts1
    in
        ("print " ++ (show c) ++ "\n", 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))


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

parserCodeGen :: [Token] -> String
parserCodeGen ts = str where (str,_) = parseSprimeCG ts


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

-- Slist ::= epsilon | S Slist
parseSlistCG :: [Token] -> (String,[Token])
parseSlistCG (TokenEOF:ts)        = ("",ts)
parseSlistCG (TokenPrintkw:ts)    =
    let (strS,ts1)      = parseSCG (TokenPrintkw:ts)
        (strSlist,ts2)  = parseSlistCG ts1
    in
        (strS ++ strSlist, ts2)


-- S     ::= “print” COLOR_LITERAL EOL
parseSCG :: [Token] -> (String,[Token])
parseSCG ts =
    let ts1         = match ts TokenPrintkw
        (c,ts2)     = matchAndGrabColor ts1
    in
        ("Meggy.setPixel((byte)1,(byte)1," ++ (show c) ++ ");" ++ "\n", ts2)