Add free variable analysis.

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)

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

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

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
+
+

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  = []