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
data Verbosity = None | Some | All
type CrashOnWarning = Bool
data Flags = Flags Verbosity CrashOnWarning
data Error = TypeNotFound Id
| RecBinding CoreBind
| CompilationNotSupported CoreBind
| CompilationError CoreBind SDoc
| OrderingFailedBinds Int [CoreBind]
| OrderingFailedTypes Int [Type]
| OtherError SDoc
pprTypeNotFound :: Verbosity -> Id -> SDoc
pprTypeNotFound :: Verbosity -> Id -> SDoc
pprTypeNotFound None _ = SDoc
empty
pprTypeNotFound Some id :: Id
id
= String -> SDoc
text "Could not obtain the type from"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 4 (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "::" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
varType Id
id) )
pprTypeNotFound All id :: Id
id = Verbosity -> Id -> SDoc
pprTypeNotFound Verbosity
Some Id
id
pprRecBinding :: Verbosity -> CoreBind -> SDoc
pprRecBinding :: Verbosity -> CoreBind -> SDoc
pprRecBinding None _ = SDoc
empty
pprRecBinding Some (Rec bs :: [(Id, Expr Id)]
bs)
= String -> SDoc
text "The binding is recursive and won't be substituted"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 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
id,_) -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "::" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
varType Id
id) ) [(Id, Expr Id)]
bs
pprRecBinding Some (NonRec id :: Id
id _)
= String -> SDoc
text "RecBinding error for non recursive binding...?"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 4 (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "::" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
varType Id
id) )
pprRecBinding All b :: CoreBind
b@(Rec _)
= String -> SDoc
text "--- The binding is recursive and won't be substituted ---"
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text ""
SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest 4 (CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
b)
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text ""
pprRecBinding All b :: CoreBind
b@(NonRec _ _)
= String -> SDoc
text "--- RecBinding error for non recursive binding ? ---"
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text ""
SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest 4 (CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
b)
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text ""
pprCompilationNotSupported :: Verbosity -> CoreBind -> SDoc
pprCompilationNotSupported :: Verbosity -> CoreBind -> SDoc
pprCompilationNotSupported None _ = SDoc
empty
pprCompilationNotSupported Some bind :: CoreBind
bind
= String -> SDoc
text "Compilation is not supported for bindings of the following format: "
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 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 -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "::" 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 All bind :: CoreBind
bind
= String -> SDoc
text "--- Compilation is not supported for bindings of the following format ---"
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text ""
SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest 4 (CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
bind)
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text ""
pprCompilationError :: Verbosity -> CoreBind -> SDoc -> SDoc
pprCompilationError :: Verbosity -> CoreBind -> SDoc -> SDoc
pprCompilationError None _ _ = SDoc
empty
pprCompilationError Some bind :: CoreBind
bind sdoc :: SDoc
sdoc
= String -> SDoc
text "Compilation failed for the following binding: "
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 4 ([SDoc] -> SDoc
vcat [SDoc]
ppr_ids)
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 4 (String -> SDoc
text "The error was:" SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 5 SDoc
sdoc)
where ppr_ids :: [SDoc]
ppr_ids = (Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\id :: Id
id -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "::" 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 All bind :: CoreBind
bind sdoc :: SDoc
sdoc
= String -> SDoc
text "--- Compilation failed for the following binding ---"
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text ""
SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest 4 (String -> SDoc
text "Error message: ")
SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest 4 SDoc
sdoc
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text ""
SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest 4 (CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
bind)
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text ""
pprOrderingFailedTypes :: Verbosity -> Int -> [Type] -> SDoc
pprOrderingFailedTypes :: Verbosity -> Int -> [Kind] -> SDoc
pprOrderingFailedTypes None _ _ = SDoc
empty
pprOrderingFailedTypes Some depth :: Int
depth types :: [Kind]
types
= String -> SDoc
text "Type ordering failed at depth" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
depth SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "for types:"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 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 All depth :: Int
depth types :: [Kind]
types = Verbosity -> Int -> [Kind] -> SDoc
pprOrderingFailedTypes Verbosity
Some Int
depth [Kind]
types
pprOrderingFailedBinds :: Verbosity -> Int -> [CoreBind] -> SDoc
pprOrderingFailedBinds :: Verbosity -> Int -> [CoreBind] -> SDoc
pprOrderingFailedBinds None _ _ = SDoc
empty
pprOrderingFailedBinds Some depth :: Int
depth binds :: [CoreBind]
binds
= String -> SDoc
text "CoreBind ordering failed at depth" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
depth SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "for bindings:"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 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 -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "::" 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 All depth :: Int
depth binds :: [CoreBind]
binds
= String -> SDoc
text "--- CoreBind ordering failed at depth" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
depth SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "for bindings ---"
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text "\n"
SDoc -> SDoc -> SDoc
$+$ Int -> SDoc -> SDoc
nest 4 ([SDoc] -> SDoc
vcat [SDoc]
ppr_binds)
SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text ""
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 None _ = SDoc
empty
pprOtherError _ sdoc :: SDoc
sdoc = SDoc
sdoc
pprError :: Verbosity -> Error -> SDoc
pprError :: Verbosity -> Error -> SDoc
pprError verb :: Verbosity
verb (TypeNotFound id :: Id
id ) = Verbosity -> Id -> SDoc
pprTypeNotFound Verbosity
verb Id
id
pprError verb :: Verbosity
verb (RecBinding bind :: CoreBind
bind) = Verbosity -> CoreBind -> SDoc
pprRecBinding Verbosity
verb CoreBind
bind
pprError verb :: Verbosity
verb (CompilationNotSupported bind :: CoreBind
bind) = Verbosity -> CoreBind -> SDoc
pprCompilationNotSupported Verbosity
verb CoreBind
bind
pprError verb :: Verbosity
verb (CompilationError bind :: CoreBind
bind str :: SDoc
str) = Verbosity -> CoreBind -> SDoc -> SDoc
pprCompilationError Verbosity
verb CoreBind
bind SDoc
str
pprError verb :: Verbosity
verb (OrderingFailedBinds d :: Int
d bs :: [CoreBind]
bs) = Verbosity -> Int -> [CoreBind] -> SDoc
pprOrderingFailedBinds Verbosity
verb Int
d [CoreBind]
bs
pprError verb :: Verbosity
verb (OrderingFailedTypes d :: Int
d ts :: [Kind]
ts) = Verbosity -> Int -> [Kind] -> SDoc
pprOrderingFailedTypes Verbosity
verb Int
d [Kind]
ts
pprError verb :: Verbosity
verb (OtherError sdoc :: SDoc
sdoc ) = Verbosity -> SDoc -> SDoc
pprOtherError Verbosity
verb SDoc
sdoc
stringToPpr :: String -> SDoc
stringToPpr :: String -> SDoc
stringToPpr str :: String
str = do
let taker :: Char -> Bool
taker ' ' = Bool
True
taker '\t' = Bool
True
taker _ = Bool
False
to_num :: Char -> p
to_num ' ' = 1
to_num '\t' = 4
to_num _ = 0
let nest_text :: String -> SDoc
nest_text str :: 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