hiccup-0.35: TclObj.hs

module TclObj where

import Test.HUnit  -- IGNORE

import qualified BSParse as P
import qualified Data.ByteString.Char8 as BS
import System.IO
import Data.Unique

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)

mkTclBStrP s p = TclBStr s mayint p
  where mayint = case BS.readInt (P.dropWhite s) of
                   Nothing -> Nothing
                   Just (i,_) -> Just i

doParse s = case P.runParse s of
                 Nothing -> Left "parse failed"
                 Just (r,rs) -> if BS.null rs then Right r else Left ("Incomplete parse: " ++ show rs)
                  
mkTclInt i = TclInt i (BS.pack (show i))

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
  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,rs) -> if BS.null rs then return r
                                              else fail $ "incomplete parse: " ++ show rs

instance ITObj TclObj where
  asStr (TclInt _ b) = BS.unpack b
  asStr (TclBStr bs _ _) = asStr bs

  asBool (TclInt i _) = i /= 0
  asBool (TclBStr bs _ _) = asBool bs

  asInt (TclInt 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 _ _ (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 # --