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

Refactoring and remonadization.

Browse Source
This commit is contained in:
Adam Wick
2016-06-29 18:01:17 -07:00
parent e1821977ab
commit 40c0517dd3
13 changed files with 477 additions and 397 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
src/Bang/CommandLine.hs
View File

@@ -5,7 +5,6 @@ module Bang.CommandLine(
, CommandsWithOutputFile(..)
, CommandsWithVerbosity(..)
, BangCommand(..)
, LexerOptions(..)
, ParserOptions(..)
, getCommand
, helpString
@@ -47,32 +46,6 @@ optOutputFile = strOption (short 'o' <> long "output-file" <> metavar "FILE"
-- -----------------------------------------------------------------------------
data LexerOptions = LexerOptions {
_lexInputFile :: FilePath
, _lexOutputFile :: FilePath
, _lexVerbosity :: Verbosity
}
deriving (Show)
makeLenses ''LexerOptions
parseLexOptions :: Parser LexerOptions
parseLexOptions = LexerOptions <$> argument str (metavar "FILE")
<*> optOutputFile
<*> verboseOption
instance CommandsWithInputFile LexerOptions where
inputFile = lexInputFile
instance CommandsWithOutputFile LexerOptions where
outputFile = lexOutputFile
instance CommandsWithVerbosity LexerOptions where
verbosity = lexVerbosity
-- -----------------------------------------------------------------------------
data ParserOptions = ParserOptions {
_parseInputFile :: FilePath
, _parseOutputFile :: FilePath
@@ -124,7 +97,6 @@ instance CommandsWithVerbosity TypeCheckOptions where
-- -----------------------------------------------------------------------------
data BangCommand = Help
| Lex LexerOptions
| Parse ParserOptions
| TypeCheck TypeCheckOptions
| Version
@@ -134,11 +106,9 @@ bangOperation :: Parser BangCommand
bangOperation = subparser $
command "help" (pure Help `withInfo` "Describe common commands.") <>
command "version" (pure Version `withInfo` "Display version information.") <>
command "lex" (parseLex `withInfo` "Lex a file into its component tokens.") <>
command "parse" (parseParse `withInfo` "Parse a file into its AST.") <>
command "typeCheck" (parseTCheck `withInfo` "Type check a file.")
where
parseLex = Lex <$> parseLexOptions
parseParse = Parse <$> parseParseOptions
parseTCheck = TypeCheck <$> parseTypeCheckOptions

130
src/Bang/Monad.hs
View File

@@ -1,41 +1,56 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Bang.Monad(
Compiler
, (==>), (==>|)
, BangError(..)
, BangWarning(..)
, runCompiler
, runPass
, getPassState, setPassState, overPassState, viewPassState
, genName, genTypeRef, genVarRef
, warn, err
)
where
import Bang.Syntax.AST
import Bang.Syntax.Location(unknownLocation)
import Bang.Utils.Pretty(BangDoc)
import Data.Text.Lazy(pack)
import MonadLib
import Text.PrettyPrint.Annotated(Doc)
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)
import Control.Exception(tryJust)
import Control.Lens(Lens', over, set, view)
import Control.Lens.TH(makeLenses)
import Control.Monad(guard)
import Data.Text.Lazy(Text, pack)
import qualified Data.Text.Lazy.IO as T
import System.Exit(ExitCode(..), exitWith)
import System.IO.Error(isDoesNotExistError)
import Text.PrettyPrint.Annotated(text, ($+$), nest, render)
class BangError e where
ppError :: e -> BangDoc
ppError :: e -> (Maybe Location, BangDoc)
class BangWarning w where
ppWarning :: w -> BangDoc
instance BangWarning w => BangError w where
ppError = ppWarning
ppWarning :: w -> (Maybe Location, BangDoc)
data CompilerState state = CompilerState {
csNextIdent :: Word
, csPromoteWarnings :: Bool
, csWarnings :: [BangDoc]
, csPassState :: state
_csNextIdent :: !Word
, _csPromoteWarnings :: !Bool
, _csWarnings :: [BangDoc]
, _csPassState :: !state
}
initialState :: CompilerState ()
initialState = CompilerState 1 False [] ()
makeLenses ''CompilerState
initialState :: BangCommand -> CompilerState ()
initialState _ = CompilerState 1 False [] ()
-- -----------------------------------------------------------------------------
newtype Compiler s a =
Compiler { unCompiler :: CompilerState s -> IO (CompilerState s, a) }
@@ -56,33 +71,46 @@ instance Monad (Compiler s) where
do (st', a) <- unCompiler m st
unCompiler (k a) st')
class PassTransition s1 s2 where
transition :: s1 -> s2
runCompiler :: CommandsWithInputFile o =>
BangCommand -> o ->
(Origin -> Text -> Compiler () a) ->
IO a
runCompiler cmd opts action =
do let path = view inputFile opts
orig = File path
mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path)
case mtxt of
Left _ -> exit ("Unable to open file '" ++ path ++ "'")
Right txt -> snd `fmap` unCompiler (action orig txt) (initialState cmd)
(==>) :: PassTransition s1 s2 =>
Compiler s1 a ->
(a -> Compiler s2 b) ->
Compiler s1 b
m1 ==> k = Compiler (\ st ->
do (st', a) <- unCompiler m1 st
let next = k a
ps' = transition (csPassState st')
st'' = st'{ csPassState = ps' }
(_, b) <- unCompiler next st''
return (st', b))
runPass :: s2 -> (Compiler s2 a) -> Compiler s1 a
runPass s2 action =
Compiler (\ cst1 ->
do let cst2 = set csPassState s2 cst1
s1 = view csPassState cst1
(cst2', v) <- unCompiler action cst2
return (set csPassState s1 cst2', v))
(==>|) :: PassTransition s1 s2 =>
Compiler s1 a ->
Compiler s2 b ->
Compiler s1 b
m1 ==>| m2 = m1 ==> (const m2)
getPassState :: Compiler s s
getPassState = Compiler (\ st -> return (st, view csPassState st))
setPassState :: s -> Compiler s ()
setPassState ps' = Compiler (\ st -> return (set csPassState ps' st, ()))
overPassState :: (s -> s) -> Compiler s ()
overPassState f = Compiler (\ st -> return (over csPassState f st, ()))
viewPassState :: Lens' s b -> Compiler s b
viewPassState l = Compiler (\ st -> return (st, view (csPassState . l) st))
-- -----------------------------------------------------------------------------
genName :: NameEnvironment -> Compiler s Name
genName env = Compiler (\ st ->
do let current = csNextIdent st
do let current = view csNextIdent st
str = "gen:" ++ show current
res = Name unknownLocation env current (pack str)
return (st{ csNextIdent = current + 1 }, res))
return (over csNextIdent (+1) st, res))
genTypeRef :: Kind -> Compiler s Type
genTypeRef k = TypeRef unknownLocation k `fmap` genName TypeEnv
@@ -90,10 +118,20 @@ genTypeRef k = TypeRef unknownLocation k `fmap` genName TypeEnv
genVarRef :: Compiler s Expression
genVarRef = ReferenceExp unknownLocation `fmap` genName VarEnv
-- -----------------------------------------------------------------------------
data WErrorWarning w = WErrorWarning w
instance BangWarning w => BangError (WErrorWarning w) where
ppError (WErrorWarning w) =
let (loc, wdoc) = ppWarning w
edoc = text "Warning lifted to error by -WError:" $+$ nest 3 wdoc
in (loc, edoc)
warn :: BangWarning w => w -> Compiler s ()
warn w = Compiler (\ st ->
if csPromoteWarnings st
then runError w
if view csPromoteWarnings st
then runError (WErrorWarning w)
else runWarning w >> return (st, ()))
err :: BangError w => w -> Compiler s a
@@ -103,5 +141,9 @@ runWarning :: BangWarning w => w -> IO ()
runWarning = undefined
runError :: BangError w => w -> IO a
runError = undefined
runError e =
do putStrLn (go (ppError e))
exitWith (ExitFailure 1)
where
go (Nothing, doc) = render doc
go (Just a, doc) = render (ppLocation a $+$ nest 3 doc)

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

@@ -59,6 +59,7 @@ instance Eq Type where
(TypeLambda _ _ at et) == (TypeLambda _ _ bt ft) = (at == bt) && (et == ft)
(TypeApp _ _ at bt) == (TypeApp _ _ ct dt) = (at == ct) && (bt == dt)
(TypeForAll ns t) == (TypeForAll ms u) = (ns == ms) && (t == u)
_ == _ = False
kind :: Type -> Kind
kind (TypeUnit _ k) = k

90
src/Bang/Syntax/Lexer.x
View File

@@ -3,14 +3,21 @@
{
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS -w #-}
module Bang.Syntax.Lexer(lexer)
module Bang.Syntax.Lexer(
AlexReturn(..)
, AlexInput(..)
, alexScan
)
where
import Bang.Syntax.Location
import Bang.Syntax.Name
import Bang.Syntax.Token
import Data.Char(isSpace, isAscii, ord)
import Bang.Syntax.Location(Location(..), Located(..), Origin(..),
Position(..), advanceWith, advanceWith',
locatedAt, initialPosition)
import Bang.Syntax.Token(Token(..), Fixity(..))
import Data.Char(isAscii, ord)
import Data.Int(Int64)
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map
import Data.Maybe(fromMaybe)
import Data.Text.Lazy(Text)
import qualified Data.Text.Lazy as T
@@ -29,13 +36,13 @@ $typestart = [A-Z\_]
$valstart = [a-z\_]
$identrest = [a-zA-Z0-9\_\.]
$opident = [\~\!\@\#\$\%\^\&\*\+\-\=\.\<\>\?\_\|:]
$escape_char = [abfnrtv'\"\\]
$escape_char = [abfnrtv'\"\\] --"
:-
-- Whitespace
$white+ ;
"/*"[.\n]*"*/" ;
"/*"[.\n]*"*/" ;
-- Numbers
$decdigit+ { emitI 0 (IntTok 10) }
@@ -48,12 +55,12 @@ $escape_char = [abfnrtv'\"\\]
-- Identifier
$typestart $identrest* { emitS TypeIdent }
$valstart $identrest* { emitS ValIdent }
$opident+ { emitS (OpIdent (LeftAssoc 9)) }
$opident+ { emitO }
-- Characters and Strings
['].['] { emitS CharTok }
['] [\\] $escape_char ['] { emitS CharTok }
[\"] ([^\"] | [\n] | ([\\] $escape_char))* [\"] { emitS StringTok }
[\"] ([^\"] | [\n] | ([\\] $escape_char))* [\"] { emitS StringTok } --"
-- Symbols
"(" { emitT "(" }
@@ -69,26 +76,37 @@ $escape_char = [abfnrtv'\"\\]
{
lexer :: Origin -> Maybe Position -> Text -> [Located Token]
lexer src mbPos txt = go (AlexInput startPos txt)
where
startPos = fromMaybe initialPosition mbPos
go input =
case alexScan input 0 of
AlexEOF -> let AlexInput pos _ = input
loc = Location src pos pos
in [EOFTok `locatedAt` loc]
AlexError input' -> let AlexInput pos text = input'
(as, bs) = T.break isSpace text
pos' = advanceWith' pos as
input'' = AlexInput pos' bs
loc = Location src pos pos'
in (ErrorTok as `locatedAt` loc) : go input''
AlexSkip input' _ -> go input'
AlexToken input' len act -> act src len input : go input'
type AlexAction = Origin -> Map Text Fixity -> Int -> AlexInput -> Located Token
data AlexInput = AlexInput !Position Text
emitT :: Text -> AlexAction
emitT t = emitS (const (Special t))
emitS :: (Text -> Token) -> AlexAction
emitS mk src _ len (AlexInput pos t) = token `locatedAt` loc
where
txt = T.take (fromIntegral len) t
token = mk txt
loc = Location src pos (pos `advanceWith'` txt)
emitI :: Int64 -> (Text -> Token) -> AlexAction
emitI dropCount mk src _ len (AlexInput pos t) = token `locatedAt` loc
where
baseText = T.take (fromIntegral len) t
txt = T.drop dropCount baseText
token = mk txt
loc = Location src pos (pos `advanceWith'` baseText)
emitO :: AlexAction
emitO src fixTable len (AlexInput pos t) =
case Map.lookup baseText fixTable of
Nothing -> OpIdent (LeftAssoc 9) baseText `locatedAt` loc
Just f -> OpIdent f baseText `locatedAt` loc
where
baseText = T.take (fromIntegral len) t
loc = Location src pos (pos `advanceWith'` baseText)
alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
alexGetByte (AlexInput p t) =
do (c, rest) <- T.uncons t
@@ -97,24 +115,4 @@ alexGetByte (AlexInput p t) =
byteForChar c | isAscii c = fromIntegral (ord c)
| otherwise = 0
type AlexAction = Origin -> Int -> AlexInput -> Located Token
emitT :: Text -> AlexAction
emitT str = emitS (const (Special str))
emitS :: (Text -> Token) -> AlexAction
emitS mk src len (AlexInput pos t) = token `locatedAt` loc
where
txt = T.take (fromIntegral len) t
token = mk txt
loc = Location src pos (pos `advanceWith'` txt)
emitI :: Int64 -> (Text -> Token) -> AlexAction
emitI dropCount mk src len (AlexInput pos t) = token `locatedAt` loc
where
baseText = T.take (fromIntegral len) t
txt = T.drop dropCount baseText
token = mk txt
loc = Location src pos (pos `advanceWith'` baseText)
}

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

@@ -1,21 +1,27 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.Syntax.Location(
Position, posRow, posColumn, posOffset
, ppPosition
, initialPosition
, advanceWith, advanceWith'
, showPosition
, Origin(..)
, ppOrigin
, Location(Location)
, locSource, locStart, locEnd
, ppLocation
, Located(..)
, locatedAt
, unknownLocation
)
where
import Bang.Utils.Pretty(BangDoc, word)
import Control.Lens
import Control.Lens.TH(makeLenses)
import Data.Monoid((<>))
import Data.Text.Lazy(Text)
import qualified Data.Text.Lazy as T
import Text.PrettyPrint.Annotated(colon, parens, text)
data Position = Position {
_posRow :: Word
@@ -26,6 +32,9 @@ data Position = Position {
makeLenses ''Position
ppPosition :: Position -> BangDoc
ppPosition (Position r c _) = word r <> colon <> word c
initialPosition :: Position
initialPosition = Position 1 1 0
@@ -43,14 +52,18 @@ advanceWith' pos txt =
Nothing -> pos
Just (c, rest) -> advanceWith' (pos `advanceWith` c) rest
showPosition :: Position -> String
showPosition (Position r c _) = show r ++ ":" ++ show c
data Origin = Unknown
| Interactive
| File FilePath
deriving (Eq, Show)
ppOrigin :: Origin -> BangDoc
ppOrigin x =
case x of
Unknown -> text "<unknown>"
Interactive -> text "<interactive>"
File f -> text f
data Location = Location {
_locSource :: Origin
, _locStart :: Position
@@ -60,6 +73,20 @@ data Location = Location {
makeLenses ''Location
ppLocation :: Location -> BangDoc
ppLocation loc
| start == end = ppOrigin src <> colon <> ppPosition start
| view posRow start == view posRow end =
ppOrigin src <> colon <> word (view posRow start) <> colon <>
word (view posColumn start) <> text "–" <> word (view posColumn end)
| otherwise =
ppOrigin src <> colon <> parens (ppPosition start) <> text "–" <>
parens (ppPosition end)
where
src = view locSource loc
start = view locStart loc
end = view locEnd loc
data Located a = Located !Location a
instance Show a => Show (Located a) where

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

@@ -5,26 +5,24 @@
{-# LANGUAGE OverloadedStrings #-}
{-# OPTION_GHC -w #-}
module Bang.Syntax.Parser(
parseModule
, ParseError, showError
, lexWithLayout
runParser
, parseModule
)
where
import Bang.Syntax.AST
import Bang.Syntax.Lexer
import Bang.Syntax.Location
import Bang.Syntax.Token
import Data.Char(digitToInt)
import Data.List(union)
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map
import Data.Maybe(catMaybes)
import Data.Text.Lazy(Text)
import qualified Data.Text.Lazy as T
import MonadLib
import Debug.Trace
import Bang.Monad(err)
import Bang.Syntax.AST(Module(..), Name(..), NameEnvironment(..),
Declaration(..), Expression(..), Type(..), Kind(..),
ConstantValue(..))
import Bang.Syntax.Location(Located(..), Origin, Position)
import Bang.Syntax.ParserError(ParserError(..))
import Bang.Syntax.ParserMonad(Parser, addFixities, registerName,
unregisterNames, lookupName, parseError,
runNextToken, runParser)
import Bang.Syntax.Token(Token(..), Fixity(..))
import Control.Monad(forM)
import Data.List(union)
import Data.Text.Lazy(Text)
}
@@ -141,7 +139,7 @@ ValueDeclLHS :: { (Expression -> Declaration, [Name]) }
{%
case $1 of
[] ->
raise (InternalError $2 "ValDeclLHS")
err (InternalError $2 "ValDeclLHS")
[Located src (ValIdent rawName)] ->
do name <- registerName True src VarEnv rawName
return (ValueDeclaration name, [name])
@@ -269,158 +267,7 @@ listopt(p)
{
newtype Parser a = Parser {
unParser :: StateT ParserState (ExceptionT ParseError Id) a
}
deriving (Functor, Applicative, Monad)
data ParseError = LexError Location Text
| ParseError Location Token
| RedefinitionError Location Location Text
| InternalError Location Text
| UnboundVariable Location Text
| UnexpectedEOF
deriving (Show)
showError :: ParseError -> String
showError (LexError l t) = show l ++ ": lexer error around " ++ T.unpack t
showError (ParseError l t) = show l ++ ": parse error around " ++ showToken t
showError UnexpectedEOF = "Unexpected end of file"
data ParserState = ParserState {
psPrecTable :: Map Text Fixity
, psTokenStream :: [Located Token]
, psNameDatabase :: Map (NameEnvironment, Text) Name
, psNextIdent :: Word
}
initialState :: [Located Token] -> ParserState
initialState tokenStream = ParserState {
psPrecTable = Map.empty
, psTokenStream = tokenStream
, psNameDatabase = Map.empty
, psNextIdent = 1
}
instance StateM Parser ParserState where
get = Parser get
set = Parser . set
instance ExceptionM Parser ParseError where
raise = Parser . raise
instance RunExceptionM Parser ParseError where
try m = Parser (try (unParser m))
addFixities :: Location ->
(Word -> Fixity) -> Located Token -> [Located Token] ->
Parser ()
addFixities src fixityBuilder lval names =
do value <- processInteger lval
let fixity = fixityBuilder value
forM_ names $ \ tok ->
do state <- get
name <- forceNameDefined VarEnv src tok state
let table' = Map.insert name fixity (psPrecTable state)
set state{ psPrecTable = table' }
where
processInteger x =
case x of
Located _ (IntTok base text) ->
return (makeNumeric base text 0)
_ ->
raise (InternalError src "Non-number in fixity?")
--
makeNumeric base text acc =
case T.uncons text of
Nothing -> acc
Just (x, rest) ->
let acc' = (acc * base) + charValue x
in makeNumeric base rest acc'
--
charValue = fromIntegral . digitToInt
--
tokenName t =
case t of
Located _ (TypeIdent x) -> x
Located _ (ValIdent x) -> x
Located _ (OpIdent _ x) -> x
_ ->
error "Internal error (tokenName in Parser.y)"
--
forceNameDefined env src token state =
do let name = tokenName token
case Map.lookup (env, name) (psNameDatabase state) of
Just _ -> return name
Nothing -> raise (UnboundVariable src name)
registerName :: Bool -> Location -> NameEnvironment -> Text -> Parser Name
registerName redefOk loc env name =
do state <- get
let key = (env, name)
db = psNameDatabase state
case Map.lookup key db of
Nothing ->
do let res = Name loc env (psNextIdent state) name
state' = state {
psNameDatabase = Map.insert key res db
, psNextIdent = 1 + psNextIdent state
}
set state'
return res
Just res | redefOk ->
return res
Just (Name origLoc _ _ _) ->
raise (RedefinitionError loc origLoc name)
unregisterNames :: NameEnvironment -> [Name] -> Parser ()
unregisterNames env names =
do state <- get
let db = psNameDatabase state
db' = foldr (\ (Name _ _ _ n) m -> Map.delete (env, n) m) db names
set state{ psNameDatabase = db' }
lookupName :: Location -> NameEnvironment -> Text -> Parser Name
lookupName loc env name =
do state <- get
case Map.lookup (env, name) (psNameDatabase state) of
Nothing ->
raise (UnboundVariable loc name)
Just name ->
return name
runNextToken :: (Located Token -> Parser a) -> Parser a
runNextToken action =
do state <- get
case psTokenStream state of
[] ->
raise (InternalError unknownLocation "End of stream, but no EOF?")
(eof@(Located _ EOFTok) : _) ->
action eof -- leave this on at the end of the stream
(x : rest) ->
do set (state{ psTokenStream = rest })
action x
lexWithLayout :: Origin -> Position -> Text -> [Located Token]
lexWithLayout src pos txt = lexer src (Just pos) txt
parseModule :: Origin -> Text -> Either ParseError Module
parseModule src txt =
let parserM = unParser top_module
excM = runStateT (initialState tokenStream)
(parserM :: StateT ParserState (ExceptionT ParseError Id) Module)
idM = runExceptionT (excM :: ExceptionT ParseError Id (Module, ParserState))
resWState = runId idM
in fmap fst resWState
where
tokenStream = lexWithLayout src initialPosition txt
parseError :: Located Token -> Parser a
parseError t =
case t of
Located _ EOFTok -> raise UnexpectedEOF
Located p (ErrorTok t) -> raise (LexError p t)
Located p t -> raise (ParseError p t)
parseModule :: Parser Module
parseModule = top_module
}

43
src/Bang/Syntax/ParserError.hs Normal file
View File

@@ -0,0 +1,43 @@
module Bang.Syntax.ParserError(
ParserError(..)
)
where
import Data.Text.Lazy(Text)
import Bang.Monad(BangError(..))
import Bang.Syntax.Location(Location, ppLocation)
import Bang.Syntax.Token(Token, ppToken)
import Bang.Utils.Pretty(BangDoc, text')
import Text.PrettyPrint.Annotated((<+>), ($+$), text, quotes, text, nest)
data ParserError = LexError Location Text
| ParseError Location Token
| RedefinitionError Location Location Text
| InternalError Location Text
| UnboundVariable Location Text
| UnexpectedEOF
deriving (Show)
instance BangError ParserError where
ppError = prettyError
prettyError :: ParserError -> (Maybe Location, BangDoc)
prettyError e =
case e of
LexError l t ->
(Just l, text "Lexical error around token" <+> quotes (text' t))
ParseError l t ->
(Just l, text "Parser error around token" <+> quotes (ppToken t))
RedefinitionError errLoc origLoc t ->
let line1 = text "Variable" <+> quotes (text' t) <+> text "is redefined: "
line2 = text "Original definition:" <+> ppLocation origLoc
line3 = text "Redefinition:" <+> ppLocation errLoc
in (Nothing, line1 $+$ nest 3 (line2 $+$ line3))
InternalError loc t ->
(Just loc, text' t)
UnboundVariable loc t ->
(Just loc, text "Unbound variable" <+> quotes (text' t))
UnexpectedEOF ->
(Nothing, text "Unexpected end of file.")

176
src/Bang/Syntax/ParserMonad.hs Normal file
View File

@@ -0,0 +1,176 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Bang.Syntax.ParserMonad(
Parser
, runParser
, addFixities
, registerName
, unregisterNames
, lookupName
, parseError
, runNextToken
)
where
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,
advanceWith', locatedAt)
import Bang.Syntax.ParserError(ParserError(..))
import Bang.Syntax.Token(Token(..), Fixity)
import Control.Lens(view, set, over)
import Control.Lens.TH(makeLenses)
import Control.Monad(forM_)
import Data.Char(digitToInt, isSpace)
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map
import Data.Text.Lazy(Text)
import qualified Data.Text.Lazy as T
data ParserState = ParserState {
_psPrecTable :: Map Text Fixity
, _psNameDatabase :: Map (NameEnvironment, Text) Name
, _psNextIdent :: Word
, _psOrigin :: Origin
, _psLexerState :: AlexInput
}
makeLenses ''ParserState
type Parser a = Compiler ParserState a
runParser :: Origin -> Text -> Parser a -> Compiler ps a
runParser origin stream action = runPass pstate action
where
initInput = AlexInput initialPosition stream
pstate = ParserState Map.empty Map.empty 1 origin initInput
-- -----------------------------------------------------------------------------
addFixities :: Location ->
(Word -> Fixity) -> Located Token -> [Located Token] ->
Parser ()
addFixities src fixityBuilder lval names =
do value <- processInteger lval
let fixity = fixityBuilder value
forM_ names $ \ tok ->
do state <- getPassState
name <- forceNameDefined VarEnv src tok state
overPassState (over psPrecTable (Map.insert name fixity))
where
processInteger x =
case x of
Located _ (IntTok base text) ->
return (makeNumeric base text 0)
_ ->
err (InternalError src "Non-number in fixity?")
--
makeNumeric base text acc =
case T.uncons text of
Nothing -> acc
Just (x, rest) ->
let acc' = (acc * base) + charValue x
in makeNumeric base rest acc'
--
charValue = fromIntegral . digitToInt
--
tokenName t =
case t of
Located _ (TypeIdent x) -> x
Located _ (ValIdent x) -> x
Located _ (OpIdent _ x) -> x
_ ->
error "Internal error (tokenName in Parser.y)"
--
forceNameDefined env loc token state =
do let name = tokenName token
case Map.lookup (env, name) (view psNameDatabase state) of
Just _ -> return name
Nothing -> err (UnboundVariable loc name)
getFixities :: Parser (Map Text Fixity)
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 = Name loc env (view psNextIdent state) name
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)
unregisterNames :: NameEnvironment -> [Name] -> Parser ()
unregisterNames env names =
do db <- viewPassState psNameDatabase
let db' = foldr (\ (Name _ _ _ n) m -> Map.delete (env, 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
where
go state@(AlexInput initPos _) =
case alexScan state 0 of
AlexEOF ->
do orig <- getOrigin
parseAction (EOFTok `locatedAt` Location orig initPos initPos)
AlexError (AlexInput pos text) ->
do let (as, bs) = T.break isSpace text
pos' = advanceWith' pos as
input' = AlexInput pos' bs
setLexerState input'
orig <- getOrigin
parseAction (ErrorTok as `locatedAt` Location orig initPos initPos)
AlexSkip input' _ ->
go input'
AlexToken input' len lexAction ->
do setLexerState input'
src <- getOrigin
table <- getFixities
parseAction (lexAction src table len state)
-- -----------------------------------------------------------------------------
getOrigin :: Parser Origin
getOrigin = viewPassState psOrigin
getLexerState :: Parser AlexInput
getLexerState = viewPassState psLexerState
setLexerState :: AlexInput -> Parser ()
setLexerState lst = overPassState (set psLexerState lst)
-- -----------------------------------------------------------------------------
parseError :: Located Token -> Parser a
parseError t =
case t of
Located _ EOFTok -> err UnexpectedEOF
Located p (ErrorTok tok) -> err (LexError p tok)
Located p tok -> err (ParseError p tok)

30
src/Bang/Syntax/Token.hs
View File

@@ -1,12 +1,14 @@
module Bang.Syntax.Token(
Token(..)
, Fixity(..)
, showToken
, ppToken
)
where
import Data.Text.Lazy(Text)
import qualified Data.Text.Lazy as T
import Bang.Utils.Pretty(BangDoc, text')
import Data.Monoid((<>))
import Data.Text.Lazy(Text)
import Text.PrettyPrint.Annotated(quotes, doubleQuotes, text, parens)
data Token = CharTok Text
| FloatTok Text
@@ -25,14 +27,14 @@ data Fixity = LeftAssoc Word
| NonAssoc Word
deriving (Show)
showToken :: Token -> String
showToken (CharTok t) = "'" ++ T.unpack t ++ "'"
showToken (FloatTok t) = T.unpack t
showToken (IntTok _ t) = T.unpack t
showToken (OpIdent _ t) = T.unpack t
showToken (Special t) = T.unpack t
showToken (StringTok t) = "\"" ++ T.unpack t ++ "\""
showToken (TypeIdent t) = T.unpack t
showToken (ValIdent t) = T.unpack t
showToken (ErrorTok t) = "ERROR(" ++ T.unpack t ++ ")"
showToken EOFTok = "EOF"
ppToken :: Token -> BangDoc
ppToken (CharTok t) = quotes (text' t)
ppToken (FloatTok t) = text' t
ppToken (IntTok _ t) = text' t
ppToken (OpIdent _ t) = text' t
ppToken (Special t) = text' t
ppToken (StringTok t) = doubleQuotes (text' t)
ppToken (TypeIdent t) = text' t
ppToken (ValIdent t) = text' t
ppToken (ErrorTok t) = text "ERROR" <> parens (text' t)
ppToken EOFTok = text "<EOF>"

75
src/Bang/TypeInfer.hs
View File

@@ -3,21 +3,19 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
module Bang.TypeInfer(typeInfer)
module Bang.TypeInfer
where
import Bang.Monad(Compiler, BangError(..), err,
getPassState, setPassState)
import Bang.Syntax.AST
import Bang.Syntax.Location(unknownLocation)
import Control.Lens(view, over)
import Control.Lens.TH(makeLenses)
import Data.List(union, nub, concat, intersect)
import Data.List(union, nub, concat)
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map
import Data.Text.Lazy(pack)
import MonadLib(StateT, ExceptionT, Id,
StateM(..), ExceptionM(..), RunExceptionM(..),
runStateT, runExceptionT, runId,
get, raise)
-- -----------------------------------------------------------------------------
@@ -36,7 +34,7 @@ nullSubstitution = Map.empty
infixr 4 @@
(@@) :: Substitution -> Substitution -> Substitution
(@@) s1 s2 =
let s2' = Map.map (\ t -> apply s1 t) s1
let s2' = Map.map (\ t -> apply s1 t) s2
in Map.union s2' s1
-- -----------------------------------------------------------------------------
@@ -49,6 +47,9 @@ data InferenceError = UnificationError Type Type
| MergeFailure Substitution Substitution
deriving (Show)
instance BangError InferenceError where
ppError = undefined
data InferenceState = InferenceState {
_istCurrentSubstitution :: Substitution
, _istNextIdentifier :: Word
@@ -56,26 +57,13 @@ data InferenceState = InferenceState {
makeLenses ''InferenceState
newtype Infer a = Infer {
unInfer :: StateT InferenceState (ExceptionT InferenceError Id) a
}
deriving (Functor, Applicative, Monad)
instance StateM Infer InferenceState where
get = Infer get
set = Infer . set
instance ExceptionM Infer InferenceError where
raise = Infer . raise
instance RunExceptionM Infer InferenceError where
try m = Infer (try (unInfer m))
type Infer a = Compiler InferenceState a
-- -----------------------------------------------------------------------------
merge :: Substitution -> Substitution -> Infer Substitution
merge s1 s2 | agree = return (Map.union s1 s2)
| otherwise = raise (MergeFailure s1 s2)
| otherwise = err (MergeFailure s1 s2)
where
names = Map.keys (Map.intersection s1 s2)
agree = all (\ v ->
@@ -93,15 +81,15 @@ mostGeneralUnifier t1 t2 =
(u@(TypeRef _ _ _), t) -> varBind u t
(t, u@(TypeRef _ _ _)) -> varBind u t
(TypePrim _ _ tc1, TypePrim _ _ tc2) | tc1 == tc2 -> return nullSubstitution
(t1, t2) -> raise (UnificationError t1 t2)
_ -> err (UnificationError t1 t2)
varBind :: Type -> Type -> Infer Substitution
varBind (TypeRef _ k u) t
| TypeRef _ _ u' <- t, u' == u = return nullSubstitution
| u `elem` tv t = raise (OccursCheckFails u t)
| k /= kind t = raise (KindCheckFails u t)
| otherwise = return (u ⟼ t)
varBind = undefined
-- | TypeRef _ _ u' <- t, u' == u = return nullSubstitution
-- | u `elem` tv t = err (OccursCheckFails u t)
-- | k /= kind t = err (KindCheckFails u t)
-- | otherwise = return (u ⟼ t)
--
match :: Type -> Type -> Infer Substitution
match t1 t2 =
case (t1, t2) of
@@ -111,22 +99,22 @@ match t1 t2 =
merge sl sr
(TypeRef _ k u, t) | k == kind t -> return (u ⟼ t)
(TypePrim _ _ tc1, TypePrim _ _ tc2) | tc1 == tc2 -> return nullSubstitution
(t1, t2) -> raise (MatchFailure t1 t2)
_ -> err (MatchFailure t1 t2)
data Scheme = Forall [Kind] Type
instance Types Scheme where
apply s (Forall ks t) = Forall ks (apply s t)
tv (Forall ks qt) = tv qt
tv (Forall _ qt) = tv qt
data Assumption = Name :>: Scheme
instance Types Assumption where
apply s (i :>: sc) = i :>: (apply s sc)
tv (i :>: sc) = tv sc
tv (_ :>: sc) = tv sc
find :: Name -> [Assumption] -> Infer Scheme
find i [] = raise (UnboundIdentifier i)
find i [] = err (UnboundIdentifier i)
find i ((i' :>: sc) : as) | i == i' = return sc
| otherwise = find i as
@@ -146,12 +134,12 @@ instance Types [Type] where
tv = nub . concat . map tv
getSubstitution :: Infer Substitution
getSubstitution = view istCurrentSubstitution `fmap` get
getSubstitution = view istCurrentSubstitution `fmap` getPassState
extendSubstitution :: Substitution -> Infer ()
extendSubstitution s' =
do s <- get
set (over istCurrentSubstitution (s' @@) s)
do s <- getPassState
setPassState (over istCurrentSubstitution (s' @@) s)
unify :: Type -> Type -> Infer ()
unify t1 t2 =
@@ -161,8 +149,8 @@ unify t1 t2 =
gensym :: Kind -> Infer Type
gensym k =
do s <- get
set (over istNextIdentifier (+1) s)
do s <- getPassState
setPassState (over istNextIdentifier (+1) s)
let num = view istNextIdentifier s
str = "gensym:" ++ show num
name = Name unknownLocation TypeEnv num (pack str)
@@ -188,21 +176,16 @@ freshInst = undefined
inferExpression :: ClassEnvironment -> [Assumption] ->
Expression ->
Infer ([Predicate], Type)
inferExpression classEnv assumpts expr =
inferExpression _classEnv assumpts expr =
case expr of
ConstantExp _ cv -> inferConstant cv
ReferenceExp _ n -> do sc <- find n assumpts
(ps :=> t) <- freshInst sc
return (ps, t)
LambdaExp _ n e -> error "FIXME, here"
LambdaExp _ _ _ -> error "FIXME, here"
infer :: Module -> Infer Module
infer = undefined
typeInfer :: Word -> Module -> Either InferenceError Module
typeInfer gensymState mdl =
let inferM = unInfer (infer mdl)
excM = runStateT (InferenceState nullSubstitution gensymState) inferM
idM = runExceptionT excM
resWState = runId idM
in fmap fst resWState
typeInfer = undefined

10
src/Bang/Utils/Pretty.hs
View File

@@ -1,12 +1,20 @@
module Bang.Utils.Pretty(
BangDoc
, Annotation(..)
, text'
, word
)
where
import Text.PrettyPrint.Annotated(Doc)
import Data.Text.Lazy(Text, unpack)
import Text.PrettyPrint.Annotated(Doc, text, integer)
type BangDoc = Doc Annotation
data Annotation = KeywordAnnotation
text' :: Text -> Doc a
text' = text . unpack
word :: Word -> Doc a
word = integer . fromIntegral