-----------------------------------------------------------------------------
-- |The Helium Compiler : Static Analysis
-- 
-- Maintainer  :  bastiaan@cs.uu.nl
-- Stability   :  experimental
-- Portability :  unknown
--
-- Collect the following information:
-- 
--    1) type constructors from a data type
--    2) type synonyms
--    3) (value) constructors from a data type
--    4) fixity declarations
--
-- Distribute the collected environments 
--    5) value constructors
--    6) type constructors
--    7) type synonyms
-------------------------------------------------------------------------------

SEM Module
  | Module   loc . collectEnvironment = setValueConstructors   (M.fromList @body.collectValueConstructors)
                                        . setTypeConstructors  (M.fromList @body.collectTypeConstructors)
                                        . setTypeSynonyms      (M.fromList @body.collectTypeSynonyms)          
                                        . setOperatorTable     (M.fromList @body.operatorFixities)
                                        . addToTypeEnvironment (M.fromList @derivedFunctions)
                                        -- . setClassEnvironment  @derivedInstances
                                        $ emptyEnvironment 
                                        -- the type environment will be added after type inferencing.
                 . derivedFunctions = let f (n,i) = ( nameOfShowFunction n
                                                    , typeOfShowFunction n (take i [ nameFromString s | s <- variableList])
                                                    )
                                          g (n,(i,_)) = f (n,i)
                                      in map f @body.collectTypeConstructors ++
                                         map g @body.collectTypeSynonyms

{-                 
                 . derivedInstances = let f (n,i) = makeInstance "Show" i (show n)
                                          g (n,(i,_)) = f (n,i)
                                      in unitFM "Show"
                                            ( []
                                            , map f @body.collectTypeConstructors ++
                                              map g @body.collectTypeSynonyms
                                            )
                 
-}                 

-------------------------------------------
-- 1) Collecting (data-)type constructors

ATTR Body Declarations Declaration [ | collectTypeConstructors : {[(Name,Int)]} | ]

SEM Module | Module   body . collectTypeConstructors = []

SEM Declaration
  | Data   lhs . collectTypeConstructors = (@simpletype.name,length @simpletype.typevariables) : @lhs.collectTypeConstructors

-------------------------------------------
-- 2) Collecting value constructors

ATTR Body Declarations Declaration Constructors Constructor [ | collectValueConstructors : {[(Name,TpScheme)]} | ]
ATTR Constructor Constructors [ | | parameterTypes USE { ++ } { [] } : Tps ]

SEM Module | Module   body . collectValueConstructors = []

SEM Constructor
  | Constructor
       lhs . collectValueConstructors = (@constructor.self, @typeScheme) : @lhs.collectValueConstructors
           . parameterTypes = @tps
       loc . typeScheme = generalizeAll ([] .=>. foldr (.->.) @tp @tps)
           . (tp,tps)   = convertFromSimpleTypeAndTypes @lhs.simpletype @types.types
                  
  | Infix
       lhs . collectValueConstructors = (@constructorOperator.self, @typeScheme) : @lhs.collectValueConstructors
           . parameterTypes = @tps
       loc . typeScheme = generalizeAll ([] .=>. foldr (.->.) @tp @tps)
           . (tp,tps)   = convertFromSimpleTypeAndTypes @lhs.simpletype [@leftType.type,@rightType.type] 

-------------------------------------------
-- 3) Collecting type synonyms

ATTR Body Declarations Declaration [ | collectTypeSynonyms : {[(Name,(Int,Tps -> Tp))]} | ]
           
SEM Module | Module   body . collectTypeSynonyms = []                   

SEM Declaration
  | Type   lhs . collectTypeSynonyms = (@simpletype.name, @typeSynonymInfo) : @lhs.collectTypeSynonyms
           loc . typeSynonymInfo = (length @simpletype.typevariables,\tps -> makeTpFromType (zip @simpletype.typevariables tps) @type.self)
           
-------------------------------------------
-- 4) Collecting Fixity Declarations

ATTR Body Declarations Declaration [ | operatorFixities : {[(Name,(Int,Assoc))]} | ]

SEM Module | Module   body . operatorFixities = [] 

SEM Declaration
  | Fixity   lhs . operatorFixities = let associativity = case @fixity.self of
                                                             Fixity_Infix _  -> AssocNone
                                                             Fixity_Infixl _ -> AssocLeft
                                                             Fixity_Infixr _ -> AssocRight
                                          priority      = case @priority.self of
                                                             MaybeInt_Just i  -> i
                                                             MaybeInt_Nothing -> 9
                                      in [ (name, (priority, associativity)) | name <- @operators.self ] ++ @lhs.operatorFixities

-------------------------------------------
-- 5) Distributing Value Constructors

SEM Module
  | Module   loc . (uniqueValueConstructors,duplicatedValueConstructors) = 
                      uniqueKeys (  @body.collectValueConstructors 
                                 ++ concatMap (M.assocs . valueConstructors) @lhs.importEnvironments
                                 )
                 . allValueConstructors = map fst @uniqueValueConstructors ++ map head @duplicatedValueConstructors
                 . valueConstructors    = M.fromList @uniqueValueConstructors

