tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

Value.hs (3093B)

      1 -- Canonical runtime value encodings. Keep demand behavior explicit.
      2 module Runtime.Value where
      3 
      4 import Runtime.Tree
      5 import Data.Word (Word8)
      6 import qualified Data.ByteString as BS
      7 import qualified Data.IntMap.Strict as IM
      8 
      9 -- | Encode a single byte (Word8) as a Tree Calculus number (0..255).
     10 ofByte :: Word8 -> T
     11 ofByte byte = byteTrees IM.! fromIntegral byte
     12 
     13 -- Immutable canonical values: host byte buffers have only 256 possible
     14 -- elements. Share their numeral trees rather than retaining a conversion
     15 -- computation (and eventually a fresh bit spine) for every input byte.
     16 -- Tree equality/encoding is unchanged; no pointer identity is exposed.
     17 {-# NOINLINE byteTrees #-}
     18 byteTrees :: IM.IntMap T
     19 byteTrees = IM.fromDistinctAscList [(n, ofNumber (toInteger n)) | n <- [0..255]]
     20 
     21 -- | Decode a Tree Calculus number as a single byte (Word8).
     22 --   Rejects values outside the range 0..255.
     23 toByte :: T -> Either String Word8
     24 toByte t = case toNumber t of
     25   Left err -> Left err
     26   Right n
     27     | n >= 0 && n <= 255 -> Right (fromIntegral n)
     28     | otherwise -> Left ("Byte value out of range: " ++ show n)
     29 
     30 -- | Encode a ByteString as a Tree Calculus list of Byte trees.
     31 ofBytes :: BS.ByteString -> T
     32 ofBytes = BS.foldr consByte Leaf
     33   where
     34     -- Force the bounded table lookup when the list cell is demanded, so an
     35     -- unexamined body does not retain one lookup closure per byte. Input is
     36     -- already a finite strict ByteString, not arbitrary language computations.
     37     consByte byte rest = let value = ofByte byte in value `seq` Fork value rest
     38 
     39 -- | Decode a Tree Calculus list of Byte trees as a ByteString.
     40 --   Rejects non-list trees and elements that are not valid byte values (0..255).
     41 toBytes :: T -> Either String BS.ByteString
     42 toBytes t = case toList t of
     43   Left err -> Left err
     44   Right bs -> BS.pack <$> mapM toByte bs
     45 
     46 -- Marshalling
     47 ofString :: String -> T
     48 ofString str = ofList $ map (ofNumber . toInteger . fromEnum) str
     49 
     50 ofNumber :: Integer -> T
     51 ofNumber 0 = Leaf
     52 ofNumber n =
     53   Fork
     54     (if odd n then Stem Leaf else Leaf)
     55     (ofNumber (n `div` 2))
     56 
     57 ofList :: [T] -> T
     58 ofList = foldr Fork Leaf
     59 
     60 toNumber :: T -> Either String Integer
     61 toNumber Leaf = Right 0
     62 toNumber (Fork Leaf rest) = case toNumber rest of
     63   Right n -> Right (2 * n)
     64   Left err -> Left err
     65 toNumber (Fork (Stem Leaf) rest) = case toNumber rest of
     66   Right n -> Right (1 + 2 * n)
     67   Left err -> Left err
     68 toNumber _ = Left "Invalid Tree Calculus number"
     69 
     70 toChar :: Integer -> Either String Char
     71 toChar n
     72   | n < 0                    = Left "Negative character code"
     73   | n > 0x10FFFF             = Left "Character code out of Unicode range"
     74   | n >= 0xD800 && n <= 0xDFFF = Left "Surrogate character code not allowed"
     75   | otherwise                = Right (toEnum (fromInteger n))
     76 
     77 toString :: T -> Either String String
     78 toString tc = do
     79   list <- toList tc
     80   nums <- mapM toNumber list
     81   mapM toChar nums
     82 
     83 toList :: T -> Either String [T]
     84 toList Leaf = Right []
     85 toList (Fork x rest) = case toList rest of
     86   Right xs -> Right (x : xs)
     87   Left err -> Left err
     88 toList _ = Left "Invalid Tree Calculus list"
     89