Commit 7022758d authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

WarnMsg replaced by Message, use of fromModuleName to handle hierarchical module names

parent d0526478
......@@ -28,7 +28,7 @@ import Env.ScopeEnv (ScopeEnv)
type CheckState = State CState
data CState = CState
{ messages :: [WarnMsg]
{ messages :: [Message]
, scope :: ScopeEnv QualIdent IdInfo
, values :: ValueEnv
, moduleId :: ModuleIdent
......@@ -38,7 +38,7 @@ emptyState :: CState
emptyState = CState [] ScopeEnv.new emptyTopEnv (mkMIdent [])
-- |Run a 'CheckState' action and return the list of messages
run :: CheckState a -> [WarnMsg]
run :: CheckState a -> [Message]
run f = reverse (messages (execState f emptyState))
-- Find potentially incorrect code in a Curry program and generate
......@@ -48,7 +48,7 @@ run f = reverse (messages (execState f emptyState))
-- - idle case alternatives
-- - overlapping case alternatives
-- - function rules which are not together
warnCheck :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl] -> [WarnMsg]
warnCheck :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl] -> [Message]
warnCheck mid vals imports decls = run $ do
addImportedValues vals
addModuleId mid
......@@ -596,12 +596,12 @@ modifyScope f state = state{ scope = f (scope state) }
genWarning :: Position -> String -> CheckState ()
genWarning pos msg
= modify (\state -> state{ messages = warnMsg:(messages state) })
where warnMsg = WarnMsg (Just pos) msg
where warnMsg = Message (Just pos) msg
genWarning' :: (Position, String) -> CheckState ()
genWarning' (pos, msg)
= modify (\state -> state{ messages = warnMsg:(messages state) })
where warnMsg = WarnMsg (Just pos) msg
where warnMsg = Message (Just pos) msg
--
insertVar :: Ident -> CheckState ()
......
......@@ -66,7 +66,7 @@ genCurrySyntax fn mod1
--
genFullCurrySyntax ::
(Options -> ModuleEnv -> CS.Module -> IO (a, b, c, CS.Module, d, [WarnMsg]))
(Options -> ModuleEnv -> CS.Module -> IO (a, b, c, CS.Module, d, [Message]))
-> [FilePath] -> MsgMonad CS.Module -> IO (MsgMonad CS.Module)
genFullCurrySyntax check paths m = runMsgIO m $ \mod1 -> do
errs <- makeInterfaces paths mod1
......
......@@ -47,7 +47,7 @@ trace' _ x = x
-- transforms intermediate language code (IL) to FlatCurry code
genFlatCurry :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv
-> ArityEnv -> IL.Module -> (Prog, [WarnMsg])
-> ArityEnv -> IL.Module -> (Prog, [Message])
genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv modul
= (prog', messages)
where (prog, messages)
......@@ -57,7 +57,7 @@ genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv modul
-- transforms intermediate language code (IL) to FlatCurry interfaces
genFlatInterface :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv
-> ArityEnv -> IL.Module -> (Prog, [WarnMsg])
-> ArityEnv -> IL.Module -> (Prog, [Message])
genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv modul =
(patchPreludeFCY intf, messages)
where (intf, messages)
......@@ -120,7 +120,7 @@ data FlatEnv = FlatEnv
, varIndexE :: Int
, varIdsE :: ScopeEnv Ident VarIndex
, tvarIndexE :: Int
, messagesE :: [WarnMsg]
, messagesE :: [Message]
, genInterfaceE :: Bool
, localTypes :: Map.Map QualIdent IL.Type
, constrTypes :: Map.Map QualIdent IL.Type
......@@ -132,7 +132,7 @@ data IdentExport = NotConstr -- function, type-constructor
-- Runs a 'FlatState' action and returns the result
run :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv
-> Bool -> FlatState a -> (a, [WarnMsg])
-> Bool -> FlatState a -> (a, [Message])
run opts cEnv mEnv tyEnv tcEnv aEnv genIntf f
= (result, messagesE env)
where
......@@ -1084,7 +1084,7 @@ clearVarIndices = modify (\env -> env { varIndexE = 0,
genWarning :: String -> FlatState ()
genWarning msg
= modify (\env -> env{ messagesE = warnMsg:(messagesE env) })
where warnMsg = WarnMsg Nothing msg
where warnMsg = Message Nothing msg
--
genInterface :: FlatState Bool
......
......@@ -43,7 +43,7 @@ data Code = Keyword String
| CharCode String
| Symbol String
| Identifier IdentifierKind QualIdent
| CodeWarning [WarnMsg] Code
| CodeWarning [Message] Code
| NotParsed String
deriving Show
......@@ -114,10 +114,10 @@ getQualIdent _ = Nothing
-- DEBUGGING----------- wird bald nicht mehr gebraucht
setMessagePosition :: WarnMsg -> WarnMsg
setMessagePosition m@(WarnMsg (Just p) _) = trace'' ("pos:" ++ show p ++ ":" ++ show m) m
setMessagePosition (WarnMsg _ m) =
let mes@(WarnMsg pos _) = (WarnMsg (getPositionFromString m) m) in
setMessagePosition :: Message -> Message
setMessagePosition m@(Message (Just p) _) = trace'' ("pos:" ++ show p ++ ":" ++ show m) m
setMessagePosition (Message _ m) =
let mes@(Message pos _) = (Message (getPositionFromString m) m) in
trace'' ("pos:" ++ show pos ++ ":" ++ show mes) mes
getPositionFromString :: String -> Maybe Position
......@@ -144,28 +144,28 @@ flatCode code = code
-- ----------Message---------------------------------------
getMessages :: MsgMonad a -> [WarnMsg]
getMessages :: MsgMonad a -> [Message]
getMessages = snd . runMsg --(Result mess _) = mess
-- getMessages (Failure mess) = mess
lessMessage :: WarnMsg -> WarnMsg -> Bool
lessMessage (WarnMsg mPos1 _) (WarnMsg mPos2 _) = mPos1 < mPos2
lessMessage :: Message -> Message -> Bool
lessMessage (Message mPos1 _) (Message mPos2 _) = mPos1 < mPos2
nubMessages :: [WarnMsg] -> [WarnMsg]
nubMessages :: [Message] -> [Message]
nubMessages = nubBy eqMessage
eqMessage :: WarnMsg -> WarnMsg -> Bool
eqMessage (WarnMsg p1 s1) (WarnMsg p2 s2) = (p1 == p2) && (s1 == s2)
eqMessage :: Message -> Message -> Bool
eqMessage (Message p1 s1) (Message p2 s2) = (p1 == p2) && (s1 == s2)
prepareMessages :: [WarnMsg] -> [WarnMsg]
prepareMessages :: [Message] -> [Message]
prepareMessages = qsort lessMessage . map setMessagePosition . nubMessages
buildMessagesIntoPlainText :: [WarnMsg] -> String -> Program
buildMessagesIntoPlainText :: [Message] -> String -> Program
buildMessagesIntoPlainText messages text =
buildMessagesIntoPlainText' messages (lines text) [] 1
where
buildMessagesIntoPlainText' :: [WarnMsg] -> [String] -> [String] -> Int -> Program
buildMessagesIntoPlainText' :: [Message] -> [String] -> [String] -> Int -> Program
buildMessagesIntoPlainText' _ [] [] _ =
[]
buildMessagesIntoPlainText' _ [] postStrs ln =
......@@ -182,7 +182,7 @@ buildMessagesIntoPlainText messages text =
(ln,1,NewLine) :
buildMessagesIntoPlainText' post preStrs [] (ln + 1)
where
isLeq (WarnMsg (Just p) _) = line p <= ln
isLeq (Message (Just p) _) = line p <= ln
isLeq _ = True
--- @param parse-Modules [typingParse,fullParse,parse]
......@@ -272,15 +272,15 @@ addModuleIdent _ c = c
-- ----------------------------------------
mergeMessages' :: [WarnMsg] -> [(Position,Token)] -> [([WarnMsg],Position,Token)]
mergeMessages' :: [Message] -> [(Position,Token)] -> [([Message],Position,Token)]
mergeMessages' _ [] = []
mergeMessages' [] ((p,t):ps) = ([],p,t) : mergeMessages' [] ps
mergeMessages' mss@(m@(WarnMsg mPos x):ms) ((p,t):ps)
mergeMessages' mss@(m@(Message mPos x):ms) ((p,t):ps)
| mPos <= Just p = trace' (show mPos ++ " <= " ++ show (Just p) ++ " Message: " ++ x) ([m],p,t) : mergeMessages' ms ps
| otherwise = ([],p,t) : mergeMessages' mss ps
tokenNcodes2codes :: [(ModuleIdent,ModuleIdent)] -> Int -> Int -> [([WarnMsg],Position,Token)] -> [Code] -> [(Int,Int,Code)]
tokenNcodes2codes :: [(ModuleIdent,ModuleIdent)] -> Int -> Int -> [([Message],Position,Token)] -> [Code] -> [(Int,Int,Code)]
tokenNcodes2codes _ _ _ [] _ = []
tokenNcodes2codes nameList currLine currCol toks@((messages,Position{line=row,column=col},token):ts) codes
| currLine < row =
......
......@@ -217,7 +217,7 @@ generated FlatCurry terms (type \texttt{Prog}).
> mintf <- readFlatInterface fn
> let intf = fromMaybe (errorAt (first fn) (interfaceNotFound m)) mintf
> (Prog modul _ _ _ _) = intf
> m' = mkMIdent [modul]
> m' = fromModuleName modul
> unless (m' == m) (errorAt (first fn) (wrongInterface m m'))
> mEnv' <- loadFlatInterfaces paths ctxt mEnv intf
> return $ bindFlatInterface intf mEnv'
......@@ -225,9 +225,9 @@ generated FlatCurry terms (type \texttt{Prog}).
> loadFlatInterfaces :: [FilePath] -> [ModuleIdent] -> ModuleEnv -> Prog
> -> IO ModuleEnv
> loadFlatInterfaces paths ctxt mEnv (Prog m is _ _ _) =
> foldM (loadInterface paths ((mkMIdent [m]):ctxt))
> foldM (loadInterface paths (fromModuleName m:ctxt))
> mEnv
> (map (\i -> (p, mkMIdent [i])) is)
> (map (\i -> (p, fromModuleName i)) is)
> where p = first m
Interface files are updated by the Curry builder when necessary.
......@@ -235,7 +235,7 @@ Interface files are updated by the Curry builder when necessary.
> -- |
> simpleCheckModule :: Options -> ModuleEnv -> Module
> -> IO (ValueEnv, TCEnv, ArityEnv, Module, Interface, [WarnMsg])
> -> IO (ValueEnv, TCEnv, ArityEnv, Module, Interface, [Message])
> simpleCheckModule opts mEnv (Module m es ds) = do
> showWarnings opts warnMsgs
> return (tyEnv'', tcEnv, aEnv'', modul, intf, warnMsgs)
......@@ -259,7 +259,7 @@ Interface files are updated by the Curry builder when necessary.
> intf = exportInterface modul pEnv' tcEnv'' tyEnv''
> checkModule :: Options -> ModuleEnv -> Module
> -> IO (ValueEnv, TCEnv, ArityEnv, Module, Interface, [WarnMsg])
> -> IO (ValueEnv, TCEnv, ArityEnv, Module, Interface, [Message])
> checkModule opts mEnv (Module m es ds) = do
> showWarnings opts warnMsgs
> when (m == mkMIdent ["field114..."]) (error (show es)) -- TODO hack?
......@@ -356,7 +356,7 @@ imported modules into scope for the current module.
> case Map.lookup m mEnv of
> Just ds1 -> importInterface (fromMaybe m asM) q is
> (Interface m ds1) pEnv' tcEnv' tyEnv' aEnv'
> Nothing -> internalError "importModule"
> Nothing -> internalError $ "importModule: Map.lookup " ++ show m ++ " " ++ show mEnv
> importModule t _ = t
> initEnvs :: (PEnv, TCEnv, ValueEnv, ArityEnv)
......@@ -476,7 +476,7 @@ type check.
> = writeFlatFile opts (genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv il)
> (fromMaybe (flatName sfn) tfn)
> writeFlatFile :: Options -> (Prog, [WarnMsg]) -> String -> IO Prog
> writeFlatFile :: Options -> (Prog, [Message]) -> String -> IO Prog
> writeFlatFile opts (res, msgs) fname = do
> showWarnings opts msgs
> when extended $ writeExtendedFlat sub fname res
......@@ -572,7 +572,7 @@ be dependent on it any longer.
> outputFile = fromMaybe (sourceRepName fn) (optOutput opts)
> modString = showModule modul
> showWarnings :: Options -> [WarnMsg] -> IO ()
> showWarnings :: Options -> [Message] -> IO ()
> showWarnings opts msgs = when (optWarn opts)
> $ putErrsLn $ map showWarning msgs
......@@ -611,19 +611,20 @@ Error functions.
> wrongInterface :: ModuleIdent -> ModuleIdent -> String
> wrongInterface m m' =
> "Expected interface for " ++ show m ++ " but found " ++ show m'
> ++ show (moduleQualifiers m, moduleQualifiers m')
\end{verbatim}
> bindFlatInterface :: Prog -> ModuleEnv -> ModuleEnv
> bindFlatInterface (Prog m imps ts fs os)
> = Map.insert (mkMIdent [m])
> = Map.insert (fromModuleName m)
> ((map genIImportDecl imps)
> ++ (map genITypeDecl ts')
> ++ (map genIFuncDecl fs)
> ++ (map genIOpDecl os))
> where
> genIImportDecl :: String -> IDecl
> genIImportDecl imp = IImportDecl pos (mkMIdent [imp])
> genIImportDecl = IImportDecl pos . fromModuleName
>
> genITypeDecl :: TypeDecl -> IDecl
> genITypeDecl (Type qn _ is cs)
......@@ -674,7 +675,7 @@ Error functions.
>
> genQualIdent :: EF.QName -> QualIdent
> genQualIdent EF.QName { modName = modul, localName = lname } =
> qualifyWith (mkMIdent [modul]) (mkIdent lname)
> qualifyWith (fromModuleName modul) (mkIdent lname)
>
> genVarIndexIdent :: String -> Int -> Ident
> genVarIndexIdent v i = mkIdent (v ++ show i)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment