hiccup 0.3 → 0.35
raw patch · 8 files changed
+899/−166 lines, 8 filesdep +readline
Dependencies added: readline
Files
- BSParse.hs +41/−11
- Hiccup.hs +311/−116
- Main.hs +13/−14
- TclObj.hs +64/−15
- atests.tcl +440/−0
- example.tcl +8/−5
- hiccup.cabal +9/−5
- include.tcl +13/−0
BSParse.hs view
@@ -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 # --
Hiccup.hs view
@@ -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 # --
Main.hs view
@@ -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
TclObj.hs view
@@ -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 # --
+ atests.tcl view
@@ -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."
example.tcl view
@@ -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"
hiccup.cabal view
@@ -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
+ include.tcl view
@@ -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+}