Global.hs

module Descript.BasicInj.Read.Resolve.Subst.Global
  ( globalSubstMany
  ) where

import Descript.BasicInj.Read.Resolve.Subst.Subst
import qualified Descript.BasicInj.Data.Value.In as In
import qualified Descript.BasicInj.Data.Value.Out as Out
import qualified Descript.BasicInj.Data.Type as RecordType
import Descript.BasicInj.Data
import Descript.Misc
import Data.Semigroup
import Core.Data.List
import Core.Data.List.Assoc

-- | Globally applies each substitution by modifying the top phase
-- and record declarations.
globalSubstMany :: (TaintAnn an)
                => [Subst]
                -> AModule an
                -> AModule an
globalSubstMany substs (AModule ann recCtx redCtx)
  = AModule
  { amoduleAnn = ann
  , recordCtx = globalSubstManyRecordCtx substs recCtx
  , reduceCtx = globalSubstManyReduceCtx recCtx_ substs redCtx
  }
  where recCtx_ = remAnns recCtx

globalSubstManyRecordCtx :: (TaintAnn an)
                         => [Subst]
                         -> RecordCtx an
                         -> RecordCtx an
globalSubstManyRecordCtx substs (RecordCtx ann decls)
  = RecordCtx ann $ concatMap (globalSubstManyRecordDecl substs) decls

globalSubstManyRecordDecl :: (TaintAnn an)
                          => [Subst]
                          -> RecordDecl an
                          -> [RecordDecl an]
globalSubstManyRecordDecl substs (RecordDecl ann typ)
  = RecordDecl ann <$> globalSubstManyRecordType substs typ

globalSubstManyRecordType :: (TaintAnn an)
                          => [Subst]
                          -> RecordType an
                          -> [RecordType an]
globalSubstManyRecordType substs (RecordType ann head' props)
  = RecordType ann <$> globalSubstManyFSymbol substs head' <*> pure props

globalSubstManyFSymbol :: (TaintAnn an)
                       => [Subst]
                       -> FSymbol an
                       -> [FSymbol an]
globalSubstManyFSymbol substs x = y ?: [x]
  where y = (ann' <$) <$> y_
        y_ = glookup x_ substs
        x_ = remAnns x
        ann' = getAnn x

globalSubstManyReduceCtx :: (TaintAnn an)
                         => RecordCtx ()
                         -> [Subst]
                         -> ReduceCtx an
                         -> ReduceCtx an
globalSubstManyReduceCtx recCtx substs (ReduceCtx ann top lows)
  = ReduceCtx ann top' lows
  where top' = top <> extraTop
        extraTop = substAnn <$ substManyPhase recCtx substs
        substAnn = preInsertAnn ann

substManyPhase :: RecordCtx () -> [Subst] -> PhaseCtx ()
substManyPhase recCtx = PhaseCtx () . map (substToReducer recCtx)

substToReducer :: RecordCtx () -> Subst -> Reducer ()
substToReducer recCtx subst@(Subst _ from to) = Reducer () from' to'
  where from'
          = singletonValue
          $ In.PartRecord
          $ Record () from
          $ map In.fullConsumeProp propKeys
        to'
          = singletonValue
          $ Out.PartRecord
          $ Record () to
          $ map (Out.fullProduceProp from) propKeys
        propKeys
          = case lookupRecordType (substDeclHead subst) recCtx of
                 Nothing -> [undefinedSym]
                 Just rtype -> RecordType.properties rtype