From 40c0517dd34c975c9f0fcb50bf0d7f20486e32c5 Mon Sep 17 00:00:00 2001 From: Adam Wick Date: Wed, 29 Jun 2016 18:01:17 -0700 Subject: [PATCH] Refactoring and remonadization. --- bang.cabal | 1 - src/Bang/CommandLine.hs | 30 ------ src/Bang/Monad.hs | 130 +++++++++++++++-------- src/Bang/Syntax/AST.hs | 1 + src/Bang/Syntax/Lexer.x | 90 ++++++++-------- src/Bang/Syntax/Location.hs | 35 +++++- src/Bang/Syntax/Parser.y | 189 ++++----------------------------- src/Bang/Syntax/ParserError.hs | 43 ++++++++ src/Bang/Syntax/ParserMonad.hs | 176 ++++++++++++++++++++++++++++++ src/Bang/Syntax/Token.hs | 30 +++--- src/Bang/TypeInfer.hs | 75 +++++-------- src/Bang/Utils/Pretty.hs | 10 +- src/Main.hs | 64 +++++------ 13 files changed, 477 insertions(+), 397 deletions(-) create mode 100644 src/Bang/Syntax/ParserError.hs create mode 100644 src/Bang/Syntax/ParserMonad.hs diff --git a/bang.cabal b/bang.cabal index cfed566..e73307c 100644 --- a/bang.cabal +++ b/bang.cabal @@ -21,7 +21,6 @@ executable bang containers >= 0.5.4 && < 0.8, lens >= 4.14 && < 4.16, llvm-pretty >= 0.4.0.1 && < 0.8, - monadLib >= 3.7.3 && < 3.9, optparse-applicative >= 0.12.1.0 && < 0.15, pretty >= 1.1.3.3 && < 1.4, text >= 1.2.2.1 && < 1.5 diff --git a/src/Bang/CommandLine.hs b/src/Bang/CommandLine.hs index 8008a1c..dc3f47f 100644 --- a/src/Bang/CommandLine.hs +++ b/src/Bang/CommandLine.hs @@ -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 diff --git a/src/Bang/Monad.hs b/src/Bang/Monad.hs index 0ce797c..67e13aa 100644 --- a/src/Bang/Monad.hs +++ b/src/Bang/Monad.hs @@ -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) diff --git a/src/Bang/Syntax/AST.hs b/src/Bang/Syntax/AST.hs index bc88eb3..5595c7f 100644 --- a/src/Bang/Syntax/AST.hs +++ b/src/Bang/Syntax/AST.hs @@ -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 diff --git a/src/Bang/Syntax/Lexer.x b/src/Bang/Syntax/Lexer.x index 4f0f23d..27a3016 100644 --- a/src/Bang/Syntax/Lexer.x +++ b/src/Bang/Syntax/Lexer.x @@ -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) - } diff --git a/src/Bang/Syntax/Location.hs b/src/Bang/Syntax/Location.hs index 4a13ed9..c2ddc8f 100644 --- a/src/Bang/Syntax/Location.hs +++ b/src/Bang/Syntax/Location.hs @@ -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 "" + Interactive -> text "" + 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 diff --git a/src/Bang/Syntax/Parser.y b/src/Bang/Syntax/Parser.y index 65a08fe..187a8d5 100644 --- a/src/Bang/Syntax/Parser.y +++ b/src/Bang/Syntax/Parser.y @@ -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 } diff --git a/src/Bang/Syntax/ParserError.hs b/src/Bang/Syntax/ParserError.hs new file mode 100644 index 0000000..2eefac7 --- /dev/null +++ b/src/Bang/Syntax/ParserError.hs @@ -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.") + + diff --git a/src/Bang/Syntax/ParserMonad.hs b/src/Bang/Syntax/ParserMonad.hs new file mode 100644 index 0000000..fbb5560 --- /dev/null +++ b/src/Bang/Syntax/ParserMonad.hs @@ -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) + + diff --git a/src/Bang/Syntax/Token.hs b/src/Bang/Syntax/Token.hs index cf5301a..e60c5db 100644 --- a/src/Bang/Syntax/Token.hs +++ b/src/Bang/Syntax/Token.hs @@ -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 "" diff --git a/src/Bang/TypeInfer.hs b/src/Bang/TypeInfer.hs index adbea9d..34c5512 100644 --- a/src/Bang/TypeInfer.hs +++ b/src/Bang/TypeInfer.hs @@ -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 diff --git a/src/Bang/Utils/Pretty.hs b/src/Bang/Utils/Pretty.hs index b15f205..1f9a991 100644 --- a/src/Bang/Utils/Pretty.hs +++ b/src/Bang/Utils/Pretty.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs index 572be08..bb49ff5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,53 +1,37 @@ import Bang.CommandLine -import Bang.Error(exit) import Bang.Monad -import Bang.Syntax.AST(Module) -import Bang.Syntax.Lexer(lexer) -import Bang.Syntax.Location -import Bang.Syntax.Parser(parseModule) +import Bang.Syntax.Lexer() +import Bang.Syntax.Parser(runParser, parseModule) import Bang.Syntax.Pretty(ppModule) -import Bang.TypeInfer(typeInfer) -import Control.Exception(tryJust) -import Control.Lens(view) -import Control.Monad(guard) -import Data.Text.Lazy(Text) -import qualified Data.Text.Lazy.IO as T import Data.Version(showVersion) import Paths_bang(version) -import System.IO.Error(isDoesNotExistError) import Text.PrettyPrint.Annotated(render) main :: IO () main = getCommand >>= \ cmd -> case cmd of - Lex o -> run o $ \ path body -> - do let ts = lexer (File path) (Just initialPosition) body - mapM_ (putStrLn . show) ts - Parse o -> run o $ withParsed $ \ mdl -> - putStrLn (render (ppModule mdl)) - TypeCheck o -> run o $ withParsed $ withInferred $ \ mdl -> - putStrLn (render (ppModule mdl)) --- Compile o -> run o $ withParsed $ withInferred $ \ mod -> --- putStrLn (render (ppModule mod)) + Parse o -> do mdl <- runCompiler cmd o (\ r t -> runParser r t parseModule) + putStrLn (render (ppModule mdl)) + TypeCheck _ -> undefined Help -> putStrLn helpString Version -> putStrLn ("Bang tool, version " ++ showVersion version) -run :: CommandsWithInputFile o => o -> (FilePath -> Text -> IO ()) -> IO () -run opts action = - do let path = view inputFile opts - mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path) - case mtxt of - Left _ -> exit ("Unable to open file '" ++ path ++ "'") - Right txt -> action path txt - -withParsed :: (Module -> IO ()) -> FilePath -> Text -> IO () -withParsed action path body = - case parseModule (File path) body of - Left err -> exit (show err) - Right mdl -> action mdl - -withInferred :: (Module -> IO ()) -> Module -> IO () -withInferred action mdl = - case typeInfer 0 mdl of - Left err -> exit (show err) - Right mdl' -> action mdl' +-- run :: CommandsWithInputFile o => o -> (FilePath -> Text -> IO ()) -> IO () +-- run opts action = +-- do let path = view inputFile opts +-- mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path) +-- case mtxt of +-- Left _ -> exit ("Unable to open file '" ++ path ++ "'") +-- Right txt -> action path txt +-- +-- withParsed :: (Module -> IO ()) -> FilePath -> Text -> IO () +-- withParsed action path body = +-- case parseModule (File path) body of +-- Left err -> exit (show err) +-- Right mdl -> action mdl +-- +-- withInferred :: (Module -> IO ()) -> Module -> IO () +-- withInferred action mdl = +-- case typeInfer 0 mdl of +-- Left err -> exit (show err) +-- Right mdl' -> action mdl'