hiccup 0.35 → 0.40
raw patch · 26 files changed
+3882/−880 lines, 26 filesdep +bytestringdep +containersdep +parsec
Dependencies added: bytestring, containers, parsec, random, time
Files
- BSParse.hs +323/−143
- Common.hs +733/−0
- Core.hs +90/−0
- EventMgr.hs +31/−0
- ExprParse.hs +267/−0
- Hiccup.hs +112/−451
- Main.hs +3/−3
- ProcArgs.hs +46/−0
- RToken.hs +110/−0
- TclChan.hs +26/−0
- TclLib.hs +14/−0
- TclLib/ArrayProcs.hs +87/−0
- TclLib/ControlProcs.hs +95/−0
- TclLib/IOProcs.hs +116/−0
- TclLib/ListProcs.hs +112/−0
- TclLib/MathProcs.hs +213/−0
- TclLib/NSProcs.hs +80/−0
- TclLib/StringProcs.hs +99/−0
- TclLib/UtilProcs.hs +74/−0
- TclObj.hs +132/−49
- Util.hs +115/−0
- VarName.hs +194/−0
- atests.tcl +747/−203
- example.tcl +22/−17
- hiccup.cabal +16/−8
- include.tcl +25/−6
BSParse.hs view
@@ -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 # --
+ Common.hs view
@@ -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 # --
+ Core.hs view
@@ -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 []+
+ EventMgr.hs view
@@ -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)
+ ExprParse.hs view
@@ -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
Hiccup.hs view
@@ -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 []
Main.hs view
@@ -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 ()
+ ProcArgs.hs view
@@ -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
+ RToken.hs view
@@ -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
+ TclChan.hs view
@@ -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 )
+ TclLib.hs view
@@ -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 ]
+ TclLib/ArrayProcs.hs view
@@ -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"
+ TclLib/ControlProcs.hs view
@@ -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"
+ TclLib/IOProcs.hs view
@@ -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+
+ TclLib/ListProcs.hs view
@@ -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+
+ TclLib/MathProcs.hs view
@@ -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 # --
+ TclLib/NSProcs.hs view
@@ -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"
+ TclLib/StringProcs.hs view
@@ -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)
+ TclLib/UtilProcs.hs view
@@ -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
TclObj.hs view
@@ -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,
+ Util.hs view
@@ -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)
+ VarName.hs view
@@ -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)
atests.tcl view
@@ -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
example.tcl view
@@ -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()}]
hiccup.cabal view
@@ -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+
include.tcl view
@@ -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+}++