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

The Lensening.

Browse Source
This commit is contained in:
Adam Wick
2016-07-07 22:22:27 -07:00
parent ad016f9dcf
commit 82c260fec3
13 changed files with 606 additions and 174 deletions
Download Patch File Download Diff File Expand all files Collapse all files

42
src/Bang/AST.hs Normal file
View File

@@ -0,0 +1,42 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.AST
( Module
, ppModule
, mkModule
, moduleName, moduleDeclarations
, module Bang.AST.Declaration
, module Bang.AST.Expression
, module Bang.AST.Name
, module Bang.AST.Type
)
where
import Bang.AST.Declaration
import Bang.AST.Expression
import Bang.AST.Name
import Bang.AST.Type
import Control.Lens(view)
import Control.Lens.TH(makeLenses)
import Text.PrettyPrint.Annotated(Doc, empty, text, (<+>), ($+$))
data Module = Module {
_moduleName :: Name
, _moduleDeclarations :: [Declaration]
}
mkModule :: Name -> [Declaration] -> Module
mkModule = Module
makeLenses ''Module
ppModule :: Module -> Doc a
ppModule m = text "module" <+> ppName (view moduleName m) $+$
dump (view moduleName m) (view moduleDeclarations m)
where
dump _ [] = empty
dump prev (x:rest)
| prev == view declName x =
ppDeclaration x $+$ dump prev rest
| otherwise =
text "" $+$ dump (view declName x) (x:rest)

129
src/Bang/AST/Declaration.hs Normal file
View File

@@ -0,0 +1,129 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.AST.Declaration
( Declaration(..)
, ppDeclaration
, declName
-- * Type Declarations
, TypeDeclaration
, ppTypeDeclaration
, mkTypeDecl
, tdName, tdLocation, tdType
-- * Value Declarations
, ValueDeclaration
, ppValueDeclaration
, mkValueDecl
, 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.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, (<+>))
data TypeDeclaration = TypeDeclaration
{ _tdName :: Name
, _tdLocation :: Location
, _tdType :: Type
}
deriving (Show)
class MkTypeDecl a where
mkTypeDecl :: Name -> Location -> Type -> a
ppTypeDeclaration :: TypeDeclaration -> Doc a
ppTypeDeclaration td =
ppName (_tdName td) <+> text "::" <+> ppType (_tdType td)
instance MkTypeDecl TypeDeclaration where
mkTypeDecl = TypeDeclaration
instance MkTypeDecl Declaration where
mkTypeDecl n l t = DeclType (TypeDeclaration n l t)
-- -----------------------------------------------------------------------------
data ValueDeclaration = ValueDeclaration
{ _vdName :: Name
, _vdLocation :: Location
, _vdFreeTypeVariables :: [Name]
, _vdFreeValueVariables :: [Name]
, _vdDeclaredType :: Maybe Type
, _vdValue :: Expression
}
deriving (Show)
class MkValueDecl a where
mkValueDecl :: Name -> Location -> Expression -> a
ppValueDeclaration :: ValueDeclaration -> Doc a
ppValueDeclaration vd =
ppName (_vdName vd) <+> text "=" <+> ppExpression (_vdValue vd)
instance MkValueDecl ValueDeclaration where
mkValueDecl n l e = ValueDeclaration n l [] [] Nothing 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)
-- -----------------------------------------------------------------------------
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)

132
src/Bang/AST/Expression.hs Normal file
View File

