1 -- -*- fundamental -*- 2 3 -- parse haskellized expressions 4 5 module ExpParse 6 7 ( pline -- expression or declaration 8 ) 9 10 where 11 12 13 import Maybes 14 import Char 15 import Lex 16 import Monad 17 18 import PI 19 import Ids 20 import Syntax 21 22 import Options 23 24 import Prec 25 26 27 -------------------------------------------------------- 28 29 paParen p = do { llit "("; x <- p; llit ")"; return x } 30 paBrace p = do { llit "{"; x <- p; llit "}"; return x } 31 paBracket p = do { llit "["; x <- p; llit "]"; return x } 32 paBackq p = do { llit "`"; x <- p; llit "`"; return x } 33 34 paCommas p = p `lsepBy` llit "," 35 36 -------------------------------------------------------- 37 38 -------------------------------------------------------- 39 40 -- elements of expressions 41 42 paNat :: PIS Int 43 paNat = 44 do { cs <- llitp "Nat" (\ cs -> and [isDigit c | c <- cs]) 45 ; return (foldl (\ x y -> 10 * x + (fromEnum y - fromEnum '0')) 0 cs) 46 } 47 48 paString :: PIS String 49 paString = 50 do { cs <- llitp "String" (\ cs -> head cs == '"') -- rely on the lexer 51 ; return (drop 1 (take (length cs - 1) cs)) 52 } 53 54 paFn :: PIS String 55 paFn = llitp "Fn" (\ cs -> isAlpha (head cs) && and [isAlphanum' c | c <- cs]) 56 57 paOp :: PIS String 58 paOp = llitp "Op" (\ cs -> and [not (isAlphanum' c) && not(isDel c) | c <- cs]) 59 60 61 paFnLikeDef :: Bool -> PIS Id 62 paFnLikeDef def = 63 do { cs <- paFn; makeidS def cs Fn Fn } 64 `mplus` do { n <- paNat; makenatS def n } 65 `mplus` do { cs <- paParen paOp; makeidS def cs Op Fn } 66 67 paOpLikeDef :: Bool -> PIS Id 68 paOpLikeDef def = 69 do { cs <- paOp; makeidS def cs Op Op } 70 `mplus` do { cs <- paBackq paFn; makeidS def cs Fn Op } 71 72 73 -- normally, don't create identifiers 74 paFnLike = paFnLikeDef False 75 paOpLike = paOpLikeDef False 76 77 ------------------------------------------------------------ 78 79 -- building expressions from elements 80 81 paCApp :: PIS Exp 82 -- a closed (parenthesised) expression 83 paCApp = 84 do { xs <- paBrace (paCommas paExp); return (Coll CSet xs) } 85 `mplus` do { xs <- paBracket (paCommas paExp); return (Coll CList xs) } 86 `mplus` do { xs <- paParen (paCommas paExp) 87 ; case xs of [x] -> return x; _ -> return (Coll CTuple xs) 88 } 89 `mplus` do { x <- paFnLike 90 ; x' <- putarityS (idname x) 0 91 ; return (App x' []) 92 } 93 94 stairway :: Exp -> [Exp] -> PIS Exp 95 stairway x xs = 96 do { opts <- getopts 97 ; let at = getopt opts "apply" 98 ; hat <- makeidS False at Op Op 99 ; return (foldl (\ l r -> App hat [l, r] ) x xs) 100 } 101 102 paMCApp :: PIS Exp 103 -- a nonempty sequence closed expressions 104 paMCApp = 105 do { x <- paCApp; xs <- lmany paCApp 106 ; if null xs then return x else 107 do { opts <- getopts 108 ; caseopts opts "implicit" 109 [ ("on", stairway x xs) 110 , ("off", error ("cannot build implicit apply node: " 111 ++ show (x : xs))) 112 ] 113 } 114 } 115 116 117 paApp :: PIS Exp 118 -- a function application 119 paApp = do { x <- paFnLike 120 ; ys <- lmany paCApp 121 ; x' <- putarityS (idname x) (length ys) 122 ; papp x' ys 123 } 124 125 --papp :: Id -> [Exp] -> PIS Exp 126 papp id args = 127 do { let nid = idarity id 128 ; let nargs = length args 129 ; o <- getopts ; let imp = onoff o "implicit" 130 ; if not imp then 131 if nid /= nargs 132 then error ("arities don't match: " ++ show id ++ show args) 133 else return (App id args) 134 else if nid > nargs 135 then error ("arguments missing: " ++ show id ++ show args) 136 else stairway (App id (take nid args)) (drop nid args) 137 } 138 139 140 paExp :: PIS Exp 141 -- sequence App op App op ... App 142 paExp = 143 do { x <- paApp `mplus` paMCApp 144 ; xs <- paExpRest 145 ; return (glue (Left x : xs)) 146 } 147 148 -- we store Left App, Right op (these are Ids in fact) 149 paExpRest = 150 do { op <- paOpLike; arg <- paApp `mplus` paMCApp; rest <- paExpRest 151 ; return (Right op : Left arg : rest) 152 } 153 `mplus` return [] 154 155 ------------------------------------------------------------------ 156 157 158 paCmd :: PIS () 159 paCmd = 160 do { llit "local" 161 ; pushlocals 162 163 -- just read ids, don't do anything with 'em 164 ; ids <- paCommas (paFnLikeDef True) 165 ; return () 166 167 } 168 169 `mplus` do { llit "unlocal" 170 ; poplocals 171 } 172 173 `mplus` do { llit "global" 174 175 -- bit of trickery here: open new local group, read ids 176 ; pushlocals 177 ; ids <- paCommas (paFnLikeDef True) 178 179 -- this adds most recent local group to global one 180 ; mkglobals 181 182 ; poplocals 183 } 184 185 `mplus` do { llit "infix"; n <- paNat; ops <- paCommas paOpLike 186 ; sequence_ [ putprecS (idname op) n Nn | op <- ops ] 187 } 188 `mplus` do { llit "infixl"; n <- paNat; ops <- paCommas paOpLike 189 ; sequence_ [ putprecS (idname op) n Lft | op <- ops ] 190 } 191 `mplus` do { llit "infixr"; n <- paNat; ops <- paCommas paOpLike 192 ; sequence_ [ putprecS (idname op) n Rght | op <- ops ] 193 } 194 195 -- obsolete? 196 `mplus` do { llit "arity"; n <- paNat; fns <- paCommas paFnLike 197 ; sequence_ [ putarityS (idname fn) n | fn <- fns ] 198 } 199 200 `mplus` do { llit "form"; fn <- paFnLike 201 ; do { llit "="; cs <- paString 202 ; putformS (idname fn) (Passive cs) 203 } 204 `mplus` do{ n <- paNat; llit "="; cs <- paString 205 ; putformS (idname fn) (Active n cs) 206 } 207 ; return () 208 } 209 210 211 212 213 --------------------------------------------------------------------- 214 215 --paTop :: PIS (Maybe Exp) 216 paTop = 217 do { paCmd ; return Nothing } 218 `mplus` do { x <- paExp ; opt (llit ";"); return (Just x) } 219 220 221 ------------------------------------------------------------------- 222 --pline :: (Opts,IdTable) -> [Char] -> (Maybe Exp,(Opts,IdTable)) 223 pline oi cs = 224 case myLex (uncomment cs) of 225 -- empty input is OK 226 [] -> (Nothing, oi) 227 -- otherwise parse one expression 228 -- closing semicolon is OK (ignored) 229 toks -> case lparse paTop oi toks of 230 Right [((x, oi'), [])] -> (x, oi') 231 _ -> (Just (App (usercon 0 "error") []), oi) 232 233