let rec
    type Ide == String

and type symbol =                                               -- lexical type
       IdentSy Ide + NumSy Int + trueSy + falseSy + nilSy +
       letSy + recSy + inSy +
       openSy + closeSy + commaSy +
       lambdaSy + dotSy +
       ifSy + thenSy + elseSy +
       consSy +
       orSy +
       andSy +
       eqSy + neSy + ltSy + leSy + gtSy + geSy +
       plusSy + minusSy +
       timesSy + divSy +
       hdSy + tlSy + nullSy + notSy +
       eofSy   + symbolErr String

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

and type Exp =
       Ident Ide + Num Int + Boolean Bool + NIL +            -- syntactic types
       Block Bool Dec Exp +
       LambdaExp Ide Exp +
       Apply Exp Exp +
       IfExp Exp Exp Exp +
       UExp symbol Exp + BExp symbol Exp Exp

and type Dec = Bind Ide Exp + Decs Dec Dec

and type PTree = exp Exp + dec Dec + PError String         -- Parse Trees

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

in let parse inp =                                           -- parse a program
  let rec
      lexical "" = eofSy, "" ||                              -- lexical routine

      lexical s  =
         if mem (hd s) [' '; '\n'; '\t'] then lexical (tl s)
         else case s in
              ':' . ':' . R  :  consSy,   R ||               -- :: is cons
              '<' . '>' . R  :  neSy,     R ||
              '<' . '=' . R  :  leSy,     R ||
              '>' . '=' . R  :  geSy,     R ||
              s: let w,r = takeword s
                 in if isdigit(hd w) then NumSy(stoi w), r
                    else assoc w
                     (if isalpha(hd w) then [                      -- keywords
                       ("true", trueSy); ("false", falseSy);
                       ("let", letSy); ("rec", recSy); ("in", inSy);
                       ("lambda", lambdaSy);
                       ("if",   ifSy); ("then", thenSy); ("else", elseSy);
                       ("and", andSy); ("or",  orSy);
                       ("not", notSy);
                       ("hd", hdSy); ("tl", tlSy); ("null", nullSy);
                       ("nil", nilSy);
                       (w, IdentSy w)  ]
                      else [
                       (".", dotSy);
                       ("(", openSy); (")", closeSy);
                       ("=", eqSy);   (",", commaSy);
                       ("+", plusSy); ("-", minusSy);
                       ("*", timesSy);("/", divSy);
                       ("<", ltSy);   (">", gtSy);
                       (w, symbolErr w) ]
                     ), r
              end

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

-- type Cont = (list PTree) -> (list symbol) -> PTree
--             parse stack     input string     answer
--
-- type Parser = Cont -> Cont

                                                            -- utility routines
and finish [exp E] [eofSy] = exp E  ||     --   finish :Cont    finish parsing
    finish (PError m. _) _ = PError m  ||
    finish  _  _           = PError " junk at end of parsing "

and literal _       sym c T (s.rest)&(sym=s) = c T rest  ||
    literal message _   _ _ _                = PError (" missing " @ message)

