{-|
Module      : Foreign.Storable.Generic.Plugin.Internal.Error
Copyright   : (c) Mateusz Kłoczko, 2016
License     : MIT
Maintainer  : mateusz.p.kloczko@gmail.com
Stability   : experimental
Portability : GHC-only

Contains the Error datatype and related pretty print functions.  

-}
{-# LANGUAGE CPP #-}
module Foreign.Storable.Generic.Plugin.Internal.Error 
    ( Verbosity(..)
    , CrashOnWarning(..)
    , Flags(..)
    , Error(..)
    , pprError
    , stringToPpr
    ) where

#if   MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Types.Id  (Id)
import GHC.Types.Var (Var(..))
import GHC.Core (CoreBind(..), Bind(..),CoreExpr(..))
import GHC.Core.Type (Type)
import GHC.Utils.Outputable
#else
import Id (Id)
import Var(Var(..))
import CoreSyn (CoreBind(..), Bind(..),CoreExpr(..))
import Type (Type)
import Outputable
#endif

import Foreign.Storable.Generic.Plugin.Internal.Helpers

-- | How verbose should the messages be.
data Verbosity = None | Some | All 

-- | Crash when an recoverable error occurs. For testing purposes.
type CrashOnWarning = Bool

-- | Contains user-specified flags.
data Flags = Flags Verbosity CrashOnWarning

-- | All possible errors.
data Error = TypeNotFound Id                         -- ^ Could not obtain the type from the id.
           | RecBinding CoreBind                     -- ^ The binding is recursive and won't be substituted.
           | CompilationNotSupported CoreBind        -- ^ The compilation-substitution is not supported for the given binding.
           | CompilationError        CoreBind [SDoc] -- ^ Error during compilation. The CoreBind is to be returned.
           | OrderingFailedBinds Int [CoreBind]      -- ^ Ordering failed for core bindings.
           | OrderingFailedTypes Int [Type]          -- ^ Ordering failed for types
           | OtherError          SDoc                -- ^ Any other error.

pprTypeNotFound :: Verbosity -> Id -> SDoc
pprTypeNotFound :: Verbosity -> CoreBndr -> SDoc
pprTypeNotFound Verbosity
None CoreBndr
_  = SDoc
empty 
pprTypeNotFound Verbosity
Some CoreBndr
id 
    =    String -> SDoc
text String
"Could not obtain the type from" 
      SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 (forall a. Outputable a => a -> SDoc
ppr CoreBndr
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (CoreBndr -> Kind
varType CoreBndr
id) )  
pprTypeNotFound Verbosity
All CoreBndr
id  = Verbosity -> CoreBndr -> SDoc
pprTypeNotFound Verbosity
Some CoreBndr
id

pprRecBinding :: Verbosity -> CoreBind -> SDoc
pprRecBinding :: Verbosity -> CoreBind -> SDoc
pprRecBinding Verbosity
None CoreBind
_ = SDoc
empty
pprRecBinding Verbosity
Some (Rec [(CoreBndr, Expr CoreBndr)]
bs) 
    =    String -> SDoc
text String
"The binding is recursive and won't be substituted"
      SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
vcat [SDoc]
ppr_ids)
    where ppr_ids :: [SDoc]
ppr_ids = forall a b. (a -> b) -> [a] -> [b]
map (\(CoreBndr
id,Expr CoreBndr
_) -> forall a. Outputable a => a -> SDoc
ppr CoreBndr
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (CoreBndr -> Kind
varType CoreBndr
id) ) [(CoreBndr, Expr CoreBndr)]
bs
pprRecBinding Verbosity
Some (NonRec CoreBndr
id Expr CoreBndr
_) 
    =    String -> SDoc
text String
"RecBinding error for non recursive binding...?"
      SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 (forall a. Outputable a => a -> SDoc
ppr CoreBndr
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (CoreBndr -> Kind
varType CoreBndr
id) )  
pprRecBinding Verbosity
All  b :: CoreBind
b@(Rec [(CoreBndr, Expr CoreBndr)]
_) 
    =     String -> SDoc
