{-# 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 "" mLoc1 finalLoc2 = fromMaybe "" 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 "" 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 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 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