@@ -0,0 +1,132 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.AST.Expression
( Expression
, ppExpression
-- * Constant Expressions
, ConstantExpression
, ppConstantExpression
, mkConstExp
, constLocation
, constValue
, ConstantValue(..)
, ppConstantValue
-- * References
, ReferenceExpression
, ppReferenceExpression
, mkRefExp
, refLocation
, refName
-- * Lambdas
, LambdaExpression
, ppLambdaExpression
, mkLambdaExp
, lambdaLocation
, lambdaArgumentNames
, lambdaBody
)
where
import Bang.Syntax.Location(Location)
import Bang.AST.Name(Name, ppName)
import Bang.Utils.Pretty(text')
import Control.Lens.TH(makeLenses)
import Data.Text.Lazy(Text)
import Text.PrettyPrint.Annotated(Doc, text, hsep, (<>), (<+>))
-- -----------------------------------------------------------------------------
data ConstantValue = ConstantInt Word Text
| ConstantChar Text
| ConstantString Text
| ConstantFloat Text
deriving (Show)
ppConstantValue :: ConstantValue -> Doc a
ppConstantValue cv =
case cv of
ConstantInt 2 t -> text "0b" <> text' t
ConstantInt 8 t -> text "0o" <> text' t
ConstantInt 10 t -> text' t
ConstantInt 16 t -> text "0x" <> text' t
ConstantInt _ _ -> error "Internal error: bad base for constant"
ConstantChar c -> text' c
ConstantString s -> text' s
ConstantFloat f -> text' f
data ConstantExpression = ConstantExpression
{ _constLocation :: Location
, _constValue :: ConstantValue
}
deriving (Show)
class MkConstExp a where
mkConstExp :: Location -> ConstantValue -> a
instance MkConstExp ConstantExpression where
mkConstExp = ConstantExpression
instance MkConstExp Expression where
mkConstExp l v = ConstExp (mkConstExp l v)
ppConstantExpression :: ConstantExpression -> Doc a
ppConstantExpression = ppConstantValue . _constValue
-- -----------------------------------------------------------------------------
data ReferenceExpression = ReferenceExpression
{ _refLocation :: Location
, _refName :: Name
}
deriving (Show)
ppReferenceExpression :: ReferenceExpression -> Doc a
ppReferenceExpression = ppName . _refName
class MkRefExp a where
mkRefExp :: Location -> Name -> a
instance MkRefExp ReferenceExpression where
mkRefExp = ReferenceExpression
instance MkRefExp Expression where
mkRefExp l n = RefExp (ReferenceExpression l n)
-- -----------------------------------------------------------------------------
data LambdaExpression = LambdaExpression
{ _lambdaLocation :: Location
, _lambdaArgumentNames :: [Name]
, _lambdaBody :: Expression
}
deriving (Show)
class MkLambdaExp a where
mkLambdaExp :: Location -> [Name] -> Expression -> a
ppLambdaExpression :: LambdaExpression -> Doc a
ppLambdaExpression le =
text "λ" <+> hsep (map ppName (_lambdaArgumentNames le)) <+> text "->" <+>
ppExpression (_lambdaBody le)
instance MkLambdaExp LambdaExpression where
mkLambdaExp = LambdaExpression
instance MkLambdaExp Expression where
mkLambdaExp l a b = LambdaExp (LambdaExpression l a b)
-- -----------------------------------------------------------------------------
data Expression = ConstExp ConstantExpression
| RefExp ReferenceExpression
| LambdaExp LambdaExpression
deriving (Show)
ppExpression :: Expression -> Doc a
ppExpression (ConstExp e) = ppConstantExpression e
ppExpression (RefExp e) = ppReferenceExpression e
ppExpression (LambdaExp e) = ppLambdaExpression e
makeLenses ''ConstantExpression
makeLenses ''ReferenceExpression
makeLenses ''LambdaExpression

54
src/Bang/AST/Name.hs Normal file
View File

@@ -0,0 +1,54 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.AST.Name(
NameEnvironment(..)
, Name
, mkName
, ppName
, nameText
, nameEnvironment
, nameLocation
, nameIndex
)
where
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.Utils.Pretty(text', word)
import Text.PrettyPrint.Annotated(Doc, colon, (<>))
data NameEnvironment = ModuleEnv | TypeEnv | VarEnv
deriving (Eq, Ord, Show)
data Name = Name
{ _nameText :: Text
, _nameEnvironment :: NameEnvironment
, _nameLocation :: Location
, _nameIndex :: Word
}
makeLenses ''Name
mkName :: Text -> NameEnvironment -> Location -> Word -> Name
mkName = Name
ppName :: Name -> Doc a
ppName n = text' (view nameText n) <> colon <> word (view nameIndex n)
instance Eq Name where
a == b = view nameIndex a == view nameIndex b
a /= b = view nameIndex a /= view nameIndex b
instance Ord Name where
compare a b = compare (view nameIndex a) (view nameIndex b)
max a b = if a < b then b else a
min a b = if a < b then a else b
(<) a b = (<) (view nameIndex a) (view nameIndex b)
(>) a b = (>) (view nameIndex a) (view nameIndex b)
(<=) a b = (<=) (view nameIndex a) (view nameIndex b)
(>=) a b = (>=) (view nameIndex a) (view nameIndex b)
instance Show Name where
show n = unpack (view nameText n) ++ ":" ++ show (view nameIndex n)

190
src/Bang/AST/Type.hs Normal file
View File

@@ -0,0 +1,190 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.AST.Type
( Type(..)
, ppType
, Kind(..)
, ppKind
, Kinded(..)
-- * the unit time
, UnitType
, ppUnitType
-- * primitive types
, PrimitiveType
, ppPrimitiveType
, mkPrimType
, ptLocation, ptName
-- * reference types
, ReferenceType
, ppReferenceType
, mkTypeRef
, rtLocation, rtKind, rtName
-- * lambda types
, FunctionType
, ppFunctionType
, mkFunType
, ftLocation, ftKind, ftArgumentTypes, ftResultType
-- * type application
, TypeApplication
, ppTypeApplication
, mkTypeApp
, taLocation, taKind, taLeftType, taRightType
)
where
import Bang.AST.Name(Name, ppName)
import Bang.Syntax.Location(Location)
import Control.Lens.TH(makeLenses)
import Text.PrettyPrint.Annotated(Doc, (<+>), (<>), text, hsep)
data Kind = Star
| Unknown
| KindArrow Kind Kind
deriving (Show, Eq)
ppKind :: Kind -> Doc a
ppKind Star = text "*"
ppKind Unknown = text "?"
ppKind (KindArrow a b) = ppKind a <+> text "->" <+> ppKind b
class Kinded a where
kind :: a -> Kind
-- -----------------------------------------------------------------------------
data UnitType = UnitType
deriving (Show)
instance Kinded UnitType where
kind _ = Star
ppUnitType :: UnitType -> Doc a
ppUnitType _ = text "()"
-- -----------------------------------------------------------------------------
data PrimitiveType = PrimitiveType
{ _ptLocation :: Location
, _ptName :: Name
}
deriving (Show)
class MkPrimType a where
mkPrimType :: Location -> Name -> a
instance Kinded PrimitiveType where
kind _ = Star
instance MkPrimType PrimitiveType where
mkPrimType = PrimitiveType
instance MkPrimType Type where
mkPrimType l n = TypePrim (PrimitiveType l n)
ppPrimitiveType :: PrimitiveType -> Doc a
ppPrimitiveType pt = text "llvm:" <> ppName (_ptName pt)
-- -----------------------------------------------------------------------------
data ReferenceType = ReferenceType
{ _rtLocation :: Location
, _rtKind :: Kind
, _rtName :: Name
}
deriving (Show)
instance Kinded ReferenceType where
kind = _rtKind
ppReferenceType :: ReferenceType -> Doc a
ppReferenceType = ppName . _rtName
class MkTypeRef a where
mkTypeRef :: Location -> Kind -> Name -> a
instance MkTypeRef ReferenceType where
mkTypeRef = ReferenceType
instance MkTypeRef Type where
mkTypeRef l k n = TypeRef (ReferenceType l k n)
-- -----------------------------------------------------------------------------
data FunctionType = FunctionType
{ _ftLocation :: Location
, _ftKind :: Kind
, _ftArgumentTypes :: [Type]
, _ftResultType :: Type
}
deriving (Show)
class MkFunType a where
mkFunType :: Location -> [Type] -> Type -> a
instance MkFunType FunctionType where
mkFunType l a r = FunctionType l Star a r
instance MkFunType Type where
mkFunType l a r = TypeFun (FunctionType l Star a r)
ppFunctionType :: FunctionType -> Doc a
ppFunctionType ft =
hsep (map ppType (_ftArgumentTypes ft)) <+> text "->" <+>
ppType (_ftResultType ft)
instance Kinded FunctionType where
kind = _ftKind
-- -----------------------------------------------------------------------------
data TypeApplication = TypeApplication
{ _taLocation :: Location
, _taKind :: Kind
, _taLeftType :: Type
, _taRightType :: Type
}
deriving (Show)
class MkTypeApp a where
mkTypeApp :: Location -> Type -> Type -> a
instance MkTypeApp TypeApplication where
mkTypeApp l s t = TypeApplication l Unknown s t
instance MkTypeApp Type where
mkTypeApp l s t = TypeApp (TypeApplication l Unknown s t)
instance Kinded TypeApplication where
kind = _taKind
ppTypeApplication :: TypeApplication -> Doc a
ppTypeApplication ta =
ppType (_taLeftType ta) <+> ppType (_taRightType ta)
-- -----------------------------------------------------------------------------
data Type = TypeUnit UnitType
| TypePrim PrimitiveType
| TypeRef ReferenceType
| TypeFun FunctionType
| TypeApp TypeApplication
deriving (Show)
ppType :: Type -> Doc a
ppType (TypeUnit t) = ppUnitType t
ppType (TypePrim t) = ppPrimitiveType t
ppType (TypeRef t) = ppReferenceType t
ppType (TypeFun t) = ppFunctionType t
ppType (TypeApp t) = ppTypeApplication t
instance Kinded Type where
kind (TypeUnit x) = kind x
kind (TypePrim x) = kind x
kind (TypeRef x) = kind x
kind (TypeFun x) = kind x
kind (TypeApp x) = kind x
makeLenses ''PrimitiveType
makeLenses ''ReferenceType
makeLenses ''FunctionType
makeLenses ''TypeApplication

22
src/Bang/Monad.hs
View File

@@ -15,10 +15,11 @@ module Bang.Monad(
)
where
import Bang.AST.Expression(Expression, mkRefExp)
import Bang.AST.Name(NameEnvironment(..), Name, mkName)
import Bang.AST.Type(Kind(..), Type, mkTypeRef)
import Bang.CommandLine(BangCommand, CommandsWithInputFile(..))
import Bang.Error(exit)
import Bang.Syntax.AST(NameEnvironment(..), Name(..),
Kind(..), Type(..), Expression(..))
import Bang.Syntax.Location(Location(..), Origin(..),
unknownLocation, ppLocation)
import Bang.Utils.Pretty(BangDoc)
@@ -110,21 +111,22 @@ registerNewName :: NameEnvironment -> Text -> Compiler s Name
registerNewName env name =
Compiler (\ st ->
do let current = view csNextIdent st
res = Name unknownLocation env current name
res = mkName name env unknownLocation current
return (over csNextIdent (+1) st, res))
genName :: NameEnvironment -> Compiler s Name
genName env = Compiler (\ st ->
do let current = view csNextIdent st
str = "gen:" ++ show current
res = Name unknownLocation env current (pack str)
return (over csNextIdent (+1) st, res))
genName env =
Compiler (\ st ->
do let current = view csNextIdent st
str = "gen:" ++ show current
res = mkName (pack str) env unknownLocation current
return (over csNextIdent (+1) st, res))
genTypeRef :: Kind -> Compiler s Type
genTypeRef k = TypeRef unknownLocation k `fmap` genName TypeEnv
genTypeRef k = mkTypeRef unknownLocation k `fmap` genName TypeEnv
genVarRef :: Compiler s Expression
genVarRef = ReferenceExp unknownLocation `fmap` genName VarEnv
genVarRef = mkRefExp unknownLocation `fmap` genName VarEnv
-- -----------------------------------------------------------------------------

71
src/Bang/Syntax/AST.hs
View File

@@ -1,71 +0,0 @@
module Bang.Syntax.AST
where
import Data.Text.Lazy(Text)
import Bang.Syntax.Location(Location)
data NameEnvironment = ModuleEnv | TypeEnv | VarEnv
deriving (Eq, Ord, Show)
data Name = Name Location NameEnvironment Word Text
deriving (Show)
instance Eq Name where
(Name _ _ x _) == (Name _ _ y _) = x == y
(Name _ _ x _) /= (Name _ _ y _) = x /= y
instance Ord Name where
compare (Name _ _ x _) (Name _ _ y _) = compare x y
--
max n1@(Name _ _ x _) n2@(Name _ _ y _) = if x > y then n1 else n2
min n1@(Name _ _ x _) n2@(Name _ _ y _) = if x > y then n2 else n1
--
(Name _ _ x _) < (Name _ _ y _) = x < y
(Name _ _ x _) <= (Name _ _ y _) = x <= y
(Name _ _ x _) >= (Name _ _ y _) = x >= y
(Name _ _ x _) > (Name _ _ y _) = x > y
data Module = Module Name [Declaration]
deriving (Show)
data Declaration = TypeDeclaration Name Type
| ValueDeclaration Name Expression
| PrimTypeDeclaration Name Text
deriving (Show)
data Expression = ConstantExp Location ConstantValue
| ReferenceExp Location Name
| LambdaExp Location [Name] Expression
deriving (Show)
data ConstantValue = ConstantInt Word Text
| ConstantChar Text
| ConstantString Text
| ConstantFloat Text
deriving (Show)
data Type = TypeUnit Location Kind
| TypePrim Location Kind Text
| TypeRef Location Kind Name
| TypeLambda Location Kind [Type] Type
| TypeApp Location Kind Type Type
deriving (Show)
instance Eq Type where
(TypeUnit _ _) == (TypeUnit _ _) = True
(TypePrim _ _ a) == (TypePrim _ _ b) = a == b
(TypeRef _ _ n) == (TypeRef _ _ m) = n == m
(TypeLambda _ _ at et) == (TypeLambda _ _ bt ft) = (at == bt) && (et == ft)
(TypeApp _ _ at bt) == (TypeApp _ _ ct dt) = (at == ct) && (bt == dt)
_ == _ = False
kind :: Type -> Kind
kind (TypeUnit _ k) = k
kind (TypePrim _ k _) = k
kind (TypeRef _ k _) = k
kind (TypeLambda _ k _ _) = k
kind (TypeApp _ k _ _) = k
data Kind = Star
| KindArrow Kind Kind
deriving (Show, Eq)

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

@@ -11,9 +11,10 @@ module Bang.Syntax.Parser(
where
import Bang.Monad(err)
import Bang.Syntax.AST(Module(..), Name(..), NameEnvironment(..),
Declaration(..), Expression(..), Type(..), Kind(..),
ConstantValue(..))
import Bang.AST(Name, Module, NameEnvironment(..), mkModule)
import Bang.AST.Declaration(Declaration, mkTypeDecl, mkPrimDecl, mkValueDecl)
import Bang.AST.Expression(ConstantValue(..), Expression, mkConstExp, mkRefExp, mkLambdaExp)
import Bang.AST.Type(Type, Kind(..), mkTypeRef, mkFunType, mkTypeApp)
import Bang.Syntax.Location(Located(..), Origin, Position)
import Bang.Syntax.ParserError(ParserError(..))
import Bang.Syntax.ParserMonad(Parser, addFixities, registerName,
@@ -119,7 +120,7 @@ top_module :: { Module }
{%
do let Located src (TypeIdent rawName) = $2
name <- registerName False src ModuleEnv rawName
return (Module name $3) }
return (mkModule name $3) }
Declaration :: { Maybe Declaration }
: ValueDeclaration { Just $1 }
@@ -142,12 +143,12 @@ ValueDeclLHS :: { (Expression -> Declaration, [Name]) }
err (InternalError $2 "ValDeclLHS")
[Located src (ValIdent rawName)] ->
do name <- registerName True src VarEnv rawName
return (ValueDeclaration name, [name])
return (mkValueDecl name src , [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 = ValueDeclaration name . LambdaExp $2 argNames
let builder = mkValueDecl name src . mkLambdaExp $2 argNames
return (builder, argNames)
}
@@ -164,13 +165,13 @@ TypeDeclaration :: { Declaration }
{%
do let Located src (ValIdent rawName) = $1
name <- registerName True src VarEnv rawName
return (TypeDeclaration name $3) }
return (mkTypeDecl name src $3) }
| 'primitive' 'type' TypeIdent '=' String
{%
do let Located src (TypeIdent rawName) = $3
Located _ (StringTok rawText) = $5
name <- registerName False src TypeEnv rawName
return (PrimTypeDeclaration name rawText) }
return (mkPrimDecl name src rawText) }
-- -----------------------------------------------------------------------------
@@ -188,7 +189,7 @@ RawType :: { (Type, [Name]) }
: RawType '->' BaseType {%
do let (p1, names1) = $1
(p2, names2) = $3
return (TypeLambda $2 (Star `KindArrow` Star) [p1] p2, union names1 names2)
return (mkFunType $2 [p1] p2, union names1 names2)
}
| BaseType { $1 }
@@ -196,11 +197,11 @@ BaseType :: { (Type, [Name]) }
: TypeIdent {%
do let Located src (TypeIdent rawName) = $1
name <- lookupName src TypeEnv rawName
return (TypeRef src Star name, []) }
return (mkTypeRef src Unknown name, []) }
| ValIdent {%
do let Located src (ValIdent rawName) = $1
name <- registerName True src TypeEnv rawName
return (TypeRef src Star name, [name])
return (mkTypeRef src Unknown name, [name])
}
-- -----------------------------------------------------------------------------
@@ -212,23 +213,23 @@ BaseExpression :: { Expression }
: OpIdent {%
do let Located src (OpIdent _ rawName) = $1
name <- lookupName src VarEnv rawName
return (ReferenceExp src name) }
return (mkRefExp src name) }
| ValIdent {%
do let Located src (ValIdent rawName) = $1
name <- lookupName src VarEnv rawName
return (ReferenceExp src name) }
return (mkRefExp src name) }
| Integer {%
do let Located src (IntTok base val) = $1
return (ConstantExp src (ConstantInt base val)) }
return (mkConstExp src (ConstantInt base val)) }
| String {%
do let Located src (StringTok val) = $1
return (ConstantExp src (ConstantString val)) }
return (mkConstExp src (ConstantString val)) }
| Float {%
do let Located src (FloatTok val) = $1
return (ConstantExp src (ConstantFloat val)) }
return (mkConstExp src (ConstantFloat val)) }
| Char {%
do let Located src (CharTok val) = $1
return (ConstantExp src (ConstantChar val)) }
return (mkConstExp src (ConstantChar val)) }
-- -----------------------------------------------------------------------------

