# FixityResolution: resolve.2.hs

File resolve.2.hs, 4.9 KB (added by simonmar@…, 4 years ago)

new version of the resolver, matching the report delta, with some test code

Line
3import Data.Char
4import Debug.Trace
5
6data Op     = Op String Prec Fixity          deriving (Eq,Show)
7data Fixity = Leftfix | Rightfix | Nonfix    deriving (Eq,Show)
8data Exp    = Var Var | OpApp Exp Op Exp | Neg Exp  deriving Eq
9type Prec   = Int
10type Var    = String
11
12-- Printing
13
14instance Show Exp where
15  showsPrec _ (Var x) = showString x
16  showsPrec p (OpApp l (Op op _ _) r) =
17        showParen (p > 0) \$ showsPrec 9 l . showString op . showsPrec 9 r
18  showsPrec p (Neg e) =
19        showParen (p > 0) \$ showString "-" . showsPrec 9 e
20
21-- -----------------------------------------------------------------------------
22-- recursive-descent
23
24data Tok = TExp Exp | TOp Op | TNeg deriving Show
25
26{-
27   the call
28
29      parse op1 E1 (op2 : E2 : tokens)
30
31   means that we are looking at an expression like
32
33      E0 `op1` E1 `op2` ...  (*1)
34
35   (the caller holds E0).  The job of parse is to build the
36   expression to the right of op1, returning this expression and the
37   remaining input.
38
39   (1) if op1 and op2 have the same precedence, but they do not have
40   the same associativity, or they are declared to be nonfix, then the
41   expression is illegal.
42
43   (2) If op1 has a higher precedence than op2, or op1 and op2 should
44   left-associate, then we know that the expression to the right of
45   op1 is E1, so we return this to the caller.
46
47   (3) Otherwise, we know we want to build an expression of the form (E1
48   `op2` R).  To find R, we recursively call (parse op2 E2 tokens),
49   which returns the expression to the right of op2, namely R.  Now,
50   we have
51
52      E0 `op1` (E1 `op2` R) `op3` ...
53
54   where op3 is the next operator in the input.  This is an instance
55   of (*1) above, so to continue we call parse, with the new E1 == (E1
56   `op2` R)
57
58   To initialise the algorithm, we set op1 to be an imaginary operator
59   with precedence lower than everything else.  Hence parse will
60   consume the whole input, and return the resulting expression.
61-}
62resolve :: [Tok] -> Maybe Exp
63resolve tokens = fmap fst \$ parseNeg (Op "" (-1) Nonfix) tokens
64  where
65    parseNeg :: Op -> [Tok] -> Maybe (Exp,[Tok])
66    parseNeg op1 (TExp e1 : rest)
67       = parse op1 e1 rest
68    parseNeg op1 (TNeg : rest)
69       = do guard (prec1 < 6)
70            (r, rest') <- parseNeg (Op "-" 6 Leftfix) rest
71            parse op1 (Neg r) rest'
72       where
73          Op _ prec1 fix1 = op1
74
75    parse :: Op -> Exp -> [Tok] -> Maybe (Exp, [Tok])
76    parse _   e1 [] = Just (e1, [])
77    parse op1 e1 tokens@(TOp op2 : rest)
78       -- case (1): check for illegal expressions
79       | prec1 == prec2 && (fix1 /= fix2 || fix1 == Nonfix)
80       = Nothing
81
82       -- case (2): op1 and op2 should associate to the left
83       | prec1 > prec2 || (prec1 == prec2 && fix1 == Leftfix)
84       = Just (e1, tokens)
85
86       -- case (3): op1 and op2 should associate to the right
87       | otherwise
88       = do (r,rest') <- parseNeg  op2 rest
89            parse op1 (OpApp e1 op2 r) rest'
90       where
91         Op _ prec1 fix1 = op1
92         Op _ prec2 fix2 = op2
93
94-- -----------------------------------------------------------------------------
96
97-- lots of backtracking...
99parseReadP str = map fst \$ filter (null.snd) \$ readP_to_S (exp 0) str
100  where
101        exp :: Int -> ReadP Exp
102        exp 10 = do c <- satisfy isAlphaNum; return (Var [c])
103        exp n  = do
104          choice [
105            do l <- exp (n+1); rexp l n,
106            if n == 6
107               then do char '-'; e <- exp 7; return (Neg e)
108               else pfail
109            ]
110
111        rexp l n = choice [
112            return l,
113            do
114              op@(Op _ prec fixity) <- do c <- get; return (lookupop c)
115              if n /= prec then pfail else do
116              case fixity of
117                Leftfix  -> do r <- exp (n+1); rexp (OpApp l op r) n
118                Nonfix   -> do r <- exp (n+1); return (OpApp l op r)
119                Rightfix -> do r <- exp n    ; return (OpApp l op r)
120           ]
121
122-- -----------------------------------------------------------------------------
123-- Testing
124
125lookupop '|' = Op "|" 2 Rightfix
126lookupop '&' = Op "&" 3 Rightfix
127lookupop '>' = Op ">" 4 Nonfix
128lookupop '<' = Op "<" 4 Nonfix
129lookupop '+' = Op "+" 6 Leftfix
130lookupop '-' = Op "-" 6 Leftfix
131lookupop '*' = Op "*" 7 Leftfix
132lookupop '/' = Op "/" 7 Leftfix
133lookupop '^' = Op "^" 8 Rightfix
134
135negop = Op "-" 6 Leftfix
136
137fromstr ('-':z) = TNeg : fromstr z
138fromstr (x:z)   = TExp (Var [x]) : fromstrop z
139
140fromstrop []     = []
141fromstrop (op:z) = TOp (lookupop op) : fromstr z
142
143tests = [
144    "a+b+c"
145   , "a+b+c*d"
146   , "a/b/c"
147   , "a/b+c"
148   , "a/b*c"
149   , "1^2^3+4"
150   , "a/1^2^3"
151   , "a*b/c"
152   , "a>b>c"
153   , "a>b+c"
154   , "a+b>c"
155   , "a+b<c+d"
156   , "a+b<c+d>e"
157   , "-a"
158   , "--a"
159   , "a+-b"
160   , "a*-b"
161   , "-a+b"
162   , "-a*b"
163   , "-a+b*c"
164   , "a<-b"
165   , "a<-3<4"
166 ]
167
168runtests = putStr \$ unlines \$ map (show.resolve.fromstr) tests
169