text String
"--- The binding is recursive and won't be substituted ---"
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
""
      SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest Int
4 (forall a. Outputable a => a -> SDoc
ppr CoreBind
b)
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
""
pprRecBinding Verbosity
All  b :: CoreBind
b@(NonRec CoreBndr
_ Expr CoreBndr
_) 
    =     String -> SDoc
text String
"--- RecBinding error for non recursive binding ? ---"
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
""
      SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest Int
4 (forall a. Outputable a => a -> SDoc
ppr CoreBind
b)
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
""

pprCompilationNotSupported :: Verbosity -> CoreBind -> SDoc
pprCompilationNotSupported :: Verbosity -> CoreBind -> SDoc
pprCompilationNotSupported Verbosity
None CoreBind
_   = SDoc
empty
pprCompilationNotSupported Verbosity
Some CoreBind
bind 
    =    String -> SDoc
text String
"Compilation is not supported for bindings of the following format: "
      SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
vcat [SDoc]
ppr_ids)
    where ppr_ids :: [SDoc]
ppr_ids = forall a b. (a -> b) -> [a] -> [b]
map (\CoreBndr
id -> forall a. Outputable a => a -> SDoc
ppr CoreBndr
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (CoreBndr -> Kind
varType CoreBndr
id) ) forall a b. (a -> b) -> a -> b
$ CoreBind -> [CoreBndr]
getIdsBind CoreBind
bind
pprCompilationNotSupported Verbosity
All  CoreBind
bind 
    =     String -> SDoc
text String
"--- Compilation is not supported for bindings of the following format ---"
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
""
      SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest Int
4 (forall a. Outputable a => a -> SDoc
ppr CoreBind
bind) 
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
""



pprCompilationError :: Verbosity -> CoreBind -> SDoc -> SDoc
pprCompilationError :: Verbosity -> CoreBind -> SDoc -> SDoc
pprCompilationError Verbosity
None CoreBind
_ SDoc
_  = SDoc
empty
pprCompilationError Verbosity
Some CoreBind
bind SDoc
sdoc
    =    String -> SDoc
text String
"Compilation failed for the following binding: "
      SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
vcat [SDoc]
ppr_ids)
      SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 (String -> SDoc
text String
"The error was:" SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
5 SDoc
sdoc)
    where ppr_ids :: [SDoc]
ppr_ids = forall a b. (a -> b) -> [a] -> [b]
map (\CoreBndr
id -> forall a. Outputable a => a -> SDoc
ppr CoreBndr
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (CoreBndr -> Kind
varType CoreBndr
id) ) forall a b. (a -> b) -> a -> b
$ CoreBind -> [CoreBndr]
getIdsBind CoreBind
bind
pprCompilationError Verbosity
All  CoreBind
bind SDoc
sdoc
    =     String -> SDoc
text String
"--- Compilation failed for the following binding ---"
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
""
      SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest Int
4 (String -> SDoc
text String
"Error message: ")
      SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest Int
4 SDoc
sdoc
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
""
      SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest Int
4 (forall a. Outputable a => a -> SDoc
ppr CoreBind
bind) 
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
""


pprOrderingFailedTypes :: Verbosity -> Int -> [Type] -> SDoc
pprOrderingFailedTypes :: Verbosity -> Int -> [Kind] -> SDoc
pprOrderingFailedTypes Verbosity
None Int
_ [Kind]
_ = SDoc
empty
pprOrderingFailedTypes Verbosity
Some Int
depth [Kind]
types 
    =    String -> SDoc
text String
"Type ordering failed at depth" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
depth SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"for types:"
      SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
vcat [SDoc]
ppr_types)
    where ppr_types :: [SDoc]
ppr_types = forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [Kind]
types
pprOrderingFailedTypes Verbosity
All  Int
depth [Kind]
types = Verbosity -> Int -> [Kind] -> SDoc
pprOrderingFailedTypes Verbosity
Some Int
depth [Kind]
types

