FixityResolution: resolve.2.hs

import Text.ParserCombinators.ReadP
import Control.Monad
import Data.Char
import Debug.Trace

data Op     = Op String Prec Fixity          deriving (Eq,Show)
data Fixity = Leftfix | Rightfix | Nonfix    deriving (Eq,Show)
data Exp    = Var Var | OpApp Exp Op Exp | Neg Exp  deriving Eq
type Prec   = Int
type Var    = String

-- Printing

instance Show Exp where
  showsPrec _ (Var x) = showString x
  showsPrec p (OpApp l (Op op _ _) r) = 
        showParen (p > 0) $ showsPrec 9 l . showString op . showsPrec 9 r
  showsPrec p (Neg e) =
        showParen (p > 0) $ showString "-" . showsPrec 9 e

-- -----------------------------------------------------------------------------
-- recursive-descent

data Tok = TExp Exp | TOp Op | TNeg deriving Show

{-
   the call

      parse op1 E1 (op2 : E2 : tokens)

   means that we are looking at an expression like

      E0 `op1` E1 `op2` ...  (*1)

   (the caller holds E0).  The job of parse is to build the
   expression to the right of op1, returning this expression and the
   remaining input.

   (1) if op1 and op2 have the same precedence, but they do not have
   the same associativity, or they are declared to be nonfix, then the
   expression is illegal.

   (2) If op1 has a higher precedence than op2, or op1 and op2 should
   left-associate, then we know that the expression to the right of
   op1 is E1, so we return this to the caller.

   (3) Otherwise, we know we want to build an expression of the form (E1
   `op2` R).  To find R, we recursively call (parse op2 E2 tokens),
   which returns the expression to the right of op2, namely R.  Now,
   we have 
   
      E0 `op1` (E1 `op2` R) `op3` ...

   where op3 is the next operator in the input.  This is an instance
   of (*1) above, so to continue we call parse, with the new E1 == (E1
   `op2` R)

   To initialise the algorithm, we set op1 to be an imaginary operator
   with precedence lower than everything else.  Hence parse will
   consume the whole input, and return the resulting expression.
-}
resolve :: [Tok] -> Maybe Exp
resolve tokens = fmap fst $ parseNeg (Op "" (-1) Nonfix) tokens
  where
    parseNeg :: Op -> [Tok] -> Maybe (Exp,[Tok])
    parseNeg op1 (TExp e1 : rest)
       = parse op1 e1 rest
    parseNeg op1 (TNeg : rest)
       = do guard (prec1 < 6)
            (r, rest') <- parseNeg (Op "-" 6 Leftfix) rest
            parse op1 (Neg r) rest'
       where
          Op _ prec1 fix1 = op1

    parse :: Op -> Exp -> [Tok] -> Maybe (Exp, [Tok])
    parse _   e1 [] = Just (e1, [])
    parse op1 e1 tokens@(TOp op2 : rest) 
       -- case (1): check for illegal expressions
       | prec1 == prec2 && (fix1 /= fix2 || fix1 == Nonfix)
       = Nothing

       -- case (2): op1 and op2 should associate to the left
       | prec1 > prec2 || (prec1 == prec2 && fix1 == Leftfix)
       = Just (e1, tokens)

       -- case (3): op1 and op2 should associate to the right
       | otherwise
       = do (r,rest') <- parseNeg  op2 rest
            parse op1 (OpApp e1 op2 r) rest'
       where
         Op _ prec1 fix1 = op1
         Op _ prec2 fix2 = op2

-- -----------------------------------------------------------------------------
-- ReadP

-- lots of backtracking...
parseReadP :: String -> [Exp]
parseReadP str = map fst $ filter (null.snd) $ readP_to_S (exp 0) str
  where 
        exp :: Int -> ReadP Exp
        exp 10 = do c <- satisfy isAlphaNum; return (Var [c])
        exp n  = do 
          choice [
            do l <- exp (n+1); rexp l n,
            if n == 6 
               then do char '-'; e <- exp 7; return (Neg e)
               else pfail
            ]

        rexp l n = choice [
            return l,
            do 
              op@(Op _ prec fixity) <- do c <- get; return (lookupop c)
              if n /= prec then pfail else do
              case fixity of
                Leftfix  -> do r <- exp (n+1); rexp (OpApp l op r) n
                Nonfix   -> do r <- exp (n+1); return (OpApp l op r)
                Rightfix -> do r <- exp n    ; return (OpApp l op r)
           ]

-- -----------------------------------------------------------------------------
-- Testing

lookupop '|' = Op "|" 2 Rightfix
lookupop '&' = Op "&" 3 Rightfix
lookupop '>' = Op ">" 4 Nonfix
lookupop '<' = Op "<" 4 Nonfix
lookupop '+' = Op "+" 6 Leftfix
lookupop '-' = Op "-" 6 Leftfix
lookupop '*' = Op "*" 7 Leftfix
lookupop '/' = Op "/" 7 Leftfix
lookupop '^' = Op "^" 8 Rightfix

negop = Op "-" 6 Leftfix

fromstr ('-':z) = TNeg : fromstr z
fromstr (x:z)   = TExp (Var [x]) : fromstrop z

fromstrop []     = []
fromstrop (op:z) = TOp (lookupop op) : fromstr z

tests = [
    "a+b+c"
   , "a+b+c*d"
   , "a/b/c"
   , "a/b+c"
   , "a/b*c"
   , "1^2^3+4"
   , "a/1^2^3"
   , "a*b/c"
   , "a>b>c"
   , "a>b+c"
   , "a+b>c"
   , "a+b<c+d"
   , "a+b<c+d>e"
   , "-a"
   , "--a"
   , "a+-b"
   , "a*-b"
   , "-a+b"
   , "-a*b"
   , "-a+b*c"
   , "a<-b"
   , "a<-3<4"
 ]

runtests = putStr $ unlines $ map (show.resolve.fromstr) tests

readptests = putStr $ unlines $ map (show.parseReadP) tests