VarDecl.hs revision 1738d16957389457347bee85075d3d33d002158f
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederModule : $Header$
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederCopyright : (c) Christian Maeder and Uni Bremen 2002-2003
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederMaintainer : maeder@tzi.de
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederStability : provisional
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederPortability : non-portable (MonadState)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maederanalyse generic var (or type var) decls
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maederimport qualified Common.Lib.Map as Map
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maederimport qualified Common.Lib.Set as Set
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- | add diagnostic messages
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederaddDiags :: [Diagnosis] -> State Env ()
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder put $ e {envDiags = ds ++ envDiags e}
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- | add sentences
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederappendSentences :: [Named Sentence] -> State Env ()
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederappendSentences fs =
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder put $ e {sentences = sentences e ++ fs}
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederanaStarType :: Type -> State Env (Maybe Type)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederanaStarType t = do mp <- fromResult (anaType (Just star, t) . typeMap)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder return $ fmap snd mp
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederanaInstTypes :: [Type] -> State Env [Type]
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederanaInstTypes ts = if null ts then return []
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder else do mp <- fromResult (anaType (Nothing, head ts) . typeMap)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder rs <- anaInstTypes $ tail ts
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder return $ case mp of
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Nothing -> rs
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Just (_, ty) -> ty:rs
fe883661c9d1a5a8b42ac4e8673ec133d9dad354Christian MaederanaTypeScheme :: TypeScheme -> State Env (Maybe TypeScheme)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederanaTypeScheme (TypeScheme tArgs (q :=> ty) p) =
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder do tm <- gets typeMap -- save global variables
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder mArgs <- mapM anaTypeVarDecl tArgs
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder let newArgs = catMaybes mArgs
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder checkUniqueTypevars newArgs
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder mt <- anaStarType ty
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder putTypeMap tm -- forget local variables
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Nothing -> return Nothing
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Just newTy -> generalize $ TypeScheme newArgs (q :=> newTy) p
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maedergeneralize :: TypeScheme -> State Env (Maybe TypeScheme)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maedergeneralize (TypeScheme newArgs (q :=> newTy) p) = do
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder let fvs = varsOf newTy
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder ts = zipWith ( \ (TypeArg i k _ _) n ->
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder TypeName i k n) fvs [-1, -2..]
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder m = Map.fromList $ zip fvs ts
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder qTy = q :=> repl m newTy
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder ds = unboundTypevars newArgs newTy
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder if null ds then
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder return $ Just $ TypeScheme newArgs qTy p
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder else if null newArgs then
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder return $ Just $ TypeScheme fvs qTy p
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder else do addDiags ds
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder return Nothing
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederanaKind :: Kind -> State Env Kind
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederanaKind k = toState star $ anaKindM k
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaedertoState :: a -> (Env -> Result a) -> State Env a
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaedertoState bot r = do
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder ma <- fromResult r
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Nothing -> return bot
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Just a -> return a
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederfromResult :: (Env -> Result a) -> State Env (Maybe a)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederfromResult f = do
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder addDiags $ diags r
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder return $ maybeResult r
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- ---------------------------------------------------------------------------
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- storing type ids with their kind and definition
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- ---------------------------------------------------------------------------
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- | store a complete type map
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederputTypeMap :: TypeMap -> State Env ()
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederputTypeMap tk = do { e <- get; put e { typeMap = tk } }
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- | store type id and check kind arity (warn on redeclared types)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederaddTypeId :: Bool -> TypeDefn -> Instance -> Kind -> Id -> State Env (Maybe Id)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederaddTypeId warn defn _ kind i =
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder do let nk = rawKind kind
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder if placeCount i <= kindArity TopLevel nk then
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder do addTypeKind warn defn i kind
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder return $ Just i
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder else do addDiags [mkDiag Error "wrong arity of" i]
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder return Nothing
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- | store type as is (warn on redeclared types)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederaddTypeKind :: Bool -> TypeDefn -> Id -> Kind -> State Env ()
e05956d1da3c97e4d808926f97c6841c4a561991Christian MaederaddTypeKind warn d i k =
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder do tk <- gets typeMap
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder c <- gets counter
e05956d1da3c97e4d808926f97c6841c4a561991Christian Maeder let rk = rawKind k
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Nothing -> case d of
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder TypeVarDefn _ -> do
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder (_, v) <- toEnvState $ freshVar (posOfId i)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder (TypeInfo rk [k] [] $ TypeVarDefn v) tk
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder _ -> putTypeMap $ Map.insert i (TypeInfo rk [k] [] d) tk
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Just (TypeInfo ok ks sups defn) ->
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder then do let isKnownInst = k `elem` ks
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder insts = if isKnownInst then ks else
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Set.toList $ mkIntersection (k:ks)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Result ds mDef = mergeTypeDefn tk c defn d
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder if warn && isKnownInst && case (defn, d) of
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder (PreDatatype, DatatypeDefn _) -> False
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder addDiags [mkDiag Hint
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder "redeclared type" i]
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder else return ()
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Just newDefn -> putTypeMap $ Map.insert i
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder (TypeInfo ok insts sups newDefn) tk
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Nothing -> addDiags $ map (improveDiag i) ds
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder else addDiags $ diffKindDiag i ok rk
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- | analyse a type argument and look up a missing kind
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederanaTypeVarDecl :: TypeArg -> State Env (Maybe TypeArg)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederanaTypeVarDecl(TypeArg t k s ps) =
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder MissingKind -> do
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder tk <- gets typeMap
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder let rm = getIdKind tk t
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder case maybeResult rm of
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Nothing -> anaTypeVarDecl(TypeArg t star s ps)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Just oldK -> addTypeVarDecl False (TypeArg t oldK s ps)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder _ -> do nk <- anaKind k
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder addTypeVarDecl True $ TypeArg t nk s ps
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- | add an analysed type argument (warn on redeclared types)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederaddTypeVarDecl :: Bool -> TypeArg -> State Env (Maybe TypeArg)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederaddTypeVarDecl warn ta@(TypeArg t k _ _) =
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder do mi <- addTypeId warn (TypeVarDefn 0) Plain k t
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder return $ fmap (const ta) mi
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder-- | compute arity from a 'Kind'
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederkindArity :: ApplMode -> Kind -> Int
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederkindArity m k =
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder FunKind k1 k2 _ -> case m of
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder TopLevel -> kindArity OnlyArg k1 +
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder kindArity TopLevel k2
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Intersection [] _ -> case m of
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder TopLevel -> 0
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder ClassKind _ ck -> kindArity m ck
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Downset _ _ dk _ -> kindArity m dk
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder Intersection (k1:_) _ -> kindArity m k1
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder ExtKind ek _ _ -> kindArity m ek
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder _ -> error "kindArity"
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- ---------------------------------------------------------------------------
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- for storing selectors and constructors
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- ---------------------------------------------------------------------------
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- | store assumptions
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederputAssumps :: Assumps -> State Env ()
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederputAssumps as = do { e <- get; put e { assumps = as } }
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- | get matching information of uninstantiated identifier
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederfindOpId :: Env -> UninstOpId -> TypeScheme -> Maybe OpInfo
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederfindOpId e i sc = listToMaybe $ fst $ partitionOpId e i sc
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- | partition information of an uninstantiated identifier
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederpartitionOpId :: Env -> UninstOpId -> TypeScheme -> ([OpInfo], [OpInfo])
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaederpartitionOpId e i sc =
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder let l = Map.findWithDefault (OpInfos []) i $ assumps e
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder in partition (isUnifiable (typeMap e) (counter e) sc . opType) $ opInfos l
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder-- | storing an operation
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederaddOpId :: UninstOpId -> TypeScheme -> [OpAttr] -> OpDefn
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder -> State Env (Maybe UninstOpId)
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederaddOpId i sc attrs defn =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder let tm = typeMap e
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder as = assumps e
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder c = counter e
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder (TypeScheme _ (_ :=> ty) _) = sc
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder ds = if placeCount i > 1 then case unalias ty of
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder FunType arg _ _ _ -> case unalias arg of
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder ProductType ts _ -> if placeCount i /= length ts then
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder [mkDiag Error "wrong number of places in" i]
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder _ -> [mkDiag Error "expected tuple argument for" i]
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder _ -> [mkDiag Error "expected function type for" i]
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder (l,r) = partitionOpId e i sc
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder oInfo = OpInfo sc attrs defn
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder if null ds then
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder do let Result es mo = foldM (mergeOpInfo tm c) oInfo l
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder addDiags $ map (improveDiag i) es
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder if i `elem` map fst bList then addDiags $ [mkDiag Error
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder "illegal overloading of predefined identifier" i]
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder else return ()
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder Nothing -> return Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder Just oi -> do putAssumps $ Map.insert i
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder (OpInfos (oi : r)) as
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder return $ Just i
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder else do addDiags ds
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder return Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder----------------------------------------------------------------------------
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder-----------------------------------------------------------------------------
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederaddGenVarDecl :: GenVarDecl -> State Env (Maybe GenVarDecl)
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederaddGenVarDecl(GenVarDecl v) = do mv <- addVarDecl v
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder return $ fmap GenVarDecl mv
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederaddGenVarDecl(GenTypeVarDecl t) = do mt <- addTypeVarDecl True t
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder return $ fmap GenTypeVarDecl mt
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederanaGenVarDecl :: GenVarDecl -> State Env (Maybe GenVarDecl)
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederanaGenVarDecl(GenVarDecl v) = optAnaVarDecl v
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederanaGenVarDecl(GenTypeVarDecl t) =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder anaTypeVarDecl t >>= (return . fmap GenTypeVarDecl)
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederconvertTypeToKind :: Type -> State Env (Maybe Kind)
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederconvertTypeToKind (FunType t1 FunArr t2 ps) =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder do mk1 <- convertTypeToKind t1
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder mk2 <- convertTypeToKind t2
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder case (mk1, mk2) of
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder (Just k1, Just k2) -> case k2 of
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder ExtKind _ _ _ -> return Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder _ -> return $ Just $ FunKind k1 k2 ps
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder _ -> return Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederconvertTypeToKind (BracketType Parens [] _) =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder return Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederconvertTypeToKind (BracketType Parens [t] _) =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder convertTypeToKind t
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederconvertTypeToKind (BracketType Parens ts ps) =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder do cs <- mapM convertTypeToKind ts
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder if all isJust cs then
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder do let k:ks = catMaybes cs
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder rk = rawKind k
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder if all ((==rk) . rawKind) ks then
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder return $ Just $ Intersection (k:ks) ps
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder else return Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder else return Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederconvertTypeToKind (MixfixType [t1, TypeToken t]) =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder let s = tokStr t
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder mv = case s of
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder "+" -> Just CoVar
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder "-" -> Just ContraVar
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder in case mv of
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder Nothing -> do return Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder mk1 <- convertTypeToKind t1
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder Just k1 -> return $ Just $ ExtKind k1 v [tokPos t]
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder _ -> return Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederconvertTypeToKind(TypeToken t) =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder if tokStr t == "Type" then return $ Just $ Intersection [] [tokPos t]
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder let ci = simpleIdToId t
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder cm <- gets classMap
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder let rm = anaClassId ci cm
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder case maybeResult rm of
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder Nothing -> return Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder Just k -> return $ Just $ ClassKind ci k
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederconvertTypeToKind _ =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder do return Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederoptAnaVarDecl :: VarDecl -> State Env (Maybe GenVarDecl)
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederoptAnaVarDecl vd@(VarDecl v t s q) =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder let varDecl = do mvd <- anaVarDecl vd
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder Nothing -> return Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder Just nvd -> do mmvd <- addVarDecl $ makeMonomorph nvd
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder return $ fmap GenVarDecl mmvd
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder in if isSimpleId v then
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder do mk <- convertTypeToKind t
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder Just k -> do addDiags [mkDiag Hint "is type variable" v]
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder tv <- anaTypeVarDecl $ TypeArg v k s q
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder return $ fmap GenTypeVarDecl tv
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaedermakeMonomorph :: VarDecl -> VarDecl
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaedermakeMonomorph (VarDecl v t sk ps) =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder let s = Map.fromList $ map ( \ a@(TypeArg i k _ _) ->
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder (a, TypeName i k 0)) $
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder in VarDecl v (repl s t) sk ps
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederanaVarDecl :: VarDecl -> State Env (Maybe VarDecl)
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederanaVarDecl(VarDecl v oldT sk ps) =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder do mt <- anaStarType oldT
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder return $ case mt of
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder Nothing -> Nothing
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder Just t -> Just $ VarDecl v t sk ps
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder-- | add a local variable with an analysed type
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederaddVarDecl :: VarDecl -> State Env (Maybe VarDecl)
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaederaddVarDecl vd@(VarDecl v t _ _) =
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder do newV <- addOpId v (simpleTypeScheme t) [] VarDefn
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder return $ fmap (const vd) newV
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian Maeder-- | get the variable
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaedergetVar :: VarDecl -> Id
aae7a026a323021c5364aef85a0e03d586e5a5c3Christian MaedergetVar(VarDecl v _ _ _) = v
Map.filter (not . null . opInfos) .
Map.map (OpInfos . filter p . opInfos)