{-|
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.  

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

import Id (Id)
import Var(Var(..))
import CoreSyn (CoreBind(..), Bind(..),CoreExpr(..))
import Type (Type)
import Outputable

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

pprRecBinding :: Verbosity -> CoreBind -> SDoc
pprRecBinding :: Verbosity -> CoreBind -> SDoc
pprRecBinding Verbosity
None CoreBind
_ = SDoc
empty
pprRecBinding Verbosity
Some (Rec [(Id, Expr Id)]
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 = ((Id, Expr Id) -> SDoc) -> [(Id, Expr Id)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
id,Expr Id
_) -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
varType Id
id) ) [(Id, Expr Id)]
bs
pprRecBinding Verbosity
Some (NonRec Id
id Expr Id
_) 
    =    String -> SDoc
text String
"RecBinding error for non recursive binding...?"
      SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
varType Id
id) )  
pprRecBinding Verbosity
All  b :: CoreBind
b@(Rec [(Id, Expr Id)]
_) 
    =     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 (CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
b)
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
""
pprRecBinding Verbosity
All  b :: CoreBind
b@(NonRec Id
_ Expr Id
_) 
    =     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 (CoreBind -> SDoc
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 = (Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\Id
id -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
varType Id
id) ) ([Id] -> [SDoc]) -> [Id] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ CoreBind -> [Id]
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 (CoreBind -> SDoc
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 = (Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\Id
id -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
varType Id
id) ) ([Id] -> [SDoc]) -> [Id] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ CoreBind -> [Id]
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 (CoreBind -> SDoc
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 = (Kind -> SDoc) -> [Kind] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> SDoc
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 = (Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\Id
id -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
varType Id
id)) ([Id] -> [SDoc]) -> [Id] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (CoreBind -> [Id]) -> [CoreBind] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [Id]
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 = (CoreBind -> SDoc) -> [CoreBind] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CoreBind -> SDoc
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            Id
id  ) = Verbosity -> Id -> SDoc
pprTypeNotFound Verbosity
verb Id
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 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 -> p
to_num  Char
' ' = p
1
        to_num Char
'\t' = p
4
        to_num Char
_    = p
0
    -- Function doing the nesting
    let nest_text :: String -> SDoc
nest_text String
str = do
            let whites :: String
whites = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
taker String
str
                rest :: String
rest   = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
taker String
str
                num :: Int
num    = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
forall p. Num p => Char -> p
to_num String
whites
            Int -> SDoc -> SDoc
nest Int
num (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
rest
    [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
nest_text ([String] -> [SDoc]) -> [String] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
str