Get name linking right again, through post-processing.

src/Bang/AST/Expression.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Bang.AST.Expression
-       ( Expression
+       ( Expression(..)
        , ppExpression
        -- * Constant Expressions
        , ConstantExpression

src/Bang/Monad.hs

@@ -10,13 +10,13 @@ module Bang.Monad(
        , runCompiler
        , runPass
        , getPassState, setPassState, overPassState, viewPassState
-       , registerNewName, genName, genTypeRef, genVarRef
+       , registerName, registerNewName, genName, genTypeRef, genVarRef
-       , warn, err
+       , warn, err, err'
        )
  where
 
 import           Bang.AST.Expression(Expression, mkRefExp)
-import           Bang.AST.Name(NameEnvironment(..), Name, mkName)
+import           Bang.AST.Name(NameEnvironment(..), Name, mkName, nameIndex)
 import           Bang.AST.Type(Kind(..), Type, mkTypeRef)
 import           Bang.CommandLine(BangCommand, CommandsWithInputFile(..))
 import           Bang.Error(exit)
@@ -26,7 +26,7 @@ import           Bang.Utils.Pretty(BangDoc)
 import           Control.Exception(tryJust)
 import           Control.Lens(Lens', over, set, view)
 import           Control.Lens.TH(makeLenses)
-import           Control.Monad(guard)
+import           Control.Monad(guard, when)
 import           Data.Text.Lazy(Text, pack)
 import qualified Data.Text.Lazy.IO as T
 import           System.Exit(ExitCode(..), exitWith)
@@ -107,6 +107,12 @@ viewPassState l = Compiler (\ st -> return (st, view (csPassState . l) st))
 
 -- -----------------------------------------------------------------------------
 
+registerName :: Name -> Compiler s Name
+registerName name =
+  Compiler (\ st ->
+             do let current = view csNextIdent st
+                return (over csNextIdent (+1) st, set nameIndex current name))
+
 registerNewName :: NameEnvironment -> Text -> Compiler s Name
 registerNewName env name =
   Compiler (\ st ->
@@ -141,19 +147,22 @@ instance BangWarning w => BangError (WErrorWarning w) where
 warn :: BangWarning w => w -> Compiler s ()
 warn w = Compiler (\ st ->
                      if view csPromoteWarnings st
-                        then runError (WErrorWarning w)
+                        then runError (WErrorWarning w) False >> return (st, ())
                         else runWarning w >> return (st, ()))
 
 err :: BangError w => w -> Compiler s a
-err w = Compiler (\ _ -> runError w)
+err w = Compiler (\ _ -> runError w True >> undefined)
+
+err' :: BangError e => e -> Compiler s ()
+err' e = Compiler (\ st -> runError e False >> return (st, ()))
 
 runWarning :: BangWarning w => w -> IO ()
 runWarning = undefined
 
-runError :: BangError w => w -> IO a
+runError :: BangError w => w -> Bool -> IO ()
-runError e =
+runError e die =
   do putStrLn (go (ppError e))
-     exitWith (ExitFailure 1)
+     when die $ exitWith (ExitFailure 1)
  where
    go (Nothing, doc) = render doc
    go (Just a, doc) = render (ppLocation a $+$ nest 3 doc)

src/Bang/Syntax/Parser.y

@@ -11,15 +11,13 @@ module Bang.Syntax.Parser(
  where
 
 import Bang.Monad(err)
-import Bang.AST(Name, Module, NameEnvironment(..), mkModule, emptyExpression)
+import Bang.AST(Name, Module, NameEnvironment(..), mkModule, mkName, emptyExpression)
 import Bang.AST.Declaration(Declaration, mkTypeDecl, mkValueDecl)
 import Bang.AST.Expression(ConstantValue(..), Expression, mkConstExp, mkRefExp, mkLambdaExp)
 import Bang.AST.Type(Type, Kind(..), mkTypeRef, mkFunType, mkTypeApp, mkPrimType)
 import Bang.Syntax.Location(Located(..), Origin, Position)
 import Bang.Syntax.ParserError(ParserError(..))
-import Bang.Syntax.ParserMonad(Parser, addFixities, registerName,
+import Bang.Syntax.ParserMonad(Parser, addFixities, parseError, runNextToken, runParser)
-                               unregisterNames, lookupName, parseError,
-                               runNextToken, runParser)
 import Bang.Syntax.Token(Token(..), Fixity(..))
 import Control.Monad(forM)
 import Data.List(union)
@@ -119,8 +117,7 @@ top_module :: { Module }
   : 'module' TypeIdent listopt(Declaration)
     {%
        do let Located src (TypeIdent rawName) = $2
-          name <- registerName False src ModuleEnv rawName
+          return (mkModule (mkName rawName ModuleEnv src 0) [$3]) }
-          return (mkModule name [$3]) }
 
 Declaration :: { Maybe Declaration }
   : ValueDeclaration  { Just $1 }
@@ -128,28 +125,21 @@ Declaration :: { Maybe Declaration }
   | TypeDeclaration   { Just $1 }
 
 ValueDeclaration :: { Declaration }
-  : ValueDeclLHS Expression
+  : list1(ValIdent) '=' Expression
-    {%
-        do let (builder, argNames) = $1
-           unregisterNames VarEnv argNames
-           return (builder $2)
-    }
-
-ValueDeclLHS :: { (Expression -> Declaration, [Name]) }
- : list1(ValIdent) '='
     {%
        case $1 of
          [] ->
             err (InternalError $2 "ValDeclLHS")
          [Located src (ValIdent rawName)] ->
-           do name <- registerName True src VarEnv rawName
+           do let name = mkName rawName VarEnv src 0
-              return (mkValueDecl name src Nothing, [name])
+              return (mkValueDecl name src Nothing $3)
          ((Located src (ValIdent rawName)) : args) ->
-           do name <- registerName True src VarEnv rawName
+           do let name     = mkName rawName VarEnv src 0
-              argNames <- forM args $ \ (Located asrc (ValIdent argName)) ->
+                  argNames = map (\ (Located arsrc (ValIdent argName)) ->
-                            registerName True asrc VarEnv argName
+                                   mkName argName VarEnv arsrc 0)
-              let builder = mkValueDecl name src Nothing . mkLambdaExp $2 argNames
+                                 args
-              return (builder, argNames)
+              return (mkValueDecl name src Nothing
+                       (mkLambdaExp $2 argNames $3))
     }
 
 FixityDeclaration :: { () }
@@ -164,50 +154,38 @@ TypeDeclaration :: { Declaration }
   : ValIdent '::' Type
     {%
        do let Located src (ValIdent rawName) = $1
-          name <- registerName True src VarEnv rawName
+              name = mkName rawName VarEnv src 0
           return (mkValueDecl name src (Just $3) emptyExpression) }
   | 'type' TypeIdent '=' Type
     {%
        do let Located src (TypeIdent rawName) = $2
-          name <- registerName True src TypeEnv rawName
+              name = mkName rawName TypeEnv src 0
           return (mkTypeDecl name src $4) }
   | 'primitive' 'type' TypeIdent '=' String
     {%
        do let Located nsrc (TypeIdent rawName) = $3
               Located tsrc (StringTok rawText) = $5
-          name <- registerName False nsrc TypeEnv rawName
+              name = mkName rawName TypeEnv nsrc 0
           return (mkTypeDecl name $2 (mkPrimType tsrc rawText)) }
 
 -- -----------------------------------------------------------------------------
 
 Type :: { Type }
-  : RawType {%
+  : RawType                      { $1 }
-      do let (result, names) = $1
-         case names of
-           [] -> return result
-           xs ->
-             do unregisterNames TypeEnv xs
-                return result
-      }
 
-RawType :: { (Type, [Name]) }
+RawType :: { Type }
-  : RawType '->' BaseType {%
+  : RawType '->' BaseType        { mkFunType $2 [$1] $3 }
-      do let (p1, names1) = $1
+  | BaseType                     { $1                   }
-             (p2, names2) = $3
-         return (mkFunType $2 [p1] p2, union names1 names2)
-     }
-  | BaseType           { $1 }
 
-BaseType :: { (Type, [Name]) }
+BaseType :: { Type }
   : TypeIdent   {%
-       do let Located src (TypeIdent rawName) = $1
+                  let Located src (TypeIdent rawName) = $1
-          name <- lookupName src TypeEnv rawName
+                      name = mkName rawName TypeEnv src 0
-          return (mkTypeRef src Unknown name, []) }
+                  in return (mkTypeRef src Unknown name) }
   | ValIdent    {%
-       do let Located src (ValIdent rawName) = $1
+                  let Located src (ValIdent rawName) = $1
-          name <- registerName True src TypeEnv rawName
+                      name = mkName rawName TypeEnv src 0
-          return (mkTypeRef src Unknown name, [name])
+                  in return (mkTypeRef src Unknown name) }
-     }
 
 -- -----------------------------------------------------------------------------
 
@@ -216,25 +194,21 @@ Expression :: { Expression }
 
 BaseExpression :: { Expression }
   : OpIdent  {%
-                do let Located src (OpIdent _ rawName) = $1
+               let Located src (OpIdent _ rawName) = $1
-                   name <- lookupName src VarEnv rawName
+                   name = mkName rawName VarEnv src 0
-                   return (mkRefExp src name) }
+               in return (mkRefExp src name) }
   | ValIdent {%
-                do let Located src (ValIdent rawName) = $1
+               let Located src (ValIdent rawName) = $1
-                   name <- lookupName src VarEnv rawName
+                   name = mkName rawName VarEnv src 0
-                   return (mkRefExp src name) }
+               in return (mkRefExp src name) }
-  | Integer  {%
+  | Integer  { let Located src (IntTok base val) = $1
-                do let Located src (IntTok base val) = $1
+               in mkConstExp src (ConstantInt base val) }
-                   return (mkConstExp src (ConstantInt base val)) }
+  | String   { let Located src (StringTok val) = $1
-  | String   {%
+               in mkConstExp src (ConstantString val) }
-                do let Located src (StringTok val) = $1
+  | Float    { let Located src (FloatTok val) = $1
-                   return (mkConstExp src (ConstantString val)) }
+               in mkConstExp src (ConstantFloat val) }
-  | Float    {%
+  | Char     { let Located src (CharTok val) = $1
-                do let Located src (FloatTok val) = $1
+               in mkConstExp src (ConstantChar val) }
-                   return (mkConstExp src (ConstantFloat val)) }
-  | Char     {%
-                do let Located src (CharTok val) = $1
-                   return (mkConstExp src (ConstantChar val)) }
 
 -- -----------------------------------------------------------------------------
 

