Refactor.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}

module Descript.Misc.Build.Process.Refactor
  ( RefactorError (..)
  , GenRefactorWarning (..)
  , RefactorWarning
  , RefactorResult
  , RefactorResultT
  , RefactorFunc
  , RefactorFuncT
  ) where

import Descript.Misc.Build.Process.Validate
import Descript.Misc.Build.Read.Parse
import Descript.Misc.Build.Read.File
import Descript.Misc.Ann
import Descript.Misc.Error
import Descript.Misc.Summary
import Data.Maybe
import Data.List

-- | Prevents a value from being refactored. Currently none of these,
-- just a stub.
data RefactorError
  = UnsupportedRefactorAction String [String]
  | BadRefactorArgs String Int [String]
  | RefactorNoSymbolAtLoc
  | RefactorParseError (Maybe SFile) (ParseError Char)
  | RefactorValidateError [Problem SrcAnn]
  deriving (Eq, Read, Show)

-- | Allows a value to be refactored, but might cause conflicts in the
-- source code later (specifically, it can't be verified that the
-- refactor will produce the same code).
data GenRefactorWarning an
  = SymConflict an String
  | RefactorDepFail (TagdDepError an)
  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | Allows a value to be refactored, but might cause conflicts in the
-- source code later (specifically, it can't be verified that the
-- refactor will produce the same code).
type RefactorWarning = GenRefactorWarning SrcAnn

-- | The result of trying to refactor an expression. Can completely
-- fail ('Failure'), give a result but it could mess up the source code
-- (nonempty 'dirtyWarnings'), or completely succeed.
type RefactorResult a = DirtyRes RefactorError RefactorWarning a

-- | The result of trying to refactor an expression, with side effects
-- from @u@.
type RefactorResultT u a = DirtyResT RefactorError RefactorWarning u a

-- | Refactors the expression of type @a@.
type RefactorFunc a = a SrcAnn -> RefactorResult (a SrcAnn)

-- | Refactors the expression of type @a@, performing side effects from
-- @u@.
type RefactorFuncT u a = a SrcAnn -> RefactorResultT u (a SrcAnn)

instance Ann GenRefactorWarning where
  getAnn (SymConflict ann _) = ann
  getAnn (RefactorDepFail derr) = getAnn derr

instance FileSummary RefactorError where
  summaryF _ (UnsupportedRefactorAction label args)
     = "unsupported refactor action: "
    ++ label
    ++ "; args: "
    ++ intercalate ", " args
  summaryF _ (BadRefactorArgs label expectedArgLen args)
     = "expected "
    ++ show expectedArgLen
    ++ ", got "
    ++ show actualArgLen
    ++ " for refactor action: "
    ++ label
    ++ "; args: "
    ++ intercalate ", " args
    where actualArgLen = length args
  summaryF _ RefactorNoSymbolAtLoc = "no symbol at this location"
  summaryF file (RefactorParseError isrc err)
    = parseErrorSummary file' err
    where file' = file `fromMaybe` isrc
  summaryF _ (RefactorValidateError probs) = validateErrorSummary probs

instance SummaryWithAnn GenRefactorWarning where
  baseSummary (SymConflict _ symPr)
    = "old symbol conflicts with new symbols: " ++ symPr
  baseSummary (RefactorDepFail derr)
    = "failed to load dependency:\n" ++ baseSummary derr

instance (AnnSummary an) => Summary (GenRefactorWarning an) where
  summary = summaryWithAnn