diff --git a/BSParse.hs b/BSParse.hs --- a/BSParse.hs +++ b/BSParse.hs @@ -1,9 +1,12 @@ {-# OPTIONS_GHC -fbang-patterns #-} -module BSParse (parseArgs,runParse,wrapInterp,TclWord(..),dropWhite) where +module BSParse ( runParse, wrapInterp, TclWord(..), dropWhite + ,bsParseTests + ) where + import qualified Data.ByteString.Char8 as B import Control.Monad -import Data.Char +import Data.Ix import Test.HUnit -- IGNORE type Result = Maybe ([[TclWord]], B.ByteString) @@ -37,14 +40,23 @@ then dorestfrom loc locval else let (pre,aft) = B.splitAt loc str in let res = case locval of - '$' -> do (s, rest) <- (brackVar `orElse` getvar) (B.tail aft) - return (pre, s, rest) + '$' -> 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" 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 + | 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 @@ -68,20 +80,23 @@ parseSub s = do guard (B.head s == '[') (p,r) <- parseArgs (B.tail s) loc <- B.elemIndex ']' r - let (pre,aft) = B.splitAt loc r + let (_,aft) = B.splitAt loc r return (Subcommand p, B.tail aft) eatcomment = return . (,) [] . B.tail . B.dropWhile (/= '\n') dropWhite = B.dropWhile (\x -> x == ' ' || x == '\t') +{- 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 == '_') + (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 + where (w,n) = B.span (\x -> wordChar x || (x `B.elem` (B.pack "$+.-*()=/:^%!&<>"))) s 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 @@ -181,6 +196,8 @@ (bp "you have $", mkwd "dollars", bp "") ?=? "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 ) ", "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!", @@ -213,18 +230,31 @@ "Fail nested" ~: Nothing ~=? nested (bp " { { }") ] +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"], "") + ] + where (?=>) str (res,r) = Just (res, bp r) ~=? parseArgs (bp str) + nosub s = mkNoSub (bp s) + runParseTests = TestList [ "one token" ~: ([[mkwd "exit"]],"") ?=? "exit", - "empty" ~: ([[]],"") ?=? " " + "empty" ~: ([[]],"") ?=? " ", + "empty2" ~: ([[]],"") ?=? "", +-- "a b " ~: ([[mkwd "a", mkwd "b"]],"") ?=? "a b ", + "arr 1" ~: ([[mkwd "set",mkwd "buggy(4)", mkwd "11"]], "") ?=? "set buggy(4) 11" ] where badword str = Nothing ~=? runParse (bp str) (?=?) (res,r) str = Just (res, bp r) ~=? runParse (bp str) -tests = TestList [ nestedTests, testEscaped, brackVarTests, +bsParseTests = TestList [ nestedTests, testEscaped, brackVarTests, parseStrTests, getInterpTests, getWordTests, wrapInterpTests, - runParseTests ] + parseArgsTests, runParseTests ] -runUnit = runTestTT tests +runUnit = runTestTT bsParseTests -- # ENDTESTS # -- diff --git a/Hiccup.hs b/Hiccup.hs --- a/Hiccup.hs +++ b/Hiccup.hs @@ -1,18 +1,20 @@ -module Hiccup where +module Hiccup (runTcl, 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 System.Environment import Data.Maybe import qualified Data.ByteString.Char8 as B -import BSParse +import BSParse (TclWord(..), wrapInterp) import qualified TclObj as T +import Test.HUnit -- IGNORE type BString = B.ByteString @@ -23,23 +25,38 @@ strMsg s = EDie s data TclEnv = TclEnv { vars :: VarMap, procs :: ProcMap, upMap :: Map.Map BString (Int,BString) } -type TclM = ErrorT Err (StateT [TclEnv] IO) +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 -procMap :: ProcMap -procMap = Map.fromList . map (B.pack *** id) $ - [("proc",procProc),("set",procSet),("upvar",procUpVar),("puts",procPuts),("gets",procGets), - ("uplevel", procUpLevel),("if",procIf),("while",procWhile),("eval", procEval),("exit",procExit), - ("list",procList),("lindex",procLindex),("llength",procLlength),("return",procReturn), - ("break",procRetv EBreak),("catch",procCatch),("continue",procRetv EContinue),("eq",procEq),("ne",procNe), - ("==",procEql), - ("string", procString), ("append", procAppend), ("info", procInfo), ("global", procGlobal), ("source", procSource), ("incr", procIncr)] - ++ map (id *** procMath) [("+",(+)), ("*",(*)), ("-",(-)), ("/",div), ("<", toI (<)),("<=",toI (<=)),("!=",toI (/=))] +coreProcs, baseProcs, mathProcs :: ProcMap +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)] + +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)] + + +mathProcs = Map.fromList . map (B.pack *** procMath) $ + [("+",(+)), ("*",(*)), ("-",(-)), + ("/",div), ("<", toI (<)),("<=",toI (<=)),("!=",toI (/=))] + io :: IO a -> TclM a io = liftIO @@ -47,29 +64,38 @@ toI n a b = if n a b then 1 else 0 baseEnv = TclEnv { vars = Map.empty, procs = procMap, upMap = Map.empty } + where procMap = Map.unions [coreProcs, baseProcs, mathProcs] -data Interpreter = Interpreter (IORef [TclEnv]) +data TclState = TclState { tclChans :: IORef ChanMap, tclStack :: [TclEnv] } + +data Interpreter = Interpreter (IORef TclState) + mkInterp :: IO Interpreter -mkInterp = newIORef [baseEnv] >>= return . Interpreter +mkInterp = do chans <- newIORef baseChans + st <- newIORef (TclState chans [baseEnv]) + return (Interpreter st) -runInterp :: Interpreter -> BString -> IO (Either BString BString) -runInterp (Interpreter i) s = do +baseChans = Map.fromList (map (\x -> (T.chanName x, x)) T.tclStdChans ) + +runInterp :: BString -> Interpreter -> IO (Either BString BString) +runInterp s = runInterp' (doTcl s) + +runInterp' t (Interpreter i) = do bEnv <- readIORef i - (r,i') <- runStateT (runErrorT ((doTcl s))) bEnv + (r,i') <- runStateT (runErrorT (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" + 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) + fixErr (Left x) = Left (perr x) fixErr (Right v) = Right (T.asBStr v) -runTcl v = mkInterp >>= (`runInterp` v) +runTcl v = mkInterp >>= runInterp v ret = return T.empty -doTcl :: BString -> ErrorT Err (StateT [TclEnv] IO) RetVal doTcl s = runCmds =<< getParsed s runCmds = liftM last . mapM runCommand @@ -85,100 +111,163 @@ p <- getParsed str case p of [x] -> runCommand x >>= return . T.asBool - _ -> tclErr "Too many statements in conditional" + _ -> tclErr "Too many statements in conditional" -trim :: T.TclObj -> BString -trim = B.reverse . dropWhite . B.reverse . dropWhite . T.asBStr +putStack s = modify (\v -> v { tclStack = s }) +modStack f = getStack >>= putStack . f withScope :: TclM RetVal -> TclM RetVal withScope f = do - (o:old) <- get - put $ (baseEnv { procs = procs o }) : o : old - ret <- f - get >>= put . tail - return ret + (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 <- liftM head get + (env:es) <- getStack case upped str env of Just (i,s) -> uplevel i (set s v) - Nothing -> do es <- liftM tail get - put ((env { vars = Map.insert str v (vars env) }):es) + Nothing -> putStack ((env { vars = Map.insert str v (vars env) }):es) upped s e = Map.lookup s (upMap e) -getProc str = get >>= return . Map.lookup str . procs . head -regProc name pr = modify (\(x:xs) -> (x { procs = Map.insert name pr (procs x) }):xs) >> ret +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,_))) = return $ T.mkTclBStrP s (Just p) -evalw (NoSub s Nothing) = return $ T.mkTclBStrP s Nothing -evalw (Subcommand c) = runCommand c - -ptrace = True -- IGNORE +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 - -- (e:_) <- get - -- when ptrace $ io (print (name,args) >> print (vars e)) -- IGNORE proc <- getProc (T.asBStr name) maybe (tclErr ("invalid command name: " ++ (T.asStr name))) ($! evArgs) proc procProc, procSet, procPuts, procIf, procWhile, procReturn, procUpLevel :: TclProc -procSet [s1,s2] = set (T.asBStr s1) s2 >> return s2 -procSet [s1] = varGet (T.asBStr s1) -procSet _ = tclErr $ "set: Wrong arg count" +procSet args = case args of + [s1,s2] -> set (T.asBStr s1) s2 >> return s2 + [s1] -> varGet (T.asBStr s1) + _ -> argErr "set" -procPuts s@(sh:st) = (io . mapM_ puts) (map T.asBStr txt) >> ret - where (puts,txt) = if sh .== "-nonewline" then (B.putStr,st) else (B.putStrLn,s) -procPuts x = tclErr $ "Bad args to puts: " ++ show x +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] -> getChan (T.asBStr ch) >>= checkReadable >>= io . B.hGetLine >>= treturn - [ch,vname] -> do h <- getChan (T.asBStr ch) >>= checkReadable + [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) - _ -> tclErr "gets: Wrong arg count" + _ -> argErr "gets" + where getReadable c = getChan (T.asBStr c) >>= checkReadable . T.chanHandle -checkReadable c = do r <- (io (hIsReadable c)) + +checkReadable c = do r <- io (hIsReadable c) if r then return c else (tclErr $ "channel wasn't opened for reading") -getChan :: BString -> TclM Handle -getChan c = maybe (tclErr ("cannot find channel named " ++ show c)) return (lookup c chans) - where chans :: [(BString,Handle)] - chans = zip (map B.pack ["stdin", "stdout", "stderr"]) [stdin, stdout, stderr] +checkWritable c = do r <- io (hIsWritable c) + if r then return c else (tclErr $ "channel wasn't opened for writing") -procEq [a,b] = return $ T.fromBool (a == b) -procNe [a,b] = return $ T.fromBool (a /= b) +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 op _ = tclErr "math: Wrong arg count" +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 "==" -tclEval s = procEval [T.mkTclBStr (B.pack s)] >>= return . T.asBStr - -procEval [s] = doTcl (T.asBStr s) +procEval [s] = doTcl s procEval x = tclErr $ "Bad eval args: " ++ show x -procSource [s] = io (B.readFile (T.asStr s)) >>= doTcl +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" -procExit [] = io (exitWith ExitSuccess) +procClose args = case args of + [ch] -> do h <- getChan (T.asBStr ch) + removeChan h + io (hClose (T.chanHandle h)) + ret + _ -> argErr "close" + -procCatch [s] = (doTcl (T.asBStr s) >> procReturn [T.tclFalse]) `catchError` (return . catchRes) - where catchRes (EDie s) = T.tclTrue +procSource args = case args of + [s] -> io (B.readFile (T.asStr s)) >>= doTcl + _ -> argErr "source" + +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" + +procCatch args = case args of + [s] -> (doTcl s >> procReturn [T.tclFalse]) `catchError` (return . catchRes) + _ -> argErr "catch" + where catchRes (EDie _) = T.tclTrue catchRes _ = T.tclFalse retmod f = \v -> treturn (f `onObj` v) @@ -187,7 +276,7 @@ procString :: TclProc procString (f:s:args) - | f .== "trim" = treturn (trim s) + | 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) @@ -196,37 +285,44 @@ 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 -procInfo [x] = if x .== "commands" - then get >>= procList . toObs . Map.keys . procs . head - else if x .== "vars" - then get >>= procList . toObs . Map.keys . vars . head - else tclErr $ "Unknown info command: " ++ show x +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 (v:vx) = do val <- varGet (T.asBStr v) `catchError` \_ -> ret - procSet [v, oconcat (val:vx)] -oconcat :: [T.TclObj] -> T.TclObj -oconcat = T.mkTclBStr . B.concat . map T.asBStr +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 = treturn . B.concat . intersperse (B.singleton ' ') . map (escape . 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 [l] = return l -procLindex [l,i] = do items <- liftM (map to_s . head) (getParsed l) +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 p) = s +to_s (NoSub s _) = s to_s x = error $ "to_s doesn't understand: " ++ show x -procIncr [vname] = incr vname 1 +procIncr [vname] = incr vname 1 procIncr [vname,val] = T.asInt val >>= incr vname -procIncr _ = tclErr $ "Wrong number of args to incr" +procIncr _ = argErr "incr" incr n i = do v <- varGet bsname intval <- T.asInt v let res = (T.mkTclInt (intval + i)) @@ -234,19 +330,20 @@ return res where bsname = T.asBStr n -procLlength [lst] - | B.null `onObj` lst = return T.tclFalse - | otherwise = liftM (T.mkTclInt . length . head) (getParsed lst) -procLlength x = tclErr $ "Bad args to llength: " ++ show x +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" procIf (cond:yes:rest) = do condVal <- doCond cond - if condVal then doTcl (T.asBStr yes) + if condVal then doTcl yes else case rest of - [s,blk] -> if s .== "else" then doTcl (T.asBStr blk) else tclErr "Invalid If" + [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 x = tclErr "Not enough arguments to If." +procIf _ = argErr "if" procWhile [cond,body] = loop `catchError` herr where herr EBreak = ret @@ -257,53 +354,101 @@ pbody <- getParsed body if condVal then runCmds pbody >> loop else ret -procReturn [s] = throwError (ERet s) +procWhile _ = argErr "while" + +procReturn args = case args of + [s] -> throwError (ERet s) + [] -> throwError (ERet T.empty) + _ -> argErr "return" + procRetv c [] = throwError c +procRetv c _ = argErr $ st c + where st EContinue = "continue" + st EBreak = "break" + st _ = "??" + procError [s] = tclErr (T.asStr s) +procError _ = argErr "error" -procUpLevel [p] = uplevel 1 (procEval [p]) -procUpLevel (si:p) = T.asInt si >>= \i -> uplevel i (procEval p) +procUpLevel args = case args of + [p] -> uplevel 1 (procEval [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) get - put new + (curr,new) <- liftM (splitAt i) getStack + putStack new res <- p - get >>= put . (curr ++) + modStack (curr ++) return res -procUpVar [d,s] = upvar 1 d s -procUpVar [si,d,s] = T.asInt si >>= \i -> upvar i d s +procUpVar args = case args of + [d,s] -> upvar 1 d s + [si,d,s] -> T.asInt si >>= \i -> upvar i d s + _ -> argErr "upvar" procGlobal lst@(_:_) = mapM_ inner lst >> ret - where inner g = do lst <- get + where inner g = do lst <- getStack let len = length lst - 1 upvar len g g +procGlobal _ = argErr "global" -upvar n d s = do (e:es) <- get - put ((e { upMap = Map.insert (T.asBStr s) (n, (T.asBStr d)) (upMap e) }):es) +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 <- case parseArgs (T.asBStr args) of - Nothing -> if trim args .== "" then return [] else tclErr $ "Parse failed: " ++ show (T.asBStr args) - Just (r,_) -> return $ map to_s r + 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") + -procRunner :: [BString] -> [[TclWord]] -> [T.TclObj] -> TclM RetVal -procRunner pl body args = withScope $ do mapM_ (uncurry set) (zip pl args) - when ((not . null) pl && (last pl .== "args")) $ do - val <- procList (drop ((length pl) - 1) args) - set (B.pack "args") val - (runCmds body) `catchError` herr - where herr (ERet s) = return s - herr (EDie s) = tclErr s +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 + 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 <- liftM head get +varGet name = do env <- getFrame case upped name env of Nothing -> maybe (tclErr ("can't read \"$" ++ T.asStr name ++ "\": no such variable")) return @@ -321,3 +466,53 @@ 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 + +-- # ENDTESTS # -- diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -4,22 +4,21 @@ import System import Hiccup import Control.Monad +import System.Console.Readline import qualified Data.ByteString.Char8 as B main = do args <- getArgs hSetBuffering stdout NoBuffering case args of - [] -> mkInterp >>= runRepl - [f] -> B.readFile f >>= runTcl >>= foll - where foll (Left e) = putStrLn $ "error: "++ B.unpack e - foll _ = return () - runRepl i = do putStr "hiccup> " - eof <- isEOF - when (not eof) $ do - ln <- B.getLine - unless (B.null ln) $ do - v <- runInterp i ln - case v of - Left e -> putStrLn $ "error: " ++ B.unpack e - Right o -> unless (B.null o) (B.putStrLn o) - runRepl i + [] -> 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 + runRepl i = do mline <- readline "hiccup> " + case mline of + Nothing -> return () + Just "" -> runRepl i + Just ln -> do addHistory ln + v <- runInterp (B.pack ln) i + v `unlessErr` (\o -> unless (B.null o) (B.putStrLn o)) + runRepl i diff --git a/TclObj.hs b/TclObj.hs --- a/TclObj.hs +++ b/TclObj.hs @@ -1,36 +1,51 @@ module TclObj where -import qualified BSParse as P +import Test.HUnit -- IGNORE +import qualified BSParse as P import qualified Data.ByteString.Char8 as BS +import System.IO +import Data.Unique -data TclObj = TclInt !Int BS.ByteString | TclBStr !BS.ByteString (Maybe Int) (Maybe [[P.TclWord]]) deriving (Show,Eq) +data TclChan = TclChan { chanHandle :: Handle, chanName :: BS.ByteString } 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) + + +data TclObj = TclInt !Int BS.ByteString | + TclBStr !BS.ByteString (Maybe Int) (Either String [[P.TclWord]]) deriving (Show,Eq) + mkTclStr s = mkTclBStr (BS.pack s) mkTclBStr s = mkTclBStrP s (doParse s) -isSpace x = x == ' ' || x == '\t' - mkTclBStrP s p = TclBStr s mayint p - where mayint = case BS.readInt (BS.dropWhile isSpace s) of + where mayint = case BS.readInt (P.dropWhite s) of Nothing -> Nothing Just (i,_) -> Just i - - doParse s = case P.runParse s of - Nothing -> Nothing - Just (r,_) -> Just r + 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)) -empty = TclBStr BS.empty Nothing Nothing +empty = TclBStr BS.empty Nothing (Left "bad parse") tclTrue = mkTclInt 1 tclFalse = mkTclInt 0 fromBool b = if b then tclTrue else tclFalse +trim :: TclObj -> BS.ByteString +trim = BS.reverse . P.dropWhite . BS.reverse . P.dropWhite . asBStr + class ITObj o where asStr :: o -> String asBool :: o -> Bool @@ -45,27 +60,61 @@ asBStr = id asParsed s = case P.runParse s of Nothing -> fail $ "parse failed: " ++ show s - Just (r,_) -> return r + Just (r,rs) -> if BS.null rs then return r + else fail $ "incomplete parse: " ++ show rs instance ITObj TclObj where - asStr (TclInt i b) = BS.unpack b + asStr (TclInt _ b) = BS.unpack b asStr (TclBStr bs _ _) = asStr bs asBool (TclInt i _) = i /= 0 asBool (TclBStr bs _ _) = asBool bs asInt (TclInt i _) = return i - asInt (TclBStr v (Just i) _) = return i + asInt (TclBStr _ (Just i) _) = return i asInt (TclBStr v Nothing _) = fail $ "Bad int: " ++ show v asBStr (TclBStr s _ _) = s asBStr (TclInt _ b) = b - asParsed (TclBStr _ _ Nothing) = fail "Parse failed" - asParsed (TclBStr _ v (Just r)) = return r + asParsed (TclBStr _ _ (Left f)) = fail f + asParsed (TclBStr _ _ (Right r)) = return r asParsed (TclInt _ _) = fail "Can't parse an int value" trueValues = map BS.pack ["1", "true", "yes", "on"] +-- # TESTS # -- +testTrim = TestList [ + trim (int 10) ?=> "10", + trim (str "10") ?=> "10", + trim (str " 10 ") ?=> "10", + trim (str "\t10\t") ?=> "10", + trim (str " \t ") ?=> "", + trim (str " 10 ") ?=> "10" + ] + where (?=>) s e = s ~=? (BS.pack e) + int i = mkTclInt i + str s = mkTclStr s + +testAsBool = TestList [ + tclTrue `is` True, + tclFalse `is` False, + (fromBool True) `is` True, + (int 1) `is` True, + (int 0) `is` False, + (int 2) `is` True, + (int (-1)) `is` True, + (str "true") `is` True, + (str "yes") `is` True, + (str "on") `is` True, + (fromBool False) `is` False + ] + where is a b = asBool a ~=? b + int i = mkTclInt i + str s = mkTclStr s + +tclObjTests = TestList [ testTrim, testAsBool ] + +-- # ENDTESTS # -- diff --git a/atests.tcl b/atests.tcl new file mode 100644 --- /dev/null +++ b/atests.tcl @@ -0,0 +1,440 @@ +set assertcount 0 +set current_test "Test" + +proc die s { + puts $s + exit +} + +source include.tcl + +proc assertEq {a b} { + global current_test + if {== $a $b} { + assertPass + } else { + die "$current_test failed: $a != $b" + } +} + + +proc checkthat { var op r } { + set res [eval "$op {$var} {$r}"] + if { == $res 1 } { + assertPass + } else { + assertFail "\"$var $op $r\" was not true" + } +} + +proc assertPass {} { + global assertcount + puts -nonewline "." + incr assertcount +} + +proc assertFail why { + global current_test + die "'$current_test' failed: $why" +} + +proc assertStrEq {a b} { + global current_test + if {eq $a $b} { + assertPass + } else { + assertFail "\"$a\" != \"$b\"" + } +} + +proc assertNoErr code { + set ret [catch $code] + if { == $ret 0 } { + assertPass + } else { + assertFail "code failed: $code" + } +} + +proc assertErr code { + set ret [catch "eval {$code}"] + if { == $ret 1 } { + assertPass + } else { + assertFail "code should've failed: $code" + } +} + +proc announce { } { + puts "Running tests" +} + +proc assert code { + set ret [uplevel $code] + if { == $ret 1 } { assertPass } else { assertFail "Failed: $code" } +} + +announce + +assertEq [eval {[* 4 4]}] 16 + + +proc uptest {var v} { + upvar $var loc + set loc $v +} + +set x 4 +uptest x 3 +assertEq $x 3 + +proc uptest2 {var2 v} { + proc inner {a b} { + upvar 2 $b whee + set whee $a + } + upvar $var2 lark + inner $v $var2 + incr lark +} + +set y 99 +uptest2 y 3 +assertEq $y 4 + +proc test {name body} { + global current_test + set current_test $name + eval $body +} + +test "unevaluated blocks aren't parsed" { + if {== 3 4} { + "This should be no problem. $woo_etcetera.; + " + } else { + assertPass + } +} + +test "incr test" { + set count 0 + + incr count + incr count + incr count + + assertEq $count 3 + + incr count 2 + + assertEq 5 $count + + incr count -2 + + assertEq 3 $count + + decr count + decr count + decr count + + assertEq $count 0 +} + +test "list test" { + set bean [list 1 2 3 4 5 {6 7 8}] + + assertEq [llength $bean] 6 + assertEq [lindex $bean 3] 4 + assertEq [lindex $bean 5] {6 7 8} + + assertEq [lindex 4] 4 + assertStrEq [lindex $bean 8] "" +} + +test "test if, elseif, else" { + if { eq "one" "two" } { + die "Should not have hit this." + } elseif { == 1 1 } { + assertPass + } else { + die "Should not have hit this." + } +} + +test "test args parameter" { + set total 0 + proc argstest {tot args} { + upvar $tot total + set i 0 + while {< $i [llength $args]} { + set total [+ [lindex $args $i] $total] + incr i + } + } + + assertEq 0 $total + argstest total 1 2 3 4 5 6 7 8 + assertEq 36 $total +} + +set sval 0 +set sval2 1 +while {<= $sval 10} { + incr sval + if {<= 8 $sval} { + break + } + if {<= 4 $sval} { + continue + } + incr sval2 +} + +assertEq 8 $sval +assertEq 4 $sval2 + + +assertEq 10 [+ 15 -5] # Check that negatives parse. + +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"] + + set fst [string index "whee" 1] + assertStrEq "h" $fst + + assertStrEq "wombat" [string tolower "WOMBAT"] + assertStrEq "CALCULUS" [string toupper "calculus"] + assertStrEq "hello" [string trim " hello "] +} + + +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] +} + +assertEq 15 $result + +set fer "old" +foreach feitem {"a b" "c d"} { + set fer $feitem +} + +checkthat $fer eq "c d" +# $fer + +test "join and foreach" { + set misc { 1 2 3 4 5 6 } + proc join { lsx mid } { + set res "" + set first_time 1 + foreach ind $lsx { + if { [== $first_time 1] } { + set res $ind + set first_time 0 + } else { + set res "$res$mid$ind" + } + } + return $res + } + + checkthat [join $misc +] eq "1+2+3+4+5+6" +} + + +proc expr { a1 args } { + if { != [llength $args] 0 } { + eval "[lindex $args 0] $a1 [lindex $args 1]" + } else { + eval "expr $a1" + } +} + +assertEq 8 [expr 4 + 4] +assertEq 8 [expr {4 + 4}] + +test "set returns correctly" { + set babytime 444 + checkthat [set babytime] == 444 + assertEq 512 [set babytime 512] + assertEq 512 $babytime +} + +assertErr { error "oh noes" } + +assertEq 1 [catch { puts "$thisdoesntexist" }] +assertEq 0 [catch { [+ 1 1] }] + +set whagganog "" +set otherthing "" + +test "global test" { + upvar otherthing ot + proc testglobal {bah} { + proc modother { m } { + global whagganog otherthing + set otherthing $whagganog$m + } + + global whagganog + append whagganog $bah + modother $bah + return $whagganog + } + + checkthat [testglobal 1] == 1 + checkthat $ot == 11 + checkthat [testglobal 2] == 12 + checkthat $ot == 122 +} + + + +test "parsing corners" { + set { shh.. ?} 425 + assertStrEq " 425 " " ${ shh.. ?} " + + assertStrEq "whee $ stuff" "whee \$ stuff" + + assertStrEq "whee \$ stuff" "whee \$ stuff" + assertStrEq "whee \$\" stuff" "whee $\" stuff" + assertNoErr { + if { == 3 3 } { } else { die "bad" } + } +} + + +proc not v { + if { == 1 $v } { return false } else { return true } +} + +test "equality of strings and nums" { + set x 10 + set y " 10 " + assert { == $x $y } + assert { ne $x $y } + assert { eq 33 33 } + assert { == "cobra" "cobra" } + checkthat " 1 " ne 1 + checkthat " 1 " == 1 + assert { eq "cobra" "cobra" } + assert { == 4 4 } +} + +test "early return" { + set moo 4 + proc yay {} { + upvar moo moo2 + return + set moo2 5 + } + + yay + checkthat $moo == 4 +} + +test "arg count check" { + proc blah {a b} { + + $a $b + } + + + assertErr { blah 4 } + assertErr { blah 4 5 6 } + assertNoErr { blah 4 5 } + + proc blah2 {a b args} { + + $a [+ $b [llength $args]] + } + + assertErr { blah2 1 } + assertErr { blah2 } + checkthat [blah2 1 2 3] == 4 + checkthat [blah2 1 2] == 3 + checkthat [blah2 1 2 1 1 1] == 6 +} + +test "bad continue/break test" { + proc whee {} { + break + } + + assertErr { whee } + + proc whee2 {} { + continue + } + + assertErr { whee2 } + + proc whee3 {} { + return + } + + assertNoErr { whee3 } + +} + +test "incomplete parse" { + assertErr { set bean 4 " } + assertNoErr { set bean 4() } + assertErr { " } +} + +test "default proc args" { + + proc plus { t { y 1 } } { + [+ $t $y] + } + + proc plus2 { x {y 1} } { + [+ $x $y] + } + + proc plus3 { {a 5} {b 1} } { + [+ $a $b] + } + + proc withargs { i {j 4} args } { + [+ [llength $args] [+ $i $j]] + } + + checkthat [plus 3 3] == 6 + checkthat [plus2 3 3] == 6 + checkthat [plus3 3 3] == 6 + checkthat [plus 3] == 4 + checkthat [plus2 3] == 4 + checkthat [plus3 3] == 4 + + checkthat [plus3] == 6 + + 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 +} + +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." diff --git a/example.tcl b/example.tcl --- a/example.tcl +++ b/example.tcl @@ -1,9 +1,9 @@ # Here is an example of some stuff hiccup can do. # I think it's neat. -proc decr v { +proc decr { v { i -1 } } { upvar $v loc - incr loc -1 + incr loc $i } proc memfib x { @@ -36,8 +36,11 @@ } } - -foreach name {Spain China Russia Argentina "North Dakota"} { - puts "I've never been to $name." +proc say_i_havent_been_to { args } { + foreach name $args { + puts "I've never been to $name." + } } + +say_i_havent_been_to Spain China Russia Argentina "North Dakota" diff --git a/hiccup.cabal b/hiccup.cabal --- a/hiccup.cabal +++ b/hiccup.cabal @@ -1,13 +1,17 @@ Name: hiccup -Version: 0.3 -Description: A simplistic interpreter for a subset of tcl +Version: 0.35 +Description: Interpreter for a subset of tcl License: GPL License-file: LICENSE Author: Kyle Consalus +Stability: experimental +Homepage: http://code.google.com/p/hiccup/ +Category: Compilers/Interpreters +Synopsis: Relatively efficient Tcl interpreter with support for basic operations Maintainer: consalus+hiccup@google.com -Build-Depends: base, HUnit, mtl, haskell98 -extra-source-files: Hiccup.hs TclObj.hs BSParse.hs README example.tcl +Build-Depends: base, HUnit, mtl, haskell98, readline +extra-source-files: Hiccup.hs TclObj.hs BSParse.hs README example.tcl atests.tcl include.tcl Executable: hiccup Main-is: Main.hs -ghc-options: -O2 -fglasgow-exts -fbang-patterns -funbox-strict-fields +ghc-options: -O2 -fglasgow-exts -fbang-patterns -funbox-strict-fields -funfolding-use-threshold=16 -fvia-c diff --git a/include.tcl b/include.tcl new file mode 100644 --- /dev/null +++ b/include.tcl @@ -0,0 +1,13 @@ +proc foreach {vname lst what} { + set i 0 + while {< $i [llength $lst]} { + uplevel "set $vname {[lindex $lst $i]}" + uplevel $what + incr i + } +} + +proc decr v { + upvar $v loc + incr loc -1 +}