src/Bang/Syntax/ParserMonad.hs

@@ -5,16 +5,12 @@ module Bang.Syntax.ParserMonad(
        , NameDatabase
        , runParser
        , addFixities
-       , registerName
-       , unregisterNames
-       , lookupName
        , parseError
        , runNextToken
        )
  where
 
-import           Bang.AST.Name(Name, NameEnvironment(..), mkName,
+import           Bang.AST.Name(Name, NameEnvironment(..))
-                               nameLocation, nameText)
 import           Bang.Monad(Compiler, err, runPass,
                             getPassState, overPassState, viewPassState)
 import           Bang.Syntax.Lexer(AlexReturn(..), AlexInput(..), alexScan)
@@ -37,7 +33,6 @@ type NameDatabase = Map (NameEnvironment, Text) Name
 data ParserState = ParserState {
        _psPrecTable    :: Map Text Fixity
      , _psNameDatabase :: Map (NameEnvironment, Text) Name
-     , _psNextIdent    :: Word
      , _psOrigin       :: Origin
      , _psLexerState   :: AlexInput
      }
@@ -51,7 +46,7 @@ runParser origin stream action =
   over _1 (view psNameDatabase) `fmap` runPass pstate action
  where
   initInput = AlexInput initialPosition stream
-  pstate    = ParserState Map.empty Map.empty 1 origin initInput
+  pstate    = ParserState Map.empty Map.empty origin initInput
 
 -- -----------------------------------------------------------------------------
 
