SrcAnn.hs

module Descript.Misc.Build.Read.Parse.SrcAnn
  ( SrcAnn (..)
  , TaintAnn (..)
  , parsedSrcAnn
  , gendSrcAnn
  , isTainted
  , appGend
  ) where

import Descript.Misc.Loc
import Descript.Misc.Summary
import Descript.Misc.Ann
import Data.Semigroup

-- | The relation between this AST node and the source it came from.
-- Organizes range and tainted status.
data SrcAnn
  = SrcAnn
  { -- | Where in the file the node came from.
    srcRange :: Range
    -- | Whether the node was completely generated or modified. A node
    -- is tainted if it's fully tainted, or one of its children are tainted.
  , isFullyTainted :: Bool
  } deriving (Eq, Ord, Read, Show)

-- | An annotation which explicitly specifies or doesn't specify that a
-- node is tainted.
class (Semigroup an) => TaintAnn an where
  -- | Specifies the node is fully tainted, if the annotation does so.
  -- Otherwise does nothing.
  taint :: an -> an

  -- | An annotation for a node inserted before the given node.
  preInsertAnn :: an -> an

  -- | An annotation for a node inserted after the given node
  postInsertAnn :: an -> an

instance TaintAnn SrcAnn where
  taint ann
    = SrcAnn
    { srcRange = taint $ srcRange ann
    , isFullyTainted = True
    }

  preInsertAnn ann
    = SrcAnn
    { srcRange = preInsertAnn $ srcRange ann
    , isFullyTainted = isFullyTainted ann
    }

  postInsertAnn ann
    = SrcAnn
    { srcRange = postInsertAnn $ srcRange ann
    , isFullyTainted = isFullyTainted ann
    }

instance TaintAnn Range where
  taint = id

  preInsertAnn = singletonRange . start

  postInsertAnn = singletonRange . end

instance TaintAnn () where
  taint () = ()
  preInsertAnn () = ()
  postInsertAnn () = ()

instance Semigroup SrcAnn where
  SrcAnn xSrcRange _ <> SrcAnn ySrcRange _
    = SrcAnn
    { srcRange = xSrcRange <> ySrcRange
    , isFullyTainted = True
    }

instance AnnSummary SrcAnn where
  annSummaryPre = annSummaryPre . srcRange

instance Summary SrcAnn where
  summary (SrcAnn srcRange' isFullyTainted')
     = "{"
    ++ summary srcRange'
    ++ ", "
    ++ taintSummary isFullyTainted'
    ++ "}"

-- | The annotation for a parsed value with the given range (the range
-- is typically the parsed value's annotation). Not tainted.
parsedSrcAnn :: Range -> SrcAnn
parsedSrcAnn srcRange'
  = SrcAnn
  { srcRange = srcRange'
  , isFullyTainted = False
  }

-- | The annotation for a generated (not parsed) value at the given range.
gendSrcAnn :: Range -> SrcAnn
gendSrcAnn srcRange'
  = SrcAnn
  { srcRange = srcRange'
  , isFullyTainted = True
  }

-- | Whether the node wasn't just parsed from a file, it was also
-- modified or completely generated.
--
-- If a node isn't tainted, it can just be "printed" by just taking the
-- text at its range. Otherwise its text needs to be regenerated.
isTainted :: (Ann a) => a SrcAnn -> Bool
isTainted = any isFullyTainted

-- | Appends a generated node to a parsed (and possibly modified) node.
appGend :: (Ann a, TaintAnn an, Semigroup (a an)) => a an -> a () -> a an
x `appGend` y = x <> (ann' <$ y)
  where ann' = taint $ postInsertAnn $ getAnn x

taintSummary :: Bool -> String
taintSummary True = "tainted"
taintSummary False = "untainted"