-- <PRE>

module Parser where

import qualified System.IO
import Data.Char(digitToInt,isUpper)
import GHC.Float(double2Float)

-- These are for defining parsers
import Text.Parsec hiding (State)
import Text.Parsec.Expr(Operator(..),Assoc(..),buildExpressionParser)
-- Replaces Text.Parsec.Token
import qualified LayoutToken as Token

-- This is for possible Monads underlying the Parsing Monad
import Control.Monad.State
import Data.Functor.Identity(Identity(..))

-- This is to catch errors when Parsing
import qualified Control.Exception

import Debug.Trace


-- import the Hughes Pretty Printing library qualified
import qualified Text.PrettyPrint.HughesPJ as PP
-- import a few widely used operations without qualification
import Text.PrettyPrint.HughesPJ(Doc,text,int,(<>),(<+>),($$),($+$),render)


-----------------------------------------------
-- running parsers

-- Extract a computation from the Parser Monad
runMParser parser parserState name tokens =
  runIdentity (runParserT parser parserState name tokens)

-- Skip whitespace before you begin
parse1 file x = runMParser (whiteSp >> x) initColumns file

-- Raise an Haskell error if a parsing error occurs
parseWithName file x s =
  case parse1 file x s of
   Right(ans) -> ans
   Left message -> error (show message)

-- Parse with a default name for the input
parse2 x s = parseWithName "keyboard input" x s

-- Parse and return the internal state
parse3 p s = putStrLn (show state) >> return object
  where (object,state) = parse2 (do { x <- p; st <- getState; return(x,st)}) s

-- Parse an t-object, return
-- (t,rest-of-input-not-parsed)
parse4 p s =
   parse2 (do { x <- p
              ; rest <- getInput
              ; return (x,rest)}) s

-- Parse a string in an arbitray monad
parseString x s =
  case parse1 s x s of
   Right(ans) -> return ans
   Left message -> fail (show message)

-- Parse a File in the IO monad
parseFile parser file =
    do possible <- Control.Exception.try (readFile file)
       case possible of
         Right contents ->
            case parse1 file parser contents of
              Right ans -> return ans
              Left message -> error(show message)
         Left err -> error(show (err::IOError))

--------------------------------------------
-- A parser with internal state of a list of columns
-- use (updateState,setState,getState) to access the [Column]

-- for debugging only
traceP p = do { ((c,vs),_) <- getState; ans <- p; ((d,us),_) <- getState
              ; trace ("In  "++show c++"\nOut "++show d) (return ans)}

initColumns = []

type MParser a = ParsecT
                    String                -- The input is a sequence of Char
                    [Column]              -- The internal state for Layout tabs
                    (Identity)            -- The underlying monad is simple
                    a                     -- the type of the object being parsed

-- Based on Parsec's haskellStyle (which we can not use directly since
-- Parsec gives it a too specific type).

lbStyle = Token.LanguageDef
                { Token.commentStart   = "{-"
                , Token.commentEnd     = "-}"
                , Token.commentLine    = "--"
                , Token.nestedComments = True
                , Token.identStart     = lower
                , Token.identLetter    = alphaNum <|> oneOf "_'"
                , Token.opStart        = oneOf ":!#$%&*+./<=>?@\\^|-~"
                , Token.opLetter       = oneOf ":!#$%&*+./<=>?@\\^|-~"
                , Token.caseSensitive  = True
                , Token.reservedOpNames =
                    ["!","?","\\",":",".", "<", "=", "+", "-", "^", "()", "_", "@"]
                , Token.reservedNames  =
                  ["if","then","else","case","of","let","in"]
                }


(haskellTP,Token.LayFun layout) = Token.makeTokenParser lbStyle "{" ";" "}"