and cat (Parser1.Ps) c = Parser1 (cat Ps c) ||     -- cat (List Parser) :Parser
    cat [] c = c

 -- either (List (symbol#Parser)) :Parser    an LL(1) choice operator
and either [( _  ,Parser)]     c T inp = Parser c T inp  ||  -- last must go !
    either ((sym1,Parser1).Ps) c T inp&(hd inp=sym1) = Parser1 c T inp  ||
    either (    _         .Ps) c T inp               = either Ps c T inp

and OprSeq ops NonTerm c =     -- eg. x+y+z    OprSeq syms Parser :Parser
       let rec opNT T (s.rest)&(mem s ops) = NonTerm (build s) T rest ||
               opNT T inp                  = c T inp
       and     build op (exp right.exp left.other) =
                  opNT (exp(BExp op left right).other)
       in  NonTerm opNT

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

in let rec                                                     -- syntax proper
    unaryOps = [plusSy; minusSy; notSy; hdSy; tlSy; nullSy]
and binaryOps= [plusSy; minusSy; timesSy; divSy; consSy] @ relOps
and relOps   = [eqSy; neSy; leSy; ltSy; geSy; gtSy]
and literals = [trueSy; falseSy; nilSy]
and startsExp (IdentSy _) = true ||
    startsExp (NumSy _)   = true ||
    startsExp sy = mem sy (unaryOps @ literals @
                           [openSy; ifSy; letSy; lambdaSy])

and Expression =                                                  -- Expression
    let rec
        opd c T (IdentSy x . rest) = c (exp(Ident x). T) rest  ||
        opd c T (NumSy   n . rest) = c (exp(Num   n). T) rest  ||
        opd c T (trueSy    . rest) = c (exp(Boolean true). T) rest  ||
        opd c T (falseSy   . rest) = c (exp(Boolean false).T) rest  ||
        opd c T (nilSy     . rest) = c (exp(NIL    ). T) rest  ||

        opd c T (ifSy . rest ) =                                 -- Conditional
           let rec
               c4 (exp Fe. exp Te. exp Se. T) = c(exp(IfExp Se Te Fe). T)
           and c3 T (elseSy . rest) = Expression c4 T rest
           and c2 T (thenSy . rest) = Expression c3 T rest
           in  Expression c2 T rest                            ||

        opd c T (lambdaSy . IdentSy x . dotSy . rest) =          -- abstraction
           let c2 (exp Body. T) = c (exp(LambdaExp x Body). T)
           in  Expression c2 T rest                            ||

        opd c T (letSy . Sy . rest) =                                  -- Block
           let rec
               isRec = Sy=recSy                     -- ? recursive declarations
           and c3 (exp Body . dec Local . T) = c(exp(Block isRec Local Body).T)
           and c2 T (inSy . rest) = Expression c3 T rest
           in  Declarations c2 T (if isRec then rest else Sy.rest)  ||

        opd c T (sy . rest)&(mem sy unaryOps) =              -- unary operators
           let c2 (exp e . T) = c (exp(UExp sy e). T)
           in  operand c2 T rest  ||

        opd c T _ = PError " bad operand "

    and operand = either [(openSy,
                           cat [literal "(" openSy; Expression;
                                literal ")" closeSy] );
                          (IdentSy "ignored!", opd)]

    and factor c T inp =                                 -- NB. f x y == (f x)y
        let rec
            c2 T (sy.rest) & ((startsExp sy)&~(mem sy binaryOps)) =
                       operand mkApply T (sy.rest) ||
            c2 T inp = c T inp
        and mkApply (exp Param . exp Fn . T) = c2 (exp(Apply Fn Param) . T)
        in operand c2 T inp

    and term      = OprSeq [timesSy; divSy] factor
    and arithExp  = OprSeq [plusSy; minusSy] term
    and relExp    = OprSeq [eqSy; neSy; ltSy; leSy; gtSy; geSy] arithExp
    and conj      = OprSeq [andSy] relExp
    and disj      = OprSeq [orSy]  conj
    and list      = OprSeq [consSy] disj

    in list

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

and Declarations dc =   -- [ x=e, y=f, ... ]                       Declarations
    let rec
        Declaration c T (IdentSy x. eqSy. rest) =
           let c2 (exp RHS. T) = c (dec(Bind x RHS). T)
           in  Expression c2 T rest
    and moreDecs T (commaSy.rest) = Declaration mkDecs T rest || -- more
        moreDecs T inp = dc T inp                                -- no more
    and mkDecs (dec D2. dec D1. T) = moreDecs (dec(Decs D1 D2). T)
    in  Declaration moreDecs                             -- end of Declarations

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

in Expression finish nil (choplist lexical inp)                 -- end of parse

--\fB Continuation Based Parser for Lambda Calculus / FP. \fP
-- see L.Allison. Some Applications of Continuations.
--     Computer Jrnl 31(1) 9-11  1988
-- (c) 1994
-- L.Allison, Department of Computer Science, Monash University, Australia