OpDecl.hs revision a94b530fa82bb281caac766a9c0f7b2fcfe7a584
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannModule : $Header$
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannCopyright : (c) Christian Maeder and Uni Bremen 2003
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannMaintainer : maeder@tzi.de
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannStability : experimental
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannPortability : portable
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann analyse operation declarations
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannanaAttr :: GlobalAnnos -> TypeScheme -> OpAttr -> State Env (Maybe OpAttr)
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannanaAttr ga (TypeScheme tvs ty _) (UnitOpAttr trm ps) =
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann do let mTy = case unalias ty of
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann FunType arg _ t3 _ ->
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann case unalias arg of
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann ProductType [t1, t2] _ -> Just (t1,t2,t3)
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann tm <- gets typeMap
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann mapM_ (addTypeVarDecl False) tvs
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann Nothing -> do addDiags [mkDiag Error
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann "unexpected type of operation" ty]
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann mt <- resolveTerm ga Nothing trm
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann putTypeMap tm
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann Nothing -> return Nothing
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann Just t -> return $ Just $ UnitOpAttr t ps
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann Just (t1, t2, t3) ->
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann do if t1 == t2 && t2 == t3 then
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann else addDiags [mkDiag Error
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann "unexpected type components of operation" ty]
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann mt <- resolveTerm ga (Just t3) trm
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann putTypeMap tm
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann case mt of Nothing -> return Nothing
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann Just t -> return $ Just $ UnitOpAttr t ps
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannanaAttr _ _ b = return $ Just b
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannpatternsToType :: [[VarDecl]] -> Type -> Type
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannpatternsToType [] t = t
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannpatternsToType (p: ps) t = FunType (tuplePatternToType p) PFunArr
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann (patternsToType ps t) []
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmanntuplePatternToType :: [VarDecl] -> Type
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmanntuplePatternToType vds = mkProductType (map ( \ (VarDecl _ t _ _) -> t) vds) []
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmanngetUninstOpId :: TypeScheme -> OpId -> (OpId, TypeScheme)
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmanngetUninstOpId (TypeScheme tvs q ps) (OpId i args qs) =
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann (OpId i [] qs, TypeScheme (args ++ tvs) q ps)
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannanaOpId :: GlobalAnnos -> OpBrand -> TypeScheme -> [OpAttr] -> OpId
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann -> State Env (Maybe OpId)
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannanaOpId ga br partSc attrs o =
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann do let (OpId i _ _, sc) = getUninstOpId partSc o
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann mSc <- anaTypeScheme sc
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann Nothing -> return Nothing
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann Just newSc -> do
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann mAttrs <- mapM (anaAttr ga newSc) attrs
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann mo <- addOpId i newSc (catMaybes mAttrs) $ NoOpDefn br
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann return $ fmap (const o) mo
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannanaOpItem :: GlobalAnnos -> OpBrand -> OpItem -> State Env OpItem
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannanaOpItem ga br (OpDecl is sc attr ps) = do
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann us <- mapM (anaOpId ga br sc attr) is
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann return $ OpDecl (catMaybes us) sc attr ps
74dfa6bc521350525358340117512f8afe9fdd26Daniel HausmannanaOpItem ga br (OpDefn o oldPats sc partial trm ps) =
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann do let (op@(OpId i _ _), extSc@(TypeScheme tArgs scTy qs)) =
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann getUninstOpId sc o
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann checkUniqueVars $ concat oldPats
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann tm <- gets typeMap
74dfa6bc521350525358340117512f8afe9fdd26Daniel Hausmann mArgs <- mapM anaTypeVarDecl tArgs