{- CAO Compiler
Copyright (C) 2014 Cryptography and Information Security Group, HASLab - INESC TEC and Universidade do Minho
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see . -}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{- |
Module : $Header$
Description : Functions to handle errors and warnings.
Copyright : (C) 2014 Cryptography and Information Security Group, HASLab - INESC TEC and Universidade do Minho
License : GPL
Maintainer : Paulo Silva
Stability : experimental
Portability : non-portable
This module provides error and warning messages, as well as functions to
throw errors.
-}
module Language.CAO.Common.Error
( mkCaoWarningInfo
, WarningCode(..)
, CaoWarning
, mkCaoWarning
, CaoError
, mkCaoError
, ParserException(..)
, ErrorCode(..)
, TypeMismatchException(..)
, DeclException(..)
, CardinalityException(..)
, AssignmentKind(..)
, ScopeKind(..)
, TypeKind(..)
, showCaoError
, showCaoWarnings
, noWarning
, mkUnknownErr
) where
import Text.Read
import Control.Monad.Error
import Control.Monad.Writer
import Language.CAO.Index
import Language.CAO.Type
import Language.CAO.Common.Outputable ( PP, showPpr )
import Language.CAO.Common.Polynomial
import Language.CAO.Common.SrcLoc
import Language.CAO.Common.Utils
import Language.CAO.Common.Var
-- CaoWarning ------------------------------------------------------------------
data WarningInfo = forall id . PP id
=> WarningInfo !SrcLoc !String !(WarningCode id)
mkCaoWarningInfo :: PP id => SrcLoc -> String -> WarningCode id -> WarningInfo
mkCaoWarningInfo = WarningInfo
data WarningCode id =
BaseExtensionWarn !(Pol id)
| PolExtensionWarn !(Pol id)
-- | Warnings for transformations/optimizations
| IndistFail id id
| DeadCodeReturn
| NoProverWarning (ICond id)
showWarningCode :: PP id => WarningCode id -> String
showWarningCode warn = case warn of
BaseExtensionWarn b ->
"Base `" ++ showPpr b ++ "' must be a prime number"
PolExtensionWarn p ->
"Polynomial `" ++ showPpr p ++ "' must be irreducible"
IndistFail i1 i2 ->
"Could not apply side-channel countermeasures: `"
++ showPpr i1 ++ ", " ++ showPpr i2
DeadCodeReturn ->
"Removing dead code after return"
NoProverWarning c ->
"Yices prover not available. The following restriction was admitted without proof:\n" ++ showPpr c
newtype CaoWarning = CaoWarning [WarningInfo]
mkCaoWarning :: WarningInfo -> CaoWarning
mkCaoWarning i = CaoWarning [i]
instance Monoid CaoWarning where
mempty = CaoWarning []
(CaoWarning l) `mappend` (CaoWarning l') = CaoWarning $! l `mappend` l'
showWarningInfo :: WarningInfo -> String
showWarningInfo (WarningInfo sl fln w) =
fln ++ ":" ++ showPpr sl ++ ":\n" ++
nestStr 4 ("[Warning] " ++ showWarningCode w)
showCaoWarnings :: CaoWarning -> String
showCaoWarnings (CaoWarning l) = unlines $ map showWarningInfo l
noWarning :: CaoWarning -> Bool
noWarning (CaoWarning w) = null w
-- CaoError --------------------------------------------------------------------
data CaoError = forall id . (Show id, Read id, PP id)
=> CaoError SrcLoc String (ErrorCode id)
instance Show CaoError where
show (CaoError loc s e) =
"CaoError " ++ '(': show loc ++ ") " ++ show s ++ " (" ++ show e ++ ")"
instance Read CaoError where
readsPrec i s = case [ x | (x,"") <- readPrec_to_S (readAsT errcds) i s ] of
[] -> []
(x:_) -> [(x, "")]
errcds :: (String, (Name, (Var, ())))
errcds = undefined
class ReadAsT t e where
readAsT :: t -> ReadPrec e
instance ReadAsT () e where
readAsT ~() = mzero
instance (Read t, Show t, PP t, ReadAsT ts CaoError)
=> ReadAsT (t,ts) CaoError where
readAsT ~(t,ts)
= goR t `mplus` readAsT ts
where
goR :: t -> ReadPrec CaoError
goR _ = prec 5 $ do
Ident "CaoError" <- lexP
l <- parens $ step readPrec
s <- step readPrec
cd <- parens $ step readPrec
return $ CaoError l s (cd :: ErrorCode t)
mkCaoError
:: (Show id, Read id, PP id)
=> SrcLoc -> String -> ErrorCode id
-> CaoError
mkCaoError = CaoError
instance Error CaoError where
noMsg = CaoError defSrcLoc ""
((UnknownErr "noMsg")::ErrorCode String)
strMsg mstr = CaoError defSrcLoc ""
((UnknownErr mstr)::ErrorCode String)
showCaoError :: CaoError -> String
showCaoError (CaoError sl fln e) =
fln ++ ":" ++ showPpr sl ++ ":\n" ++ nestStr 4 (showErrorCode e)
-- Error Messages --------------------------------------------------------------
data ErrorCode id
= IntEvalErr
| TimesMatrixErr
| PowerMatrixErr
| FuncReturnErr
| SeqRangeErr
| LiteralModErr (Mon id) (Type id)
| UnknownLiteralErr (Mon id)
| PolynomialErr (Pol id)
| ExpressionErr id
| NotDefinedCodeErr
| UnknownErr String
| MultipleErr [CaoError]
| StrictModeErr
| ContainerInitErr
| NestedModpolErr (Type id)
| NotSupportedTypeErr (Type id)
| NotSupportedOp String (Type id)
| NotSupportedVar String (Type id)
-- XXX: Not supported is not the best name....
| NotSupportedIndexTyp
| NotSupportedIndexOp
| NotSupportedIndexLit
| ParserException ParserException
| ScopeException id ScopeKind
| BadUseException id ScopeKind
| TypeMismatchException (Type id) (Type id) TypeMismatchException
| WrongTypeException (Type id) TypeKind
| SemanticException SemanticException
| DeclException (DeclException id)
| RangeException TypeKind
| CardinalityException CardinalityException
deriving (Show, Read)
data TypeMismatchException
= CastException
| MatchException
| UnificationException
deriving (Show, Read)
data ScopeKind
= GenericScope
| IndScope
| VarScope
| TypeScope
| ProcScope
| FuncScope
| IndetScope
| SFieldScope Name
deriving (Show, Read)
data TypeKind
= AlgebraicType
| ModType
| IntOrModType
| BitsType
| BitsOrVectorType
| VectorType
| MatrixType
| StructType
deriving (Show, Read)
data SemanticException
= DivByZeroException
| ModDivException
| RemByZeroException
| NegativeExponentException
| VectorAccessException
| MatrixRowAccessException
| MatrixColAccessException
deriving (Show, Read)
data ParserException
= LexicalException String
| ParsingException String
| EOFException
deriving (Show, Read)
data DeclException id
= SizeDeclException (IExpr id) (Maybe (IExpr id)) TypeKind
| BaseDeclException (IExpr id)
| MultipleDeclException id
deriving (Show, Read)
data CardinalityException
= AssignCardinalityException AssignmentKind
| ParamsCardinalityException
| InitCardinalityException TypeKind
deriving (Show, Read)
data AssignmentKind
= MultipleAssign
| TupleAssign
deriving (Show, Read)
mkUnknownErr :: String -> ErrorCode String
mkUnknownErr = UnknownErr
showErrorCode :: PP id => ErrorCode id -> String
showErrorCode err = case err of
IntEvalErr ->
"Expression could not be evaluated during compilation"
TimesMatrixErr ->
"Multiplication only is possible if the number of columns of left matrix\n" ++
" is the same as the number of rows of right matrix"
PowerMatrixErr ->
"Exponentiation only is possible on square matrices"
FuncReturnErr ->
"Function must return a value"
SeqRangeErr ->
"Invalid bounds or stepping distance in seq statement"
LiteralModErr lit t ->
"Literal `[" ++ showPpr lit ++ "]' is not a valid literal of type `" ++
showPpr t ++ "'"
UnknownLiteralErr lit ->
"Literal `[" ++ showPpr lit ++ "]' has unknown type"
PolynomialErr pol ->
"Polynomial literal `[" ++ showPpr pol ++ "]' is not in canonical form"
ExpressionErr cmd ->
"Not an expression: `" ++ showPpr cmd ++ "'"
NotDefinedCodeErr ->
"The specification of the current platform does not define type codes"
UnknownErr str ->
"Unexpected error occurred:\n" ++ str
MultipleErr lst ->
unlines $ map showCaoError lst
StrictModeErr ->
"Unexpected declaration on non dependent type checking mode"
NotSupportedIndexTyp ->
"Not valid index type"
NotSupportedIndexOp ->
"Not supported operations on indexes"
NotSupportedIndexLit ->
"Not supported index literal"
ContainerInitErr ->
"Initialization with multiple values only is possible for container types"
NestedModpolErr t ->
"Translation does not support nested polynomial extensions:\n\t`" ++
showPpr t ++ "'"
NotSupportedTypeErr t ->
"Translation for the current platform does not support the type:\n\t`" ++
showPpr t ++ "'"
NotSupportedOp op t ->
"Translation for the current platform does not support the operation `"
++ op ++ "' for type:\n\t`" ++ showPpr t ++ "'"
NotSupportedVar op t ->
"Translation for the current platform does not support variables of type `"
++ showPpr t ++ "' in operation `" ++ op
++ "'. Only constants are allowed."
ParserException k -> showParserException k
ScopeException a k -> showScopeException a k
BadUseException a k -> showBadUseException a k
TypeMismatchException t1 t2 k -> showTypeMismatchException t1 t2 k
WrongTypeException t k -> showWrongTypeException t k
SemanticException k -> showSemanticException k
DeclException e -> showDeclException e
RangeException k -> showRangeException k
CardinalityException e -> showCardinalityException e
showParserException :: ParserException -> String
showParserException k = case k of
LexicalException s ->
"Lexical error at character '" ++ s ++ "'"
ParsingException tok ->
"Parse error on input `" ++ tok ++ "'"
EOFException ->
"Parse error at end of input"
showScopeKind :: ScopeKind -> String
showScopeKind k = case k of
GenericScope -> ""
VarScope -> "variable"
IndScope -> "index"
FuncScope -> "function"
ProcScope -> "procedure"
TypeScope -> "type or struct"
IndetScope -> "indeterminate"
SFieldScope s -> "field of struct `" ++ showPpr s ++ "'"
showTypeMismatchException :: PP id => Type id -> Type id -> TypeMismatchException -> String
showTypeMismatchException it et kind = case kind of
CastException ->
"Couldn't cast inferred type `" ++ showPpr it ++ "'\n" ++
" to casting type `" ++ showPpr et ++ "'"
MatchException ->
"Couldn't match expected type `" ++ showPpr et ++ "'\n" ++
" against inferred type `" ++ showPpr it ++ "'"
UnificationException ->
"Couldn't unify type `" ++ showPpr it ++ "'\n" ++
" with type `" ++ showPpr et ++ "'"
showScopeException :: PP id => id -> ScopeKind -> String
showScopeException v kind = "Symbol not found in current scope: "
++ showScopeKind kind ++ " `" ++ showPpr v ++ "'"
showBadUseException :: PP id => id -> ScopeKind -> String
showBadUseException v kind =
"Bad use of " ++ showScopeKind kind ++ " `" ++ showPpr v ++ "'"
showWrongTypeException :: PP id => Type id -> TypeKind -> String
showWrongTypeException t kind =
"Couldn't match expected " ++ showTypeKind kind ++ " type\n" ++
" against inferred type `" ++ showPpr t ++ "'"
showTypeKind :: TypeKind -> String
showTypeKind k = case k of
AlgebraicType -> "algebraic"
ModType -> "mod"
IntOrModType -> "int or mod"
BitsType -> "bits"
BitsOrVectorType -> "bits or vector"
VectorType -> "vector"
MatrixType -> "matrix"
StructType -> "struct"
showSemanticException :: SemanticException -> String
showSemanticException k = case k of
VectorAccessException ->
"Invalid index in vector selection"
MatrixRowAccessException ->
"Invalid row index in matrix selection"
MatrixColAccessException ->
"Invalid column index in matrix selection"
DivByZeroException ->
"Invalid division by zero"
NegativeExponentException ->
"Negative exponent"
ModDivException ->
"Invalid mod division"
RemByZeroException ->
"Invalid remainder by zero"
showDeclException :: PP id => DeclException id -> String
showDeclException e = case e of
SizeDeclException i mi k ->
"Invalid size [" ++
showPpr i ++ maybe "" ((", " ++) . showPpr) mi ++
"] in " ++ showTypeKind k ++ " type declaration"
BaseDeclException i ->
"Invalid modulus `" ++ showPpr i ++ "' in mod type declaration"
MultipleDeclException v ->
"Multiple declarations of `" ++ showPpr v ++ "'"
showRangeException :: TypeKind -> String
showRangeException kind =
"Invalid range in " ++ showTypeKind kind ++ " selection"
showCardinalityException :: CardinalityException -> String
showCardinalityException e = case e of
AssignCardinalityException k ->
"The number of left values does not match the number of right " ++ showAssignmentKind k
ParamsCardinalityException ->
"Invalid number of parameters"
InitCardinalityException k ->
"Initialization doesn't match " ++ showTypeKind k ++ "dimension"
where
showAssignmentKind k = case k of
MultipleAssign -> "expresions"
TupleAssign -> " values returned by the function"