Binary.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Binary instances for JSTarget types.
module Haste.AST.Binary () where
import Prelude hiding (LT, GT)
import Data.Binary
import Data.Array
import Control.Applicative
import Haste.AST.Syntax
import Haste.AST.Op

instance Binary Module where
  put (Module pkgid name deps defs) =
    put pkgid >> put name >> put deps >> put defs
  get = Module <$> get <*> get <*> get <*> get

instance Binary Var where
  put (Foreign str) =
    putWord8 0 >> put str
  put (Internal name comment knownloc) =
    putWord8 1 >> put name >> put comment >> put knownloc

  get = do
    which <- getWord8
    case which of
      0 -> Foreign <$> get
      1 -> Internal <$> get <*> get <*> get

instance Binary LHS where
  put (NewVar r v) = putWord8 0 >> put r >> put v
  put (LhsExp r e) = putWord8 1 >> put r >> put e
  
  get = getWord8 >>= ([NewVar <$> get <*> get,
                       LhsExp <$> get <*> get] !!) . fromIntegral

instance Binary Call where
  put (Normal tr) = putWord8 0 >> put tr
  put (Fast tr)   = putWord8 1 >> put tr
  put (Method m)  = putWord8 2 >> put m
  
  get = do
    tag <- fromIntegral <$> getWord8
    [Normal <$> get, Fast <$> get,Method <$> get] !! tag

instance Binary Lit where
  put (LNum d)  = putWord8 0 >> put d
  put (LStr s)  = putWord8 1 >> put s
  put (LBool b) = putWord8 2 >> put b
  put (LInt n)  = putWord8 3 >> put n
  put (LNull)   = putWord8 4
  
  get = do
    t <- getWord8
    [LNum <$> get, LStr <$> get, LBool <$> get, LInt <$> get, pure LNull] !!
      fromIntegral t

instance Binary Exp where
  put (Var v)         = putWord8 0 >> put v
  put (Lit l)         = putWord8 1 >> put l
  put (JSLit l)       = putWord8 2 >> put l
  put (Not ex)        = putWord8 3 >> put ex
  put (BinOp op a b)  = putWord8 4 >> put op >> put a >> put b
  put (Fun as body)   = putWord8 5 >> put as >> put body
  put (Call a c f xs) = putWord8 6 >> put a >> put c >> put f >> put xs
  put (Index arr ix)  = putWord8 7 >> put arr >> put ix
  put (Arr exs)       = putWord8 8 >> put exs
  put (AssignEx l r)  = putWord8 9 >> put l >> put r
  put (IfEx c th el)  = putWord8 10 >> put c >> put th >> put el
  put (Eval x)        = putWord8 11 >> put x
  put (Thunk upd x)   = putWord8 12 >> put upd >> put x
  put (Member o m)    = putWord8 13 >> put o >> put m
  put (Obj xs)        = putWord8 14 >> put xs
  
  get = do
    tag <- getWord8
    case tag of
      0  -> Var <$> get
      1  -> Lit <$> get
      2  -> JSLit <$> get
      3  -> Not <$> get
      4  -> BinOp <$> get <*> get <*> get
      5  -> Fun <$> get <*> get
      6  -> Call <$> get <*> get <*> get <*> get
      7  -> Index <$> get <*> get
      8  -> Arr <$> get
      9  -> AssignEx <$> get <*> get
      10  -> IfEx <$> get <*> get <*> get
      11 -> Eval <$> get
      12 -> Thunk <$> get <*> get
      13 -> Member <$> get <*> get
      14 -> Obj <$> get
      n  -> error $ "Bad tag in get :: Get Exp: " ++ show n

instance Binary Stm where
  put (Case e def alts next) =
    putWord8 0 >> put e >> put def >> put alts >> put next
  put (Forever stm) =
    putWord8 1 >> put stm
  put (Assign lhs rhs next) =
    putWord8 2 >> put lhs >> put rhs >> put next
  put (Return ex) =
    putWord8 3 >> put ex
  put (Cont) =
    putWord8 4
  put (Stop) =
    putWord8 5
  put (Tailcall ex) =
    putWord8 6 >> put ex
  put (ThunkRet ex) =
    putWord8 7 >> put ex
  
  get = do
    tag <- getWord8
    case tag of
      0 -> Case <$> get <*> get <*> get <*> get
      1 -> Forever <$> get
      2 -> Assign <$> get <*> get <*> get
      3 -> Return <$> get
      4 -> pure Cont
      5 -> pure Stop
      6 -> Tailcall <$> get
      7 -> ThunkRet <$> get
      n -> error $ "Bad tag in get :: Get Stm: " ++ show n

instance Binary BinOp where
  put Add       = putWord8 0
  put Mul       = putWord8 1
  put Sub       = putWord8 2
  put Div       = putWord8 3
  put Mod       = putWord8 4
  put And       = putWord8 5
  put Or        = putWord8 6
  put Eq        = putWord8 7
  put StrictEq  = putWord8 8
  put Neq       = putWord8 9
  put StrictNeq = putWord8 10
  put LT        = putWord8 11
  put GT        = putWord8 12
  put LTE       = putWord8 13
  put GTE       = putWord8 14
  put Shl       = putWord8 15
  put ShrL      = putWord8 16
  put ShrA      = putWord8 17
  put BitAnd    = putWord8 18
  put BitOr     = putWord8 19
  put BitXor    = putWord8 20

  get = (opTbl !) <$> getWord8

instance Binary Name where
  put (Name name owner) = put name >> put owner
  get = Name <$> get <*> get

opTbl :: Array Word8 BinOp
opTbl =
    listArray (0, arrLen-1) es
  where
    arrLen = fromIntegral $ length es
    es = [Add, Mul, Sub, Div, Mod, And,  Or,   Eq,     StrictEq, Neq, StrictNeq,
          LT,  GT,  LTE, GTE, Shl, ShrL, ShrA, BitAnd, BitOr,    BitXor]