-----------------------------------------------------------------------------
-- |The Helium Compiler : Static Analysis
-- 
-- Maintainer  :  bastiaan@cs.uu.nl
-- Stability   :  experimental
-- Portability :  unknown
--
-- All variables (of type Name) are determined that are in 
--    scope (for each location in the abstract syntax tree)
-- 
-- Variables can be added to the scope by three ways: 
--
--   1) externally defefined, imported, or primitive
--           Module.Module
--
--   2) introduced in a binding-group (nodes with "Declarations")
--            Body.Body
--            MaybeDeclarations.Just
--            Expression.Let
--            Statement.Let
--            Qualifier.Let
--
--   3) introduced in a pattern that is not part of a binding-group; these
--         variables are automatically monomorphic. (nodes with "Pattern"
--         or "Patterns") 
--            FunctionBinding.FunctionBinding
--            Expression.Lambda
--            Alternative.Alternative
--            Statement.Generator
--            Qualifier.Generator
--
-- The scope simply follows the shape of the abstract syntax tree, except for
-- Statements, Qualifiers en RightHandSide (where).
--
-------------------------------------------------------------------------------

ATTR Expression RightHandSide
     RecordExpressionBinding RecordExpressionBindings
     MaybeExpression GuardedExpression FunctionBinding
     Expressions Declaration Declarations Alternative FunctionBindings
     Alternatives GuardedExpressions RecordPatternBinding
     Patterns Pattern LeftHandSide RecordPatternBindings AnnotatedType
     AnnotatedTypes Constructor Constructors FieldDeclaration FieldDeclarations Body
     [ namesInScope : Names | counter : Int | unboundNames USE {++} {[]} : Names ]

SEM Module
  | Module   loc . (namesInScope, unboundNames, scopeInfo) = changeOfScope (@initialScope ++ @body.declVarNames) @body.unboundNames []
             body . counter = 0
                 
SEM MaybeDeclarations
  | Just   loc . (namesInScope, unboundNames, scopeInfo)   = changeOfScope @declarations.declVarNames (@declarations.unboundNames ++ @lhs.unboundNames) @lhs.namesInScope
           lhs . unboundNames = @unboundNames -- not a copy-rule for my ag-compiler!
           
SEM Expression
  | Let    loc . (namesInScope, unboundNames, scopeInfo) = changeOfScope @declarations.declVarNames (@declarations.unboundNames ++ @expression.unboundNames) @lhs.namesInScope
           lhs . unboundNames = @unboundNames -- not a copy-rule for my ag-compiler!
           
SEM Statement
  | Let    loc . (namesInScope, unboundNames, scopeInfo) = changeOfScope @declarations.declVarNames (@declarations.unboundNames ++ @lhs.unboundNames) @lhs.namesInScope
           
SEM Qualifier
  | Let    loc . (namesInScope, unboundNames, scopeInfo) = changeOfScope @declarations.declVarNames (@declarations.unboundNames ++ @lhs.unboundNames) @lhs.namesInScope
           
-- monomorphic binding constructs

SEM FunctionBinding
  | FunctionBinding   loc . (namesInScope, unboundNames, scopeInfo) = changeOfScope @lefthandside.patVarNames @righthandside.unboundNames @lhs.namesInScope
                      lhs . unboundNames = @unboundNames -- not a copy-rule for my ag-compiler!
                      
SEM Expression
  | Lambda            loc . (namesInScope, unboundNames, scopeInfo) = changeOfScope @patterns.patVarNames @expression.unboundNames @lhs.namesInScope
                      lhs . unboundNames = @unboundNames -- not a copy-rule for my ag-compiler!
  -- | Hole              lhs . namesInScope = @namesInScope


SEM Alternative
  | Alternative       loc . (namesInScope, unboundNames, scopeInfo) = changeOfScope @pattern.patVarNames @righthandside.unboundNames @lhs.namesInScope
                      lhs . unboundNames = @unboundNames -- not a copy-rule for my ag-compiler!
                      
SEM Statement
  | Generator         loc . (namesInScope, unboundNames, scopeInfo) = changeOfScope @pattern.patVarNames (@expression.unboundNames ++ @lhs.unboundNames) @lhs.namesInScope

SEM Qualifier
  | Generator         loc . (namesInScope, unboundNames, scopeInfo) = changeOfScope @pattern.patVarNames (@expression.unboundNames  ++ @lhs.unboundNames)  @lhs.namesInScope
                      
