diff --git a/BSParse.hs b/BSParse.hs --- a/BSParse.hs +++ b/BSParse.hs @@ -1,12 +1,15 @@ {-# OPTIONS_GHC -fbang-patterns #-} -module BSParse (parseArgs,runParse,getInterp,TclWord(..),dropWhite) where + +module BSParse (parseArgs,runParse,wrapInterp,TclWord(..),dropWhite) where import qualified Data.ByteString.Char8 as B import Control.Monad import Data.Char import Test.HUnit -- IGNORE -data TclWord = Word B.ByteString | Subcommand [TclWord] | NoSub B.ByteString deriving (Show,Eq) +type Result = Maybe ([[TclWord]], B.ByteString) +data TclWord = Word !B.ByteString | Subcommand [TclWord] | NoSub !B.ByteString Result deriving (Show,Eq) + dispatch str = do h <- safeHead str case h of '{' -> nested str @@ -14,36 +17,53 @@ '"' -> parseStr str _ -> getword str +mkNoSub s = NoSub s (runParse s) + parseArgs = multi (dispatch . dropWhite) + +runParse :: B.ByteString -> Result runParse = multi (mainparse . dropWhite) safeHead s = guard (not (B.null s)) >> return (B.head s) +wrapInterp str = case getInterp str of + Nothing -> Left $! escapeStr str + Just (pr,s,r) -> Right (escapeStr pr, s, r) getInterp str = do loc <- B.findIndex (\x -> x == '$' || x == '[') str let locval = B.index str loc - if escaped loc str - then do (p,v,r) <- getInterp (B.drop (loc+1) str) - return (B.append (B.take (loc-1) str) (B.cons locval p), v, r) + if escaped loc str + then dorestfrom loc locval else let (pre,aft) = B.splitAt loc str in - case B.index str loc of - '$' -> do (s, rest) <- getword aft - return (pre, s,rest) - '[' -> do (s, rest) <- parseSub aft - return (pre, s, rest) + let res = case locval of + '$' -> do (s, rest) <- (brackVar `orElse` getvar) (B.tail aft) + return (pre, s, rest) + '[' -> do (s, rest) <- parseSub aft + return (pre, s, 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) -mainparse str = do h <- safeHead str - case h of - ';' -> return ([], B.tail str) - '\n' -> return ([], B.tail str) - '#' -> eatcomment str - _ -> parseArgs str +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 + multi p s = do (w,r) <- p s - case multi p r of - Nothing -> return ([w],r) - Just (wx,r2) -> return $! (w:wx,r2) + 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) @@ -56,26 +76,43 @@ dropWhite = B.dropWhile (\x -> x == ' ' || x == '\t') wordChar ' ' = False -wordChar c = let ci = ord c in +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 `B.elem` (B.pack "+-*=/:^$%!^&<>")) + (ord '0' <= ci && ci <= ord '9') || (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 + +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 +brackVar x = do hv <- safeHead x + guard (hv == '{') + let (b,a) = B.span (/='}') (B.tail x) + safeHead a + return (Word b,(B.tail a)) + 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 (ueword (B.append nw w1), v) - else return (ueword w, B.tail r) + return (Word (B.append nw w1), v) + else return (Word w, B.tail r) where str = B.tail s - ueword = Word . strSub (B.pack "\\t", B.singleton '\t') . strSub (B.pack "\\n",B.singleton '\n') -strSub (from,to) s = B.concat $ reverse $ breakUp s nls - where nls = reverse $ B.findSubstrings from s - breakUp x [] = [x] - breakUp x (i:xs) = let (a,b) = B.splitAt i x in (B.drop (B.length from) b):to:breakUp a xs +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) + 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)) @@ -83,7 +120,7 @@ nested s = do ind <- match 0 0 let (w,r) = B.splitAt ind s - return (NoSub (B.tail w), (B.tail r)) + return (mkNoSub (B.tail w), (B.tail r)) where match !c !i | B.length s <= i = fail $ "Couldn't match bracket" ++ show s | otherwise = @@ -94,39 +131,100 @@ -- # TESTS # -- -testNested = "Fail nested" ~: Nothing ~=? nested (bp " { the end") -testNested2 = "Pass nested" ~: Just (NoSub (bp " { }"), B.empty) ~=? nested (bp "{ { }}") -testNested3 = "Fail nested" ~: Nothing ~=? nested (bp " { { }") - -testEscaped = (escaped 1 (B.pack "\\\"")) ~? "pre-slashed quote should be escaped" -testEscaped2 = TestCase $ assertBool "non-slashed quote not escaped" (not (escaped 1 (B.pack " \""))) -testEscaped3 = TestCase $ assertBool "pre-slashed quote should be escaped" (escaped 2 (B.pack " \\\"")) -testEscaped4 = TestCase $ assertBool "non-slashed quote not escaped" (not (escaped 2 (B.pack " \""))) +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 " \"")) + ] + where checkFalse str val = TestCase $ assertBool str (not val) bp = B.pack mklit = Word . bp mkwd = Word . bp -testParseStr = "Escaped works" ~: Just (mklit "Oh \"yeah\" baby.", B.empty) ~=? parseStr (bp "\"Oh \\\"yeah\\\" baby.\"") -testParseStrLeft = "Parse Str with leftover" ~: Just (mklit "Hey there.", bp " 44") ~=? parseStr (bp "\"Hey there.\" 44") -testGetInterp = "Escaped $ works" ~: Nothing ~=? getInterp (bp "a \\$variable") -testGetInterp2 = "unescaped $ works" ~: Just (bp "a ", mkwd "$variable", bp "") ~=? getInterp (bp "a $variable") -testGetInterp3 = "Escaped [" ~: Nothing ~=? getInterp (bp "a \\[sub] thing.") -testGetInterp4 = "Escaped []" ~: Nothing ~=? getInterp (bp "a \\[sub\\] thing.") -testGetInterp5 = "Escaped [] crazy" ~: - Just (bp "a ",Subcommand [mkwd "sub",mklit "quail [puts 1]"], bp " thing.") ~=? getInterp (bp "a [sub \"quail [puts 1]\"] thing.") -testGetInterp6 = "unescaped $ works" ~: Just (bp "a $", mkwd "$variable", bp "") ~=? getInterp (bp "a \\$$variable") +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?\"", + "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 } ", + "bad parse" ~: badParse "{ oh no", + "bad parse" ~: badParse "pancake" + ] + where (?=?) res str = Just res ~=? brackVar (bp str) + badParse str = Nothing ~=? brackVar (bp str) -nestedTests= TestList [testNested, testNested2, testNested3] +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" ~: + 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", + "Escaped [" ~: noInterp "a \\[sub] thing.", + "Trailing bang" ~: (bp "", mkwd "var", bp "!" ) ?=? "$var!", + "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", + "Escaped [] crazy" ~: + (bp "a ",Subcommand [mkwd "sub",mklit "quail [puts 1]"], bp " thing.") ?=? "a [sub \"quail [puts 1]\"] thing." + ] + where noInterp str = Nothing ~=? getInterp (bp str) + (?=?) res str = Just res ~=? getInterp (bp str) +wrapInterpTests = TestList [ + "simple escape" ~: "oh $ yeah" ?!= "oh \\$ yeah" + ] + where (?=?) res str = Right res ~=? wrapInterp (bp str) + (?!=) res str = Left (bp res) ~=? wrapInterp (bp str) -getInterpTests = TestList [ testGetInterp, testGetInterp2, testGetInterp3, testGetInterp4, testGetInterp5, testGetInterp6 ] +getWordTests = TestList [ + "Simple" ~: badword "", + "Simple2" ~: (mkwd "$whoa", bp "") ?=? "$whoa", + "Simple with bang" ~: (mkwd "whoa!", bp " ") ?=? "whoa! " + ] + where badword str = Nothing ~=? getword (bp str) + (?=?) res str = Just res ~=? getword(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 " { { }") + ] -tests = TestList [ nestedTests, testEscaped, testEscaped2, testEscaped3, testEscaped4, testParseStr, testParseStrLeft, - getInterpTests ] +runParseTests = TestList [ + "one token" ~: ([[mkwd "exit"]],"") ?=? "exit", + "empty" ~: ([[]],"") ?=? " " + ] + where badword str = Nothing ~=? runParse (bp str) + (?=?) (res,r) str = Just (res, bp r) ~=? runParse (bp str) +tests = TestList [ nestedTests, testEscaped, brackVarTests, + parseStrTests, getInterpTests, getWordTests, wrapInterpTests, + runParseTests ] + runUnit = runTestTT tests + -- # ENDTESTS # -- diff --git a/Hiccup.hs b/Hiccup.hs new file mode 100644 --- /dev/null +++ b/Hiccup.hs @@ -0,0 +1,323 @@ +module Hiccup where +import Control.Monad.State +import qualified Data.Map as Map +import Control.Arrow +import System.IO +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 qualified TclObj as T + +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 [TclEnv] IO) +type TclProc = [T.TclObj] -> TclM RetVal +type ProcMap = Map.Map BString TclProc +type VarMap = Map.Map BString T.TclObj + +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 (/=))] + +io :: IO a -> TclM a +io = liftIO + +toI :: (Int -> Int -> Bool) -> (Int -> Int -> Int) +toI n a b = if n a b then 1 else 0 + +baseEnv = TclEnv { vars = Map.empty, procs = procMap, upMap = Map.empty } + +data Interpreter = Interpreter (IORef [TclEnv]) +mkInterp :: IO Interpreter +mkInterp = newIORef [baseEnv] >>= return . Interpreter + +runInterp :: Interpreter -> BString -> IO (Either BString BString) +runInterp (Interpreter i) s = do + bEnv <- readIORef i + (r,i') <- runStateT (runErrorT ((doTcl s))) 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) + fixErr (Right v) = Right (T.asBStr 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 + +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" + +trim :: T.TclObj -> BString +trim = B.reverse . dropWhite . B.reverse . dropWhite . T.asBStr + +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 + +set :: BString -> T.TclObj -> TclM () +set str v = do when (B.null str) $ tclErr "Empty varname to set!" + env <- liftM head get + 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) + +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 + +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 + +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" + +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 + +procGets args = case args of + [ch] -> getChan (T.asBStr ch) >>= checkReadable >>= io . B.hGetLine >>= treturn + [ch,vname] -> do h <- getChan (T.asBStr ch) >>= checkReadable + 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" + +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] + +procEq [a,b] = return $ T.fromBool (a == b) +procNe [a,b] = return $ T.fromBool (a /= b) + +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" + +procEql [a,b] = case (T.asInt a, T.asInt b) of + (Just ia, Just ib) -> return $ T.fromBool (ia == ib) + _ -> procEq [a,b] + + +tclEval s = procEval [T.mkTclBStr (B.pack s)] >>= return . T.asBStr + +procEval [s] = doTcl (T.asBStr s) +procEval x = tclErr $ "Bad eval args: " ++ show x + +procSource [s] = io (B.readFile (T.asStr s)) >>= doTcl + +procExit [] = io (exitWith ExitSuccess) + +procCatch [s] = (doTcl (T.asBStr s) >> procReturn [T.tclFalse]) `catchError` (return . catchRes) + where catchRes (EDie s) = 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 (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 + +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 + +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 + +procList = treturn . B.concat . intersperse (B.singleton ' ') . map (escape . T.asBStr) + 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) + ind <- T.asInt i + if ind >= length items then ret else treturn (items !! ind) + +to_s (Word s) = s +to_s (NoSub s p) = s +to_s x = error $ "to_s doesn't understand: " ++ show x + +procIncr [vname] = incr vname 1 +procIncr [vname,val] = T.asInt val >>= incr vname +procIncr _ = tclErr $ "Wrong number of args to 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 + +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 + +procIf (cond:yes:rest) = do + condVal <- doCond cond + if condVal then doTcl (T.asBStr yes) + else case rest of + [s,blk] -> if s .== "else" then doTcl (T.asBStr 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." + +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 + +procReturn [s] = throwError (ERet s) +procRetv c [] = throwError c +procError [s] = tclErr (T.asStr s) + +procUpLevel [p] = uplevel 1 (procEval [p]) +procUpLevel (si:p) = T.asInt si >>= \i -> uplevel i (procEval p) + +uplevel i p = do + (curr,new) <- liftM (splitAt i) get + put new + res <- p + get >>= put . (curr ++) + return res + +procUpVar [d,s] = upvar 1 d s +procUpVar [si,d,s] = T.asInt si >>= \i -> upvar i d s + +procGlobal lst@(_:_) = mapM_ inner lst >> ret + where inner g = do lst <- get + let len = length lst - 1 + upvar len g g + +upvar n d s = do (e:es) <- get + put ((e { upMap = Map.insert (T.asBStr s) (n, (T.asBStr d)) (upMap e) }):es) + ret + +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 + 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) + + +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 + +varGet :: BString -> TclM RetVal +varGet name = do env <- liftM head get + 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)) diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,246 +1,25 @@ -import Control.Monad.State -import qualified Data.Map as Map -import Control.Arrow +module Main where + import System.IO -import Control.Monad.Error -import System.Exit -import Data.Char (toLower,toUpper) -import Data.List (intersperse) -import System.Environment -import Data.Maybe +import System +import Hiccup +import Control.Monad import qualified Data.ByteString.Char8 as B -import BSParse -type BString = B.ByteString - -data Err = ERet BString | EBreak | EContinue | EDie String deriving (Show,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 [TclEnv] IO) -type TclProc = [BString] -> TclM RetVal -type ProcMap = Map.Map BString TclProc -type VarMap = Map.Map BString BString - -type RetVal = BString -- 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), - ("string", procString), ("append", procAppend), ("info", procInfo)] - ++ map (id *** procMath) [("+",(+)), ("*",(*)), ("-",(-)), ("/",div), ("<", toI (<)),("<=",toI (<=)),("==",toI (==)),("!=",toI (/=))] - -io :: IO a -> TclM a -io = liftIO - -toI :: (Int -> Int -> Bool) -> (Int -> Int -> Int) -toI n a b = if n a b then 1 else 0 - -baseEnv = TclEnv { vars = Map.empty, procs = procMap, upMap = Map.empty } - main = do args <- getArgs hSetBuffering stdout NoBuffering case args of - [] -> run repl - [f] -> B.readFile f >>= run . doTcl - where run p = evalStateT (runErrorT (p `catchError` perr >> ret)) [baseEnv] >> return () - perr (EDie s) = io (hPutStrLn stderr s) >> ret - repl = do io (putStr "hiccup> ") - eof <- (io isEOF) - if eof then ret - else do ln <- procGets [] - if (not . B.null) ln then doTcl ln `catchError` perr >> repl else ret - -ret = return B.empty - -doTcl = runCmds . getParsed -runCmds = liftM last . mapM runCommand - -getParsed str = case runParse str of - Nothing -> error $ "parse error: " ++ (B.unpack str) - Just (v,r) -> filter (not . null) v - -doCond str = case getParsed str of - [x] -> runCommand x >>= return . isTrue - _ -> tclErr "Too many statements in conditional" - where isTrue = (/= B.pack "0") . trim - -trim = B.reverse . dropWhite . B.reverse . dropWhite - -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 - -set :: BString -> BString -> TclM () -set str v = do env <- liftM head get - 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) - -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 - -evalw :: TclWord -> TclM RetVal -evalw (Word s) = interp s -evalw (NoSub s) = return s -evalw (Subcommand c) = runCommand c - -ptrace = False -- IGNORE - -runCommand :: [TclWord] -> TclM RetVal -runCommand [Subcommand s] = runCommand s -runCommand args = do - (name:evArgs) <- mapM evalw args - when ptrace $ io . print $ (name,args) -- IGNORE - proc <- getProc name - maybe (tclErr ("invalid command name: " ++ show name)) ($! evArgs) proc - -procProc, procSet, procPuts, procIf, procWhile, procReturn, procUpLevel :: TclProc -procSet [s1,s2] = set s1 s2 >> return s2 -procSet _ = tclErr $ "set: Wrong arg count" - -procPuts s@(sh:st) = (io . mapM_ puts) txt >> ret - where (puts,txt) = if sh == B.pack "-nonewline" then (B.putStr,st) else (B.putStrLn,s) -procPuts x = tclErr $ "Bad args to puts: " ++ show x - -procGets [] = io B.getLine >>= return -procGets _ = error "gets: Wrong arg count" - -procEq [a,b] = return . B.pack $ if a == b then "1" else "0" - -procMath :: (Int -> Int -> Int) -> TclProc -procMath op [s1,s2] = liftM2 op (parseInt s1) (parseInt s2) >>= return . B.pack . show -procMath op _ = tclErr "math: Wrong arg count" - -procEval [s] = doTcl s -procEval x = tclErr $ "Bad eval args: " ++ show x - -procExit [] = io (exitWith ExitSuccess) - -procCatch [s] = doTcl s `catchError` (const . return . B.pack) "0" - -procString (f:s:args) - | f == B.pack "trim" = return (trim s) - | f == B.pack "tolower" = return (B.map toLower s) - | f == B.pack "toupper" = return (B.map toUpper s) - | f == B.pack "length" = return . B.pack . show . B.length $ s - | f == B.pack "index" = case args of - [i] -> do ind <- parseInt i - if ind >= B.length s || ind < 0 then ret else return $ B.singleton (B.index s ind) - _ -> tclErr $ "Bad args to string index." - | otherwise = tclErr $ "Can't do string action: " ++ show f - -tclErr = throwError . EDie - -procInfo [x] = if x == B.pack "commands" then get >>= procList . Map.keys . procs . head - else tclErr $ "Unknown info command: " ++ show x - -procAppend (v:vx) = do val <- varGet v - procSet [v,B.concat (val:vx)] - -procList = return . B.concat . intersperse (B.singleton ' ') . map escape - where escape s = if B.elem ' ' s then B.concat [B.singleton '{', s, B.singleton '}'] else s - -procLindex [l,i] = do let items = map getDat . head . getParsed $ l - return . (!!) items =<< (parseInt i) - where getDat (Word s) = s - getDat (NoSub s) = s - getDat x = error $ "getDat doesn't understand: " ++ show x - -procLlength [lst] - | B.null lst = return (B.pack "0") - | otherwise = return . B.pack . show . length . head . getParsed $ lst -procLlength x = tclErr $ "Bad args to llength: " ++ show x - -procIf (cond:yes:rest) = do - condVal <- doCond cond - if condVal then doTcl yes - else case rest of - [s,blk] -> if s == B.pack "else" then doTcl blk else error "Invalid If" - (s:r) -> if s == B.pack "elseif" then procIf r else error "Invalid If" - [] -> ret -procIf x = tclErr "Not enough arguments to If." - -procWhile [cond,body] = loop `catchError` herr - where pbody = getParsed body - herr EBreak = ret - herr (ERet s) = return s - herr EContinue = loop `catchError` herr - herr x = throwError x - loop = do condVal <- doCond cond - if condVal then runCmds pbody >> loop else ret - -procReturn [s] = throwError (ERet s) -procRetv c [] = throwError c -procError [s] = tclErr (B.unpack s) - -parseInt si = maybe (tclErr ("Bad int: " ++ show si)) (return . fst) (B.readInt si) - -procUpLevel [p] = uplevel 1 (procEval [p]) -procUpLevel (si:p) = parseInt si >>= \i -> uplevel i (procEval p) - -uplevel i p = do - (curr,new) <- liftM (splitAt i) get - put new - res <- p - get >>= put . (curr ++) - return res - -procUpVar [s,d] = upvar 1 s d -procUpVar [si,s,d] = parseInt si >>= \i -> upvar i s d - -upvar n s d = do (e:es) <- get - put ((e { upMap = Map.insert s (n,d) (upMap e) }):es) - ret - -procProc [name,body] = regProc name (procRunner [] (getParsed body)) -procProc [name,args,body] = do - let params = case parseArgs args of - Nothing -> error "Parse failed." - Just (r,_) -> map to_s r - let pbody = getParsed body - regProc name (procRunner params pbody) - where to_s (Word b) = b - -procProc x = tclErr $ "proc: Wrong arg count (" ++ show (length x) ++ "): " ++ show x - - -procRunner :: [BString] -> [[TclWord]] -> [BString] -> TclM RetVal -procRunner pl body args = withScope $ do mapM_ (uncurry set) (zip pl args) - when ((not . null) pl && (last pl == B.pack "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 x = error (show x) - -varGet name = do env <- liftM head get - case upped name env of - Nothing -> maybe (tclErr ("can't read \"$" ++ B.unpack name ++ "\": no such variable")) - return - (Map.lookup name (vars env)) - Just (i,n) -> uplevel i (varGet n) - - -interp :: BString -> TclM RetVal -interp str = case getInterp str of - Nothing -> return str - Just x -> handle x - where f (Word match) = varGet (B.tail match) - f x = runCommand [x] - handle (b,m,a) = do pre <- liftM (B.append b) (f m) - post <- interp a - return (B.append pre post) + [] -> 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 diff --git a/TclObj.hs b/TclObj.hs new file mode 100644 --- /dev/null +++ b/TclObj.hs @@ -0,0 +1,71 @@ +module TclObj where + +import qualified BSParse as P + +import qualified Data.ByteString.Char8 as BS + +data TclObj = TclInt !Int BS.ByteString | TclBStr !BS.ByteString (Maybe Int) (Maybe [[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 + Nothing -> Nothing + Just (i,_) -> Just i + + + +doParse s = case P.runParse s of + Nothing -> Nothing + Just (r,_) -> Just r + +mkTclInt i = TclInt i (BS.pack (show i)) + +empty = TclBStr BS.empty Nothing Nothing + +tclTrue = mkTclInt 1 +tclFalse = mkTclInt 0 + +fromBool b = if b then tclTrue else tclFalse + +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]] + +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) + asBStr = id + asParsed s = case P.runParse s of + Nothing -> fail $ "parse failed: " ++ show s + Just (r,_) -> return r + +instance ITObj TclObj where + asStr (TclInt i 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 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 (TclInt _ _) = fail "Can't parse an int value" + + +trueValues = map BS.pack ["1", "true", "yes", "on"] + + diff --git a/example.tcl b/example.tcl --- a/example.tcl +++ b/example.tcl @@ -1,14 +1,9 @@ # Here is an example of some stuff hiccup can do. # I think it's neat. -proc incr v { - upvar 1 loc $v - set loc [+ $loc 1] -} - proc decr v { - upvar loc $v - set loc [- $loc 1] + upvar $v loc + incr loc -1 } proc memfib x { @@ -17,8 +12,8 @@ while { <= $ctr $x } { set v1 [lindex $loc [- $ctr 1]] set v2 [lindex $loc [- $ctr 2]] - set sum [+ $v1 $v2] - set loc "$loc $sum" + set {the sum} [+ $v1 $v2] + set loc "$loc ${the sum}" incr ctr } return [lindex $loc $x] @@ -35,14 +30,14 @@ proc foreach {vname lst what} { set i 0 while {< $i [llength $lst]} { - uplevel "set $vname [lindex $lst $i]" + uplevel "set $vname {[lindex $lst $i]}" uplevel $what incr i } } -foreach name {Spain China Russia Argentina} { +foreach name {Spain China Russia Argentina "North Dakota"} { puts "I've never been to $name." } diff --git a/hiccup.cabal b/hiccup.cabal --- a/hiccup.cabal +++ b/hiccup.cabal @@ -1,14 +1,12 @@ Name: hiccup -Version: 0.2 +Version: 0.3 Description: A simplistic interpreter for a subset of tcl License: GPL License-file: LICENSE Author: Kyle Consalus Maintainer: consalus+hiccup@google.com -Category: Compilers/Interpreters -Synopsis: Simple tcl interpeter -Build-Depends: base, HUnit, mtl -extra-source-files: BSParse.hs README example.tcl +Build-Depends: base, HUnit, mtl, haskell98 +extra-source-files: Hiccup.hs TclObj.hs BSParse.hs README example.tcl Executable: hiccup Main-is: Main.hs diff --git a/hiccup.cabal~ b/hiccup.cabal~ deleted file mode 100644 --- a/hiccup.cabal~ +++ /dev/null @@ -1,13 +0,0 @@ -Name: hiccup -Version: 0.2 -Description: A simplistic interpreter for a subset of tcl -License: GPL -License-file: LICENSE -Author: Kyle Consalus -Maintainer: consalus+hiccup@google.com -Build-Depends: base, HUnit, mtl -extra-source-files: BSParse.hs README example.tcl - -Executable: hiccup -Main-is: Main.hs -ghc-options: -O2 -fglasgow-exts -fbang-patterns -funbox-strict-fields