module SMR.Codec.Poke
( pokeFileDecls
, pokeDecl
, pokeExp, pokeKey, pokeParam
, pokeCar, pokeSnvBind, pokeUpsBump
, pokeRef
, pokeName, pokeBump, pokeNom
, pokeWord8, pokeWord16, pokeWord32, pokeWord64)
where
import SMR.Core.Exp
import SMR.Prim.Op.Base
import qualified Foreign.Marshal.Utils as F
import qualified Foreign.Storable as F
import qualified Foreign.Ptr as F
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Unsafe as BS
import Data.Text (Text)
import Foreign.Ptr (Ptr)
import Control.Monad
import Data.Bits
import Data.Word
type Poke a = a -> Ptr Word8 -> IO (Ptr Word8)
pokeFileDecls :: Poke [Decl Text Prim]
pokeFileDecls ds
= pokeWord8 0x53
>=> pokeWord8 0x4d
>=> pokeWord8 0x52
>=> pokeWord8 0x31
>=> pokeList pokeDecl ds
pokeDecl :: Poke (Decl Text Prim)
pokeDecl xx
= case xx of
DeclMac name x
-> pokeWord8 0xa1 >=> pokeText name >=> pokeExp x
DeclSet name x
-> pokeWord8 0xa2 >=> pokeText name >=> pokeExp x
pokeExp :: Poke (Exp Text Prim)
pokeExp xx
= case xx of
XRef ref
-> pokeWord8 0xb1 >=> pokeRef ref
XKey key x
-> pokeWord8 0xb2 >=> pokeKey key >=> pokeExp x
XApp x1 xs
-> pokeWord8 0xb3 >=> pokeExp x1 >=> pokeList pokeExp xs
XVar name i
-> pokeWord8 0xb4 >=> pokeName name >=> pokeBump i
XAbs ps x
-> pokeWord8 0xb5 >=> pokeList pokeParam ps >=> pokeExp x
XSub cs x
-> pokeWord8 0xb6 >=> pokeList pokeCar cs >=> pokeExp x
pokeKey :: Poke Key
pokeKey key
= case key of
KBox -> pokeWord8 0xba
KRun -> pokeWord8 0xbb
pokeParam :: Poke Param
pokeParam pp
= case pp of
PParam tx PVal
-> pokeWord8 0xbc >=> pokeName tx
PParam tx PExp
-> pokeWord8 0xbd >=> pokeName tx
pokeCar :: Poke (Car Text Prim)
pokeCar car
= case car of
CSim (SSnv sbs)
-> pokeWord8 0xc1 >=> pokeList pokeSnvBind sbs
CRec (SSnv sbs)
-> pokeWord8 0xc2 >=> pokeList pokeSnvBind sbs
CUps (UUps ups)
-> pokeWord8 0xc3 >=> pokeList pokeUpsBump ups
pokeSnvBind :: Poke (SnvBind Text Prim)
pokeSnvBind !b
= case b of
BindVar n d x
-> pokeWord8 0xca >=> pokeName n >=> pokeBump d >=> pokeExp x
BindNom n x
-> pokeWord8 0xcb >=> pokeNom n >=> pokeExp x
pokeUpsBump :: Poke UpsBump
pokeUpsBump ((n, d), i)
= pokeWord8 0xcc >=> pokeName n >=> pokeBump d >=> pokeBump i
pokeRef :: Poke (Ref Text Prim)
pokeRef !r
= case r of
RSym tx -> pokeWord8 0xd1 >=> pokeName tx
RPrm p -> pokeWord8 0xd2 >=> pokePrim p
RMac tx -> pokeWord8 0xd3 >=> pokeName tx
RSet tx -> pokeWord8 0xd4 >=> pokeName tx
RNom i -> pokeWord8 0xd5 >=> pokeNom i
pokeName :: Poke Name
pokeName !p n
= pokeText p n
pokeBump :: Poke Integer
pokeBump !n !p
= if n <= 2^(16 :: Int) then
do pokeWord16 (fromIntegral n) p
else error "shimmer.pokeBump: bump counter too large."
pokeNom :: Poke Integer
pokeNom !n !p
= if n <= 2^(28 :: Int) then
do pokeWord32 (fromIntegral n) p
else error "shimmer.pokeNom: nominal constant index too large."
pokePrim :: Poke Prim
pokePrim !pp
= case pp of
PrimTagUnit -> pokeWord8 0xda
PrimLitBool True -> pokeWord8 0xdb
PrimLitBool False -> pokeWord8 0xdc
PrimOp tx -> pokeWord8 0xdf >=> pokeText tx
PrimLitNat n
-> pokeWord8 0xef
>=> pokeName (T.pack "nat")
>=> pokeList pokeWord8
[ fromIntegral $ (n .&. 0xff00000000000000) `shiftR` 56
, fromIntegral $ (n .&. 0x00ff000000000000) `shiftR` 48
, fromIntegral $ (n .&. 0x0000ff0000000000) `shiftR` 40
, fromIntegral $ (n .&. 0x000000ff00000000) `shiftR` 32
, fromIntegral $ (n .&. 0x00000000ff000000) `shiftR` 24
, fromIntegral $ (n .&. 0x0000000000ff0000) `shiftR` 16
, fromIntegral $ (n .&. 0x000000000000ff00) `shiftR` 8
, fromIntegral $ (n .&. 0x00000000000000ff)]
PrimTagList{} -> error "TODO: pokePrim: handle lists"
pokeList :: Poke a -> Poke [a]
pokeList pokeA ls
= do let n = length ls
if n <= 2^(8 :: Int) 1
then pokeWord8 0xf1 >=> pokeWord8 (fromIntegral n) >=> go ls
else if n <= 2^(16 :: Int) 1
then pokeWord8 0xf2 >=> pokeWord16 (fromIntegral n) >=> go ls
else if n <= 2^(28 :: Int)
then pokeWord8 0xf2 >=> pokeWord32 (fromIntegral n) >=> go ls
else error "shimmer.pokeList: list too long."
where go [] !p0 = return p0
go (x : xs) !p0
= do p1 <- pokeA x p0
go xs p1
pokeText :: Poke Text
pokeText !tx !p0
= do let bs = T.encodeUtf8 tx
BS.unsafeUseAsCStringLen bs $ \(pStr, nBytes)
-> if nBytes <= 255 then
do p1 <- pokeWord8 0xf1 p0
p2 <- pokeWord8 (fromIntegral nBytes) p1
F.copyBytes (F.castPtr p2) pStr nBytes
return (F.plusPtr p2 nBytes)
else if nBytes <= 65535 then
do p1 <- pokeWord8 0xf2 p0
p2 <- pokeWord16 (fromIntegral nBytes) p1
F.copyBytes (F.castPtr p2) pStr nBytes
return (F.plusPtr p2 nBytes)
else if nBytes <= 2^(28 :: Int) then
do p1 <- pokeWord8 0xf3 p0
p2 <- pokeWord32 (fromIntegral nBytes) p1
F.copyBytes (F.castPtr p2) pStr nBytes
return (F.plusPtr p2 nBytes)
else error "shimmer.pokeText: text string too large."
pokeWord8 :: Poke Word8
pokeWord8 w p
= do F.poke p w
return (F.plusPtr p 1)
pokeWord16 :: Poke Word16
pokeWord16 w p
= do poke8 p 0 $ from16 $ (w .&. 0xff00) `shiftR` 8
poke8 p 1 $ from16 $ (w .&. 0x00ff)
return (F.plusPtr p 2)
pokeWord32 :: Poke Word32
pokeWord32 w p
= do poke8 p 0 $ from32 $ (w .&. 0xff000000) `shiftR` 24
poke8 p 1 $ from32 $ (w .&. 0x00ff0000) `shiftR` 16
poke8 p 2 $ from32 $ (w .&. 0x0000ff00) `shiftR` 8
poke8 p 3 $ from32 $ (w .&. 0x000000ff)
return (F.plusPtr p 4)
pokeWord64 :: Poke Word64
pokeWord64 w p
= do poke8 p 0 $ from64 $ (w .&. 0xff00000000000000) `shiftR` 56
poke8 p 1 $ from64 $ (w .&. 0x00ff000000000000) `shiftR` 48
poke8 p 2 $ from64 $ (w .&. 0x0000ff0000000000) `shiftR` 40
poke8 p 3 $ from64 $ (w .&. 0x000000ff00000000) `shiftR` 32
poke8 p 4 $ from64 $ (w .&. 0x00000000ff000000) `shiftR` 24
poke8 p 5 $ from64 $ (w .&. 0x0000000000ff0000) `shiftR` 16
poke8 p 6 $ from64 $ (w .&. 0x000000000000ff00) `shiftR` 8
poke8 p 7 $ from64 $ (w .&. 0x00000000000000ff)
return (F.plusPtr p 8)
from16 :: Word16 -> Word8
from16 = fromIntegral
from32 :: Word32 -> Word8
from32 = fromIntegral
from64 :: Word64 -> Word8
from64 = fromIntegral
poke8 :: Ptr a -> Int -> Word8 -> IO ()
poke8 p i w = F.pokeByteOff p i w