
-- ==========================================================--
-- === Raw lexical analysis (tokenisation) of source      ===--
-- ===                                           Lexer.hs ===--
-- ==========================================================--

module Main where
-- import Char -- 1.3
----------------------------------------------------------
-- Lexemes                                              --
----------------------------------------------------------

type Token = (Int, Int, Lex, String) -- (line, column, lexeme type, value)

data Lex = Lcon             -- constructor used as prefix:
                            -- normal prefix constructor,
                            -- or bracketed infix constructor

         | Lconop           -- constructor used as infix:
                            -- normal prefix constructor in backquotes,
                            -- or infix constructor (starting with ":")

         | Lvar             -- variable used as prefix:
                            -- normal prefix variable,
                            -- or bracketed infix var (operator)

         | Lvarop           -- variable used as infix:
                            -- normal prefix variable in backquotes,
                            -- or infix variable (operator)

         -- | Ltycon           -- constructor starting with A-Z
                              -- subcase of Lcon

         -- | Ltyvar           -- variable starting with a-z
                              -- subcase of Lvar

         | Lintlit          -- integer literal
         | Lcharlit         -- character literal
         | Lstringlit       -- string literal

         | Llbrace          --  {
         | Lrbrace          --  }
         | Lsemi            --  ;
         | Lequals          --  =
         | Lbar             --  |
         | Larrow           --  ->
         | Llparen          --  (
         | Lrparen          --  )
         | Lcomma           --  ,
         | Llbrack          --  [
         | Lrbrack          --  ]
         | Lunder           --  _
         | Lminus           --  -
         | Lslash           --  \

         | Lmodule
         | Linfixl
         | Linfixr
         | Linfix
         | Lext
         | Ldata
         | Lif
         | Lthen
         | Lelse
         | Llet
         | Lin
         | Lcase
         | Lof
         | Lwhere

         | Leof -- deriving (Eq, Show{-was:Text-})

eqLex :: Lex -> Lex -> Bool
eqLex Lcon Lcon = True
eqLex Lconop Lconop = True
eqLex Lvar Lvar = True
eqLex Lvarop Lvarop = True

eqLex Lintlit Lintlit = True          -- integer literal
eqLex Lcharlit Lcharlit = True         -- character literal
eqLex Lstringlit Lstringlit = True       -- string literal

eqLex Llbrace Llbrace = True          --  {
eqLex Lrbrace Lrbrace = True          --  }
eqLex Lsemi Lsemi = True            --  ;
eqLex Lequals Lequals = True          --  =
eqLex Lbar Lbar = True             --  |
eqLex Larrow Larrow = True           --  ->
eqLex Llparen Llparen = True          --  (
eqLex Lrparen Lrparen = True          --  )
eqLex Lcomma Lcomma = True           --  ,
eqLex Llbrack Llbrack = True          --  [
eqLex Lrbrack Lrbrack = True          --  ]
eqLex Lunder Lunder = True           --  _
eqLex Lminus Lminus = True           --  -
eqLex Lslash Lslash = True           --  \

eqLex Lmodule Lmodule = True
eqLex Linfixl Linfixl = True
eqLex Linfixr Linfixr = True
eqLex Linfix Linfix = True
eqLex Lext Lext = True
eqLex Ldata Ldata = True
eqLex Lif Lif = True
eqLex Lthen Lthen = True
eqLex Lelse Lelse = True
eqLex Llet Llet = True
eqLex Lin Lin = True
eqLex Lcase Lcase = True
eqLex Lof Lof = True
eqLex Lwhere Lwhere = True

eqLex Leof Leof = True -- deriving (Eq, Show{-was:Text-})

eqLex _ _ = False

{- 
   Lexing rules:

   case (
      if next is \,                                         -> Llparen
      if next is symbol, take symbols and expect closing )  -> Lvar
      if next is :, take tail-ident-chars, expect closing ) -> Lcon
      otherwise                                             -> Llparen

   case `
      if next A-Z, take tail-ident-chars, expect `          -> Lconop
      if next a-z, take tail-ident-chars, expect `          -> Lvarop
      otherwise                                             -> error

   case A-Z
      take tail-ident-chars                                 -> Lcon

   case a-z
      take tail-ident-chars                                 -> Lvar

   case 0-9
      take 0-9s                                             -> Lintlit

   case '
      expect a lit-char, then '                             -> charlit

   case "
      expect lit-chars, then "                              -> stringlit

   case {
      case -                                                -> run_comment
      otherwise                                             -> Llbrace

   case }                                                   -> Lrbrace

   case )                                                   -> Lrparen

   case [                                                   -> Llbrack
   case ]                                                   -> Lrbrack

   case ;                                                   -> Lsemi
   case ,                                                   -> Lcomma
   case _                                                   -> Lunder
   case -
      case -                                                -> line_comment
      case >                                                -> Larrow
      otherwise                                             -> Lminus

   case # in column 1: this is a preprocessor line

   case :!#$%&*+./<=>?@\^|~
      take symbols, then case resulting
         "="                                                -> Lequals
         "|"                                                -> Lbar
         "\"                                                -> Lslash
         otherwise
            if starts with :                                -> Lconop
            else                                            -> lvarop
-}



-- ==========================================================--
--
leLex :: Int -> Int -> String -> [Token]

leLex l n [] 
   = repeat (99997, 99997, Leof, "")

leLex l n ('(':[])
   = [(l, n, Llparen, ")")]

leLex l n ('(':c:cs)
   | c `eqChar` ':'
   = case leChunk (n+1) leIsTailChar cs of
        (restSym, nn, restInput) -> case restInput of
           []        -> leFail l nn "  )  expected"
           (')':as)  -> (l, n, Lvar, c:restSym) : leLex l (nn+1) as
           (_:_)     -> leFail l nn "  )  expected"
   | c `eqChar` '\\'
   = (l, n, Llparen, "(") : leLex l (n+1) (c:cs)
   | leIsSymbol c
   = case leChunk (n+1) leIsSymbol cs of
        (restSym, nn, restInput) -> case restInput of
           []        -> leFail l nn "  )  expected"
           (')':as)  -> (l, n, Lvar, c:restSym) : leLex l (nn+1) as
           (_:_)     -> leFail l nn "  )  expected"
   | otherwise
   = (l, n, Llparen, "(") : leLex l (n+1) (c:cs)

leLex l n ('`':c:cs)
   | isAlpha c
   = case leChunk (n+1) isAlpha cs of
        (restSym, nn, restInput) -> case restInput of
           []        -> leFail l nn "  `  expected"
           ('`':as)  -> (l, n, if isUpper c then Lconop else Lvarop, c:restSym) 
                        : leLex l (nn+1) as
           (_:_)     -> leFail l nn "  `  expected"
   | otherwise
   = leFail l n "Bad infix operator"

