{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}

-- | Exceptions that may be thrown by the large-records plugin.
module Data.Record.Internal.Plugin.Exception (
    Exception(..)
  , exceptionLoc
  , exceptionToSDoc
  ) where

import Data.Record.Internal.GHC.Shim

data Exception =
    UnsupportedStockDeriving (LHsType GhcPs)
  | UnsupportedStrategy (LDerivStrategy GhcPs)
  | InvalidDeclaration (LHsDecl GhcPs)

exceptionLoc :: Exception -> SrcSpan
exceptionLoc :: Exception -> SrcSpan
exceptionLoc = \case
    UnsupportedStockDeriving (LHsType GhcPs -> LHsType GhcPs
forall a. Located a -> Located a
reLoc -> L SrcSpan
l HsType GhcPs
_) -> SrcSpan
l
    UnsupportedStrategy      (LDerivStrategy GhcPs -> LDerivStrategy GhcPs
forall a. a -> a
id    -> L SrcSpan
l DerivStrategy GhcPs
_) -> SrcSpan
l
    InvalidDeclaration       (LHsDecl GhcPs -> LHsDecl GhcPs
forall a. Located a -> Located a
reLoc -> L SrcSpan
l HsDecl GhcPs
_) -> SrcSpan
l

exceptionToSDoc :: Exception -> SDoc
exceptionToSDoc :: Exception -> SDoc
exceptionToSDoc = [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> (Exception -> [SDoc]) -> Exception -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    UnsupportedStockDeriving LHsType GhcPs
ty -> [
        SDoc
"Unsupported stock class: "
      , LHsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
ty
      ]
    UnsupportedStrategy (L SrcSpan
_ DerivStrategy GhcPs
strategy) -> [
        SDoc
"Strategy "
      , DerivStrategy GhcPs -> SDoc
forall a. DerivStrategy a -> SDoc
derivStrategyName DerivStrategy GhcPs
strategy
      , SDoc
" is not supported"
      ]
    InvalidDeclaration LHsDecl GhcPs
_decl -> [
        SDoc
"Unsupported declaration for large-records"
      ]