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

Merge branch 'master' of /home/bjp/public_html/repos/curry-frontend

parents 50d60cf5 9b576eac
dist/ dist/
*/.curry .curry/
...@@ -41,6 +41,7 @@ Executable cymake ...@@ -41,6 +41,7 @@ Executable cymake
Other-Modules: Other-Modules:
Base.Arity Base.Arity
, Base.Eval , Base.Eval
, Base.Expr
, Base.Import , Base.Import
, Base.Module , Base.Module
, Base.OpPrec , Base.OpPrec
......
{- |Free and bound variables
The compiler needs to compute the sets of free and bound variables for
various different entities. We will devote three type classes to that
purpose. The \texttt{QualExpr} class is expected to take into account
that it is possible to use a qualified name to refer to a function
defined in the current module and therefore \emph{M.x} and $x$, where
$M$ is the current module name, should be considered the same name.
However note that this is correct only after renaming all local
definitions as \emph{M.x} always denotes an entity defined at the
top-level.
-}
module Base.Expr (Expr (..), QualExpr (..), QuantExpr (..)) where
import qualified Data.Set as Set (fromList, notMember)
import Curry.Base.Ident
import Curry.Syntax
import qualified IL
class Expr e where
fv :: e -> [Ident]
class QualExpr e where
qfv :: ModuleIdent -> e -> [Ident]
class QuantExpr e where
bv :: e -> [Ident]
instance Expr e => Expr [e] where
fv = concatMap fv
instance QualExpr e => QualExpr [e] where
qfv m = concatMap (qfv m)
instance QuantExpr e => QuantExpr [e] where
bv = concatMap bv
-- The \texttt{Decl} instance of \texttt{QualExpr} returns all free
-- variables on the right hand side, regardless of whether they are bound
-- on the left hand side. This is more convenient as declarations are
-- usually processed in a declaration group where the set of free
-- variables cannot be computed independently for each declaration. Also
-- note that the operator in a unary minus expression is not a free
-- variable. This operator always refers to a global function from the
-- prelude.
instance QualExpr Decl where
qfv m (FunctionDecl _ _ eqs) = qfv m eqs
qfv m (PatternDecl _ _ rhs) = qfv m rhs
qfv _ _ = []
instance QuantExpr Decl where
bv (TypeSig _ vs _) = vs
bv (EvalAnnot _ fs _) = fs
bv (FunctionDecl _ f _) = [f]
bv (ExternalDecl _ _ _ f _) = [f]
bv (FlatExternalDecl _ fs) = fs
bv (PatternDecl _ t _) = bv t
bv (ExtraVariables _ vs) = vs
bv _ = []
instance QualExpr Equation where
qfv m (Equation _ lhs rhs) = filterBv lhs (qfv m lhs ++ qfv m rhs)
instance QuantExpr Lhs where
bv = bv . snd . flatLhs
instance QualExpr Lhs where
qfv m lhs = qfv m (snd (flatLhs lhs))
instance QualExpr Rhs where
qfv m (SimpleRhs _ e ds) = filterBv ds (qfv m e ++ qfv m ds)
qfv m (GuardedRhs es ds) = filterBv ds (qfv m es ++ qfv m ds)
instance QualExpr CondExpr where
qfv m (CondExpr _ g e) = qfv m g ++ qfv m e
instance QualExpr Expression where
qfv _ (Literal _) = []
qfv m (Variable v) = maybe [] return (localIdent m v)
qfv _ (Constructor _) = []
qfv m (Paren e) = qfv m e
qfv m (Typed e _) = qfv m e
qfv m (Tuple _ es) = qfv m es
qfv m (List _ es) = qfv m es
qfv m (ListCompr _ e qs) = foldr (qfvStmt m) (qfv m e) qs
qfv m (EnumFrom e) = qfv m e
qfv m (EnumFromThen e1 e2) = qfv m e1 ++ qfv m e2
qfv m (EnumFromTo e1 e2) = qfv m e1 ++ qfv m e2
qfv m (EnumFromThenTo e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
qfv m (UnaryMinus _ e) = qfv m e
qfv m (Apply e1 e2) = qfv m e1 ++ qfv m e2
qfv m (InfixApply e1 op e2) = qfv m op ++ qfv m e1 ++ qfv m e2
qfv m (LeftSection e op) = qfv m op ++ qfv m e
qfv m (RightSection op e) = qfv m op ++ qfv m e
qfv m (Lambda _ ts e) = filterBv ts (qfv m e)
qfv m (Let ds e) = filterBv ds (qfv m ds ++ qfv m e)
qfv m (Do sts e) = foldr (qfvStmt m) (qfv m e) sts
qfv m (IfThenElse _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
qfv m (Case _ e alts) = qfv m e ++ qfv m alts
qfv m (RecordConstr fs) = qfv m fs
qfv m (RecordSelection e _) = qfv m e
qfv m (RecordUpdate fs e) = qfv m e ++ qfv m fs
qfvStmt :: ModuleIdent -> Statement -> [Ident] -> [Ident]
qfvStmt m st fvs = qfv m st ++ filterBv st fvs
instance QualExpr Statement where
qfv m (StmtExpr _ e) = qfv m e
qfv m (StmtDecl ds) = filterBv ds (qfv m ds)
qfv m (StmtBind _ _ e) = qfv m e
instance QualExpr Alt where
qfv m (Alt _ t rhs) = filterBv t (qfv m rhs)
instance QuantExpr a => QuantExpr (Field a) where
bv (Field _ _ t) = bv t
instance QualExpr a => QualExpr (Field a) where
qfv m (Field _ _ t) = qfv m t
instance QuantExpr Statement where
bv (StmtExpr _ _) = []
bv (StmtBind _ t _) = bv t
bv (StmtDecl ds) = bv ds
instance QualExpr InfixOp where
qfv m (InfixOp op) = qfv m (Variable op)
qfv _ (InfixConstr _) = []
instance QuantExpr ConstrTerm where
bv (LiteralPattern _) = []
bv (NegativePattern _ _) = []
bv (VariablePattern v) = [v]
bv (ConstructorPattern _ ts) = bv ts
bv (InfixPattern t1 _ t2) = bv t1 ++ bv t2
bv (ParenPattern t) = bv t
bv (TuplePattern _ ts) = bv ts
bv (ListPattern _ ts) = bv ts
bv (AsPattern v t) = v : bv t
bv (LazyPattern _ t) = bv t
bv (FunctionPattern f ts) = bvFuncPatt (FunctionPattern f ts)
bv (InfixFuncPattern t1 op t2) = bvFuncPatt (InfixFuncPattern t1 op t2)
bv (RecordPattern fs r) = maybe [] bv r ++ bv fs
instance QualExpr ConstrTerm where
qfv _ (LiteralPattern _) = []
qfv _ (NegativePattern _ _) = []
qfv _ (VariablePattern _) = []
qfv m (ConstructorPattern _ ts) = qfv m ts
qfv m (InfixPattern t1 _ t2) = qfv m [t1, t2]
qfv m (ParenPattern t) = qfv m t
qfv m (TuplePattern _ ts) = qfv m ts
qfv m (ListPattern _ ts) = qfv m ts
qfv m (AsPattern _ ts) = qfv m ts
qfv m (LazyPattern _ t) = qfv m t
qfv m (FunctionPattern f ts)
= maybe [] return (localIdent m f) ++ qfv m ts
qfv m (InfixFuncPattern t1 op t2)
= maybe [] return (localIdent m op) ++ qfv m [t1, t2]
qfv m (RecordPattern fs r) = maybe [] (qfv m) r ++ qfv m fs
instance Expr TypeExpr where
fv (ConstructorType _ tys) = fv tys
fv (VariableType tv)
| tv == anonId = []
| otherwise = [tv]
fv (TupleType tys) = fv tys
fv (ListType ty) = fv ty
fv (ArrowType ty1 ty2) = fv ty1 ++ fv ty2
fv (RecordType fs rty) = maybe [] fv rty ++ fv (map snd fs)
filterBv :: QuantExpr e => e -> [Ident] -> [Ident]
filterBv e = filter (`Set.notMember` Set.fromList (bv e))
-- Since multiple variable occurrences are allowed in function patterns,
-- it is necessary to compute the list of bound variables in a different way:
-- Each variable occuring in the function pattern will be unique in the result
-- list.
bvFuncPatt :: ConstrTerm -> [Ident]
bvFuncPatt = bvfp []
where
bvfp bvs (LiteralPattern _) = bvs
bvfp bvs (NegativePattern _ _) = bvs
bvfp bvs (VariablePattern v)
| v `elem` bvs = bvs
| otherwise = v : bvs
bvfp bvs (ConstructorPattern _ ts) = foldl bvfp bvs ts
bvfp bvs (InfixPattern t1 _ t2) = foldl bvfp bvs [t1, t2]
bvfp bvs (ParenPattern t) = bvfp bvs t
bvfp bvs (TuplePattern _ ts) = foldl bvfp bvs ts
bvfp bvs (ListPattern _ ts) = foldl bvfp bvs ts
bvfp bvs (AsPattern v t)
| v `elem` bvs = bvfp bvs t
| otherwise = bvfp (v : bvs) t
bvfp bvs (LazyPattern _ t) = bvfp bvs t
bvfp bvs (FunctionPattern _ ts) = foldl bvfp bvs ts
bvfp bvs (InfixFuncPattern t1 _ t2) = foldl bvfp bvs [t1, t2]
bvfp bvs (RecordPattern fs r)
= foldl bvfp (maybe bvs (bvfp bvs) r) (map fieldTerm fs)
-- intermediate language
instance Expr IL.Expression where
fv (IL.Variable v) = [v]
fv (IL.Apply e1 e2) = fv e1 ++ fv e2
fv (IL.Case _ _ e alts) = fv e ++ fv alts
fv (IL.Or e1 e2) = fv e1 ++ fv e2
fv (IL.Exist v e) = filter (/= v) (fv e)
fv (IL.Let (IL.Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2)
fv (IL.Letrec bds e) = filter (`notElem` vs) (fv es ++ fv e)
where (vs,es) = unzip [(v,e') | IL.Binding v e' <- bds]
fv _ = []
instance Expr IL.Alt where
fv (IL.Alt (IL.ConstructorPattern _ vs) e) = filter (`notElem` vs) (fv e)
fv (IL.Alt (IL.VariablePattern v) e) = filter (v /=) (fv e)
fv (IL.Alt _ e) = fv e
...@@ -19,10 +19,10 @@ order of type variables in the left hand side of a type declaration. ...@@ -19,10 +19,10 @@ order of type variables in the left hand side of a type declaration.
> import Data.List (nub) > import Data.List (nub)
> import qualified Data.Map as Map (Map, fromList, lookup) > import qualified Data.Map as Map (Map, fromList, lookup)
> import Curry.Base.Expr
> import Curry.Base.Ident > import Curry.Base.Ident
> import qualified Curry.Syntax as CS > import qualified Curry.Syntax as CS
> import Base.Expr
> import Messages (internalError) > import Messages (internalError)
> import Types > import Types
......
...@@ -19,11 +19,11 @@ of the operators involved. ...@@ -19,11 +19,11 @@ of the operators involved.
> import Data.List (partition, mapAccumL) > import Data.List (partition, mapAccumL)
> import Curry.Base.Expr
> import Curry.Base.Position > import Curry.Base.Position
> import Curry.Base.Ident > import Curry.Base.Ident
> import Curry.Syntax > import Curry.Syntax
> import Base.Expr
> import Base.OpPrec (PEnv, OpPrec (..), PrecInfo (..), defaultP, bindP, qualLookupP) > import Base.OpPrec (PEnv, OpPrec (..), PrecInfo (..), defaultP, bindP, qualLookupP)
> import Messages (errorAt') > import Messages (errorAt')
> import Utils (findDouble) > import Utils (findDouble)
......
...@@ -26,12 +26,12 @@ merged into a single definition. ...@@ -26,12 +26,12 @@ merged into a single definition.
> import qualified Data.Map as Map (empty, insert, lookup) > import qualified Data.Map as Map (empty, insert, lookup)
> import Control.Monad.State as S (State, evalState, get, liftM, modify) > import Control.Monad.State as S (State, evalState, get, liftM, modify)
> import Curry.Base.Expr
> import Curry.Base.Position > import Curry.Base.Position
> import Curry.Base.Ident > import Curry.Base.Ident
> import Curry.Syntax > import Curry.Syntax
> import Base.Arity (ArityEnv, ArityInfo (..), lookupArity, qualLookupArity) > import Base.Arity (ArityEnv, ArityInfo (..), lookupArity, qualLookupArity)
> import Base.Expr
> import Base.Import (ImportEnv, lookupAlias) > import Base.Import (ImportEnv, lookupAlias)
> import Base.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC) > import Base.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC)
> import Base.Value (ValueEnv, ValueInfo (..)) > import Base.Value (ValueEnv, ValueInfo (..))
......
...@@ -30,12 +30,12 @@ type annotation is present. ...@@ -30,12 +30,12 @@ type annotation is present.
> import qualified Data.Set as Set (Set, fromList, member, notMember, unions) > import qualified Data.Set as Set (Set, fromList, member, notMember, unions)
> import Text.PrettyPrint.HughesPJ > import Text.PrettyPrint.HughesPJ
> import Curry.Base.Expr
> import Curry.Base.Position > import Curry.Base.Position
> import Curry.Base.Ident > import Curry.Base.Ident
> import Curry.Syntax > import Curry.Syntax
> import Curry.Syntax.Pretty > import Curry.Syntax.Pretty
> import Base.Expr
> import Base.Types (fromQualType, toType, toTypes) > import Base.Types (fromQualType, toType, toTypes)
> import Base.TypeConstructors (TCEnv, TypeInfo (..), bindTypeInfo, qualLookupTC) > import Base.TypeConstructors (TCEnv, TypeInfo (..), bindTypeInfo, qualLookupTC)
> import Base.Value ( ValueEnv, ValueInfo (..), bindFun, rebindFun > import Base.Value ( ValueEnv, ValueInfo (..), bindFun, rebindFun
......
...@@ -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 ()
......
...@@ -25,13 +25,13 @@ data structures, we can use only a qualified import for the ...@@ -25,13 +25,13 @@ data structures, we can use only a qualified import for the
> import qualified Data.Set as Set (delete, fromList, toList) > import qualified Data.Set as Set (delete, fromList, toList)
> import qualified Data.Map as Map (Map, empty, insert, lookup) > import qualified Data.Map as Map (Map, empty, insert, lookup)
> import Curry.Base.Expr
> import Curry.Base.Position > import Curry.Base.Position
> import Curry.Base.Ident > import Curry.Base.Ident
> import qualified IL as IL > import qualified IL as IL
> import Curry.Syntax > import Curry.Syntax
> import Base.Eval (EvalEnv) > import Base.Eval (EvalEnv)
> import Base.Expr
> import Base.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC) > import Base.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC)
> import Base.Types (toQualTypes) > import Base.Types (toQualTypes)
> import Base.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue) > import Base.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
......
...@@ -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