11
src/Bang/Syntax/ParserMonad.hs
View File

@@ -13,9 +13,10 @@ module Bang.Syntax.ParserMonad(
)
where
import Bang.AST.Name(Name, NameEnvironment(..), mkName,
nameLocation, nameText)
import Bang.Monad(Compiler, err, runPass,
getPassState, overPassState, viewPassState)
import Bang.Syntax.AST(Name(..), NameEnvironment(..))
import Bang.Syntax.Lexer(AlexReturn(..), AlexInput(..), alexScan)
import Bang.Syntax.Location(Location(..), Located(..),
Origin(..), initialPosition,
@@ -107,19 +108,19 @@ registerName redefOk loc env name =
let key = (env, name)
case Map.lookup key (view psNameDatabase state) of
Nothing ->
do let res = Name loc env (view psNextIdent state) name
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 origLoc _ _ _) ->
err (RedefinitionError loc origLoc name)
Just name' ->
err (RedefinitionError loc (view nameLocation name') name)
unregisterNames :: NameEnvironment -> [Name] -> Parser ()
unregisterNames env names =
do db <- viewPassState psNameDatabase
let db' = foldr (\ (Name _ _ _ n) m -> Map.delete (env, n) m) db names
let db' = foldr (\ n m -> Map.delete (env, view nameText n) m) db names
overPassState (set psNameDatabase db')
lookupName :: Location -> NameEnvironment -> Text -> Parser Name

15
src/Bang/Syntax/PostProcess.hs Normal file
View File

@@ -0,0 +1,15 @@
module Bang.Syntax.PostProcess(
runPostProcessor
)
import Bang.Syntax.AST
runPostProcessor :: Module -> Compiler ps Module
runPostProcessor mod = undefined
-- -----------------------------------------------------------------------------
type DeclarationTable = Map Name (Maybe TypeDeclaration, Maybe ValueDeclaration)
makeDeclarationTable :: Module -> DeclarationTable

64
src/Bang/Syntax/Pretty.hs
View File

@@ -1,64 +0,0 @@
module Bang.Syntax.Pretty(
ppModule
, ppDeclaration
, ppExpression
, ppType
, ppName
)
where
import Bang.Syntax.AST
import Data.Text.Lazy(Text, unpack)
import Text.PrettyPrint.Annotated
ppName :: Name -> Doc a
ppName (Name _ _ w t) = text' t <> colon <> integer (fromIntegral w)
ppModule :: Module -> Doc a
ppModule (Module name decls) =
vcat ([text "module" <> space <> ppName name, text ""] ++
map ppDeclaration decls)
ppDeclaration :: Declaration -> Doc a
ppDeclaration d =
case d of
TypeDeclaration n t ->
ppName n <> space <> text "::" <> space <> ppType t
ValueDeclaration n e ->
ppName n <> space <> text "=" <> space <> ppExpression e
PrimTypeDeclaration n t ->
text "primitive" <> space <> text "type" <> space <>
ppName n <> space <> text "=" <> space <> text' t
ppExpression :: Expression -> Doc a
ppExpression x =
case x of
ConstantExp _ v -> ppConstantValue v
ReferenceExp _ n -> ppName n
LambdaExp _ ns e ->
text "λ" <> space <> hsep (map ppName ns) <> space <> text "->" <>
space <> ppExpression e
ppConstantValue :: ConstantValue -> Doc a
ppConstantValue cv =
case cv of
ConstantInt 2 t -> text "0b" <> text' t
ConstantInt 8 t -> text "0o" <> text' t
ConstantInt 10 t -> text' t
ConstantInt 16 t -> text "0x" <> text' t
ConstantInt _ _ -> error "Internal error: bad base for constant"
ConstantChar c -> text' c
ConstantString s -> text' s
ConstantFloat f -> text' f
ppType :: Type -> Doc a
ppType t =
case t of
TypeUnit _ _ -> text "()"
TypePrim _ _ n -> text (unpack n)
TypeRef _ _ n -> ppName n
TypeLambda _ _ as b -> hsep (map ppType as) <> space <> text "->" <> space <> ppType b
TypeApp _ _ a b -> ppType a <> space <> ppType b
text' :: Text -> Doc a
text' = text . unpack

8
src/Bang/TypeInfer.hs
View File

@@ -3,14 +3,16 @@
module Bang.TypeInfer(runTypeInference)
where
runTypeInference :: a
runTypeInference = undefined
{- Better version
import Bang.Monad(Compiler, BangError(..), err,
runPass, getPassState, setPassState,
viewPassState, overPassState,
registerNewName, genName)
import Bang.Syntax.AST
import Bang.Syntax.Location(Location, unknownLocation)
import Bang.Syntax.ParserMonad(NameDatabase(..))
import Bang.Syntax.Pretty(ppName)
import Bang.Utils.Pretty(BangDoc)
import Control.Lens(set, view, over)
import Control.Lens.TH(makeLenses)
@@ -91,7 +93,7 @@ inferModule = undefined
runTypeInference :: NameDatabase -> Module -> Compiler ps Module
runTypeInference ndb mod = runInfer ndb (inferModule mod)
-}
-- data Scheme = Scheme [Name] Type
--
-- getName :: NameEnvironment -> Text -> Infer Name

7
src/Main.hs
View File

@@ -1,8 +1,7 @@
import Bang.CommandLine
import Bang.Monad
import Bang.Syntax.Lexer()
import Bang.CommandLine(getCommand, BangCommand(..), helpString)
import Bang.AST(ppModule)
import Bang.Monad(runCompiler)
import Bang.Syntax.Parser(runParser, parseModule)
import Bang.Syntax.Pretty(ppModule)
import Bang.TypeInfer(runTypeInference)
import Data.Version(showVersion)
import Paths_bang(version)