MixAna.hs revision 53301de22afd7190981b363b57c48df86fcb50f7
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
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederMixfix analysis of terms and patterns, types annotations are also analysed
ca010363454de207082dfaa4b753531ce2a34551Christian Maederimport qualified Common.Lib.Map as Map
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maederimport qualified Common.Lib.Set as Set
53301de22afd7190981b363b57c48df86fcb50f7Christian Maederimport qualified Common.Lib.Rel as Rel
53301de22afd7190981b363b57c48df86fcb50f7Christian Maederassert :: Bool -> a -> a
53301de22afd7190981b363b57c48df86fcb50f7Christian Maederassert b a = if b then a else error ("assert")
53301de22afd7190981b363b57c48df86fcb50f7Christian Maedertype Rule = (Id, (), [Token])
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederifThenElse :: Id
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederifThenElse = mkId (map mkSimpleId [ifS, place, thenS, place, elseS, place])
53301de22afd7190981b363b57c48df86fcb50f7Christian MaedermkInfix :: String -> Id
53301de22afd7190981b363b57c48df86fcb50f7Christian MaedermkInfix s = mkId $ map mkSimpleId [place, s, place]
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederexEq = mkInfix exEqual
53301de22afd7190981b363b57c48df86fcb50f7Christian MaedereqId = mkInfix equalS
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederandId = mkInfix lAnd
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederorId = mkInfix lOr
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederimplId = mkInfix implS
53301de22afd7190981b363b57c48df86fcb50f7Christian MaedereqvId = mkInfix equivS
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederdefId = mkId $ map mkSimpleId [defS, place]
53301de22afd7190981b363b57c48df86fcb50f7Christian MaedernotId = mkId $ map mkSimpleId [notS, place]
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederaddBuiltins :: GlobalAnnos -> GlobalAnnos
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederaddBuiltins ga =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let ass = assoc_annos ga
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder [(applId, ALeft), (andId, ALeft), (orId, ALeft),
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (implId, ARight)]
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder precs = Rel.toList $ prec_annos ga
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder lows = map fst $ filter ((==eqId) . snd) precs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder logs = [(eqvId, implId), (implId, andId), (implId, orId),
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (andId, eqId), (orId, eqId), (andId, exEq), (orId, exEq)]
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder eqs = concatMap ( \ i -> [(eqId, i), (exEq, i)]) $
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder filter (`notElem` (eqId : lows)) $ filter isInfix $ map fst precs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder appls = map ( \ i -> (i, applId)) $ filter (/=applId) $
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder filter isInfix $ map snd precs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder in ga { assoc_annos = newAss
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder , prec_annos = Rel.transClosure $
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Rel.fromList $ concat [logs, eqs, appls, precs] }
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederinitTermRules :: [Id] -> [Rule]
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederinitTermRules is = (map (mixRule ()) . nub)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder ([tupleId, parenId, unitId, applId, exprId, ifThenElse,
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder exEq, eqId, orId, andId, implId, eqvId, defId, notId] ++ is) ++
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder map ( \ i -> (protect i, (), getPlainTokenList i ))
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (nub $ filter isMixfix is)
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederaddType :: Term -> Term -> Term
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederaddType (TypedTerm _ qual ty ps) t = TypedTerm t qual ty ps
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederaddType _ _ = error "addType"
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederdummyFilter :: () -> () -> Maybe Bool
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederdummyFilter () () = Nothing
53301de22afd7190981b363b57c48df86fcb50f7Christian MaedertoMixTerm :: Id -> () -> [Term] -> [Pos] -> Term
53301de22afd7190981b363b57c48df86fcb50f7Christian MaedertoMixTerm ide _ ar qs =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder if ide == applId then assert (length ar == 2) $
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let [op, arg] = ar in ApplTerm op arg qs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder else if ide == tupleId || ide == unitId then
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder TupleTerm ar qs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder else ResolvedMixTerm ide ar qs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maedertype TermChart = Chart Term ()
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) []
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederiterateCharts :: GlobalAnnos -> [Term] -> TermChart
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder -> State Env TermChart
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederiterateCharts ga terms chart =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let self = iterateCharts ga
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder oneStep = nextChart addType dummyFilter toMixTerm ga chart
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder as = assumps e
48708376ccab0e56251f53b0ec21499a277e9102Christian Maeder tm = typeMap e
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder if null terms then return chart else
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder do let t:tt = terms
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder recurse trm = self tt $
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder oneStep (trm, exprTok {tokPos = posOfTerm trm})
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder MixfixTerm ts -> self (ts ++ tt) chart
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder BracketTerm b ts ps -> self
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (expandPos TermToken (getBrackets b) ts ps ++ tt) chart
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder QualVar v typ ps -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mTyp <- anaStarType typ
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Nothing -> recurse t
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Just nTyp -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let mi = findOpId as tm (counter e) v nTyp
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Nothing -> addDiags [mkDiag Error
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder "value not found" v]
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder _ -> return ()
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder recurse $ QualVar v nTyp ps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder QualOp io@(InstOpId v _ _)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (TypeScheme rs (qs :=> typ) ss) ps -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mTyp <- anaStarType typ
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Nothing -> recurse t
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Just nTyp -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let mi = findOpId as tm (counter e) v nTyp
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Nothing -> addDiags [mkDiag Error
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder "value not found" v]
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder _ -> return ()
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder recurse $ QualOp io
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (TypeScheme rs (qs :=> nTyp) ss) ps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder TypedTerm hd tqual typ ps -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mTyp <- anaStarType typ
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Nothing -> recurse t
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Just nTyp -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mt <- resolve ga hd
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let newT = case mt of Just trm -> trm
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder recurse $ TypedTerm newT tqual nTyp ps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder QuantifiedTerm quant decls hd ps -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mapM_ anaGenVarDecl decls
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mt <- resolve ga hd
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder putAssumps as
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder putTypeMap tm
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let newT = case mt of Just trm -> trm
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder recurse $ QuantifiedTerm quant decls newT ps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder LambdaTerm decls part hd ps -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mDecls <- mapM (resolveConstrPattern ga) decls
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let newDecls = catMaybes mDecls
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder l <- mapM extractBindings newDecls
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let bs = concatMap snd l
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder checkUniqueVars bs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mapM_ addVarDecl bs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mt <- resolve ga hd
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder putAssumps as
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let newT = case mt of Just trm -> trm
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder recurse $ LambdaTerm (map fst l) part newT ps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder CaseTerm hd eqs ps -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mt <- resolve ga hd
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let newT = case mt of Just trm -> trm
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder newEs <- resolveCaseEqs ga eqs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder recurse $ CaseTerm newT newEs ps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder LetTerm eqs hd ps -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder newEs <- resolveLetEqs ga eqs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mt <- resolve ga hd
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let newT = case mt of Just trm -> trm
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder putAssumps as
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder recurse $ LetTerm newEs newT ps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder TermToken tok -> self tt $ oneStep (t, tok)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder _ -> error ("iterCharts: " ++ show t)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maederresolve :: GlobalAnnos -> Term -> State Env (Maybe Term)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maederresolve ga trm =
48708376ccab0e56251f53b0ec21499a277e9102Christian Maeder do as <- gets assumps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder chart<- iterateCharts (addBuiltins ga) [trm] $
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder initChart (initTermRules $ Map.keys as) Set.empty
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let Result ds mr = getResolved showPretty (posOfTerm trm)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder toMixTerm chart
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder-- * equation stuff
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederresolveCaseEq :: GlobalAnnos -> ProgEq -> State Env (Maybe ProgEq)
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederresolveCaseEq ga (ProgEq p t ps) =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder do mp <- resolveConstrPattern ga p
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Nothing -> return Nothing
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Just np -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder as <- gets assumps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (newP, bs) <- extractBindings np
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder checkUniqueVars bs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mapM_ addVarDecl bs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mtt <- resolve ga t
669e21946b6f90785fc3cb44e7cf4f38c3f6493dChristian Maeder putAssumps as
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder return $ case mtt of
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Nothing -> Nothing
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Just newT -> Just $ ProgEq newP newT ps
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederresolveCaseEqs :: GlobalAnnos -> [ProgEq] -> State Env [ProgEq]
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederresolveCaseEqs _ [] = return []
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederresolveCaseEqs ga (eq:rt) =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder do mEq <- resolveCaseEq ga eq
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder eqs <- resolveCaseEqs ga rt
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder return $ case mEq of
669e21946b6f90785fc3cb44e7cf4f38c3f6493dChristian Maeder Nothing -> eqs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Just newEq -> newEq : eqs
669e21946b6f90785fc3cb44e7cf4f38c3f6493dChristian MaederresolveLetEqs :: GlobalAnnos -> [ProgEq] -> State Env [ProgEq]
669e21946b6f90785fc3cb44e7cf4f38c3f6493dChristian MaederresolveLetEqs _ [] = return []
669e21946b6f90785fc3cb44e7cf4f38c3f6493dChristian MaederresolveLetEqs ga (ProgEq pat trm ps : rt) =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder do mPat <- resolveConstrPattern ga pat
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Nothing -> do resolve ga trm
669e21946b6f90785fc3cb44e7cf4f38c3f6493dChristian Maeder resolveLetEqs ga rt
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Just nPat -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (newPat, bs) <- extractBindings nPat
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder checkUniqueVars bs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mapM addVarDecl bs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mTrm <- resolve ga trm
669e21946b6f90785fc3cb44e7cf4f38c3f6493dChristian Maeder Nothing -> resolveLetEqs ga rt
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Just newTrm -> do
669e21946b6f90785fc3cb44e7cf4f38c3f6493dChristian Maeder eqs <- resolveLetEqs ga rt
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder return (ProgEq newPat newTrm ps : eqs)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder-- * pattern stuff
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder-- | extract bindings from a pattern
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederextractBindings :: Pattern -> State Env (Pattern, [VarDecl])
46d766efdf8beaaadf3f34d99c305738064e9216Christian MaederextractBindings pat =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder PatternVar l@(VarDecl v t sk ps) -> case t of
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder MixfixType [] ->
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder do tvar <- toEnvState freshVar
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let ty = TypeName tvar star 1
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder vd = VarDecl v ty sk ps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder return (PatternVar vd, [vd])
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder _ -> do mt <- anaStarType t
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder Just ty -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let vd = VarDecl v ty sk ps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder return (PatternVar vd, [vd])
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder _ -> return (pat, [l])
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder ResolvedMixPattern i pats ps -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder l <- mapM extractBindings pats
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder return (ResolvedMixPattern i (map fst l) ps, concatMap snd l)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder PatternConstr i sc pats ps -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder l <- mapM extractBindings pats
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder return (PatternConstr i sc (map fst l) ps, concatMap snd l)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder TuplePattern pats ps -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder l <- mapM extractBindings pats
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder return (TuplePattern (map fst l) ps, concatMap snd l)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder TypedPattern p ty ps -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mt <- anaStarType ty
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let newT = case mt of Just t -> t
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder PatternVar (VarDecl v (MixfixType []) sk _) -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let vd = VarDecl v newT sk ps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder return (PatternVar vd, [vd])
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder _ -> do (newP, bs) <- extractBindings p
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder return (TypedPattern newP newT ps, bs)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder _ -> return (pat, [])
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder-- _ -> error ("extractBindings: " ++ show pat)
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederresolveConstrPattern :: GlobalAnnos -> Pattern
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder -> State Env (Maybe Pattern)
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederresolveConstrPattern ga pat =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder do as <- gets assumps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let newAs = filterAssumps ( \ o -> case opDefn o of
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder ConstructData _ -> True
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder VarDefn -> True
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder _ -> False) as
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder putAssumps newAs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mp <- resolvePattern ga pat
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder putAssumps as
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederinitPatternRules :: [Id] -> [Rule]
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederinitPatternRules is =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (tupleId, (), getTokenPlaceList tupleId) :
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (parenId, (), getTokenPlaceList parenId) :
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (unknownId, (), getTokenPlaceList unknownId) :
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (applId, (), getTokenPlaceList applId) :
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (exprId, (), getTokenPlaceList exprId) :
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder map ( \ i -> (i, (), getTokenPlaceList i )) is ++
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder map ( \ i -> (protect i, (), getPlainTokenList i )) (filter isMixfix is)
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederaddPatternType :: Pattern -> Pattern -> Pattern
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederaddPatternType (TypedPattern _ ty ps) p = TypedPattern p ty ps
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederaddPatternType _ _ = error "addPatternType"
53301de22afd7190981b363b57c48df86fcb50f7Christian MaedermkPatAppl :: Pattern -> Pattern -> [Pos] -> Pattern
53301de22afd7190981b363b57c48df86fcb50f7Christian MaedermkPatAppl op arg qs =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder ResolvedMixPattern i as ps ->
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder ResolvedMixPattern i (as++[arg]) (ps++qs)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder PatternVar (VarDecl i (MixfixType []) _ _) ->
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder ResolvedMixPattern i [arg] qs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder TypedPattern p ty ps ->
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder TypedPattern (mkPatAppl p arg qs) ty ps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder _ -> error ("mkPatAppl: " ++ show op)
53301de22afd7190981b363b57c48df86fcb50f7Christian MaedertoPat :: Id -> () -> [Pattern] -> [Pos] -> Pattern
53301de22afd7190981b363b57c48df86fcb50f7Christian MaedertoPat i _ ar qs =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder if i == applId then assert (length ar == 2) $
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let [op, arg] = ar in mkPatAppl op arg qs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder else if i == tupleId then
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder TuplePattern ar qs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder else if isUnknownId i then
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder PatternVar (VarDecl (simpleIdToId $ unToken i)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (MixfixType []) Other qs)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder else ResolvedMixPattern i ar qs
53301de22afd7190981b363b57c48df86fcb50f7Christian Maedertype PatChart = Chart Pattern ()
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederiterPatCharts :: GlobalAnnos -> [Pattern] -> PatChart -> State Env PatChart
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederiterPatCharts ga pats chart=
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let self = iterPatCharts ga
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder oneStep = nextChart addPatternType dummyFilter toPat ga chart
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder in if null pats then return chart
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder do let p:pp = pats
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder recurse pt = self pp $
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder oneStep (pt, exprTok {tokPos = posOfPat pt})
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder MixfixPattern ps -> self (ps ++ pp) chart
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder BracketPattern b ps qs -> self
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder (expandPos PatternToken (getBrackets b) ps qs ++ pp) chart
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder TypedPattern hd typ ps -> do
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder mp <- resolvePattern ga hd
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let np = case mp of Just pt -> pt
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder recurse $ TypedPattern np typ ps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder PatternToken tok -> self pp $ oneStep (p, tok)
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder _ -> error ("iterPatCharts: " ++ show p)
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaedergetKnowns :: Id -> Knowns
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian MaedergetKnowns (Id ts cs _) = Set.union (Set.fromList (map tokStr ts)) $
fcfed328fae6266214ee61ee7a16fd263fd3cb70Christian Maeder Set.unions (map getKnowns cs)
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederresolvePattern :: GlobalAnnos -> Pattern -> State Env (Maybe Pattern)
53301de22afd7190981b363b57c48df86fcb50f7Christian MaederresolvePattern ga pat =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder do as <- gets assumps
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder ks = Set.union (Set.fromList (tokStr exprTok: inS :
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder map (:[]) "{}[](),"))
48708376ccab0e56251f53b0ec21499a277e9102Christian Maeder $ Set.unions $ map getKnowns ids
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder chart <- iterPatCharts ga [pat] $ initChart (initPatternRules ids) ks
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder let Result ds mp = getResolved showPretty (posOfPat pat) toPat chart