diff --git a/src/Bang/AST/Declaration.hs b/src/Bang/AST/Declaration.hs index 4384670..a2035e5 100644 --- a/src/Bang/AST/Declaration.hs +++ b/src/Bang/AST/Declaration.hs @@ -32,6 +32,7 @@ import Data.Text.Lazy(Text) import Control.Lens(Lens', view, set, lens) import Control.Lens(makeLenses) import Text.PrettyPrint.Annotated(Doc, text, (<+>), ($+$), empty) +import Text.PrettyPrint.Annotated(braces, punctuate, comma, hsep) data TypeDeclaration = TypeDeclaration { _tdName :: Name @@ -69,8 +70,13 @@ class MkValueDecl a where mkValueDecl :: Name -> Location -> Expression -> a ppValueDeclaration :: ValueDeclaration -> Doc a -ppValueDeclaration vd = typedecl $+$ valuedecl +ppValueDeclaration vd = frees $+$ typedecl $+$ valuedecl where + frees = + text "free type variables: " <+> + braces (hsep (punctuate comma (map ppName (_vdFreeTypeVariables vd)))) $+$ + text "free value variables: " <+> + braces (hsep (punctuate comma (map ppName (_vdFreeValueVariables vd)))) typedecl | Just dt <- _vdDeclaredType vd = ppTypeDeclaration (TypeDeclaration (_vdName vd) (_vdLocation vd) dt) diff --git a/src/Bang/AST/Expression.hs b/src/Bang/AST/Expression.hs index 39b980f..66a5665 100644 --- a/src/Bang/AST/Expression.hs +++ b/src/Bang/AST/Expression.hs @@ -28,6 +28,7 @@ module Bang.AST.Expression import Bang.Syntax.Location(Location) import Bang.AST.Name(Name, ppName) +import Bang.Utils.FreeVars(CanHaveFreeVars(..)) import Bang.Utils.Pretty(text') import Control.Lens.TH(makeLenses) import Data.Text.Lazy(Text) @@ -68,6 +69,9 @@ instance MkConstExp ConstantExpression where instance MkConstExp Expression where mkConstExp l v = ConstExp (mkConstExp l v) +instance CanHaveFreeVars ConstantExpression where + freeVariables _ = [] + ppConstantExpression :: ConstantExpression -> Doc a ppConstantExpression = ppConstantValue . _constValue @@ -91,6 +95,9 @@ instance MkRefExp ReferenceExpression where instance MkRefExp Expression where mkRefExp l n = RefExp (ReferenceExpression l n) +instance CanHaveFreeVars ReferenceExpression where + freeVariables r = [_refName r] + -- ----------------------------------------------------------------------------- data LambdaExpression = LambdaExpression @@ -114,6 +121,10 @@ instance MkLambdaExp LambdaExpression where instance MkLambdaExp Expression where mkLambdaExp l a b = LambdaExp (LambdaExpression l a b) +instance CanHaveFreeVars LambdaExpression where + freeVariables l = filter (\ x -> not (x `elem` (_lambdaArgumentNames l))) + (freeVariables (_lambdaBody l)) + -- ----------------------------------------------------------------------------- data Expression = ConstExp ConstantExpression @@ -121,6 +132,11 @@ data Expression = ConstExp ConstantExpression | LambdaExp LambdaExpression deriving (Show) +instance CanHaveFreeVars Expression where + freeVariables (ConstExp e) = freeVariables e + freeVariables (RefExp e) = freeVariables e + freeVariables (LambdaExp e) = freeVariables e + ppExpression :: Expression -> Doc a ppExpression (ConstExp e) = ppConstantExpression e ppExpression (RefExp e) = ppReferenceExpression e diff --git a/src/Bang/AST/Type.hs b/src/Bang/AST/Type.hs index 5ff3c62..de59f8c 100644 --- a/src/Bang/AST/Type.hs +++ b/src/Bang/AST/Type.hs @@ -33,7 +33,9 @@ module Bang.AST.Type import Bang.AST.Name(Name, ppName) import Bang.Syntax.Location(Location) +import Bang.Utils.FreeVars(CanHaveFreeVars(..)) import Control.Lens.TH(makeLenses) +import Data.List(foldl', union) import Text.PrettyPrint.Annotated(Doc, (<+>), (<>), text, hsep) data Kind = Star @@ -57,6 +59,9 @@ data UnitType = UnitType instance Kinded UnitType where kind _ = Star +instance CanHaveFreeVars UnitType where + freeVariables _ = [] + ppUnitType :: UnitType -> Doc a ppUnitType _ = text "()" @@ -80,6 +85,9 @@ instance MkPrimType PrimitiveType where instance MkPrimType Type where mkPrimType l n = TypePrim (PrimitiveType l n) +instance CanHaveFreeVars PrimitiveType where + freeVariables _ = [] + ppPrimitiveType :: PrimitiveType -> Doc a ppPrimitiveType pt = text "llvm:" <> ppName (_ptName pt) @@ -107,6 +115,9 @@ instance MkTypeRef ReferenceType where instance MkTypeRef Type where mkTypeRef l k n = TypeRef (ReferenceType l k n) +instance CanHaveFreeVars ReferenceType where + freeVariables r = [_rtName r] + -- ----------------------------------------------------------------------------- data FunctionType = FunctionType @@ -134,6 +145,11 @@ ppFunctionType ft = instance Kinded FunctionType where kind = _ftKind +instance CanHaveFreeVars FunctionType where + freeVariables ft = foldl' (\ acc x -> acc `union` freeVariables x) + (freeVariables (_ftResultType ft)) + (_ftArgumentTypes ft) + -- ----------------------------------------------------------------------------- data TypeApplication = TypeApplication @@ -160,6 +176,10 @@ ppTypeApplication :: TypeApplication -> Doc a ppTypeApplication ta = ppType (_taLeftType ta) <+> ppType (_taRightType ta) +instance CanHaveFreeVars TypeApplication where + freeVariables ta = freeVariables (_taLeftType ta) `union` + freeVariables (_taRightType ta) + -- ----------------------------------------------------------------------------- data Type = TypeUnit UnitType @@ -183,6 +203,13 @@ instance Kinded Type where kind (TypeFun x) = kind x kind (TypeApp x) = kind x +instance CanHaveFreeVars Type where + freeVariables (TypeUnit t) = freeVariables t + freeVariables (TypePrim t) = freeVariables t + freeVariables (TypeRef t) = freeVariables t + freeVariables (TypeFun t) = freeVariables t + freeVariables (TypeApp t) = freeVariables t + makeLenses ''PrimitiveType makeLenses ''ReferenceType makeLenses ''FunctionType diff --git a/src/Bang/Syntax/PostProcess.hs b/src/Bang/Syntax/PostProcess.hs index 4511a0b..85d9210 100644 --- a/src/Bang/Syntax/PostProcess.hs +++ b/src/Bang/Syntax/PostProcess.hs @@ -7,11 +7,14 @@ import Bang.AST(Name, Module, moduleDeclarations, ppName) import Bang.AST.Declaration(Declaration(..), declName, TypeDeclaration, ValueDeclaration, tdName, tdLocation, tdType, - vdName, vdLocation, vdDeclaredType) + vdName, vdLocation, vdDeclaredType, + vdFreeTypeVariables, + vdValue, vdFreeValueVariables) import Bang.Monad(Compiler, BangError(..), err) import Bang.Syntax.Location(Location, ppLocation) +import Bang.Utils.FreeVars(CanHaveFreeVars(..)) import Bang.Utils.Pretty(BangDoc) -import Control.Lens(view, set) +import Control.Lens(view, set, over) import Control.Monad(foldM) import Data.Map.Strict(Map) import qualified Data.Map.Strict as Map @@ -41,7 +44,7 @@ runPostProcessor :: Module -> Compiler ps Module runPostProcessor mdl = do declTable <- makeDeclarationTable mdl mdl' <- combineTypeValueDeclarations declTable mdl - return mdl' + return (addFreeVarsToDecls mdl') -- ----------------------------------------------------------------------------- @@ -102,4 +105,18 @@ combineTypeValueDeclarations table m = (x:) `fmap` process rest Just (Just td, _) -> do let vd' = set vdDeclaredType (Just (view tdType td)) vd - (DeclVal vd' :) `fmap` process rest + (DeclVal vd' :) `fmap` process rest + +-- ----------------------------------------------------------------------------- + +addFreeVarsToDecls :: Module -> Module +addFreeVarsToDecls = over moduleDeclarations (map process) + where + process (DeclVal vd) = + let dtype = view vdDeclaredType vd + dval = view vdValue vd + in DeclVal (set vdFreeTypeVariables (freeVariables dtype) $ + set vdFreeValueVariables (freeVariables dval) vd) + process x = x + + diff --git a/src/Bang/Utils/FreeVars.hs b/src/Bang/Utils/FreeVars.hs new file mode 100644 index 0000000..632cfc6 --- /dev/null +++ b/src/Bang/Utils/FreeVars.hs @@ -0,0 +1,13 @@ +module Bang.Utils.FreeVars( + CanHaveFreeVars(..) + ) + where + +import Bang.AST.Name(Name) + +class CanHaveFreeVars a where + freeVariables :: a -> [Name] + +instance CanHaveFreeVars a => CanHaveFreeVars (Maybe a) where + freeVariables (Just x) = freeVariables x + freeVariables Nothing = []