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