Clean up type declarations for most of the system, at the cost of some post-processing shenanigans.

src/Bang/AST/Declaration.hs

@@ -15,24 +15,17 @@ module Bang.AST.Declaration
        , vdName, vdLocation
        , vdFreeTypeVariables, vdFreeValueVariables
        , vdDeclaredType, vdValue
-       -- * Declarations of primitive types
-       , PrimitiveDeclaration
-       , ppPrimitiveDeclaration
-       , mkPrimDecl
-       , pdName, pdLocation, pdLLVMType
        )
  where
 
 import Bang.AST.Expression(Expression, ppExpression)
 import Bang.AST.Name(Name, ppName)
-import Bang.AST.Type(Type, ppType)
+import Bang.AST.Type(Type(TypePrim), ppType)
 import Bang.Syntax.Location(Location)
-import Bang.Utils.Pretty(text')
-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(Doc, text, (<+>), ($+$), (<>), empty)
-import Text.PrettyPrint.Annotated(braces, punctuate, comma, hsep)
+import Text.PrettyPrint.Annotated(braces, punctuate, comma, hsep, space)
 
 data TypeDeclaration = TypeDeclaration
      { _tdName     :: Name
@@ -45,8 +38,11 @@ class MkTypeDecl a where
   mkTypeDecl :: Name -> Location -> Type -> a
 
 ppTypeDeclaration :: TypeDeclaration -> Doc a
-ppTypeDeclaration td =
+ppTypeDeclaration td = prefix <> text "type" <+> ppName (_tdName td) <+>
-  ppName (_tdName td) <+> text "::" <+> ppType (_tdType td)
+                       text "=" <+> ppType (_tdType td)
+ where
+  prefix | TypePrim _ <- _tdType td = text "primitive" <> space
+         | otherwise                = empty
 
 instance MkTypeDecl TypeDeclaration where
   mkTypeDecl = TypeDeclaration
@@ -67,7 +63,7 @@ data ValueDeclaration = ValueDeclaration
  deriving (Show)
 
 class MkValueDecl a where
-  mkValueDecl :: Name -> Location -> Expression -> a
+  mkValueDecl :: Name -> Location -> Maybe Type -> Expression -> a
 
 ppValueDeclaration :: ValueDeclaration -> Doc a
 ppValueDeclaration vd = frees $+$ typedecl $+$ valuedecl
@@ -84,57 +80,29 @@ ppValueDeclaration vd = frees $+$ typedecl $+$ valuedecl
   valuedecl = ppName (_vdName vd) <+> text "=" <+> ppExpression (_vdValue vd)
 
 instance MkValueDecl ValueDeclaration where
-  mkValueDecl n l e = ValueDeclaration n l [] [] Nothing e
+  mkValueDecl n l mt e = ValueDeclaration n l [] [] mt e
 
 instance MkValueDecl Declaration where
-  mkValueDecl n l e = DeclVal (ValueDeclaration n l [] [] Nothing e)
+  mkValueDecl n l mt e = DeclVal (ValueDeclaration n l [] [] mt e)
-
--- -----------------------------------------------------------------------------
-
-data PrimitiveDeclaration = PrimitiveDeclaration
-     { _pdName     :: Name
-     , _pdLocation :: Location
-     , _pdLLVMType :: Text
-     }
- deriving (Show)
-
-class MkPrimDecl a where
-  mkPrimDecl :: Name -> Location -> Text -> a
-
-ppPrimitiveDeclaration :: PrimitiveDeclaration -> Doc a
-ppPrimitiveDeclaration pd =
-  text "primitive" <+> text "type" <+> ppName (_pdName pd) <+>
-  text "=" <+> text' (_pdLLVMType pd)
-
-instance MkPrimDecl PrimitiveDeclaration where
-  mkPrimDecl = PrimitiveDeclaration
-
-instance MkPrimDecl Declaration where
-  mkPrimDecl n l t = DeclPrim (PrimitiveDeclaration n l t)
 
 -- -----------------------------------------------------------------------------
 
 data Declaration = DeclType TypeDeclaration
                  | DeclVal  ValueDeclaration
-                 | DeclPrim PrimitiveDeclaration
  deriving (Show)
 
 ppDeclaration :: Declaration -> Doc a
 ppDeclaration (DeclType d) = ppTypeDeclaration d
 ppDeclaration (DeclVal  d) = ppValueDeclaration d
-ppDeclaration (DeclPrim d) = ppPrimitiveDeclaration d
 
 makeLenses ''TypeDeclaration
 makeLenses ''ValueDeclaration
-makeLenses ''PrimitiveDeclaration
 
 declName :: Lens' Declaration Name
 declName = lens getter setter
  where
   getter (DeclType d) = view tdName d
   getter (DeclVal  d) = view vdName d
-  getter (DeclPrim d) = view pdName d
   setter (DeclType d) x = DeclType (set tdName x d)
   setter (DeclVal  d) x = DeclVal  (set vdName x d)
-  setter (DeclPrim d) x = DeclPrim (set pdName x d)
 

src/Bang/AST/Expression.hs

@@ -23,13 +23,17 @@ module Bang.AST.Expression
        , lambdaLocation
        , lambdaArgumentNames
        , lambdaBody
+       -- * Empty Expressions
+       , emptyExpression
+       , isEmptyExpression
        )
  where
 
-import Bang.Syntax.Location(Location)
+import Bang.Syntax.Location(Location, fakeLocation)
-import Bang.AST.Name(Name, ppName)
+import Bang.AST.Name(Name, ppName, nothingName)
 import Bang.Utils.FreeVars(CanHaveFreeVars(..))
 import Bang.Utils.Pretty(text')
+import Control.Lens(view)
 import Control.Lens.TH(makeLenses)
 import Data.Text.Lazy(Text)
 import Text.PrettyPrint.Annotated(Doc, text, hsep, (<>), (<+>))
@@ -146,3 +150,13 @@ makeLenses ''ConstantExpression
 makeLenses ''ReferenceExpression
 makeLenses ''LambdaExpression
 
+emptyExpression :: Expression
+emptyExpression = mkRefExp fakeLocation nothingName
+
+isEmptyExpression :: Expression -> Bool
+isEmptyExpression (RefExp e) = view refLocation e == fakeLocation &&
+                               view refName     e == nothingName
+isEmptyExpression _          = False
+
+
+

src/Bang/AST/Name.hs

@@ -1,7 +1,9 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
 module Bang.AST.Name(
          NameEnvironment(..)
        , Name
+       , nothingName
        , mkName
        , ppName
        , nameText
@@ -15,7 +17,7 @@ import Control.Lens(view)
 import Control.Lens.TH(makeLenses)
 import Data.Text.Lazy(Text, unpack)
 import Data.Word(Word)
-import Bang.Syntax.Location(Location)
+import Bang.Syntax.Location(Location, fakeLocation)
 import Bang.Utils.Pretty(text', word)
 import Text.PrettyPrint.Annotated(Doc, colon, (<>))
 
@@ -31,6 +33,9 @@ data Name = Name
 
 makeLenses ''Name
 
+nothingName :: Name
+nothingName = Name ":<nothing>:" VarEnv fakeLocation 0
+
 mkName :: Text -> NameEnvironment -> Location -> Word -> Name
 mkName = Name
 

src/Bang/AST/Type.hs

@@ -34,8 +34,10 @@ module Bang.AST.Type
 import Bang.AST.Name(Name, ppName)
 import Bang.Syntax.Location(Location)
 import Bang.Utils.FreeVars(CanHaveFreeVars(..))
+import Bang.Utils.Pretty(text')
 import Control.Lens.TH(makeLenses)
 import Data.List(foldl', union)
+import Data.Text.Lazy(Text)
 import Text.PrettyPrint.Annotated(Doc, (<+>), (<>), text, hsep)
 
 data Kind = Star
@@ -69,12 +71,12 @@ ppUnitType _ = text "()"
 
 data PrimitiveType = PrimitiveType
      { _ptLocation :: Location
-     , _ptName     :: Name
+     , _ptName     :: Text
      }
  deriving (Show)
 
 class MkPrimType a where
-  mkPrimType :: Location -> Name -> a
+  mkPrimType :: Location -> Text -> a
 
 instance Kinded PrimitiveType where
   kind _ = Star
@@ -83,13 +85,13 @@ instance MkPrimType PrimitiveType where
   mkPrimType = PrimitiveType
 
 instance MkPrimType Type where
-  mkPrimType l n = TypePrim (PrimitiveType l n)
+  mkPrimType l t = TypePrim (PrimitiveType l t)
 
 instance CanHaveFreeVars PrimitiveType where
   freeVariables _ = []
 
 ppPrimitiveType :: PrimitiveType -> Doc a
-ppPrimitiveType pt = text "llvm:" <> ppName (_ptName pt)
+ppPrimitiveType pt = text "llvm:" <> text' (_ptName pt)
 
 -- -----------------------------------------------------------------------------
 

src/Bang/Syntax/Location.hs

@@ -12,6 +12,7 @@ module Bang.Syntax.Location(
        , Located(..)
        , locatedAt
        , unknownLocation
+       , fakeLocation
        )
  where
 
@@ -53,6 +54,7 @@ advanceWith' pos txt =
     Just (c, rest) -> advanceWith' (pos `advanceWith` c) rest
 
 data Origin = Unknown
+            | Generated
             | Interactive
             | File FilePath
  deriving (Eq, Show)
@@ -61,6 +63,7 @@ ppOrigin :: Origin -> BangDoc
 ppOrigin x =
   case x of
     Unknown     -> text "<unknown>"
+    Generated   -> text "<generated>"
     Interactive -> text "<interactive>"
     File f      -> text f
 
@@ -97,3 +100,6 @@ locatedAt a p = Located p a
 
 unknownLocation :: Location
 unknownLocation = Location Unknown initialPosition initialPosition
+
+fakeLocation :: Location
+fakeLocation = Location Generated initialPosition initialPosition

src/Bang/Syntax/Parser.y

@@ -11,10 +11,10 @@ module Bang.Syntax.Parser(
  where
 
 import Bang.Monad(err)
-import Bang.AST(Name, Module, NameEnvironment(..), mkModule)
+import Bang.AST(Name, Module, NameEnvironment(..), mkModule, emptyExpression)
-import Bang.AST.Declaration(Declaration, mkTypeDecl, mkPrimDecl, mkValueDecl)
+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)
+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,
@@ -143,12 +143,12 @@ ValueDeclLHS :: { (Expression -> Declaration, [Name]) }
             err (InternalError $2 "ValDeclLHS")
          [Located src (ValIdent rawName)] ->
            do name <- registerName True src VarEnv rawName
-              return (mkValueDecl name src , [name])
+              return (mkValueDecl name src Nothing, [name])
          ((Located src (ValIdent rawName)) : args) ->
            do name <- registerName True src VarEnv rawName
               argNames <- forM args $ \ (Located asrc (ValIdent argName)) ->
                             registerName True asrc VarEnv argName
-              let builder = mkValueDecl name src . mkLambdaExp $2 argNames
+              let builder = mkValueDecl name src Nothing . mkLambdaExp $2 argNames
               return (builder, argNames)
     }
 
@@ -165,13 +165,18 @@ TypeDeclaration :: { Declaration }
     {%
        do let Located src (ValIdent rawName) = $1
           name <- registerName True src VarEnv rawName
-          return (mkTypeDecl name src $3) }
+          return (mkValueDecl name src (Just $3) emptyExpression) }
+  | 'type' TypeIdent '=' Type
+    {%
+       do let Located src (TypeIdent rawName) = $2
+          name <- registerName True src TypeEnv rawName
+          return (mkTypeDecl name src $4) }
   | 'primitive' 'type' TypeIdent '=' String
     {%
-       do let Located src (TypeIdent rawName) = $3
+       do let Located nsrc (TypeIdent rawName) = $3
-              Located _   (StringTok rawText) = $5
+              Located tsrc (StringTok rawText) = $5
-          name <- registerName False src TypeEnv rawName
+          name <- registerName False nsrc TypeEnv rawName
-          return (mkPrimDecl name src rawText) }
+          return (mkTypeDecl name $2 (mkPrimType tsrc rawText)) }
 
 -- -----------------------------------------------------------------------------
 

src/Bang/Syntax/PostProcess.hs

@@ -5,11 +5,12 @@ module Bang.Syntax.PostProcess(
 
 import           Bang.AST(Name, Module, moduleDeclarations, ppName)
 import           Bang.AST.Declaration(Declaration(..), declName,
-                                      TypeDeclaration, ValueDeclaration,
+                                      ValueDeclaration,
-                                      tdName, tdLocation, tdType,
                                       vdName, vdLocation, vdDeclaredType,
                                       vdFreeTypeVariables,
                                       vdValue, vdFreeValueVariables)
+import           Bang.AST.Expression(isEmptyExpression)
+import           Bang.AST.Type(Type)
 import           Bang.Monad(Compiler, BangError(..), err)
 import           Bang.Syntax.Location(Location, ppLocation)
 import           Bang.Utils.FreeVars(CanHaveFreeVars(..))
@@ -48,7 +49,7 @@ runPostProcessor mdl =
 
 -- -----------------------------------------------------------------------------
 
-type DeclarationTable = Map Name (Maybe TypeDeclaration, Maybe ValueDeclaration)
+type DeclarationTable = Map Name (Maybe (Type, Location), Maybe ValueDeclaration)
 
 makeDeclarationTable :: Module -> Compiler ps DeclarationTable
 makeDeclarationTable m = foldM combine Map.empty (view moduleDeclarations m)
@@ -56,16 +57,23 @@ makeDeclarationTable m = foldM combine Map.empty (view moduleDeclarations m)
   combine table d =
     do let name = view declName d
        case d of
-         DeclType td ->
+         DeclType _ ->
-           case Map.lookup name table of
+           return table
-             Nothing            ->
+         DeclVal vd | Just t <- view vdDeclaredType vd,
-               return (Map.insert name (Just td, Nothing) table)
+                      isEmptyExpression (view vdValue vd) ->
-             Just (Nothing, vd) ->
+           do let myLoc = view vdLocation vd
-               return (Map.insert name (Just td, vd) table)
+                  myVal = Just (t, myLoc)
-             Just (Just td', _) ->
+              case Map.lookup name table of
-               do let newLoc  = view tdLocation td
+                Nothing            ->
-                      origLoc = view tdLocation td'
+                  return (Map.insert name (myVal, Nothing) table)
-                  err (RedefinitionError name newLoc origLoc)
+                Just (Nothing, vd') ->
+                  return (Map.insert name (myVal, vd') table)
+                Just (Just (_, theirLoc), _) ->
+                  err (RedefinitionError name myLoc theirLoc)
+         DeclVal vd | Just _ <- view vdDeclaredType vd ->
+           err (InternalError name)
+         DeclVal vd | isEmptyExpression (view vdValue vd) ->
+           err (InternalError name)
          DeclVal vd ->
            case Map.lookup name table of
              Nothing            ->
@@ -76,8 +84,6 @@ makeDeclarationTable m = foldM combine Map.empty (view moduleDeclarations m)
                do let newLoc  = view vdLocation vd
                       origLoc = view vdLocation vd'
                   err (RedefinitionError name newLoc origLoc)
-         DeclPrim _ ->
-           return table
 
 -- -----------------------------------------------------------------------------
 
@@ -90,21 +96,19 @@ combineTypeValueDeclarations table m =
   process [] = return []
   process (x:rest) =
     case x of
-      DeclPrim _  -> (x:) `fmap` process rest
+      DeclType _ ->
-      DeclType td ->
+        (x:) `fmap` process rest
-        case Map.lookup (view tdName td) table of
+      DeclVal vd | Just _ <- view vdDeclaredType vd,
-          Just (_, Nothing) ->
+                   isEmptyExpression (view vdValue vd) ->
-            err (TypeDeclWithoutValue (view tdName td) (view tdLocation td))
+        process rest
-          _ ->
-            process rest
       DeclVal vd ->
         case Map.lookup (view vdName vd) table of
           Nothing ->
             err (InternalError (view vdName vd))
           Just (Nothing, _) ->
             (x:) `fmap` process rest
-          Just (Just td, _) ->
+          Just (Just (t, _), _) ->
-            do let vd' = set vdDeclaredType (Just (view tdType td)) vd
+            do let vd' = set vdDeclaredType (Just t) vd
                (DeclVal vd' :) `fmap` process rest
 
 -- -----------------------------------------------------------------------------