leLex l n ('"':cs)
   = case leTakeLitChars True l (n+1) cs of
        (restSym, nn, restInput) -> case restInput of
           []        -> leFail l nn "  \"  expected"
           ('"':as)  -> (l, n, Lstringlit, restSym) : leLex l (nn+1) as
           (_:_)     -> leFail l nn "  \"  expected"

leLex l n ('\'':cs)
   = case leTakeLitChars False l (n+1) cs of
        (restSym, nn, restInput) -> case restInput of
           []        -> leFail l nn "  '  expected"
           ('\'':as) -> case restSym of
                           [_] -> (l, n, Lcharlit, restSym) : leLex l (nn+1) as
                           _   -> leFail l (n+1) "Bad character literal"
           (_:_)     -> leFail l nn "  '  expected"

leLex l n ('}':cs)
   = (l, n, Lrbrace, "}") : leLex l (n+1) cs

leLex l n (')':cs)
   = (l, n, Lrparen, ")") : leLex l (n+1) cs

leLex l n ('[':cs)
   = (l, n, Llbrack, "[") : leLex l (n+1) cs

leLex l n (']':cs)
   = (l, n, Lrbrack, "]") : leLex l (n+1) cs

leLex l n (';':cs)
   = (l, n, Lsemi, ";") : leLex l (n+1) cs

leLex l n (',':cs)
   = (l, n, Lcomma, ",") : leLex l (n+1) cs

leLex l n ('_':cs)
   = (l, n, Lunder, "_") : leLex l (n+1) cs

leLex l n ('{':cs)
   = case cs of
        []         -> [(l, n, Llbrace, "}")]
        ('-':cs2)  -> leLexRComment l (n+2) cs2
        (_:_)      -> (l, n, Llbrace, "}") : leLex l (n+1) cs

leLex l n ('-':cs)
   = case cs of
        []         -> [(l, n, Lminus, "-")]
        ('-':cs2)  -> leLexLComment l (n+2) cs2
        ('>':cs3)  -> (l, n, Larrow, "->") : leLex l (n+2) cs3
        ('}':cs3)  -> leFail l n "Misplaced -}"
        (_:_)      -> (l, n, Lminus, "-") : leLex l (n+1) cs

leLex l n (' ':cs) 
   = leLex l (n+1) cs

leLex l n ('\n':cs)
   = leLex (l+1) 1 cs

leLex l n ('\t':cs)
   = leLex l (n - (n `mod` 8) + 9) cs

