{-# LANGUAGE StandaloneDeriving,
             OverloadedStrings,
             LambdaCase,
             TypeSynonymInstances,
             FlexibleInstances,
             TupleSections,
             ScopedTypeVariables,
             DeriveGeneric,
             Rank2Types,
             GeneralizedNewtypeDeriving#-}

{- |
  Serialization/deserialization for the binary .js_o files

  The .js_o files contain dependency information and generated code

  all strings are mapped to a central string table, which helps reduce
  file size and gives us efficient hash consing on read

  Binary intermediate JavaScript object files:
    serialized [Text] -> ([ClosureInfo], JStat) blocks

  file layout:

   - header ["GHCJSOBJ", length of symbol table, length of dependencies, length of index]
   - symbol table
   - dependency info
   - closureinfo index
   - closureinfo data (offsets described by index)
-}

module Gen2.Object ( object
                   , object'
                   , showDeps
                   , readDepsFile
                   , hReadDeps
                   , readDeps
                   , showObject
                   , readObjectFile
                   , readObjectFileKeys
                   , readObject
                   , readObjectKeys
                   , serializeStat
                   , emptySymbolTable
                   , isGlobalUnit
                   , SymbolTable
                   , ObjUnit (..)
                   , Deps (..), BlockDeps (..)
                   , Fun (..), showFun
                   , Package (..), showPkg
                   , versionTag, versionTagLength
                   ) where

import           Control.DeepSeq
import           Control.Exception (bracket)
import           Control.Lens
import           Control.Monad
import           Control.Monad.Trans
import           Control.Monad.Trans.Reader

import           Data.Array
import qualified Data.Binary     as DB
import qualified Data.Binary.Get as DB
import qualified Data.Binary.Put as DB
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as B
import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as C8 (pack, unpack)
import           Data.Data.Lens
import           Data.Function (on)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import           Data.Int
import qualified Data.IntMap as IM
import           Data.IntSet (IntSet)
import qualified Data.IntSet as IS
import           Data.List (sortBy)
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Maybe (catMaybes, fromMaybe)
import           Data.Monoid
import           Data.Set (Set)
import qualified Data.Set as S
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Text.Binary ()
import qualified Data.Text.Lazy as TL
import           Data.Word

import           GHC.Generics

import           System.IO (openBinaryFile, withFile, Handle, hClose, hSeek, SeekMode(..), IOMode(..) )

import           Text.PrettyPrint.Leijen.Text (displayT, renderPretty)

import           Compiler.JMacro
import           Compiler.Info

import           Gen2.ClosureInfo hiding (Fun)
import           Gen2.Printer (pretty)
import           Gen2.Utils (trim)

data Header = Header { symbsLen :: !Int64
                     , depsLen  :: !Int64
                     , idxLen   :: !Int64
                     } deriving (Eq, Ord, Show)

-- | dependencies for a single module
data Deps = Deps
  { depsPackage         :: !Package                -- ^ package name
  , depsModule          :: !Text                   -- ^ module name
  , depsRequired        :: !IntSet                 -- ^ blocks that always need to be linked when this object is loaded (e.g. everything that contains initializer code or foreign exports)
  , depsHaskellExported :: !(Map   Fun  Int)       -- ^ exported Haskell functions -> block
  , depsBlocks          :: !(Array Int  BlockDeps) -- ^ info about each block
  } deriving (Show, Generic)

instance NFData Deps

data BlockDeps = BlockDeps
  { blockBlockDeps       :: [Int] -- ^ dependencies on blocks in this object
  , blockFunDeps         :: [Fun] -- ^ dependencies on exported symbols in other objects
  , blockForeignExported :: [ExpFun]
  } deriving (Show, Generic)

instance NFData BlockDeps

data ExpFun = ExpFun { isIO   :: !Bool
                     , args   :: [JSFFIType]
                     , result :: !JSFFIType
                     } deriving (Eq, Ord, Show)

{- | we use the convention that the first unit (0) is a module-global
     unit that's always included when something from the module
     is loaded. everything in a module implicitly depends on the
     global block. the global unit itself can't have dependencies
 -}
isGlobalUnit :: Int -> Bool
isGlobalUnit n = n == 0

instance NFData ExpFun where
  rnf (ExpFun _x as _r) = rnf as `seq` ()

instance NFData JSFFIType where
  rnf x = x `seq` ()

data JSFFIType = Int8Type
               | Int16Type
               | Int32Type
               | Int64Type
               | Word8Type
               | Word16Type
               | Word32Type
               | Word64Type
               | DoubleType
               | ByteArrayType
               | PtrType
               | RefType
               deriving (Show, Ord, Eq, Enum)

data Fun = Fun { funPackage :: !Package
               , funModule  :: !Text
               , funSymbol  :: !Text
               } deriving (Eq, Ord, Show)

instance NFData Fun where rnf x = x `seq` ()

{-
data Package = Package { packageName    :: !Text
                       , packageVersion :: !Text
                       }
-}
newtype Package = Package { unPackage :: Text }
  deriving (Eq, Ord, Show, Generic, NFData)
instance DB.Binary Package

-- we need to store the size separately, since getting a HashMap's size is O(n)
data SymbolTable  = SymbolTable !Int !(HashMap Text Int)

emptySymbolTable :: SymbolTable
emptySymbolTable = SymbolTable 0 HM.empty

insertSymbol :: Text -> SymbolTable -> (SymbolTable, Int)
insertSymbol s st@(SymbolTable n t) =
  case HM.lookup s t of
    Just k  -> (st, k)
    Nothing -> (SymbolTable (n+1) (HM.insert s n t), n)

data ObjEnv = ObjEnv { oeSymbols :: SymbolTableR
                     , oeName    :: String
                     }

data SymbolTableR = SymbolTableR { strText   :: Array Int Text
                                 , strString :: Array Int String
                                 }

-- The Control.Monad.Trans.State.Strict transformer leaks
newtype StrictStateT s m a = StrictStateT
  { runStrictStateT :: forall r . (s -> a -> m r) -> s -> m r }

instance Functor (StrictStateT s m) where
  fmap f m = StrictStateT $ \c s0 -> s0 `seq` runStrictStateT m (\s1 a -> s1 `seq` c s1 (f a)) s0

instance Applicative (StrictStateT s m) where
  pure a  = StrictStateT (\c s -> s `seq` c s a)
  f <*> v = StrictStateT $ \c s0 -> runStrictStateT f
                (\s1 g -> s1 `seq` runStrictStateT v (\s2 a -> s1 `seq` c s2 (g a)) s1) s0

instance Monad m => Monad (StrictStateT s m) where
  return a = StrictStateT (\c s -> s `seq` c s a)
  m >>= f = m `seq` f `seq` (StrictStateT $
    \c s0 -> s0 `seq` runStrictStateT m (\s1 a -> let fa = f a in s1 `seq` fa `seq` runStrictStateT fa c s1) s0)
  m1 >> m2 = m1 `seq` m2 `seq` (StrictStateT $
    \c s0 -> s0 `seq` runStrictStateT m1 (\s1 _ -> s1 `seq` runStrictStateT m2 c s1) s0)

instance MonadTrans (StrictStateT s) where
  lift m = m `seq` StrictStateT (\c s -> m >>= \a -> s `seq` c s a)

getState :: Monad m => StrictStateT s m s
getState = StrictStateT (\c s -> c s s)

putState :: Monad m => s -> StrictStateT s m ()
putState s = StrictStateT (\c _ -> c s ())

execStrictStateT :: Monad m => StrictStateT s m a -> s -> m s
execStrictStateT ss i = runStrictStateT ss (\s _ -> return s) i

type PutSM = StrictStateT SymbolTable DB.PutM
type PutS  = PutSM ()
type GetS  = ReaderT ObjEnv DB.Get

class Objectable a where
  put :: a -> PutS
  get :: GetS a
  putList :: [a] -> PutS
  putList = putListOf put
  getList :: GetS [a]
  getList = getListOf get

runGetS :: String -> SymbolTableR -> GetS a -> ByteString -> a
runGetS name st m bs = DB.runGet (runReaderT m (ObjEnv st name)) bs

runPutS :: SymbolTable -> PutS -> (SymbolTable, ByteString)
runPutS st ps = DB.runPutM (execStrictStateT ps st)

unexpected :: String -> GetS a
unexpected err = ask >>= \e ->
  error (oeName e ++ ": " ++ err)

-- one toplevel block in the object file
data ObjUnit = ObjUnit { oiSymbols :: [Text]         -- toplevel symbols (stored in index)
                       , oiClInfo  :: [ClosureInfo]  -- closure information of all closures in block
                       , oiStatic  :: [StaticInfo]   -- static closure data
                       , oiStat    :: JStat          -- the code
                       }

-- | build an object file
object :: Deps        -- ^ the dependencies
       -> [ObjUnit]   -- ^ units, the first unit is the module-global one
       -> ByteString  -- ^ serialized object
object ds units = object' symbs ds xs
  where
    (xs, symbs) = go emptySymbolTable units
    go st0 (ObjUnit sy cl si st : ys) =
      let (st1, bs)  = serializeStat st0 cl si st
          (bss, st2) = go st1 ys
      in  ((sy,bs):bss, st2)
    go st0 [] = ([], st0)

serializeStat :: SymbolTable
              -> [ClosureInfo]
              -> [StaticInfo]
              -> JStat
              -> (SymbolTable, ByteString)
serializeStat st ci si s =
  let (st', bs) = runPutS st (put ci >> put s >> put si) -- fixme order
      bs' = B.toStrict bs
  in  (st', B.fromChunks [bs'])

object' :: SymbolTable           -- ^ final symbol table
        -> Deps                  -- ^ dependencies
        -> [([Text],ByteString)] -- ^ serialized units and their exported symbols, the first unit is module-global
        -> ByteString
object' st0 deps0 os = rnf deps0 `seq` (hdr <> symbs <> deps1 <> idx <> mconcat (map snd os))
  where
    hdr          = putHeader (Header (bl symbs) (bl deps1) (bl idx))
    bl           = fromIntegral . B.length
    deps1        = putDepsSection deps0
    (sti, idx)   = putIndex st0 os
    symbs        = putSymbolTable sti

putIndex :: SymbolTable -> [([Text], ByteString)] -> (SymbolTable, ByteString)
putIndex st xs = runPutS st (put $ zip symbols offsets)
  where
    (symbols, values) = unzip xs
    offsets = scanl (+) 0 (map B.length values)

getIndex :: String -> SymbolTableR -> ByteString -> [([Text], Int64)]
getIndex name st bs = runGetS name st get bs

putDeps :: SymbolTable -> Deps -> (SymbolTable, ByteString)
putDeps st deps = runPutS st (put deps)

getDeps :: String -> SymbolTableR -> ByteString -> Deps
getDeps name st bs = runGetS name st get bs

toI32 :: Int -> Int32
toI32 = fromIntegral

fromI32 :: Int32 -> Int
fromI32 = fromIntegral

putDepsSection :: Deps -> ByteString
putDepsSection deps =
  let (st, depsbs) = putDeps emptySymbolTable deps
      stbs         = putSymbolTable st
  in  DB.runPut (DB.putWord32le (fromIntegral $ B.length stbs)) <> stbs <> depsbs

getDepsSection :: String -> ByteString -> Deps
getDepsSection name bs =
  let symbsLen = fromIntegral $ DB.runGet DB.getWord32le bs
      symbs    = getSymbolTable (B.drop 4 bs)
  in  getDeps name symbs (B.drop (4+symbsLen) bs)

instance Objectable Deps where
  put (Deps p m r e b)
    = put p >> put m >> put (map toI32 $ IS.toList r) >>
      put (map (\(x,y) -> (x, toI32 y)) $ M.toList e) >>
      put (elems b)
  get = Deps <$> get
             <*> get
             <*> (IS.fromList . map fromI32 <$> get)
             <*> (fmap fromI32 . M.fromList <$> get)
             <*> ((\xs -> listArray (0, length xs - 1) xs) <$> get)

instance Objectable BlockDeps where
  put (BlockDeps bbd bfd bfe) = put bbd >> put bfd >> put bfe
  get = BlockDeps <$> get <*> get <*> get

instance Objectable ExpFun where
  put (ExpFun isIO args res) = put isIO >> put args >> put res
  get                        = ExpFun <$> get <*> get <*> get

-- | reads only the part necessary to get the dependencies
--   so it's potentially more efficient than readDeps <$> B.readFile file
readDepsFile :: FilePath -> IO Deps
readDepsFile file = withFile file ReadMode (hReadDeps file)

hReadDeps :: String -> Handle -> IO Deps
hReadDeps name h = do
  mhdr <- getHeader <$> B.hGet h headerLength
  case mhdr of
    Left err -> error ("hReadDeps: not a valid GHCJS object: " ++ name ++ "\n    " ++ err)
    Right hdr -> do
      hSeek h RelativeSeek (fromIntegral $ symbsLen hdr)
      getDepsSection name <$> B.hGet h (fromIntegral $ depsLen hdr)

-- | call with contents of the file
readDeps :: String -> ByteString -> Deps
readDeps name bs =
  case getHeader bs of
    Left err -> error ("readDeps: not a valid GHCJS object: " ++ name ++ "\n   " ++ err)
    Right hdr ->
      let depsStart = fromIntegral headerLength + fromIntegral (symbsLen hdr)
      in  getDepsSection name (B.drop depsStart bs)

-- | extract the linkable units from an object file
readObjectFile :: FilePath -> IO [ObjUnit]
readObjectFile = readObjectFileKeys (\_ _ -> True)

readObjectFileKeys :: (Int -> [Text] -> Bool) -> FilePath -> IO [ObjUnit]
readObjectFileKeys p file = bracket (openBinaryFile file ReadMode) hClose $ \h -> do
  mhdr <- getHeader <$> B.hGet h headerLength
  case mhdr of
    Left err -> error ("readObjectFileKeys: not a valid GHCJS object: " ++ file ++ "\n    " ++ err)
    Right hdr -> do
      bss <- B.hGet h (fromIntegral $ symbsLen hdr)
      hSeek h RelativeSeek (fromIntegral $ depsLen hdr)
      bsi <- B.fromStrict <$> BS.hGetContents h
      return $ readObjectKeys' file p (getSymbolTable bss) bsi (B.drop (fromIntegral $ idxLen hdr) bsi)

readObject :: String -> ByteString -> [ObjUnit]
readObject name = readObjectKeys name (\_ _ -> True)

readObjectKeys :: String -> (Int -> [Text] -> Bool) -> ByteString -> [ObjUnit]
readObjectKeys name p bs =
  case getHeader bs of
    Left err -> error ("readObjectKeys: not a valid GHCJS object: " ++ name ++ "\n    " ++ err)
    Right hdr ->
      let bssymbs = B.drop (fromIntegral headerLength) bs
          bsidx   = B.drop (fromIntegral $ symbsLen hdr + depsLen hdr) bssymbs
          bsobjs  = B.drop (fromIntegral $ idxLen hdr) bsidx
      in readObjectKeys' name p (getSymbolTable bssymbs) bsidx bsobjs

readObjectKeys' :: String
                -> (Int -> [Text] -> Bool)
                -> SymbolTableR
                -> ByteString
                -> ByteString
                -> [ObjUnit]
readObjectKeys' name p st bsidx bsobjs = catMaybes (zipWith readObj [0..] idx)
    where
      idx = getIndex name st bsidx
      readObj n (x,off)
        | p n x     = let (ci, s, si) = runGetS name st ((,,) <$> get <*> get <*> get) (B.drop off bsobjs) -- fixme order!
                      in  Just (ObjUnit x ci si s)
        | otherwise = Nothing

getSymbolTable :: ByteString -> SymbolTableR
getSymbolTable bs = SymbolTableR (listArray (0,n-1) xs) (listArray (0,n-1) (map T.unpack xs))
  where
    (n,xs) = DB.runGet getter bs
    getter :: DB.Get (Int, [Text])
    getter = do
      l <- DB.getWord32le
      let l' = fromIntegral l
      (l',) <$> replicateM l' DB.get

putSymbolTable :: SymbolTable -> ByteString
putSymbolTable (SymbolTable _ hm)
--  | trace "putting symbol table" False = undefined
  | otherwise = DB.runPut $ do
  DB.putWord32le (fromIntegral $ length xs)
  mapM_ DB.put xs
    where
      xs :: [Text]
      xs = map fst . sortBy (compare `on` snd) . HM.toList $ hm

headerLength :: Int
headerLength = 64

-- human readable version string in object
versionTag :: ByteString
versionTag = B.take 32 . C8.pack $ getFullCompilerVersion ++ replicate versionTagLength ' '

versionTagLength :: Int
versionTagLength = 32

getHeader :: ByteString -> Either String Header
getHeader bs | B.length bs < fromIntegral headerLength = Left "not enough input, file truncated?"
             | magic /= "GHCJSOBJ"                     = Left "magic number incorrect, not a js_o file?"
             | tag   /= versionTag                     = Left $ "incorrect version, expected " ++ getFullCompilerVersion ++
                                                                    " but got " ++ (trim . C8.unpack $ tag)
             | otherwise                               = Right header
   where
     g                    = fromIntegral <$> DB.getWord64le
     (magic, tag, header) = DB.runGet ((,,) <$> DB.getByteString 8
                                            <*> DB.getLazyByteString (fromIntegral versionTagLength)
                                            <*> (Header <$> g <*> g <*> g)
                                      ) bs

putHeader :: Header -> ByteString
putHeader (Header sl dl il) = DB.runPut $ do
  DB.putByteString "GHCJSOBJ"
  DB.putLazyByteString versionTag
  mapM_ (DB.putWord64le . fromIntegral) [sl, dl, il]

-- prettyprint object similar to how the old text based
-- objects worked
showObject :: [ObjUnit] -> TL.Text
showObject xs = mconcat (zipWith showSymbol xs [0..])
  where
    showSymbol :: ObjUnit -> Int -> TL.Text
    showSymbol (ObjUnit symbs cis sis stat) n -- fixme show static data
      | "h$debug" `elem` symbs =
           "/*\n" <> (TL.fromStrict $ T.unlines ( stat ^.. template . _JStr )) <> "\n*/\n"
      | otherwise = TL.unlines
        [ "// begin: [" <> TL.intercalate "," (map TL.fromStrict symbs) <> "] (" <> TL.pack (show n) <> ")"
        , displayT . renderPretty 0.8 150 . pretty $ (stat <> mconcat (map toStat cis))
        , "/* static:"
        , TL.pack (show sis)
        , "end of static */"
        , "// end: [" <> TL.intercalate "," (map TL.fromStrict symbs) <> "]"
        ]

showDeps :: Deps -> TL.Text
showDeps (Deps p m r e b) =
  "package: " <> showPkg p <> "\n" <>
  "module: "  <> TL.fromStrict m <> "\n" <>
  "required:" <> TL.pack (show $ IS.toList r) <> "\n" <>
  "blocks:\n"   <> TL.unlines (map dumpBlock $ assocs b)
  where
    listOf n f xs = "  " <> n <> ":\n" <>
                    TL.unlines (map (TL.pack . ("  - "++) . f) xs)
    blockExps = IM.fromListWith (++) $ map (\(f,n) -> (n,[f])) (M.toList e)
    dumpBlock (n, (BlockDeps bbd bfd bfe)) = TL.pack (show n) <> " ->\n" <>
      listOf "block deps" show bbd <>

      listOf "external deps" showFun bfd <>
      listOf "exports"       showFun (fromMaybe [] $ IM.lookup n blockExps) {- <>
      listOf "foreign exports" fixme bfe fixme -}

showPkg :: Package -> TL.Text
showPkg = TL.fromStrict . unPackage

showFun :: Fun -> String
showFun (Fun p m s) = TL.unpack (showPkg p) ++ ":" ++ T.unpack m ++ "." ++ T.unpack s

tag :: Word8 -> PutS
tag x = lift (DB.putWord8 x)

getTag :: GetS Word8
getTag = lift DB.getWord8

instance (Objectable a, Objectable b) => Objectable (a, b) where
  put (x, y) = put x >> put y
  get = (,) <$> get <*> get

instance Objectable a => Objectable [a] where
  put = putList
  get = getList

instance Objectable Char where
  put = lift . DB.putWord32le . fromIntegral . fromEnum
  get = toEnum . fromIntegral <$> lift DB.getWord32le
  putList = put . T.pack
  getList = do
    st <- oeSymbols <$> ask
    n <- lift DB.getWord32le
    return (strString st ! fromIntegral n)

putListOf :: (a -> PutS) -> [a] -> PutS
putListOf p xs = do
  lift (DB.putWord32le (fromIntegral $ length xs))
  mapM_ p xs

getListOf :: GetS a -> GetS [a]
getListOf g = do
  l <- lift DB.getWord32le
  replicateM (fromIntegral l) g

instance (Ord k, Objectable k, Objectable v) => Objectable (Map k v) where
  put = put . M.toList
  get = M.fromList <$> get

instance (Ord a, Objectable a) => Objectable (Set a) where
  put = put . S.toList
  get = S.fromList <$> get

instance Objectable Word64 where
  put = lift . DB.putWord64le
  get = lift DB.getWord64le

instance Objectable Int64 where
  put = lift . DB.putWord64le . fromIntegral
  get = fromIntegral <$> lift DB.getWord64le

instance Objectable Word32 where
  put = lift . DB.putWord32le
  get = lift DB.getWord32le

instance Objectable Int32 where
  put = lift . DB.putWord32le . fromIntegral
  get = fromIntegral <$> lift DB.getWord32le

instance Objectable a => Objectable (Maybe a) where
  put Nothing  = tag 1
  put (Just x) = tag 2 >> put x
  get = getTag >>= \case
                      1 -> pure Nothing
                      2 -> Just <$> get
                      n -> unexpected ("Objectable get Maybe: invalid tag: " ++ show n)

instance Objectable Text where
  put t = do
    symbols <- getState
    let (symbols', n) = insertSymbol t symbols
    putState symbols'
    lift (DB.putWord32le $ fromIntegral n)
  get = do
    st <- oeSymbols <$> ask
    n <- lift DB.getWord32le
    return (strText st ! fromIntegral n)

instance Objectable JStat where
  put (DeclStat i)         = tag 1  >> put i
  put (ReturnStat e)       = tag 2  >> put e
  put (IfStat e s1 s2)     = tag 3  >> put e  >> put s1 >> put s2
  put (WhileStat b e s)    = tag 4  >> put b  >> put e  >> put s
  put (ForInStat b i e s)  = tag 5  >> put b  >> put i  >> put e  >> put s
  put (SwitchStat e ss s)  = tag 6  >> put e  >> put ss >> put s
  put (TryStat s1 i s2 s3) = tag 7  >> put s1 >> put i  >> put s2 >> put s3
  put (BlockStat xs)       = tag 8  >> put xs
  put (ApplStat e es)      = tag 9  >> put e  >> put es
  put (UOpStat o e)        = tag 10 >> put o  >> put e
  put (AssignStat e1 e2)   = tag 11 >> put e1 >> put e2
  put (UnsatBlock {})      = error "put JStat: UnsatBlock"
  put (AntiStat xs)        = tag 12 >> put xs
  put (LabelStat l s)      = tag 13 >> put l  >> put s
  put (BreakStat ml)       = tag 14 >> put ml
  put (ContinueStat ml)    = tag 15 >> put ml
  get = getTag >>= \case
                      1  -> DeclStat     <$> get
                      2  -> ReturnStat   <$> get
                      3  -> IfStat       <$> get <*> get <*> get
                      4  -> WhileStat    <$> get <*> get <*> get
                      5  -> ForInStat    <$> get <*> get <*> get <*> get
                      6  -> SwitchStat   <$> get <*> get <*> get
                      7  -> TryStat      <$> get <*> get <*> get <*> get
                      8  -> BlockStat    <$> get
                      9  -> ApplStat     <$> get <*> get
                      10 -> UOpStat      <$> get <*> get
                      11 -> AssignStat   <$> get <*> get
                      12 -> AntiStat     <$> get
                      13 -> LabelStat    <$> get <*> get
                      14 -> BreakStat    <$> get
                      15 -> ContinueStat <$> get
                      n -> unexpected ("Objectable get JStat: invalid tag: " ++ show n)

instance Objectable JExpr where
  put (ValExpr v)          = tag 1 >> put v
  put (SelExpr e i)        = tag 2 >> put e  >> put i
  put (IdxExpr e1 e2)      = tag 3 >> put e1 >> put e2
  put (InfixExpr o e1 e2)  = tag 4 >> put o  >> put e1 >> put e2
  put (UOpExpr o e)        = tag 5 >> put o  >> put e
  put (IfExpr e1 e2 e3)    = tag 6 >> put e1 >> put e2 >> put e3
  put (ApplExpr e es)      = tag 7 >> put e  >> put es
  put (UnsatExpr {})       = error "put JExpr: UnsatExpr"
  put (AntiExpr xs)        = tag 8 >> put xs
  get = getTag >>= \case
                      1 -> ValExpr   <$> get
                      2 -> SelExpr   <$> get <*> get
                      3 -> IdxExpr   <$> get <*> get
                      4 -> InfixExpr <$> get <*> get <*> get
                      5 -> UOpExpr   <$> get <*> get
                      6 -> IfExpr    <$> get <*> get <*> get
                      7 -> ApplExpr  <$> get <*> get
                      8 -> AntiExpr  <$> get
                      n -> unexpected ("Objectable get JExpr: invalid tag: " ++ show n)

instance Objectable JVal where
  put (JVar i)      = tag 1 >> put i
  put (JList es)    = tag 2 >> put es
  put (JDouble d)   = tag 3 >> put d
  put (JInt i)      = tag 4 >> put i
  put (JStr xs)     = tag 5 >> put xs
  put (JRegEx xs)   = tag 6 >> put xs
  put (JHash m)     = tag 7 >> put (M.toList m)
  put (JFunc is s)  = tag 8 >> put is >> put s
  put (UnsatVal {}) = error "put JVal: UnsatVal"
  get = getTag >>= \case
                      1 -> JVar    <$> get
                      2 -> JList   <$> get
                      3 -> JDouble <$> get
                      4 -> JInt    <$> get
                      5 -> JStr    <$> get
                      6 -> JRegEx  <$> get
                      7 -> JHash . M.fromList  <$> get
                      8 -> JFunc   <$> get <*> get
                      n -> unexpected ("Objectable get JVal: invalid tag: " ++ show n)

instance Objectable Ident where
  put (TxtI xs) = put xs
  get = TxtI <$> get

instance Objectable Integer where
  put = lift . DB.put
  get = lift DB.get

-- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this
instance Objectable SaneDouble where
  put (SaneDouble d)
    | isNaN d               = tag 1
    | isInfinite d && d > 0 = tag 2
    | isInfinite d && d < 0 = tag 3
    | isNegativeZero d      = tag 4
    | otherwise             = tag 5 >> lift (DB.put d)
  get = getTag >>= \case
                      1 -> pure $ SaneDouble (0    / 0)
                      2 -> pure $ SaneDouble (1    / 0)
                      3 -> pure $ SaneDouble ((-1) / 0)
                      4 -> pure $ SaneDouble (-0)
                      5 -> SaneDouble <$> lift DB.get
                      n -> unexpected ("Objectable get SaneDouble: invalid tag: " ++ show n)

instance Objectable ClosureInfo where
  put (ClosureInfo v regs name layo typ static) = do
    put v >> put regs >> put name >> put layo >> put typ >> put static
  get = ClosureInfo <$> get <*> get <*> get <*> get <*> get <*> get

instance Objectable JSFFIType where
  put = putEnum
  get = getEnum

instance Objectable VarType where
  put = putEnum
  get = getEnum

instance Objectable CIRegs where
  put CIRegsUnknown       = tag 1
  put (CIRegs skip types) = tag 2 >> putIW16 skip >> put types
  get = getTag >>= \case
                      1 -> pure CIRegsUnknown
                      2 -> CIRegs <$> getIW16 <*> get
                      n -> unexpected ("Objectable get CIRegs: invalid tag: " ++ show n)
instance Objectable JOp where
  put = putEnum
  get = getEnum

instance Objectable JUOp where
  put = putEnum
  get = getEnum

-- 16 bit sizes should be enough...
instance Objectable CILayout where
  put CILayoutVariable           = tag 1
  put (CILayoutUnknown size)     = tag 2 >> putIW16 size
  put (CILayoutFixed size types) = tag 3 >> putIW16 size >> put types
  get = getTag >>= \case
                      1 -> pure CILayoutVariable
                      2 -> CILayoutUnknown <$> getIW16
                      3 -> CILayoutFixed   <$> getIW16 <*> get
                      n -> unexpected ("Objectable get CILayout: invalid tag: " ++ show n)

instance Objectable CIStatic where
  put (CIStaticRefs refs) = tag 1 >> put refs
  get = getTag >>= \case
                      1 -> CIStaticRefs <$> get
                      n -> unexpected ("Objectable get CIStatic: invalid tag: " ++ show n)

instance Objectable CIType where
  put (CIFun arity regs) = tag 1 >> putIW16 arity >> putIW16 regs
  put CIThunk            = tag 2
  put (CICon conTag)     = tag 3 >> putIW16 conTag
  put CIPap              = tag 4
  put CIBlackhole        = tag 5
  put CIStackFrame       = tag 6
  get = getTag >>= \case
                      1 -> CIFun <$> getIW16 <*> getIW16
                      2 -> pure CIThunk
                      3 -> CICon <$> getIW16
                      4 -> pure CIPap
                      5 -> pure CIBlackhole
                      6 -> pure CIStackFrame
                      n -> unexpected ("Objectable get CIType: invalid tag: " ++ show n)

-- put an Int as a Word16, little endian. useful for many small values
putIW16 :: Int -> PutS
putIW16 i | i > 65535 || i < 0 = error ("putIW16: out of range: " ++ show i)
          | otherwise          = lift $ DB.putWord16le (fromIntegral i)

getIW16 :: GetS Int
getIW16 = lift (fmap fromIntegral DB.getWord16le)

-- the binary instance stores ints as 64 bit
instance Objectable Int where
  put = lift . DB.put
  get = lift DB.get

instance Objectable Fun where
  put (Fun pkg modu symb) = put pkg >> put modu >> put symb
  get = Fun <$> get <*> get <*> get

instance Objectable Package where
  put (Package k) = put k
  get = Package <$> get

putEnum :: Enum a => a -> PutS
putEnum x | n > 65535 = error ("putEnum: out of range: " ++ show n)
          | otherwise = putIW16 n
  where n = fromEnum x

getEnum :: Enum a => GetS a
getEnum = toEnum <$> getIW16

instance Objectable Bool where
  put False = tag 1
  put True  = tag 2
  get = getTag >>= \case
                      1 -> return False
                      2 -> return True
                      n -> unexpected ("Objectable get Bool: invalid tag: " ++ show n)

instance Objectable StaticInfo where
  put (StaticInfo ident val cc) = put ident >> put val >> put cc
  get = StaticInfo <$> get <*> get <*> get

instance Objectable StaticVal where
  put (StaticFun f)        = tag 1 >> put f
  put (StaticThunk t)      = tag 2 >> put t
  put (StaticUnboxed u)    = tag 3 >> put u
  put (StaticData dc args) = tag 4 >> put dc >> put args
  put (StaticList xs t)    = tag 5 >> put xs >> put t
  get = getTag >>= \case
                      1 -> StaticFun     <$> get
                      2 -> StaticThunk   <$> get
                      3 -> StaticUnboxed <$> get
                      4 -> StaticData    <$> get <*> get
                      5 -> StaticList    <$> get <*> get
                      n -> unexpected ("Objectable get StaticVal: invalid tag " ++ show n)

instance Objectable StaticUnboxed where
   put (StaticUnboxedBool b)   = tag 1 >> put b
   put (StaticUnboxedInt i)    = tag 2 >> put i
   put (StaticUnboxedDouble d) = tag 3 >> put d
   get = getTag >>= \case
                       1 -> StaticUnboxedBool   <$> get
                       2 -> StaticUnboxedInt    <$> get
                       3 -> StaticUnboxedDouble <$> get
                       n -> unexpected ("Objectable get StaticUnboxed: invalid tag " ++ show n)

instance Objectable StaticArg where
  put (StaticObjArg i)      = tag 1 >> put i
  put (StaticLitArg p)      = tag 2 >> put p
  put (StaticConArg c args) = tag 3 >> put c >> put args
  get = getTag >>= \case
                      1 -> StaticObjArg <$> get
                      2 -> StaticLitArg <$> get
                      3 -> StaticConArg <$> get <*> get
                      n -> unexpected ("Objectable get StaticArg: invalid tag " ++ show n)

instance Objectable StaticLit where
  put (BoolLit b)    = tag 1 >> put b
  put (IntLit i)     = tag 2 >> put i
  put NullLit        = tag 3
  put (DoubleLit d)  = tag 4 >> put d
  put (StringLit t)  = tag 5 >> put t
  put (BinLit b)     = tag 6 >> put b
  put (LabelLit b t) = tag 7 >> put b >> put t
  get = getTag >>= \case
                      1 -> BoolLit   <$> get
                      2 -> IntLit    <$> get
                      3 -> pure NullLit
                      4 -> DoubleLit <$> get
                      5 -> StringLit <$> get
                      6 -> BinLit    <$> get
                      7 -> LabelLit  <$> get <*> get
                      n -> unexpected ("Objectable get StaticLit: invalid tag " ++ show n)

instance Objectable BS.ByteString where
  put = lift . DB.put
  get = lift DB.get

