mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-23 08:18:04 +03:00
add the "more instructions" marker, most of the time
This commit is contained in:
Arya Irani
parent
3de9756900
commit
df91671f3b
@ -3,6 +3,7 @@
|
||||
module Unison.Codecs where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.State
|
||||
import qualified Data.ByteString as B
|
||||
import Data.ByteString.Builder (doubleBE, int64BE, toLazyByteString)
|
||||
@ -24,127 +25,129 @@ import Data.Int (Int64)
|
||||
type Pos = Word64
|
||||
|
||||
serializeTerm :: (MonadPut m, MonadState Pos m, Var v) => Term v -> m Pos
|
||||
serializeTerm x = do
|
||||
case ABT.out x of
|
||||
ABT.Var v -> do
|
||||
putWord8 0
|
||||
lengthEncode $ Var.qualifiedName v
|
||||
ABT.Abs v body -> do
|
||||
pbody <- serializeTerm body
|
||||
putWord8 1
|
||||
lengthEncode $ Var.qualifiedName v
|
||||
putBackref pbody
|
||||
ABT.Cycle body -> do
|
||||
pbody <- serializeTerm body
|
||||
putWord8 10
|
||||
putBackref pbody
|
||||
ABT.Tm f -> case f of
|
||||
Ref ref -> do
|
||||
putWord8 2
|
||||
serializeReference ref
|
||||
Constructor ref id -> do
|
||||
putWord8 3
|
||||
serializeReference ref
|
||||
putWord32be $ fromIntegral id
|
||||
Request ref id -> do
|
||||
putWord8 4
|
||||
serializeReference ref
|
||||
putWord32be $ fromIntegral id
|
||||
Text text -> do
|
||||
putWord8 5
|
||||
lengthEncode text
|
||||
Int64 n -> do
|
||||
putWord8 6
|
||||
serializeInt64 n
|
||||
UInt64 n -> do
|
||||
putWord8 6
|
||||
serializeUInt64 n
|
||||
Float n -> do
|
||||
putWord8 6
|
||||
serializeFloat n
|
||||
Boolean b -> do
|
||||
putWord8 6
|
||||
serializeBoolean b
|
||||
Vector v -> do
|
||||
elementPositions <- traverse serializeTerm v
|
||||
putWord8 7
|
||||
putLength $ length elementPositions
|
||||
traverse_ putBackref elementPositions
|
||||
Lam body -> do
|
||||
pos <- serializeTerm body
|
||||
putWord8 8
|
||||
putBackref pos
|
||||
App fn arg -> do
|
||||
posf <- serializeTerm fn
|
||||
posarg <- serializeTerm arg
|
||||
putWord8 9
|
||||
putBackref posf
|
||||
putLength (1 :: Int)
|
||||
putBackref posarg
|
||||
Let binding body -> do
|
||||
posbind <- serializeTerm binding
|
||||
posbod <- serializeTerm body
|
||||
putWord8 11
|
||||
putBackref posbind
|
||||
putBackref posbod
|
||||
If c t f -> do
|
||||
posc <- serializeTerm c
|
||||
post <- serializeTerm t
|
||||
posf <- serializeTerm f
|
||||
putWord8 12
|
||||
putBackref posc
|
||||
putBackref post
|
||||
putBackref posf
|
||||
And x y -> do
|
||||
posx <- serializeTerm x
|
||||
posy <- serializeTerm y
|
||||
putWord8 13
|
||||
putBackref posx
|
||||
putBackref posy
|
||||
Or x y -> do
|
||||
posx <- serializeTerm x
|
||||
posy <- serializeTerm y
|
||||
putWord8 14
|
||||
putBackref posx
|
||||
putBackref posy
|
||||
Match scrutinee cases -> do
|
||||
poss <- serializeTerm scrutinee
|
||||
casePositions <- traverse serializeCase1 cases
|
||||
putWord8 15
|
||||
putBackref poss
|
||||
putLength $ length casePositions
|
||||
traverse_ serializeCase2 casePositions
|
||||
Blank -> error "cannot serialize program with blanks"
|
||||
Handle h body -> do
|
||||
hpos <- serializeTerm h
|
||||
bpos <- serializeTerm body
|
||||
putWord8 16
|
||||
putBackref hpos
|
||||
putBackref bpos
|
||||
EffectPure t -> do
|
||||
pos <- serializeTerm t
|
||||
putWord8 17
|
||||
putBackref pos
|
||||
EffectBind r cid args k -> do
|
||||
positions <- traverse serializeTerm args
|
||||
kpos <- serializeTerm k
|
||||
putWord8 18
|
||||
serializeReference r
|
||||
putWord32be $ fromIntegral cid
|
||||
putLength $ length positions
|
||||
traverse_ putBackref positions
|
||||
putBackref kpos
|
||||
Ann e _ -> void $ serializeTerm e -- ignore types (todo: revisit)
|
||||
LetRec bs body -> do
|
||||
positions <- traverse serializeTerm bs
|
||||
serializeTerm x = go x False where
|
||||
go x ghettoThingToSkip111 = do
|
||||
when (not ghettoThingToSkip111) (putWord8 111)
|
||||
case ABT.out x of
|
||||
ABT.Var v -> do
|
||||
putWord8 0
|
||||
lengthEncode $ Var.qualifiedName v
|
||||
ABT.Abs v body -> do
|
||||
pbody <- serializeTerm body
|
||||
putWord8 19
|
||||
putLength $ length positions
|
||||
traverse_ putBackref positions
|
||||
putWord8 1
|
||||
lengthEncode $ Var.qualifiedName v
|
||||
putBackref pbody
|
||||
pos <- get
|
||||
modify' (+1)
|
||||
pure pos
|
||||
ABT.Cycle body -> do
|
||||
pbody <- serializeTerm body
|
||||
putWord8 10
|
||||
putBackref pbody
|
||||
ABT.Tm f -> case f of
|
||||
Ann e _ -> void $ go e True -- ignore types (todo: revisit)
|
||||
Ref ref -> do
|
||||
putWord8 2
|
||||
serializeReference ref
|
||||
Constructor ref id -> do
|
||||
putWord8 3
|
||||
serializeReference ref
|
||||
putWord32be $ fromIntegral id
|
||||
Request ref id -> do
|
||||
putWord8 4
|
||||
serializeReference ref
|
||||
putWord32be $ fromIntegral id
|
||||
Text text -> do
|
||||
putWord8 5
|
||||
lengthEncode text
|
||||
Int64 n -> do
|
||||
putWord8 6
|
||||
serializeInt64 n
|
||||
UInt64 n -> do
|
||||
putWord8 6
|
||||
serializeUInt64 n
|
||||
Float n -> do
|
||||
putWord8 6
|
||||
serializeFloat n
|
||||
Boolean b -> do
|
||||
putWord8 6
|
||||
serializeBoolean b
|
||||
Vector v -> do
|
||||
elementPositions <- traverse serializeTerm v
|
||||
putWord8 7
|
||||
putLength $ length elementPositions
|
||||
traverse_ putBackref elementPositions
|
||||
Lam body -> do
|
||||
pos <- serializeTerm body
|
||||
putWord8 8
|
||||
putBackref pos
|
||||
App fn arg -> do
|
||||
posf <- serializeTerm fn
|
||||
posarg <- serializeTerm arg
|
||||
putWord8 9
|
||||
putBackref posf
|
||||
putLength (1 :: Int)
|
||||
putBackref posarg
|
||||
Let binding body -> do
|
||||
posbind <- serializeTerm binding
|
||||
posbod <- serializeTerm body
|
||||
putWord8 11
|
||||
putBackref posbind
|
||||
putBackref posbod
|
||||
If c t f -> do
|
||||
posc <- serializeTerm c
|
||||
post <- serializeTerm t
|
||||
posf <- serializeTerm f
|
||||
putWord8 12
|
||||
putBackref posc
|
||||
putBackref post
|
||||
putBackref posf
|
||||
And x y -> do
|
||||
posx <- serializeTerm x
|
||||
posy <- serializeTerm y
|
||||
putWord8 13
|
||||
putBackref posx
|
||||
putBackref posy
|
||||
Or x y -> do
|
||||
posx <- serializeTerm x
|
||||
posy <- serializeTerm y
|
||||
putWord8 14
|
||||
putBackref posx
|
||||
putBackref posy
|
||||
Match scrutinee cases -> do
|
||||
poss <- serializeTerm scrutinee
|
||||
casePositions <- traverse serializeCase1 cases
|
||||
putWord8 15
|
||||
putBackref poss
|
||||
putLength $ length casePositions
|
||||
traverse_ serializeCase2 casePositions
|
||||
Blank -> error "cannot serialize program with blanks"
|
||||
Handle h body -> do
|
||||
hpos <- serializeTerm h
|
||||
bpos <- serializeTerm body
|
||||
putWord8 16
|
||||
putBackref hpos
|
||||
putBackref bpos
|
||||
EffectPure t -> do
|
||||
pos <- serializeTerm t
|
||||
putWord8 17
|
||||
putBackref pos
|
||||
EffectBind r cid args k -> do
|
||||
positions <- traverse serializeTerm args
|
||||
kpos <- serializeTerm k
|
||||
putWord8 18
|
||||
serializeReference r
|
||||
putWord32be $ fromIntegral cid
|
||||
putLength $ length positions
|
||||
traverse_ putBackref positions
|
||||
putBackref kpos
|
||||
LetRec bs body -> do
|
||||
positions <- traverse serializeTerm bs
|
||||
pbody <- serializeTerm body
|
||||
putWord8 19
|
||||
putLength $ length positions
|
||||
traverse_ putBackref positions
|
||||
putBackref pbody
|
||||
pos <- get
|
||||
modify' (+1)
|
||||
pure pos
|
||||
|
||||
serializePattern :: MonadPut m => Pattern -> m ()
|
||||
serializePattern p = case p of
|
||||
|
||||
Loading…
Reference in New Issue
Block a user