@@ -102,38 +97,6 @@ getFixities = viewPassState psPrecTable
 
 -- -----------------------------------------------------------------------------
 
-registerName :: Bool -> Location -> NameEnvironment -> Text -> Parser Name
-registerName redefOk loc env name =
-  do state <- getPassState
-     let key = (env, name)
-     case Map.lookup key (view psNameDatabase state) of
-       Nothing ->
-         do let res = mkName name env loc (view psNextIdent state)
-            overPassState (over psNameDatabase (Map.insert key res) .
-                           over psNextIdent (+1))
-            return res
-       Just res | redefOk ->
-         return res
-       Just name' ->
-         err (RedefinitionError loc (view nameLocation name') name)
-
-unregisterNames :: NameEnvironment -> [Name] -> Parser ()
-unregisterNames env names =
-  do db <- viewPassState psNameDatabase
-     let db' = foldr (\ n m -> Map.delete (env, view nameText n) m) db names
-     overPassState (set psNameDatabase db')
-
-lookupName :: Location -> NameEnvironment -> Text -> Parser Name
-lookupName loc env name =
-  do state <- getPassState
-     case Map.lookup (env, name) (view psNameDatabase state) of
-       Nothing ->
-         err (UnboundVariable loc name)
-       Just realName ->
-         return realName
-
--- -----------------------------------------------------------------------------
-
 runNextToken :: (Located Token -> Parser a) ->
                 Parser a
 runNextToken parseAction = go =<< getLexerState

src/Bang/Syntax/PostProcess.hs

@@ -1,28 +1,36 @@
+{-# LANGUAGE RankNTypes #-}
 module Bang.Syntax.PostProcess(
          runPostProcessor
        )
  where
 
-import           Bang.AST(Name, Module, moduleDeclarations, ppName)
+import           Bang.AST(Name, Module, moduleDeclarations, ppName,
+                          nameText, nameLocation, nameEnvironment)
 import           Bang.AST.Declaration(Declaration(..), declName,
-                                      ValueDeclaration,
+                                      tdName, tdType,
-                                      vdName, vdLocation, vdDeclaredType,
+                                      ValueDeclaration, vdName, vdLocation,
-                                      vdValue)
+                                      vdDeclaredType, vdValue)
-import           Bang.AST.Expression(isEmptyExpression)
+import           Bang.AST.Expression(Expression(..), isEmptyExpression, refName,
-import           Bang.AST.Type(Type)
+                                     lambdaArgumentNames, lambdaBody,
-import           Bang.Monad(Compiler, BangError(..), err)
+                                     isEmptyExpression)
+import           Bang.AST.Type(Type(..), rtName, ftArgumentTypes, ftResultType,
+                               taLeftType, taRightType)
+import           Bang.Monad(Compiler, BangError(..), err, err', registerName)
 import           Bang.Syntax.Location(Location, ppLocation)
 import           Bang.Utils.FreeVars(CanHaveFreeVars(..))
-import           Bang.Utils.Pretty(BangDoc)
+import           Bang.Utils.Pretty(BangDoc, text')
-import           Control.Lens(view, set)
+import           Control.Lens(Lens', view, set)
 import           Control.Monad(foldM)
+import           Data.Char(isLower)
 import           Data.Graph(SCC(..))
 import           Data.Graph.SCC(stronglyConnComp)
 import           Data.Map.Strict(Map)
 import qualified Data.Map.Strict as Map
-import           Text.PrettyPrint.Annotated(text, ($+$), (<+>), nest)
+import           Data.Text.Lazy(uncons)
+import           Text.PrettyPrint.Annotated(text, ($+$), (<+>), nest, quotes)
 
 data PostProcessError = InternalError        Name
+                      | UndefinedVariable    Name
                       | RedefinitionError    Name Location Location
                       | TypeDeclWithoutValue Name Location
  deriving (Show)
@@ -35,6 +43,8 @@ prettyError e =
   case e of
     InternalError n ->
       (Nothing, text "Serious post-processing error w.r.t. " <+> ppName n)
+    UndefinedVariable n ->
+      (Just (view nameLocation n), text "Undefined variable " <+> quotes (text' (view nameText n)))
     RedefinitionError n l1 l2 ->
       (Just l1, text "Name" <+> ppName n <+> text "redefined." $+$
                 nest 2 (text "original definiton at " <+> ppLocation l2))
@@ -44,13 +54,99 @@ prettyError e =
 
 runPostProcessor :: Module -> Compiler ps Module
 runPostProcessor mdl =
-  do let decls = concat (view moduleDeclarations mdl)
+  do let baseDecls = concat (view moduleDeclarations mdl)
+     decls     <- linkNames baseDecls
      declTable <- makeDeclarationTable decls
-     decls' <- combineTypeValueDeclarations declTable decls
+     decls'    <- combineTypeValueDeclarations declTable decls
      return (set moduleDeclarations (orderDecls decls') mdl)
 
 -- -----------------------------------------------------------------------------
 
+linkNames :: [Declaration] -> Compiler ps [Declaration]
+linkNames decls =
+  do declaredNames <- foldM addNewNames Map.empty (map (view declName) decls)
+     mapM (linkDecls declaredNames) decls
+ where
+  addNewNames t n =
+    do n' <- registerName n
+       let key = (view nameText n, view nameEnvironment n)
+       return (Map.insert key n' t)
+  --
+  replaceName nameMap name =
+    do let key = (view nameText name, view nameEnvironment name)
+       case Map.lookup key nameMap of
+         Nothing    -> err' (UndefinedVariable name) >> return name
+         Just name' -> return name'
+  --
+  addOrReplaceName nameMap name =
+    do let key  = (view nameText name, view nameEnvironment name)
+       case Map.lookup key nameMap of
+         Nothing | couldBeTypeVariable name ->
+           do name' <- registerName name
+              return (name', Map.insert key name' nameMap)
+         Nothing ->
+           err' (UndefinedVariable name) >> return (name, nameMap)
+         Just name' ->
+           return (name', nameMap)
+  --
+  couldBeTypeVariable n =
+    case uncons (view nameText n) of
+      Nothing ->
+        error "Empty variable name?"
+      Just (x,_) ->
+        isLower x
+  --
+  linkDecls nameMap (DeclType td) =
+    do td'  <- overM tdType (linkType' nameMap)    td
+       td'' <- overM tdName (replaceName nameMap)  td'
+       return (DeclType td'')
+  linkDecls nameMap (DeclVal vd) =
+    do vd'   <- overM vdDeclaredType (traverse (linkType' nameMap)) vd
+       vd''  <- overM vdValue        (linkExpr nameMap)             vd'
+       vd''' <- overM vdName         (replaceName nameMap)          vd''
+       return (DeclVal vd''')
+  --
+  linkType' nm t = fst `fmap` linkType nm t
+  --
+  linkType nameMap x@(TypeUnit _) = return (x, nameMap)
+  linkType nameMap x@(TypePrim _) = return (x, nameMap)
+  linkType nameMap   (TypeRef t)  =
+    do (name, nameMap') <- addOrReplaceName nameMap (view rtName t)
+       let t' = set rtName name t
+       return (TypeRef t', nameMap') 
+  linkType nameMap   (TypeFun t)  =
+    do (argTypes, nameMap')  <- foldM linkTypes ([], nameMap) (view ftArgumentTypes t)
+       (resType,  nameMap'') <- linkType nameMap' (view ftResultType t)
+       return (TypeFun (set ftArgumentTypes argTypes $
+                        set ftResultType    resType  t),
+               nameMap'')
+  linkType nameMap   (TypeApp t)  =
+    do (lt, nameMap')  <- linkType nameMap  (view taLeftType  t)
+       (rt, nameMap'') <- linkType nameMap' (view taRightType t)
+       return (TypeApp (set taLeftType lt (set taRightType rt t)), nameMap'')
+  --
+  linkTypes (acc, nameMap) argType =
+    do (argType', nameMap') <- linkType nameMap argType
+       return (acc ++ [argType'], nameMap')
+  -- 
+  linkExpr _ x | isEmptyExpression x = return x
+  linkExpr _ x@(ConstExp  _) = return x
+  linkExpr nameMap (RefExp    e) =
+    RefExp `fmap` overM refName (replaceName nameMap) e
+  linkExpr nameMap (LambdaExp e) =
+    do let names = view lambdaArgumentNames e
+       nameMap' <- foldM addNewNames nameMap names
+       e'  <- overM lambdaArgumentNames (mapM (replaceName nameMap')) e
+       e'' <- overM lambdaBody          (linkExpr nameMap')           e'
+       return (LambdaExp e'')
+
+overM :: Monad m => Lens' s a -> (a -> m a) -> s -> m s
+overM field action input =
+  do newval <- action (view field input)
+     return (set field newval input)
+
+-- -----------------------------------------------------------------------------
+
 type DeclarationTable = Map Name (Maybe (Type, Location), Maybe ValueDeclaration)
 
 makeDeclarationTable :: [Declaration] -> Compiler ps DeclarationTable

test.bang

@@ -8,3 +8,6 @@ one = 1
 
 id :: a -> a
 id x = x
+
+seq :: a -> a -> a
+seq x y = y