init

.gitignore

@@ -0,0 +1 @@
+.stack-work

Bin.hs

@@ -0,0 +1,102 @@
+
+module Bin (encode, decode) where
+
+import Data.Word
+import Data.Bits
+import Data.Monoid
+import Control.Monad (replicateM)
+import qualified Data.ByteString.Lazy as B
+import Data.Binary.Get
+import Data.ByteString.Builder
+
+import Type
+
+encodeun :: Word64 -> Builder
+encodeun v
+    | v <= 240 = w8 v
+    | v <= 2287 = let v' = v - 240 in w8 ((v' `shiftR` 8) + 241) <> w8 (v' .&. 0xff)
+    | v <= 67823 = let v' = v - 2288 in word8 249 <> w8 (v' `shiftR` 8) <> w8 (v' .&. 0xff)
+    | otherwise = words 0 v mempty
+  where
+    words :: Word8 -> Word64 -> Builder -> Builder
+    words l 0 b = word8 (247 + l) <> b
+    words l v' b = words (l + 1) (v' `shiftR` 8) (w8 (0xff .&. v') <> b)
+
+    w8 = word8 . fromIntegral
+
+decodeun' :: Word8 -> Get Word64
+decodeun' a0
+    | a0 <= 240 = return $ fromIntegral a0
+    | a0 <= 248 = getWord8 >>= (\a1 -> return $ 240 + 256 * (fromIntegral a0 - 241) + fromIntegral a1)
+    | a0 == 249 = do
+        a1 <- getWord8
+        a2 <- getWord8
+        return $ 2288 + 256 * (fromIntegral a1) + (fromIntegral a2)
+    | otherwise = getBytes (a0 - 247) 0
+  where
+    getBytes :: Word8 -> Word64 -> Get Word64
+    getBytes 0 n = return n
+    getBytes l n = getWord8 >>= (\b -> getBytes (l-1) ((n `shiftL` 8) + (fromIntegral b)))
+
+decodeun :: Get Word64
+decodeun = getWord8 >>= decodeun'
+
+encode' :: TypeV -> Builder
+encode' (U8v w) = word8 w
+encode' (U16v w) = word16BE w
+encode' (U32v w) = word32BE w
+encode' (U64v w) = word64BE w
+encode' (I8v i) = int8 i
+encode' (I16v i) = int16BE i
+encode' (I32v i) = int32BE i
+encode' (I64v i) = int64BE i
+encode' (F32v f) = floatBE f
+encode' (F64v d) = doubleBE d
+encode' (UVv w) = encodeun w
+encode' (Tuplev x) = foldMap (encode' . snd) x
+encode' (Unionv _ n x) = encode' (UVv n)
+                      <> encode' x
+encode' (Arrayv x) = encode' (UVv $ fromIntegral $ length x)
+                  <> foldMap encode' x
+
+encode :: TypeV -> B.ByteString
+encode = toLazyByteString . encode'
+
+nth :: [a] -> Word64 -> Maybe a
+nth (x:_) 0 = Just x
+nth (_:xs) n = nth xs (n - 1)
+nth _ _ = Nothing
+
+dec :: (Maybe String, Raw) -> Get (Maybe String, TypeV)
+dec (a, b) = (,) a <$> decode' b
+
+decode' :: Raw -> Get TypeV
+decode' U8 = U8v <$> getWord8
+decode' U16 = U16v <$> getWord16be
+decode' U32 = U32v <$> getWord32be
+decode' U64 = U64v <$> getWord64be
+decode' I8 = I8v <$> getInt8
+decode' I16 = I16v <$> getInt16be
+decode' I32 = I32v <$> getInt32be
+decode' I64 = I64v <$> getInt64be
+decode' F32 = F32v <$> getFloatbe
+decode' F64 = F64v <$> getDoublebe
+decode' UV = UVv <$> decodeun
+decode' (NameR _) = undefined
+decode' (TupleR t) = Tuplev <$> (mapM dec t)
+decode' (UnionR u) = do
+    n <- decodeun
+    case u `nth` n of
+      Nothing -> fail "union index out of bounds"
+      Just (annotation, r) -> Unionv annotation n <$> decode' r
+decode' (ArrayR a) = Arrayv <$>
+    (decodeun >>= return . fromIntegral >>=
+    flip replicateM (decode' a))
+
+decode :: Raw -> B.ByteString -> Either String TypeV
+decode spec bs =
+    case runGetOrFail (decode' spec) bs of
+      Right (i, _, t) -> if B.null i
+                            then Right t
+                            else Left "too much input"
+      Left (_, _, e) -> Left e

Diag.hs

@@ -0,0 +1,118 @@
+
+module Diag (diag) where
+
+import Data.Word
+import Codec.Binary.UTF8.String as UTF8
+
+import Text.Parsec
+import Text.Parsec.String
+
+import Type
+
+valid :: (Num a) => (Int -> Integer -> Bool) -> String -> Int -> String -> Parser a
+valid out kind bits s =
+    let n = read s in
+    if out bits n
+        then fail $ concat [ s,
+            " does not fit in ", kind,
+            " number of ", show bits,
+            " bits"
+            ]
+        else return $ fromIntegral n
+
+tonat :: (Num a) => Int -> String -> Parser a
+tonat = valid uout "an unsigned"
+
+toint :: (Num a) => Int -> String -> Parser a
+toint = valid iout "a signed"
+
+uout :: Int -> Integer -> Bool
+uout bits n = n >= 2 ^ bits || n < 0
+
+iout :: Int -> Integer -> Bool
+iout bits n = n >= 2 ^ (bits-1) || n < - (2 ^ (bits-1))
+
+size :: Bool -> String -> Parser TypeV
+size validInt n = char '\'' >> if validInt
+    then unsigned <|> signed <|> floating
+    else floating
+  where
+    unsigned = char 'u' >> choice [
+        char '8' >> U8v <$> tonat 8 n,
+        string "16" >> U16v <$> tonat 16 n,
+        string "32" >> U32v <$> tonat 32 n,
+        string "64" >> U64v <$> tonat 64 n
+        ]
+    signed = char 'i' >> choice [
+        char '8' >> I8v <$> toint 8 n,
+        string "16" >> I16v <$> toint 16 n,
+        string "32" >> I32v <$> toint 32 n,
+        string "64" >> I64v <$> toint 64 n
+        ]
+    floating = char 'f' >> choice [
+        string "32" >> return (F32v (read n)),
+        string "64" >> return (F64v (read n))
+        ]
+
+num :: Parser TypeV
+num = do
+    i <- integer <?> "a number"
+    s <- suffix
+    case s of
+      "" -> size True i <|> (UVv <$> tonat 64 i)
+      s' -> let f = i ++ s' in (size False f)
+  where
+    (<:>) a b = (:) <$> a <*> b
+    digits = many1 digit
+    plus = char '+' >> digits
+    minus = char '-' <:> digits
+    integer = plus <|> minus <|> digits
+    suffix = (++) <$> d <*> e
+    d = option "" $ char '.' <:> digits
+    e = option "" $ oneOf "eE" <:> integer
+
+ws :: Parser ()
+ws = spaces <?> ""
+
+annotation :: Parser (Maybe String)
+annotation = optionMaybe (try note) <?> "an annotation"
+  where
+    word = many1 $ alphaNum <|> oneOf "._-<>?!"
+    note = word <* char ':' <* ws
+
+tuple :: Parser TypeV
+tuple = Tuplev <$> (open >> many pair <* close)
+  where
+    pair = (,) <$> annotation <*> diag'
+    open = char '{' <* ws
+    close = char '}' <* ws
+
+union :: Word64 -> Parser TypeV
+union n = char '@' >> ws >> Unionv Nothing n <$> diag'
+
+unionum :: Parser TypeV
+unionum = do
+    n <- num <* ws
+    case n of
+      UVv n' -> union n' <|> return (UVv n')
+      _ -> return n
+
+array :: Parser TypeV
+array = Arrayv <$> (open >> many diag' <* close)
+  where
+    open = char '[' <* ws
+    close = char ']' <* ws
+
+str :: Parser TypeV
+str = Arrayv . f <$> str'
+  where
+    open = char '"'
+    close = char '"' <* ws
+    str' = open >> many (noneOf "\"\n") <* close
+    f s = U8v <$> UTF8.encode s
+
+diag' :: Parser TypeV
+diag' = choice [ unionum, tuple, array, str ]
+
+diag :: String -> String -> Either ParseError TypeV
+diag name input = parse (ws >> diag' <* eof) name input

LICENSE

@@ -0,0 +1,13 @@
+Copyright (c) 2018 Murray
+
+Permission to use, copy, modify, and/or distribute this software for any purpose
+with or without fee is hereby granted, provided that the above copyright notice
+and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
+OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
+TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
+THIS SOFTWARE.

Main.hs

@@ -0,0 +1,93 @@
+
+import System.Environment
+import System.Exit
+
+import Control.Monad
+
+import qualified Data.ByteString.Lazy as B
+
+import Schema
+import Diag
+import Bin
+
+readFrom :: String -> IO String
+readFrom "-" = getContents
+readFrom f = readFile f
+
+bytesFrom :: FilePath -> IO B.ByteString
+bytesFrom "-" = B.getContents
+bytesFrom f = B.readFile f
+
+arg :: String -> String -> [String] -> String
+arg _ "" [a] = a
+arg def switch (s:v:args')
+    | switch == s = v
+    | otherwise = arg def switch args'
+arg def _ _ = def
+
+display :: String -> String
+display "-" = "stdin"
+display s = s
+
+check :: [String] -> IO ()
+check args =
+  let input = arg "-" "" args
+      incdir = arg "." "-i" args in do
+  str <- readFrom input
+  r <- schema incdir (display input) str
+  case r of
+    Left e -> die (show e)
+    Right s -> print s
+
+bin2diag :: [String] -> IO ()
+bin2diag args =
+  let schemaFile = arg "-" "-s" args
+      incdir = arg "." "-i" args
+      input = arg "-" "" args in do
+  when (schemaFile == input) $
+       die "cannot read schema and data from the same file, see `help`"
+  str <- readFrom schemaFile
+  r <- schema incdir (display schemaFile) str
+  case r of
+    Left e -> die (show e)
+    Right s -> do
+      bs <- bytesFrom input
+      case decode s bs of
+        Left e -> die e
+        Right d -> print d
+
+diag2bin :: [String] -> IO ()
+diag2bin args =
+  let input = arg "-" "" args in do
+  str <- readFrom input
+  case diag (display input) str of
+     Left e -> die (show e)
+     Right d -> B.putStr $ encode d
+
+help :: IO ()
+help = do
+    prog <- getProgName
+    putStrLn $ "\
+\usage: \n\
+\  " ++ prog ++ " [-i dir] [file]\n\
+\  " ++ prog ++ " encode [file]\n\
+\  " ++ prog ++ " decode [-s file] [-i dir] [file]\n\
+\  " ++ prog ++ " help\n\
+\\n\
+\    -s file   file containing the schema\n\
+\    -i dir    include search path\n\
+\\n\
+\file always defaults to stdin"
+
+main :: IO ()
+main = do
+  args <- getArgs
+  case args of
+    ("encode":args') -> diag2bin args'
+    ("decode":args') -> bin2diag args'
+    ("help":_) -> help
+    ("-h":_) -> help
+    ("-help":_) -> help
+    ("--help":_) -> help
+    args' -> check args'
+