cereal-example.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Omnitrans.OtMatrix.Header where

import Data.Text as T
import Control.Monad
import Data.Serialize as B
import Control.Lens
import Data.Char (chr)
import Data.Word
import qualified Data.Vector as V

data Date = Date !Word16 !Word8 !Word8 deriving (Eq, Show)

data Time = Time !Word8 !Word8 !Word8 !Word8 deriving (Eq, Show)

data V2Stuff =
  V2Stuff {_changed :: !Word8
          ,_updatedDate :: !Date
          ,_updatedTime :: !Time
          ,_updatedProgram :: !Text  -- 32
          ,_total :: !Double  -- 8
          ,_minRow :: !Int  -- 4
          ,_minCol :: !Int  -- 4
          ,_minValue :: !Double
          ,_maxRow :: !Int
          ,_maxCol :: !Int
          ,_maxValue :: !Double
          ,_nZerosCells :: !Int}
  deriving (Eq,Show)
makeLenses ''V2Stuff

data Version = V1 | V2 !V2Stuff deriving (Eq, Show)

makePrisms ''Version

data Header = Header {
  _tag :: !Text,
  _version :: !Version,
  _date :: !Date,
  _time :: !Time,
  _creationProgram :: !Text,
  _comment :: !Text,
  _compression :: !Word8,
  _rowCount :: !Int,
  _columnCount :: !Int,
  _offset :: !(Maybe (V.Vector Int))
  } deriving (Eq, Show)
makeLenses ''Header

readHeader :: Get Header
readHeader =
  do tag' <- getString 4
     guard $ tag' == "OT\STX\SO"
     versionNum <- B.getWord32le
     date' <- getDate
     time' <- getTime
     creationProgram' <- upToNUL <$>
                        getString 32
     comment' <- upToNUL <$>
                getString 512
     version' <- case versionNum of
                  1 -> return V1
                  2 -> V2 <$> getV2
                  _ -> fail "Unknown version"
     tag'' <- upToNUL <$> getString 32
     versionQ <- getWord32le
     compression' <- getWord8
     -- We are okay with compression being 0 or 6.
     -- 0 -> No compression
     -- 6 -> OMNITRANS compression
     _ <- getWord8 -- 0 for ODMatrix, 1 for SkimMatrix, according to code comments
     _ <- getString 2 -- dummy, apparently
     nZones <- fromIntegral <$> getWord32le
     -- TODO Should we permit 'matrix' tags? Might be reasonable, and help
     -- prevent parse errors
     offset' <- case (tag'',versionQ) of
                 ("matrix",1) ->
                   Just <$!> V.replicateM nZones getLong
                 _ -> return Nothing
     return $!
       Header tag'' version' date' time' creationProgram' comment' compression' nZones nZones offset'
  where getV2 =
          V2Stuff <$>
          getWord8 <*>
          getDate <*>
          getTime <*>
          (upToNUL <$> getString 32) <*>
          getDouble <*>
          getLong <*>
          getLong <*>
          getDouble <*>
          getLong <*>
          getLong <*>
          getDouble <*>
          getLong

upToNUL :: Text -> Text
upToNUL = T.takeWhile (/= '\NUL')

getString :: Int -> Get Text
getString n = T.pack . fmap (chr . fromIntegral) <$> replicateM n B.getWord8

getDouble :: Get Double
getDouble = getFloat64le

getLong :: Get Int
getLong = fromIntegral <$> getWord32le

getDate :: Get Date
getDate = Date <$> getWord16le <*> getWord8 <*> getWord8

getTime :: Get Time
getTime = Time <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8