OpDecl.hs revision f626b1acbe874a48143a6f8d6246bf9d7a055ffb
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder Authors: Christian Maeder
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder analyse op decls
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maederimport HasCASL.PrintAs(showPretty)
f9e0b18852b238ddb649d341194e05d7200d1bbeChristian Maederimport qualified Common.Lib.Map as Map
bdf2e01977470bedcb4425e2dadabc9e9f6ba149Ewaryst SchulzmissingAna :: PrettyPrint a => a -> [Pos] -> State Env ()
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian MaedermissingAna t ps = appendDiags [Diag FatalError
64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder ("no analysis yet for: " ++ showPretty t "")
64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder $ if null ps then nullPos else head ps]
64e1905404e5135e98a26d2ab4150b6764956576Christian MaederposOfOpId :: OpId -> Pos
64e1905404e5135e98a26d2ab4150b6764956576Christian MaederposOfOpId (OpId i _ _) = posOfId i
64e1905404e5135e98a26d2ab4150b6764956576Christian MaederanaOpItem :: OpItem -> State Env ()
4c7f058cdd19ce67b2b5d4b7f69703d0f8a21e38Christian MaederanaOpItem (OpDecl is sc attr _) =
4c7f058cdd19ce67b2b5d4b7f69703d0f8a21e38Christian Maeder mapM_ (anaOpId sc attr) is
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian MaederanaOpItem (OpDefn i _ _ _ _ _) = missingAna i [posOfOpId i]
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian MaederanaOpId :: TypeScheme -> [OpAttr] -> OpId -> State Env ()
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian MaederanaOpId (TypeScheme tvs q ps) attrs (OpId i args _) =
67869d63d1725c79e4c07b51acd466a31932b275Christian Maeder do let newArgs = args ++ tvs
083a5256468076d5a9bfeb22a6e97076c224252eChristian Maeder sc = TypeScheme newArgs q ps
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder appendDiags $ checkDifferentTypeArgs newArgs
64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder (mk, newSc) <- anaTypeScheme sc
64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder Nothing -> return () -- induced error
0d7d8e3dd817450cf792778d9d4e36420f5e8abfChristian Maeder Just k -> do checkKinds (posOfId i) k star
bdf2e01977470bedcb4425e2dadabc9e9f6ba149Ewaryst Schulz addOpId i newSc attrs NoOpDefn
65dce48b81f69e11a36bf1051314a845299446e1Christian MaederanaTypeScheme :: TypeScheme -> State Env (Maybe Kind, TypeScheme)
64e1905404e5135e98a26d2ab4150b6764956576Christian MaederanaTypeScheme (TypeScheme tArgs (q :=> ty) p) =
64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder do tm <- getTypeMap -- save global variables
64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder mapM_ anaTypeVarDecl tArgs
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder (ik, newTy) <- anaType ty
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder let newPty = TypeScheme tArgs (q :=> newTy) p
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder putTypeMap tm -- forget local variables
67869d63d1725c79e4c07b51acd466a31932b275Christian Maeder return (ik, newPty)
0d7d8e3dd817450cf792778d9d4e36420f5e8abfChristian MaedercheckDifferentTypeArgs :: [TypeArg] -> [Diagnosis]
431eff6083370269f3a37767bcde001f389ac927mcodescucheckDifferentTypeArgs l =
431eff6083370269f3a37767bcde001f389ac927mcodescu let v = map (\ (TypeArg i _ _ _) -> i) l
62eaa2fb831613d8a6e59687f83a45be1041ab17Christian Maeder vd = filter ( not . null . tail) $ group $ sort v
64e1905404e5135e98a26d2ab4150b6764956576Christian Maeder in map ( \ vs -> mkDiag Error ("duplicate ids at '" ++
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder showSepList (showString " ") shortPosShow
42e78fd3454812d4f98b06154fdabc5ec3488718mcodescu (map posOfId (tail vs)) "'"
42e78fd3454812d4f98b06154fdabc5ec3488718mcodescu ++ " for") (head vs)) vd
42e78fd3454812d4f98b06154fdabc5ec3488718mcodescushortPosShow :: Pos -> ShowS
42e78fd3454812d4f98b06154fdabc5ec3488718mcodescushortPosShow p = showParen True (shows (sourceLine p) . showString "," .
42e78fd3454812d4f98b06154fdabc5ec3488718mcodescu shows (sourceColumn p))
431eff6083370269f3a37767bcde001f389ac927mcodescuaddOpId :: UninstOpId -> TypeScheme -> [OpAttr] -> OpDefn -> State Env ()
42e78fd3454812d4f98b06154fdabc5ec3488718mcodescuaddOpId i sc attrs defn =
42e78fd3454812d4f98b06154fdabc5ec3488718mcodescu do as <- getAssumps
42e78fd3454812d4f98b06154fdabc5ec3488718mcodescu let l = Map.findWithDefault [] i as
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder if sc `elem` map opType l then
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder addDiag $ mkDiag Warning
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder "repeated value" i
67869d63d1725c79e4c07b51acd466a31932b275Christian Maeder else do bs <- mapM (unifiable sc) $ map opType l
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder if or bs then addDiag $ mkDiag Error
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder "illegal overloading of" i
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder else putAssumps $ Map.insert i
1bc5dccbf0083a620ae1181c717fea75e4af5e5cChristian Maeder (OpInfo sc attrs defn : l ) as