lexemE p    = Token.lexeme haskellTP p
arrow       = lexemE(string "->")
larrow      = lexemE(string "<-")
dot         = lexemE(char '.')
parenS p    = between (symboL "(") (symboL ")") p
braceS p    = between (symboL "{") (symboL "}") p
bracketS p  = between (symboL "[") (symboL "]") p
symboL      = Token.symbol haskellTP
natural     = lexemE(number 10 digit)
whiteSp     = Token.whiteSpace haskellTP
idenT       = Token.identifier haskellTP
keyworD     = Token.reserved haskellTP
commA       = Token.comma haskellTP
resOp       = Token.reservedOp haskellTP
opeR        = Token.operator haskellTP
character c = lexemE(char c)


---------------------------------------------------------------

number ::  Integer -> MParser Char -> MParser Integer
number base baseDigit
    = do{ digits <- many1 baseDigit
        ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits
        ; seq n (return n)
        }

signed p = do { f <- sign; n <- p ; return(f n)}
  where sign = (character '-' >> return (* (-1))) <|>
               (character '+' >> return id) <|>
               (return id)

int32:: MParser Int
int32 = do { n <- signed natural; return(fromInteger n)} <?> "<Int Literal>"

float32:: MParser Float
float32 = do { n <- Token.float haskellTP ; return(double2Float n)} <?> "<Float Literal>"

letParser declP expP =
  do { pos <- getPosition   -- This gets the SourcePos
     ; keyworD "let"
     ; ds <- layout declP (keyworD "in")
     ; exp <- expP
     ; return(ds,exp)}


------------------------------------------------------------------

type Var = (SourcePos,String)  -- Starts lowercase
type Con = (SourcePos,String)  -- Starts with Upper case
type Name = (SourcePos,String) -- Starts with either lower case or uppercase

data Lit
  = Int Int
  | Char Char
  | Unit
  | Float Float

data Pat
  = Plit Lit                  -- { 5 or 'c' }
  | Pvar Var                  -- { x }
  | Pprod [Pat]               -- { (p1,p2,p3) }
  | Paspat Var Pat            -- { x @ p }
  | Pwild                     -- { _ }
  | Pcon Con [Pat]            -- C x y (z,a)


data Exp
  = Var Name                   -- { x  or  Nil }
  | Lit Lit                   -- { 5 or 'c'  or  5.6 }
  | Prod [Exp]                -- { (e1,e2,e3) }
  | App Exp Exp               -- { f x }
  | Lam [Pat] Exp             -- { \ p1 p2 -> e }
  | Let [Dec] Exp             -- { let { x=e1;   y=e2 } in e3 }
  | Case Exp [Match Pat Exp Dec]    -- { case e of { m1; m2 }}
  | Do [Stmt Pat Exp Dec]           -- { do { p <- e1; e2 } }

-- Let, Case, Do, all use layout

type Match p e d = (SourcePos,p,Body e,[d]) -- case e of { p -> b where decs }

data Body e
  = Guarded [(e,e)]           -- f p { | e1 = e2 | e3 = e4 } where ds
  | Normal e                  -- f p = { e } where ds
                              -- Where uses layout

data Stmt p e d
  = BindSt SourcePos p e
  | LetSt SourcePos [d]
  | NoBindSt SourcePos e

data Dec
  = Fun SourcePos Var [Match [Pat] Exp Dec]   -- { f p1 p2 = b where decs }
  | Val SourcePos Pat (Body Exp) [Dec]        -- { p = b where decs }


------------------------------
-- Parsing code here








---------------------------------
-- Pretty printing code here


ppDec:: Dec -> Doc
ppDec = undefined


ppLit:: Lit -> Doc
ppLit = undefined


ppExp:: Exp -> Doc
ppExp = undefined


ppPat:: Pat -> Doc
ppPat = undefined

ppBody:: (e -> Doc) -> Body e -> Doc
ppBody = undefined


ppStmt :: (p -> Doc) -> (e -> Doc) -> (d -> Doc) -> Stmt p e d -> Doc
ppStmt = undefined


ppProg :: [Dec] -> Doc
ppProg = undefined



--------------------------------
-- The main functions here


main :: IO()
main = undefined


test:: IO()
test = undefined


-- </PRE>