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

-- | Print an error according to verbosity flag.
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


-- | Change String to SDoc.
-- Each newline is $$ed with nest equal to spaces before.
-- \t is 4.
stringToPpr :: String -> SDoc
stringToPpr :: String -> SDoc
stringToPpr str :: String
str = do
    -- Whether to take a letter
    let taker :: Char -> Bool
taker   ' ' = Bool
True
        taker  '\t' = Bool
True
        taker  _    = Bool
False
    -- Whether to 
        to_num :: Char -> p
to_num  ' ' = 1
        to_num '\t' = 4
        to_num _    = 0
    -- Function doing the nesting
    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