pprOrderingFailedBinds :: Verbosity -> Int -> [CoreBind] -> SDoc
pprOrderingFailedBinds :: Verbosity -> Int -> [CoreBind] -> SDoc
pprOrderingFailedBinds Verbosity
None Int
_ [CoreBind]
_ = SDoc
empty
pprOrderingFailedBinds Verbosity
Some Int
depth [CoreBind]
binds 
    =    String -> SDoc
text String
"CoreBind ordering failed at depth" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
depth SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"for bindings:"
      SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
vcat [SDoc]
ppr_ids)
    where ppr_ids :: [SDoc]
ppr_ids = forall a b. (a -> b) -> [a] -> [b]
map (\CoreBndr
id -> forall a. Outputable a => a -> SDoc
ppr CoreBndr
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (CoreBndr -> Kind
varType CoreBndr
id)) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [CoreBndr]
getIdsBind [CoreBind]
binds
pprOrderingFailedBinds Verbosity
All  Int
depth [CoreBind]
binds
    =     String -> SDoc
text String
"--- CoreBind ordering failed at depth" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
depth SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"for bindings ---"
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
"\n"
      SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
vcat [SDoc]
ppr_binds)
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
""
    where ppr_binds :: [SDoc]
ppr_binds = forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [CoreBind]
binds

pprOtherError :: Verbosity -> SDoc -> SDoc
pprOtherError :: Verbosity -> SDoc -> SDoc
pprOtherError Verbosity
None SDoc
_   = SDoc
empty
pprOtherError Verbosity
_    SDoc
sdoc = SDoc
sdoc

-- | Print an error according to verbosity flag.
pprError :: Verbosity -> Error -> SDoc
pprError :: Verbosity -> Error -> SDoc
pprError Verbosity
verb (TypeNotFound            CoreBndr
id  ) = Verbosity -> CoreBndr -> SDoc
pprTypeNotFound Verbosity
verb CoreBndr
id
pprError Verbosity
verb (RecBinding              CoreBind
bind) = Verbosity -> CoreBind -> SDoc
pprRecBinding   Verbosity
verb CoreBind
bind
pprError Verbosity
verb (CompilationNotSupported CoreBind
bind) = Verbosity -> CoreBind -> SDoc
pprCompilationNotSupported Verbosity
verb CoreBind
bind
pprError Verbosity
verb (CompilationError    CoreBind
bind [SDoc]
str) = Verbosity -> CoreBind -> SDoc -> SDoc
pprCompilationError Verbosity
verb CoreBind
bind forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [SDoc]
str
pprError Verbosity
verb (OrderingFailedBinds Int
d    [CoreBind]
bs) = Verbosity -> Int -> [CoreBind] -> SDoc
pprOrderingFailedBinds Verbosity
verb Int
d [CoreBind]
bs
pprError Verbosity
verb (OrderingFailedTypes Int
d    [Kind]
ts) = Verbosity -> Int -> [Kind] -> SDoc
pprOrderingFailedTypes Verbosity
verb Int
d [Kind]
ts
pprError Verbosity
verb (OtherError          SDoc
sdoc   ) = Verbosity -> SDoc -> SDoc
pprOtherError          Verbosity
verb SDoc
sdoc


-- | Change String to SDoc.
-- Each newline is $$ed with nest equal to spaces before.
-- \t is 4.
stringToPpr :: String -> SDoc
stringToPpr :: String -> SDoc
stringToPpr String
str = do
    -- Whether to take a letter
    let taker :: Char -> Bool
taker   Char
' ' = Bool
True
        taker  Char
'\t' = Bool
True
        taker  Char
_    = Bool
False
    -- Whether to 
        to_num :: Char -> a
to_num  Char
' ' = a
1
        to_num Char
'\t' = a
4
        to_num Char
_    = a
0
    -- Function doing the nesting
    let nest_text :: String -> SDoc
nest_text String
str = do
            let whites :: String
whites = forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
taker String
str
                rest :: String
rest   = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
taker String
str
                num :: Int
num    = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Num a => Char -> a
to_num String
whites
            Int -> SDoc -> SDoc
nest Int
num forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
rest
    [SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
nest_text forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
str