PrintPatch.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Descript.Misc.Build.Write.Print.PrintPatch
  ( ppatch
  , ppatchThorough
  , ppatchRec
  , ppatchF
  ) where

import Descript.Misc.Build.Write.Print.PrintText
import Descript.Misc.Build.Write.Print.Printable
import Descript.Misc.Build.Write.Print.APrint
import Descript.Misc.Build.Write.Print.Patch
import Descript.Misc.Build.Read.Parse
import Descript.Misc.Ann
import Core.Data.Proxy
import Data.Maybe
import Data.List
import Data.String

-- | A "printed" patch - a patch generated using printing. Punctuation
-- (such as delimiters) are ignored, so only 'plex' patches are actually
-- applied.
newtype PrintPatch
  = PrintPatch{ runPrintPatch :: Patch }
  deriving (Eq, Monoid)

newtype PrintPatchThorough
  = PrintPatchThorough{ runPrintPatchThorough :: Maybe Patch }
  deriving (Eq, Monoid)

instance APrint PrintPatch where
  plex = plexPatchErr

  pimp = id

  pintercal sep = mconcat . intersperse sep

instance APrint PrintPatchThorough where
  plex _ = PrintPatchThorough Nothing

  pimp _ = PrintPatchThorough $ Just mempty

  pintercal sep = mconcat . intersperse sep

instance IsString PrintPatch where
  fromString _ = mempty

instance IsString PrintPatchThorough where
  fromString _ = PrintPatchThorough $ Just mempty

-- | "Pretty patch". Converts the node into a patch which can be applied
-- to the source text, so when it's parsed again, it yields the new node.
-- This patch will affect as little as possible - e.g. if the node
-- wasn't tainted (came right from text), the patch will do absolutely
-- nothing.
ppatch :: (Printable a) => a SrcAnn -> Patch
ppatch x
  | isFullyTainted ann || (isTainted' && needsFullReprint (proxyOf x))
  = mkCPatch (srcRange ann) $ pprint x
  | isTainted' = ppatchRec ppatch x
  | otherwise = mempty
  where isTainted' = isTainted x
        ann = getAnn x

-- | Pretty patch this node, recursively patching partially tainted
-- nodes. The resulting patch should be identical to 'ppatch' but more
-- complicated. Useful only for testing.
ppatchThorough :: (Printable a) => a SrcAnn -> Patch
ppatchThorough x
  | isFullyTainted ann = fullPatch
  | otherwise = fullPatch `fromMaybe` ppatchThoroughRec ppatchThorough x
  where fullPatch = mkCPatch (srcRange ann) $ pprint x
        ann = getAnn x

-- | Converts this node into a patch which can be applied to the source
-- by converting its children into patches.
ppatchRec :: (Printable a)
          => (forall b. (Printable b) => b an -> Patch)
          -> a an
          -> Patch
ppatchRec sub = runPrintPatch . aprintRec (PrintPatch . sub)

-- | Converts this node into a patch which can be applied to the source
-- by converting its children into patches. The resulting patch should
-- be identical to 'ppatch' but more complicated. Useful only for testing.
ppatchThoroughRec :: (Printable a)
                  => (forall b. (Printable b) => b an -> Patch)
                  -> a an
                  -> Maybe Patch
ppatchThoroughRec sub
  = runPrintPatchThorough
  . aprintRec (PrintPatchThorough . Just . sub)

-- | Convert the nodes into a patch which can be applied to the source
-- text, so when it's parsed again, it yields the new node. Used for
-- lexemes.
ppatchF :: (Foldable w, Printable a) => w (a SrcAnn) -> Patch
ppatchF = foldMap ppatch

-- | An error generated when 'plex' is used to create a patch.
plexPatchErr :: a
plexPatchErr
  = error $ concat
  [ "'plex' can't be used when generating patches.\n"
  , "This was raised because an partially tainted node (not fully "
  , "tainted but with tainted children) used 'plex'. A node should "
  , "never use 'plex' unless it's a leaf (has no children), and then "
  , "it should never be partially tainted, either fully tainted or "
  , "fully untainted."
  ]