Refactoring and remonadization.

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

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
 

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.CommandLine(BangCommand, CommandsWithInputFile(..))
-import Bang.Syntax.Location(unknownLocation)
+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 Data.Text.Lazy(pack)
+import           Control.Exception(tryJust)
-import MonadLib
+import           Control.Lens(Lens', over, set, view)
-import Text.PrettyPrint.Annotated(Doc)
+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
+  ppWarning :: w -> (Maybe Location, BangDoc)
-
-instance BangWarning w => BangError w where
-  ppError = ppWarning
 
 data CompilerState state = CompilerState {
-       csNextIdent       :: Word
+       _csNextIdent       :: !Word
-     , csPromoteWarnings :: Bool
+     , _csPromoteWarnings :: !Bool
-     , csWarnings        :: [BangDoc]
+     , _csWarnings        :: [BangDoc]
-     , csPassState       :: state
+     , _csPassState       :: !state
      }
 
-initialState :: CompilerState ()
+makeLenses ''CompilerState
-initialState = CompilerState 1 False [] ()
+
+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
+runCompiler :: CommandsWithInputFile o =>
-  transition :: s1 -> s2
+               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 =>
+runPass :: s2 -> (Compiler s2 a) -> Compiler s1 a
-         Compiler s1 a ->
+runPass s2 action =
-         (a -> Compiler s2 b) ->
+  Compiler (\ cst1 ->
-         Compiler s1 b
+             do let cst2 = set csPassState s2 cst1
-m1 ==> k = Compiler (\ st ->
+                    s1   = view csPassState cst1
-                        do (st', a) <- unCompiler m1 st
+                (cst2', v) <- unCompiler action cst2
-                           let next = k a
+                return (set csPassState s1 cst2', v))
-                               ps'  = transition (csPassState st')
-                               st'' = st'{ csPassState = ps' }
-                           (_, b) <- unCompiler next st''
-                           return (st', b))
 
-(==>|) :: PassTransition s1 s2 =>
+getPassState :: Compiler s s
-          Compiler s1 a ->
+getPassState = Compiler (\ st -> return (st, view csPassState st))
-          Compiler s2 b ->
+
-          Compiler s1 b
+setPassState :: s -> Compiler s ()
-m1 ==>| m2 = m1 ==> (const m2)
+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
+                     if view csPromoteWarnings st
-                        then runError w
+                        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)

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

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.Location(Location(..), Located(..), Origin(..),
-import           Bang.Syntax.Name
+                                      Position(..), advanceWith, advanceWith',
-import           Bang.Syntax.Token
+                                      locatedAt, initialPosition)
-import           Data.Char(isSpace, isAscii, ord)
+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,7 +36,7 @@ $typestart   = [A-Z\_]
 $valstart    = [a-z\_]
 $identrest   = [a-zA-Z0-9\_\.]
 $opident     = [\~\!\@\#\$\%\^\&\*\+\-\=\.\<\>\?\_\|:]
-$escape_char = [abfnrtv'\"\\]
+$escape_char = [abfnrtv'\"\\] --"
 
 :-
 
@@ -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]
+type AlexAction = Origin -> Map Text Fixity -> Int -> AlexInput -> 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'
 
 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)
-
 }

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

src/Bang/Syntax/Parser.y

@@ -5,26 +5,24 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTION_GHC -w              #-}
 module Bang.Syntax.Parser(
-         parseModule
+         runParser
-       , ParseError, showError
+       , parseModule
-       , lexWithLayout
        )
  where
 
-import           Bang.Syntax.AST
+import Bang.Monad(err)
-import           Bang.Syntax.Lexer
+import Bang.Syntax.AST(Module(..), Name(..), NameEnvironment(..),
-import           Bang.Syntax.Location
+                       Declaration(..), Expression(..), Type(..), Kind(..),
-import           Bang.Syntax.Token
+                       ConstantValue(..))
-import           Data.Char(digitToInt)
+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.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
 
 }
 
@@ -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 {
+parseModule :: Parser Module
-          unParser :: StateT ParserState (ExceptionT ParseError Id) a
+parseModule = top_module
-        }
- 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)
 
 }

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.")
+
+

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

src/Bang/Syntax/Token.hs

@@ -1,12 +1,14 @@
 module Bang.Syntax.Token(
          Token(..)
        , Fixity(..)
-       , showToken
+       , ppToken
        )
  where
 
+import Bang.Utils.Pretty(BangDoc, text')
+import Data.Monoid((<>))
 import Data.Text.Lazy(Text)
-import qualified Data.Text.Lazy as T
+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
+ppToken :: Token -> BangDoc
-showToken (CharTok   t)   = "'" ++ T.unpack t ++ "'"
+ppToken (CharTok   t)   = quotes (text' t)
-showToken (FloatTok  t)   = T.unpack t
+ppToken (FloatTok  t)   = text' t
-showToken (IntTok    _ t) = T.unpack t
+ppToken (IntTok    _ t) = text' t
-showToken (OpIdent   _ t) = T.unpack t
+ppToken (OpIdent   _ t) = text' t
-showToken (Special   t)   = T.unpack t
+ppToken (Special   t)   = text' t
-showToken (StringTok t)   = "\"" ++ T.unpack t ++ "\""
+ppToken (StringTok t)   = doubleQuotes (text' t)
-showToken (TypeIdent t)   = T.unpack t
+ppToken (TypeIdent t)   = text' t
-showToken (ValIdent  t)   = T.unpack t
+ppToken (ValIdent  t)   = text' t
-showToken (ErrorTok  t)   = "ERROR(" ++ T.unpack t ++ ")"
+ppToken (ErrorTok  t)   = text "ERROR" <> parens (text' t)
-showToken EOFTok          = "EOF"
+ppToken EOFTok          = text "<EOF>"

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 {
+type Infer a = Compiler InferenceState a
-          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))
 
 -- -----------------------------------------------------------------------------
 
 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
+varBind = undefined
-  | TypeRef _ _ u' <- t, u' == u = return nullSubstitution
+--  | TypeRef _ _ u' <- t, u' == u = return nullSubstitution
-  | u `elem` tv t                = raise (OccursCheckFails u t)
+--  | u `elem` tv t                = err (OccursCheckFails u t)
-  | k /= kind t                  = raise (KindCheckFails u t)
+--  | k /= kind t                  = err (KindCheckFails u t)
-  | otherwise                    = return (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
+  do s <- getPassState
-     set (over istCurrentSubstitution (s' @@) s)
+     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
+  do s <- getPassState
-     set (over istNextIdentifier (+1) s)
+     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 =
+typeInfer = undefined
-  let inferM    = unInfer (infer mdl)
-      excM      = runStateT (InferenceState nullSubstitution gensymState) inferM
-      idM       = runExceptionT excM
-      resWState = runId idM
-  in fmap fst resWState

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

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()
-import           Bang.Syntax.Lexer(lexer)
+import           Bang.Syntax.Parser(runParser, parseModule)
-import           Bang.Syntax.Location
-import           Bang.Syntax.Parser(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 ->
+    Parse     o -> do mdl <- runCompiler cmd o (\ r t -> runParser r t parseModule)
-                     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 ->
+    TypeCheck _ -> undefined
-                     putStrLn (render (ppModule mdl))
---    Compile   o -> run o $ withParsed $ withInferred $ \ mod ->
---                     putStrLn (render (ppModule mod))
     Help        -> putStrLn helpString
     Version     -> putStrLn ("Bang tool, version " ++ showVersion version)
 
-run :: CommandsWithInputFile o => o -> (FilePath -> Text -> IO ()) -> IO ()
+-- run :: CommandsWithInputFile o => o -> (FilePath -> Text -> IO ()) -> IO ()
-run opts action =
+-- run opts action =
-  do let path = view inputFile opts
+--   do let path = view inputFile opts
-     mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path)
+--      mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path)
-     case mtxt of
+--      case mtxt of
-       Left  _   -> exit ("Unable to open file '" ++ path ++ "'")
+--        Left  _   -> exit ("Unable to open file '" ++ path ++ "'")
-       Right txt -> action path txt
+--        Right txt -> action path txt
-
+-- 
-withParsed :: (Module -> IO ()) -> FilePath -> Text -> IO ()
+-- withParsed :: (Module -> IO ()) -> FilePath -> Text -> IO ()
-withParsed action path body =
+-- withParsed action path body =
-  case parseModule (File path) body of
+--   case parseModule (File path) body of
-    Left  err -> exit (show err)
+--     Left  err -> exit (show err)
-    Right mdl -> action mdl
+--     Right mdl -> action mdl
-
+-- 
-withInferred :: (Module -> IO ()) -> Module -> IO ()
+-- withInferred :: (Module -> IO ()) -> Module -> IO ()
-withInferred action mdl =
+-- withInferred action mdl =
-  case typeInfer 0 mdl of
+--   case typeInfer 0 mdl of
-    Left err   -> exit (show err)
+--     Left err   -> exit (show err)
-    Right mdl' -> action mdl'
+--     Right mdl' -> action mdl'