acw/bang
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Adam Wick
2016-07-17 12:22:41 -07:00
parent 188114ce78
commit 15b4059163
7 changed files with 89 additions and 85 deletions
Download Patch File Download Diff File Expand all files Collapse all files

54
src/Bang/AST/Declaration.hs
View File

@@ -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(braces, punctuate, comma, hsep)
import Text.PrettyPrint.Annotated(Doc, text, (<+>), ($+$), (<>), empty)
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 =
ppName (_tdName td) <+> text "::" <+> ppType (_tdType td)
ppTypeDeclaration td = prefix <> text "type" <+> ppName (_tdName 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)
-- -----------------------------------------------------------------------------
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)
mkValueDecl n l mt e = DeclVal (ValueDeclaration n l [] [] mt e)
-- -----------------------------------------------------------------------------
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)

18
src/Bang/AST/Expression.hs
View File

@@ -23,13 +23,17 @@ module Bang.AST.Expression
, lambdaLocation
, lambdaArgumentNames
, lambdaBody
-- * Empty Expressions
, emptyExpression
, isEmptyExpression
)
where
import Bang.Syntax.Location(Location)
import Bang.AST.Name(Name, ppName)
import Bang.Syntax.Location(Location, fakeLocation)
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

9
src/Bang/AST/Name.hs
View File

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

10
src/Bang/AST/Type.hs
View File

@@ -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)
-- -----------------------------------------------------------------------------

6
src/Bang/Syntax/Location.hs
View File

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

25
src/Bang/Syntax/Parser.y
View File

@@ -11,10 +11,10 @@ module Bang.Syntax.Parser(
where
import Bang.Monad(err)
import Bang.AST(Name, Module, NameEnvironment(..), mkModule)
import Bang.AST.Declaration(Declaration, mkTypeDecl, mkPrimDecl, mkValueDecl)
import Bang.AST(Name, Module, NameEnvironment(..), mkModule, 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)
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
Located _ (StringTok rawText) = $5
name <- registerName False src TypeEnv rawName
return (mkPrimDecl name src rawText) }
do let Located nsrc (TypeIdent rawName) = $3
Located tsrc (StringTok rawText) = $5
name <- registerName False nsrc TypeEnv rawName
return (mkTypeDecl name $2 (mkPrimType tsrc rawText)) }
-- -----------------------------------------------------------------------------

52
src/Bang/Syntax/PostProcess.hs
View File

@@ -5,11 +5,12 @@ module Bang.Syntax.PostProcess(
import Bang.AST(Name, Module, moduleDeclarations, ppName)
import Bang.AST.Declaration(Declaration(..), declName,
TypeDeclaration, ValueDeclaration,
tdName, tdLocation, tdType,
ValueDeclaration,
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 ->
case Map.lookup name table of
Nothing ->
return (Map.insert name (Just td, Nothing) table)
Just (Nothing, vd) ->
return (Map.insert name (Just td, vd) table)
Just (Just td', _) ->
do let newLoc = view tdLocation td
origLoc = view tdLocation td'
err (RedefinitionError name newLoc origLoc)
DeclType _ ->
return table
DeclVal vd | Just t <- view vdDeclaredType vd,
isEmptyExpression (view vdValue vd) ->
do let myLoc = view vdLocation vd
myVal = Just (t, myLoc)
case Map.lookup name table of
Nothing ->
return (Map.insert name (myVal, Nothing) table)
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 td ->
case Map.lookup (view tdName td) table of
Just (_, Nothing) ->
err (TypeDeclWithoutValue (view tdName td) (view tdLocation td))
_ ->
process rest
DeclType _ ->
(x:) `fmap` process rest
DeclVal vd | Just _ <- view vdDeclaredType vd,
isEmptyExpression (view vdValue vd) ->
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, _) ->
do let vd' = set vdDeclaredType (Just (view tdType td)) vd
Just (Just (t, _), _) ->
do let vd' = set vdDeclaredType (Just t) vd
(DeclVal vd' :) `fmap` process rest
-- -----------------------------------------------------------------------------