----------------------------------------------------------------------------- -- |The Helium Compiler : Static Analysis -- -- Maintainer : bastiaan@cs.uu.nl -- Stability : experimental -- Portability : unknown -- -- Try to match the specialized type rules with the abstract syntax tree at -- hand. If a specialized type rule can be applied at the certain node in the -- tree, then a different set of constraints is inserted instead of the -- standard ones. -- -- (directives based on "Scripting the Type Inference Process", ICFP 2003) ----------------------------------------------------------------------------- imports { import Data.List import Helium.StaticAnalysis.Directives.Matchers import Helium.StaticAnalysis.Directives.TS_Apply (applyTypingStrategy, matchInformation) import Helium.StaticAnalysis.Directives.TS_CoreSyntax import Helium.StaticAnalysis.Directives.TS_Attributes } ATTR Body Statement Qualifier Statements Qualifiers Expression RightHandSide MaybeExpression Expressions GuardedExpression GuardedExpressions FunctionBinding FunctionBindings Declaration Declarations MaybeDeclarations Alternative Alternatives [ | matchIO : {IO ()} | ] SEM Module | Module body . matchIO = return () --------------------------------------------------------------------------------------------------------- ATTR Expressions Expression MaybeExpression GuardedExpression GuardedExpressions Qualifiers Qualifier Statements Statement [ | uniqueSecondRound : Int | ] SEM RightHandSide | Expression expression . uniqueSecondRound = @expression.betaUnique where . betaUnique = @expression.uniqueSecondRound | Guarded guardedexpressions . uniqueSecondRound = @guardedexpressions.betaUnique where . betaUnique = @guardedexpressions.uniqueSecondRound --------------------------------------------------------------------------------------------------------- ATTR Body Expression Expressions MaybeExpression Statements Statement Qualifiers Qualifier GuardedExpression GuardedExpressions FunctionBinding FunctionBindings Declaration Declarations MaybeDeclarations RightHandSide Alternative Alternatives [ allPatterns : {[((Expression, [String]), Core_TypingStrategy)]} | | ] SEM Module | Module body . allPatterns = [ (matchInfo, typingStrategy) | typingStrategy <- typingStrategies @lhs.importEnvironment , matchInfo <- matchInformation @lhs.importEnvironment typingStrategy ] --------------------------------------------------------------------------------------------------------- ATTR Expressions [ tryPatterns : {[(Expressions , [String])]} | | ] ATTR Expression [ tryPatterns : {[(Expression , [String])]} | | ] ATTR MaybeExpression [ tryPatterns : {[(MaybeExpression, [String])]} | | ] --------------------------------------------------------------------------------------------------------- ATTR Expression Expressions MaybeExpression [ | | matches : {[Maybe MetaVariableTable]} ] SEM Expression | Literal ((), lhs.matches, lhs.constraints, lhs.assumptions, lhs.uniqueSecondRound, loc.ioMatch) = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in match0 infoTuple @lhs.uniqueSecondRound (match_Expression_Literal @literal.self) @lhs.tryPatterns @lhs.allPatterns [] | Variable ((), lhs.matches, lhs.constraints, lhs.assumptions, lhs.uniqueSecondRound, loc.ioMatch) = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in match0 infoTuple @lhs.uniqueSecondRound (match_Expression_Variable @name.self) @lhs.tryPatterns @lhs.allPatterns [] | Hole ((), lhs.matches, lhs.constraints, lhs.assumptions, lhs.uniqueSecondRound, loc.ioMatch) = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in match0 infoTuple @lhs.uniqueSecondRound (const Nothing) @lhs.tryPatterns @lhs.allPatterns [] | Constructor ((), lhs.matches, lhs.constraints, lhs.assumptions, lhs.uniqueSecondRound, loc.ioMatch) = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in match0 infoTuple @lhs.uniqueSecondRound (match_Expression_Constructor @name.self) @lhs.tryPatterns @lhs.allPatterns [] | NormalApplication ( (function.tryPatterns, arguments.tryPatterns) , lhs.matches, lhs.constraints, lhs.assumptions, lhs.uniqueSecondRound, loc.ioMatch ) = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in match2 infoTuple @arguments.uniqueSecondRound match_Expression_NormalApplication @lhs.tryPatterns @lhs.allPatterns [@function.matches, @arguments.matches] | InfixApplication ( (leftExpression.tryPatterns, operator.tryPatterns, rightExpression.tryPatterns) , lhs.matches, lhs.constraints, lhs.assumptions, lhs.uniqueSecondRound, loc.ioMatch ) = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in match3 infoTuple @rightExpression.uniqueSecondRound match_Expression_InfixApplication @lhs.tryPatterns @lhs.allPatterns [@leftExpression.matches, @operator.matches,@rightExpression.matches] | If ( (guardExpression.tryPatterns, thenExpression.tryPatterns, elseExpression.tryPatterns) , lhs.matches, lhs.constraints, lhs.assumptions, lhs.uniqueSecondRound, loc.ioMatch ) = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in match3 infoTuple @elseExpression.uniqueSecondRound match_Expression_If @lhs.tryPatterns @lhs.allPatterns [@guardExpression.matches,@thenExpression.matches,@elseExpression.matches] | List (expressions.tryPatterns, lhs.matches, lhs.constraints, lhs.assumptions, lhs.uniqueSecondRound, loc.ioMatch) = let infoTuple = metaVarInfo @constraints @expressions.assumptions @localInfo in match1 infoTuple @expressions.uniqueSecondRound match_Expression_List @lhs.tryPatterns @lhs.allPatterns [@expressions.matches] | Tuple (expressions.tryPatterns, lhs.matches, lhs.constraints, lhs.assumptions, lhs.uniqueSecondRound, loc.ioMatch) = let infoTuple = metaVarInfo @constraints @expressions.assumptions @localInfo in match1 infoTuple @expressions.uniqueSecondRound match_Expression_Tuple @lhs.tryPatterns @lhs.allPatterns [@expressions.matches] | Enum ( (from.tryPatterns, then.tryPatterns, to.tryPatterns) , lhs.matches, lhs.constraints, lhs.assumptions, lhs.uniqueSecondRound, loc.ioMatch ) = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in match3 infoTuple @to.uniqueSecondRound match_Expression_Enum @lhs.tryPatterns @lhs.allPatterns [@from.matches, @then.matches, @to.matches] | Negate (expression.tryPatterns, lhs.matches, lhs.constraints, lhs.assumptions, lhs.uniqueSecondRound, loc.ioMatch) = let infoTuple = metaVarInfo @constraints @expression.assumptions @localInfo in match1 infoTuple @expression.uniqueSecondRound match_Expression_Negate @lhs.tryPatterns @lhs.allPatterns [@expression.matches] | NegateFloat (expression.tryPatterns, lhs.matches, lhs.constraints, lhs.assumptions, lhs.uniqueSecondRound, loc.ioMatch) = let infoTuple = metaVarInfo @constraints @expression.assumptions @localInfo in match1 infoTuple @expression.uniqueSecondRound match_Expression_NegateFloat @lhs.tryPatterns @lhs.allPatterns [@expression.matches] SEM Expressions | Cons ((hd.tryPatterns,tl.tryPatterns), lhs.matches, _, _, _, _) = match2' match_Expressions_Cons @lhs.tryPatterns [] [@hd.matches, @tl.matches] | Nil ((), lhs.matches, _, _, _, _) = match0' match_Expressions_Nil @lhs.tryPatterns [] [] SEM MaybeExpression | Just (expression.tryPatterns, lhs.matches, _, _ , _, _) = match1' match_MaybeExpression_Just @lhs.tryPatterns [] [@expression.matches] | Nothing ((), lhs.matches, _, _, _, _) = match0' match_MaybeExpression_Nothing @lhs.tryPatterns [] [] --------------------------------------------------------------- -- Expressions that can only match with a meta variable. SEM Expression | Lambda lhs.matches = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in matchOnlyVariable infoTuple @lhs.tryPatterns | Case lhs.matches = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in matchOnlyVariable infoTuple @lhs.tryPatterns | Let lhs.matches = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in matchOnlyVariable infoTuple @lhs.tryPatterns | Do lhs.matches = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in matchOnlyVariable infoTuple @lhs.tryPatterns | Comprehension lhs.matches = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in matchOnlyVariable infoTuple @lhs.tryPatterns | Typed lhs.matches = let infoTuple = metaVarInfo @constraints @assumptions @localInfo in matchOnlyVariable infoTuple @lhs.tryPatterns SEM Expression | Lambda expression . tryPatterns = [] | Case expression . tryPatterns = [] | Let expression . tryPatterns = [] | Comprehension expression . tryPatterns = [] | Typed expression . tryPatterns = [] SEM Statement | Expression expression . tryPatterns = [] | Generator expression . tryPatterns = [] SEM Qualifier | Guard guard . tryPatterns = [] | Generator expression . tryPatterns = [] SEM GuardedExpression | GuardedExpression guard . tryPatterns = [] expression . tryPatterns = [] SEM RightHandSide | Expression expression . tryPatterns = [] --------------------------------------------------------------- -- Debug IO: matches SEM Expression | Literal lhs.matchIO = @lhs.matchIO >> @ioMatch | Variable lhs.matchIO = @lhs.matchIO >> @ioMatch -- | Hole lhs.matchIO = @lhs.matchIO >> @ioMatch | Constructor lhs.matchIO = @lhs.matchIO >> @ioMatch | NormalApplication lhs.matchIO = @arguments.matchIO >> @ioMatch | InfixApplication lhs.matchIO = @rightExpression.matchIO >> @ioMatch | If lhs.matchIO = @elseExpression.matchIO >> @ioMatch | List lhs.matchIO = @expressions.matchIO >> @ioMatch | Tuple lhs.matchIO = @expressions.matchIO >> @ioMatch | Enum lhs.matchIO = @to.matchIO >> @ioMatch | Negate lhs.matchIO = @expression.matchIO >> @ioMatch | NegateFloat lhs.matchIO = @expression.matchIO >> @ioMatch --------------------------------------------------------------------------------------------------------- { matchConverter0 :: [([String],())] -> () matchConverter0 = const () matchConverter1 :: [([String],a)] -> [(a,[String])] matchConverter1 = map (\(a,b) -> (b,a)) matchConverter2 :: [([String],(a,b))] -> ([(a,[String])],[(b,[String])]) matchConverter2 = let localInsert (metas,(a,b)) (as,bs) = ((a,metas):as,(b,metas):bs) in foldr localInsert ([],[]) matchConverter3 :: [([String],(a,b,c))] -> ([(a,[String])],[(b,[String])],[(c,[String])]) matchConverter3 = let localInsert (metas,(a,b,c)) (as,bs,cs) = ((a,metas):as,(b,metas):bs,(c,metas):cs) in foldr localInsert ([],[],[]) allMatch :: [Maybe [a]] -> Maybe [a] allMatch = rec_ [] where rec_ xs [] = Just xs rec_ _ (Nothing:_) = Nothing rec_ xs (Just ys:rest) = rec_ (ys ++ xs) rest data Match a = NoMatch | NonTerminalMatch a | MetaVariableMatch String instance Show (Match a) where show (NoMatch) = "NoMatch" show (NonTerminalMatch _) = "NonTerminal ??" show (MetaVariableMatch s) = "MetaVariableMatch "++show s expressionVariableMatcher :: Expression -> Maybe String expressionVariableMatcher expr = case expr of Expression_Variable _ name -> Just (show name) _ -> Nothing match0 :: MetaVariableInfo -> Int -> (Expression -> Maybe ()) -> [(Expression, [String])] -> [((Expression, [String]), Core_TypingStrategy)] -> [[Maybe MetaVariableTable]] -> ((), [Maybe MetaVariableTable], ConstraintSet, Assumptions, Int, IO ()) match0 = generalMatch expressionVariableMatcher matchConverter0 match1 :: MetaVariableInfo -> Int -> (Expression -> Maybe a) -> [(Expression, [String])] -> [((Expression, [String]), Core_TypingStrategy)] -> [[Maybe MetaVariableTable]] -> ([(a, [String])], [Maybe MetaVariableTable], ConstraintSet, Assumptions, Int, IO ()) match1 = generalMatch expressionVariableMatcher matchConverter1 match2 :: MetaVariableInfo -> Int -> (Expression -> Maybe (a, b)) -> [(Expression, [String])] -> [((Expression, [String]), Core_TypingStrategy)] -> [[Maybe MetaVariableTable]] -> (([(a, [String])], [(b, [String])]), [Maybe MetaVariableTable], ConstraintSet, Assumptions, Int, IO ()) match2 = generalMatch expressionVariableMatcher matchConverter2 match3 :: MetaVariableInfo -> Int -> (Expression -> Maybe (a, b, c)) -> [(Expression, [String])] -> [((Expression, [String]), Core_TypingStrategy)] -> [[Maybe MetaVariableTable]] -> (([(a, [String])], [(b, [String])], [(c, [String])]), [Maybe MetaVariableTable], ConstraintSet, Assumptions, Int, IO ()) match3 = generalMatch expressionVariableMatcher matchConverter3 match0' :: (a -> Maybe ()) -> [(a, [String])] -> [((a, [String]), Core_TypingStrategy)] -> [[Maybe MetaVariableTable]] -> ((), [Maybe MetaVariableTable], ConstraintSet, Assumptions, Int, IO ()) match0' = generalMatch noMatch matchConverter0 noMetaVariableInfo 0 match1' :: (a -> Maybe b) -> [(a, [String])] -> [((a, [String]), Core_TypingStrategy)] -> [[Maybe MetaVariableTable]] -> ([(b, [String])], [Maybe MetaVariableTable], ConstraintSet, Assumptions, Int, IO ()) match1' = generalMatch noMatch matchConverter1 noMetaVariableInfo 0 match2' :: (n -> Maybe (a, b)) -> [(n, [String])] -> [((n, [String]), Core_TypingStrategy)] -> [[Maybe MetaVariableTable]] -> (([(a, [String])], [(b, [String])]), [Maybe MetaVariableTable], ConstraintSet, Assumptions, Int, IO ()) match2' = generalMatch noMatch matchConverter2 noMetaVariableInfo 0 matchOnlyVariable :: MetaVariableInfo -> [(Expression, [String])] -> [Maybe MetaVariableTable] matchOnlyVariable infoTuple tryPats = let ((),matches,_,_,_,_) = match0 infoTuple 0 noMatch tryPats [] [] in matches noMatch :: a -> Maybe b noMatch = const Nothing noMetaVariableInfo :: a noMetaVariableInfo = internalError "PatternMatching.ag" "noMetaVariableInfo" "" generalMatch :: (nonTerminal -> Maybe String) -> ([([String], childrenTuple)] -> childrenResult) -> MetaVariableInfo -> Int -> (nonTerminal -> Maybe childrenTuple) -> [(nonTerminal, [String])] -> [((nonTerminal, [String]), Core_TypingStrategy)] -> [[Maybe MetaVariableTable]] -> ( childrenResult , [Maybe MetaVariableTable] , ConstraintSet , Assumptions , Int , IO () ) generalMatch exprVarMatcher converter metaInfo unique matcher tryPats allPats childrenResults = let match (expr,metas) = case exprVarMatcher expr of Just s | s `elem` metas -> MetaVariableMatch s _ -> case matcher expr of Just x -> NonTerminalMatch (metas,x) Nothing -> NoMatch (allPatterns, allStrategies) = unzip allPats matchListTry = map match tryPats matchListNew = map match allPatterns matchNTTry = [ x | NonTerminalMatch x <- matchListTry ] matchNTNew = [ x | NonTerminalMatch x <- matchListNew ] forChildren = converter (matchNTTry ++ matchNTNew) numberOfTry = length matchNTTry (resultTry,resultNew) = unzip . map (splitAt numberOfTry) $ if null childrenResults then [repeat (Just [])] else childrenResults inspectMatch m (res, nts) = case m of NoMatch -> (Nothing:res, nts) NonTerminalMatch _ -> (allMatch (head nts):res, tail nts) MetaVariableMatch s -> (Just [(s, metaInfo)]:res, nts) -- !!! result = fst (foldr inspectMatch ([],reverse $ transpose resultTry) matchListTry) complete = let (list,_) = foldr inspectMatch ([],reverse $ transpose resultNew) matchListNew in [ (x, y) | (Just x, y) <- zip list allStrategies ] (assumptions, constraintSet, debugIO, newUnique) = case complete of [] -> (getAssumptions metaInfo, getConstraintSet metaInfo, return (), unique) (childrenInfo, typingStrategy):_ -> applyTypingStrategy typingStrategy metaInfo childrenInfo unique in (forChildren, result, constraintSet, assumptions, newUnique, debugIO) } -- prevent ag-warnings SEM RecordExpressionBinding | RecordExpressionBinding loc . (allPatterns,tryPatterns,matchIO,uniqueSecondRound) = internalError "TS_PatternMatching.ag" "n/a" "RecordExpressionBinding is not supported" SEM Expression | RecordConstruction loc . matches = internalError "TS_PatternMatching.ag" "n/a" "RecordConstruction is not supported"