Error.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Descript.Free.Error
  ( RefineResult
  , RefineDiff (..)
  , IndivRefineDiff (..)
  , LocalRefineDiff (..)
  , entireRefineDiff
  , actualSummary
  , diffErrorDesc
  ) where

import Descript.Misc

-- | The result of trying to refine a free value.
type RefineResult a = Result RefineDiff a

-- | When a term can't be refined because it has the wrong shape,
-- describes which parts of the term have the wrong shape, and for each
-- part, what shape was expected and given.
newtype RefineDiff = RefineDiff [IndivRefineDiff] deriving (Eq, Ord, Read, Show, Monoid)

-- | When a term can't be refined because a sub-term has the wrong shape,
-- describes the range of the sub-term with the wrong shape, and what shape
-- was expected and given.
data IndivRefineDiff
  = IndivRefineDiff
  { range :: Range
  , localDiff :: LocalRefineDiff
  } deriving (Eq, Ord, Read, Show)

-- | When a term can't be refined because the entire term has the wrong
-- shape, describes what shape was expected and what shape this term has.
data LocalRefineDiff
  = LocalRefineDiff
  { expected :: String
  , actual :: String
  , actualPr :: String
  } deriving (Eq, Ord, Read, Show)

instance Summary RefineDiff where
  summary = msgToStr . diffErrorDesc

instance Summary IndivRefineDiff where
  summary = indivDiffErrorDesc

instance Summary LocalRefineDiff where
  summary = localDiffErrorDesc

-- | States that an entire term's shape is wrong.
entireRefineDiff :: Range -> LocalRefineDiff -> RefineDiff
entireRefineDiff range' x
  = RefineDiff
  [ IndivRefineDiff{range = range', localDiff = x}
  ]

-- | Gets a description of the refine difference.
diffErrorDesc :: RefineDiff -> ErrorMsg
diffErrorDesc (RefineDiff xs) = ErrorMsg $ map indivDiffErrorDesc xs

indivDiffErrorDesc :: IndivRefineDiff -> String
indivDiffErrorDesc indiv
   = summary (range indiv)
  ++ ": "
  ++ localDiffErrorDesc (localDiff indiv)

localDiffErrorDesc :: LocalRefineDiff -> String
localDiffErrorDesc diff
   = actualPr diff
  ++ ": expected "
  ++ expected diff
  ++ ", got "
  ++ actual diff

-- | Combines the actual print and term label to form a summary of the
-- actual item in a refine diff.
actualSummary :: LocalRefineDiff -> String
actualSummary diff = actual diff ++ " \"" ++ actualPr diff ++ "\""