hiccup 0.2 → 0.3
raw patch · 7 files changed
+570/−319 lines, 7 filesdep +haskell98
Dependencies added: haskell98
Files
- BSParse.hs +148/−50
- Hiccup.hs +323/−0
- Main.hs +19/−240
- TclObj.hs +71/−0
- example.tcl +6/−11
- hiccup.cabal +3/−5
- hiccup.cabal~ +0/−13
BSParse.hs view
@@ -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 # --
+ Hiccup.hs view
@@ -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))
Main.hs view
@@ -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
+ TclObj.hs view
@@ -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"]++
example.tcl view
@@ -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." }
hiccup.cabal view
@@ -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
− hiccup.cabal~
@@ -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