-- correct scope for RightHandSides (where)

ATTR MaybeDeclarations [ | counter : Int unboundNames : Names namesInScope : Names | ]

SEM RightHandSide 
  | Expression   lhs                . unboundNames = @where.unboundNames
                 expression         . namesInScope = @where.namesInScope
                 where              . unboundNames = @expression.unboundNames
  | Guarded      lhs                . unboundNames = @where.unboundNames
                 guardedexpressions . namesInScope = @where.namesInScope 
                 where              . unboundNames = @guardedexpressions.unboundNames

-- correct scope for Statements/Qualifiers

ATTR Statements Statement Qualifier Qualifiers [ | counter : Int namesInScope : Names unboundNames : Names | ]

SEM Expression
  | Do  statements . unboundNames = []

SEM Statement
  | Generator   lhs        . namesInScope = @namesInScope
                           . unboundNames = @unboundNames
                expression . namesInScope = @lhs.namesInScope
  | Let         lhs        . unboundNames = @unboundNames                
  | Expression  lhs        . unboundNames = @expression.unboundNames ++ @lhs.unboundNames                 

SEM Statements
  | Cons   lhs . unboundNames = @hd.unboundNames
           tl  . unboundNames = @lhs.unboundNames
           hd  . unboundNames = @tl.unboundNames
  | Nil    lhs . unboundNames = @lhs.unboundNames
  
SEM Expression
  | Comprehension    lhs        . unboundNames = @qualifiers.unboundNames
                     expression . namesInScope = @qualifiers.namesInScope
                     qualifiers . namesInScope = @lhs.namesInScope
                                . unboundNames = @expression.unboundNames

SEM Qualifier
  | Generator   lhs        . namesInScope = @namesInScope
                           . unboundNames = @unboundNames
                expression . namesInScope = @lhs.namesInScope
  | Let         lhs        . unboundNames = @unboundNames                
  | Guard       lhs        . unboundNames = @guard.unboundNames ++ @lhs.unboundNames  

SEM Qualifiers
  | Cons   lhs . unboundNames = @hd.unboundNames
           tl  . unboundNames = @lhs.unboundNames
           hd  . unboundNames = @tl.unboundNames
  | Nil    lhs . unboundNames = @lhs.unboundNames

-------------------------------------------------------------------------------------

ATTR Pattern Patterns 
     LeftHandSide [ | | patVarNames USE {++} {[]} : Names ]

SEM Pattern 
  | Variable   lhs . patVarNames = [ @name.self ]
  | As         lhs . patVarNames = @name.self : @pattern.patVarNames
  | Hole       lhs . patVarNames = [ Name_Special noRange [] ("hole" ++ show @loc.i) ]
               loc . i : UNIQUEREF counter

SEM Expression 
  | Variable   lhs . unboundNames = [ @name.self ]    

ATTR Body Declaration Declarations [ | | declVarNames USE {++} {[]} : Names ]

SEM Declaration 
  | FunctionBindings  lhs . declVarNames = [@bindings.name]
  | PatternBinding    lhs . declVarNames = @pattern.patVarNames

-- utility function
{                  
type ScopeInfo = ( [Names]          -- duplicated variables
                 , [Name]           -- unused variables
                 , [(Name, Name)]   -- shadowed variables
                 )

changeOfScope :: Names -> Names -> Names -> (Names, Names, ScopeInfo)
changeOfScope names unboundNames namesInScope = 
   let (uniqueNames, duplicatedNames) = uniqueAppearance names
       unusedNames   = uniqueNames \\ unboundNames
       shadowedNames = let f n = [ (n, n') | n' <- namesInScope, n == n' ]
                       in concatMap f uniqueNames
   in ( uniqueNames ++ map head duplicatedNames ++ (namesInScope \\ names)
      , unboundNames \\ names
      , (duplicatedNames, unusedNames, shadowedNames)
      )
      
uniqueAppearance :: Ord a => [a] -> ([a],[[a]])
uniqueAppearance = Prelude.foldr myInsert ([],[]) . group . sort
   where myInsert [x] (as,bs) = (x:as,bs)
         myInsert xs  (as,bs) = (as,xs:bs)
       
nextUnique :: Num a => a -> (a, a)         
nextUnique n = (n+1, n)
}