DepError.hs

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

module Descript.Misc.Build.Read.File.DepError
  ( AnonDepError (..)
  , TagdDepError (..)
  , GenDepResult
  , GenDepResultT
  , GenDirtyDep
  , GenDirtyDepT
  , mapDirtyDepdAnn
  , guardCycle
  , guardCycleT
  , guardPromoteCycle
  , guardPromoteCycleT
  ) where

import Descript.Misc.Build.Read.File.Depd
import Descript.Misc.Build.Read.File.Scope
import Descript.Misc.Error
import Descript.Misc.Ann
import Descript.Misc.Summary
import Core.Data.String
import Core.Control.Monad.Trans

-- | An error encountered trying to load a dependency. Doesn't specify
-- the dependency's scope (must be inferred).
data AnonDepError
  = DepNotExist [String]
  | DepNotReadable
  | DepNotBuild String
  | DepCycles [RelScope]
  deriving (Eq, Ord, Read, Show)

-- | An error encountered trying to load a dependency. Specifies the
-- dependency's scope.
data TagdDepError an
  = TagdDepError
  { tagdDepErrorAnn :: an
  , tagdDepErrorScope :: AbsScope
  , tagdDepError :: AnonDepError
  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)

-- | The result of trying to load a dependency with no fallback.
type GenDepResult a = Result AnonDepError a

-- | The result of trying to load a dependency with no fallback (stacked).
type GenDepResultT u a = ResultT AnonDepError u a

-- | The result of trying to load dependencies with fallback.
type GenDirtyDep an a = Dirty (TagdDepError an) a

-- | The result of trying to load dependencies with fallback (stacked).
type GenDirtyDepT an u a = DirtyT (TagdDepError an) u a

instance Ann TagdDepError where
  getAnn = tagdDepErrorAnn

instance SummaryWithAnn TagdDepError where
  baseSummary (TagdDepError _ scope err)
    = anonDepErrorSummary suffix (Just scope) err
    where suffix = " - " ++ summary scope

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

instance Summary AnonDepError where
  summary = anonDepErrorSummary "" Nothing

-- | Transforms the annotations within the @DirtyDepd@. Annotations are
-- in the value and errors associated with the dependency, but \not\ the
-- dependency itself.
mapDirtyDepdAnn :: (Functor a)
                => (an1 -> an2)
                -> GenDepd (GenDirtyDep an1 d) (a an1)
                -> GenDepd (GenDirtyDep an2 d) (a an2)
mapDirtyDepdAnn f (Depd ddep x)
  = Depd (mapWarnings (fmap f) ddep) (f <$> x)

anonDepErrorSummary :: String
                    -> Maybe AbsScope
                    -> AnonDepError
                    -> String
anonDepErrorSummary sufx _ (DepNotExist paths)
  = unlines
  ( ("couldn't find module" ++ sufx ++ ", tried:")
  : map indentBullet paths )
anonDepErrorSummary sufx _ DepNotReadable = "couldn't read module" ++ sufx
anonDepErrorSummary sufx _ (DepNotBuild msg)
  = "couldn't build module" ++ sufx ++ ":\n" ++ msg
anonDepErrorSummary _ optScope (DepCycles relInters)
  = unlines
  ( "module depends on this module, forming a cycle:"
  : map indentBullet interSums )
  where interSums
          = reverse
          $ case optScope of
                 Nothing -> map summary relInters
                 Just scope -> map summary $ scanr (flip anchorScopeSib) scope relInters

-- | Fails with 'DepCycles' if adding the given dependency to the given
-- chain of dependencies creates a cycle (if the chain contains the
-- dependency).
guardCycle :: RelScope -> [RelScope] -> GenDepResult ()
guardCycle new dpds
  | new `elem` dpds = Failure $ DepCycles $ new : dpds
  | otherwise = Success ()

-- | Hoisted 'guardCycle' for convenience.
guardCycleT :: (Monad u) => RelScope -> [RelScope] -> GenDepResultT u ()
guardCycleT new = hoist . guardCycle new

-- | Fails if one of the dependency "errors" is a 'DepCycles'. Typically
-- because data with other dependency errors is still interpreted for
-- more errors, but 'DepCycles' errors generate redundant messages
-- later, so when they're encountered, resolution immediately fails.
guardPromoteCycle :: [TagdDepError an] -> GenDepResult ()
guardPromoteCycle [] = Success ()
guardPromoteCycle (x : xs) = guardPromoteCycle1 x >> guardPromoteCycle xs

guardPromoteCycle1 :: TagdDepError an -> GenDepResult ()
guardPromoteCycle1 terr
  = case tagdDepError terr of
         DepCycles inters -> Failure $ DepCycles inters
         _ -> Success ()

-- | Hoisted 'guardPromoteCycle' for convenience.
guardPromoteCycleT :: (Monad u) => [TagdDepError an] -> GenDepResultT u ()
guardPromoteCycleT = hoist . guardPromoteCycle