leLex l n (c:cs)
   = if   c `eqChar` '#'
     then if n == 1
          then
          {- This is a CPP line number thingy -}
          let lineNoText  = takeWhile isDigit (tail cs)
              lineNo      = leStringToInt lineNoText
              nextLine    = drop 1 (dropWhile (\x -> not (eqChar '\n' x)) cs)
          in
              leLex lineNo 1 nextLine
          else
          {- it's a symbol starting with # -}
          case leChunk (n+1) leIsSymbol cs of
             (restSym, nn, restText) -> (l, n, Lvarop, c:restSym) :
                                        leLex l nn restText
     else
     if   isAlpha c
     then case leChunk (n+1) leIsTailChar cs of
             (restSym, nn, restText) -> (l, n, if   isUpper c 
                                               then Lcon 
                                               else Lvar, c:restSym) :
                                        leLex l nn restText 
     else
     if   isDigit c
     then case leChunk (n+1) isDigit cs of
             (restSym, nn, restText) -> (l, n, Lintlit, c:restSym) :
                                        leLex l nn restText 
     else
     if   leIsSymbol c
     then case leChunk (n+1) leIsSymbol cs of
             (restSym, nn, restText) -> (l, n, if   c `eqChar` ':' 
                                               then Lconop 
                                               else Lvarop, c:restSym) :
                                        leLex l nn restText 
     else
     leFail l n ("Illegal character  " ++ [c])


-- ==========================================================--
--
leChunk :: Int -> (Char -> Bool) -> String -> (String, Int, String)

leChunk n proper [] 
  = ([], n, [])

leChunk n proper (c:cs)
  | proper c        
  = case leChunk (n+1) proper cs of
       (restId, col, restInput) -> (c:restId, col, restInput)
  | otherwise
  = ([], n, c:cs)


-- ==========================================================--
--
leTakeLitChars :: Bool -> Int -> Int -> String -> (String, Int, String)

leTakeLitChars d l n []
  = leFail l n "End of file inside literal"

leTakeLitChars d l n ('\\':'\\':cs)
  = case leTakeLitChars d l (n+2) cs of
       (rest, col, left) -> ('\\':rest, col, left)

leTakeLitChars d l n ('\\':'n':cs)
  = case leTakeLitChars d l (n+2) cs of
       (rest, col, left) -> ('\n':rest, col, left)

leTakeLitChars d l n ('\\':'t':cs)
  = case leTakeLitChars d l (n+2) cs of
       (rest, col, left) -> ('\t':rest, col, left)

leTakeLitChars d l n ('\\':'"':cs)
  = case leTakeLitChars d l (n+2) cs of
       (rest, col, left) -> ('"':rest, col, left)

leTakeLitChars d l n ('\\':'\'':cs)
  = case leTakeLitChars d l (n+2) cs of
       (rest, col, left) -> ('\'':rest, col, left)

leTakeLitChars d l n ('"':cs)
  | d      = ([], n, ('"':cs))
  | not d  = case leTakeLitChars d l (n+1) cs of
                (rest, col, left) -> ('"':rest, col, left)

leTakeLitChars d l n ('\'':cs)
  | not d  = ([], n, ('\'':cs))
  | d      = case leTakeLitChars d l (n+1) cs of
                (rest, col, left) -> ('\'':rest, col, left)

leTakeLitChars d l n ('\n':cs)
  = leFail l n "Literal exceeds line"

leTakeLitChars d l n ('\t':cs)
  = leFail l n "Literal contains tab"

leTakeLitChars d l n (c:cs)
  = case leTakeLitChars d l (n+1) cs of
       (rest, col, left) -> (c:rest, col, left)


-- ==========================================================--
--
leLexLComment :: Int -> Int -> String -> [Token]

leLexLComment l n cs
   = leLex (l+1) 1 (drop 1 (dropWhile (\x -> not (eqChar '\n' x)) cs))


-- ==========================================================--
--
leLexRComment :: Int -> Int -> String -> [Token]

leLexRComment l n [] 
   = leFail l n "End of file inside {- ... -} comment"

leLexRComment l n ('-':'}':cs)
   = leLex l (n+2) cs

leLexRComment l n ('\n':cs)
   = leLexRComment (l+1) 1 cs

leLexRComment l n ('\t':cs)
   = leLexRComment l (n - (n `mod` 8) + 9) cs

leLexRComment l n (c:cs)
   = leLexRComment l (n+1) cs


-- ==========================================================--
--
leIsSymbol :: Char -> Bool

leIsSymbol c = elemBy eqChar c leSymbols

leSymbols = ":!#$%&*+./<=>?\\@^|~"


-- ==========================================================--
--
leIsTailChar :: Char -> Bool

leIsTailChar c 
   = isLower c || 
     isUpper c || 
     isDigit c || 
     c `eqChar` '\'' || 
     c `eqChar` '_'  ||
     c `eqChar` '\''


-- ==========================================================--
--
leIsLitChar :: Char -> Bool

leIsLitChar c
   = c `neqChar` '\n' &&
     c `neqChar` '\t' &&
     c `neqChar` '\'' &&
     c `neqChar` '"'

neqChar c1 c2 = not (eqChar c1 c2)

-- ==========================================================--
--
leStringToInt :: String -> Int

leStringToInt
   = let s2i []      = 0
         s2i (d:ds)  = (ord d - ord '0') + 10 *s2i ds
     in s2i . reverse


-- ==========================================================--
--
leFail l n m
  = faiL ("Lexical error, line " ++ showInt l ++ ", col " ++ showInt n ++ 
          ":\n   " ++ m )

faiL m = error ( "\n\n" ++ m ++ "\n" )

-- ==========================================================--
-- === end                                       Lexer.hs ===--
-- ==========================================================--

-- ==========================================================--
-- === Keyword spotting, and offside rule implementation  ===--
-- ===                                          Layout.hs ===--
-- ==========================================================--

--module Layout

-- ==========================================================--
--
laKeyword :: Token -> Token

laKeyword (l, n, what, text) 
   = let
        f Lvarop "="      = Lequals
        f Lvarop "|"      = Lbar
        f Lvarop "\\"     = Lslash

        f Lvar "module"   = Lmodule
        f Lvar "infix"    = Linfix
        f Lvar "infixl"   = Linfixl
        f Lvar "infixr"   = Linfixr
        f Lvar "ext"      = Lext
        f Lvar "data"     = Ldata
        f Lvar "if"       = Lif
        f Lvar "then"     = Lthen
        f Lvar "else"     = Lelse
        f Lvar "let"      = Llet
        f Lvar "in"       = Lin
        f Lvar "case"     = Lcase
        f Lvar "of"       = Lof
        f Lvar "where"    = Lwhere

        f item words      = item
        
     in
         (l, n, f what text, text)


-- ==========================================================--
--
laLayout :: Int -> [Int] -> [Token] -> [Token]

laLayout l s []
   = laRbrace (length s - 1) 99999 99999

laLayout l s (t1:[])
   = t1 : laRbrace (length s - 1) 99998 99998

laLayout l (s:ss) (t1@(l1, n1, w1, c1) :
                   t2@(l2, n2, w2, c2) : ts)

   | elemBy eqLex w1 [Lof, Llet, Lwhere] && not (w2 `eqLex` Llbrace)
   = t1 :
     (l1, n1, Llbrace, "{") :
     t2 :
     laLayout l2 (n2:s:ss) ts 

   | l1 == l
   = t1 :
     laLayout l (s:ss) (t2:ts)

   | n1 > s
   = t1 :
     laLayout l1 (s:ss) (t2:ts)

   | n1 == s
   = (l1, n1, Lsemi, ";") :
     t1 :
     laLayout l1 (s:ss) (t2:ts)

   | n1 < s
   = (l1, n1, Lrbrace, "}") :
     laLayout l ss (t1:t2:ts)


-- ==========================================================--
--
laRbrace c l n 
   = take c (repeat (l, n, Lrbrace, "}"))

-- ==========================================================--
--
laMain :: String -> [Token]

laMain
   = laLayout 1 [0] . map laKeyword . leLex 1 1


-- ==========================================================--
-- === end                                      Layout.hs ===--
-- ==========================================================--

-- ==========================================================--
-- === Abstract syntax for modules                        ===--
-- ===                                       AbsSyntax.hs ===--
-- ==========================================================--

--module AbsSyntax where

--1.3:data Maybe a = Nothing 
--             | Just a

type AList a b = [(a, b)]

type Id = String

data Module 
   = MkModule Id [TopDecl]
            -- deriving (Show{-was:Text-})

data FixityDecl
   = MkFixDecl Id (Fixity, Int)
            -- deriving (Show{-was:Text-})

data DataDecl
   = MkDataDecl Id ([Id], [ConstrAltDecl])
            -- deriving (Show{-was:Text-})

data TopDecl
   = MkTopF FixityDecl
   | MkTopD DataDecl
   | MkTopV ValBind
            -- deriving (Show{-was:Text-})

data Fixity
   = InfixL
   | InfixR
   | InfixN
            -- deriving (Eq,Show{-was:Text-})

eqFixity :: Fixity -> Fixity -> Bool
eqFixity InfixL InfixL = True
eqFixity InfixR InfixR = True
eqFixity InfixN InfixN = True
eqFixity _ _ = False

type ConstrAltDecl
   = (Id, [TypeExpr])

data TypeExpr = TypeVar    Id
              | TypeArr    TypeExpr TypeExpr
              | TypeCon    Id [TypeExpr]
              | TypeList   TypeExpr
              | TypeTuple  [TypeExpr]
            --  deriving (Show{-was:Text-})

data ValBind
   = MkValBind Int Lhs Expr
            --  deriving (Show{-was:Text-})

data Lhs
   = LhsPat Pat
   | LhsVar Id [Pat]
             -- deriving (Show{-was:Text-})

data Pat 
   = PatVar Id
   | PatCon Id [Pat]
   | PatWild
   | PatList   [Pat]
   | PatTuple  [Pat]
             -- deriving (Show{-was:Text-})

data Expr
   = ExprVar      Id
   | ExprCon      Id
   | ExprApp      Expr Expr
   | ExprLam      [Pat] Expr
   | ExprCase     Expr [ExprCaseAlt]
   | ExprLetrec   [ValBind] Expr
   | ExprWhere    Expr [ValBind]
   | ExprGuards   [(Expr, Expr)]
   | ExprLiteral  Literal
   | ExprList     [Expr]
   | ExprTuple    [Expr]
   | ExprIf       Expr Expr Expr
   | ExprBar
   | ExprFail
             -- deriving (Show{-was:Text-})

data ExprCaseAlt
   = MkExprCaseAlt Pat Expr
             -- deriving (Show{-was:Text-})

data Literal
   = LiteralInt     Int
   | LiteralChar    Char
   | LiteralString  String
             -- deriving (Show{-was:Text-})

-- ==========================================================--
-- === end                                   AbsSyntax.hs ===--
-- ==========================================================--

-- ==========================================================--
-- === Parser generics                                    ===--
-- ===                                   ParserGeneric.hs ===--
-- ==========================================================--

--module ParserGeneric

type PEnv = AList String (Fixity, Int)

data PResult a = POk    PEnv [Token] a
               | PFail  Token

type Parser a = PEnv -> [Token] -> PResult a

type PEntry = (Bool, Expr, Id)

-- ==========================================================--
--
pgItem :: Lex -> Parser String

pgItem x env [] = PFail pgEOF

pgItem x env ((l, n, w, t):toks)
   | x `eqLex` w     = POk env toks t
   | otherwise  = PFail (l, n, w, t)


-- ==========================================================--
--
pgAlts :: [Parser a] -> Parser a

pgAlts ps env toks
   = let
        useAlts [] bestErrTok 
           = PFail bestErrTok
        useAlts (p:ps) bestErrTok
           = case p env toks of
                PFail someErrTok -> useAlts ps (further someErrTok bestErrTok)
                successful_parse -> successful_parse
        further x1@(l1, n1, w1, t1) x2@(l2, n2, w2, t2)
           =      if l2 > l1 then x2
             else if l1 > l2 then x1
             else if n1 > n2 then x1
             else x2
     in
        useAlts ps (head (toks ++ [pgEOF])) 


-- ==========================================================--
--
pgThen2 :: (a -> b -> c) -> 
           Parser a -> 
           Parser b -> 
           Parser c

pgThen2 combine p1 p2 env toks
   = case p1 env toks of
     {
       PFail tok1 
         -> PFail tok1 ;
       POk env1 toks1 item1 
         -> case p2 env1 toks1 of
            {
              PFail tok2 
                -> PFail tok2 ;
              POk env2 toks2 item2
                -> POk env2 toks2 (combine item1 item2)
            }
     }


-- ==========================================================--
--
pgThen3 :: (a -> b -> c -> d) -> 
           Parser a -> 
           Parser b -> 
           Parser c -> 
           Parser d

pgThen3 combine p1 p2 p3 env toks
   = case p1 env toks of
     {
       PFail tok1 
         -> PFail tok1 ;
       POk env1 toks1 item1 
         -> case p2 env1 toks1 of
            {
              PFail tok2 
                -> PFail tok2 ;
              POk env2 toks2 item2
                -> case p3 env2 toks2 of
                   {
                     PFail tok3
                       -> PFail tok3 ;
                     POk env3 toks3 item3
                       -> POk env3 toks3 (combine item1 item2 item3)
                   }
            }
     }


-- ==========================================================--
--
pgThen4 :: (a -> b -> c -> d -> e) -> 
           Parser a -> 
           Parser b -> 
           Parser c -> 
           Parser d ->
           Parser e

pgThen4 combine p1 p2 p3 p4 env toks
   = case p1 env toks of
     {
       PFail tok1 
         -> PFail tok1 ;
       POk env1 toks1 item1 
         -> case p2 env1 toks1 of
            {
              PFail tok2 
                -> PFail tok2 ;
              POk env2 toks2 item2
                -> case p3 env2 toks2 of
                   {
                     PFail tok3
                       -> PFail tok3 ;
                     POk env3 toks3 item3
                       -> case p4 env3 toks3 of
                          {
                            PFail tok4 
                              -> PFail tok4 ;
                            POk env4 toks4 item4
                              -> POk env4 toks4 (combine item1 item2 item3 item4)
                          }
                   }
            }
     }


-- ==========================================================--
--
pgZeroOrMore :: Parser a -> Parser [a]

pgZeroOrMore p env toks
   = case p env toks of
     {
       PFail tok1 
         -> POk env toks [] ;
       POk env1 toks1 item1 
         -> case pgZeroOrMore p env1 toks1 of
            {
              PFail tok2 
                -> POk env1 toks1 [item1] ;
              POk env2 toks2 item2_list
                -> POk env2 toks2 (item1 : item2_list)
            }
     }
         

-- ==========================================================--
--
pgOneOrMore :: Parser a -> Parser [a]

pgOneOrMore p
   = pgThen2 (:) p (pgZeroOrMore p)


-- ==========================================================--
--
pgApply :: (a -> b) -> Parser a -> Parser b

pgApply f p env toks
   = case p env toks of
     {
       PFail tok1
         -> PFail tok1 ;
       POk env1 toks1 item1
         -> POk env1 toks1 (f item1)
     }


-- ==========================================================--
--
pgTwoOrMoreWithSep :: Parser a -> Parser b -> Parser [a]

pgTwoOrMoreWithSep p psep
   = pgThen4
        (\i1 s1 i2 rest -> i1:i2:rest)
        p
        psep
        p 
        (pgZeroOrMore (pgThen2 (\sep x -> x) psep p))


-- ==========================================================--
--
pgOneOrMoreWithSep :: Parser a -> Parser b -> Parser [a]

pgOneOrMoreWithSep p psep
   = pgThen2 (:) p (pgZeroOrMore (pgThen2 (\sep x -> x) psep p))


-- ==========================================================--
--
pgZeroOrMoreWithSep :: Parser a -> Parser b -> Parser [a]

pgZeroOrMoreWithSep p psep
   = pgAlts
     [
        pgOneOrMoreWithSep p psep,
        pgApply (\x -> x:[]) p,
        pgEmpty []
     ]


-- ==========================================================--
--
pgOptional :: Parser a -> Parser (Maybe a)

pgOptional p env toks
   = case p env toks of
     {
       PFail tok1
         -> POk env toks Nothing ;
       POk env2 toks2 item2
         -> POk env2 toks2 (Just item2)
     }


-- ==========================================================--
--
pgGetLineNumber :: Parser a -> Parser (Int, a)

pgGetLineNumber p env toks
   = let 
         lineNo = case (head (toks ++ [pgEOF])) of (l, n, w, t) -> l
     in
         case p env toks of
         {
           PFail tok1
             -> PFail tok1 ;
           POk env2 toks2 item2
             -> POk env2 toks2 (lineNo, item2)
         }


-- ==========================================================--
--
pgEmpty :: a -> Parser a

pgEmpty item env toks
   = POk env toks item


-- ==========================================================--
--
pgEOF :: Token

pgEOF = (88888, 88888, Lvar, "*** Unexpected end of source! ***")


-- ============================================================--
-- === Some kludgey stuff for implementing the offside rule ===--
-- ============================================================--

-- ==========================================================--
--
pgEatEnd :: Parser ()

pgEatEnd env [] 
   = POk env [] ()

pgEatEnd env (tok@(l, n, w, t):toks)
   | w `eqLex` Lsemi || w `eqLex` Lrbrace   = POk env toks ()
   | otherwise                    = POk env (tok:toks) ()


-- ==========================================================--
--
pgDeclList :: Parser a -> Parser [a]

pgDeclList p
   = pgThen3 (\a b c -> b) (pgItem Llbrace) 
                           (pgOneOrMoreWithSep p (pgItem Lsemi))
                           pgEatEnd


-- ==========================================================--
-- === end                               ParserGeneric.hs ===--
-- ==========================================================--

-- ==========================================================--
-- === The parser.                                        ===--
-- ===                                          Parser.hs ===--
-- ==========================================================--

--module Parser where

{- FIX THESE UP -}
utLookupDef env k def
   = head ( [ vv | (kk,vv) <- env, kk `eqString` k] ++ [def] )
panic = error
{- END FIXUPS -}

paLiteral :: Parser Literal
paLiteral
   = pgAlts 
     [
        pgApply (LiteralInt . leStringToInt) (pgItem Lintlit),
        pgApply (LiteralChar . head)         (pgItem Lcharlit),
        pgApply LiteralString              (pgItem Lstringlit)
     ]

paExpr
   = pgAlts 
     [
        paCaseExpr, 
        paLetExpr, 
        paLamExpr,
        paIfExpr,
        paUnaryMinusExpr,
        hsDoExpr []
     ]

paUnaryMinusExpr
   = pgThen2
        (\minus (_, aexpr, _) -> 
             ExprApp (ExprApp (ExprVar "-") (ExprLiteral (LiteralInt 0))) aexpr)
        paMinus
        paAExpr

paCaseExpr
   = pgThen4
        (\casee expr off alts -> ExprCase expr alts)
        (pgItem Lcase)
        paExpr
        (pgItem Lof)
        (pgDeclList paAlt)

paAlt
   = pgAlts
     [
        pgThen4
           (\pat arrow expr wheres 
                -> MkExprCaseAlt pat (pa_MakeWhereExpr expr wheres))
           paPat
           (pgItem Larrow)
           paExpr
           (pgOptional paWhereClause),
        pgThen3
           (\pat agrdrhss wheres
                -> MkExprCaseAlt pat
                      (pa_MakeWhereExpr (ExprGuards agrdrhss) wheres))
           paPat
           (pgOneOrMore paGalt)
           (pgOptional paWhereClause)
     ]

paGalt
   = pgThen4
        (\bar guard arrow expr -> (guard, expr))
        (pgItem Lbar)
        paExpr
        (pgItem Larrow)
        paExpr

paLamExpr
   = pgThen4
        (\lam patterns arrow rhs -> ExprLam patterns rhs)
        (pgItem Lslash)
        (pgZeroOrMore paAPat)
        (pgItem Larrow)
        paExpr

paLetExpr
   = pgThen4
        (\lett decls inn rhs -> ExprLetrec decls rhs)
        (pgItem Llet)
        paValdefs
        (pgItem Lin)
        paExpr

paValdefs 
   = pgApply pa_MergeValdefs (pgDeclList paValdef)

pa_MergeValdefs 
   = id

paLhs
   = pgAlts
     [
        pgThen2 (\v ps -> LhsVar v ps) paVar (pgOneOrMore paPat),
        pgApply LhsPat paPat
     ]

paValdef
   = pgAlts
     [
        pgThen4
           (\(line, lhs) eq rhs wheres 
                -> MkValBind line lhs (pa_MakeWhereExpr rhs wheres))
           (pgGetLineNumber paLhs)
           (pgItem Lequals)
           paExpr
           (pgOptional paWhereClause),
        pgThen3
           (\(line, lhs) grdrhss wheres 
                -> MkValBind line lhs 
                      (pa_MakeWhereExpr (ExprGuards grdrhss) wheres))
           (pgGetLineNumber paLhs)
           (pgOneOrMore paGrhs)
           (pgOptional paWhereClause)
     ]

pa_MakeWhereExpr expr Nothing 
   = expr
pa_MakeWhereExpr expr (Just whereClauses) 
   = ExprWhere expr whereClauses

paWhereClause
   = pgThen2 (\x y -> y) (pgItem Lwhere) paValdefs
paGrhs
   = pgThen4
        (\bar guard equals expr -> (guard, expr))
        (pgItem Lbar)
        paExpr
        (pgItem Lequals)
        paExpr
        

paAPat
   = pgAlts
     [
        pgApply PatVar paVar,
        pgApply (\id -> PatCon id []) paCon,
        pgApply (const PatWild) (pgItem Lunder),
        pgApply PatTuple
                (pgThen3 (\l es r -> es)
                         (pgItem Llparen) 
                         (pgTwoOrMoreWithSep paPat (pgItem Lcomma))
                         (pgItem Lrparen)),
        pgApply PatList
                (pgThen3 (\l es r -> es)
                         (pgItem Llbrack) 
                         (pgZeroOrMoreWithSep paPat (pgItem Lcomma))
                         (pgItem Lrbrack)),
        pgThen3 (\l p r -> p)
                (pgItem Llparen)
                paPat
                (pgItem Lrparen)
     ]

paPat
   = pgAlts
     [
        pgThen2 (\c ps -> PatCon c ps)
                paCon
                (pgOneOrMore paAPat),
        pgThen3 (\ap c pa -> PatCon c [ap,pa])
                paAPat
                paConop
                paPat,
        paAPat
     ]


paIfExpr
 = pgThen4
      (\iff c thenn (t,f) -> ExprIf c t f)
      (pgItem Lif)
      paExpr
      (pgItem Lthen)
      (pgThen3
         (\t elsee f -> (t,f))
         paExpr
         (pgItem Lelse)
         paExpr
      )

paAExpr
 = pgApply (\x -> (False, x, []))
   (pgAlts 
    [
       pgApply ExprVar paVar,
       pgApply ExprCon paCon,
       pgApply ExprLiteral paLiteral,
       pgApply ExprList paListExpr,
       pgApply ExprTuple paTupleExpr,
       pgThen3 (\l e r -> e) (pgItem Llparen) paExpr (pgItem Lrparen)
    ]
   )

paListExpr
   = pgThen3 (\l es r -> es) 
             (pgItem Llbrack) 
             (pgZeroOrMoreWithSep paExpr (pgItem Lcomma))
             (pgItem Lrbrack)

paTupleExpr
   = pgThen3 (\l es r -> es) 
             (pgItem Llparen) 
             (pgTwoOrMoreWithSep paExpr (pgItem Lcomma))
             (pgItem Lrparen)

paVar = pgItem Lvar
paCon = pgItem Lcon
paVarop = pgItem Lvarop
paConop = pgItem Lconop
paMinus = pgItem Lminus

paOp
 = pgAlts [
            pgApply (\x -> (True, ExprVar x, x)) paVarop,
            pgApply (\x -> (True, ExprCon x, x)) paConop,
            pgApply (\x -> (True, ExprVar x, x)) paMinus
          ]

paDataDecl
   = pgThen2
        (\dataa useful -> useful)
        (pgItem Ldata)
        paDataDecl_main

paDataDecl_main
   = pgThen4
        (\name params eq drhs -> MkDataDecl name (params, drhs))
        paCon
        (pgZeroOrMore paVar)
        (pgItem Lequals)
        (pgOneOrMoreWithSep paConstrs (pgItem Lbar))

paConstrs
   = pgThen2
        (\con texprs -> (con, texprs))
        paCon
        (pgZeroOrMore paAType)

paType 
   = pgAlts
     [
        pgThen3 
           (\atype arrow typee -> TypeArr atype typee)
           paAType
           (pgItem Larrow)
           paType,
        pgThen2
           TypeCon
           paCon
           (pgOneOrMore paAType),
        paAType
     ]

paAType
   = pgAlts
     [
        pgApply TypeVar paVar,
        pgApply (\tycon -> TypeCon tycon []) paCon,
        pgThen3
           (\l t r -> t)
           (pgItem Llparen)
           paType
           (pgItem Lrparen),
        pgThen3
           (\l t r -> TypeList t)
           (pgItem Llbrack)
           paType
           (pgItem Lrbrack),
        pgThen3
           (\l t r -> TypeTuple t)
           (pgItem Llparen)
           (pgTwoOrMoreWithSep paType (pgItem Lcomma))
           (pgItem Lrparen)
     ]

paInfixDecl env toks
  = let dump (ExprVar v) = v
        dump (ExprCon c) = c
    in
    pa_UpdateFixityEnv 
       (pgThen3
          (\assoc prio name -> MkFixDecl name (assoc, prio))
          paInfixWord
          (pgApply leStringToInt (pgItem Lintlit)) 
          (pgApply (\(_, op, _) -> dump op) paOp)
          env 
          toks 
       )

paInfixWord
  = pgAlts
    [
       pgApply (const InfixL) (pgItem Linfixl),
       pgApply (const InfixR) (pgItem Linfixr),
       pgApply (const InfixN) (pgItem Linfix)
    ]

pa_UpdateFixityEnv (PFail tok) 
   = PFail tok

pa_UpdateFixityEnv (POk env toks (MkFixDecl name assoc_prio))
   = let 
         new_env = (name, assoc_prio) : env
     in
         POk new_env toks (MkFixDecl name assoc_prio)

paTopDecl
   = pgAlts
     [
        pgApply MkTopF paInfixDecl,
        pgApply MkTopD paDataDecl,
        pgApply MkTopV paValdef
     ]

paModule
   = pgThen4
        (\modyule name wheree topdecls -> MkModule name topdecls)
        (pgItem Lmodule)
        paCon
        (pgItem Lwhere)
        (pgDeclList paTopDecl)
   
parser_test toks
   = let parser_to_test
            = --paPat
              --paExpr
              --paValdef
              --pgZeroOrMore paInfixDecl
              --paDataDecl
              --paType
              paModule
              --pgTwoOrMoreWithSep (pgItem Lsemi) (pgItem Lcomma)
              
     in
         parser_to_test hsPrecTable toks

-- ==============================================--
-- === The Operator-Precedence parser (yuck!) ===--
-- ==============================================--

--
-- ==========================================================--
--
hsAExprOrOp 
 = pgAlts [paAExpr, paOp]

hsDoExpr :: [PEntry] -> Parser Expr
-- [PaEntry] is a stack of operators and atomic expressions
-- hsDoExpr uses a parser (hsAexpOrOp :: Parsr PaEntry) for atomic
-- expressions or operators

hsDoExpr stack env toks = 
  let
     (validIn, restIn, parseIn, err)
        = case hsAExprOrOp env toks of
             POk env1 toks1 item1
                -> (True, toks1, item1, panic "hsDoExpr(1)")
             PFail err
                -> (False, panic "hsDoExpr(2)", panic "hsDoExpr(3)", err)
     (opIn, valueIn, nameIn)
        = parseIn
     (assocIn, priorIn)
        = utLookupDef env nameIn (InfixL, 9)
     shift
        = hsDoExpr (parseIn:stack) env restIn
  in 
     case stack of
        s1:s2:s3:ss
           | validIn && opS2 && opIn && priorS2 > priorIn
              -> reduce
           | validIn && opS2 && opIn && priorS2 == priorIn
              -> if assocS2 `eqFixity` InfixL && 
                    assocIn `eqFixity` InfixL 
                 then reduce
             else 
                 if assocS2 `eqFixity` InfixR && 
                    assocIn `eqFixity` InfixR 
                 then shift
             else PFail (head toks) -- Because of ambiguousness 
           | not validIn && opS2
              -> reduce
             where
               (opS1, valueS1, nameS1) = s1
               (opS2, valueS2, nameS2) = s2
               (opS3, valueS3, nameS3) = s3
               (assocS2, priorS2) = utLookupDef env nameS2 (InfixL, 9)
               reduce = hsDoExpr ((False, ExprApp (ExprApp valueS2 valueS3) 
                                                  valueS1, [])
                                  : ss) env toks
        s1:s2:ss
           | validIn && (opS1 || opS2) -> shift
           | otherwise -> reduce
             where
                (opS1, valueS1, nameS1) = s1
                (opS2, valueS2, nameS2) = s2
                reduce = hsDoExpr ((False, ExprApp valueS2 valueS1, []) : ss) 
                                  env toks
        (s1:[])
           | validIn -> shift
           | otherwise -> POk env toks valueS1
             where
                (opS1, valueS1, nameS1) = s1
        []
           | validIn -> shift
           | otherwise -> PFail err

-- ==========================================================--
-- === end                                      Parser.hs ===--
-- ==========================================================--

hsPrecTable :: PEnv
hsPrecTable = [
  ("-",     (InfixL, 6)),
  ("+",     (InfixL, 6)),
  ("*",     (InfixL, 7)),
  ("div",   (InfixN, 7)),
  ("mod",   (InfixN, 7)),

  ("<",     (InfixN, 4)),
  ("<=",    (InfixN, 4)),
  ("==",    (InfixN, 4)),
  ("/=",    (InfixN, 4)),
  (">=",    (InfixN, 4)),
  (">",     (InfixN, 4)),

  ("C:",        (InfixR, 5)),
  ("++",        (InfixR, 5)),
  ("\\",        (InfixN, 5)),
  ("!!",        (InfixL, 9)),
  (".",         (InfixR, 9)),
  ("^",         (InfixR, 8)),
  ("elem",      (InfixN, 4)),
  ("notElem",   (InfixN, 4)),

  ("||",    (InfixR, 2)),
  ("&&",    (InfixR, 3))]


getAll = do
    c <- getChar
    if c `eqChar` '#' then -- fake EOF
       return [c]
      else
        do
            cs <- getAll
            return (c:cs)
            
main = do
    cs <- getAll
    let tokens = laMain cs
    let parser_res = parser_test tokens
    putStr (showx parser_res)

showx (PFail t) 
 = "\n\nFailed on token: " ++ showToken t ++  "\n\n"

showx (POk env toks result)
 = "\n\nSucceeded, with:\n   Size env = " ++ showInt (length env) ++
   "\n   Next token = " ++ showToken (head toks) ++
   "\n\n   Result = " ++ showModule result ++ "\n\n"

-- ==========================================================--
--
layn :: [[Char]] -> [Char]

layn x =   f 1 x
           where
           f :: Int -> [[Char]] -> [Char]
           f n [] = []
           f n (a:x) = rjustify 4 (showInt n) ++") "++a++"\n"++f (n+1) x



-- ==========================================================--
--
rjustify :: Int -> [Char] -> [Char]
rjustify n s = spaces (n - length s)++s
               where
                  spaces :: Int -> [Char]
                  spaces m = copy m ' '

copy :: Int -> a -> [a]

copy n x = take (max 0 n) xs where xs = x:xs