ATTR Body Declarations Declaration Expressions Expression Patterns Pattern 
     Statement Statements Qualifier Qualifiers
     Alternative Alternatives Constructor Constructors
     GuardedExpressions GuardedExpression FunctionBinding FunctionBindings
     LeftHandSide RightHandSide MaybeDeclarations MaybeExpression AnnotatedType AnnotatedTypes
     [ valueConstructors : {M.Map Name TpScheme} allValueConstructors : Names | | ]

-------------------------------------------
-- 6) Distributing Type Constructors

SEM Module
  | Module loc . (uniqueTypeConstructors,duplicatedTypeConstructors) =
                    uniqueKeys (  @body.collectTypeConstructors
                               ++ concatMap (M.assocs . typeConstructors) @lhs.importEnvironments
                               ++ [ (n,i) | (n,(i,_)) <- @body.collectTypeSynonyms ]
                               )
               . allTypeConstructors = map fst @uniqueTypeConstructors ++ map head @duplicatedTypeConstructors
               . typeConstructors    = M.fromList @uniqueTypeConstructors

ATTR Body Declarations Declaration Expressions Expression Patterns Pattern    
     Statement Statements Qualifier Qualifiers 
     Alternative Alternatives Constructor Constructors
     GuardedExpressions GuardedExpression FunctionBinding FunctionBindings     
     LeftHandSide RightHandSide MaybeDeclarations MaybeExpression 
     Type Types AnnotatedType AnnotatedTypes ContextItem ContextItems
     [ typeConstructors : {M.Map Name Int} allTypeConstructors : Names | | ]

-------------------------------------------
-- 7) Distributing Type Synonyms

ATTR Module -> Declaration [ orderedTypeSynonyms:OrderedTypeSynonyms | | ]

SEM Module
  | Module body . orderedTypeSynonyms =
                      let list     = concatMap (M.assocs . typeSynonyms) @lhs.importEnvironments ++
                                     @body.collectTypeSynonyms
                          newmap   = M.fromList [ (show name, t) | (name, t) <- list ]
                          ordering = fst (getTypeSynonymOrdering newmap)
                      in (ordering, newmap)

--------------------------------
-- Derived instances (see also TypeInferenceCollect.ag)

ATTR Module -> Declaration [ classEnvironment:ClassEnvironment | | collectInstances USE { ++ } { [] } : {[(Name, Instance)]} ]

SEM Module
  | Module
       body.classEnvironment = 
          let importEnv = foldr combineImportEnvironments emptyEnvironment @lhs.importEnvironments
          in foldr (\(n, i) -> insertInstance (show n) i) 
                   (createClassEnvironment importEnv) 
                   @body.collectInstances

SEM Declaration
  | Data
       lhs . collectInstances = [ (cl, makeInstance (show cl) (length @simpletype.typevariables) (show @simpletype.name) ) 
                                | cl <- @derivings.self 
                                ]


-------------------------------------------------------
-- utility attributes for types and constructors

ATTR SimpleType [ | | name:Name typevariables:Names ]

SEM SimpleType
  | SimpleType  lhs . name          = @name.self                   
                    . typevariables = @typevariables.self

ATTR Type Types AnnotatedTypes AnnotatedType Constructors Constructor [ | | typevariables USE { ++ } { [] } : Names ]

SEM Type
  | Variable  lhs . typevariables = [ @name.self ]

ATTR Constructors Constructor [ simpletype:SimpleType | | ]

SEM Declaration
  | Data     constructors . simpletype = @simpletype.self
  | Newtype  constructor  . simpletype = @simpletype.self

ATTR AnnotatedTypes [ | | types : Types ]
ATTR AnnotatedType  [ | | type  : Type  ]

SEM AnnotatedTypes
  | Cons   lhs . types = @hd.type : @tl.types
  | Nil    lhs . types = []
   
SEM AnnotatedType
  | AnnotatedType  lhs . type = @type.self 

{
uniqueKeys :: Ord key => [(key,a)] -> ([(key,a)],[[key]])
uniqueKeys = let comp (x,_) (y,_) = compare x y
                 eq   (x,_) (y,_) = x == y
                 predicate xs = length xs == 1 
             in (\(xs, ys) -> (map head xs, map (map fst) ys)) 
              . partition predicate 
              . groupBy eq 
              . sortBy comp
}

-------------------------------------------
-- Collecting Type Signatures

ATTR Declaration Declarations [ | typeSignatures:{[(Name,TpScheme)]} | ]
ATTR Body                     [ | | typeSignatures:{[(Name,TpScheme)]} ]

SEM Body              
  | Hole lhs . typeSignatures = []
  | Body    declarations . typeSignatures = []
SEM Expression        | Let     declarations . typeSignatures = []
SEM Statement         | Let     declarations . typeSignatures = []
SEM Qualifier         | Let     declarations . typeSignatures = []
SEM MaybeDeclarations | Just    declarations . typeSignatures = []

SEM Declaration
  | TypeSignature
      lhs . typeSignatures = [ (name, @typeScheme) | name <- @names.self ] ++ @lhs.typeSignatures
      loc . (typeScheme, intMap) = makeTpSchemeFromType' @type.self