MixAna.hs revision fcfed328fae6266214ee61ee7a16fd263fd3cb70
ca010363454de207082dfaa4b753531ce2a34551Christian MaederModule : $Header$
83cc27e4ca7cf1a4bb5f4a8df17d3e6d44e6f1eaChristian MaederCopyright : (c) Christian Maeder and Uni Bremen 2003
4b0a4c7dea0f67a233dcc42ce9bb18d36de109aeChristian MaederLicence : All rights reserved.
ca010363454de207082dfaa4b753531ce2a34551Christian MaederMaintainer : hets@tzi.de
ca010363454de207082dfaa4b753531ce2a34551Christian MaederStability : experimental
83cc27e4ca7cf1a4bb5f4a8df17d3e6d44e6f1eaChristian MaederPortability : portable
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederMixfix analysis of terms and patterns, adapted from the CASL analysis
ca010363454de207082dfaa4b753531ce2a34551Christian Maederimport qualified Common.Lib.Map as Map
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maederimport qualified Common.Lib.Set as Set
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- Earley Algorithm
aae44eae4cd27141bea70af8d54844c3849a0711Christian MaederlookUp :: (Ord a) => Map.Map a [b] -> a -> [b]
aae44eae4cd27141bea70af8d54844c3849a0711Christian MaederlookUp ce k = Map.findWithDefault [] k ce
1db126da06f707b90b5be9d66a73c36ee2cd22eeChristian Maedertype PMap a = Map.Map Index [PState a]
1db126da06f707b90b5be9d66a73c36ee2cd22eeChristian Maederdata ParseMap a = ParseMap { varCount :: Int
1db126da06f707b90b5be9d66a73c36ee2cd22eeChristian Maeder , lastIndex :: Index
1db126da06f707b90b5be9d66a73c36ee2cd22eeChristian Maeder , failDiags :: [Diagnosis]
1db126da06f707b90b5be9d66a73c36ee2cd22eeChristian Maeder , parseMap :: PMap a
08f8731b34de5dc1ced274594978ad8879c831bdChristian MaedertermToToken :: Term -> Token
08f8731b34de5dc1ced274594978ad8879c831bdChristian MaedertermToToken trm =
d601fb0d7be0f4e8de9f01b5293df7d80673d76aChristian Maeder TermToken x -> x
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder TypedTerm _ _ _ _ -> inTok
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder-- match (and shift) a token (or partially finished term)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maederscan :: TypeMap -> Knowns -> (Maybe Type, a) -> (a -> Token)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder -> ParseMap a -> ParseMap a
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maederscan tm knowns (ty, trm) f pm =
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder let m = parseMap pm
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder i = lastIndex pm
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder incI = incrIndex i
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder (ps, c2) = runState (mapM (scanState tm knowns (ty, trm) $ f trm)
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder $ lookUp m i) $ varCount pm
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder pm { lastIndex = incI
801c2781e70c80f5f2069894a1f5cdfed7da8c9cChristian Maeder , varCount = c2
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder , parseMap = Map.insert incI (concat ps) m }
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- when a grammar rule (mixfix Id) has been fully matched
08f8731b34de5dc1ced274594978ad8879c831bdChristian MaedercollectArg :: GlobalAnnos -> TypeMap -> PMap a -> (PState a -> a)
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder -> PState a -> [PState a]
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- pre: finished rule
08f8731b34de5dc1ced274594978ad8879c831bdChristian MaedercollectArg ga tm m f
83cc27e4ca7cf1a4bb5f4a8df17d3e6d44e6f1eaChristian Maeder s@(PState { ruleId = argIde, stateNo = arg, ruleType = argType }) =
88d16ba9fcfb786c4e953f99982e3056ad2045ecChristian Maeder map (\ p -> p { restRule = tail $ restRule p })
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder $ mapMaybe (filterByType tm (argType, f s))
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder $ filter (filterByPrec ga argIde)
83cc27e4ca7cf1a4bb5f4a8df17d3e6d44e6f1eaChristian Maeder $ lookUp m arg
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maedercompl :: GlobalAnnos -> TypeMap -> PMap a -> (PState a -> a)
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder -> [PState a] -> [PState a]
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maedercompl ga tm m f l =
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder concat $ map (collectArg ga tm m f)
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder $ filter (null . restRule) l
08f8731b34de5dc1ced274594978ad8879c831bdChristian MaedercomplRec :: GlobalAnnos -> TypeMap -> PMap a -> (PState a -> a)
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder -> [PState a] -> [PState a]
08f8731b34de5dc1ced274594978ad8879c831bdChristian MaedercomplRec ga tm m f l = let l1 = compl ga tm m f l in
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder if null l1 then l else complRec ga tm m f l1 ++ l
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maedercomplete :: GlobalAnnos -> TypeMap -> (PState a -> a)
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder -> ParseMap a -> ParseMap a
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maedercomplete ga tm f pm =
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder let m = parseMap pm
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder i = lastIndex pm in
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder pm { parseMap = Map.insert i (complRec ga tm m f $ lookUp m i) m }
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- predict which rules/ids might match for (the) nonterminal(s) (termTok)
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder-- provided the "dot" is followed by a nonterminal
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maederpredict :: (Index -> State Int [PState a]) -> ParseMap a -> ParseMap a
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maederpredict f pm =
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder let m = parseMap pm
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder i = lastIndex pm
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder c = varCount pm in
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder if not (isStartIndex i) && any (\ (PState { restRule = ts }) ->
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder not (null ts) && head ts == termTok)
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder then let (nextStates, c2) = runState (f i) c
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder in pm { varCount = c2
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder , parseMap = Map.insertWith (++) i nextStates m }
08f8731b34de5dc1ced274594978ad8879c831bdChristian MaedercompleteScanPredict :: (PrettyPrint a, PosItem a)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder => GlobalAnnos -> TypeMap -> Knowns
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder -> (Maybe Type, a) -> (PState a -> a) -> (a -> Token)
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder -> (Index -> State Int [PState a])
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder -> ParseMap a -> ParseMap a
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaedercompleteScanPredict ga tm knowns (ty, a) fromState toToken initStates pm =
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder let pm3 = complete ga tm fromState
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder $ scan tm knowns (ty, a) toToken
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder $ predict initStates pm
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder in if (null $ lookUp (parseMap pm3) $ lastIndex pm3)
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder && null (failDiags pm3)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder then pm3 { failDiags = [mkDiag Error
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder ("unexpected mixfix token") a] }
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian MaedernextState :: GlobalAnnos -> Assumps -> TypeMap -> (Maybe Type, Term)
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder -> ParseMap Term -> ParseMap Term
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaedernextState ga as tm (ty, trm) =
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder completeScanPredict ga tm Set.empty (ty, trm) stateToAppl termToToken $
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder initialState ga as
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder-- | find information for qualified operation
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian MaederfindOpId :: Assumps -> TypeMap -> Int -> UninstOpId -> Type -> Maybe OpInfo
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian MaederfindOpId as tm c i ty = listToMaybe $ fst $
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder partitionOpId as tm c i $ TypeScheme [] ([] :=> ty) []
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian MaederiterStates :: GlobalAnnos -> Assumps -> TypeMap -> ClassMap -> Type -> [Term]
1db126da06f707b90b5be9d66a73c36ee2cd22eeChristian Maeder -> ParseMap Term -> ParseMap Term
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian MaederiterStates ga as tm cm ty terms pm =
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder let self = iterStates ga as tm cm ty
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder in if null terms then pm
ca010363454de207082dfaa4b753531ce2a34551Christian Maeder else case head terms of
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder MixfixTerm ts -> self (ts ++ tail terms) pm
a0a2ff520a916e334d58f96e59f009aae61e98a7Christian Maeder BracketTerm b ts ps -> self
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder (expandPos TermToken (getBrackets b) ts ps ++ tail terms) pm
9cc728bd2b84e76193626f123eea2cb5736b366bChristian Maeder (QualVar v tyq ps) ->
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder let (Result es mt) = (readR $ anaType (star, tyq)) (cm, tm) in
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder Just (_, typq) ->
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder let mi = findOpId as tm (varCount pm) v typq in
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder Just _ -> self (tail terms) $ nextState ga as tm
9cc728bd2b84e76193626f123eea2cb5736b366bChristian Maeder (Just typq, QualVar v typq ps) pm
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder Nothing -> pm { failDiags =
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder [mkDiag Error
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder "value not found" v] }
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder Nothing -> pm { failDiags = es }
9cc728bd2b84e76193626f123eea2cb5736b366bChristian Maeder (QualOp io@(InstOpId v _ _) (TypeScheme vs (qs :=> tyq) ps1) ps2)
9cc728bd2b84e76193626f123eea2cb5736b366bChristian Maeder -> let (Result es mt) = (readR $ anaType (star, tyq)) (cm, tm)
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder Just (_, typq) ->
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder let mi = findOpId as tm (varCount pm) v typq in
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder Just _ -> self (tail terms) $ nextState ga as tm
9cc728bd2b84e76193626f123eea2cb5736b366bChristian Maeder (Just typq, QualOp io
9cc728bd2b84e76193626f123eea2cb5736b366bChristian Maeder (TypeScheme vs (qs :=> typq) ps1)
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder Nothing -> pm { failDiags =
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder [mkDiag Error
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder "value not found" v] }
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder Nothing -> pm { failDiags = es }
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder TypedTerm hd tqual tyq ps ->
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder let (Result es mt) = (readR $ anaType (star, tyq)) (cm, tm) in
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder Just (_, typq) ->
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder let (Result ds mtt, c2) = runRState
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder (case tqual of
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder OfType -> resolve ga as tm cm (typq, hd)
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder _ -> resolveAny ga as tm cm hd)
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder $ varCount pm
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder pm2 = pm { varCount = c2, failDiags = es++ds }
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder in case mtt of
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder Just (_, ttt) -> self (tail terms)
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder $ nextState ga as tm
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder (Just (case tqual of
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder InType -> logicalType
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder TypedTerm ttt tqual typq ps) pm2
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder Nothing -> pm2
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder Nothing -> pm { failDiags = es }
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder QuantifiedTerm quant decls hd ps ->
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder let (Result ds mtt, c2) = runRState
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder (resolve ga as tm cm (logicalType, hd)) $ varCount pm
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder pm2 = pm { varCount = c2, failDiags = ds }
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder in case mtt of
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder Just (_, tt) -> self (tail terms) $ nextState ga as tm
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder (Just logicalType,
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder QuantifiedTerm quant decls tt ps) pm2
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder Nothing -> pm2
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder LambdaTerm decls part hd ps ->
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder let (Result ds mtt, c2) = runRState
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder (resolveAny ga as tm cm hd) $ varCount pm
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder pm2 = pm { varCount = c2, failDiags = ds }
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder in case mtt of
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder Just (typq, tt) -> self (tail terms) $ nextState ga as tm
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder (Just typq, LambdaTerm decls part tt ps) pm2
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder Nothing -> pm2
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder CaseTerm hd (ProgEq pat e1 pps : _) ps ->
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder let (Result ds mtt, c2) = runRState
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder (resolveAny ga as tm cm hd) $ varCount pm
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder (Result es frst, c3) = runRState
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder (resolveAny ga as tm cm e1) c2
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder pm2 = pm { varCount = c3, failDiags = ds++es }
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder in case (mtt, frst) of
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder (Just (_, tt), Just (typq, te)) -> self (tail terms)
08f8731b34de5dc1ced274594978ad8879c831bdChristian Maeder $ nextState ga as tm
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder (Just typq, CaseTerm tt [ProgEq pat te pps] ps) pm2
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder LetTerm eqs hd ps ->
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder let (Result ds mtt, c2) = runRState
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder (resolveAny ga as tm cm hd) $ varCount pm
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder pm2 = pm { varCount = c2, failDiags = ds }
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder in case mtt of
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder Just (typq, tt) -> self (tail terms) $ nextState ga as tm
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder (Just typq, LetTerm eqs tt ps) pm2
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder Nothing -> pm2
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder t@(TermToken _) -> self (tail terms)
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder $ nextState ga as tm (Nothing, t) pm
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder t -> error ("iterStates: " ++ show t)
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaedergetAppls :: ParseMap a -> [PState a]
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder filter (\ (PState { restRule = ts, stateNo = k })
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder -> null ts && isStartIndex k) $
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder lookUp (parseMap pm) $ lastIndex pm
1db126da06f707b90b5be9d66a73c36ee2cd22eeChristian MaedergetLastType :: ParseMap a -> Type
8853be843bc3eed2ca6722efeee5174335e28b0eChristian MaedergetLastType pm =
8853be843bc3eed2ca6722efeee5174335e28b0eChristian Maeder let tys = map ruleType $
8853be843bc3eed2ca6722efeee5174335e28b0eChristian Maeder filter (\ (PState { restRule = ts, stateNo = k })
8853be843bc3eed2ca6722efeee5174335e28b0eChristian Maeder -> null ts && isStartIndex k) $
8853be843bc3eed2ca6722efeee5174335e28b0eChristian Maeder lookUp (parseMap pm) $ lastIndex pm
8853be843bc3eed2ca6722efeee5174335e28b0eChristian Maeder in if null tys then error "getLastType" else head tys
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian MaederresolveToParseMap :: GlobalAnnos -> Assumps -> TypeMap -> ClassMap -> Int
1db126da06f707b90b5be9d66a73c36ee2cd22eeChristian Maeder -> Type -> Term -> ParseMap Term
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian MaederresolveToParseMap ga as tm cm c ty trm =
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder let (initStates, c2) = runState (initialState ga as startIndex) c in
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder iterStates ga as tm cm ty [trm]
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder ParseMap { lastIndex = startIndex
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder , failDiags = []
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder , varCount = c2
aae44eae4cd27141bea70af8d54844c3849a0711Christian Maeder , parseMap = Map.single startIndex initStates }
1db126da06f707b90b5be9d66a73c36ee2cd22eeChristian MaedercheckResultType :: TypeMap -> Type -> ParseMap a -> ParseMap a
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian MaedercheckResultType tm t pm =
cf58a323fcb5c4185c3aa378713bbee3bba18c0aChristian Maeder let m = parseMap pm
cf58a323fcb5c4185c3aa378713bbee3bba18c0aChristian Maeder i = lastIndex pm in
cf58a323fcb5c4185c3aa378713bbee3bba18c0aChristian Maeder pm { parseMap = Map.insert i
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder (mapMaybe (filterByResultType tm t)
cf58a323fcb5c4185c3aa378713bbee3bba18c0aChristian Maeder $ lookUp m i) m }
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian MaederresolveAny :: GlobalAnnos -> Assumps -> TypeMap -> ClassMap
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder -> Term -> RState Int (Type, Term)
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian MaederresolveAny ga as tm cm trm =
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder do tvar <- liftS freshVar
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder resolve ga as tm cm (TypeName tvar star 1, trm)
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederresolveFromParseMap :: (PosItem a, PrettyPrint a) => (PState a -> a)
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder -> TypeMap -> (Type, a) -> ParseMap a -> Result (Type, a)
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederresolveFromParseMap f tm (ty, a) pm0 =
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder let pm = checkResultType tm ty $ pm0
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder ds = failDiags pm
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder ts = map f $ getAppls pm in
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder if null ts then Result
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder (if null ds then
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder [mkDiag FatalError "no resolution for" a]
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder else ds) Nothing
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder else if null $ tail ts then Result ds (Just (getLastType pm, head ts))
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder else Result (mkDiag
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder Error ("ambiguous applications:\n\t" ++
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder (concatMap ( \ t -> showPretty t "\n\t")
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder $ take 5 ts) ++ "for" ) a : ds) Nothing
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maederresolve :: GlobalAnnos -> Assumps -> TypeMap -> ClassMap
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder -> (Type, Term) -> RState Int (Type, Term)
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maederresolve ga as tm cm (ty, trm) =
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder do c <- liftS get
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder liftR $ resolveFromParseMap (toAppl ga) tm (ty, trm) $
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder resolveToParseMap ga as tm cm c ty trm
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian MaedertoEnvRState :: RState Int a -> RState Env a
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian MaedertoEnvRState p =
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder do s <- liftS get
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder let (r, c) = runRState p $ counter s
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder liftS $ put s { counter = c }
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian MaederresolveTerm :: GlobalAnnos -> Type -> Term -> RState Env Term
4b0a4c7dea0f67a233dcc42ce9bb18d36de109aeChristian MaederresolveTerm ga ty trm =
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder do s <- liftS $ get
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder (_, r) <- toEnvRState $ resolve ga
8b39fe4e459a2c534b55bab3bd68f929ba9a8b74Christian Maeder (assumps s) (typeMap s) (classMap s) (ty, trm)
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian MaedertoRResultState :: RState s a -> State s (Result a)
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian MaedertoRResultState r =
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder let (r', s') = runRState r s
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder-- ---------------------------------
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder-- ---------------------------------
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederextractBindings :: Pattern -> [VarDecl]
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederextractBindings pat =
aa60342b6a000c6798730e1b1ddeec846254c62cChristian Maeder PatternVar l -> [l]
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder PatternConstr _ _ ps _ -> concatMap extractBindings ps
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder TuplePattern ps _ -> concatMap extractBindings ps
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder TypedPattern p _ _ -> extractBindings p
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder AsPattern p q _ -> extractBindings p ++ extractBindings q
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder _ -> error ("extractBindings: " ++ show pat)
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederpatToToken :: Pattern -> Token
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederpatToToken pat =
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder PatternToken x -> x
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder TypedPattern _ _ _ -> inTok
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder _ -> error ("patToToken: " ++ show pat)
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederpatFromState :: PState Pattern -> Pattern
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederpatFromState p =
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder let r@(Id ts _ _)= ruleId p
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder sc@(TypeScheme _ (_ :=> _ty) _) = ruleScheme p
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder ar = reverse $ ruleArgs p
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder qs = reverse $ posList p
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder in if r == inId
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder || r == parenId
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder else if r == applId then
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder case head ar of
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder PatternConstr instOp isc args ps ->
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder PatternConstr instOp isc (args ++ tail ar) (ps ++ qs)
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder t -> error ("patFromState: " ++ show t)
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder else if r == tupleId || r == unitId then
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder TuplePattern ar qs
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder else if isUnknownId r then
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder if null $ tail ts then error "patFromState"
aa60342b6a000c6798730e1b1ddeec846254c62cChristian Maeder else PatternVar (VarDecl (Id [head $ tail ts] [] [])
aa60342b6a000c6798730e1b1ddeec846254c62cChristian Maeder (ruleType p) Other qs)
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder else PatternConstr (InstOpId (setIdePos r ar qs) [] []) sc ar qs
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian MaederinitialPatState :: Assumps -> Index -> State Int [PState a]
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian MaederinitialPatState as i =
ffd01020a4f35f434b912844ad6e0d6918fadffdChristian Maeder do let ids = concatMap (\ (ide, l) -> map ( \ e -> (ide, e)) $ opInfos l)
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder l1 <- mapM (mkMixfixState i) ids
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder l2 <- mapM (mkPlainApplState i) $ filter (isMixfix . fst) ids
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder a <- mkApplTokState i applId
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder p <- mkParenTokState i parenId
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder t <- mkTupleTokState i tupleId
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder l3 <- mapM (mkTokState i)
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder return (a:p:t:l1 ++ l2 ++ l3)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaedernextPatState :: GlobalAnnos -> Assumps -> TypeMap -> Knowns
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder -> (Maybe Type, Pattern) -> ParseMap Pattern -> ParseMap Pattern
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaedernextPatState ga as tm knowns (ty, trm) =
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder completeScanPredict ga tm knowns (ty, trm) patFromState patToToken
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder $ initialPatState as
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaederiterPatStates :: GlobalAnnos -> Assumps -> TypeMap -> Knowns -> ClassMap
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder -> Type -> [Pattern] -> ParseMap Pattern -> ParseMap Pattern
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaederiterPatStates ga as tm knowns cm ty pats pm =
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder let self = iterPatStates ga as tm knowns cm ty
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder in if null pats then pm
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder else case head pats of
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder MixfixPattern ts -> self (ts ++ tail pats) pm
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder BracketPattern b ts ps -> self
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder (expandPos PatternToken (getBrackets b) ts ps ++ tail pats) pm
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder TypedPattern hd tyq ps ->
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder let (Result es mt) = (readR $ anaType (star, tyq)) (cm, tm) in
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder Just (_, typq) ->
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder let (Result ds mtt, c2) = runRState
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder (resolvePat ga as tm cm (typq, hd)) $ varCount pm
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder pm2 = pm { varCount = c2, failDiags = es++ds }
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder in case mtt of
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder Just (_, ttt) -> self (tail pats)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder $ nextPatState ga as tm knowns
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder (Just typq, TypedPattern ttt typq ps) pm2
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder Nothing -> pm2
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder Nothing -> pm { failDiags = es }
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder t@(PatternToken _) -> self (tail pats)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder $ nextPatState ga as tm knowns
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder (Nothing, t) pm
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder t -> error ("iterPatStates: " ++ show t)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaedergetKnowns :: Id -> Knowns
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaedergetKnowns (Id ts cs _) = Set.union (Set.fromList (map tokStr ts)) $
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder Set.unions (map getKnowns cs)
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederresolvePatToParseMap :: GlobalAnnos -> Assumps -> TypeMap -> ClassMap -> Int
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder -> Type -> Pattern -> ParseMap Pattern
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederresolvePatToParseMap ga as tm cm c ty trm =
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder let (initStates, c2) = runState (initialPatState as startIndex) c
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder knowns = Set.union (Set.fromList (tokStr inTok : map (:[]) "{}[](),"))
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder $ Set.unions $ map getKnowns ids
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder iterPatStates ga as tm knowns cm ty [trm]
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder ParseMap { lastIndex = startIndex
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder , failDiags = []
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder , varCount = c2
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder , parseMap = Map.single startIndex initStates }
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederresolveAnyPat :: GlobalAnnos -> Assumps -> TypeMap -> ClassMap
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder -> Pattern -> RState Int (Type, Pattern)
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederresolveAnyPat ga as tm cm trm =
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder do tvar <- liftS $ freshVar
46d766efdf8beaaadf3f34d99c305738064e9216Christian Maeder resolvePat ga as tm cm (TypeName tvar star 1, trm)
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederresolvePat :: GlobalAnnos -> Assumps -> TypeMap -> ClassMap
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder -> (Type, Pattern) -> RState Int (Type, Pattern)
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederresolvePat ga as tm cm (ty, trm) =
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder do c <- liftS $ get
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder let pm = resolvePatToParseMap ga as tm cm c ty trm
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder c2 = varCount pm
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder (newTy, pat) <- liftR $ resolveFromParseMap patFromState tm (ty, trm) pm
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder let (r, (c3, _)) = runRState (specializePatVars tm
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder (newTy, pat)) (c2, Map.empty)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder liftS $ put c3
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaederresolvePattern :: GlobalAnnos -> Pattern -> RState Env (Type, Pattern)
4b0a4c7dea0f67a233dcc42ce9bb18d36de109aeChristian MaederresolvePattern ga pat =
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder do s <- liftS $ get
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder toEnvRState $ resolveAnyPat ga
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder (assumps s) (typeMap s) (classMap s) pat
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder-- ---------------------------------------------------------------------------
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder-- ---------------------------------------------------------------------------
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaedergetArgsRes :: Type -> [a] -> ([Type], Type)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaedergetArgsRes t [] = ([], t)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaedergetArgsRes (FunType t1 _ t2 _) (_:r) =
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder let (as, res) = getArgsRes t2 r in
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaedergetArgsRes _ _ = error "getArgsRes"
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaederspecializePatVars :: TypeMap -> (Type, Pattern)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder -> RState (Int, Subst) (Type, Pattern)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaederspecializePatVars tm (ty, pat) =
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder PatternVar (VarDecl v vty k ps)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder -> do (c, oldSubst) <- liftS get
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder newSubst <- liftR $ unify tm (subst oldSubst ty)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder $ subst oldSubst vty
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder liftS $ put (c, newSubst)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder return (subst newSubst ty,
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder PatternVar $ VarDecl v (subst newSubst vty) k ps)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder PatternConstr i sc args ps
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder -> do (c, oldSubst) <- liftS get
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder let (ity, c2) = runState (freshInst sc) c
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder (ats, res) = getArgsRes ity args
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder newSubst <- liftR $ unify tm (subst oldSubst ty)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder $ subst oldSubst res
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder liftS $ put (c2, newSubst)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder largs <- mapM (specializePatVars tm) $ zip ats args
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder (_, lastSubst) <- liftS get
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder return (subst lastSubst res,
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder PatternConstr i sc (map snd largs) ps)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder TuplePattern args ps ->
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder ProductType ats qs ->
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder if length ats == length args then
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder do largs <- mapM (specializePatVars tm) $ zip ats args
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder (_, lastSubst) <- liftS get
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder return (subst lastSubst $ ProductType (map fst largs) qs
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder , TuplePattern (map snd largs) ps)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder else error "wrong TuplePattern in specializePatVars"
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder _ -> error "TuplePattern in specializePatVars"
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder TypedPattern tpat vty ps ->
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder do (c, oldSubst) <- liftS get
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder newSubst <- liftR $ unify tm (subst oldSubst ty)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder $ subst oldSubst vty
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder liftS $ put (c, newSubst)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder (newTy, newPat) <- specializePatVars tm
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder (subst newSubst vty, tpat)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder return (newTy, case newPat of
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder PatternVar _ -> newPat
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder TypedPattern _ _ _ -> newPat
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder _ -> TypedPattern newPat newTy ps)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder _ -> error "specializePatVars"