content: {-
    Copyright (c) Meta Platforms, Inc. and affiliates.
    All rights reserved.
  
    This source code is licensed under the BSD-style license found in the
    LICENSE file in the root directory of this source tree.
  -}
  
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE DerivingStrategies #-}
  {-# LANGUAGE RecursiveDo #-}
  {-# LANGUAGE CPP #-}
  module Glean.Query.Transform
    ( transformationsFor
    , transformResultsBack
    , ResultTransformations
    , transformType
    , transformBytes
    , transformPattern
    , transformFact
    , skipTrusted
    , buildTerm
    , isWordTy
    , isByteTy
    , defaultValue
    ) where
  
  import Control.Monad
  #if MIN_VERSION_mtl(2,3,1)
  import Control.Monad.Cont hiding (label)
  #else
  import Control.Monad.Cont
  #endif
  import Data.Bifoldable
  import Data.Bifunctor (bimap)
  import qualified Data.ByteString as ByteString
  import Data.Coerce (Coercible, coerce)
  import Data.Either (isLeft)
  import Data.Either.Extra (fromEither)
  import Data.Function (fix)
  import qualified Data.Map.Strict as Map
  import Data.Map.Strict (Map)
  import Data.Maybe (fromMaybe, mapMaybe, isJust)
  import qualified Data.IntMap.Strict as IntMap
  import Data.IntMap.Strict (IntMap)
  import Data.Text (Text, unpack)
  import qualified Data.Text as Text
  import Data.Vector (Vector, (!))
  import qualified Data.Set as Set
  import Data.Set (Set)
  import Data.Word (Word64)
  
  import Glean.Angle.Types (Type_(..), FieldDef_(..), Name)
  import Glean.Bytecode.Types (Ty(..))
  import Glean.Schema.Util (lowerEnum, lowerMaybe, showRef)
  import Glean.Query.Codegen.QueryRegs
  import Glean.Query.Codegen.Types
    ( Match(..)
    , Var(..)
    , Typed(..)
    , Output
    , TransformAndBind(..) )
  import Glean.Database.Schema.Types
  import qualified Glean.RTS as RTS
  import Glean.RTS.Bytecode.Code
  import Glean.RTS.Bytecode.Gen.Issue
  import Glean.RTS.Foreign.Query (QueryResults(..))
  import Glean.RTS.Types as RTS
  import Glean.RTS.Term (Term(..), Value)
  import qualified Glean.Types as Thrift
  
  -- | Predicate transformations to be applied to a query's result. Keyed by the
  -- predicate to be transformed. i.e. the one available in the database.
  newtype ResultTransformations =
    ResultTransformations (IntMap PredicateTransformation)
    deriving newtype (Semigroup, Monoid)
  
  -- | Transformations for a type and all its transitively nested types
  -- It is an error if the type uses multiple versions of the same predicate.
  transformationsFor
    :: DbSchema
    -> QueryTransformations
    -> Type
    -> Either Text ResultTransformations
  transformationsFor schema qtrans ty =
    if null repeated
    then Right transformations
    else Left $ "multiple versions of evolved predicates: "
        <> Text.unlines (map showRepeated repeated)
    where
      detailsFor pid = case lookupPid pid schema of
        Nothing -> error $ "unknown predicate " <> show pid
        Just details -> details
  
      inType :: [Pid]
      inType = filter (needsTransformation qtrans) (getPids ty)
        where getPids = bifoldMap (pure . pid) (getPids . expandType)
              expandType (ExpandedType _ t) = t
  
      withDeps :: [Pid]
      withDeps = Set.toList $ foldr addDeps mempty inType
        where
        addDeps :: Pid -> Set Pid -> Set Pid
        addDeps pid seen = foldr Set.insert seen deps
          where deps = transitiveDeps detailsFor seen pid
  
      -- predicates available are mapped to the predicates requested
      mappings :: Map Pid (Set Pid)
      mappings =
        Map.fromListWith (<>)
          [ (to, Set.singleton from)
          | from <- withDeps
          , let to = case lookupTransformation from qtrans of
                  Nothing -> from
                  Just e -> pid $ tAvailable e
          ]
  
      repeated :: [(Pid, Set Pid)]
      repeated = Map.toList $ Map.filter ((> 1) . Set.size) mappings
  
      transformations :: ResultTransformations
      transformations = ResultTransformations $ IntMap.fromList
        [ (to, evolution)
        | evolution <- mapMaybe (`lookupTransformation` qtrans) withDeps
        , let to = fromIntegral $ fromPid $ pid  $ tAvailable evolution
        ]
  
      showRepeated :: (Pid, Set Pid) -> Text
      showRepeated (to, froms) =
        showPid to <> " evolves "
        <> Text.intercalate " and " (showPid <$> Set.toList froms)
        where showPid = showRef . predicateRef . detailsFor
  
  pid :: PidRef -> Pid
  pid (PidRef x _) = x
  
  -- ========================
  -- Transform back
  -- ========================
  
  -- | Transform facts back into the type the query originally asked for.
  transformResultsBack :: ResultTransformations -> QueryResults -> QueryResults
  transformResultsBack (ResultTransformations trans) results@QueryResults{..}
    | IntMap.null trans = results
    | otherwise = results
      { queryResultsFacts = overFacts queryResultsFacts
      , queryResultsNestedFacts = overFacts queryResultsNestedFacts
      }
    where
      overFacts :: Vector (Fid, Thrift.Fact) -> Vector (Fid, Thrift.Fact)
      overFacts = fmap (fmap overFact)
  
      overFact :: Thrift.Fact -> Thrift.Fact
      overFact fact@(Thrift.Fact pid _ _) =
        case IntMap.lookup (fromIntegral pid) trans of
          Nothing -> fact
          Just PredicateTransformation{..} -> tTransformFactBack fact
  
  -- ===========================================================================
  -- Byte code manipulation
  -- ===========================================================================
  
  -- | Generate code to skip over a value of the given type in the input
  --
  skipTrusted
    :: Register 'DataPtr
    -> Register 'DataPtr
    -> Type
    -> Code ()
  skipTrusted input inputend ty = skip (repType ty)
    where
    skip ty = case ty of
      ByteRep -> do size <- constant 1; inputBytes input inputend size
      NatRep -> inputSkipNat input inputend
      ArrayRep eltTy ->
        local $ \size -> do
          inputNat input inputend size
          case eltTy of
            ByteRep -> inputBytes input inputend size
            _ -> mdo
              jumpIf0 size end
              loop2 <- label
              skip eltTy
              decrAndJumpIfNot0 size loop2
              end <- label
              return ()
      TupleRep tys -> mapM_ skip tys
      SumRep tys
        | all isEmpty tys -> inputSkipNat input inputend
        | otherwise -> mdo
        local $ \sel -> do
          inputNat input inputend sel
          let unknown = [end]
          select sel (alts ++ unknown)
        raise "selector out of range"
        alts <- forM tys $ \ty -> do
          -- TODO: for (Tuple []) we don't need to generate any bytecode
          alt <- label
          skip ty
          jump end
          return alt
        end <- label
        return ()
      SetRep eltTy ->
        local $ \size -> do
          inputNat input inputend size
          case eltTy of
            ByteRep -> inputBytes input inputend size
            _ -> mdo
              jumpIf0 size end
              loop2 <- label
              skip eltTy
              decrAndJumpIfNot0 size loop2
              end <- label
              return ()
      StringRep -> inputSkipTrustedString input inputend
      PredicateRep _ -> inputSkipNat input inputend
  
    -- Empty tuples and empty records do not take any bytes
    isEmpty = \case
      TupleRep fields -> all isEmpty fields
      _ -> False
  
  -- | Serialize a term into the given output register.
  buildTerm
    :: Register 'BinaryOutputPtr
    -> Vector (Register 'Word)
    -> Term (Match () Var)
    -> Code ()
  buildTerm out vars term = go term
    where
    go term = case term of
      Byte b -> outputByteImm (fromIntegral b) out
      Nat n -> outputNatImm n out
      String s ->
        local $ \ptr end -> do
          -- NOTE: We assume that the string has been validated during parsing.
          loadLiteral (RTS.mangleString s) ptr end
          outputBytes ptr end out
      Array vs -> do
        outputNatImm (fromIntegral (length vs)) out
        mapM_ go vs
      Tuple fields -> mapM_ go fields
      Alt n term -> do outputNatImm n out; go term
      Ref (MatchFid f) -> outputNatImm (fromIntegral (fromFid f)) out
      Ref (MatchPrefix str rest) -> do
        local $ \ptr end -> do
          let
            mangled = RTS.fromValue (String str)
            withoutTerminator =
              ByteString.take (ByteString.length mangled - 2) mangled
          loadLiteral withoutTerminator ptr end
          outputBytes ptr end out
        go rest
      Ref (MatchVar (Var ty var _))
        | isByteTy ty -> outputByte (vars ! var) out
        | isWordTy ty -> outputNat (vars ! var) out
        | otherwise ->
          local $ \ptr end -> do
            getOutput (castRegister (vars ! var)) ptr end
            outputBytes ptr end out
      Ref (MatchArrayPrefix _ _ all) -> go all
      other -> error $ "buildTerm: " <> show other
  
  -- | A 'ResultTerm' is represented in two ways depending on the type
  -- of the value being returned:
  --
  -- * 'PredicateTy' and 'NatTy' results are stored directly in a 'Register Word'
  -- * Other types are built in a 'binary::Output' and are represented by a
  --   'Register BinaryOutputPtr'.
  --
  -- 'isWordTy' returns 'True' for the first kind.
  --
  isWordTy :: Type -> Bool
  isWordTy = isWordRep . repType
    where
    isWordRep PredicateRep{} = True
    isWordRep ByteRep = True
    isWordRep NatRep = True
    isWordRep _ = False
  
  isByteTy :: Type -> Bool
  isByteTy = (ByteRep ==) . repType
  
  -- | Transform predicates inside the type but keep its structure.
  transformType :: QueryTransformations -> Type -> Type
  transformType qtrans ty = transform ty
    where
      transform ty = bimap overPidRef overExpandedType ty
  
      overPidRef pref =
        case lookupTransformation (pid pref) qtrans of
          Nothing -> pref
          Just PredicateTransformation{..} -> tAvailable
  
      overExpandedType (ExpandedType tref ty) =
        ExpandedType tref (transform ty)
  
  transformFact
    :: PredicateDetails
    -> PredicateDetails
    -> (Thrift.Fact -> Thrift.Fact)
  transformFact from to
    | Nothing <- mTransformKey
    , Nothing <- mTransformValue =
      \(Thrift.Fact _ key value) ->
        Thrift.Fact (fromPid $ predicatePid to) key value
    | otherwise =
      \(Thrift.Fact _ key value) ->
       Thrift.Fact
         (fromPid $ predicatePid to)
         (RTS.fromValue $ overKey $ RTS.toValue keyRep key)
         (RTS.fromValue $ overValue $ RTS.toValue valueRep value)
    where
      overKey = fromMaybe id mTransformKey
      overValue = fromMaybe id mTransformValue
      keyRep = repType $ predicateKeyType from
      valueRep = repType $ predicateValueType from
      mTransformKey = transformExpression
        (predicateKeyType from)
        (predicateKeyType to)
      mTransformValue = transformExpression
        (predicateValueType from)
        (predicateValueType to)
  
  -- | Transform an expression into a another type.
  -- Missing fields are filled with their default value.
  transformExpression :: Type -> Type -> Maybe (Value -> Value)
  transformExpression from to =
    case transformTerm inner defaultValue from to of
      Nothing -> Nothing
      Just f -> Just $ \ta ->
        f (error "QueryRegs are never used in transformExpression") discard ta id
    where
      inner _ _ _ _ _ a f = f a
      discard _ _ = return ()
  
  type Matcher = Match TransformAndBind Output
  
  -- | Transform a matching pattern into a another type.
  -- All variable bindings are removed.
  -- Missing fields are filled with wildcards.
  transformPattern
    :: forall a. Type
    -> Type
    -> Maybe
          (  QueryRegs
          -> (Type -> Term Matcher -> Code ())
          -> Term Matcher
          -> (Term Matcher -> Code a)
          -> Code a
          )
  transformPattern from to = do
    f <- transformTerm transformMatch defaultForType from to
    return $ \qr discard term ->
      let
          discard' :: Type -> Term Matcher -> Cont (Code a) ()
          discard' a b = cont $ \r -> do
            () <- discard a b
            r ()
      in
      runCont (f qr discard' term)
    where
      defaultForType ty = Ref (MatchWild ty)
  
  -- | Transform a Match which matches against a value of 'from' type into one
  -- that matches against a value of 'to' type.
  --
  -- NB. Type compatibility is not checked. Assumes that a transformation is
  -- possible and required.
  transformMatch
    :: QueryRegs
    -> (Type -> Matcher -> Cont (Code x) ())  -- ^ handle discarded record fields
    -> Type
    -> Type
    -> (Term Matcher -> Cont (Code x) (Term Matcher))
    -> Matcher
    -> Cont (Code x) Matcher
  transformMatch syscalls discard from to overTerm match = case match of
    MatchWild _ -> return $ MatchWild to
    MatchNever _ -> return $ MatchNever to
    MatchFid fid -> return $ MatchFid fid
    -- Convert value from 'to' type into 'from' before binding.
    -- If we get to this case it means that this conversion is required,
    MatchBind out -> return $ MatchExt $ TransformAndBind to out
    MatchVar (Typed _ var) ->
      case transformBytes' syscalls discard' from to of
        Nothing -> return $ MatchVar $ Typed to var
        Just transform ->
          cont $ \r ->
            output $ \result -> do
            local $ \start end -> do
              getOutput var start end
              transform (Bytes start end) result
            r $ MatchVar $ Typed to result
    MatchAnd left right -> do
      left' <- overTerm left
      right' <- overTerm right
      return $ MatchAnd left' right'
    -- both types must be StringTy so this transformation is a no-op
    MatchPrefix prefix rest -> return $ MatchPrefix prefix rest
    MatchArrayPrefix _ prefix all -> do
      all' <- overTerm all
      res <- overTerm (Array prefix)
      case res of
        Array prefix' -> return $ MatchArrayPrefix to prefix' all'
        _ -> error "array transformation did not yield another array"
    MatchExt x -> return $ MatchExt x
    where
      discard' :: Type -> Bytes -> Code ()
      discard' ty (Bytes start end) = do
        output $ \out -> do
          outputBytes start end out
          run $ discard ty (MatchVar $ Typed ty out)
      run :: forall x. Cont (Code x) () -> Code ()
      run m = void $ runCont m (\() -> return undefined)
  
  type TransformTerm m a b
    = QueryRegs
    -> (Type -> Term a -> m ())   -- ^ discard term
    -> Term a                    -- ^ source term
    -> m (Term b)
  
  -- | Create a transformation from a term into another term of a compatible type.
  --
  -- This will be used for transforming patterns and expressions. In each of
  -- these two cases we will handle default values and discarded records fields
  -- differently so we take those handling functions as input.
  transformTerm
    :: forall a b m. (Coercible a b, Show a, Show b, Monad m)
    => ( QueryRegs
      -> (Type -> a -> m ())       --  discard inner value
      -> Type                      --  from type
      -> Type                      --  to type
      -> (Term a -> m (Term b))    --  handle inner terms
      -> a
      -> m b)
    -> (Type -> Term b)            -- ^ default value for type
    -> Type                        -- ^ from type
    -> Type                        -- ^ to type
    -> Maybe (TransformTerm m a b)
  transformTerm inner defaultForType src dst = go src dst
    where
      -- Types are the same. No transformation is required
      id' :: Term a -> m (Term b)
      id' term = return (coerce term)
  
      names = map fieldDefName
  
      -- one entry for each common field
      transformationsFor
        :: [RTS.FieldDef]
        -> [RTS.FieldDef]
        -> Map Text (Maybe (Word64, TransformTerm m a b))
      transformationsFor from to =
        Map.intersectionWith trans fromFields toFields
        where
          trans :: (Word64, Type)
                -> (Word64, Type)
                -> Maybe (Word64, TransformTerm m a b)
          trans (ixFrom, defFrom) (ixTo, defTo) =
            case go defFrom defTo of
              -- fields are identical
              Nothing | ixTo == ixFrom -> Nothing
              -- field order changed
              Nothing -> Just (ixTo, \_ _ -> id')
              -- field content changed
              Just f -> Just (ixTo, f)
  
          fromFields :: Map Text (Word64, Type)
          fromFields = Map.fromList $ flip map (zip from [0..])
            $ \(FieldDef name def, ix) -> (name, (ix, def))
  
          toFields :: Map Text (Word64, Type)
          toFields = Map.fromList $ flip map (zip to [0..])
            $ \(FieldDef name def, ix) -> (name, (ix, def))
  
      go :: Type -> Type -> Maybe (TransformTerm m a b)
      go from@(NamedTy _ _) to = go (derefType from) to
      go from to@(NamedTy _ _) = go from (derefType to)
      go ByteTy ByteTy = Nothing
      go NatTy NatTy = Nothing
      go StringTy StringTy = Nothing
      go BooleanTy BooleanTy = Nothing
      go (MaybeTy from) (MaybeTy to) = go (lowerMaybe from) (lowerMaybe to)
      go (PredicateTy _ _) (PredicateTy _ _) = Nothing
      go (EnumeratedTy from) (EnumeratedTy to) =
        go (lowerEnum from) (lowerEnum to)
      go (ArrayTy from) (ArrayTy to) = do
        f <- go from to
        return $ fix $ \recurse qr discard term ->
          case term of
            Array vs -> Array <$> traverse (f qr discard) vs
            Ref a -> Ref <$> inner qr
              (\ty val -> discard ty (Ref val))
              (ArrayTy from)
              (ArrayTy to)
              (recurse qr discard)
              a
            _ -> error $ "expected Array, got " <> show term
      go (SetTy from) (SetTy to) = do
        f <- go from to
        return $ fix $ \recurse qr discard term ->
          case term of
            Array vs -> Array <$> traverse (f qr discard) vs
            Ref a -> Ref <$> inner qr
              (\ty val -> discard ty (Ref val))
              (SetTy from)
              (SetTy to)
              (recurse qr discard)
              a
            _ -> error $ "expected Array, got " <> show term
      go (RecordTy from) (RecordTy to) =
        let transformations = transformationsFor from to
            sameFieldCount = length from == length to
            -- implies same field order as well
            sameFieldContents = Map.null (Map.filter isJust transformations)
            noChange = sameFieldCount && sameFieldContents
        in
        if noChange
        then Nothing
        else Just $ fix $ \recurse qr discard term -> case term of
          Tuple contents -> do
            contents' <- sequence
              [ case Map.lookup name transMap of
                  -- 'to' field doesn't exist in 'from'
                  Nothing -> return $ defaultForType ty
                  Just (content, Nothing) -> id' content
                  Just (content, Just (_, transform)) ->
                    transform qr discard content
              | FieldDef name ty <- to
              ]
  
            sequence_
              [ discard tyFrom term
              | (FieldDef nameFrom tyFrom, term) <- zip from contents
              , nameFrom `notElem` names to
              ]
  
            return (Tuple contents')
            where
              transMap = Map.intersectionWith (,) contentsByName transformations
              contentsByName = Map.fromList $ zip (names from) contents
          Ref a -> Ref <$> inner qr
            (\ty val -> discard ty (Ref val))
            (RecordTy from)
            (RecordTy to)
            (recurse qr discard)
            a
          _ -> error $ "expected Tuple, got " <> show term
  
      go (SumTy from) (SumTy to) =
        let transformations = transformationsFor from to
            safeAltCount = length from <= length to
            sameAltContents = Map.null (Map.filter isJust transformations)
            noChange = safeAltCount && sameAltContents
            transformationsByIx = Map.fromList
                [ (ixFrom, trans)
                | (name, ixFrom) <- zip (names from) [0..]
                , Just trans <- [Map.lookup name transformations]
                ]
            unknown = Alt (fromIntegral $ length to) (Tuple [])
        in
        if noChange
          then Nothing
          else Just $ fix $ \recurse qr discard term -> case term of
            Alt n content -> case Map.lookup n transformationsByIx of
              -- alternative in 'from' doesn't exist in 'to'
              Nothing -> return unknown
              Just Nothing -> id' term
              Just (Just (n', transform)) -> do
                content' <- transform qr discard content
                return (Alt n' content')
            Ref a -> Ref <$> inner qr
              (\ty -> discard ty . Ref)
              (SumTy from)
              (SumTy to)
              (recurse qr discard)
              a
            _ -> error $ "expected Alt, got " <> show term
      go (ArrayTy from) (SetTy to) = do
        f <- go from to
        return $ fix $ \recurse qr discard term ->
          case term of
            Array vs -> Array <$> traverse (f qr discard) vs
            Ref a -> Ref <$> inner qr
              (\ty val -> discard ty (Ref val))
              (ArrayTy from)
              (SetTy to)
              (recurse qr discard)
              a
            _ -> error $ "expected Array, got " <> show term
      go (SetTy from) (ArrayTy to) = do
        f <- go from to
        return $ fix $ \recurse qr discard term ->
          case term of
            Array vs -> Array <$> traverse (f qr discard) vs
            Ref a -> Ref <$> inner qr
              (\ty val -> discard ty (Ref val))
              (SetTy from)
              (ArrayTy to)
              (recurse qr discard)
              a
            _ -> error $ "expected Array, got " <> show term
  
      go from to =
        error $ "invalid type conversion: "
          <> show from <> " to " <> show to
  
  defaultValue :: Type -> Term a
  defaultValue ty = case derefType ty of
    MaybeTy _ -> Alt 0 (Tuple [])
    ByteTy -> Byte 0
    NatTy -> Nat 0
    BooleanTy -> Alt 0 (Tuple [])
    StringTy -> String ""
    ArrayTy _ -> Array []
    RecordTy fields -> Tuple (map (defaultValue . fieldDefType) fields)
    EnumeratedTy{} -> Alt 0 (Tuple [])
    SumTy (first : _) -> Alt 0 (defaultValue (fieldDefType first))
    _ -> error $ "type doesn't have a default value: " <> show ty
  
  -- | Transform a fact key or value contained in some binary input into another
  -- compatible type.
  --
  -- The transformation function will always leave the start pointer of `Bytes` at
  -- the end of the transformed input.
  transformBytes
    :: QueryRegs
    -> Type
    -> Type
    -> Maybe (Bytes -> Register 'BinaryOutputPtr -> Code ())
  transformBytes syscalls = transformBytes' syscalls ignoreDiscarded
    where
      ignoreDiscarded _ _ = return ()
  
  transformBytes'
    :: QueryRegs
    -> (Type -> Bytes -> Code ()) -- handle discarded record fields
    -> Type
    -> Type
    -> Maybe (Bytes -> Register 'BinaryOutputPtr -> Code ())
  transformBytes' QueryRegs{..} discard src dst =
    case go src dst of
      Left _ -> Nothing
      Right transform -> Just $ \bytes out -> transform out bytes
    where
    go :: Type
       -> Type
       -> Either
            (Register 'BinaryOutputPtr -> Bytes -> Code ()) -- copy as is
            (Register 'BinaryOutputPtr -> Bytes -> Code ()) -- transform and copy
    go from@(NamedTy _ _) to = go (derefType from) to
    go from to@(NamedTy _ _) = go from (derefType to)
    go ByteTy ByteTy = Left $ copy ByteTy
    go NatTy NatTy = Left $ copy NatTy
    go StringTy StringTy = Left $ copy StringTy
    go BooleanTy BooleanTy = Left $ copy BooleanTy
    go (MaybeTy from) to = go (lowerMaybe from) to
    go from (MaybeTy to) = go from (lowerMaybe to)
    go (PredicateTy _ _) (PredicateTy pid s) = Left $ copy (PredicateTy pid s)
    go from (EnumeratedTy to) = go from (lowerEnum to)
    go (EnumeratedTy from) to = go (lowerEnum from) to
    go (ArrayTy from) (ArrayTy to) =
      case go from to of
        Left _ -> Left $ copy (ArrayTy to)
        Right trans -> Right $ \out (Bytes start end) ->
          local $ \size -> mdo
            inputNat start end size
            outputNat size out
            jumpIf0 size finish
            loop <- label
            trans out (Bytes start end)
            decrAndJumpIfNot0 size loop
            finish <- label
            return ()
    go (SetTy from) (SetTy to) =
      case go from to of
        Left _ -> Left $ copy (SetTy to)
        Right trans -> Right $ \out (Bytes start end) ->
          local $ \size -> do
          inputNat start end size
          local $ \set -> mdo
            jumpIf0 size finish
            newSet set
            loop <- label
            output $ \tempOut -> do
              trans tempOut (Bytes start end)
              insertOutputSet set tempOut
              decrAndJumpIfNot0 size loop
            finish <- label
            setToArray set out
            freeSet set
          return ()
    go (SumTy from) (SumTy to)
      | sameOrder && sameTypes = Left $ copy (SumTy to)
      | otherwise = Right $ \out (Bytes start end) -> mdo
          local $ \sel -> mdo
            inputNat start end sel
            let unknown = [finish]
            select sel (lbls ++ unknown)
            -- TODO: Add tests for this unknown.
            raise "selector out of range"
          lbls <- forM alts $ \(ixTo, trans) -> mdo
            lbl <- label
            outputNatImm (fromIntegral ixTo) out
            -- the start pointer was already moved to the beginning
            -- of the content when the selector was read.
            fromEither trans out (Bytes start end)
            jump finish
            return lbl
          finish <- label
          return ()
        where
          toAlts :: Map Name (Int, Type)
          toAlts = Map.fromList
              [ (name, (ixTo, tyTo))
              | (ixTo, FieldDef name tyTo) <- zip [0..] to
              ]
          alts =
            [ case Map.lookup name toAlts of
                -- removed alternative
                Nothing -> (unknownAltIx, unknownAlt tyFrom)
                Just (ixTo, tyTo) -> (ixTo, go tyFrom tyTo)
            | FieldDef name tyFrom <- from
            ]
  
          unknownAltIx = length to
          unknownAlt tyFrom = Right $ \_ (Bytes start end) ->
            skipTrusted start end tyFrom
  
          sameIndex (ixFrom, (ixTo, _)) = ixFrom == ixTo
          sameOrder = all sameIndex (zip [0..] alts)
          sameTypes = all (isLeft . snd) alts
    go (RecordTy from) (RecordTy to)
      | sameFieldCount && sameFieldContents = Left $ copy (RecordTy to)
      | otherwise = Right walk
      where
      sameFieldCount = length from == length to
      sameFieldContents = all identical (zip from to)
      identical (FieldDef nameFrom tyFrom, FieldDef nameTo tyTo) =
        nameFrom == nameTo && isLeft (go tyFrom tyTo)
  
      fieldsFrom = Set.fromList $ map fieldDefName from
      fieldsTo = Set.fromList $ map fieldDefName to
  
      -- walk through the record being copied alongside the record being built.
      walk out bytes@(Bytes start end) = step mempty from to
        where
        step saved from' to' = case to' of
          [] ->
            -- nothing more to add, skip origin record
            skipTrusted start end (RecordTy from')
          FieldDef nameTo tyTo : restTo
            | Just (fieldBytes, savedTyFrom) <- Map.lookup nameTo saved -> do
              -- we've saved that field before, move it over now.
              fromEither (go savedTyFrom tyTo) out fieldBytes
              let saved' = Map.delete nameTo saved
              step saved' from' restTo
            | not (nameTo `Set.member` fieldsFrom) -> do
              -- target field is not in origin, use default value
              buildTerm out mempty (defaultValue tyTo)
              step saved from' restTo
            | otherwise ->
              case from' of
                [] ->
                  -- if there are no more 'from' fields, all remaining 'to'
                  -- fields should either be missing in 'fieldsFrom or already
                  -- saved for copying.
                  error $ "field unaccounted for: '" <> unpack nameTo <> "'"
                FieldDef nameFrom tyFrom : restFrom
                  | not (nameFrom `Set.member` fieldsTo) -> do
                    -- origin field is not in target, discard it
                    local $ \saved_start -> do
                      move start saved_start
                      skipTrusted start end tyFrom
                      discard tyFrom (Bytes saved_start start)
                    step saved restFrom to'
                  | nameTo == nameFrom -> do
                    -- matching field, move it over
                    fromEither (go tyFrom tyTo) out bytes
                    step saved restFrom restTo
                  | otherwise ->
                    -- the field will be required later. Save its location
                    local $ \fieldStart -> do
                    move start fieldStart
                    skipTrusted start end tyFrom
                    let fieldBytes = Bytes fieldStart end
                        saved' = Map.insert nameFrom (fieldBytes, tyFrom) saved
                    step saved' restFrom to'
    go (ArrayTy from) (SetTy to) =
      let trans =
            case go from to of
              Left copy -> copy
              Right trans -> trans
      in Right $ \out (Bytes start end) ->
        local $ \size -> do
          inputNat start end size
          local $ \set -> mdo
            jumpIf0 size finish
            newSet set
            loop <- label
            output $ \tempOut -> do
              trans tempOut (Bytes start end)
              insertOutputSet set tempOut
              decrAndJumpIfNot0 size loop
            finish <- label
            setToArray set out
            freeSet set
          return ()
    go (SetTy from) (ArrayTy to) =
      let trans =
            case go from to of
              Left copy -> copy
              Right trans -> trans
      in Right $ \out (Bytes start end) ->
        local $ \size -> mdo
          inputNat start end size
          outputNat size out
          jumpIf0 size finish
          loop <- label
          trans out (Bytes start end)
          decrAndJumpIfNot0 size loop
          finish <- label
          return ()
    go from to = error $ "invalid type conversion: "
      <> show from <> " to " <> show to
  
    -- moves the Bytes start position
    copy :: Type -> Register 'BinaryOutputPtr -> Bytes -> Code ()
    copy ty out (Bytes start end)
      | RecordTy [] <- ty = return ()
      | otherwise =
        local $ \saved_start -> do
          move start saved_start
          skipTrusted start end ty
          outputBytes saved_start start out
  