helium-1.8: src/Helium/StaticAnalysis/StaticChecks/Collect.ag
-----------------------------------------------------------------------------
-- |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