diff --git a/BSParse.hs b/BSParse.hs --- a/BSParse.hs +++ b/BSParse.hs @@ -1,176 +1,297 @@ -{-# OPTIONS_GHC -fbang-patterns #-} - -module BSParse ( runParse, wrapInterp, TclWord(..), dropWhite - ,bsParseTests +{-# LANGUAGE BangPatterns,OverloadedStrings #-} +module BSParse ( runParse, doInterp, TclWord(..), parseList + ,Result + ,TokCmd + ,bsParseTests ) where import qualified Data.ByteString.Char8 as B import Control.Monad import Data.Ix -import Test.HUnit -- IGNORE +import Util hiding (orElse,escapeStr) +import Test.HUnit -type Result = Maybe ([[TclWord]], B.ByteString) +data TclWord = Word !B.ByteString + | Subcommand TokCmd + | NoSub !B.ByteString Result + | Expand TclWord deriving (Show,Eq) -data TclWord = Word !B.ByteString | Subcommand [TclWord] | NoSub !B.ByteString Result deriving (Show,Eq) +type Parser a = BString -> PResult a +type PResult a = Maybe (a, BString) +type Result = PResult [TokCmd] +type TokCmd = (TclWord, [TclWord]) +runParse :: Parser [TokCmd] +runParse s = multi (mainparse . dropWhite) s >>= \(wds, rem) -> return (asCmds wds, rem) + +asCmds lst = [ let (c:a) = x in (c,a) | x <- lst, not (null x)] + +mainparse :: Parser [TclWord] +mainparse str = if B.null str + then return ([], B.empty) + else do + h <- safeHead str + case h of + ';' -> return ([], B.tail str) + '\n' -> return ([], B.tail str) + '#' -> eatComment str + _ -> parseArgs str + +parseArgs :: Parser [TclWord] +parseArgs = multi (dispatch . dropWhite) + +dispatch :: Parser TclWord dispatch str = do h <- safeHead str case h of - '{' -> nested str - '[' -> parseSub str + '{' -> (parseExpand `orElse` parseNoSub) str + '[' -> (parseSub `wrapWith` Subcommand) str '"' -> parseStr str - _ -> getword str + '\\' -> handleEsc str + _ -> wordToken str -mkNoSub s = NoSub s (runParse s) +handleEsc :: Parser TclWord +handleEsc str = do + s <- eatChar '\\' str + h <- safeHead s + let rest = B.drop 1 s + case h of + '\n' -> (dispatch . dropWhite) rest + v -> case wordTokenRaw rest of + Just (w, r) -> return (Word (B.concat ["\\", B.singleton v, w]), r) + Nothing -> return (Word (B.cons '\\' (B.singleton v)), rest) -parseArgs = multi (dispatch . dropWhite) +parseList s = if onlyWhite s + then return [] + else do (l,r) <- multi (listDisp . dWhite) $ s + guard (onlyWhite r) + return l + where onlyWhite = B.all isWhite + isWhite = (`elem` " \t\n") + dWhite = B.dropWhile isWhite -runParse :: B.ByteString -> Result -runParse = multi (mainparse . dropWhite) +listDisp str = do h <- safeHead str + case h of + '{' -> nested str + '"' -> parseStrRaw str + _ -> getListItem str +getListItem s = if B.null w then fail "can't parse list item" else return (w,n) + where (w,n) = B.splitAt (listItemEnd s) s + +listItemEnd s = inner 0 False where + inner i esc = if i == B.length s then i + else if esc then inner (i+1) False + else case B.index s i of + '\\' -> inner (i+1) True + v -> if v `B.elem` "{}\" \t\n" then i else inner (i+1) False + + safeHead s = guard (not (B.null s)) >> return (B.head s) +{-# INLINE safeHead #-} -wrapInterp str = case getInterp str of - Nothing -> Left $! escapeStr str +doInterp str = case getInterp str of + Nothing -> Left (escapeStr str) Just (pr,s,r) -> Right (escapeStr pr, s, r) -getInterp str = do +(.>-) f w s = wrapWith f w s + +-- TODO: UGLY +getInterp str = do loc <- B.findIndex (\x -> x == '$' || x == '[') str let locval = B.index str loc if escaped loc str then dorestfrom loc locval else let (pre,aft) = B.splitAt loc str in - let res = case locval of - '$' -> do (Word s, rest) <- (brackVar `orElse` getvar) (B.tail aft) - case getInd rest of - Nothing -> return (pre, Word s, rest) - Just (i,r) -> return (pre, Word (B.append s i), r) - '[' -> do (s, rest) <- parseSub aft - return (pre, s, rest) - _ -> fail "should've been $ or [ in getInterp" + let pfun = (doVarParse .>- Left) `orElse` (parseSub .>- Right) in + let res = pfun aft >>= \(v,rest) -> return (pre, v, rest) in res `mplus` dorestfrom loc locval where dorestfrom loc lval = do (p,v,r) <- getInterp (B.drop (loc+1) str) return (B.append (B.take loc str) (B.cons lval p), v, r) -getInd str - | B.null str || B.head str /= '(' = Nothing +doVarParse :: Parser BString +doVarParse s = eatChar '$' s >>= parseVarRef + +parseVarRef :: Parser BString +parseVarRef s = do + let flist = [ parseVarTerm `orElse` getNS + ,tryGet parseVarRef + ,tryGet parseInd] + chain flist s + +getNS = chain [parseLit "::", parseVarTerm, tryGet getNS] + +parseVarTerm :: Parser BString +parseVarTerm = getvar `orElse` brackVar + +parseInd str + | B.null str || B.head str /= '(' = fail "no indexer" | otherwise = do ind <- B.elemIndex ')' str let (pre,post) = B.splitAt (ind+1) str return (pre, post) - -orElse a b = \v -> (a v) `mplus` (b v) -mainparse str = if B.null str - then return ([], B.empty) - else do - h <- safeHead str - case h of - ';' -> return ([], B.tail str) - '\n' -> return ([], B.tail str) - '#' -> eatcomment str - _ -> parseArgs str +orElse a b = \v -> v `seq` ((a v) `mplus` (b v)) +{-# INLINE orElse #-} +chain lst !rs = inner lst [] rs + where inner [] !acc !r = return (B.concat (reverse acc), r) + inner (f:fs) !acc !r = do (s,r2) <- f r + inner fs (s:acc) r2 + +parseLit :: BString -> Parser BString +parseLit !w s = do + let wlen = B.length w + let slen = B.length s + if wlen <= slen && w == B.take wlen s + then return (w, B.drop wlen s) + else fail "didn't match" + +eatChar :: Char -> BString -> Maybe BString +eatChar c s = parseChar c s >>= return . snd +{-# INLINE eatChar #-} + +parseChar :: Char -> Parser BString +parseChar !c s = case B.uncons s of + Nothing -> failStr "empty string" + Just (h,t) -> if h == c then return (B.singleton h,t) + else failStr (show h) + where failStr what = fail $ "didn't match, expected " ++ show c ++ ", got " ++ what +{-# INLINE parseChar #-} + multi p s = do (w,r) <- p s - if B.null r + if B.null r then return ([w],r) else case multi p r of Nothing -> return ([w],r) Just (wx,r2) -> return $! (w:wx,r2) {-# INLINE multi #-} -parseSub s = do guard (B.head s == '[') - (p,r) <- parseArgs (B.tail s) - loc <- B.elemIndex ']' r - let (_,aft) = B.splitAt loc r - return (Subcommand p, B.tail aft) - -eatcomment = return . (,) [] . B.tail . B.dropWhile (/= '\n') +parseSub :: Parser TokCmd +parseSub s = do + (p,r) <- eatChar '[' s >>= parseArgs + aft <- eatChar ']' (dropWhite r) + case p of + [] -> fail "empty subcommand" + (ph:pt) -> return ((ph,pt), aft) -dropWhite = B.dropWhile (\x -> x == ' ' || x == '\t') +eatComment = return . (,) [] . B.drop 1 . B.dropWhile (/= '\n') {- wordChar ' ' = False wordChar !c = let ci = ord c in - (ord 'a' <= ci && ci <= ord 'z') || (ord 'A' <= ci && ci <= ord 'Z') || - (ord '0' <= ci && ci <= ord '9') || (c == '_') -} ---wordChar !c = c /= ' ' && any (`inRange` c) [('a','z'),('A','Z'), ('0','9')] || c == '_' + (ord 'a' <= ci && ci <= ord 'z') || (ord 'A' <= ci && ci <= ord 'Z') || + (ord '0' <= ci && ci <= ord '9') || (c == '_') +wordChar !c = c /= ' ' && any (`inRange` c) [('a','z'),('A','Z'), ('0','9')] || c == '_' +-} wordChar !c = c /= ' ' && (inRange ('a','z') c || inRange ('A','Z') c || inRange ('0','9') c || c == '_') -getword s = if B.null w then fail "can't parse word" else return (Word w,n) - where (w,n) = B.span (\x -> wordChar x || (x `B.elem` (B.pack "$+.-*()=/:^%!&<>"))) s +parseWord :: Parser TclWord +parseWord s = getWord s >>= \(w,r) -> return (Word w, r) -getvar s = if B.null w then fail "can't parse var name" else return (Word w,n) - where (w,n) = B.span wordChar s +getPred p s = if B.null w then fail "no match" else return $! (w,n) + where (w,n) = B.span p s -brackVar x = do hv <- safeHead x - guard (hv == '{') - let (b,a) = B.span (/='}') (B.tail x) - safeHead a - return (Word b,(B.tail a)) +getWord = getPred p + where p c = wordChar c || (c `B.elem` "+.-=<>*()$/,:^%!&|?") -parseStr s = do loc <- B.elemIndex '"' str - let (w,r) = B.splitAt loc str - if escaped loc str then do (Word w1, v) <- parseStr r - let nw = B.snoc (B.take (B.length w - 1) w) '"' - return (Word (B.append nw w1), v) - else return (Word w, B.tail r) - where str = B.tail s +getvar = getPred wordChar +tryGet fn s = (fn `orElse` (\_ -> return (B.empty, s))) s + +wrapWith fn wr s = fn s >>= \(!w,r) -> return (wr w, r) +{-# INLINE wrapWith #-} + +wordToken = wordTokenRaw `wrapWith` Word +wordTokenRaw = (chain [parseChar '$', parseVar]) `orElse` getWord + +parseVar = (brackVar `wrapWith` brackIt) `orElse` (chain [getWord, tryGet wordTokenRaw]) + where brackIt w = B.concat ["{", w , "}"] + +brackVar x = eatChar '{' x >> nested x + + +parseStr = parseStrRaw `wrapWith` Word + +parseStrRaw s = do + str <- eatChar '"' s + loc <- B.elemIndex '"' str + let (w,r) = B.splitAt loc str + if escaped loc str then do (w1, v) <- parseStrRaw r + let nw = B.snoc (B.take (B.length w - 1) w) '"' + return (B.append nw w1, v) + else return (w, B.tail r) + escapeStr = optim - where escape' !esc !lx = - if B.null lx then lx - else let (x,xs) = (B.head lx, B.tail lx) - in case (x, esc) of - ('\\', False) -> escape' True xs - ('\\', True) -> B.cons x (optim xs) - (_,False) -> B.cons x (optim xs) - (_,True) -> B.cons (escapeChar x) (optim xs) - optim s = let (c,r) = B.span (/= '\\') s in B.append c (escape' False r) + where escape' !esc !lx = + case B.uncons lx of + Nothing -> lx + Just (x,xs) -> case (x, esc) of + ('\\', False) -> escape' True xs + ('\\', True) -> B.cons x (optim xs) + (_, False) -> B.cons x (optim xs) + (_, True) -> B.cons (escapeChar x) (optim xs) + optim s = case B.elemIndex '\\' s of + Nothing -> s + Just i -> let (c,r) = B.splitAt i s in B.append c (escape' True (B.drop 1 r)) escapeChar 'n' = '\n' escapeChar 't' = '\t' escapeChar c = c escaped v s = escaped' v - where escaped' !i = if (i <= 0) then False else (B.index s (i-1) == '\\') && not (escaped' (i-1)) + where escaped' !i = if i <= 0 then False + else (B.index s (i-1) == '\\') && not (escaped' (i-1)) +mkNoSub s = NoSub s (runParse s) -nested s = do ind <- match 0 0 +parseExpand s = do + (_,r) <- parseLit "{*}" s + rh <- safeHead r + guard (not (rh `elem` " \n\t")) + (dispatch `wrapWith` Expand) r + +parseNoSub = nested `wrapWith` mkNoSub + +nested s = do ind <- match 0 0 False let (w,r) = B.splitAt ind s - return (mkNoSub (B.tail w), (B.tail r)) - where match !c !i + return (B.tail w, B.tail r) + where match !c !i !esc | B.length s <= i = fail $ "Couldn't match bracket" ++ show s - | otherwise = - case B.index s i of - '}' -> if c == 1 then return i else match (c-1) (i+1) - '{' -> match (c+1) (i+1) - _ -> match c (i+1) + | otherwise = + let nexti = i+1 in + case B.index s i of + '}' -> if esc then match c nexti False else (if c == 1 then return i else match (c-1) nexti False) + '{' -> if esc then match c nexti False else match (c+1) nexti False + '\\' -> match c nexti (not esc) + _ -> match c nexti False + -- # TESTS # -- testEscaped = TestList [ - (escaped 1 (B.pack "\\\"")) ~? "pre-slashed quote should be escaped", - checkFalse "non-slashed quote not escaped" (escaped 1 (B.pack " \"")), - checkFalse "non-slashed quote not escaped" (escaped 1 (B.pack " \"")), - (escaped 2 (B.pack " \\\"")) ~? "pre-slashed quote should be escaped", - checkFalse "non-slashed quote not escaped" (escaped 2 (B.pack " \"")) + (escaped 1 "\\\"") ~? "pre-slashed quote should be escaped", + checkFalse "non-slashed quote not escaped" (escaped 1 " \""), + checkFalse "non-slashed quote not escaped" (escaped 1 " \""), + (escaped 2 " \\\"") ~? "pre-slashed quote should be escaped", + checkFalse "non-slashed quote not escaped" (escaped 2 " \"") ] where checkFalse str val = TestCase $ assertBool str (not val) -bp = B.pack -mklit = Word . bp +bp = id +mklit = Word . bp mkwd = Word . bp parseStrTests = TestList [ - "Escaped works" ~: (mklit "Oh \"yeah\" baby.", B.empty) ?=? "\"Oh \\\"yeah\\\" baby.\"", - "Parse Str with leftover" ~: (mklit "Hey there.", bp " 44") ?=? "\"Hey there.\" 44", - "Parse Str with dolla" ~: (mklit "How about \\$44?", B.empty) ?=? "\"How about \\$44?\"", + "Escaped works" ~: (mkwd "Oh \"yeah\" baby.", "") ?=? "\"Oh \\\"yeah\\\" baby.\"", + "Parse Str with leftover" ~: (mkwd "Hey there.", " 44") ?=? "\"Hey there.\" 44", + "Parse Str with dolla" ~: (mklit "How about \\$44?", "") ?=? "\"How about \\$44?\"", "bad parse1" ~: badParse "What's new?" ] where (?=?) res str = Just res ~=? parseStr (bp str) badParse str = Nothing ~=? parseStr (bp str) brackVarTests = TestList [ - "Simple" ~: (mklit "data", B.empty) ?=? "{data}", - "With spaces" ~: (mklit " a b c d ", bp " ") ?=? "{ a b c d } ", + "Simple" ~: ("data", "") ?=? "{data}", + "With spaces" ~: (" a b c d ", " ") ?=? "{ a b c d } ", + "With esc" ~: (" \\} yeah! ", " ") ?=? "{ \\} yeah! } ", "bad parse" ~: badParse "{ oh no", "bad parse" ~: badParse "pancake" ] @@ -179,82 +300,141 @@ getInterpTests = TestList [ "Escaped $ works" ~: noInterp "a \\$variable", - "Bracket interp 1" ~: (bp "", mkwd "booga", bp "") ?=? "${booga}", - "Bracket interp 2" ~: (bp "", mkwd "oh yeah!", bp "") ?=? "${oh yeah!}", - "Bracket interp 3" ~: (bp " ", mkwd " !?! ", bp " ") ?=? " ${ !?! } ", - "unescaped $ works" ~: - (bp "a ", mkwd "variable", bp "") ?=? "a $variable", - "escaped $ works" ~: - (bp "a \\$ ", mkwd "variable", bp "") ?=? "a \\$ $variable", - "escaped $ works 2" ~: + "Bracket interp 1" ~: ("", mkvar "booga", "") ?=? "${booga}", + "Bracket interp 2" ~: ("", mkvar "oh yeah!", "") ?=? "${oh yeah!}", + "Bracket interp 3" ~: (" ", mkvar " !?! ", " ") ?=? " ${ !?! } ", + "global namespace" ~: ("", mkvar "::booga", "") ?=? "$::booga", + ":::" ~: noInterp "$:::booga", + "some namespace" ~: ("", mkvar "log::booga", "") ?=? "$log::booga", -- TODO + "unescaped $ works" ~: + ("a ", mkvar "variable", "") ?=? "a $variable", + "escaped $ works" ~: + ("a \\$ ", mkvar "variable", "") ?=? "a \\$ $variable", + "escaped $ works 2" ~: noInterp "you deserve \\$44.", - "adjacent interp works" ~: - (bp "", mkwd "var", bp "$bar$car") ?=? "$var$bar$car", - "interp after escaped dolla" ~: - (bp "a \\$", mkwd "name", bp " guy") ?=? "a \\$$name guy", - "interp after dolla" ~: - (bp "you have $", mkwd "dollars", bp "") ?=? "you have $$dollars", + "adjacent interp works" ~: + ("", mkvar "var", "$bar$car") ?=? "$var$bar$car", + "interp after escaped dolla" ~: + ("a \\$", mkvar "name", " guy") ?=? "a \\$$name guy", + "interp after dolla" ~: + ("you have $", mkvar "dollars", "") ?=? "you have $$dollars", "Escaped [" ~: noInterp "a \\[sub] thing.", - "Trailing bang" ~: (bp "", mkwd "var", bp "!" ) ?=? "$var!", - "basic arr" ~: (bp "", mkwd "boo(4)", bp " " ) ?=? "$boo(4) ", - "basic arr" ~: (bp "", mkwd "boo( 4,5 )", bp " " ) ?=? "$boo( 4,5 ) ", + "Trailing bang" ~: ("", mkvar "var", "!" ) ?=? "$var!", + "basic arr" ~: ("", mkvar "boo(4)", " " ) ?=? "$boo(4) ", + "basic arr2" ~: (" ", mkvar "boo(4)", " " ) ?=? " $boo(4) ", + "basic arr3" ~: ("", mkvar "boo( 4,5 )", " " ) ?=? "$boo( 4,5 ) ", "Escaped []" ~: noInterp "a \\[sub\\] thing.", "Lone $ works" ~: noInterp "a $ for the head of each rebel!", "Escaped lone $ works" ~: noInterp "a \\$ for the head of each rebel!", - "unescaped $ after esc works" ~: - (bp "a \\$", mkwd "variable", bp "") ?=? "a \\$$variable", + "unescaped $ after esc works" ~: + ("a \\$", mkvar "variable", "") ?=? "a \\$$variable", "Escaped [] crazy" ~: - (bp "a ",Subcommand [mkwd "sub",mklit "quail [puts 1]"], bp " thing.") ?=? "a [sub \"quail [puts 1]\"] thing." + ("a ",Right (mkwd "sub",[mklit "quail [puts 1]"]), " thing.") ?=? "a [sub \"quail [puts 1]\" ] thing." ] where noInterp str = Nothing ~=? getInterp (bp str) (?=?) res str = Just res ~=? getInterp (bp str) + mkvar w = Left w -wrapInterpTests = TestList [ - "simple escape" ~: "oh $ yeah" ?!= "oh \\$ yeah" +doInterpTests = TestList [ + "dollar escape" ~: "oh $ yeah" ?!= "oh \\$ yeah", + "brace escape" ~: "oh [ yeah" ?!= "oh \\[ yeah", + "tab escape" ~: "a \t tab" ?!= "a \\t tab", + "slash escape" ~: "slash \\\\ party" ?!= "slash \\\\\\\\ party", + "subcom" ~: ("some ", Right (mkwd "cmd", []), "") ?=? "some [cmd]", + "newline escape" ~: "\nline\n" ?!= "\\nline\\n" ] - where (?=?) res str = Right res ~=? wrapInterp (bp str) - (?!=) res str = Left (bp res) ~=? wrapInterp (bp str) + where (?=?) res str = Right res ~=? doInterp (bp str) + (?!=) res str = Left (bp res) ~=? doInterp (bp str) getWordTests = TestList [ "Simple" ~: badword "", - "Simple2" ~: (mkwd "$whoa", bp "") ?=? "$whoa", - "Simple with bang" ~: (mkwd "whoa!", bp " ") ?=? "whoa! " + "Simple2" ~: (mkwd "$whoa", "") ?=? "$whoa", + "Simple with bang" ~: (mkwd "whoa!", " ") ?=? "whoa! " ] - where badword str = Nothing ~=? getword (bp str) - (?=?) res str = Just res ~=? getword(bp str) + where badword str = Nothing ~=? parseWord (bp str) + (?=?) res str = Just res ~=? parseWord(bp str) nestedTests = TestList [ - "Fail nested" ~: Nothing ~=? nested (bp " { the end"), - "Pass nested" ~: Just (mkNoSub (bp " { }"), B.empty) ~=? nested (bp "{ { }}"), - "Pass empty nested" ~: Just (mkNoSub (bp " "), B.empty) ~=? nested (bp "{ }"), - "Fail nested" ~: Nothing ~=? nested (bp " { { }") + "Fail nested" ~: Nothing ~=? nested " { the end", + "Pass nested" ~: Just (" { }", "") ~=? nested "{ { }}", + "Pass empty nested" ~: Just (" ", "") ~=? nested "{ }", + "Fail nested" ~: Nothing ~=? nested " { { }", + "Pass escape" ~: "{ \\{ }" `should_be` " \\{ ", + "Pass escape 2" ~: "{ \\{ \\{ }" `should_be` " \\{ \\{ ", + "Pass escape 3" ~: "{ \\\\}" `should_be` " \\\\", + "Pass escape 4" ~: "{ \\} }" `should_be` " \\} " + ,"no bracks" ~: "happy" `should_fail` () ] + where should_be act exp = Just (bp exp, B.empty) ~=? nested (bp act) + should_fail act () = Nothing ~=? nested (bp act) parseArgsTests = TestList [ - " x " ~: "x" ?=> ([mkwd "x"], "") - ," x y " ~: " x y " ?=> ([mkwd "x", mkwd "y"], " ") - ,"x y" ~: "x y" ?=> ([mkwd "x", mkwd "y"], "") - ,"x { y 0 }" ~: "x { y 0 }" ?=> ([mkwd "x", nosub " y 0 "], "") - ,"x {y 0}" ~: "x {y 0}" ?=> ([mkwd "x", nosub "y 0"], "") + " x " ~: "x" ?=> ([mkwd "x"], "") + ," x y " ~: " x y " ?=> ([mkwd "x", mkwd "y"], " ") + ,"x y" ~: "x y" ?=> ([mkwd "x", mkwd "y"], "") + ,"x { y 0 }" ~: "x { y 0 }" ?=> ([mkwd "x", nosub " y 0 "], "") + ,"x {y 0}" ~: "x {y 0}" ?=> ([mkwd "x", nosub "y 0"], "") ] where (?=>) str (res,r) = Just (res, bp r) ~=? parseArgs (bp str) nosub s = mkNoSub (bp s) +parseListTests = TestList [ + " x " ~: " x " ?=> ["x"] + ,"" ~: "" ?=> [] + ,"\t \t " ~: "\t \t" ?=> [] + ," x y " ~: " x y " ?=> ["x", "y"] + ,"x y" ~: "x y" ?=> ["x", "y"] + ,"x { y 0 }" ~: "x { y 0 }" ?=> ["x", " y 0 "] + ,"x [puts yay]" ~: "x [puts yay]" ?=> ["x", "[puts", "yay]"] + ," y { \\{ \\{ \\{ } { x }" ~: " y { \\{ \\{ \\{ } { x }" ?=> ["y", " \\{ \\{ \\{ ", " x "] + , "unmatched fail" ~: fails " { { " + ,"x {y 0}" ~: "x {y 0}" ?=> ["x", "y 0"] + ,"with nl" ~: "x 1 \n y 2 \n z 3" ?=> ["x", "1", "y", "2", "z", "3"] + ,"escaped1" ~: "x \\{ z" ?=> ["x", "\\{", "z"] + ] + where (?=>) str res = Just res ~=? parseList (bp str) + fails str = Nothing ~=? parseList (bp str) + +parseVarRefTests = TestList [ + no_parse "" + ,"standard" ~: "boo" ?=> ("boo", "") + ,"global" ~: "::boo" ?=> ("::boo", "") + ,"arr1" ~: "boo(one) " ?=> ("boo(one)", " ") + ,"ns arr1" ~: "::big::boo(one) " ?=> ("::big::boo(one)", " ") + ,"::big(3)$::boo(one)" ?=> ("::big(3)", "$::boo(one)") + , "triple" ~: "::one::two::three" ?=> ("::one::two::three","") + , "brack" ~: "::one::{t o}::three" ?=> ("::one::t o::three","") + , "mid paren" ~: "::one::two(1)::three" ?=> ("::one::two(1)", "::three") + ] + where (?=>) str (p,r) = Just (bp p, bp r) ~=? parseVarRef (bp str) + no_parse str = Nothing ~=? parseVarRef (bp str) + runParseTests = TestList [ - "one token" ~: ([[mkwd "exit"]],"") ?=? "exit", - "empty" ~: ([[]],"") ?=? " ", - "empty2" ~: ([[]],"") ?=? "", --- "a b " ~: ([[mkwd "a", mkwd "b"]],"") ?=? "a b ", - "arr 1" ~: ([[mkwd "set",mkwd "buggy(4)", mkwd "11"]], "") ?=? "set buggy(4) 11" + "one token" ~: (pr ["exit"]) ?=? "exit", + "multi-line" ~: (pr ["puts", "44"]) ?=? " puts \\\n 44", + "escaped space" ~: (pr ["puts", "\\ "]) ?=? " puts \\ ", + "empty" ~: ([],"") ?=? " ", + "empty2" ~: ([],"") ?=? "", + "unmatched" ~: badword "{ { }", + "a b " ~: (pr ["a", "b"]) ?=? "a b ", + "two vars" ~: (pr ["puts", "$one$two"]) ?=? "puts $one$two", + "brack" ~: (pr ["puts", "${oh no}"]) ?=? "puts ${oh no}", + "arr 1" ~: (pr ["set","buggy(4)", "11"]) ?=? "set buggy(4) 11", + "arr 2" ~: (pr ["set","buggy($bean)", "11"]) ?=? "set buggy($bean) 11", + "arr 3" ~: (pr ["set","buggy($bean)", "$koo"]) ?=? "set buggy($bean) $koo" + ,"arr 4" ~: (pr ["set","buggy($bean)", "${wow}"]) ?=? "set buggy($bean) ${wow}" + ,"quoted ws arr" ~: (pr ["set","arr(1 2)", "4"]) ?=? "set \"arr(1 2)\" 4" + -- not yet TODO + -- ,"unquoted ws arr" ~: (pr ["puts","$arr(1 2)"]) ?=? "puts $arr(1 2)" + ,"expand" ~: ([(mkwd "incr", [Expand (mkwd "$boo")])], "") ?=? "incr {*}$boo" ] where badword str = Nothing ~=? runParse (bp str) (?=?) (res,r) str = Just (res, bp r) ~=? runParse (bp str) + pr (x:xs) = ([(mkwd x, map mkwd xs)], "") + pr [] = error "bad test!" bsParseTests = TestList [ nestedTests, testEscaped, brackVarTests, - parseStrTests, getInterpTests, getWordTests, wrapInterpTests, - parseArgsTests, runParseTests ] - -runUnit = runTestTT bsParseTests - + parseStrTests, getInterpTests, getWordTests, doInterpTests, + parseArgsTests, parseListTests, runParseTests, parseVarRefTests] -- # ENDTESTS # -- diff --git a/Common.hs b/Common.hs new file mode 100644 --- /dev/null +++ b/Common.hs @@ -0,0 +1,733 @@ +{-# LANGUAGE BangPatterns #-} +module Common (RetVal, TclM + ,TclState + ,Err(..) + ,TclCmd,applyTo,cmdBody,getOrigin + ,runTclM + ,makeState + ,runCheckResult + ,withLocalScope + ,withNS + ,makeCmdMap + ,mergeCmdMaps + ,getProc + ,getProcNS + ,regProc + ,varGetNS + ,varGet + ,varModify + ,varSet + ,varSetHere + ,varExists + ,varUnset + ,varUnsetNS + ,renameProc + ,getArray + ,addChan + ,removeChan + ,getChan + ,evtAdd + ,evtGetDue + ,uplevel + ,upvar + ,makeEnsemble + ,io + ,tclErr + ,treturn + ,ret + ,argErr + ,stackLevel + ,globalVars + ,localVars + ,currentVars + ,currentNS + ,parentNS + ,existsNS + ,deleteNS + ,childrenNS + ,variableNS + ,exportNS + ,getExportsNS + ,importNS + ,checkpoint + ,commandNames + ,commonTests + ) where + +import qualified Data.ByteString.Char8 as B +import Control.Monad.Error +import Control.Monad.State.Strict +import qualified Data.Map as Map +import Data.IORef +import Data.Unique + +import qualified EventMgr as Evt + +import qualified TclObj as T +import TclChan +import VarName +import Util + +import Test.HUnit + +type RetVal = T.TclObj + +data Err = ERet !RetVal | EBreak + | EContinue | EDie String deriving (Eq,Show) + +instance Error Err where + noMsg = EDie "An error occurred." + strMsg s = EDie s + +type TclM = ErrorT Err (StateT TclState IO) + +checkpoint str f = f `catchError` handle + where handle (EDie es) = throwError (EDie (str ++ es)) + handle e = throwError e + +data Namespace = TclNS { + nsName :: BString, + nsProcs :: CmdMap, + nsFrame :: FrameRef, + nsExport :: [BString], + nsParent :: Maybe NSRef, + nsChildren :: Map.Map BString NSRef } + + +type FrameRef = IORef TclFrame +type NSRef = IORef Namespace + +data TclFrame = TclFrame { + frVars :: !VarMap, + upMap :: Map.Map BString (FrameRef,BString), + frNS :: NSRef, + frTag :: Int } + +type TclStack = [FrameRef] + +data TclState = TclState { + tclChans :: ChanMap, + tclEvents :: Evt.EventMgr T.TclObj, + tclStack :: !TclStack, + tclGlobalNS :: !NSRef } + +type TclCmd = [T.TclObj] -> TclM T.TclObj +data TclCmdObj = TclCmdObj { + cmdName :: BString, + cmdBody :: BString, + cmdOrigNS :: Maybe BString, + cmdAction :: TclCmd } + +type ProcKey = BString +data CmdMap = CmdMap { + cmdMapEpoch :: !Int, + unCmdMap :: !(Map.Map ProcKey TclCmdObj) + } + +type TclArray = Map.Map BString T.TclObj +data TclVar = ScalarVar !T.TclObj | ArrayVar TclArray | Undefined deriving (Eq,Show) +type VarMap = Map.Map BString TclVar + + +getOrigin p = if nso == nsSep + then return $ B.append nso pname + else return $ B.concat [nso, nsSep, pname] + where nso = maybe nsSep id (cmdOrigNS p) + pname = cmdName p + +applyTo !(TclCmdObj _ _ _ !f) !args = f args +{-# INLINE applyTo #-} + +mkProcAlias nsr pn = do + pr <- getProcNorm pn nsr + case pr of + Nothing -> fail "trying to import proc that doesn't exist" + Just p -> return $ p { cmdAction = inner } + where inner args = do thep <- getProcNorm pn nsr + case thep of + Nothing -> tclErr "bad imported command. Yikes" + Just p -> p `applyTo` args + +globalNS fr = do + return $ TclNS { nsName = nsSep, + nsProcs = emptyCmdMap, nsFrame = fr, + nsExport = [], + nsParent = Nothing, nsChildren = Map.empty } + +makeCmdMap :: [(String,TclCmd)] -> CmdMap +makeCmdMap = CmdMap 0 . Map.fromList . map toTclCmdObj . mapFst pack + +toTclCmdObj (n,v) = (n, TclCmdObj n errStr Nothing v) + where errStr = pack $ show n ++ " isn't a procedure" + +tclErr :: String -> TclM a +tclErr s = do + (setErrorInfo s) `orElse` ret + throwError (EDie s) + +setErrorInfo s = do + glFr <- getGlobalNS >>= getNSFrame + varSet' (VarName (pack "errorInfo") Nothing) (T.mkTclStr s) glFr + +mergeCmdMaps :: [CmdMap] -> CmdMap +mergeCmdMaps = CmdMap 0 . Map.unions . map unCmdMap + +makeVarMap = Map.fromList . mapSnd ScalarVar + +makeState :: [(BString,T.TclObj)] -> CmdMap -> IO TclState +makeState = makeState' baseChans + +makeState' :: ChanMap -> [(BString,T.TclObj)] -> CmdMap -> IO TclState +makeState' chans vlist procs = do + fr <- createFrame (makeVarMap vlist) + gns <- globalNS fr + ns <- newIORef (gns { nsProcs = procs }) + setFrNS fr ns + addChildNS ns (pack "") ns + return $! TclState { tclChans = chans, + tclEvents = Evt.emptyMgr, + tclStack = [fr], + tclGlobalNS = ns } + +getStack = gets tclStack +{-# INLINE getStack #-} +getNsCmdMap nsr = (io . readIORef) nsr >>= \v -> return $! (nsProcs v) +{-# INLINE getNsCmdMap #-} + +putStack s = modify (\v -> v { tclStack = s }) +{-# INLINE putStack #-} +modStack :: (TclStack -> TclStack) -> TclM () +modStack f = modify (\v -> v { tclStack = f (tclStack v) }) +{-# INLINE modStack #-} +getFrame = do st <- gets tclStack + case st of + (fr:_) -> return $! fr + _ -> tclErr "stack badness" +{-# INLINE getFrame #-} + +io :: IO a -> TclM a +io = liftIO +{-# INLINE io #-} + +stackLevel = getStack >>= return . pred . length +globalVars = getGlobalNS >>= getNSFrame >>= getFrameVars >>= return . Map.keys +localVars = getFrame >>= getFrameVars >>= return . Map.keys +currentVars = do f <- getFrame + vs <- getFrameVars f + mv <- getUpMap f + return $ Map.keys vs ++ Map.keys mv + +commandNames = getCurrNS >>= getNsCmdMap >>= return . Map.keys . unCmdMap + + + +argErr s = tclErr ("wrong # of args: " ++ s) + +runTclM :: TclM a -> TclState -> IO (Either Err a, TclState) +runTclM code env = runStateT (runErrorT code) env + +onChan f = gets tclChans >>= f +modChan f = modify (\s -> s { tclChans = f (tclChans s) }) +getChan n = onChan (\m -> return (lookupChan n m)) +addChan c = modChan (insertChan c) +removeChan c = modChan (deleteChan c) + +evtAdd e t = do + em <- gets tclEvents + (tag,m) <- io $ Evt.addEvent e t em + modify (\s -> s { tclEvents = m }) + treturn tag + +evtGetDue = do + em <- gets tclEvents + (d,em') <- io $ Evt.getDue em + when (not (null d)) $ modify (\s -> s { tclEvents = em' }) + return d + +upped !s !fr = getUpMap fr >>= \f -> return $! (Map.lookup s f) +{-# INLINE upped #-} + +getProc !pname = getProcNS (parseProc pname) + +-- TODO: Special case for globals and locals when we're in the global NS? +getProcNS (NSQual nst n) = do + res <- (getNamespace nst >>= getProcNorm n) `ifFails` Nothing + if isNothing res && not (isGlobalQual nst) + then do ns2 <- if noNsQual nst then getGlobalNS else getNamespace (asGlobal nst) + getProcNorm n ns2 + else return $! res + where + isNothing Nothing = True + isNothing _ = False +{-# INLINE getProcNS #-} + +getProcNorm :: ProcKey -> NSRef -> TclM (Maybe TclCmdObj) +getProcNorm !i !nsr = do + currpm <- getNsCmdMap nsr + return $! (pmLookup i currpm) +{-# INLINE getProcNorm #-} + +pmLookup :: ProcKey -> CmdMap -> Maybe TclCmdObj +pmLookup !i !m = Map.lookup i (unCmdMap m) +{-# INLINE pmLookup #-} + +rmProc name = rmProcNS (parseProc name) +rmProcNS (NSQual nst n) = getNamespace nst >>= rmFromNS + where rmFromNS nsref = io $ changeProcs nsref (Map.delete n) + + +regProc name body pr = + let (NSQual nst n) = parseProc name + in regProcNS nst n (TclCmdObj n body Nothing pr) + +regProcNS nst k newProc = getNamespace nst >>= regInNS + where + pmInsert proc m = Map.insert k proc m + regInNS nsr = do fn <- nsr `refExtract` nsName + io $ changeProcs nsr (pmInsert (setOrigin fn newProc)) + return () + setOrigin fn x = if cmdOrigNS x == Nothing then x { cmdOrigNS = Just fn } else x + +varSet :: BString -> T.TclObj -> TclM RetVal +varSet !n v = varSetNS (parseVarName n) v +{-# INLINE varSet #-} + +varSetNS qvn v = usingNsFrame qvn (\n f -> varSet' n v f) +{-# INLINE varSetNS #-} + +varSetHere vn v = getFrame >>= varSet' vn v + +varSet' vn v frref = do + isUpped <- upped (vnName vn) frref + case isUpped of + Nothing -> modVar (vnName vn) >> return v + Just (f,s) -> varSet' (vn {vnName = s}) v f + where cantSetErr why = fail $ "can't set " ++ showVN vn ++ ":" ++ why + modVar str = do + vm <- getFrameVars frref + let changeVar = insertVar frref str + case vnInd vn of + Nothing -> case Map.lookup str vm of + Just (ArrayVar _) -> cantSetErr "variable is array" + _ -> changeVar (ScalarVar v) + Just i -> case Map.findWithDefault (ArrayVar Map.empty) str vm of + ArrayVar prev -> changeVar (ArrayVar (Map.insert i v prev)) + Undefined -> changeVar (ArrayVar (Map.singleton i v)) + _ -> cantSetErr "variable isn't array" + + +varModify :: BString -> (T.TclObj -> TclM T.TclObj) -> TclM RetVal +varModify !n f = do + let vn = parseVarName n + val <- varGetNS vn + res <- f val + varSetNS vn res +{-# INLINE varModify #-} + +varExists :: BString -> TclM Bool +varExists name = (varGet name >> return True) `catchError` (\_ -> return False) + +renameProc old new = do + mpr <- getProc old + case mpr of + Nothing -> tclErr $ "can't rename, bad command " ++ show old + Just pr -> do rmProc old + unless (bsNull new) (regProc new (cmdBody pr) (cmdAction pr)) + +varUnset :: BString -> TclM RetVal +varUnset name = varUnsetNS (parseVarName name) + +varUnsetNS :: NSQual VarName -> TclM RetVal +varUnsetNS qns = usingNsFrame qns varUnset' + +usingNsFrame :: NSQual VarName -> (VarName -> FrameRef -> TclM RetVal) -> TclM RetVal +usingNsFrame (NSQual !ns !vn) f = lookupNsFrame ns >>= f vn + where lookupNsFrame Nothing = getFrame + lookupNsFrame ns = getNamespace ns >>= getNSFrame +{-# INLINE usingNsFrame #-} + +{- This specialization is ugly, but GHC hasn't been doing it for me and it + - knocks a few percent off the runtime of my benchmarks. -} +usingNsFrame2 :: NSQual BString -> (BString -> FrameRef -> TclM b) -> TclM b +usingNsFrame2 (NSQual !ns !vn) f = lookupNsFrame ns >>= f vn + where lookupNsFrame Nothing = getFrame + lookupNsFrame ns = getNamespace ns >>= getNSFrame +{-# INLINE usingNsFrame2 #-} + +varUnset' vn frref = do + isUpped <- upped (vnName vn) frref + case isUpped of + Nothing -> modVar >> ret + Just (f,s) -> do + when (not (isArr vn)) $ do + changeUpMap frref (Map.delete (vnName vn)) + varUnset' (vn {vnName = s}) f + where noExist = cantUnset "no such variable" + cantUnset why = fail $ "can't unset " ++ showVN vn ++ ": " ++ why + modVar = do + vm <- getFrameVars frref + let str = vnName vn + let deleteVar = changeVars frref (Map.delete str) + val <- maybe noExist return (Map.lookup str vm) + case vnInd vn of + Nothing -> deleteVar + Just i -> case val of + ArrayVar prev -> case Map.lookup i prev of + Nothing -> cantUnset "no such element in array" + Just _ -> insertVar frref str (prev `modArr` (Map.delete i)) + ScalarVar _ -> cantUnset "variable isn't array" + _ -> noExist + +modArr v f = ArrayVar (f v) + +getArray :: BString -> TclM TclArray +getArray name = usingNsFrame2 (parseProc name) getArray' + +getArray' :: BString -> FrameRef -> TclM TclArray +getArray' name frref = do + var <- varLookup name frref + case var of + Just (ArrayVar a) -> return a + Just _ -> tclErr $ "can't read " ++ show name ++ ": variable isn't array" + Nothing -> tclErr $ "can't read " ++ show name ++ ": no such variable" + +varLookup !name !frref = do + isUpped <- upped name frref + case isUpped of + Nothing -> getFrameVars frref >>= \m -> return $! (Map.lookup name m) + Just (f,n) -> varLookup n f +{-# INLINE varLookup #-} + +varGet :: BString -> TclM RetVal +varGet !n = varGetNS (parseVarName n) + +varGetNS :: NSQual VarName -> TclM RetVal +varGetNS qns = usingNsFrame qns varGet' +{-# INLINE varGetNS #-} + +varGet' vn !frref = do + var <- varLookup (vnName vn) frref + case var of + Nothing -> cantReadErr "no such variable" + Just o -> o `getInd` (vnInd vn) + where cantReadErr why = fail $ "can't read " ++ showVN vn ++ ": " ++ why + getInd (ScalarVar o) Nothing = return o + getInd (ScalarVar _) _ = cantReadErr "variable isn't array" + getInd (ArrayVar o) (Just i) = maybe (cantReadErr "no such element in array") return (Map.lookup i o) + getInd (ArrayVar _) _ = cantReadErr "variable is array" + getInd Undefined _ = cantReadErr "no such variable" + + +uplevel :: Int -> TclM a -> TclM a +uplevel i p = do + (curr,new) <- liftM (splitAt i) getStack + when (null new) (tclErr ("bad level: " ++ show i)) + putStack new + res <- p `ensure` (modStack (curr ++)) + return res +{-# INLINE uplevel #-} + +getUpFrame i = do st <- getStack + if length st <= i + then fail "too far up the stack" + else return $! (st!!i) + +linkToFrame name (upfr, upname) = do + frref <- getFrame + changeUpMap frref (Map.insert name (upfr, upname)) + +upvar n d s = do + upfr <- getUpFrame n + s `linkToFrame` (upfr, d) +{-# INLINE upvar #-} + +deleteNS name = do + nst <- parseNSTag name + ns <- getNamespace' nst >>= readRef + case nsParent ns of + Nothing -> return () + Just p -> removeChild p (nsTail nst) + +removeChild nsr child = io (modifyIORef nsr (\v -> v { nsChildren = Map.delete child (nsChildren v) } )) +addChildNS nsr name child = (modifyIORef nsr (\v -> v { nsChildren = Map.insert name child (nsChildren v) } )) + +getNamespace Nothing = getCurrNS +getNamespace (Just nst) = getNamespace' nst +{-# INLINE getNamespace #-} + +-- TODO: Unify namespace getters +getNamespace' (NS gq nsl) = do + base <- if gq then getGlobalNS else getCurrNS + foldM getKid base nsl + where getKid !nsref !k = do + kids <- nsref `refExtract` nsChildren + case Map.lookup k kids of + Nothing -> tclErr $ "can't find namespace " ++ show k ++ " in " ++ show nsl + Just v -> return $! v + +getOrCreateNamespace (NS gq nsl) = do + base <- if gq then getGlobalNS else getCurrNS + foldM getKid base nsl + where getKid nsref k = do + kids <- nsref `refExtract` nsChildren + case Map.lookup k kids of + Nothing -> io (mkEmptyNS k nsref) + Just v -> return $! v + +existsNS ns = (parseNSTag ns >>= getNamespace' >> return True) `catchError` (\_ -> return False) + +variableNS name val = do + let (NSQual ns (VarName n ind)) = parseVarName name + ensureNotArr ind + nsfr <- getNamespace ns >>= getNSFrame + fr <- getFrame + same <- sameTags fr nsfr + if same then insertVar fr name varVal + else n `linkToFrame` (nsfr, n) + where + ensureNotArr Nothing = return () + ensureNotArr (Just _) = tclErr $ "can't define " ++ show name ++ ": name refers to value in array" + varVal = maybe Undefined ScalarVar val + sameTags f1 f2 = do + t1 <- getTag f1 + t2 <- getTag f2 + return (t1 == t2) + +exportNS clear name = do + nsr <- getCurrNS + io $ modifyIORef nsr (\n -> n { nsExport = (name:(getPrev n)) }) + where getPrev n = if clear then [] else nsExport n + +getExportsNS = do + getCurrNS >>= readRef >>= return . reverse . nsExport + +importNS force name = do + let (NSQual nst n) = parseProc name + nsr <- getNamespace nst + exported <- getExports nsr n + mapM (importProc nsr) exported + return . T.mkTclList . map T.mkTclBStr $ exported + where importProc nsr n = do + np <- mkProcAlias nsr n + when (not force) $ do + oldp <- getProcNS (NSQual Nothing n) + case oldp of + Nothing -> return () + Just _ -> tclErr $ "can't import command " ++ show n ++ ": already exists" + regProcNS Nothing n np + getExports nsr pat = do + ns <- readRef nsr + let exlist = nsExport ns + let pnames = Map.keys (unCmdMap (nsProcs ns)) + let filt = filter (\v -> or (map (`globMatch` v) exlist)) pnames + return (globMatches pat filt) + + +getTag frref = do + f <- readRef frref + return (frTag f) + +setFrNS !frref !nsr = modifyIORef frref (\f -> f { frNS = nsr }) + +withLocalScope vl f = do + ns <- getCurrNS + fr <- io $! createFrameWithNS ns $! makeVarMap vl + withScope fr f +{-# INLINE withLocalScope #-} + +withScope :: FrameRef -> TclM a -> TclM a +withScope !frref fun = do + stack <- getStack + -- when (length stack > 10000) (tclErr $ "Stack too deep: " ++ show 10000) + putStack $ frref : stack + fun `ensure` (modStack (drop 1)) + +mkEmptyNS name parent = do + pname <- liftM nsName (readIORef parent) + emptyFr <- createFrame emptyVarMap + let sep = if pname == nsSep then B.empty else nsSep + let fullname = B.concat [pname, sep, name] + new <- newIORef $ TclNS { nsName = fullname, + nsProcs = emptyCmdMap, nsFrame = emptyFr, + nsExport = [], + nsParent = Just parent, nsChildren = Map.empty } + addChildNS parent name new + setFrNS emptyFr new + return $! new + +withNS :: BString -> TclM a -> TclM a +withNS name f = do + newCurr <- parseNSTag name >>= getOrCreateNamespace + withExistingNS f newCurr + +withExistingNS f !nsref = do + fr <- getNSFrame nsref + withScope fr f + +getFrameVars :: FrameRef -> TclM VarMap +getFrameVars !frref = (frref `refExtract` frVars) >>= \r -> return $! r +{-# INLINE getFrameVars #-} + +getUpMap !frref = (frref `refExtract` upMap) >>= \r -> return $! r +{-# INLINE getUpMap #-} + +getNSFrame :: NSRef -> TclM FrameRef +getNSFrame !nsref = nsref `refExtract` nsFrame + + +getCurrNS = getFrame >>= liftIO . readIORef >>= \f -> return $! (frNS f) +{-# INLINE getCurrNS #-} + +getGlobalNS = gets tclGlobalNS + +readRef :: IORef a -> TclM a +readRef !r = (liftIO . readIORef) r +{-# INLINE readRef #-} + +refExtract !ref !f = readRef ref >>= \d -> let r = f d in r `seq` (return $! r) +{-# INLINE refExtract #-} + +currentNS = getCurrNS >>= readRef >>= return . nsName + +parentNS = do + ns <- getCurrNS >>= readRef + case nsParent ns of + Nothing -> return B.empty + Just v -> readRef v >>= return . nsName + +childrenNS :: TclM [BString] +childrenNS = do + ns <- getCurrNS >>= readRef + (return . Map.keys . nsChildren) ns + +ensure action p = do + r <- action `catchError` (\e -> p >> throwError e) + p + return $! r + +ret :: TclM RetVal +ret = return T.empty +{-# INLINE ret #-} + +treturn :: BString -> TclM RetVal +treturn = return . T.mkTclBStr +{-# INLINE treturn #-} + +createFrame !vref = do + tag <- liftM hashUnique newUnique + res <- newIORef $! TclFrame { frVars = vref, upMap = Map.empty, frTag = tag, frNS = undefined } + return $! res + +createFrameWithNS !nsref !vref = do + tag <- liftM hashUnique newUnique + res <- newIORef $! TclFrame { frVars = vref, upMap = Map.empty, frTag = tag, frNS = nsref } + return $! res + +changeUpMap fr fun = io (modifyIORef fr (\f -> f { upMap = fun (upMap f) })) + +changeVars !fr fun = io (modifyIORef fr (\f -> let r = fun (frVars f) in r `seq` f { frVars = r } )) +{-# INLINE changeVars #-} + +insertVar fr k v = changeVars fr (Map.insert k v) +{-# INLINE insertVar #-} + +changeProcs nsr fun = do + ns <- readIORef nsr + modKids (\x -> changeProcs x id) ns + writeIORef nsr (updateNS ns) + where update (CmdMap e m) = CmdMap (e+1) (fun m) + updateNS ns = ns { nsProcs = update (nsProcs ns) } + +modKids f ns = let kidfun kr = do + kid <- readIORef kr + when (nsParent kid /= Nothing) (f kr) + in mapM_ kidfun (Map.elems (nsChildren ns)) + +makeEnsemble name subs = top + where top args = case args of + (x:xs) -> case Map.lookup (T.asBStr x) (unCmdMap subMap) of + Nothing -> tclErr $ "unknown subcommand " ++ show (T.asBStr x) ++ ": must be " + ++ commaList "or" (map unpack (cmdMapNames subMap)) + Just f -> (cmdAction f) xs + [] -> argErr $ " should be \"" ++ name ++ "\" subcommand ?arg ...?" + subMap = makeCmdMap subs + cmdMapNames = map cmdName . Map.elems . unCmdMap + +emptyCmdMap = CmdMap 0 Map.empty +emptyVarMap = Map.empty + +-- # TESTS # -- + +runCheckResult :: TclM RetVal -> Either Err RetVal -> IO Bool +runCheckResult t v = + do st <- makeState' Map.empty [] emptyCmdMap + retv <- liftM fst (runTclM t st) + return (retv == v) + +errWithEnv :: TclM a -> IO (Either Err a) +errWithEnv t = + do st <- makeState' Map.empty [] emptyCmdMap + retv <- liftM fst (runTclM t st) + return retv + +commonTests = TestList [ setTests, getTests, unsetTests, withScopeTests ] where + + b = pack + + evalWithEnv :: TclM a -> IO (Either Err a, TclStack) + evalWithEnv t = + do st <- makeState' Map.empty [] emptyCmdMap + (retv, resStack) <- runTclM t st + return (retv, tclStack resStack) + + + checkErr a s = errWithEnv a >>= \v -> assertEqual "err match" (Left (EDie s)) v + checkNoErr a = errWithEnv a >>= \v -> assertBool "err match" (isRight v) + + checkExists a n = do (_,(v:_)) <- evalWithEnv a + vExists n v + + vExists vn env = readIORef env >>= \fr -> return (frVars fr) >>= \vm -> assert (Map.member (b vn) vm) + + checkEq :: TclM t -> String -> T.TclObj -> Assertion + checkEq a n val = do (_,(v:_)) <- evalWithEnv a + vEq n v val + + vEq vn env val = do + vm <- readIORef env >>= return . frVars + assert ((Map.lookup (b vn) vm) == (Just (ScalarVar val))) + + value = int 666 + name = b "varname" + + isRight (Right _) = True + isRight _ = False + int = T.mkTclInt + + setTests = TestList [ + "set exists" ~: (varSet (b "x") (int 1)) `checkExists` "x" + ,"set exists2" ~: (varSet (b "boogie") (int 1)) `checkExists` "boogie" + ,"checkeq" ~: checkEq (varSet name value) "varname" value + ] + withScopeTests = TestList [ + "with scope" ~: getVM (varSet (b "x") (int 1)) (\m -> not (Map.null m)) + ] + where getVM f c = do vmr <- createFrame emptyVarMap + (res,_) <- evalWithEnv (withScope vmr f) + case res of + Left e -> error (show e) + Right _ -> do fr <- readIORef vmr + vm <- return (frVars fr) + assertBool "getVM" (c vm) + + + getTests = TestList [ + "non-exist" ~: (varGet (b "boo")) `checkErr` "can't read \"boo\": no such variable" + ,"no err if exists" ~: checkNoErr ((varSet name value) >> varGet name) + ] + + unsetTests = TestList [ + "non-exist" ~: (varUnset (b "boo")) `checkErr` "can't unset \"boo\": no such variable" + ] + +-- # ENDTESTS # -- diff --git a/Core.hs b/Core.hs new file mode 100644 --- /dev/null +++ b/Core.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE BangPatterns #-} +module Core (evalTcl, doCond, subst, callProc, coreTests) where + +import Common +import qualified TclObj as T +import qualified Data.ByteString.Char8 as B +import RToken +import Util +import VarName (arrName, NSQual(..)) + +import Test.HUnit + +evalTcl :: T.TclObj -> TclM RetVal +evalTcl s = runCmds =<< asParsed s +{-# INLINE evalTcl #-} + +runCmds [x] = runCmd x +runCmds (x:xs) = runCmd x >> runCmds xs +runCmds [] = ret + + +getSubst s = do + case asParsed s of + Just cmds -> do + let toks = concatMap uncmd cmds + if all noInterp toks + then return (Left (T.asBStr s)) + else return (Right toks) + Nothing -> tclErr "subst failed: currently, doesn't work on stuff that we can't tokenize" -- TODO + where uncmd (Right n,args) = (n:args) + uncmd (Left (NSQual nst n), args) = if nst == Nothing then ((Lit n):args) else error (show (nst,n)) + +subst s = getSubst s >>= doeval + where doeval (Right t) = evalRTokens t [] >>= return . B.concat . map T.asBStr + doeval (Left s) = return s + +callProc :: BString -> [T.TclObj] -> TclM T.TclObj +callProc pn args = do + getProc pn >>= \pr -> doCall pn pr args + +evalRTokens :: [RToken] -> [T.TclObj] -> TclM [T.TclObj] +evalRTokens [] !acc = return $! reverse acc +evalRTokens (x:xs) !acc = case x of + Lit s -> evalRTokens xs ((T.mkTclBStr s):acc) + LitInt i -> evalRTokens xs ((T.mkTclInt i):acc) + CmdTok t -> nextWith (runCmd t) + VarRef vn -> nextWith (varGetNS vn) + Block s p -> evalRTokens xs ((T.fromBlock s p):acc) + ArrRef ns n i -> do + ni <- evalRTokens [i] [] >>= return . T.asBStr . head + nextWith (varGetNS (NSQual ns (arrName n ni))) + CatLst l -> nextWith (evalRTokens l [] >>= treturn . B.concat . map T.asBStr) + ExpTok t -> do + [rs] <- evalRTokens [t] [] + l <- T.asList rs + evalRTokens xs ((reverse l) ++ acc) + where nextWith f = f >>= \r -> evalRTokens xs (r:acc) + +runCmd :: Cmd -> TclM RetVal +runCmd (n,args) = do + evArgs <- evalRTokens args [] + res <- evArgs `seq` go n evArgs + return $! res + where go (Left p@(NSQual _ name)) a = getProcNS p >>= \pr -> doCall name pr a + go (Right rt) a = do lst <- evalRTokens [rt] [] + let (o:rs) = lst ++ a + let name = T.asBStr o + getProc name >>= \pr -> doCall name pr rs + + +doCall !pn !mproc args = do + case mproc of + Nothing -> do ukproc <- getProc (pack "unknown") + case ukproc of + Nothing -> tclErr $ "invalid command name " ++ show pn + Just uk -> uk `applyTo` ((T.mkTclBStr pn):args) + Just proc -> proc `applyTo` args +{-# INLINE doCall #-} + +doCond :: T.TclObj -> TclM Bool +doCond str = do + p <- asParsed str + case p of + [x] -> do r <- runCmd x + return $! T.asBool r + _ -> tclErr "Too many statements in conditional" +{-# INLINE doCond #-} + +coreTests = TestList [] + diff --git a/EventMgr.hs b/EventMgr.hs new file mode 100644 --- /dev/null +++ b/EventMgr.hs @@ -0,0 +1,31 @@ +module EventMgr (EventMgr,addEvent,getDue, emptyMgr) where +import Data.Time.Clock +import Util +import Data.List (sortBy,partition) +import Data.Unique +import Data.Ord (comparing) +import Control.Monad (liftM) + +type EvtID = BString +data Event a = Evt { evtTime :: UTCTime, + evtID :: EvtID, + evtAction :: a } + +newtype EventMgr a = EventMgr [Event a] + +emptyMgr = EventMgr [] +mgrInsert evt (EventMgr evts) = EventMgr (sortBy (comparing evtTime) (evt:evts)) + +getNextID :: IO EvtID +getNextID = do + num <- liftM hashUnique newUnique + return $! pack ("after#" ++ show num) + +addEvent act deadline el = do + id <- getNextID + return $ (id, mgrInsert (Evt { evtTime = deadline, evtID = id, evtAction = act }) el) + +getDue (EventMgr evts) = do + currTime <- getCurrentTime + let (due,rest) = partition (\x -> evtTime x <= currTime) evts + return (map evtAction due, EventMgr rest) diff --git a/ExprParse.hs b/ExprParse.hs new file mode 100644 --- /dev/null +++ b/ExprParse.hs @@ -0,0 +1,267 @@ +module ExprParse (exprParseTests, riExpr, exprCompile) where +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec.Expr +import qualified TclLib.MathProcs as Math +import Test.HUnit + +import qualified TclObj as T +import qualified Data.Map as M + +import Util + +lexer :: P.TokenParser () +lexer = P.makeTokenParser emptyDef + +intOrFloat = P.naturalOrFloat lexer +symbol = P.symbol lexer +schar c = char c >> P.whiteSpace lexer +identifier = P.identifier lexer +stringLit = P.stringLiteral lexer + +data Op = OpDiv | OpPlus | OpMinus | OpTimes | OpEql | OpNeql | + OpLt | OpGt | OpLte | OpGte | OpStrNe | OpStrEq | OpAnd | + OpOr + deriving (Show,Eq) + +data TExp = TOp !Op TExp TExp | TNot TExp | TVar String | TFun String [TExp] | TVal T.TclObj deriving (Show,Eq) + +exprCompile :: (Monad m) => String -> m (Callback m -> m T.TclObj) +exprCompile s = do v <- expr s + return $ runExpr v + + +expr s = case parse pexpr "" s of + Left err -> fail $ "Bad parse: (" ++ s ++ "): " ++ show err + Right res -> return res + +instance Num TExp where + a + b = TOp OpPlus a b + (-) = TOp OpMinus + (*) = TOp OpTimes + abs = undefined + signum = undefined + negate = undefined + fromInteger i = TVal (T.mkTclInt (fromIntegral i)) + +(.&&) = TOp OpAnd +(.||) = TOp OpOr + +(.<) = TOp OpLt +(.<=) = TOp OpLte +(.>) = TOp OpGt +(.>=) = TOp OpGte +(.==) = TOp OpEql + +eq = TOp OpStrEq +ne = TOp OpStrNe + +objapply :: (Monad m) => Callback m -> (T.TclObj -> T.TclObj -> m T.TclObj) -> TExp -> TExp -> m T.TclObj +objapply lu f x y = do + i1 <- runExpr x lu + i2 <- runExpr y lu + f i1 i2 +{-# INLINE objapply #-} + +funapply lu fn al = do + args <- mapM (\v -> runExpr v lu) al + lu (mkCmd fn args) + +type CBData = Either BString (BString, [T.TclObj]) +type Callback m = (CBData -> m T.TclObj) + +mkCmd a b = Right (pack a,b) + +runExpr :: (Monad m) => TExp -> Callback m -> m T.TclObj +runExpr exp lu = + case exp of + (TOp OpPlus a b) -> objap Math.plus a b + (TOp OpTimes a b) -> objap Math.times a b + (TOp OpMinus a b) -> objap Math.minus a b + (TOp OpDiv a b) -> objap Math.divide a b + (TOp OpEql a b) -> objap (up Math.equals) a b + (TOp OpLt a b) -> objap (up Math.lessThan) a b + (TOp OpNeql a b) -> objap (up Math.notEquals) a b + (TOp OpGt a b) -> objap (up Math.greaterThan) a b + (TOp OpLte a b) -> objap (up Math.lessThanEq) a b + (TOp OpGte a b) -> objap (up Math.greaterThanEq) a b + (TOp OpStrEq a b) -> objap (sup T.strEq) a b + (TOp OpStrNe a b) -> objap (sup T.strNe) a b + (TOp OpAnd a b) -> objap (procBool (&&)) a b + (TOp OpOr a b) -> objap (procBool (||)) a b + (TNot v) -> runExpr v lu >>= return . T.fromBool . not . T.asBool + (TVal v) -> return $! v + (TVar n) -> lu (Left (pack n)) + (TFun fn al) -> funapply lu fn al + where objap = objapply lu + up f a b = return (f a b) + sup f a b = return (T.fromBool (f a b)) + +procBool f a b = do + let ab = T.asBool a + let bb = T.asBool b + return $! T.fromBool (ab `f` bb) + +pexpr :: Parser TExp +pexpr = do + many space + res <- myexpr + many space + eof + return res + +myexpr = buildExpressionParser table factor + +table = [[op1 '*' (OpTimes) AssocLeft, op1 '/' (OpDiv) AssocLeft] + ,[op1 '+' (OpPlus) AssocLeft, op1 '-' (OpMinus) AssocLeft] + ,[op "==" (OpEql) AssocLeft, op "!=" (OpNeql) AssocLeft] + ,[op "eq" OpStrEq AssocLeft, op "ne" OpStrNe AssocLeft] + ,[tryop "<=" (OpLte) AssocLeft, tryop ">=" (OpGte) AssocLeft] + ,[op1 '<' OpLt AssocLeft, op1 '>' OpGt AssocLeft] + ,[op "&&" OpAnd AssocLeft, op "||" OpOr AssocLeft] + ,[prefix '!' TNot] + ] + where + op s f assoc = Infix (do{ symbol s; return (TOp f)}) assoc + op1 s f assoc = Infix (do{ schar s; return (TOp f)}) assoc + tryop s f assoc = Infix (do{ try(symbol s); return (TOp f)}) assoc + prefix c f = Prefix (do { schar c; return f}) + +factor = nested <|> numval + <|> boolval <|> mystr <|> myvar <|> myfun "term" + where nested = do + schar '(' + x <- myexpr + schar ')' + return x + +neg = (char '-' >> return True) + <|> (char '+' >> return False) + <|> return False + +numval = do n <- neg + let adj v = if n then negate v else v + iorf <- intOrFloat + return $ case iorf of + Left i -> tInt (adj (fromIntegral i)) + Right f -> tFloat (adj f) + + +mystr = do s <- stringLit + return $ tStr s + "string" + +boolval = do + b <- ((s "true" <|> try (s "on")) >> return True) + <|> ((s "false" <|> s "off") >> return False) + return . TVal $ T.fromBool b + where s str = symbol str + +myvar = do char '$' + s <- identifier + return $ TVar s + "variable" + +myfun = do s <- identifier + schar '(' + inner <- myexpr `sepBy` (char ',') + schar ')' + return $ TFun s inner + + +--- Unit Testing --- + +ptest a (p,s) = a ~=? (tparse p s) + where tparse p s = case parse p "" s of + Left _ -> Nothing + Right res -> Just res + +a ?=? x = ptest (Just a) x +isBad x = ptest Nothing x + +aNumberTests = TestList + ["ANumber1" ~: (tInt 3) ?=? (numval, "3"), + "double" ~: (tFloat 1.25) ?=? (numval, "1.25"), + "ANumber2" ~: (tInt (-1)) ?=? (numval, "-1"), + "ANumber3" ~: isBad (numval, "Button")] + +stringTests = TestList [ + "string1" ~: (tStr "boo") ?=? (mystr, "\"boo\"") + ,"string2" ~: (tStr "") ?=? (mystr, "\"\"") + ,"string3" ~: (tStr "44") ?=? (mystr, "\"44\"") + ] + +varTests = TestList [ + "var1" ~: (TVar "boo") ??= "$boo" + ,"var2" ~: (TVar "keebler") ??= "$keebler" + ,"var3" ~: bad "$" + ] + where bad v = ptest Nothing (myvar,v) + a ??= v = ptest (Just a) (myvar,v) + +tInt i = TVal (T.mkTclInt i) +tStr s = TVal (T.mkTclStr s) +tFloat f = TVal (T.mkTclDouble f) + +exprTests = TestList + [ "expr1" ~: (tInt 3) ?=? (pexpr, "3") + ,"expr2" ~: ((tInt 3) + (tInt 1)) ?=? (pexpr, "3+1") + ,"var+var" ~: ((TVar "a") + (TVar "b")) ?=? (pexpr, "$a+$b") + ,"expr2 in paren" ~: ((tInt 3) + (tInt 1)) ?=? (pexpr, "(3+1)") + ,"expr2 in paren 2" ~: ((tInt 3) + (tInt 1)) ?=? (pexpr, "((3)+1)") + ,"expr3" ~: ((tInt 2) + (tInt 5) * (tInt 5)) ?=? (pexpr, "2+5*5") + ,"lt" ~: ((tInt 2) .< (tInt 5)) ?=? (pexpr, "2 < 5") + ,"lte" ~: ((tInt 2) .<= (tInt 5)) ?=? (pexpr, "2 <= 5") + ,"gt" ~: ((tInt 5) .> (tInt 5)) ?=? (pexpr, "5 > 5") + ,"gte" ~: ((tInt 6) .>= (tInt 5)) ?=? (pexpr, "6 >= 5") + ,"string eq" ~: ((tStr "X") `eq` (tStr "Y")) ?=? (pexpr, "\"X\" eq \"Y\"") + ,"string eq var" ~: ((TVar "X") `eq` (tStr "Y")) ?=? (pexpr, "$X eq \"Y\"") + ,"string ne" ~: ((tStr "X") `ne` (tStr "Y")) ?=? (pexpr, " \"X\" ne \"Y\"") + ,"varstorm1" ~: (((TVar "me") + (TVar "hey")) .< (TVar "something")) ?=? (pexpr, "($me + $hey) < $something") + ,"varstorm2" ~: (((TVar "me") + (TVar "hey")) .< (TVar "something")) ?=? (pexpr, "($me + $hey)< $something") + ,"varstorm3" ~: (((TVar "me") + (TVar "hey")) .< (TVar "st")) ?=? (pexpr, " ( $me+$hey ) <$st ") + ,"varstorm4" ~: (((TVar "me") * (TVar "hey")) .== (TVar "st")) ?=? (pexpr, " $me * $hey == $st ") + ,"fun1" ~: (TFun "sin" [tInt 44]) ?=? (pexpr, "sin(44)") + ,"fun2" ~: ((tInt 11) + (TFun "sin" [tInt 44])) ?=? (pexpr, "11 + sin(44)") + ,"fun3" ~: (TFun "rand" []) ?=? (pexpr, "rand()") + ,"and expr" ~: ((tInt 1) .&& (tInt 2)) ?=? (pexpr, "1 && 2") + ,"or expr" ~: (((tInt 1) + (tInt 1)) .|| (tInt 2)) ?=? (pexpr, "(1+1) || 2") + ,"sin +" ~: ((TFun "sin" [tInt 0]) + (tInt 10)) ?=? (pexpr, "sin(0) + 10") + ] + +mint v = T.mkTclInt v + +evalTests = TestList + [ + (tInt 3) `eql` (mint 3), + ((tInt 5) + (tInt 5)) `eql` (mint 10), + (((tInt 8) - (tInt 5)) + (tInt 5)) `eql` (mint 8), + (((tInt 8) - (tInt 5)) .> (tInt 5)) `eql` T.tclFalse, + "5 >= 5 -> true" ~: ((tInt 5) .>= (tInt 5)) `eql` (T.tclTrue), + "5 <= 5 -> true" ~: ((tInt 5) .<= (tInt 5)) `eql` (T.tclTrue), + ((tInt 6) .<= (tInt 5)) `eql` (T.tclFalse), + "8 - 5 < 5 -> true" ~: (((tInt 8) - (tInt 5)) .< (tInt 5)) `eql` T.tclTrue + ] + where eql a b = (runExpr a (return . make)) ~=? Just b + make (Left a) = T.mkTclBStr a + make (Right _) = T.mkTclStr "PROC" + +varEvalTests = TestList + [ + "$num -> 4" ~: (TVar "num") `eql` (mint 4), + ((TVar "num") + (tInt 3)) `eql` (mint 7), + ((tInt 4) + ((TVar "num") - (tInt 1))) `eql` (mint 7), + "$boo == \"bean\" -> true" ~: ((TVar "boo") `eq` (tStr "bean")) `eql` T.tclTrue + ] + where eql a b = (runExpr a lu) ~=? Just b + table = M.fromList . mapFst pack $ [("boo", T.mkTclStr "bean"), ("num", T.mkTclInt 4)] + lu :: (Monad m) => Callback m + lu (Left v) = M.lookup v table + lu (Right _) = return $ T.mkTclStr "PROC" + +riExpr s f = expr s >>= \e -> runExpr e f + +exprParseTests = TestList [ aNumberTests, stringTests, varTests, exprTests, evalTests, varEvalTests ] + +-- howbout s = parse pexpr "" s diff --git a/Hiccup.hs b/Hiccup.hs --- a/Hiccup.hs +++ b/Hiccup.hs @@ -1,518 +1,179 @@ -module Hiccup (runTcl, mkInterp,runInterp,hiccupTests) where +{-# LANGUAGE BangPatterns #-} +module Hiccup (runTcl, runTclWithArgs, mkInterp, runInterp, hiccupTests) where -import Control.Monad.State -import qualified Data.Map as Map -import Control.Arrow -import System.IO -import qualified System.IO.Error as IOE import Control.Monad.Error -import System.Exit import Data.IORef -import Data.Char (toLower,toUpper) -import Data.List (intersperse) -import Data.Maybe -import qualified Data.ByteString.Char8 as B -import BSParse (TclWord(..), wrapInterp) -import qualified TclObj as T -import Test.HUnit -- IGNORE -type BString = B.ByteString - -data Err = ERet !RetVal | EBreak | EContinue | EDie String deriving (Eq) - -instance Error Err where - noMsg = EDie "An error occurred." - strMsg s = EDie s - -data TclEnv = TclEnv { vars :: VarMap, procs :: ProcMap, upMap :: Map.Map BString (Int,BString) } -type TclM = ErrorT Err (StateT TclState IO) -type TclProc = [T.TclObj] -> TclM RetVal -type ProcMap = Map.Map BString TclProc -type VarMap = Map.Map BString T.TclObj - -type ChanMap = Map.Map BString T.TclChan - -type RetVal = T.TclObj -- IGNORE +import Util +import qualified TclObj as T +import Core (evalTcl) +import Common +import ProcArgs -coreProcs, baseProcs, mathProcs :: ProcMap +import TclLib (libCmds) -coreProcs = Map.fromList . map (B.pack *** id) $ - [("proc",procProc),("set",procSet),("upvar",procUpVar), - ("uplevel", procUpLevel),("if",procIf), - ("while",procWhile),("eval", procEval),("exit",procExit), - ("list",procList),("return",procReturn), - ("break",procRetv EBreak),("catch",procCatch), - ("continue",procRetv EContinue),("eq",procEq),("ne",procNe), - ("==",procEql), ("error", procError), ("info", procInfo), ("global", procGlobal)] +import Test.HUnit -baseProcs = Map.fromList . map (B.pack *** id) $ - [("puts",procPuts),("gets",procGets), - ("lindex",procLindex),("llength",procLlength), - ("string", procString), ("append", procAppend), - ("source", procSource), ("incr", procIncr), - ("open", procOpen), ("close", procClose)] +coreProcs = makeCmdMap $ + [("proc", procProc),("set", procSet),("upvar", procUpVar), + ("rename", procRename),("uplevel", procUpLevel), ("unset", procUnset),("eval", procEval), + ("return", procReturn),("break", procRetv EBreak),("catch", procCatch), + ("continue", procRetv EContinue),("error", procError), ("info", procInfo), ("global", procGlobal)] -mathProcs = Map.fromList . map (B.pack *** procMath) $ - [("+",(+)), ("*",(*)), ("-",(-)), - ("/",div), ("<", toI (<)),("<=",toI (<=)),("!=",toI (/=))] - -io :: IO a -> TclM a -io = liftIO +baseProcs = mergeCmdMaps [libCmds, coreProcs] + -toI :: (Int -> Int -> Bool) -> (Int -> Int -> Int) -toI n a b = if n a b then 1 else 0 +processArgs al = [("argc" * T.mkTclInt (length al)), ("argv" * T.mkTclList al)] + where (*) name val = (pack name, val) -baseEnv = TclEnv { vars = Map.empty, procs = procMap, upMap = Map.empty } - where procMap = Map.unions [coreProcs, baseProcs, mathProcs] +interpVars = [("tcl_version" * (show hiccupVersion))] + where (*) name val = (pack name, T.mkTclStr val) -data TclState = TclState { tclChans :: IORef ChanMap, tclStack :: [TclEnv] } +hiccupVersion = 0.4 data Interpreter = Interpreter (IORef TclState) -mkInterp :: IO Interpreter -mkInterp = do chans <- newIORef baseChans - st <- newIORef (TclState chans [baseEnv]) - return (Interpreter st) +mkInterp = mkInterpWithArgs [] -baseChans = Map.fromList (map (\x -> (T.chanName x, x)) T.tclStdChans ) +mkInterpWithArgs :: [BString] -> IO Interpreter +mkInterpWithArgs args = do + st <- makeState (interpVars ++ (processArgs (map T.mkTclBStr args))) baseProcs + stref <- newIORef st + return (Interpreter stref) + runInterp :: BString -> Interpreter -> IO (Either BString BString) -runInterp s = runInterp' (doTcl s) +runInterp s = runInterp' (evalTcl (T.mkTclBStr s)) runInterp' t (Interpreter i) = do bEnv <- readIORef i - (r,i') <- runStateT (runErrorT (t)) bEnv + (r,i') <- runTclM t bEnv writeIORef i i' return (fixErr r) - where perr (EDie s) = B.pack s - perr (ERet v) = T.asBStr v - perr EBreak = B.pack $ "invoked \"break\" outside of a loop" - perr EContinue = B.pack $ "invoked \"continue\" outside of a loop" - fixErr (Left x) = Left (perr x) + where perr (EDie s) = Left $ pack s + perr (ERet v) = Right $ T.asBStr v + perr EBreak = Left . pack $ "invoked \"break\" outside of a loop" + perr EContinue = Left . pack $ "invoked \"continue\" outside of a loop" + fixErr (Left x) = perr x fixErr (Right v) = Right (T.asBStr v) runTcl v = mkInterp >>= runInterp v +runTclWithArgs v args = mkInterpWithArgs args >>= runInterp v -ret = return T.empty -doTcl s = runCmds =<< getParsed s - -runCmds = liftM last . mapM runCommand - -getParsed str = do p <- T.asParsed str - return $ filter (not . null) p - -(.==) bs str = (T.asBStr bs) == B.pack str -{-# INLINE (.==) #-} - -doCond :: T.TclObj -> TclM Bool -doCond str = do - p <- getParsed str - case p of - [x] -> runCommand x >>= return . T.asBool - _ -> tclErr "Too many statements in conditional" - -putStack s = modify (\v -> v { tclStack = s }) -modStack f = getStack >>= putStack . f - -withScope :: TclM RetVal -> TclM RetVal -withScope f = do - (o:old) <- getStack - putStack $ (baseEnv { procs = procs o }) : o : old - f `ensure` (modStack tail) - -ensure :: TclM RetVal -> TclM () -> TclM RetVal -ensure action p = do - r <- action `catchError` (\e -> p >> throwError e) - p - return r - -set :: BString -> T.TclObj -> TclM () -set str v = do when (B.null str) $ tclErr "Empty varname to set!" - (env:es) <- getStack - case upped str env of - Just (i,s) -> uplevel i (set s v) - Nothing -> putStack ((env { vars = Map.insert str v (vars env) }):es) - -upped s e = Map.lookup s (upMap e) - -getProc str = getFrame >>= return . Map.lookup str . procs -regProc name pr = modStack (\(x:xs) -> (x { procs = Map.insert name pr (procs x) }):xs) >> ret - -evalw :: TclWord -> TclM RetVal -evalw (Word s) = interp s -evalw (NoSub s (Just (p,ps))) = if B.null ps then return $ T.mkTclBStrP s (Right p) - else return $ T.mkTclBStrP s (Left ("bad parse: " ++ show ps)) -evalw (NoSub s Nothing) = return $ T.mkTclBStrP s (Left "bad parse") -evalw (Subcommand c) = runCommand c - -runCommand :: [TclWord] -> TclM RetVal -runCommand [Subcommand s] = runCommand s -runCommand args = do - (name:evArgs) <- mapM evalw args - proc <- getProc (T.asBStr name) - maybe (tclErr ("invalid command name: " ++ (T.asStr name))) ($! evArgs) proc - -procProc, procSet, procPuts, procIf, procWhile, procReturn, procUpLevel :: TclProc procSet args = case args of - [s1,s2] -> set (T.asBStr s1) s2 >> return s2 + [s1,s2] -> varSet (T.asBStr s1) s2 [s1] -> varGet (T.asBStr s1) _ -> argErr "set" -procPuts args = case args of - [s] -> tPutLn stdout s - [a1,str] -> if a1 .== "-nonewline" then tPut stdout str - else do h <- getWritable a1 - tPutLn h str - [a1,a2,str] ->do unless (a1 .== "-nonewline") bad - h <- getWritable a2 - tPut h str - _ -> bad - where tPut h s = (io . B.hPutStr h . T.asBStr) s >> ret - tPutLn h s = (io . B.hPutStrLn h . T.asBStr) s >> ret - getWritable c = getChan (T.asBStr c) >>= checkWritable . T.chanHandle - bad = argErr "puts" - -procGets args = case args of - [ch] -> do h <- getReadable ch - eof <- io (hIsEOF h) - if eof then ret else (io . B.hGetLine) h >>= treturn - [ch,vname] -> do h <- getReadable ch - eof <- io (hIsEOF h) - if eof - then set (T.asBStr vname) (T.empty) >> return (T.mkTclInt (-1)) - else do s <- io (B.hGetLine h) - set (T.asBStr vname) (T.mkTclBStr s) - return $ T.mkTclInt (B.length s) - _ -> argErr "gets" - where getReadable c = getChan (T.asBStr c) >>= checkReadable . T.chanHandle - - -checkReadable c = do r <- io (hIsReadable c) - if r then return c else (tclErr $ "channel wasn't opened for reading") - -checkWritable c = do r <- io (hIsWritable c) - if r then return c else (tclErr $ "channel wasn't opened for writing") - -getChans = do s <- gets tclChans - (io . readIORef) s - -addChan c = do s <- gets tclChans - io (modifyIORef s (Map.insert (T.chanName c) c)) - -removeChan c = do s <- gets tclChans - io (modifyIORef s (Map.delete (T.chanName c))) - -getChan :: BString -> TclM T.TclChan -getChan c = do chans <- getChans - maybe (tclErr ("cannot find channel named " ++ show c)) return (Map.lookup c chans) - - -procEq args = case args of - [a,b] -> return $ T.fromBool (a == b) - _ -> argErr "eq" - -procNe args = case args of - [a,b] -> return $ T.fromBool (a /= b) - _ -> argErr "ne" - -argErr s = tclErr ("wrong # of args: " ++ s) - - -procMath :: (Int -> Int -> Int) -> TclProc -procMath op [s1,s2] = liftM2 op (T.asInt s1) (T.asInt s2) >>= return . T.mkTclInt -procMath _ _ = argErr "math" - -procEql [a,b] = case (T.asInt a, T.asInt b) of - (Just ia, Just ib) -> return $ T.fromBool (ia == ib) - _ -> procEq [a,b] -procEql _ = argErr "==" - - -procEval [s] = doTcl s -procEval x = tclErr $ "Bad eval args: " ++ show x - -procOpen args = case args of - [fn] -> do eh <- io (IOE.try (openFile (T.asStr fn) ReadMode)) - case eh of - Left e -> if IOE.isDoesNotExistError e - then tclErr $ "could not open " ++ show (T.asStr fn) ++ ": no such file or directory" - else tclErr (show e) - Right h -> do - chan <- io (T.mkChan h) - addChan chan - treturn (T.chanName chan) - _ -> argErr "open" - -procClose args = case args of - [ch] -> do h <- getChan (T.asBStr ch) - removeChan h - io (hClose (T.chanHandle h)) - ret - _ -> argErr "close" - +procUnset args = case args of + [n] -> varUnset (T.asBStr n) + _ -> argErr "unset" -procSource args = case args of - [s] -> io (B.readFile (T.asStr s)) >>= doTcl - _ -> argErr "source" +procRename args = case args of + [old,new] -> renameProc (T.asBStr old) (T.asBStr new) >> ret + _ -> argErr "rename" -procExit args = case args of - [] -> io (exitWith ExitSuccess) - [i] -> do v <- T.asInt i - let ecode = if v == 0 then ExitSuccess else ExitFailure v - io (exitWith ecode) - _ -> argErr "exit" +procEval args = case args of + [] -> argErr "eval" + [s] -> evalTcl s + _ -> evalTcl (T.objconcat args) procCatch args = case args of - [s] -> (doTcl s >> procReturn [T.tclFalse]) `catchError` (return . catchRes) + [s] -> (evalTcl s >> return T.tclFalse) `catchError` (retInt . retCodeToInt) + [s,result] -> (evalTcl s >>= varSet (T.asBStr result) >> return T.tclFalse) `catchError` (retReason result) _ -> argErr "catch" - where catchRes (EDie _) = T.tclTrue - catchRes _ = T.tclFalse - -retmod f = \v -> treturn (f `onObj` v) - -onObj f o = (f (T.asBStr o)) - -procString :: TclProc -procString (f:s:args) - | f .== "trim" = treturn (T.trim s) - | f .== "tolower" = retmod (B.map toLower) s - | f .== "toupper" = retmod (B.map toUpper) s - | f .== "length" = return $ T.mkTclInt (B.length `onObj` s) - | f .== "index" = case args of - [i] -> do ind <- T.asInt i - if ind >= (B.length `onObj` s) || ind < 0 then ret else treturn $ B.singleton (B.index (T.asBStr s) ind) - _ -> tclErr $ "Bad args to string index." - | otherwise = tclErr $ "Can't do string action: " ++ show f -procString _ = tclErr $ "Bad string args" - -tclErr = throwError . EDie - -getFrame = liftM head getStack - -procInfo [x] - | x .== "commands" = getFrame >>= procList . toObs . Map.keys . procs - | x .== "vars" = getFrame >>= procList . toObs . Map.keys . vars - | otherwise = tclErr $ "Unknown info command: " ++ show (T.asBStr x) -procInfo _ = argErr "info" - -toObs = map T.mkTclBStr - -procAppend args = case args of - (v:vx) -> do val <- varGet (T.asBStr v) `catchError` \_ -> ret - procSet [v, oconcat (val:vx)] - _ -> argErr "append" - where oconcat = T.mkTclBStr . B.concat . map T.asBStr - -procList :: TclProc -procList a = treturn $ (map (escape . T.asBStr) a) `joinWith` ' ' - where escape s = if B.elem ' ' s then B.concat [B.singleton '{', s, B.singleton '}'] else s - -procLindex args = case args of - [l] -> return l - [l,i] -> do items <- liftM (map to_s . head) (getParsed l) - ind <- T.asInt i - if ind >= length items then ret else treturn (items !! ind) - _ -> argErr "lindex" - -to_s (Word s) = s -to_s (NoSub s _) = s -to_s x = error $ "to_s doesn't understand: " ++ show x + where retCodeToInt c = case c of + (EDie _) -> 1 + (ERet _) -> 2 + EBreak -> 3 + EContinue -> 4 + retReason v e = case e of + EDie s -> varSet (T.asBStr v) (T.mkTclStr s) >> return T.tclTrue + _ -> retInt . retCodeToInt $ e + retInt = return . T.mkTclInt -procIncr [vname] = incr vname 1 -procIncr [vname,val] = T.asInt val >>= incr vname -procIncr _ = argErr "incr" -incr n i = do v <- varGet bsname - intval <- T.asInt v - let res = (T.mkTclInt (intval + i)) - set bsname res - return res - where bsname = T.asBStr n +procInfo = makeEnsemble "info" [ + matchp "locals" localVars, + matchp "globals" globalVars, + matchp "vars" currentVars, + matchp "commands" commandNames, + noarg "level" (liftM T.mkTclInt stackLevel), + ("exists", info_exists), + ("body", info_body)] + where noarg n f = (n, no_args n f) + matchp n f = (n, matchList ("info " ++ n) f) + no_args n f args = case args of + [] -> f + _ -> argErr $ "info " ++ n -procLlength args = case args of - [lst] -> if B.null `onObj` lst - then return T.tclFalse - else liftM (T.mkTclInt . length . head) (getParsed lst) - _ -> argErr "llength" +matchList name f args = case args of + [] -> f >>= asTclList + [pat] -> getMatches pat + _ -> argErr name + where getMatches pat = f >>= asTclList . globMatches (T.asBStr pat) -procIf (cond:yes:rest) = do - condVal <- doCond cond - if condVal then doTcl yes - else case rest of - [s,blk] -> if s .== "else" then doTcl blk else tclErr "Invalid If" - (s:r) -> if s .== "elseif" then procIf r else tclErr "Invalid If" - [] -> ret -procIf _ = argErr "if" +info_exists args = case args of + [n] -> varExists (T.asBStr n) >>= return . T.fromBool + _ -> argErr "info exists" -procWhile [cond,body] = loop `catchError` herr - where herr EBreak = ret - herr (ERet s) = return s - herr EContinue = loop `catchError` herr - herr x = throwError x - loop = do condVal <- doCond cond - pbody <- getParsed body - if condVal then runCmds pbody >> loop else ret +info_body args = case args of + [n] -> do p <- getProc (T.asBStr n) + case p of + Nothing -> tclErr $ show (T.asBStr n) ++ " isn't a procedure" + Just p -> treturn (cmdBody p) + _ -> argErr "info body" -procWhile _ = argErr "while" +asTclList = return . T.mkTclList . map T.mkTclBStr procReturn args = case args of [s] -> throwError (ERet s) [] -> throwError (ERet T.empty) _ -> argErr "return" -procRetv c [] = throwError c -procRetv c _ = argErr $ st c +procRetv c args = case args of + [] -> throwError c + _ -> argErr $ st c where st EContinue = "continue" st EBreak = "break" st _ = "??" procError [s] = tclErr (T.asStr s) -procError _ = argErr "error" +procError _ = argErr "error" procUpLevel args = case args of - [p] -> uplevel 1 (procEval [p]) + [p] -> uplevel 1 (evalTcl p) (si:p) -> T.asInt si >>= \i -> uplevel i (procEval p) _ -> argErr "uplevel" -getStack = gets tclStack -uplevel i p = do - (curr,new) <- liftM (splitAt i) getStack - putStack new - res <- p - modStack (curr ++) - return res - +procUpVar :: TclCmd procUpVar args = case args of - [d,s] -> upvar 1 d s - [si,d,s] -> T.asInt si >>= \i -> upvar i d s + [d,s] -> doUp 1 d s + [si,d,s] -> T.asInt si >>= \i -> doUp i d s _ -> argErr "upvar" + where doUp i d s = upvar i (T.asBStr d) (T.asBStr s) >> ret -procGlobal lst@(_:_) = mapM_ inner lst >> ret - where inner g = do lst <- getStack - let len = length lst - 1 +procGlobal args = case args of + [] -> argErr "global" + _ -> mapM_ (inner . T.asBStr) args >> ret + where inner g = do len <- stackLevel upvar len g g -procGlobal _ = argErr "global" -upvar n d s = do (e:es) <- getStack - putStack ((e { upMap = Map.insert (T.asBStr s) (n, (T.asBStr d)) (upMap e) }):es) - ret - -type ArgList = [Either BString (BString,BString)] -type ParamList = (Bool,ArgList) - -procProc [name,args,body] = do - params <- parseParams args - pbody <- getParsed body - regProc (T.asBStr name) (procRunner params pbody) -procProc x = tclErr $ "proc: Wrong arg count (" ++ show (length x) ++ "): " ++ show (map T.asBStr x) - -parseParams :: T.TclObj -> TclM ParamList -parseParams args = - case getParsed args of - Nothing -> tclErr $ "arg parse failed: " ++ show (T.asBStr args) - Just [] -> countRet [] - Just [r] -> countRet r - x -> tclErr $ "What the heck is " ++ show x ++ "? " ++ show args - where parseArg (Word s) = Left s - parseArg (NoSub _ (Just ([[Word z, Word n]],_))) = Right (z,n) - parseArg (NoSub _ (Just ([[ Word z, Word n],[]],_))) = Right (z,n) -- FIXME: Whuh? - parseArg x = error $ "parseArg doesn't understand: " ++ show x - countRet l = return (hasArgs l, map parseArg l) - hasArgs pl = (not . null) pl && (to_s (last pl) .== "args") - +procProc args = case args of + [name,alst,body] -> do + let pname = T.asBStr name + params <- parseParams pname alst + regProc pname (T.asBStr body) (procRunner params body) + ret + _ -> argErr "proc" -procRunner :: ParamList -> [[TclWord]] -> [T.TclObj] -> TclM RetVal -procRunner pl body args = - withScope $ do - bindArgs pl args - runCmds body `catchError` herr - where herr (ERet s) = return s - herr (EDie s) = tclErr s +procRunner pl body args = do + locals <- bindArgs pl args + withLocalScope locals (evalTcl body `catchError` herr) + where herr (ERet s) = return $! s herr EBreak = tclErr "invoked \"break\" outside of a loop" herr EContinue = tclErr "invoked \"continue\" outside of a loop" - -bindArgs (hasArgs, pl) args = do - walkBoth used args - where walkBoth ((Left v):xs) (a:as) = set v a >> walkBoth xs as - walkBoth ((Right (k,_)):xs) (a:as) = set k a >> walkBoth xs as - walkBoth ((Left _):_) [] = badArgs - walkBoth ((Right (k,v)):xs) [] = set k (T.mkTclBStr v) >> walkBoth xs [] - walkBoth [] xl = if hasArgs then do procList xl >>= set (B.pack "args") - else when (not (null xl)) badArgs - a2s (Left s) = s - a2s (Right (k,_)) = B.cons '?' (B.snoc k '?') - badArgs = argErr $ "should be " ++ show ((map a2s used) `joinWith` ' ') ++ if hasArgs then " ..." else "" - used = if hasArgs then init pl else pl - -joinWith bsl c = B.concat (intersperse (B.singleton c) bsl) - -varGet :: BString -> TclM RetVal -varGet name = do env <- getFrame - case upped name env of - Nothing -> maybe (tclErr ("can't read \"$" ++ T.asStr name ++ "\": no such variable")) - return - (Map.lookup name (vars env)) - Just (i,n) -> uplevel i (varGet n) - -treturn = return . T.mkTclBStr - -interp :: BString -> TclM RetVal -interp str = case wrapInterp str of - Left s -> treturn s - Right x -> handle x - where f (Word match) = varGet match - f x = runCommand [x] - handle (b,m,a) = do mid <- f m - let front = B.append b (T.asBStr mid) - interp a >>= \v -> treturn (B.append front (T.asBStr v)) - --- # TESTS # -- - -parseArrRef str = do start <- B.elemIndex '(' str - guard (start /= 0) - guard (B.last str == ')') - let (pre,post) = B.splitAt start str - return (pre, B.tail (B.init post)) - - -run :: TclM RetVal -> Either Err RetVal -> IO Bool -run t v = do chans <- newIORef Map.empty - ret <- liftM fst (runStateT (runErrorT (t)) (TclState chans [baseEnv])) - return (ret == v) - -testProcEq = TestList [ - "1 eq 1 -> t" ~: (procEq [int 1, int 1]) `is` True - ,"1 == 1 -> t" ~: (procEql [int 1, int 1]) `is` True - ,"' 1 ' == 1 -> t" ~: procEql [str " 1 ", int 1] `is` True - ,"' 1 ' eq 1 -> f" ~: procEq [str " 1 ", int 1] `is` False - ,"' 1 ' eq ' 1 ' -> t" ~: procEq [str " 1 ", str " 1 "] `is` True - ,"' 1 ' ne '1' -> t" ~: procNe [str " 1 ", str "1"] `is` True - ,"'cats' eq 'cats' -> t" ~: procEq [str "cats", str "cats"] `is` True - ,"'cats' eq 'caps' -> f" ~: procEq [str "cats", str "caps"] `is` False - ,"'cats' ne 'cats' -> t" ~: procNe [str "cats", str "cats"] `is` False - ,"'cats' ne 'caps' -> f" ~: procNe [str "cats", str "caps"] `is` True - ] - where (?=?) a b = assert (run b (Right a)) - is c b = (T.fromBool b) ?=? c - int i = T.mkTclInt i - str s = T.mkTclStr s - -testArr = TestList [ - "december" `should_be` Nothing - ,"dec(mber" `should_be` Nothing - ,"dec)mber" `should_be` Nothing - ,"(cujo)" `should_be` Nothing - ,"de(c)mber" `should_be` Nothing - ,"a(1)" ?=> ("a","1") - ,"xx(september)" ?=> ("xx","september") - ,"arr(3,4,5)" ?=> ("arr","3,4,5") - ,"arr()" ?=> ("arr","") - ] - where (?=>) a b@(b1,b2) = (a ++ " -> " ++ show b) ~: parseArrRef (B.pack a) ~=? Just (B.pack b1, B.pack b2) - should_be x r = (x ++ " should be " ++ show r) ~: parseArrRef (B.pack x) ~=? r -hiccupTests = TestList [ testProcEq, testArr ] - -runUnit = runTestTT hiccupTests + herr e = throwError e --- # ENDTESTS # -- +hiccupTests = TestList [] diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -11,9 +11,9 @@ hSetBuffering stdout NoBuffering case args of [] -> mkInterp >>= runRepl - [f] -> B.readFile f >>= runTcl >>= (`unlessErr` (\_ -> return ())) - _ -> error "too many args" - where unlessErr x f = either (\e -> putStrLn ("error: " ++ B.unpack e)) f x + (f:fs) -> do fdata <- B.readFile f + runTclWithArgs fdata (map B.pack fs) >>= (`unlessErr` (\_ -> return ())) + where unlessErr x f = either (\e -> B.putStrLn e) f x runRepl i = do mline <- readline "hiccup> " case mline of Nothing -> return () diff --git a/ProcArgs.hs b/ProcArgs.hs new file mode 100644 --- /dev/null +++ b/ProcArgs.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE BangPatterns #-} +module ProcArgs (parseParams, bindArgs) where +import Util +import qualified TclObj as T +import Common +import qualified Data.ByteString.Char8 as B + +type ArgSpec = Either BString (BString,T.TclObj) +type ArgList = [ArgSpec] + +showParams (n,hasArgs,pl) = + show ((n:(map arg2name pl)) `joinWith` ' ') ++ if hasArgs then " ..." else "" + +arg2name arg = case arg of + Left s -> s + Right (k,_) -> B.cons '?' (B.snoc k '?') + +type ParamList = (BString, Bool, ArgList) + +mkParamList :: BString -> ArgList -> ParamList +mkParamList name lst = (name, hasArgs, used) + where hasArgs = (not . null) lst && (lastIsArgs lst) + used = if hasArgs then init lst else lst + lastIsArgs = either (== (pack "args")) (const False) . last + + +parseParams :: BString -> T.TclObj -> TclM ParamList +parseParams name args = T.asList args >>= countRet + where countRet :: [T.TclObj] -> TclM ParamList + countRet lst = mapM doArg lst >>= return . mkParamList name + doArg :: T.TclObj -> TclM ArgSpec + doArg s = do l <- T.asList s + return $ case l of + [k,v] -> Right (T.asBStr k,v) + _ -> Left (T.asBStr s) + +bindArgs :: ParamList -> [T.TclObj] -> TclM [(BString,T.TclObj)] +bindArgs params@(_,hasArgs,pl) args = walkBoth pl args [] + where walkBoth ((Left v):xs) (a:as) !acc = walkBoth xs as ((v,a):acc) + walkBoth ((Left _):_) [] _ = badArgs + walkBoth ((Right (k,_)):xs) (a:as) !acc = walkBoth xs as ((k,a):acc) + walkBoth ((Right (k,v)):xs) [] !acc = walkBoth xs [] ((k,v):acc) + walkBoth [] xl !acc = if hasArgs then return $! ((pack "args"),(T.mkTclList xl)):acc + else if null xl then return $! acc + else badArgs + badArgs = argErr $ "should be " ++ showParams params diff --git a/RToken.hs b/RToken.hs new file mode 100644 --- /dev/null +++ b/RToken.hs @@ -0,0 +1,110 @@ +module RToken (Cmd, RToken(..), noInterp, singleTok, tryParsed, Parseable, Parsed, asParsed, rtokenTests ) where +import qualified Data.ByteString.Char8 as B +import BSParse (TclWord(..), doInterp, runParse) +import Util (BString,pack) +import VarName +import Test.HUnit + +type Parsed = [Cmd] +type Cmd = (Either (NSQual BString) RToken, [RToken]) +data RToken = Lit !BString | LitInt !Int | CatLst [RToken] + | CmdTok Cmd | ExpTok RToken + | VarRef (NSQual VarName) | ArrRef (Maybe NSTag) !BString RToken + | Block !BString (Either String [Cmd]) deriving (Eq,Show) + +isEmpty (Lit x) = B.null x +isEmpty (CatLst l) = null l +isEmpty _ = False + +noInterp tok = case tok of + (CmdTok _) -> False + (VarRef _) -> False + (ArrRef _ _ _) -> False + (ExpTok t) -> noInterp t + (CatLst l) -> all noInterp l + _ -> True + + +-- Bit hacky, but better than no literal handling +litIfy s + | B.length s == 1 = let c = B.index s 0 + in case c of + '0' -> LitInt 0 + '1' -> LitInt 1 + '2' -> LitInt 2 + _ -> Lit s + | otherwise = Lit s + + +compile :: BString -> RToken +compile str = case doInterp str of + Left s -> litIfy s + Right x -> handle x + where f (Left match) = case parseVarName match of + NSQual ns (VarName n (Just ind)) -> ArrRef ns n (compile ind) + vn -> VarRef vn + f (Right x) = compCmd x + handle (b,m,a) = let front = [Lit b, f m] + in let lst = filter (not . isEmpty) (front ++ [compile a]) + in case lst of + [a] -> a + _ -> CatLst lst + +compToken :: TclWord -> RToken +compToken (Word s) = compile s +compToken (NoSub s res) = Block s (fromParsed res) +compToken (Expand t) = ExpTok (compToken t) +compToken (Subcommand c) = compCmd c + +compCmd c = CmdTok (toCmd c) + +class Parseable a where + asParsed :: (Monad m) => a -> m Parsed + +instance Parseable B.ByteString where + asParsed s = case tryParsed s of + Left s -> fail s + Right p -> return p + +tryParsed :: BString -> Either String Parsed +tryParsed s = case runParse s of + Nothing -> Left $ "parse failed: " ++ show s + Just (r,rs) -> if B.null rs then Right (map toCmd r) else Left ("Incomplete parse: " ++ show rs) + +fromParsed Nothing = Left "parse failed" +fromParsed (Just (tl,v)) = if B.null v then Right (map toCmd tl) else Left ("incomplete parse: " ++ show v) + + +toCmd (x,xs) = (handleProc (compToken x), map compToken xs) + where handleProc (Lit v) = Left (parseProc v) + handleProc xx = Right xx + +singleTok b = [toCmd (Word b,[])] + +rtokenTests = TestList [compTests, compTokenTests] where + compTests = TestList [ + "x -> x" ~: "x" `compiles_to` (lit "x") + ,"$x -> VarRef x" ~: "$x" `compiles_to` (varref "x") + ,"x(G) -> ArrRef x G" ~: "$x(G)" `compiles_to` (arrref "x" (lit "G")) + ,"CatLst" ~: "$x$y" `compiles_to` (CatLst [varref "x", varref "y"]) + ,"lit" ~: "incr x -1" `compiles_to` lit "incr x -1" + ,"cmd" ~: "[double 4]" `compiles_to` cmdTok (Left (vlocal (pack "double")), [lit "4"]) + ] + + compTokenTests = TestList [ + "1" ~: (mkwd "x") `tok_to` (lit "x") + ,"2" ~: (mknosub "puts 4") `tok_to` (block "puts 4" [((Left (vlocal (pack "puts"))), [lit "4"])]) + ] + + block s v = Block (pack s) (Right v) + mknosub s = NoSub (pack s) (runParse (pack s)) + mkwd = Word . pack + lit = Lit . pack + vlocal x = NSQual Nothing x + cmdTok = CmdTok + varref = VarRef . parseVarName . pack + arrref s t = ArrRef Nothing (pack s) t + tok_to a b = do let r = compToken a + assertEqual (show a ++ " compiles to " ++ show b) b r + compiles_to a b = do let r = compile (pack a) + assertEqual (show a ++ " compiles to " ++ show b) b r diff --git a/TclChan.hs b/TclChan.hs new file mode 100644 --- /dev/null +++ b/TclChan.hs @@ -0,0 +1,26 @@ +module TclChan ( TclChan(..), mkChan, ChanMap, insertChan, lookupChan, deleteChan, tclStdChans, baseChans ) where + +import Data.Unique +import Util + +import System.IO +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map as Map + +type ChanMap = Map.Map BString TclChan + +insertChan c m = Map.insert (chanName c) c m +lookupChan n m = Map.lookup n m +deleteChan c m = Map.delete (chanName c) m + +data TclChan = TclChan { chanHandle :: Handle, chanName :: BString } deriving (Eq,Show) + +tclStdChans = [ mkChan' stdout "stdout", mkChan' stdin "stdin", mkChan' stderr "stderr" ] + + +mkChan h = do n <- uniqueNum + return (mkChan' h ("file" ++ show n)) + where uniqueNum = newUnique >>= return . hashUnique + +mkChan' h n = TclChan h (BS.pack n) +baseChans = Map.fromList (map (\c -> (chanName c, c)) tclStdChans ) diff --git a/TclLib.hs b/TclLib.hs new file mode 100644 --- /dev/null +++ b/TclLib.hs @@ -0,0 +1,14 @@ +module TclLib (libCmds) where + +import Common +import TclLib.IOProcs +import TclLib.ListProcs +import TclLib.ArrayProcs +import TclLib.ControlProcs +import TclLib.StringProcs +import TclLib.NSProcs +import TclLib.MathProcs (mathProcs) +import TclLib.UtilProcs + +libCmds = mergeCmdMaps [ controlProcs, mathProcs, nsProcs, + ioProcs, listProcs, arrayProcs, stringProcs, utilProcs ] diff --git a/TclLib/ArrayProcs.hs b/TclLib/ArrayProcs.hs new file mode 100644 --- /dev/null +++ b/TclLib/ArrayProcs.hs @@ -0,0 +1,87 @@ +module TclLib.ArrayProcs (arrayProcs) where +import Common + +import Util +import qualified TclObj as T +import TclObj ((.==)) +import Control.Monad +import qualified Data.Map as Map +import VarName +import Text.Printf + +arrayProcs = makeCmdMap [("array", procArray), ("parray", procParray)] + +procParray args = case args of + [name] -> do let n = T.asBStr name + arr <- getArray n `orElse` (tclErr ((show n) ++ " isn't an array")) + mapM_ (showFun n) (Map.toList arr) + ret + _ -> argErr "parray" + where showFun n (a,b) = io (printf "%s(%s) = %s\n" (unpack n) (unpack a) (T.asStr b)) + + +procArray = makeEnsemble "array" [ + ("get", array_get), ("size", array_size), + ("exists", array_exists), ("set", array_set), + ("names", array_names), ("unset", array_unset) + ] + +arrSet n i v = varSetHere (arrName n i) v + +toPairs (a:b:xs) = (a,b) : toPairs xs +toPairs _ = [] + +getOrEmpty name = getArray (T.asBStr name) `ifFails` Map.empty + +array_get args = case args of + [name] -> runGet name (const True) + [name,pat] -> runGet name (globMatch (T.asBStr pat)) + _ -> argErr "array get" + where runGet name filt = do + arr <- getOrEmpty name + return . T.mkTclList $ concatMap (\(k,v) -> [T.mkTclBStr k, v]) (filter (filt . fst) (Map.toList arr)) + + +array_names args = case args of + [name] -> getKeys name >>= retlist + [name,pat] -> getKeys name >>= retlist . globMatches (T.asBStr pat) + [name,mode,pat] -> do + keys <- getKeys name + let bpat = T.asBStr pat + if mode .== "-glob" + then retlist (globMatches bpat keys) + else if mode .== "-exact" + then retlist (exactMatches bpat keys) + else tclErr $ "bad option " ++ show mode + + _ -> argErr "array names" + where getKeys n = getOrEmpty n >>= return . Map.keys + retlist = return . T.mkTclList . map T.mkTclBStr + +array_set args = case args of + [a2,a3] -> do l <- T.asList a3 + if even (length l) + then mapM_ (\(a,b) -> arrSet (T.asBStr a2) (T.asBStr a) b) (toPairs l) >> ret + else tclErr "list must have even number of elements" + _ -> argErr "array set" + +array_unset args = case args of + [name] -> varUnset (T.asBStr name) + [name,pat] -> do let n = T.asBStr name + arr <- getArray n + let (NSQual nst (VarName vn x)) = parseVarName n + when (x /= Nothing) $ tclErr "what the heck just happened" + let withInd i = (NSQual nst (VarName vn (Just i))) + mapM_ (\ind -> varUnsetNS (withInd ind)) (globMatches (T.asBStr pat) (Map.keys arr)) + ret + _ -> argErr "array unset" + +array_exists args = case args of + [a2] -> do b <- (getArray (T.asBStr a2) >> return True) `ifFails` False + return (T.fromBool b) + _ -> argErr "array exists" + +array_size args = case args of + [name] -> do arr <- getOrEmpty name + return $ T.mkTclInt (Map.size arr) + _ -> argErr "array exists" diff --git a/TclLib/ControlProcs.hs b/TclLib/ControlProcs.hs new file mode 100644 --- /dev/null +++ b/TclLib/ControlProcs.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE BangPatterns #-} +module TclLib.ControlProcs (controlProcs) where + +import Common +import Core +import Control.Monad.Error +import qualified TclObj as T +import TclObj ((.==)) +import Util + +controlProcs = makeCmdMap $ + [("while", procWhile), ("if", procIf), ("for", procFor), + ("foreach", procForEach), ("switch", procSwitch)] + +procIf (cond:yes:rest) = do + condVal <- doCond cond + if condVal then evalTcl yes + else case rest of + [] -> ret + [s,blk] -> if (T.asBStr s) == (pack "else") then evalTcl blk else tclErr "Invalid If" + (s:r) -> if s .== "elseif" then procIf r else tclErr "Invalid If" +procIf _ = argErr "if" + +procWhile [cond,body] = loop `catchError` herr + where herr EBreak = ret + herr EContinue = loop `catchError` herr + herr x = throwError x + loop = do condVal <- doCond cond + if condVal then evalTcl body >> loop else ret + +procWhile _ = argErr "while" + +eatErr f v = (f >> ret) `catchError` \e -> if v == e then ret else throwError e +{-# INLINE eatErr #-} + +procFor args = case args of + [start,test,next,body] -> do evalTcl start + loop test next body `eatErr` EBreak + ret + _ -> argErr "for" + where loop test next body = do + c <- doCond test + if c then (evalTcl body `eatErr` EContinue) >> evalTcl next >> loop test next body + else ret + +procForEach args = + case args of + [vl_,l_,block] -> do + vl <- T.asList vl_ + l <- T.asList l_ + let vllen = length vl + if vllen == 1 + then allowBreak (mapM_ (doSingl (head vl) block) l) + else do + let chunks = l `chunkBy` vllen + allowBreak (mapM_ (doChunk vl block) chunks) + ret + _ -> argErr "foreach" + where allowBreak f = f `eatErr` EBreak + doChunk vl block items = do zipWithM_ (\a b -> varSet (T.asBStr a) b) vl (items ++ repeat T.empty) + evalTcl block `eatErr` EContinue + doSingl v block i = do varSet (T.asBStr v) i + evalTcl block `eatErr` EContinue + +chunkBy lst n = let (a,r) = splitAt n lst + in a : (if null r then [] else r `chunkBy` n) + +procSwitch args = case args of + [str,pairlst] -> T.asList pairlst >>= doSwitch (exacter str) + [opt,str,pairlst] -> if opt .== "--" || opt .== "-exact" + then T.asList pairlst >>= doSwitch (exacter str) + else if opt .== "-glob" + then T.asList pairlst >>= doSwitch (globber str) + else tclErr $ "switch: bad option " ++ show opt + _ -> argErr "switch" + where globber s = let bs = T.asBStr s in \o -> globMatch (T.asBStr o) bs + exacter s = let bs = T.asBStr s in \o -> exactMatch (T.asBStr o) bs + +doSwitch matchP lst = do + pl <- toPairs lst + switcher pl False + where switcher [(k,v)] useNext = do + if matchP k || useNext || k .== "default" + then if v .== "-" then tclErr $ "no body specified for pattern " ++ show k + else evalTcl v + else ret + switcher ((k,v):xs) useNext = do + if matchP k || useNext + then if v .== "-" then switcher xs True else evalTcl v + else switcher xs False + switcher [] _ = tclErr "impossible condition in \"switch\"" + +toPairs [a,b] = return [(a,b)] +toPairs (a:b:r) = liftM ((a,b):) (toPairs r) +toPairs _ = tclErr "list must have even number of elements" diff --git a/TclLib/IOProcs.hs b/TclLib/IOProcs.hs new file mode 100644 --- /dev/null +++ b/TclLib/IOProcs.hs @@ -0,0 +1,116 @@ +module TclLib.IOProcs (ioProcs) where +import Common +import Control.Monad (unless) +import System.IO +import System.Exit +import Core (evalTcl) +import qualified TclObj as T +import qualified TclChan as T +import qualified System.IO.Error as IOE +import qualified Data.ByteString.Char8 as B +import TclObj ((.==)) +import Util + +ioProcs = makeCmdMap $ + [("puts",procPuts),("gets",procGets), + ("open", procOpen), ("close", procClose),("flush", procFlush), + ("exit", procExit), ("source", procSource), ("eof", procEof)] + +procEof args = case args of + [ch] -> do h <- getReadable ch + io (hIsEOF h) >>= return . T.fromBool + _ -> argErr "eof" + +procPuts args = case args of + [s] -> tPutLn stdout s + [a1,str] -> if a1 .== "-nonewline" then tPut stdout str + else do h <- getWritable a1 + tPutLn h str + [a1,a2,str] ->do unless (a1 .== "-nonewline") bad + h <- getWritable a2 + tPut h str + _ -> bad + where tPut h s = (io . B.hPutStr h . T.asBStr) s >> ret + tPutLn h s = (io . B.hPutStrLn h . T.asBStr) s >> ret + getWritable c = lookupChan (T.asBStr c) >>= checkWritable . T.chanHandle + bad = argErr "puts" + +procGets args = case args of + [ch] -> do h <- getReadable ch + eof <- io (hIsEOF h) + if eof then ret else (io . B.hGetLine) h >>= treturn + [ch,vname] -> do h <- getReadable ch + eof <- io (hIsEOF h) + if eof + then varSet (T.asBStr vname) (T.empty) >> return (T.mkTclInt (-1)) + else do s <- io (B.hGetLine h) + varSet (T.asBStr vname) (T.mkTclBStr s) + return $ T.mkTclInt (B.length s) + _ -> argErr "gets" + +getReadable c = lookupChan (T.asBStr c) >>= checkReadable . T.chanHandle + +procSource args = case args of + [s] -> do + let fn = T.asStr s + useFile fn (slurpFile fn) >>= evalTcl . T.mkTclBStr + _ -> argErr "source" + +checkReadable c = do r <- io (hIsReadable c) + if r then return c else (tclErr "channel wasn't opened for reading") + +checkWritable c = do r <- io (hIsWritable c) + if r then return c else (tclErr "channel wasn't opened for writing") + +procOpen args = case args of + [fn] -> openChan fn ReadMode + [fn,m] -> parseMode (T.asStr m) >>= openChan fn + _ -> argErr "open" + where parseMode m = + case m of + "w" -> return WriteMode + "r" -> return ReadMode + "a" -> return AppendMode + _ -> fail "Unknown file mode" + openChan fn m = do + let name = T.asStr fn + h <- useFile name (openFile name m) + chan <- io (T.mkChan h) + addChan chan + treturn (T.chanName chan) + +useFile fn fun = do + eh <- io $ IOE.try fun + case eh of + Left e -> if IOE.isDoesNotExistError e + then tclErr $ "could not open " ++ show fn ++ ": no such file or directory" + else tclErr (show e) + Right h -> return h + +procClose args = case args of + [ch] -> do h <- lookupChan (T.asBStr ch) + removeChan h + io (hClose (T.chanHandle h)) + ret + _ -> argErr "close" + +procFlush args = case args of + [ch] -> do h <- lookupChan (T.asBStr ch) + io (hFlush (T.chanHandle h)) + ret + _ -> argErr "flush" + +procExit args = case args of + [] -> io (exitWith ExitSuccess) + [i] -> do v <- T.asInt i + let ecode = if v == 0 then ExitSuccess else ExitFailure v + io (exitWith ecode) + _ -> argErr "exit" + + +lookupChan :: BString -> TclM T.TclChan +lookupChan c = do chan <- getChan c + case chan of + Nothing -> tclErr ("cannot find channel named " ++ show c) + Just ch -> return ch + diff --git a/TclLib/ListProcs.hs b/TclLib/ListProcs.hs new file mode 100644 --- /dev/null +++ b/TclLib/ListProcs.hs @@ -0,0 +1,112 @@ +module TclLib.ListProcs (listProcs,procList) where +import Common +import Util +import Data.List (sortBy) +import Data.Ord (comparing) +import qualified TclObj as T +import TclObj ((.==)) +import Control.Monad +import qualified Data.Sequence as S +import Data.Sequence ((><)) + +listProcs = makeCmdMap $ + [("list", procList),("lindex",procLindex), + ("llength",procLlength), ("lappend", procLappend), + ("lset", procLset), ("lassign", procLassign), ("lsort", procLsort), + ("join", procJoin), ("concat", procConcat)] + +procList = return . T.mkTclList + +procLindex args = case args of + [l] -> return l + [l,i] -> do items <- T.asSeq l + if T.isEmpty i + then return l + else do + ind <- toInd items i + if ind >= S.length items || ind < 0 then ret else return (S.index items ind) + _ -> argErr "lindex" + where toInd s i = T.asInt i `orElse` tryEnd s i + tryEnd s i = if i .== "end" then return ((S.length s) - 1) else return (-1) + +procLlength args = case args of + [lst] -> T.asSeq lst >>= return . T.mkTclInt . S.length + _ -> argErr "llength" + +procLset args = case args of + [name,val] -> varModify (T.asBStr name) (\_ -> return val) + [name,ind,val] -> varModify (T.asBStr name) $ + \old -> do + items <- T.asSeq old + if T.isEmpty ind + then return $! val + else do + i <- T.asInt ind + rangeCheck items i + return $! T.mkTclList' (S.update i val items) + _ -> argErr "lset" + where rangeCheck seq i = if i < 0 || i >= (S.length seq) then tclErr "list index out of range" else return () + +procLassign args = case args of + (list:(varnames@(_:_))) -> do l <- T.asList list + let (src,rest) = splitAt (length varnames) l + zipWithM_ setter varnames (src ++ repeat T.empty) + return (T.mkTclList rest) + _ -> argErr "lassign" + where setter n v = varSet (T.asBStr n) v + +procJoin args = case args of + [lst] -> dojoin lst (pack " ") + [lst,sep] -> dojoin lst (T.asBStr sep) + _ -> argErr "join" + where dojoin ll sep = do + lst <- T.asList ll + return $ T.mkTclBStr (joinWithBS (map T.asBStr lst) sep) + +procConcat = return . T.objconcat + +procLappend args = case args of + (n:news) -> varModify (T.asBStr n) $ + \old -> do items <- T.asSeq old + return $ T.mkTclList' (items >< (S.fromList news)) + _ -> argErr "lappend" + +data SortType = AsciiSort | IntSort deriving (Eq,Show) +data SortFlags = SF { sortType :: SortType, sortReverse :: Bool, noCase :: Bool } deriving (Eq, Show) + +accumFlags [] sf = return sf +accumFlags (x:xs) sf = case T.asStr x of + "-ascii" -> accumFlags xs (sf { sortType = AsciiSort }) + "-integer" -> accumFlags xs (sf { sortType = IntSort }) + "-decreasing" -> accumFlags xs (sf { sortReverse = True }) + "-increasing" -> accumFlags xs (sf { sortReverse = False }) + "-nocase" -> accumFlags xs (sf { noCase = True }) + unrecognized -> tclErr $ "unrecognized lsort option: " ++ unrecognized + +defaultSort = SF { sortType = AsciiSort, sortReverse = False, noCase = False } + +procLsort args = case args of + [] -> argErr "lsort" + alst -> let (opts,lst) = (init alst, last alst) + in do sf <- accumFlags opts defaultSort + dosort sf lst + where dosort sf lst = do + items <- T.asList lst + sortEm sf items >>= return . T.mkTclList + +ifTrue fun b = if b then fun else id + +-- NOTE: This is so ugly. +sortEm :: SortFlags -> [T.TclObj] -> TclM [T.TclObj] +sortEm (SF stype rev nocase) lst = do + pairs <- modder + return $ post pairs + where paired f = mapM (\x -> f x >>= \nx -> return (nx, x)) lst + caser = downCase `ifTrue` nocase + retSortFst :: (Ord a) => [(a,T.TclObj)] -> TclM [T.TclObj] + retSortFst = return . map snd . sortBy (comparing fst) + post = reverse `ifTrue` rev + modder = case stype of + AsciiSort -> paired (return . caser . T.asBStr) >>= retSortFst + IntSort -> paired (T.asInt) >>= retSortFst + diff --git a/TclLib/MathProcs.hs b/TclLib/MathProcs.hs new file mode 100644 --- /dev/null +++ b/TclLib/MathProcs.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE BangPatterns #-} +module TclLib.MathProcs (mathProcs, plus, + minus, + times, + divide, + equals, + notEquals, + lessThan, + lessThanEq, + greaterThan, + greaterThanEq, + mathTests ) where + +import Common +import qualified TclObj as T +import Control.Monad +import System.Random +import Test.HUnit + +mathProcs = makeCmdMap $ + [("+", many plus 0), ("*", many times 1), ("-", m2 minus), ("pow", m2 pow), + ("sin", onearg sin), ("cos", onearg cos), ("abs", m1 absfun), ("double", onearg id), + ("eq", procEq), ("ne", procNe), ("sqrt", m1 squarert), + ("==", procEql), ("!=", procNotEql), + ("/", m2 divide), ("<", lessThanProc),(">", greaterThanProc), + mkcmd ">=" greaterThanEq, ("<=",lessThanEqProc), + ("rand", procRand), ("srand", procSrand), + ("!", procNot)] + +mkcmd n f = (n,inner) + where inner args = case args of + [a,b] -> return $! f a b + _ -> argErr n + +procSrand args = case args of + [v] -> mathSrand v + [] -> tclErr "too few arguments to math function" + _ -> tclErr "too many arguments to math function" + +mathSrand v = do + i <- T.asInt v + io (setStdGen (mkStdGen i)) + ret + +procRand _ = mathRand + +mathRand = io randomIO >>= return . T.mkTclDouble + +onearg f = m1 inner + where inner x = do + d <- T.asDouble x + return (T.mkTclDouble (f d)) +{-# INLINE onearg #-} + +absfun x = case T.asInt x of + Nothing -> do d <- T.asDouble x + return (T.mkTclDouble (abs d)) + Just i -> return (T.mkTclInt (abs i)) + +m1 f args = case args of + [a] -> f a + _ -> if length args > 1 then tclErr "too many arguments to math function" + else tclErr "too few arguments to math function" +{-# INLINE m1 #-} + +many !f !i args = case args of + [a,b] -> f a b + _ -> foldM f (T.mkTclInt i) args +{-# INLINE many #-} + +m2 f args = case args of + [a,b] -> f a b + _ -> if length args > 2 then tclErr "too many arguments to math function" + else tclErr "too few arguments to math function" +{-# INLINE m2 #-} + +procNot args = case args of + [x] -> return $! T.fromBool . not . T.asBool $ x + _ -> argErr "!" + +squarert x = do + case T.asInt x of + Just i -> return $! T.mkTclDouble (sqrt (fromIntegral i)) + Nothing -> do + d1 <- T.asDouble x + return $! T.mkTclDouble (sqrt d1) + +plus x y = do + case (T.asInt x, T.asInt y) of + (Just i1, Just i2) -> return $! (T.mkTclInt (i1+i2)) + _ -> do + d1 <- T.asDouble x + d2 <- T.asDouble y + return $! T.mkTclDouble (d1+d2) + +pow x y = do + case (T.asInt x, T.asInt y) of + (Just i1, Just i2) -> return $! (T.mkTclInt (i1^i2)) + _ -> do + d1 <- T.asDouble x + d2 <- T.asDouble y + return $! T.mkTclDouble (d1 ** d2) + +minus x y = do + case (T.asInt x, T.asInt y) of + (Just i1, Just i2) -> return $! (T.mkTclInt (i1-i2)) + _ -> do + d1 <- T.asDouble x + d2 <- T.asDouble y + return $! T.mkTclDouble (d1-d2) + +times !x !y = do + case (T.asInt x, T.asInt y) of + (Just i1, Just i2) -> return $! (T.mkTclInt (i1*i2)) + _ -> do + d1 <- T.asDouble x + d2 <- T.asDouble y + return $! T.mkTclDouble (d1*d2) + +divide x y = do + case (T.asInt x, T.asInt y) of + (Just i1, Just i2) -> return $! (T.mkTclInt (i1 `div` i2)) + _ -> do + d1 <- T.asDouble x + d2 <- T.asDouble y + return $! T.mkTclDouble (d1 / d2) + +lessThan a b = case tclCompare a b of + LT -> T.tclTrue + _ -> T.tclFalse + +lessThanProc args = case args of + [a,b] -> return $! lessThan a b + _ -> argErr "<" + +lessThanEq a b = case tclCompare a b of + GT -> T.tclFalse + _ -> T.tclTrue + +lessThanEqProc args = case args of + [a,b] -> return $! (lessThanEq a b) + _ -> argErr "<=" + +greaterThan a b = case tclCompare a b of + GT -> T.tclTrue + _ -> T.tclFalse + +greaterThanProc args = case args of + [a,b] -> return $! greaterThan a b + _ -> argErr ">" + +greaterThanEq a b = case tclCompare a b of + LT -> T.tclFalse + _ -> T.tclTrue + +equals a b = case tclCompare a b of + EQ -> T.tclTrue + _ -> T.tclFalse + +procEql args = case args of + [a,b] -> return $! (equals a b) + _ -> argErr "==" + +notEquals a b = case tclCompare a b of + EQ -> T.tclFalse + _ -> T.tclTrue + +procNotEql args = case args of + [a,b] -> case (T.asInt a, T.asInt b) of + (Just ia, Just ib) -> return $! T.fromBool (ia /= ib) + _ -> procNe [a,b] + _ -> argErr "!=" + +procEq args = case args of + [a,b] -> return . T.fromBool $! (T.strEq a b) + _ -> argErr "eq" + +procNe args = case args of + [a,b] -> return . T.fromBool $! (T.strNe a b) + _ -> argErr "ne" + + +tclCompare a b = + case (T.asInt a, T.asInt b) of + (Just i1, Just i2) -> compare i1 i2 + _ -> case (T.asDouble a, T.asDouble b) of + (Just d1, Just d2) -> compare d1 d2 + _ -> compare (T.asBStr a) (T.asBStr b) +{-# INLINE tclCompare #-} + +-- # TESTS # -- + + +testProcEq = TestList [ + "1 eq 1 -> t" ~: (procEq [int 1, int 1]) `is` True + ,"1 == 1 -> t" ~: (procEql [int 1, int 1]) `is` True + ,"' 1 ' == 1 -> t" ~: procEql [str " 1 ", int 1] `is` True + ,"' 1 ' eq 1 -> f" ~: procEq [str " 1 ", int 1] `is` False + ,"' 1 ' eq ' 1 ' -> t" ~: procEq [str " 1 ", str " 1 "] `is` True + ,"' 1 ' ne '1' -> t" ~: procNe [str " 1 ", str "1"] `is` True + ,"'cats' eq 'cats' -> t" ~: procEq [str "cats", str "cats"] `is` True + ,"'cats' eq 'caps' -> f" ~: procEq [str "cats", str "caps"] `is` False + ,"'cats' ne 'cats' -> t" ~: procNe [str "cats", str "cats"] `is` False + ,"'cats' ne 'caps' -> f" ~: procNe [str "cats", str "caps"] `is` True + ] + where (?=?) a b = assert (runCheckResult b (Right a)) + is c b = (T.fromBool b) ?=? c + int i = T.mkTclInt i + str s = T.mkTclStr s + +mathTests = TestList [ testProcEq ] + +-- # ENDTESTS # -- diff --git a/TclLib/NSProcs.hs b/TclLib/NSProcs.hs new file mode 100644 --- /dev/null +++ b/TclLib/NSProcs.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE BangPatterns,OverloadedStrings #-} +module TclLib.NSProcs (nsProcs) where + +import Common +import Core (evalTcl) +import VarName +import qualified TclObj as T + +nsProcs = makeCmdMap [("namespace", procNamespace), ("variable", procVariable)] + +procNamespace :: [T.TclObj] -> TclM RetVal +procNamespace = makeEnsemble "namespace" [ + ("current", ns_current), + ("eval", ns_eval), + ("parent", ns_parent), + ("children", ns_children), + ("delete", ns_delete), + ("tail", ns_tail), + ("export", ns_export), + ("import", ns_import), + ("origin", ns_origin), + ("qualifiers", ns_qualifiers), + ("exists", ns_exists)] + +procVariable args = case args of + [n] -> variableNS (T.asBStr n) Nothing >> ret + [n,v] -> variableNS (T.asBStr n) (Just v) >> ret + _ -> argErr "variable" + +ns_current args = case args of + [] -> currentNS >>= treturn + _ -> argErr "namespace current" + +ns_eval args = case args of + [nsname, code] -> withNS (T.asBStr nsname) (evalTcl code) + _ -> argErr "namespace eval" + +ns_parent args = case args of + [] -> parentNS >>= treturn + _ -> argErr "namespace parent" + +ns_export :: TclCmd +ns_export args = case map T.asBStr args of + [] -> getExportsNS >>= return . T.mkTclList . map T.mkTclBStr + ("-clear":al) -> mapM_ (exportNS True) al >> ret + al -> mapM_ (exportNS False) al >> ret + +ns_import args = case map T.asBStr args of + ("-force":rest) -> mapM_ (importNS True) rest >> ret + al -> mapM_ (importNS False) al >> ret + +ns_origin :: TclCmd +ns_origin args = case args of + [pn] -> do pr <- getProc (T.asBStr pn) + case pr of + Nothing -> tclErr $ "invalid command name: " ++ show pn + Just p -> getOrigin p >>= treturn + _ -> argErr "namespace origin" + +ns_children args = case args of + [] -> childrenNS >>= return . T.mkTclList . map T.mkTclBStr + _ -> argErr "namespace children" + +ns_exists args = case args of + [nsn] -> existsNS (T.asBStr nsn) >>= return . T.fromBool + _ -> argErr "namespace exists" + +ns_delete args = case args of + [] -> argErr "namespace delete" + nsl -> mapM_ (deleteNS . T.asBStr) nsl >> ret + +ns_tail args = case args of + [s] -> case parseNSTag (T.asBStr s) of + Nothing -> ret + Just v -> return . T.mkTclBStr $ (nsTail v) + _ -> argErr "namespace tail" + +ns_qualifiers args = case args of + [s] -> return . T.mkTclBStr $ (nsQualifiers (T.asBStr s)) + _ -> argErr "namespace qualifiers" diff --git a/TclLib/StringProcs.hs b/TclLib/StringProcs.hs new file mode 100644 --- /dev/null +++ b/TclLib/StringProcs.hs @@ -0,0 +1,99 @@ +module TclLib.StringProcs (stringProcs, stringTests) where + +import Common +import Util +import qualified Data.ByteString.Char8 as B +import qualified TclObj as T +import TclObj ((.==)) +import Data.Char (toLower,toUpper) + +import Test.HUnit + +stringProcs = makeCmdMap [("string", procString), ("append", procAppend), ("split", procSplit)] + +procString = makeEnsemble "string" [ + ("trim", string_Op "trim" T.trim), + ("tolower", string_Op "tolower" (B.map toLower)), + ("toupper", string_Op "toupper" (B.map toUpper)), + ("reverse", string_Op "reverse" B.reverse), + ("length", string_length), + ("match", string_match), ("compare", string_compare), + ("index", string_index) + ] + +string_Op name op args = case args of + [s] -> treturn $! op (T.asBStr s) + _ -> argErr $ "string " ++ name + +string_length args = case args of + [s] -> return $ T.mkTclInt (B.length (T.asBStr s)) + _ -> argErr "string length" + +string_compare args = case args of + [s1,s2] -> case compare (T.asBStr s1) (T.asBStr s2) of + LT -> return (T.mkTclInt (-1)) + GT -> return (T.mkTclInt 1) + EQ -> return (T.mkTclInt 0) + _ -> argErr "string compare" + +string_match args = case map T.asBStr args of + [s1,s2] -> domatch False s1 s2 + [nocase,s1,s2] -> if nocase == pack "-nocase" then domatch True s1 s2 else argErr "string" + _ -> argErr "string match" + where domatch nocase a b = return (T.fromBool (match nocase a b)) + +string_index args = case args of + [s,i] -> do let str = T.asBStr s + ind <- toInd str i + if ind >= (B.length str) || ind < 0 + then ret + else treturn $ B.take 1 (B.drop ind str) + _ -> argErr "string index" + where toInd s i = (T.asInt i) `orElse` tryEnd s i + tryEnd s i = if i .== "end" + then return ((B.length s) - 1) + else do let (ip,is) = B.splitAt (length "end-") (T.asBStr i) + if ip == pack "end-" + then case B.readInt is of + Just (iv,_) -> return ((B.length s) - (1+iv)) + _ -> tclErr "bad index" + else tclErr "bad index" + +procAppend args = case args of + (v:vx) -> do val <- varGet (T.asBStr v) `ifFails` T.empty + let cated = oconcat (val:vx) + varSet (T.asBStr v) cated + _ -> argErr "append" + where oconcat = T.mkTclBStr . B.concat . map T.asBStr + +procSplit args = case args of + [str] -> dosplit (T.asBStr str) (pack "\t\n ") + [str,chars] -> let splitChars = T.asBStr chars + in if B.null splitChars then return $ (T.mkTclList . map (T.mkTclBStr . B.singleton) . unpack) (T.asBStr str) + else dosplit (T.asBStr str) splitChars + _ -> argErr "split" + + where dosplit str chars = return $ T.mkTclList (map T.mkTclBStr (B.splitWith (\v -> v `B.elem` chars) str)) + +stringTests = TestList [ matchTests ] +matchTests = TestList [ + "boo" `matches` "boo" + ,"" `matches` "" + ,"1" `matches` "1" + ,"a?c" `matches` "abc" + ,"a?c" `doesnt_match` "ab" + ,"a??d" `matches` "abcd" + ,"f??d" `matches` "feed" + ,"b??n" `matches` "been" + ,"a" `doesnt_match` "ab" + ,"ab" `doesnt_match` "a" + ,"a*" `matches` "abcde" + ,"a*b" `matches` "ab" + ,"a*b" `matches` "a OMG b" + ,"*b" `matches` "in the land of bob" + ,"*" `matches` "in the land of bob" + ,"*" `matches` "" + ,"s\\*r" `matches` "s*r" + ] + where matches a b = (show a) ++ " matches " ++ (show b) ~: True ~=? match False (B.pack a) (B.pack b) + doesnt_match a b = (show a) ++ " doesn't match " ++ (show b) ~: False ~=? match False (B.pack a) (B.pack b) diff --git a/TclLib/UtilProcs.hs b/TclLib/UtilProcs.hs new file mode 100644 --- /dev/null +++ b/TclLib/UtilProcs.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE BangPatterns #-} +module TclLib.UtilProcs ( utilProcs ) where + +import Data.Time.Clock (diffUTCTime,getCurrentTime,addUTCTime) +import Control.Monad (unless) +import Control.Concurrent (threadDelay) +import Core (evalTcl, subst, callProc) +import Common +import Util (unpack) +import ExprParse +import Data.List (intersperse) +import qualified TclObj as T + +utilProcs = makeCmdMap [ + ("time", procTime), + ("incr", procIncr), ("expr", procExpr), + ("after", procAfter), ("update", procUpdate)] + +procIncr args = case args of + [vname] -> incr vname 1 + [vname,val] -> T.asInt val >>= incr vname + _ -> argErr "incr" + +incr :: T.TclObj -> Int -> TclM RetVal +incr n !i = varModify (T.asBStr n) $ + \v -> do ival <- T.asInt v + return $! (T.mkTclInt (ival + i)) + +procTime args = + case args of + [code] -> do tspan <- dotime code + return (T.mkTclStr (show tspan)) + [code,cnt] -> do count <- T.asInt cnt + unless (count > 0) (tclErr "invalid number of iterations in time") + ts <- mapM (\_ -> dotime code) [1..count] + let str = show ((sum ts) / fromIntegral (length ts)) + return (T.mkTclStr (str ++ " per iteration")) + _ -> argErr "time" + where dotime code = do + startt <- io getCurrentTime + evalTcl code + endt <- io getCurrentTime + let tspan = diffUTCTime endt startt + return tspan + +procAfter args = + case args of + [mss] -> do + ms <- T.asInt mss + io $ threadDelay (1000 * ms) + ret + (mss:acts) -> do + ms <- T.asInt mss + let secs = (fromIntegral ms) / 1000.0 + currT <- io getCurrentTime + let dline = addUTCTime secs currT + evtAdd (T.objconcat acts) dline + _ -> argErr "after" + +procUpdate args = case args of + [] -> do evts <- evtGetDue + upglobal (mapM_ evalTcl evts) + ret + _ -> argErr "update" + where upglobal f = do sl <- stackLevel + uplevel sl f + +procExpr args = do + al <- mapM subst args + let s = concat $ intersperse " " (map unpack al) + riExpr s lu + where lu v = case v of + Left n -> varGet n + Right (n,a) -> callProc n a diff --git a/TclObj.hs b/TclObj.hs --- a/TclObj.hs +++ b/TclObj.hs @@ -1,89 +1,172 @@ -module TclObj where - -import Test.HUnit -- IGNORE +{-# LANGUAGE BangPatterns #-} +module TclObj ( + TclObj + ,mkTclStr + ,mkTclBStr + ,mkTclList + ,mkTclList' + ,mkTclInt + ,mkTclDouble + ,fromBlock + ,fromBool + ,empty + ,isEmpty + ,tclTrue + ,tclFalse + ,asStr + ,asBool + ,asInt + ,asBStr + ,asParsed + ,asSeq + ,asList + ,asDouble + ,(.==) + ,strEq + ,strNe + ,trim + ,objconcat + ,tclObjTests ) where import qualified BSParse as P import qualified Data.ByteString.Char8 as BS -import System.IO -import Data.Unique +import Control.Monad +import RToken +import Util +import qualified Data.Sequence as S +import qualified Data.Foldable as F -data TclChan = TclChan { chanHandle :: Handle, chanName :: BS.ByteString } deriving (Eq,Show) +import Test.HUnit -tclStdChans = [ mkChan' stdout "stdout", mkChan' stdin "stdin", mkChan' stderr "stderr" ] +data TclObj = TclInt !Int BString | + TclDouble !Double BString | + TclList !(S.Seq TclObj) BString | + TclBStr !BString (Maybe Int) (Either String Parsed) deriving (Show,Eq) +mkTclStr s = mkTclBStr (pack s) +mkTclBStr s = TclBStr s (maybeInt s) (tryParsed s) +{-# INLINE mkTclBStr #-} -mkChan h = do n <- uniqueNum - return (mkChan' h ("file" ++ show n)) - where uniqueNum = newUnique >>= return . hashUnique +mkTclList l = TclList (S.fromList l) (fromList (map asBStr l)) +mkTclList' l = TclList l (fromList (map asBStr (F.toList l))) -mkChan' h n = TclChan h (BS.pack n) +fromBlock s p = TclBStr s (maybeInt s) p +maybeInt s = case BS.readInt (dropWhite s) of + Nothing -> Nothing + Just (i,r) -> if BS.null r || BS.null (dropWhite r) then Just i else Nothing -data TclObj = TclInt !Int BS.ByteString | - TclBStr !BS.ByteString (Maybe Int) (Either String [[P.TclWord]]) deriving (Show,Eq) +strEq (TclInt i1 _) (TclInt i2 _) = i1 == i2 +strEq o1 o2 = asBStr o1 == asBStr o2 -mkTclStr s = mkTclBStr (BS.pack s) -mkTclBStr s = mkTclBStrP s (doParse s) +strNe (TclInt i1 _) (TclInt i2 _) = i1 /= i2 +strNe o1 o2 = asBStr o1 /= asBStr o2 -mkTclBStrP s p = TclBStr s mayint p - where mayint = case BS.readInt (P.dropWhite s) of - Nothing -> Nothing - Just (i,_) -> Just i -doParse s = case P.runParse s of - Nothing -> Left "parse failed" - Just (r,rs) -> if BS.null rs then Right r else Left ("Incomplete parse: " ++ show rs) - -mkTclInt i = TclInt i (BS.pack (show i)) +mkTclInt !i = TclInt i bsval + where bsval = pack (show i) +{-# INLINE mkTclInt #-} +mkTclDouble :: Double -> TclObj +mkTclDouble !d = TclDouble d bsval + where bsval = pack (show d) + empty = TclBStr BS.empty Nothing (Left "bad parse") +isEmpty (TclInt _ _) = False +isEmpty (TclDouble _ _) = False +isEmpty v = BS.null (asBStr v) -tclTrue = mkTclInt 1 -tclFalse = mkTclInt 0 -fromBool b = if b then tclTrue else tclFalse +tclTrue = mkTclInt 1 +tclFalse = mkTclInt 0 -trim :: TclObj -> BS.ByteString -trim = BS.reverse . P.dropWhite . BS.reverse . P.dropWhite . asBStr +fromBool !b = if b then tclTrue else tclFalse +trim = BS.reverse . dropWhite . BS.reverse . dropWhite + class ITObj o where - asStr :: o -> String asBool :: o -> Bool asInt :: (Monad m) => o -> m Int - asBStr :: o -> BS.ByteString - asParsed :: (Monad m) => o -> m [[P.TclWord]] + asBStr :: o -> BString + asSeq :: (Monad m) => o -> m (S.Seq o) +bstrAsInt bs = case BS.readInt bs of + Nothing -> fail ("Bad int: " ++ show bs) + Just (i,r) -> if BS.null r then return i else fail ("Bad int: " ++ show bs) + +bstrAsSeq st = liftM S.fromList (asListS st) +{- instance ITObj BS.ByteString where asStr = BS.unpack asBool bs = (bs `elem` trueValues) - asInt bs = maybe (fail ("Bad int: " ++ show bs)) (return . fst) (BS.readInt bs) + asInt = bstrAsInt asBStr = id - asParsed s = case P.runParse s of - Nothing -> fail $ "parse failed: " ++ show s - Just (r,rs) -> if BS.null rs then return r - else fail $ "incomplete parse: " ++ show rs + asParsed s = either fail return (resultToEither (P.runParse s) s) + asSeq st = liftM S.fromList (asListS st) -instance ITObj TclObj where - asStr (TclInt _ b) = BS.unpack b - asStr (TclBStr bs _ _) = asStr bs +-} - asBool (TclInt i _) = i /= 0 - asBool (TclBStr bs _ _) = asBool bs +asList :: (Monad m) => TclObj -> m [TclObj] +asList o = liftM F.toList (asSeq o) +asStr o = unpack (asBStr o) + +instance ITObj TclObj where + asBool (TclList _ bs) = bs `elem` trueValues + asBool (TclInt i _) = i /= 0 + asBool (TclDouble d _) = d /= 0.0 + asBool (TclBStr bs _ _) = bs `elem` trueValues + asInt (TclInt i _) = return i + asInt (TclDouble _ b) = fail $ "expected integer, got " ++ show b asInt (TclBStr _ (Just i) _) = return i asInt (TclBStr v Nothing _) = fail $ "Bad int: " ++ show v - + asInt (TclList _ v) = bstrAsInt v + asBStr (TclBStr s _ _) = s asBStr (TclInt _ b) = b + asBStr (TclDouble _ b) = b + asBStr (TclList _ b) = b + {-# INLINE asBStr #-} - asParsed (TclBStr _ _ (Left f)) = fail f + asSeq (TclBStr s _ _) = bstrAsSeq s >>= return . fmap mkTclBStr + asSeq (TclList l _) = return l + asSeq v = return (S.singleton v) + +instance Parseable TclObj where + asParsed (TclBStr _ _ (Left f)) = fail f asParsed (TclBStr _ _ (Right r)) = return r - asParsed (TclInt _ _) = fail "Can't parse an int value" - + asParsed (TclInt _ b) = return (singleTok b) + asParsed (TclDouble _ b) = return (singleTok b) + asParsed (TclList _ s) = asParsed s + {-# INLINE asParsed #-} -trueValues = map BS.pack ["1", "true", "yes", "on"] +asDouble :: (Monad m) => TclObj -> m Double +asDouble (TclDouble d _) = return $! d +asDouble obj = do + case asInt obj of + Just i -> return $! (fromIntegral i) + Nothing -> let strval = asStr obj + in case reads strval of + [(d,"")] -> return $! d -- TODO: not quite right. + _ -> fail $ "expected float but got " ++ show strval +fromList l = (map listEscape l) `joinWith` ' ' + +asListS s = case P.parseList s of + Nothing -> fail $ "list parse failure: " ++ show s + Just lst -> return lst + + +trueValues = map pack ["1", "true", "yes", "on"] + +(.==) :: TclObj -> String -> Bool +(.==) bs str = (asBStr bs) == pack str +{-# INLINE (.==) #-} + +objconcat :: [TclObj] -> TclObj +objconcat = mkTclBStr . (`joinWith` ' ') . map (trim . asBStr) + -- # TESTS # -- testTrim = TestList [ @@ -95,8 +178,8 @@ trim (str " 10 ") ?=> "10" ] where (?=>) s e = s ~=? (BS.pack e) - int i = mkTclInt i - str s = mkTclStr s + int = asBStr . mkTclInt + str = asBStr . mkTclStr testAsBool = TestList [ tclTrue `is` True, diff --git a/Util.hs b/Util.hs new file mode 100644 --- /dev/null +++ b/Util.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE BangPatterns,OverloadedStrings #-} +module Util where +import qualified Data.ByteString.Char8 as B +import Control.Monad.Error +import Data.List(intersperse) +import Test.HUnit +import Data.Char (toLower) +import Data.String + +type BString = B.ByteString + +instance IsString B.ByteString where + fromString = B.pack + +joinWithBS bsl bs = B.concat (intersperse bs bsl) +joinWith bsl c = B.concat (intersperse (B.singleton c) bsl) +{-# INLINE joinWith #-} +pack = B.pack +{-# INLINE pack #-} +unpack = B.unpack +bsNull = B.null +{-# INLINE bsNull #-} + +dropWhite = B.dropWhile (\x -> x == ' ' || x == '\t') +{-# INLINE dropWhite #-} + +mapSnd f = map (\(a,b) -> (a, f b)) +{-# INLINE mapSnd #-} +mapFst f = map (\(a,b) -> (f a, b)) + +ifFails f v = f `catchError` (\_ -> return v) +{-# INLINE ifFails #-} + +orElse f f2 = f `catchError` (\_ -> f2) + +slurpFile fname = do dat <- B.readFile fname + B.length dat `seq` return dat + +listEscape s = if (B.elem ' ' s && not hasBracks) || B.null s + then B.concat [B.singleton '{', s, B.singleton '}'] + else if hasBracks then B.concat (escapeStr s) else s + where hasBracks = bdepth /= 0 + bdepth = brackDepth s + +downCase = B.map toLower + +brackDepth s = match 0 0 False + where match i c esc = if i >= B.length s + then c + else let ni = i+1 + in if esc then match ni c False + else case B.index s i of + '{' -> match ni (c+1) False + '}' -> match ni (c-1) False + '\\' -> match ni c True + _ -> match ni c False + + +escapeStr s = case B.findIndex (`B.elem` " \n\t{}") s of + Nothing -> [s] + Just i -> let (b,a) = B.splitAt i s + in b : handle (B.head a) : escapeStr (B.drop 1 a) + where handle '\n' = "\\n" + handle ' ' = "\\ " + handle '{' = "\\{" + handle '}' = "\\}" + handle _ = error "The impossible happened in handle" + +commaList :: String -> [String] -> String +commaList _ [] = "" +commaList _ [a] = a +commaList conj lst = (intercalate ", " (init lst)) ++ " " ++ conj ++ " " ++ last lst + +intercalate :: String -> [String] -> String +intercalate xs xss = concat (intersperse xs xss) + +match :: Bool -> BString -> BString -> Bool +match nocase pat str = inner 0 0 + where slen = B.length str + plen = B.length pat + ceq a b = if nocase then toLower a == toLower b else a == b + inner pi si + | pi == plen = si == slen + | otherwise = case B.index pat pi of + '*' -> pi == (plen - 1) || or (map (inner (succ pi)) [si..(slen - 1)]) + '?' -> not (si == slen) && inner (succ pi) (succ si) + '\\' -> inner (succ pi) si + v -> not (si == slen) && v `ceq` (B.index str si) && inner (succ pi) (succ si) + +globMatch pat = match False pat +exactMatch pat = (== pat) +globMatches pat = filter (globMatch pat) +exactMatches pat = filter (exactMatch pat) + +utilTests = TestList [joinWithTests, listEscapeTests] where + + joinWithTests = TestList [ + ([""],'!') `joinsTo` "" + ,(["one"],'!') `joinsTo` "one" + ,(["one", "two"],',') `joinsTo` "one,two" + ] + where joinsTo (a,s) r = pack r ~=? ((map pack a) `joinWith` s) + + listEscapeTests = TestList [ + noEscape "one" + ,noEscape "[andkda]" + ,"" `escapesAs` "{}" + ,"a b" `escapesAs` "{a b}" + ,"a { b" `escapesAs` "a\\ \\{\\ b" + ,"a } b" `escapesAs` "a\\ \\}\\ b" + ,"a {b} c" `escapesAs` "{a {b} c}" + ," { " `escapesAs` "\\ \\{\\ " + ] + where escapesAs a b = pack b ~=? listEscape (pack a) + noEscape a = pack a ~=? listEscape (pack a) diff --git a/VarName.hs b/VarName.hs new file mode 100644 --- /dev/null +++ b/VarName.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE BangPatterns,OverloadedStrings #-} +module VarName (parseVarName, + nsTail, + nsQualifiers, + parseNSTag, + parseProc, + VarName(..), + arrName, + isArr, + showVN, + NSQual(..), + NSTag(..), + asGlobal, + isGlobalQual, + noNsQual, + splitWith, + nsSep, + varNameTests) where +import Util +import qualified Data.ByteString.Char8 as B +import Data.ByteString (findSubstrings) +import Test.HUnit + + +data NSQual a = NSQual !(Maybe NSTag) !a deriving (Eq,Show) + +data NSTag = NS !Bool ![BString] deriving (Eq,Show,Ord) + +data VarName = VarName { vnName :: !BString, vnInd :: Maybe BString } deriving (Eq,Show) + +class BStringable a where + toBStr :: a -> BString + +instance BStringable NSTag where + toBStr (NS g lst) = B.append (if g then nsSep else B.empty) (B.intercalate nsSep lst) + +arrName !an !ind = VarName an (Just ind) +{-# INLINE arrName #-} + +isArr (VarName _ (Just _)) = True +isArr _ = False + +nsSep :: BString +nsSep = "::" + +isGlobalQual (Just (NS v _)) = v +isGlobalQual _ = False +{-# INLINE isGlobalQual #-} + +noNsQual nst = case nst of + Nothing -> True + (Just (NS False [])) -> True + _ -> False +{-# INLINE noNsQual #-} + +asGlobal (Just (NS _ lst)) = Just (NS True lst) +asGlobal Nothing = Just (NS True []) + +parseNSQual ns = case parseNSTag ns of + Nothing -> NSQual Nothing "" + Just (NS False [s]) -> NSQual Nothing s + Just (NS gq []) -> NSQual (Just (NS gq [])) "" + Just (NS gq nsl) -> NSQual (Just (NS gq (init nsl))) (last nsl) + + +parseNSTag ns = toNSTag (ns `splitWith` nsSep) where + toNSTag nl = if isAbs then return (NS True (tail nl)) + else return (NS False nl) + isAbs = nsSep == B.take 2 ns + +parseVarName name = + case parseArrRef name of + (str,ind) -> case parseNSQual str of + NSQual nst n -> NSQual nst (VarName n ind) + +parseProc :: BString -> NSQual BString +parseProc = parseNSQual + +showVN :: VarName -> String +showVN (VarName name Nothing) = show name +showVN (VarName name (Just i)) = "\"" ++ unpack name ++ "(" ++ unpack i ++ ")\"" + +parseArrRef str = case B.elemIndex '(' str of + Nothing -> (str, Nothing) + Just start -> if (start /= 0) && B.last str == ')' + then let (pre,post) = B.splitAt start str + in (pre, Just (B.tail (B.init post))) + else (str, Nothing) +nsTail (NS _ []) = error "Malformed NSTag" +nsTail (NS _ nsl) = last nsl + +nsTail_ x = case parseNSTag x of + Nothing -> error "FAIL" + Just v -> nsTail v + + +nsQualifiers str = case findSubstrings nsSep str of + [] -> B.empty + lst -> B.take (last lst) str + + +splitWith :: BString -> BString -> [BString] +splitWith str sep = + case findSubstrings sep str of + [] -> [str] + il -> extract il str + where slen = B.length sep + extract [] !s = [s] + extract (i:ix) !s = let (b,a) = B.splitAt i s + in b : extract (map (\v -> v - (i+slen)) ix) (B.drop slen a) +{-# INLINE splitWith #-} + +varNameTests = TestList [splitWithTests, testArr, testParseVarName, testParseNS, testNSTail, + testNsQuals,testInvert, testParseNSQual, + testParseProc] where + bp = pack + splitWithTests = TestList [ + ("one::two","::") `splitsTo` ["one","two"] + ,("::x","::") `splitsTo` ["","x"] + ,("wonderdragon","::") `splitsTo` ["wonderdragon"] + ,("","::") `splitsTo` [""] + ,("::","::") `splitsTo` ["", ""] + ] + where splitsTo (a,b) r = map bp r ~=? ((bp a) `splitWith` (bp b)) + + testParseNSQual = TestList [ + "boo" `parses_to` (Nothing, "boo") + ,"::boo" `parses_to` (mkns True [], "boo") + ,"::boo::flag" `parses_to` (mkns True ["boo"], "flag") + ,"foo::bar" `parses_to` (mkns False ["foo"], "bar") + ] + where parses_to a (b1,b2) = ("parseNSQual " ++ show a) ~: NSQual b1 (bp b2) ~=? parseNSQual a + mkns g v = Just (NS g v) + + testParseNS = TestList [ + "boo" `parses_to` (NS False ["boo"]) + ,"::boo" `parses_to` (NS True ["boo"]) + ,"::" `parses_to` (NS True [""]) + ,"foo::boo" `parses_to` NS False ["foo", "boo"] + ,"::foo::boo" `parses_to` NS True ["foo", "boo"] + ,"woo::foo::boo" `parses_to` NS False ["woo", "foo", "boo"] + ] + where parses_to a nst = ("parseNSTag " ++ show a) ~: (Just nst) ~=? parseNSTag a + + testParseVarName = TestList [ + parseVarName "x" ~=? NSQual Nothing (VarName "x" Nothing) + ,parseVarName "x(a)" ~=? NSQual Nothing (VarName "x" (Just "a")) + ,parseVarName "boo::x(::)" ~=? NSQual (Just (NS False ["boo"])) (VarName "x" (Just "::")) + ,parseVarName "::x" ~=? NSQual (Just (NS True [])) (VarName "x" Nothing) + ] + + testNSTail = TestList [ + nsTail_ "boo" ~=? "boo" + ,nsTail_ (bp "::boo") ~=? (bp "boo") + ,nsTail_ (bp "baby::boo") ~=? (bp "boo") + ,nsTail_ (bp "::baby::boo") ~=? (bp "boo") + ,nsTail_ (bp "::") ~=? (bp "") + ] + testNsQuals = TestList [ + "boo" `should_be` "" + ,"::" `should_be` "" + ,"a::b" `should_be` "a" + ,"a::b::c" `should_be` "a::b" + ,"::a::b::c" `should_be` "::a::b" + ] + where should_be b a = nsQualifiers (bp b) ~=? (bp a) + + testParseProc = TestList [ + "boo" `parses_to` (NSQual Nothing "boo") + ,"::boo" `parses_to` (NSQual (Just (NS True [])) "boo") + ,"::some::boo" `parses_to` (NSQual (Just (NS True ["some"])) "boo") + ] + where parses_to a b = b ~=? parseProc (bp a) + + testInvert = TestList (map tryInvert vals) + where vals = map bp ["boo", "::boo", "::", "::a::b", "a::b", ""] + tryInvert v = v ~=? toBStr (up (parseNSTag v)) + up (Just x) = x + up _ = error "Error in testInvert" + + testArr = TestList [ + "december" `should_be` Nothing + ,"dec(mber" `should_be` Nothing + ,"dec)mber" `should_be` Nothing + ,"(cujo)" `should_be` Nothing + ,"de(c)mber" `should_be` Nothing + ,"a(1)" ?=> ("a","1") + ,"boo(4)" ?=> ("boo","4") + ,"xx(september)" ?=> ("xx","september") + ,"arr(3,4,5)" ?=> ("arr","3,4,5") + ,"arr()" ?=> ("arr","") + ] + where (?=>) a b@(b1,b2) = (a ++ " -> " ++ show b) ~: parseArrRef (bp a) ~=? ((bp b1), Just (bp b2)) + should_be x _ = (x ++ " should be " ++ show (bp x)) ~: parseArrRef (bp x) ~=? (bp x, Nothing) diff --git a/atests.tcl b/atests.tcl --- a/atests.tcl +++ b/atests.tcl @@ -1,111 +1,84 @@ -set assertcount 0 -set current_test "Test" -proc die s { - puts $s - exit -} - source include.tcl +source testlib.tcl -proc assertEq {a b} { - global current_test - if {== $a $b} { - assertPass - } else { - die "$current_test failed: $a != $b" - } -} +source atests/string_tests.tcl +source atests/list_tests.tcl +source atests/array_tests.tcl +source atests/ns_tests.tcl +test "upvar" { -proc checkthat { var op r } { - set res [eval "$op {$var} {$r}"] - if { == $res 1 } { - assertPass - } else { - assertFail "\"$var $op $r\" was not true" + proc uptest {var v} { + upvar $var loc + set loc $v } -} -proc assertPass {} { - global assertcount - puts -nonewline "." - incr assertcount -} - -proc assertFail why { - global current_test - die "'$current_test' failed: $why" -} + set x 4 + uptest x 3 + checkthat $x == 3 -proc assertStrEq {a b} { - global current_test - if {eq $a $b} { - assertPass - } else { - assertFail "\"$a\" != \"$b\"" + proc uptest2 {var2 v} { + proc inner {a b} { + upvar 2 $b whee + set whee $a + } + upvar $var2 lark + inner $v $var2 + incr lark } -} -proc assertNoErr code { - set ret [catch $code] - if { == $ret 0 } { - assertPass - } else { - assertFail "code failed: $code" - } + set y 99 + uptest2 y 3 + checkthat $y == 4 } -proc assertErr code { - set ret [catch "eval {$code}"] - if { == $ret 1 } { - assertPass - } else { - assertFail "code should've failed: $code" - } +test "info vars" { + checkthat [llength [info vars]] == 0 + set x 4 + checkthat [info vars] eq "x" + checkthat [info vars y] eq {} + checkthat [info vars ?] eq "x" } -proc announce { } { - puts "Running tests" -} +test "info exists" { + checkthat [info exists x] == 0 + set x 4 + checkthat [info exists x] == 1 + checkthat [info exists current_test] == 0 + variable testlib::current_test + checkthat [info exists current_test] == 1 -proc assert code { - set ret [uplevel $code] - if { == $ret 1 } { assertPass } else { assertFail "Failed: $code" } + set arr(4) 2 + checkthat [info exists arr(3)] == 0 + checkthat [info exists arr(4)] == 1 + # TODO: Check upvar'd exists } -announce - -assertEq [eval {[* 4 4]}] 16 - +test "info level" { + checkthat [uplevel {info level}] == 0 + checkthat [info level] == 1 + proc getlevel {} { + return [info level] + } -proc uptest {var v} { - upvar $var loc - set loc $v + checkthat [getlevel] == 2 } -set x 4 -uptest x 3 -assertEq $x 3 +test "upvar create" { + proc xxx {} { upvar up local; set local 5 } + checkthat [info exists up] == 0 + xxx + checkthat $up == 5 -proc uptest2 {var2 v} { - proc inner {a b} { - upvar 2 $b whee - set whee $a - } - upvar $var2 lark - inner $v $var2 - incr lark + proc xxx2 {} { upvar up2 local } + checkthat [info exists up2] == 0 + xxx2 + checkthat [info exists up2] == 0 } -set y 99 -uptest2 y 3 -assertEq $y 4 - -proc test {name body} { - global current_test - set current_test $name - eval $body +test "error on bad upvar level" { + assertErr { upvar 1000 x x } } test "unevaluated blocks aren't parsed" { @@ -117,6 +90,15 @@ } } +test "unused args" { + proc addem {a b} { + return [+ $a $a] + return [+ $b $a] + } + + checkthat [addem 5 "balloon"] == 10 +} + test "incr test" { set count 0 @@ -124,34 +106,79 @@ incr count incr count - assertEq $count 3 + checkthat $count == 3 incr count 2 - assertEq 5 $count + checkthat $count == 5 incr count -2 - assertEq 3 $count + checkthat $count == 3 decr count decr count decr count - assertEq $count 0 + checkthat $count == 0 } -test "list test" { - set bean [list 1 2 3 4 5 {6 7 8}] +test "math test" { + checkthat [pow 2 2] == 4 + checkthat [pow 2 10] == 1024 - assertEq [llength $bean] 6 - assertEq [lindex $bean 3] 4 - assertEq [lindex $bean 5] {6 7 8} + checkthat [expr { sqrt(2 + 2) }] eq 2.0 + checkthat [+ 3.5 3.5] == 7.0 - assertEq [lindex 4] 4 - assertStrEq [lindex $bean 8] "" + checkthat [* 2 1.5] == 3.0 + + checkthat [+ 1 1 1 1 1 1] == 6 + checkthat [* 1 1 1 1 1 1 2] == 2 } +test "expr fun parse" { + checkthat [expr { sin(0.0) + 10 }] == 10.0 + + checkthat[expr { !(3 == 4) }] + checkthat[expr { !0 }] + checkthat[expr { !true }] == 0 + + assert_err { expr {} } + # TODO: Not yet + # assert_noerr { expr {[set x ""]} } +} + +test "double compare" { + checkthat [< 0.3 0.9] + checkthat [<= 0.3 0.9] + checkthat [<= 0.9 0.9] + checkthat [<= 0.9 0.3] == 0 + checkthat [> 1.9 1] + checkthat [== 3.8 3.8] + + checkthat [expr { double(3) }] == 3.0 +} + +test "abs mathfunc" { + checkthat [expr { abs(-3) }] eq 3 + checkthat [expr { abs(3) }] eq 3 +} + +test "bool test" { + checkthat [expr { true || false }] == 1 + checkthat [expr { false || true }] == 1 + checkthat [expr { false || false }] == 0 + checkthat [expr { true && false }] == 0 + checkthat [expr { false && true }] == 0 + checkthat [expr { false && false }] == 0 + checkthat [expr { true && true }] == 1 + checkthat [expr { on || off }] == 1 + + checkthat [! true] == 0 + checkthat [! false] == 1 + checkthat [! [! [! true]]] == 0 +} + test "test if, elseif, else" { if { eq "one" "two" } { die "Should not have hit this." @@ -173,74 +200,89 @@ } } - assertEq 0 $total + checkthat $total == 0 argstest total 1 2 3 4 5 6 7 8 - assertEq 36 $total + checkthat $total == 36 } -set sval 0 -set sval2 1 -while {<= $sval 10} { - incr sval - if {<= 8 $sval} { - break - } - if {<= 4 $sval} { - continue +test "basic control flow" { + set sval 0 + set sval2 1 + while {<= $sval 10} { + incr sval + if {<= 8 $sval} { + break + } + if {<= 4 $sval} { + continue + } + incr sval2 } - incr sval2 -} -assertEq 8 $sval -assertEq 4 $sval2 + checkthat $sval == 8 + checkthat $sval2 == 4 +} +test "test append" { + set somestr "one" + append somestr " two" " three" " four" + checkthat $somestr eq "one two three four" + append avar a b c + checkthat $avar eq "abc" +} -assertEq 10 [+ 15 -5] # Check that negatives parse. +test "foreach" { + set numbers {1 2 3 4 5} + set result 0 + foreach number $numbers { + set result [+ $number $result] + } -test "string methods" { - assertEq 4 [string length "five"] - assertEq 0 [string length ""] - assertEq 7 [string length "one\ntwo"] - assertEq 4 [string length "h\n\ti"] + checkthat $result == 15 - set fst [string index "whee" 1] - assertStrEq "h" $fst + set fer "old" + foreach feitem {"a b" "c d"} { + set fer $feitem + } - assertStrEq "wombat" [string tolower "WOMBAT"] - assertStrEq "CALCULUS" [string toupper "calculus"] - assertStrEq "hello" [string trim " hello "] + checkthat $fer eq "c d" } - -set somestr "one" -append somestr " two" " three" " four" -assertStrEq "one two three four" $somestr -append avar a b c -assertStrEq "abc" $avar - -set numbers {1 2 3 4 5} -set result 0 -foreach number $numbers { - set result [+ $number $result] +test "foreach multi-bind" { + foreach {x y z} [list 1 2 3] {} + checkthat $x == 1 + checkthat $y == 2 + checkthat $z == 3 + foreach {x y z} [list 1 2 3 4] {} + checkthat $x == 4 + checkthat $y eq "" + checkthat $z eq "" } -assertEq 15 $result +test "foreach break and continue" { + set v 0 + foreach x { 1 2 3 4 5 } { + set v $x + continue + set v 0 + } + checkthat $v == 5 -set fer "old" -foreach feitem {"a b" "c d"} { - set fer $feitem + set v 0 + foreach x { 1 2 3 4 5 } { + set v $x + break + } + checkthat $v == 1 } -checkthat $fer eq "c d" -# $fer - -test "join and foreach" { +test "foreach misc" { set misc { 1 2 3 4 5 6 } - proc join { lsx mid } { + proc join2 { lsx mid } { set res "" set first_time 1 foreach ind $lsx { - if { [== $first_time 1] } { + if { == $first_time 1 } { set res $ind set first_time 0 } else { @@ -250,82 +292,162 @@ return $res } - checkthat [join $misc +] eq "1+2+3+4+5+6" + checkthat [join2 $misc +] eq "1+2+3+4+5+6" } +test "for loop" { + set res 0 + for {set i 0} { < $i 20 } { incr i } { + incr res $i + } -proc expr { a1 args } { - if { != [llength $args] 0 } { - eval "[lindex $args 0] $a1 [lindex $args 1]" - } else { - eval "expr $a1" + checkthat $res == 190 + checkthat $i == 20 + + set val 0 + for {set i 20} { > $i 0 } { decr i } { + incr val } + + checkthat $val == 20 } -assertEq 8 [expr 4 + 4] -assertEq 8 [expr {4 + 4}] +test "eval tests" { + checkthat [eval {* 4 4}] == 16 + assertNoErr { eval "" } + assertNoErr { eval " " } + + assertErr { eval } # Eval needs 1 or more args + + checkthat [eval * 4 4] == 16 # Eval concats multiple args +} + +test "expr" { + checkthat [expr 4 + 4] == 8 + checkthat [expr {4 + 4}] == 8 + checkthat [expr {9 + (1 * 1)}] == 10 + set x 10 + checkthat [expr { $x + $x }] == 20 + checkthat [expr { [+ 1 1] * 2 }] == 4 + + checkthat [expr { 3 < 4.5 }] + checkthat [expr { 3 <= 4.5 }] + checkthat [expr { 4.5 <= 4.5 }] + checkthat [expr { 4.5 == "4.5" }] + checkthat [expr { 4.5 != 4 }] + checkthat [expr { 4.9 > 2 }] + checkthat [expr { 4.9 >= 2 }] + checkthat [expr { 4.9 >= 4.9 }] + checkthat [expr { "one" eq "one" }] + checkthat [expr { "two" ne "one" }] + checkthat [expr { "1" eq 1 }] +} + test "set returns correctly" { set babytime 444 checkthat [set babytime] == 444 - assertEq 512 [set babytime 512] - assertEq 512 $babytime + checkthat [set babytime 512] == 512 + checkthat $babytime == 512 } -assertErr { error "oh noes" } +test "errors and catch" { -assertEq 1 [catch { puts "$thisdoesntexist" }] -assertEq 0 [catch { [+ 1 1] }] + assertErr { error "oh noes" } + checkthat [catch { puts "$thisdoesntexist" }] == 1 + checkthat [catch { + 1 1 }] == 0 + + catch { set x [+ $x 4] } reason + checkthat $reason eq {can't read "x": no such variable} + + set x 4 + catch { incr x } result + checkthat $result == 5 +} + + +test "catching return, break and continue" { + checkthat [catch return] == 2 + checkthat [catch break] == 3 + checkthat [catch continue] == 4 +} + +test "whitespace escaping" { + set x \ + 13 + + checkthat $x == 13 + + set boo \ redrum + + checkthat $boo eq " redrum" + + set lala \ + checkthat $lala eq " " +} + +test "int parsing" { + checkthat 1 != "1 2 3 4" +} + + set whagganog "" set otherthing "" - test "global test" { - upvar otherthing ot - proc testglobal {bah} { - proc modother { m } { - global whagganog otherthing - set otherthing $whagganog$m - } + proc testglobal {bah} { + proc modother { m } { + global whagganog otherthing + set otherthing $whagganog$m + } - global whagganog - append whagganog $bah - modother $bah - return $whagganog - } + global whagganog + append whagganog $bah + modother $bah + return $whagganog + } - checkthat [testglobal 1] == 1 - checkthat $ot == 11 - checkthat [testglobal 2] == 12 - checkthat $ot == 122 + checkthat [testglobal 1] == 1 + checkthat $::otherthing == 11 + checkthat [testglobal 2] == 12 + checkthat $::otherthing == 122 } +unset whagganog +unset otherthing test "parsing corners" { + checkthat [+ 15 -5] == 10 # Check that negatives parse. + set { shh.. ?} 425 - assertStrEq " 425 " " ${ shh.. ?} " + checkthat " 425 " eq " ${ shh.. ?} " - assertStrEq "whee $ stuff" "whee \$ stuff" + checkthat "whee $ stuff" eq "whee \$ stuff" - assertStrEq "whee \$ stuff" "whee \$ stuff" - assertStrEq "whee \$\" stuff" "whee $\" stuff" + checkthat "whee \$ stuff" eq "whee \$ stuff" + checkthat "whee \$\" stuff" eq "whee $\" stuff" assertNoErr { if { == 3 3 } { } else { die "bad" } } -} + set x four + checkthat "$x: 4" eq "four: 4" +} -proc not v { - if { == 1 $v } { return false } else { return true } +test "ns parsing with array lookup" { + assert_noerr { + set x(::) 4 + set y $x(::) + } } test "equality of strings and nums" { set x 10 set y " 10 " - assert { == $x $y } - assert { ne $x $y } - assert { eq 33 33 } + checkthat $x == $y + checkthat $x ne $y + checkthat 33 eq 33 assert { == "cobra" "cobra" } checkthat " 1 " ne 1 checkthat " 1 " == 1 @@ -333,18 +455,26 @@ assert { == 4 4 } } +test "equality 2" { + checkthat [list 1 2] eq "1 2" + checkthat [ne [list 1 2] {1 2}] eq 0 +} + test "early return" { set moo 4 - proc yay {} { - upvar moo moo2 - return - set moo2 5 - } + finalize { proc yay } { + proc yay {} { + upvar moo moo2 + return + set moo2 5 + } - yay - checkthat $moo == 4 + yay + checkthat $moo == 4 + } } + test "arg count check" { proc blah {a b} { + $a $b @@ -393,22 +523,27 @@ assertErr { " } } + test "default proc args" { proc plus { t { y 1 } } { - [+ $t $y] + + $t $y } proc plus2 { x {y 1} } { - [+ $x $y] + + $x $y } - proc plus3 { {a 5} {b 1} } { - [+ $a $b] + proc plus3 { " a 5 " "b 1" } { + + $a $b } + proc weirdorder { { a1 "boo" } a2 } { + return $a1$a2 + } + proc withargs { i {j 4} args } { - [+ [llength $args] [+ $i $j]] + + [llength $args] [+ $i $j] } checkthat [plus 3 3] == 6 @@ -420,21 +555,430 @@ checkthat [plus3] == 6 + checkthat [weirdorder "xx" "yy"] eq "xxyy" + + assertErr { weirdorder "xx" } + checkthat [withargs 1] == 5 checkthat [withargs 1 3] == 4 checkthat [withargs 1 3 1] == 5 checkthat [withargs 1 3 1 1 1 8 1] == 9 } -test "array set/get" { - set boo(4) 111 - checkthat "$boo(4)" == 111 +test "lone subcommand" { + proc id {x} { return $x } + set x 0 + + [id "set"] x 11 + + checkthat $x == 11 } -assertErr { proc banana } -assertErr { proc banana { puts "banana" } } -assertNoErr { proc banana { } { puts "banana" } } -assertNoErr { proc banana {} { puts "banana" } } -puts "" -puts stdout "Done. Passed $assertcount checks." +test "unset" { + set y 4 + checkthat $y == 4 + checkthat [info exists y] == 1 + checkthat [unset y] eq "" + assertErr { incr y } + checkthat [info exists y] == 0 +} + +test "unset with upvar" { + proc unset_x {} { + with_test "in proc" { + upvar x boo + checkthat [info exists boo] == 1 + checkthat $boo == 0 + unset boo + checkthat [info exists boo] == 0 + } + } + set x 0 + checkthat $x == 0 + checkthat [info exists x] == 1 + unset_x + checkthat [info exists x] == 0 + + finalize { proc unset_x } +} + +test "unset array elt" { + set x(4) 4 + set x(5) 5 + checkthat [array size x] == 2 + checkthat $x(4) == 4 + unset x(4) + + checkthat [array size x] == 1 +} + +test "proc must be complete" { + assertErr { proc banana } + assertErr { proc banana { puts "banana" } } + assertNoErr { proc banana { } { puts "banana" } } + assertNoErr { proc banana {} { puts "banana" } } +} + + +test "rename" { + assertErr { rename one one_ } + proc one {} { return 1 } + checkthat [one] == 1 + rename one one_ + assertErr { one } + checkthat [one_] == 1 + rename one_ "" + assertErr { one_ } +} + +test "for loop 2" { + set val 0 + for {set x 1} {< $x 10} {incr x} { + set val $x + } + checkthat $val == 9 + checkthat $x == 10 + + for {set x 1} {< $x 10} {incr x} { + break + } + + checkthat $x == 1 + + set val -1 + for {set x 1} {< $x 10} {incr x} { + continue + set val $x + } + checkthat $val == -1 +} + +proc ignore _ { return {} } + +proc no_ignore code { uplevel $code } + +test "global ns proc" { + checkthat [::+ 1 1] == 2 + checkthat [+ 1 1] == 2 +} + +test "switch" { + set x 4 + switch $x { + 1 { assertFail "bad switch" } + 3 { assertFail "bad switch" } + 4 { assertPass } + } +} + +test "switch fallthrough" { + set x 4 + switch $x { + 1 { assertFail "bad switch" } + 3 { assertFail "bad switch" } + 4 - + 5 { assertPass } + 4 { assertFail "bad switch" } + } + + set val 0 + switch $x { + 1 - 2 - 3 - 4 - 5 { incr val } + } + checkthat $val == 1 +} + +test "switch default" { + set res "failed" + set x 4 + switch $x { + 1 { assertFail "bad switch" } + 3 { assertFail "bad switch" } + default { set res "worked" } + } + + checkthat $res eq "worked" +} + +test "switch return" { + set x 2 + set result \ + [switch $x { + 1 { + 1 2 } + 2 { + 2 2 } + 3 { + 3 2 } + }] + + checkthat $result == 4 + +} + +test "switch exact" { + set x 4 + switch -exact $x { + 2 { assertFail "bad Switch" } + 4 { assertPass } + default { assertFail "bad Swich" } + } +} + +test "switch glob" { + set x been + switch -glob $x { + 2 { assertFail "bad Switch1" } + b*d { assertFail "bad Switch2" } + b??n { assertPass } + been { assertFail "wtf" } + default { assertFail "bad Switch3" } + } +} + +test "switch --" { + set x 4 + switch -- $x { + 2 { assertFail "bad Switch" } + 4 { assertPass } + default { assertFail "bad Swich" } + } +} + +test "expand" { + checkthat [+ {*}[list 1 1]] == 2 + checkthat [+ {*}5 {*}5] == 10 + set boo [list 3 3] + checkthat [list {*}$boo] eq $boo + + checkthat [concat {*}$boo] eq "3 3" +} + +test "list escaping" { + set x [list 1 2 3 \{ \} 6] + checkthat [llength $x] == 6 +} + +test "split" { + set res [split "one two three four"] + checkthat [llength $res] == 4 + + set res [split "comp.lang.misc.fuzzyx" ".x"] + checkthat [lindex $res 2] eq "misc" + checkthat [llength $res] == 5 + + + checkthat [llength [split "Hey you" {}]] == 7 +} + +test "namespaces" { + set ::x 4 + checkthat $::x == 4 + unset ::x + assertErr { checkthat $::x == 4 } +} + +test "exists and unset global" { + set ::gv 9 + checkthat [info exists ::gv] == 1 + unset ::gv + checkthat [info exists ::gv] == 0 +} + +test "incr global" { + set ::gv 1 + incr ::gv + checkthat $::gv == 2 + unset ::gv +} + +test "set global" { + set ::x 4 + checkthat [set ::x] == 4 + unset ::x +} + +test "unknown" { + set oops 0 + set missed {} + rename banana "" + proc unknown {name args} { + uplevel {incr oops} + uplevel "set missed $name" + } + checkthat $oops == 0 + banana 44 + checkthat $oops == 1 + checkthat $missed eq banana + rename unknown "" +} + +test "uplevel issue" { + set level [info level] + catch { uplevel { error "Oh no" } } + checkthat [info level] == $level +} + +test "global namespace" { + uplevel { set a_global 9 } + checkthat [info exists a_global] == 0 + checkthat $::a_global == 9 + uplevel { unset a_global } +} + +test "namespace exists" { + checkthat [namespace exists imaginary] == 0 + checkthat [namespace exists ::] + verify { namespace exists {} } + namespace eval boo { + checkthat [namespace exists ::] + checkthat [namespace exists {}] == 0 "empty doesn't exist when not in global" + } +} + +test "ns level" { + finalize { namespace abc } { + set ::lev 0 + namespace eval abc { + set ::lev [info level] + } + + checkthat [info level] == [- $::lev 1] + unset ::lev + } +} + + + +test "upvar in uplevel" { + proc set_to_3 vn { + upvar $vn x + set x 3 + } + + proc thingee {} { + uplevel { set_to_3 y } + } + + set y 4 + thingee + checkthat $y == 3 + finalize { proc thingee proc set_to_3 } +} + +test "upvar in uplevel 2" { + proc bind_to_x vn { + uplevel { + upvar $vn x + } + } + + proc thingee vn { + bind_to_x $vn + set x 3 + } + + set y 4 + thingee y + checkthat $y == 3 + + finalize { proc thingee proc bind_to_x } +} + +test "procs declared in namespace global" { + proc ::woot {} { return 4545 } + checkthat [::woot] == 4545 +} + +test "procs declared in foo namespace" { + namespace eval foo {} + proc foo::ret5 {} { return 5 } + + checkthat [foo::ret5] == 5 + checkthat [::foo::ret5] == 5 + + proc ::foo::ret6 {} { return 6 } + + checkthat [foo::ret6] == 6 + checkthat [::foo::ret6] == 6 + finalize { namespace foo } +} + +test "proc in namespace that doesn't exist fails" { + assertErr { + proc foo::bar {} { return 1 } + } + + assertErr { + proc ::foo::bar {} { return 1 } + } + + namespace eval foo {} + + assertNoErr { + proc foo::bar {} { return 1 } + } + + finalize { namespace foo } +} + +test "rename with ns qualifiers" { + namespace eval foo { + proc bar {} { return "omg!" } + } + + assertNoErr { ::foo::bar } + + rename ::foo::bar ::foo::baz + + assertErr { ::foo::bar } + checkthat [::foo::baz] eq "omg!" + + rename ::foo::baz whatnot + assertErr { ::foo::baz } + + checkthat [whatnot] eq "omg!" + + finalize { namespace foo proc whatnot } +} + +test "uplevel in ns" { + set g 0 + namespace eval foo { + uplevel { set g [namespace current] } + } + + checkthat $g eq {::} +} + +test "globally qualified proc in ns" { + namespace eval foo { + proc ::blah {} { return 4 } + } + + assertErr { ::foo::blah } + assertNoErr { ::blah; blah } + + assertNoErr { + namespace eval foo { + rename ::blah {} + } + } + assertErr { ::blah } + finalize { ns foo } +} + +test "list eval" { + checkthat [eval [list * 3 5]] == 15 +} + +test "odd procs" { + set one [+ 1 0] + proc $one {} { return ONE } + checkthat [eval $one] eq ONE + + set ffff [+ 55 0.55] + proc $ffff {} { return FFFF } + checkthat [eval $ffff] eq FFFF + finalize { proc 1 proc 55.55 } +} + +run_tests diff --git a/example.tcl b/example.tcl --- a/example.tcl +++ b/example.tcl @@ -7,16 +7,15 @@ } proc memfib x { - set loc {1 1} - set ctr 2 - while { <= $ctr $x } { - set v1 [lindex $loc [- $ctr 1]] - set v2 [lindex $loc [- $ctr 2]] + set ::loc(0) 1 + set ::loc(1) 1 + for {set ctr 2} { <= $ctr $x } {incr ctr} { + set v1 "$::loc([- $ctr 1])" + set v2 "$::loc([- $ctr 2])" set {the sum} [+ $v1 $v2] - set loc "$loc ${the sum}" - incr ctr + set ::loc($ctr) ${the sum} } - return [lindex $loc $x] + return $::loc($x) } set fcount 21 @@ -27,15 +26,6 @@ } puts "\nDone." -proc foreach {vname lst what} { - set i 0 - while {< $i [llength $lst]} { - uplevel "set $vname {[lindex $lst $i]}" - uplevel $what - incr i - } -} - proc say_i_havent_been_to { args } { foreach name $args { puts "I've never been to $name." @@ -44,3 +34,18 @@ say_i_havent_been_to Spain China Russia Argentina "North Dakota" +proc is v { + return $v +} + +foreach num {0 1 2 3 4 5 6 7 8 9} { + set type [switch -- $num { + 1 - 9 {is odd} + 2 - 3 - 5 - 7 {is prime} + 0 - 4 - 6 - 8 {is even} + default {is unknown} + }] + puts "$num is $type" +} + +puts [expr { sin(4) + 44.5 + rand()}] diff --git a/hiccup.cabal b/hiccup.cabal --- a/hiccup.cabal +++ b/hiccup.cabal @@ -1,17 +1,25 @@ Name: hiccup -Version: 0.35 -Description: Interpreter for a subset of tcl +Version: 0.40 +Description: Interpreter for a subset of tcl License: GPL License-file: LICENSE Author: Kyle Consalus Stability: experimental -Homepage: http://code.google.com/p/hiccup/ +Homepage: http://hiccup.googlecode.com/ Category: Compilers/Interpreters -Synopsis: Relatively efficient Tcl interpreter with support for basic operations -Maintainer: consalus+hiccup@google.com -Build-Depends: base, HUnit, mtl, haskell98, readline -extra-source-files: Hiccup.hs TclObj.hs BSParse.hs README example.tcl atests.tcl include.tcl +Synopsis: Relatively efficient Tcl interpreter with support for basic operations +Maintainer: consalus+hiccup@gmail.com +Build-Depends: base, HUnit, time, mtl, haskell98, readline, parsec, bytestring, containers, random +Build-Type: Simple +data-files: README +extra-source-files: example.tcl atests.tcl include.tcl Executable: hiccup +Other-Modules: Hiccup, TclObj, VarName, Common, Util, Core, RToken, BSParse, ExprParse, EventMgr, ProcArgs, TclLib, + TclLib.IOProcs, TclLib.StringProcs, TclLib.ListProcs, TclLib.ArrayProcs, TclLib.NSProcs, TclChan, + TclLib.ControlProcs, TclLib.UtilProcs, TclLib.MathProcs Main-is: Main.hs -ghc-options: -O2 -fglasgow-exts -fbang-patterns -funbox-strict-fields -funfolding-use-threshold=16 -fvia-c +ghc-options: -O2 -funbox-strict-fields -funfolding-use-threshold=16 -fvia-c -optc-O3 -W +ghc-prof-options: -auto-all -prof +Extensions: BangPatterns + diff --git a/include.tcl b/include.tcl --- a/include.tcl +++ b/include.tcl @@ -1,13 +1,32 @@ -proc foreach {vname lst what} { - set i 0 - while {< $i [llength $lst]} { - uplevel "set $vname {[lindex $lst $i]}" - uplevel $what - incr i + +proc apply { fun args } { + set len [llength $fun] + if { [|| [< $len 2] [> $len 3]] } { + error "can't interpret \"$fun\" as anonymous funtion" } + + lassign $fun argList body ns } proc decr v { upvar $v loc incr loc -1 } + +proc range {a b {step 1}} { + set res [list] + for {set i $a} { <= $i $b } { incr i $step } { + lappend res $i + } + return $res +} + +proc sum lst { + set res 0 + foreach i $lst { + incr res $i + } + return $res +} + +