-----------------------------------------------------------------------------
-- |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 List
import Matchers
import TS_Apply (applyTypingStrategy, matchInformation)
import TS_CoreSyntax
import 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 
                    []
           
  | 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            
  | 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 insert (metas,(a,b)) (as,bs) = ((a,metas):as,(b,metas):bs)
                  in foldr insert ([],[])                  

matchConverter3 :: [([String],(a,b,c))] -> ([(a,[String])],[(b,[String])],[(c,[String])])
matchConverter3 = let insert (metas,(a,b,c)) (as,bs,cs) = ((a,metas):as,(b,metas):bs,(c,metas):cs)
                  in foldr insert ([],[],[]) 

allMatch :: [Maybe [a]] -> Maybe [a]
allMatch = rec []
  where rec xs []             = Just xs
        rec xs (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 a) = "NonTerminal ??"
  show (MetaVariableMatch s) = "MetaVariableMatch "++show s

expressionVariableMatcher :: Expression -> Maybe String
expressionVariableMatcher expr =
   case expr of
      Expression_Variable _ name -> Just (show name)
      _                          -> Nothing

match0 = generalMatch expressionVariableMatcher matchConverter0
match1 = generalMatch expressionVariableMatcher matchConverter1
match2 = generalMatch expressionVariableMatcher matchConverter2
match3 = generalMatch expressionVariableMatcher matchConverter3

match0' = generalMatch noMatch matchConverter0 noMetaVariableInfo 0
match1' = generalMatch noMatch matchConverter1 noMetaVariableInfo 0
match2' = generalMatch noMatch matchConverter2 noMetaVariableInfo 0

matchOnlyVariable infoTuple tryPats = 
       let ((),matches,_,_,_,_) = match0 infoTuple 0 noMatch tryPats [] []
   in matches

noMatch :: a -> Maybe b
noMatch = const Nothing

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"
