forsyde-deep-0.2.0: src/ForSyDe/Deep/ForSyDeErr.hs
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module : ForSyDe.ForSyDeErr
-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : forsyde-dev@ict.kth.se
-- Stability : experimental
-- Portability : portable
--
-- ForSyDe error-related types and functions.
--
-----------------------------------------------------------------------------
module ForSyDe.Deep.ForSyDeErr
(ForSyDeErr(..),
ContextErr(..),
VHDLFunErr(..),
VHDLExpErr(..),
Context(..),
setProcC,
setProcFunC,
setProcValC,
Loc,
EProne,
liftEither,
uError,
intError,
qError,
qGiveUp,
qPutTraceMsg,
printError,
printVHDLError,
printGraphMLError,
module Control.Monad.Error,
module Debug.Trace) where
import ForSyDe.Deep.Ids
import Data.Maybe (fromMaybe)
import Debug.Trace
import Control.Monad.Error
import Data.Dynamic
import Language.Haskell.TH.Syntax hiding (Loc)
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.PprLib
import Text.PrettyPrint.HughesPJ (render)
import Data.Typeable.FSDTypeRepLib
-------------
-- ForSyDeErr
-------------
-- | All Errors thrown or displayed in ForSyDe
data ForSyDeErr =
-- Used in ForSyDe.ForSyDeErr
InconsistentContexts |
-- Used in ForSyDe.Netlist
EvalErr String |
-- Used in ForSyDe.System.*
-- | Not a variable name
NonVarName Name |
-- | Incompatible system function
IncomSysF Name Type |
-- | Incompatible input interface length
InIfaceLength (SysId,Int) ([String],Int) |
-- | Incompatible output interface length
OutIfaceLength (SysId,Int) ([String],Int) |
-- | Multiply defined port identifier
MultPortId PortId |
-- | Multiply defined process identifier
MultProcId ProcId |
-- | The system contains components from different subsystems with
-- the same Identifiers
SubSysIdClash SysId (Maybe Loc) (Maybe Loc) |
-- | Not a SysDef variable
NonSysDef Name Type |
-- Used in ForSyDe.Proc.ProcFun
-- | Incorrect Declarations provided to create a ProcFun
IncorrProcFunDecs [Dec] |
-- Used in ForSyDe.Netlist.Traversable
-- | Inconsistent output tag
InconsOutTag |
-- Used in ForSyDe.Backend.Simulate
-- | Inconsistent System Definition Port
InconsSysDefPort PortId |
-- | Dynamic type mismatch
DynMisMatch Dynamic TypeRep |
-- | Signature mismatch
SigMisMatch Type |
-- | Simulation input signals length mismatch
InLengthMisMatch Int Int |
-- Used in ForSyDe.Backend.VHDL.*
-- | Empty VHDL identifier
EmptyVHDLId |
-- | Incorrect Basic VHDL Identifier
IncVHDLBasId String |
-- | Incorrect Extended VHDL Identifier
IncVHDLExtId String |
-- | Function untranslatable to VHDL (function name and error raised)
UntranslatableVHDLFun VHDLFunErr |
-- | Expresion untranslatable to VHDL
UntranslatableVHDLExp Exp VHDLExpErr |
-- Common Backend errors
-- | UnsUpported type
UnsupportedType FSDTypeRep |
-- | Reserved identifier
ReservedId String |
-- | Unsupported process
UnsupportedProc |
-- | Quartus Failed
QuartusFailed |
-- | Ghdl Failed
GhdlFailed |
-- | Modelsim Failed
ModelsimFailed |
-- | Other Errors
Other String
-- | Function translation errors in the VHDL backend
data VHDLFunErr =
-- | Polymorphic declaration
PolyDec Dec |
-- | Unsupported declaration block
UnsupportedDecBlock [Dec] |
-- | Insufficient number of parameters
InsParamNum Name Int |
-- | Unsupported input pattern in function
UnsupportedFunPat Pat |
-- | Multiple clauses
MultipleClauses [Clause] |
-- | Guards in case alternatives are not supported
FunGuardedBody Body |
-- | A general Error which applies to a function
-- (e.g. its name or parameters are not a VHDL identifier,
-- an error in an inner expression ... )
GeneralErr ForSyDeErr
instance Show VHDLFunErr where
show (PolyDec dec) = "polymorphic daclaration:\n" ++
pprint dec ++
"\nDeclarations within a ProcFun must be monomorphic in order to be " ++
"translatable to VHDL"
show (UnsupportedDecBlock decs) = "Unsupported declaration block:\n" ++
concatMap pprint decs ++
"All declaration blocks within a process function must follow the following " ++
"pattern:\n" ++
" name1 :: type\n" ++
" name1 arg1 arg2 ... = defintion1\n" ++
" name2 :: type\n" ++
" name2 arg1 arg2 .... = defintion2\n"
show (FunGuardedBody body) = "guards are not supported in functions:\n" ++
(render.to_HPJ_Doc.(pprBody True)) body
show (InsParamNum name n) =
"insufficient number of parameters (" ++ show n ++ ") in the defintion of `" ++
pprint name ++
"'\n point free definitons are not suported by the VHDL backend"
show (UnsupportedFunPat pat) =
"input pattern `" ++ pprint pat ++ "' is not supported"
show (MultipleClauses cs) = "multiple clauses (" ++
(show.length) cs ++ "):\n" ++ pprint cs
show (GeneralErr err) = show err
-- | Expression translation errors in the VHDL backend
data VHDLExpErr =
-- | Guards in case alternatives are not supported
CaseGuardedBody Body |
-- Unsupported case pattern
UnsupportedCasePat Pat |
-- | Where constructs in case alternatives are not supported
CurryUnsupported Int Int |
-- | Unkown identifier
UnkownIdentifier Name |
-- Unsupported literal
UnsupportedLiteral |
-- Sections are not supported
Section |
-- Lambda Abstractions are not supported
LambdaAbstraction |
-- Conditional expressions are only supported in a function body
Conditional |
-- Case expressions are only supported in a function body
Case |
-- Do expressions are not supported
Do |
-- List comprehensions are not supported
ListComprehension |
-- Arithmetic sequences are not supported
ArithSeq |
-- Lists are not supported
List |
-- Signature expressiosn are not supported
Signature |
-- Record expressions are not supported
Record |
-- Unsupported expression generic error
-- it shouldn't be raised, just for pattern completeness
Unsupported
instance Show VHDLExpErr where
show (CaseGuardedBody body) =
"guards are not supported in case alternatives:\n" ++
(render.to_HPJ_Doc.(pprBody True)) body
show (UnsupportedCasePat pat) = "unsupported case pattern: `" ++
pprint pat ++ "'"
show (CurryUnsupported expected real) =
"Currification is not supported, all arguments must be fully supplied\n"++
" Expected arguments: " ++ show expected ++ " Provided arguments: " ++
show real
show (UnkownIdentifier name) = "unkown identifier `" ++ pprint name ++ "'"
show UnsupportedLiteral = "unsupported literal"
show Section = "sections are not supported"
show LambdaAbstraction = "lambda abstractions are not supported"
show Conditional = "conditional expressions are only supported within"
++ " a function body"
show Case = "case expressions are only supported within"
++ " a function body"
show Do = "do expressions are not suupported"
show ListComprehension = "list comprehensions are not supported"
show ArithSeq = "arithmetic sequences are not supported"
show List = "lists are not supported"
show Signature = "signature expressions are not supported"
show Record = "record expressions are not supported"
show Unsupported = "unsupported expression"
-- | Show errors
instance Show ForSyDeErr where
show InconsistentContexts = "Inconsistent contexts"
show (EvalErr str) = "Non evaluable node (" ++ show str ++ ")"
show (NonVarName name) = show name ++ " is not a variable name."
show (IncomSysF fName inctype) =
"Incompatible system function type\n"++
show strFName ++ " was expected to have type:\n" ++
" Signal i1 -> Signal i2 -> ..... -> Signal in ->\n" ++
" (Signal o1, Signal o2, ... , Signal om)\n" ++
" with n <- |N U {0} and m <- |N U {0}\n" ++
" i1 .. in, o1 .. im monomorphic types\n" ++
"However " ++ strFName ++ " has type\n " ++
" " ++ pprint inctype
where strFName = show fName
show (InIfaceLength sysInInfo portIdsInInfo) =
showIfaceLength "input interface" sysInInfo portIdsInInfo
show (OutIfaceLength sysOutInfo portIdsOutInfo) =
showIfaceLength "output interface" sysOutInfo portIdsOutInfo
show (MultPortId portId) =
"Multiply defined port identifier " ++ show portId
show (MultProcId procId) =
"Multiply defined process identifier " ++ show procId
show (SubSysIdClash subSysId mLoc1 mLoc2) =
"System contains components of different subsystems " ++
"(defined at locations " ++ finalLoc1 ++ " and " ++ finalLoc2 ++ ") " ++
"which share the same system identifier (`"++subSysId++")"
where finalLoc1 = fromMaybe "<unkown>" mLoc1
finalLoc2 = fromMaybe "<unkown>" mLoc2
show (NonSysDef name t) =
"A variable with SysDef type was expected\n" ++
"However " ++ show name ++ " has type " ++ pprint t
show (IncorrProcFunDecs decs) =
"Only a function declaration (possibly precedeeded by a signature)" ++
"is accepted\n"++
"The specific, incorrect declarations follow:\n" ++
pprint decs
show InconsOutTag = "Inconsistent output tag"
show (InconsSysDefPort id) = "Inconsistent port in SysDef: " ++ show id
show (DynMisMatch dyn rep) =
"Type matching error in dynamic value with typerep " ++
show (dynTypeRep dyn) ++
"\n(Expected type: " ++ show rep ++ " )."
show (SigMisMatch t) =
"Signal mismatch: expected a Signal type but got " ++ pprint t
show (InLengthMisMatch l1 l2) =
"Cannot simulate: simulation arguments length-mismatch: " ++
show l1 ++ " /= " ++ show l2
show EmptyVHDLId = "Empty VHDL identifier"
show (IncVHDLBasId id) = "Incorrect VHDL basic identifier " ++
"`" ++ id ++ "'"
show (IncVHDLExtId id) = "Incorrect VHDL extended identifier " ++
"`" ++ id ++ "'"
show (UnsupportedType tr) = "Unsupported type " ++ show tr
show (ReservedId str) = "Identifier `" ++ str ++ "' is reserved"
show UnsupportedProc = "Unsupported process"
show (UntranslatableVHDLFun err) =
"Untranslatable function: " ++ show err
show (UntranslatableVHDLExp exp err) =
"Untranslatable expression `" ++ pprint exp ++ "': " ++ show err
show QuartusFailed = "Quartus failed"
show GhdlFailed = "Ghdl failed"
show ModelsimFailed = "Modelsim failed"
show (Other str) = str
-- | help function for the show instance
showIfaceLength :: String -> (SysId, Int) -> ([String],Int) -> String
showIfaceLength ifaceMsg (sysName, sysIfaceL) (ifaceIds, ifaceL) =
"Incorrect length of " ++ ifaceMsg ++ " (" ++ show ifaceL ++ ")\n" ++
" " ++ show ifaceIds ++ "\n" ++
sysName ++ " expects an " ++ show ifaceMsg ++ " length of " ++
show sysIfaceL
-----------------
-- Context Error
-----------------
-- | A context error: a 'ForSyDeErr' with context information (indicating where
-- the error ocurred)
data ContextErr = ContextErr Context ForSyDeErr
-- | A context: it indicates where an error ocurred.
data Context =
-- | Empty context
EmptyC |
-- | In a System definition
SysDefC SysId (Maybe Loc) |
-- | In a Process
ProcC SysId (Maybe Loc) ProcId |
-- | In a Proces Function
ProcFunC SysId (Maybe Loc) ProcId Name Loc |
-- | In a Process value
ProcValC SysId (Maybe Loc) ProcId Exp
-- | type indicating a location in the user's source
-- code
type Loc = String
-- | Set a process context from a system context
setProcC :: ProcId -- ^ Identifier of the process
-> Context -- ^ system context
-> Context
setProcC pid (SysDefC sysid mSysloc) = ProcC sysid mSysloc pid
setProcC _ _ = intError funName InconsistentContexts
where funName = "ForSyDe.ForSyDeErr.setProcC"
-- | Set a process function context from a process context
setProcFunC :: Name -- ^ Function name
-> Loc -- ^ Function location
-> Context -- ^ system context
-> Context
setProcFunC name loc (ProcC sysid sysloc pid) =
ProcFunC sysid sysloc pid name loc
setProcFunC _ _ _ = intError funName InconsistentContexts
where funName = "ForSyDe.ForSyDeErr.setProcFunC"
-- | Set a process value context from a process context
setProcValC :: Exp -- ^ Expression value
-> Context -- ^ system context
-> Context
setProcValC exp (ProcC sysid sysloc pid) = ProcValC sysid sysloc pid exp
setProcValC _ _ = intError funName InconsistentContexts
where funName = "ForSyDe.ForSyDeErr.setProcValC"
instance Show Context where
show EmptyC = ""
show (SysDefC id mLoc) = "system definition `" ++ id ++
"' (created in " ++ finalLoc ++ ")"
where finalLoc = fromMaybe "<unkown>" mLoc
show (ProcC sysid sysloc pid) = "process `" ++ pid ++ "' belonging to " ++
show (SysDefC sysid sysloc)
show (ProcFunC sysid sysloc pid fName fLoc) =
"process function `" ++ pprint fName ++ "' (created in " ++ fLoc ++ ") " ++
" used by " ++ show (ProcC sysid sysloc pid)
show (ProcValC sysid sysloc pid valExp) =
"process argument `" ++ pprint valExp ++ "' used by "
++ show (ProcC sysid sysloc pid)
instance Show ContextErr where
show (ContextErr cxt err) = case cxt of
EmptyC -> show err
_ -> show err ++ "\nin " ++ show cxt
--------------
-- Error Monad
--------------
-- | We make ForSyDeErr an instance of the Error class to be able to throw it
-- as an exception.
instance Error ForSyDeErr where
noMsg = Other "An Error has ocurred"
strMsg = Other
instance Error ContextErr where
noMsg = ContextErr EmptyC noMsg
strMsg = \str -> ContextErr EmptyC (strMsg str)
-- | 'EProne' represents failure using Left ForSyDeErr or a successful
-- result of type a using Right a
--
-- 'EProne' is implicitly an instance of
-- ['MonadError'] (@Error e => MonadError e (Either e)@)
-- ['Monad'] (@Error e => Monad (Either e)@)
type EProne = Either ForSyDeErr
-- FIXME: Rethink Eprone so that it takes contexts in account
-------------------
-- Helper functions
-------------------
-- | Throws a an error caused by improper use of a user-exported function
uError :: String -- ^ User-exported function which cuased the error
-> ForSyDeErr -- ^ Error to show
-> a
uError funName err = error $ "User error in " ++ funName ++ ": " ++
show err ++ "\n"
-- | Throws an internal error
intError :: String -- ^ Function which caused the internal error
-> ForSyDeErr -- ^ Error to show
-> a
intError funName err = error $ "Internal error in " ++ funName ++ ": " ++
show err ++ "\n" ++
"Please report!"
-- | lift an Either expression to an Error Monad
liftEither :: MonadError e m => Either e a -> m a
liftEither = either throwError return
-- | An error reporting function for Quasi monads
-- Executing in the monad will stop inmideately after calling qError
-- Note, it does not work for GHC<6.8
-- see <http://hackage.haskell.org/trac/ghc/ticket/1265>
qError :: Quasi m => String -- ^ The name of the function
-- called in the splice
-> ForSyDeErr -- ^ Error to show
-> m a
qError fname err = fail $ "Error when calling " ++ fname ++ ":\n" ++
show err
-- | Stop execution, find the enclosing qRecover
-- if a recover is not found, it is considered as an internal error
-- and the string provided will used as a reference to
-- the origin of the error.
-- Note, it does not work for GHC<6.8
-- see <http://hackage.haskell.org/trac/ghc/ticket/1265>
qGiveUp :: Quasi m => String -> m a
qGiveUp name = fail $ "qGiveUp: Internal error in " ++ name ++
", please report."
-- | Output a trace message in a quasi monad (similar to 'putTraceMsg')
qPutTraceMsg :: Quasi m => String -> m ()
qPutTraceMsg msg = qRunIO (putTraceMsg msg)
-- | Print an Error
printError :: Show a => a -> IO ()
printError = putStrLn.("Error: "++).show
-- | Print a VHDL compilation error
printVHDLError :: Show a => a -> IO b
printVHDLError = error.("VHDL Compilation Error: "++).show
-- | Print a GraphML compilation error
printGraphMLError :: Show a => a -> IO ()
printGraphMLError = putStrLn.("VHDL Compilation Error: "++).show