{-# LANGUAGE FlexibleContexts #-}
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
data ForSyDeErr =
InconsistentContexts |
EvalErr String |
NonVarName Name |
IncomSysF Name Type |
InIfaceLength (SysId,Int) ([String],Int) |
OutIfaceLength (SysId,Int) ([String],Int) |
MultPortId PortId |
MultProcId ProcId |
SubSysIdClash SysId (Maybe Loc) (Maybe Loc) |
NonSysDef Name Type |
IncorrProcFunDecs [Dec] |
InconsOutTag |
InconsSysDefPort PortId |
DynMisMatch Dynamic TypeRep |
SigMisMatch Type |
InLengthMisMatch Int Int |
EmptyVHDLId |
IncVHDLBasId String |
IncVHDLExtId String |
UntranslatableVHDLFun VHDLFunErr |
UntranslatableVHDLExp Exp VHDLExpErr |
UnsupportedType FSDTypeRep |
ReservedId String |
UnsupportedProc |
QuartusFailed |
GhdlFailed |
ModelsimFailed |
Other String
data VHDLFunErr =
PolyDec Dec |
UnsupportedDecBlock [Dec] |
InsParamNum Name Int |
UnsupportedFunPat Pat |
MultipleClauses [Clause] |
FunGuardedBody Body |
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
data VHDLExpErr =
CaseGuardedBody Body |
UnsupportedCasePat Pat |
CurryUnsupported Int Int |
UnkownIdentifier Name |
UnsupportedLiteral |
Section |
LambdaAbstraction |
Conditional |
Case |
Do |
ListComprehension |
ArithSeq |
List |
Signature |
Record |
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"
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
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
data ContextErr = ContextErr Context ForSyDeErr
data Context =
EmptyC |
SysDefC SysId (Maybe Loc) |
ProcC SysId (Maybe Loc) ProcId |
ProcFunC SysId (Maybe Loc) ProcId Name Loc |
ProcValC SysId (Maybe Loc) ProcId Exp
type Loc = String
setProcC :: ProcId
-> Context
-> Context
setProcC pid (SysDefC sysid mSysloc) = ProcC sysid mSysloc pid
setProcC _ _ = intError funName InconsistentContexts
where funName = "ForSyDe.ForSyDeErr.setProcC"
setProcFunC :: Name
-> Loc
-> Context
-> Context
setProcFunC name loc (ProcC sysid sysloc pid) =
ProcFunC sysid sysloc pid name loc
setProcFunC _ _ _ = intError funName InconsistentContexts
where funName = "ForSyDe.ForSyDeErr.setProcFunC"
setProcValC :: Exp
-> 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
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)
type EProne = Either ForSyDeErr
uError :: String
-> ForSyDeErr
-> a
uError funName err = error $ "User error in " ++ funName ++ ": " ++
show err ++ "\n"
intError :: String
-> ForSyDeErr
-> a
intError funName err = error $ "Internal error in " ++ funName ++ ": " ++
show err ++ "\n" ++
"Please report!"
liftEither :: MonadError e m => Either e a -> m a
liftEither = either throwError return
qError :: Quasi m => String
-> ForSyDeErr
-> m a
qError fname err = fail $ "Error when calling " ++ fname ++ ":\n" ++
show err
qGiveUp :: Quasi m => String -> m a
qGiveUp name = fail $ "qGiveUp: Internal error in " ++ name ++
", please report."
qPutTraceMsg :: Quasi m => String -> m ()
qPutTraceMsg msg = qRunIO (putTraceMsg msg)
printError :: Show a => a -> IO ()
printError = putStrLn.("Error: "++).show
printVHDLError :: Show a => a -> IO b
printVHDLError = error.("VHDL Compilation Error: "++).show
printGraphMLError :: Show a => a -> IO ()
printGraphMLError = putStrLn.("VHDL Compilation Error: "++).show