module Generics.BiGUL.Error where

import GHC.InOut
import Text.PrettyPrint


class PrettyPrintable a where
  toDoc :: a -> Doc

data PutError :: * -> * -> * where
  PFail                      :: String -> PutError s v
  PSourcePatternMismatch     :: PatExprDirError s -> PutError s v
  PViewPatternMismatch       :: PatExprDirError v -> PutError s v
  PUnevalFailed              :: PatExprDirError s' -> PutError s v
  PDependencyMismatch        :: s -> PutError s (v, v')
  PNoIntermediateSource      :: GetError s v' -> PutError s v
  PCaseExhausted             :: PutError s v
  PAdaptiveBranchRevisited   :: PutError s v
  PAdaptiveBranchMatched     :: PutError s v
  PPreviousBranchMatched     :: PutError s v
  PBranchPredictionIncorrect :: PutError s v
  PPostVerificationFailed    :: PutError s v
  PBranchUnmatched           :: PutError s v
  --
  PProdLeft     :: s -> v -> PutError s v -> PutError (s, s') (v, v')
  PProdRight    :: s' -> v' -> PutError s' v' -> PutError (s, s') (v, v')
  PRearrS       :: s' -> v -> PutError s' v -> PutError s v
  PRearrV       :: s -> v' -> PutError s v' -> PutError s v
  PDep          :: s -> v -> PutError s v -> PutError s (v, v')
  PComposeLeft  :: a -> b -> PutError a b -> PutError a c
  PComposeRight :: b -> c -> PutError b c -> PutError a c
  PBranch       :: Int -> PutError s v -> PutError s v

incrBranchNo :: PutError s v -> PutError s v
incrBranchNo (PBranch i e) = PBranch (i+1) e
incrBranchNo e              = e

instance Show (PutError s v) where
  show (PFail str)                   = "fail: " ++ str
  show (PSourcePatternMismatch e)    = show e
  show (PViewPatternMismatch e)      = show e
  show (PUnevalFailed e)             = show e
  show (PDependencyMismatch _)       = "dependency mismatch"
  show (PNoIntermediateSource e)     = show e
  show  PCaseExhausted               = "case exhausted"
  show  PAdaptiveBranchRevisited     = "adaptive branch revisited"
  show  PAdaptiveBranchMatched       = "adaptive branch matched"
  show  PPreviousBranchMatched       = "previous branch matched"
  show  PBranchPredictionIncorrect   = "branch prediction incorrect"
  show  PPostVerificationFailed      = "post-verification failed"
  show  PBranchUnmatched             = "branch unmatched"
  show (PProdLeft _ _ e)             = show e
  show (PProdRight _ _ e)            = show e
  show (PRearrS _ _ e)               = show e
  show (PRearrV _ _ e)               = show e
  show (PDep _ _ e)                  = show e
  show (PComposeLeft _ _ e)          = show e
  show (PComposeRight _ _ e)         = show e
  show (PBranch _ e)                 = show e

indent :: Doc -> Doc
indent = nest 2

instance PrettyPrintable (PutError s v) where
  toDoc e@(PFail str)                = text (show e)
  toDoc (PSourcePatternMismatch e)   = text "source pattern mismatch" $+$ indent (toDoc e)
  toDoc (PViewPatternMismatch e)     = text "view pattern mismatch" $+$ indent (toDoc e)
  toDoc (PUnevalFailed e)            = text "inverse evaluation failed" $+$ indent (toDoc e)
  toDoc e@(PDependencyMismatch _)    = text (show e)
  toDoc (PNoIntermediateSource e)    = text "computation of intermediate source failed" $+$ indent (toDoc e)
  toDoc e@PCaseExhausted             = text (show e)
  toDoc e@PAdaptiveBranchRevisited   = text (show e)
  toDoc e@PAdaptiveBranchMatched     = text (show e)
  toDoc e@PPreviousBranchMatched     = text (show e)
  toDoc e@PBranchPredictionIncorrect = text (show e)
  toDoc e@PPostVerificationFailed    = text (show e)
  toDoc e@PBranchUnmatched           = text (show e)
  toDoc (PProdLeft _ _ e)            = text "on the left-hand side of Prod" $+$ toDoc e
  toDoc (PProdRight _ _ e)           = text "on the right-hand side of Prod" $+$ toDoc e
  toDoc (PRearrS _ _ e)              = text "in RearrS" $+$ toDoc e
  toDoc (PRearrV _ _ e)              = text "in RearrV" $+$ toDoc e
  toDoc (PDep _ _ e)                 = text "in Dep" $+$ toDoc e
  toDoc (PComposeLeft _ _ e)         = text "on the left-hand side of Comp" $+$ toDoc e
  toDoc (PComposeRight _ _ e)        = text "on the right-hand side of Comp" $+$ toDoc e
  toDoc (PBranch i e)                = text ("in Case branch " ++ show i) $+$ toDoc e

data GetError :: * -> * -> * where
  GFail                      :: String -> GetError s v
  GSourcePatternMismatch     :: PatExprDirError s -> GetError s v
  GUnevalFailed              :: PatExprDirError s' -> GetError s v
  GViewRecoveringIncomplete  :: PatExprDirError v' -> GetError s v
  GCaseExhausted             :: [GetError s v] -> GetError s v
  GPreviousBranchMatched     :: GetError s v
  GPostVerificationFailed    :: GetError s v
  GBranchUnmatched           :: GetError s v
  GAdaptiveBranchMatched     :: GetError s v
  --
  GProdLeft     :: s -> GetError s v -> GetError (s, s') (v, v')
  GProdRight    :: s' -> GetError s' v' -> GetError (s, s') (v, v')
  GRearrS       :: s' -> GetError s' v -> GetError s v
  GRearrV       :: s -> GetError s v' -> GetError s v
  GDep          :: s -> GetError s v -> GetError s (v, v')
  GComposeLeft  :: a -> GetError a b -> GetError a c
  GComposeRight :: b -> GetError b c -> GetError a c
  GBranch       :: Int -> GetError s v -> GetError s v

addCurrentBranchError :: GetError s v -> GetError s v -> GetError s v
addCurrentBranchError e0 (GCaseExhausted es) = GCaseExhausted (e0:es)
addCurrentBranchError e0 (GBranch i e) = GBranch (i+1) e

instance Show (GetError s v) where
  show (GFail str)                   = "fail: " ++ str
  show (GSourcePatternMismatch e)    = show e
  show (GUnevalFailed e)             = show e
  show (GViewRecoveringIncomplete e) = show e
  show (GCaseExhausted _)            = "case exhausted"
  show  GPreviousBranchMatched       = "previous branch matched"
  show  GPostVerificationFailed      = "post-verification failed"
  show  GBranchUnmatched             = "branch unmatched"
  show  GAdaptiveBranchMatched       = "adaptive branch matched"
  show (GProdLeft _ e)               = show e
  show (GProdRight _ e)              = show e
  show (GRearrS _ e)                 = show e
  show (GRearrV _ e)                 = show e
  show (GDep _ e)                    = show e
  show (GComposeLeft _ e)            = show e
  show (GComposeRight _ e)           = show e
  show (GBranch _ e)                 = show e

instance PrettyPrintable (GetError s v) where
  toDoc e@(GFail str)                 = text (show e)
  toDoc (GSourcePatternMismatch e)    = text "source pattern mismatch" $+$ indent (toDoc e)
  toDoc (GUnevalFailed e)             = text "inverse evaluation failed" $+$ indent (toDoc e)
  toDoc (GViewRecoveringIncomplete e) = text "view recovering incomplete" $+$ indent (toDoc e)
  toDoc e@(GCaseExhausted es)         = text (show e) $+$
                                                foldr ($+$) empty
                                                  (zipWith (\i doc -> text ("branch " ++ show i) $+$ indent doc)
                                                           [0..]
                                                           (map toDoc es))
  toDoc e@GPreviousBranchMatched      = text (show e)
  toDoc e@GPostVerificationFailed     = text (show e)
  toDoc e@GBranchUnmatched            = text (show e)
  toDoc e@GAdaptiveBranchMatched      = text (show e)
  toDoc (GProdLeft _ e)               = text "on the left-hand side of Prod" $+$ toDoc e
  toDoc (GProdRight _ e)              = text "on the right-hand side of Prod" $+$ toDoc e
  toDoc (GRearrS _ e)                 = text "in RearrS" $+$ toDoc e
  toDoc (GRearrV _ e)                 = text "in RearrV" $+$ toDoc e
  toDoc (GDep _ e)                    = text "in Dep" $+$ toDoc e
  toDoc (GComposeLeft _ e)            = text "on the left-hand side of Comp" $+$ toDoc e
  toDoc (GComposeRight _ e)           = text "on the right-hand side of Comp" $+$ toDoc e
  toDoc (GBranch i e)                 = text ("in Case branch " ++ show i) $+$ toDoc e

data PatExprDirError :: * -> * where
  PEDConstantMismatch    :: PatExprDirError a
  PEDEitherMismatch   :: PatExprDirError (Either a b)
  PEDValueUnrecoverable  :: PatExprDirError a
  PEDIncompatibleUpdates :: a -> a -> PatExprDirError a
  PEDMultipleUpdates     :: a -> a -> PatExprDirError a
  --
  PEDProdLeft    :: PatExprDirError a -> PatExprDirError (a, b)
  PEDProdRight   :: PatExprDirError b -> PatExprDirError (a, b)
  PEDEitherLeft  :: PatExprDirError a -> PatExprDirError (Either a b)
  PEDEitherRight :: PatExprDirError b -> PatExprDirError (Either a b)
  PEDIn          :: InOut a => PatExprDirError (F a) -> PatExprDirError a

instance Show (PatExprDirError a) where
  show  PEDConstantMismatch         = "constant mismatch"
  show  PEDEitherMismatch           = "either value mismatch"
  show  PEDValueUnrecoverable       = "value unrecoverable"
  show (PEDIncompatibleUpdates _ _) = "incompatible updates"
  show (PEDMultipleUpdates _ _)     = "multiple updates"
  show (PEDProdLeft e)              = show e
  show (PEDProdRight e)             = show e
  show (PEDEitherLeft e)            = show e
  show (PEDEitherRight e)           = show e
  show (PEDIn e)                    = show e

instance PrettyPrintable (PatExprDirError a) where
  toDoc e@PEDConstantMismatch          = text (show e)
  toDoc e@PEDEitherMismatch            = text (show e)
  toDoc e@PEDValueUnrecoverable        = text (show e)
  toDoc e@(PEDIncompatibleUpdates _ _) = text (show e)
  toDoc e@(PEDMultipleUpdates _ _)     = text (show e)
  toDoc (PEDProdLeft e)                = text "on the left-hand side of PProd" $+$ toDoc e
  toDoc (PEDProdRight e)               = text "on the right-hand side of PProd" $+$ toDoc e
  toDoc (PEDEitherLeft e)              = text "inside PLeft" $+$ toDoc e
  toDoc (PEDEitherRight e)             = text "inside PRight" $+$ toDoc e
  toDoc (PEDIn e)                      = text "inside PIn" $+$ toDoc e

liftE :: (a -> b) -> Either a c -> Either b c
liftE f = either (Left . f) Right