Checkpoint. We're inferring stuff, sorta.

.gitignore

@@ -5,4 +5,7 @@
 *.bak
 hsrc/Syntax/Lexer.hs
 hsrc/Syntax/Parser.hs
-bang
+
+.cabal-sandbox/
+dist/
+cabal.sandbox.config

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2016, Adam Wick
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Adam Wick nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

bang.cabal

@@ -0,0 +1,50 @@
+name:                bang
+version:             0.1.0.0
+synopsis:            A fun little language to explore building a compiler. Again.
+homepage:            http://github.com/acw/bang
+license:             BSD3
+license-file:        LICENSE
+author:              Adam Wick <awick@uhsure.com>
+maintainer:          Adam Wick <awick@uhsure.com>
+
+category:            Development
+build-type:          Simple
+cabal-version:       >= 1.10
+
+
+executable bang
+  main-is:             Main.hs
+  build-depends:
+                       array                >= 0.5.1.1  && < 0.9,
+                       base                 >= 4.7      && < 5.0,
+                       bytestring           >= 0.10.6   && < 0.13,
+                       containers           >= 0.5.4    && < 0.8,
+                       GraphSCC             >= 1.0.4    && < 1.4,
+                       lens                 >= 4.14     && < 4.16,
+                       llvm-pretty          >= 0.4.0.1  && < 0.8,
+                       optparse-applicative >= 0.12.1.0 && < 0.15,
+                       pretty               >= 1.1.3.3  && < 1.4,
+                       text                 >= 1.2.2.1  && < 1.5
+  hs-source-dirs:      src
+  build-tools:         alex, happy
+  ghc-options:         -Wall
+  default-language:    Haskell2010
+  other-extensions:    CPP,
+                       DeriveDataTypeable,
+                       DeriveFunctor,
+                       FlexibleInstances,
+                       GeneralizedNewtypeDeriving,
+                       MagicHash,
+                       MultiParamTypeClasses,
+                       OverloadedStrings,
+                       TemplateHaskell,
+                       UndecidableInstances
+  other-modules:
+                       Bang.CommandLine,
+                       Bang.Syntax.Lexer,
+                       Bang.Syntax.Location,
+                       Bang.Syntax.Name,
+                       Bang.Syntax.Parser,
+                       Bang.Syntax.Token,
+                       Paths_bang
+  

hsrc/Main.hs

@@ -1,55 +0,0 @@
-import Control.Exception
-import Control.Monad
-import qualified Data.ByteString as S
-import System.Environment
-import System.Exit
-import System.IO.Error
-
-import Syntax.AST
-import Syntax.Lexer
-import Syntax.Parser
-import Syntax.ParserCore
-
-main :: IO ()
-main = do
-  args <- getArgs
-  case args of
-    [file]        -> do
-      ast <- loadModule file
-      putStrLn "Successful parse!"
-      putStrLn (show ast)
-    ["-lex",path] -> do
-      mtxt <- tryJust (guard . isDoesNotExistError) $ S.readFile path
-      case mtxt of
-        Left _    -> fail $ "Unable to open file: " ++ path
-        Right txt -> do
-          case runParser path txt pullTokens of
-            Left err -> printError err >> exitWith (ExitFailure 1)
-            Right ress -> do
-              mapM_ putStrLn ress
-              putStrLn "Successful lex."
-    ["-parse",path] -> do
-      ast <- loadModule path
-      putStrLn "Successful parse!"
-      putStrLn (show ast)
-    _ -> fail "Unacceptable arguments."
-
-pullTokens :: Parser [String]
-pullTokens = do
-  tok <- scan
-  case tok of
-    Lexeme pos tok' -> do
-      let res = show pos ++ " " ++ show tok'
-      if tok' == TokEOF
-        then return [res]
-        else return (res :) `ap` pullTokens
-
-loadModule :: FilePath -> IO (Module Position)
-loadModule path = do
-  mtxt <- tryJust (guard . isDoesNotExistError) $ S.readFile path
-  case mtxt of
-    Left _ -> fail $ "Unable to open file: " ++ path
-    Right txt ->
-      case runParser path txt parseModule of
-        Left err  -> printError err >> exitWith (ExitFailure 1)
-        Right ast -> return ast

hsrc/Syntax/AST.hs

@@ -1,109 +0,0 @@
-module Syntax.AST where
-
-import Syntax.ParserCore
-
-data Show a => Module a = Module {
-    modName    :: QualifiedName
-  , modImports :: [Import]
-  , modDecls   :: [Decl a]
-  }
- deriving (Show)
-
-data QualifiedName = QualifiedName {
-    qnPrefixes :: [String]
-  , qnName     :: String
-  }
- deriving (Show)
-
-gensym :: Parser QualifiedName
-gensym = do
-  name <- genstr
-  return (QualifiedName [] name)
-
-data Import = Import {
-    imName      :: QualifiedName
-  , imQualified :: Bool
-  , imList      :: Maybe [ImportName]
-  , imAs        :: Maybe QualifiedName
-  }
- deriving (Show)
-
-data ImportName = ImportNamed QualifiedName
-                | ImportRenamed QualifiedName QualifiedName
- deriving (Show)
-
-data Show a => Decl a =
-    DeclData a [Type] QualifiedName [QualifiedName] [DataClause a]
-  | DeclType a [Type]
-  | DeclNewtype a [Type]
-  | DeclClass a [Type] QualifiedName [QualifiedName] [ClassClause a]
-  | DeclInstance a [Type]
-  | DeclValue a [Type] Type QualifiedName (Expr a)
-  | DeclExport a (Decl a)
- deriving (Show)
-
-addTypeRestrictions :: Show a => [Type] -> Decl a -> Decl a
-addTypeRestrictions rs (DeclData     s _ a b c)   = DeclData s rs a b c
-addTypeRestrictions rs (DeclType     s _)         = DeclType s rs
-addTypeRestrictions rs (DeclNewtype  s _)         = DeclNewtype s rs
-addTypeRestrictions rs (DeclClass    s _ a b c)   = DeclClass s rs a b c
-addTypeRestrictions rs (DeclInstance s _)         = DeclInstance s rs
-addTypeRestrictions rs (DeclValue    s _ n a b)   = DeclValue s rs n a b
-addTypeRestrictions rs (DeclExport   s d)         =
-  DeclExport s (addTypeRestrictions rs d)
-
-data DataClause a = DataClause a QualifiedName [Maybe QualifiedName] [Type]
- deriving (Show)
-
-data ClassClause a = ClassClause a QualifiedName Type (Maybe (Expr a))
- deriving (Show)
-
-data Show a => Expr a =
-    Const  a ConstVal
-  | VarRef a QualifiedName
-  | Cond a (Expr a) (Expr a) (Expr a)
-  | App a (Expr a) [Expr a]
-  | Block a [Stmt a]
-  | Lambda a [QualifiedName] (Expr a)
-  | Let a Type QualifiedName (Expr a) (Expr a)
- deriving (Show)
-
-getSpecial :: Show a => Expr a -> a
-getSpecial (Const a _)     = a
-getSpecial (VarRef a _)    = a
-getSpecial (Cond a _ _ _)  = a
-getSpecial (App a _ _)     = a
-getSpecial (Block a _)     = a
-getSpecial (Lambda a _ _)  = a
-getSpecial (Let a _ _ _ _) = a
-
-data Show a => Stmt a =
-    SExpr a (Expr a)
-  | SBind a QualifiedName (Stmt a)
-  | SLet  a Type QualifiedName (Expr a)
-  | SCase a (Expr a) [(Pattern,Maybe (Expr a),Stmt a)]
- deriving (Show)
-
-data Pattern =
-    ListNull
-  | PConst ConstVal
-  | PVar QualifiedName
-  | PNamed QualifiedName Pattern
-  | PAp Pattern Pattern
- deriving (Show)
-
-data Kind = Star | KFun Kind Kind
- deriving (Eq,Show)
-
-data Type = TVar QualifiedName Kind
-          | TCon QualifiedName Kind
-          | TAp Type Type
-          | TGen Int
- deriving (Show)
-
-data ConstVal = ConstInteger Int String
-              | ConstFloat String
-              | ConstChar String
-              | ConstString String
-              | ConstEmpty
- deriving (Show)

hsrc/Syntax/Lexer.x

@@ -1,129 +0,0 @@
-{
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# OPTIONS -w #-}
-module Syntax.Lexer where
-
-import qualified Codec.Binary.UTF8.Generic as UTF8
-import qualified Data.ByteString as S
-import MonadLib
-
-import Syntax.ParserCore
-
-}
-
--- Digits
-$decdigit = 0-9
-$hexdigit = [0-9a-fA-f]
-$octdigit = 0-7
-$bindigit = [01]
-
--- Identifier Characters
-$typestart   = [A-Z\_]
-$valstart    = [a-z\_]
-$identrest   = [a-zA-Z0-9\_\.]
-$opident     = [\~\!\@\#\$\%\^\&\*\+\-\=\.\<\>\?\_\|]
-$escape_char = [abfnrtv'\"\\]
-
-:-
-
--- Whitespace
-  $white+                              ;
-  "/*".*"*/"                                 ;
-
--- Numbers
-  $decdigit+                                       { emitS (buildInt 10)  }
-  "0x"$hexdigit+                                   { emitS (buildInt 16) }
-  "0o"$octdigit+                                   { emitS (buildInt 8)  }
-  "0b"$bindigit+                                   { emitS (buildInt 2)  }
-  $decdigit+"."$decdigit+ ("e""-"?$decdigit+)?     { emitS TokFloat}
-  $decdigit+"e""-"?$decdigit+                      { emitS TokFloat}
-
--- Identifier
-  $typestart $identrest*                           { emitS TokTypeIdent }
-  "prim%" $typestart $identrest*                   { emitS TokTypeIdent }
-  $valstart $identrest*                            { emitS TokValIdent  }
-  "prim%" $valstart $identrest*                    { emitS TokValIdent  }
-  $opident+                                        { emitS TokOpIdent   }
-  ":"+                                             { emitS TokOpIdent   }
-
--- Characters and Strings
-  ['].[']                                          { emitS TokChar }
-  ['] [\\] $escape_char [']                        { emitS TokChar }
-  [\"] ([^\"] | [\n] | ([\\] $escape_char))* [\"]  { emitS TokString }
-
--- Symbols
-  "("                                             { emitT LParen  }
-  ")"                                             { emitT RParen  }
-  "["                                             { emitT LSquare }
-  "]"                                             { emitT RSquare }
-  "{"                                             { emitT LBrace  }
-  "}"                                             { emitT RBrace  }
-  ";"                                             { emitT Semi    }
-  ","                                             { emitT Comma   }
-  "`"                                             { emitT BTick   }
-  [\\]                                            { emitT LLambda }
-
-{
-
-type AlexInput = (Position,Char,S.ByteString)
-
-emitT :: Token -> AlexInput -> Int -> Parser Lexeme
-emitT tok (pos,_,_) _ = return $! Lexeme pos tok
-
-emitS :: (String -> Token) -> AlexInput -> Int -> Parser Lexeme
-emitS mk (pos,c,bs) len = return $! Lexeme pos (mk input)
- where input = UTF8.toString (S.take len bs)
-
-scan :: Parser Lexeme
-scan  = do
-  inp@(pos,_,_) <- alexGetInput
-  sc            <- alexGetStartCode
-  case alexScan inp sc of
-    AlexEOF                   -> return $! Lexeme pos TokEOF
-    AlexError inp'            -> do
-      let posStr = pprtPosition pos
-      alexError $ posStr ++ ": Lexical error."
-    AlexSkip inp' len'        -> alexSetInput inp' >> scan
-    AlexToken inp' len action -> do
-      alexSetInput inp'
-      action inp len
-
-alexGetInput :: Parser AlexInput
-alexGetInput = do
-  s <- get
-  return (psPos s, psChar s, psInput s)
-
-alexSetInput :: AlexInput -> Parser ()
-alexSetInput (pos,c,bs) = do
-  s <- get
-  set $! s {
-    psPos   = pos
-  , psChar  = c
-  , psInput = bs
-  }
-
-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
-alexGetChar (p,_,bs) = do
-  (c,bs') <- UTF8.uncons bs
-  return (c, (movePos p c, c, bs'))
-
-alexInputPrevChar :: AlexInput -> Char
-alexInputPrevChar (_,c,_) = c
-
-alexError :: String -> Parser a
-alexError  = raiseL
-
-alexGetStartCode :: Parser Int
-alexGetStartCode  = psLexCode `fmap` get
-
-alexSetStartCode :: Int -> Parser ()
-alexSetStartCode code = do
-  s <- get
-  set $! s { psLexCode = code }
-
-begin code _ _ = alexSetStartCode code >> scan
-
-buildInt :: Int -> String -> Token
-buildInt base val = TokInt (base, val)
-
-}

hsrc/Syntax/Makefile

@@ -1,14 +0,0 @@
-CURDIR      := $(TOPDIR)/hsrc/Syntax
-
-SYNFILES := Lexer ParserCore AST Parser
-
-SYNFILES_PREFIXED := $(addprefix $(CURDIR)/,$(SYNFILES))
-OBJECTS        += $(addsuffix .o,$(SYNFILES_PREFIXED))
-HS_SOURCES     += $(addsuffix .hs,$(SYNFILES_PREFIXED))
-
-EXTRA_CLEAN += $(CURDIR)/Lexer.hs  $(CURDIR)/Lexer.info  \
-			   $(CURDIR)/Parser.hs $(CURDIR)/Parser.info
-
-.SECONDARY: $(CURDIR)/Lexer.hs $(CURDIR)/Parser.hs
-
-$(CURDIR)/Parser.d: $(CURDIR)/Lexer.d

hsrc/Syntax/Parser.y

@@ -1,509 +0,0 @@
-{
-{-# OPTIONS_GHC -w #-}
-
--- vim: filetype=haskell
-
-module Syntax.Parser where
-
-import Syntax.AST
-import Syntax.Lexer
-import Syntax.ParserCore
-
-import MonadLib
-import qualified Codec.Binary.UTF8.Generic as UTF8
-
-}
-
-%token
-
--- reserved words
-  'module'    { Lexeme $$ (TokValIdent "module"  )  }
-  'export'    { Lexeme $$ (TokValIdent "export"  )  }
-  'import'    { Lexeme $$ (TokValIdent "import"  )  }
-  'datatype'  { Lexeme $$ (TokValIdent "datatype")  }
-  'type'      { Lexeme $$ (TokValIdent "type"    )  }
-  'newtype'   { Lexeme $$ (TokValIdent "newtype" )  }
-  'class'     { Lexeme $$ (TokValIdent "class"   )  }
-  'instance'  { Lexeme $$ (TokValIdent "instance")  }
-  'qualified' { Lexeme $$ (TokValIdent "qualified") }
-  'as'        { Lexeme $$ (TokValIdent "as")        }
-  'let'       { Lexeme $$ (TokValIdent "let")       }
-  'in'        { Lexeme $$ (TokValIdent "in")        }
-  'case'      { Lexeme $$ (TokValIdent "case")      }
-  'of'        { Lexeme $$ (TokValIdent "of")        }
-  'restrict'  { Lexeme $$ (TokValIdent "restrict")  }
-
--- symbols
-  '='        { Lexeme $$ (TokOpIdent  "=")        }
-  '|'        { Lexeme $$ (TokOpIdent  "|")        }
-  '->'       { Lexeme $$ (TokOpIdent  "->")       }
-  '@'        { Lexeme $$ (TokOpIdent  "@")       }
-  '::'       { Lexeme $$ (TokOpIdent  "::")       }
-  '\\'       { Lexeme $$ LLambda  }
-  '('        { Lexeme $$ LParen  }
-  ')'        { Lexeme $$ RParen  }
-  '['        { Lexeme $$ LSquare }
-  ']'        { Lexeme $$ RSquare }
-  '{'        { Lexeme $$ LBrace  }
-  '}'        { Lexeme $$ RBrace  }
-  ';'        { Lexeme $$ Semi    }
-  ','        { Lexeme $$ Comma   }
-  '`'        { Lexeme $$ BTick   }
-
--- identifiers
-  TYPE_IDENT { Lexeme _ (TokTypeIdent _) }
-  VAL_IDENT  { Lexeme _ (TokValIdent _) }
-  OP_IDENT   { Lexeme _ (TokOpIdent _) }
-
--- values
-  INTVAL     { Lexeme _ (TokInt _) }
-  FLOATVAL   { Lexeme _ (TokFloat _) }
-  CHARVAL    { Lexeme _ (TokChar _) }
-  STRVAL     { Lexeme _ (TokString _) }
-
-%monad { Parser } { (>>=) } { return }
-%name parseModule top_module
-%tokentype { Lexeme }
-
-%lexer { lexer } { Lexeme initPosition TokEOF }
-
-%%
-
-top_module :: { Module Position } : 'module' TYPE_IDENT module_decls {
-    let (imports,items) = $3
-    in Module (makeQualified $2) imports items
-  }
-
-module_decls :: { ([Import], [Decl Position]) }
-  : module_decls module_decl { $1 `pappend` $2 }
-  | module_decl              { $1              }
-
-module_decl :: { ([Import], [Decl Position]) }
-  : import_decl ';' { ([$1], [])   }
-  | decl        ';' { ([],   [$1]) }
-
--- Import Declarations ------------------------------------------------------
-
-import_decl :: { Import }
-  : 'import' mqualified TYPE_IDENT mimport_list mas
-    { Import (makeQualified $3) $2 $4 $5 }
-
-mqualified :: { Bool }
-  :             { False }
-  | 'qualified' { True  }
-
-mimport_list :: { Maybe [ImportName] }
-  :                     { Nothing }
-  | '(' ')'             { Just [] }
-  | '(' import_list ')' { Just $2 }
-
-mas :: { Maybe QualifiedName }
-  :                     { Nothing }
-  | 'as' TYPE_IDENT     { Just (makeQualified $2) }
-
-import_list :: { [ImportName] }
-  : import_name                 { [$1] }
-  | import_list ',' import_name { $1 ++ [$3] }
-
-import_name :: { ImportName }
-  : either_ident                   { ImportNamed $1 }
-  | either_ident 'as' either_ident { ImportRenamed $1 $3 }
-
-either_ident :: { QualifiedName }
-  : TYPE_IDENT          { makeQualified $1 }
-  | VAL_IDENT           { makeQualified $1 }
-
--- Actual Declarations ------------------------------------------------------
-
--- A declaration starts with an optional export flag and an optional type
--- restriction flag, and then has the declaration. We apply the restrictions /
--- exports post-hoc because we're lazy.
-decl :: { Decl Position }
-  : optional_decl_flags decl2 { $1 $2 }
-
-optional_decl_flags :: { Decl Position -> Decl Position }
-  :                           { id }
-  | opt_export                { $1 }
-  | opt_restrict              { $1 }
-  | opt_export opt_restrict   { $1 . $2 }
-  | opt_restrict opt_export   { $1 . $2 }
-
-opt_export :: { Decl Position -> Decl Position }
-  : 'export'                  { DeclExport $1 }
-
-opt_restrict :: { Decl Position -> Decl Position }
-  : 'restrict' '(' type_restrictions ')' { addTypeRestrictions $3 }
-
-type_restrictions :: { [Type] }
-  : type_restriction                       { [$1] }
-  | type_restrictions ',' type_restriction { $1 ++ [$3] }
-
-type_restriction :: { Type }
-  : TYPE_IDENT VAL_IDENT
-    { TAp (TVar (makeQualified $1) Star) (TVar (makeQualified $2) Star) }
-  | type_restriction VAL_IDENT
-    { TAp $1 (TVar (makeQualified $2) Star) }
-
-decl2 :: { Decl Position }
-  : data_decl     { $1 }
-  | type_decl     { $1 }
-  | newtype_decl  { $1 }
-  | class_decl    { $1 }
-  | instance_decl { $1 }
-  | value_decl    { $1 }
-
--- Data Declarations --------------------------------------------------------
-
-data_decl :: { Decl Position }
-  : 'datatype' TYPE_IDENT type_args '=' data_clauses
-    { DeclData $1 [] (makeQualified $2) $3 $5 }
-
-type_args :: { [QualifiedName] }
-  :                     { [] }
-  | type_args VAL_IDENT { $1 ++ [makeQualified $2] }
-
-data_clauses :: { [DataClause Position] }
-  : data_clause                  { [] }
-  | data_clauses '|' data_clause { $1 ++ [$3] }
-
-data_clause :: { DataClause Position }
-  : constructor_name '(' ')'
-    { DataClause $2 $1 [] [] }
-  | constructor_name '(' constructor_args ')'
-    { DataClause $2 $1 (map fst $3) (map snd $3) }
-
-constructor_name :: { QualifiedName }
-  : TYPE_IDENT       { makeQualified $1 }
-  | '(' OP_IDENT ')' { makeQualified $2 }
-
-constructor_args :: { [(Maybe QualifiedName,Type)] }
-  : constructor_arg                      { [$1] }
-  | constructor_args ',' constructor_arg { $1 ++ [$3] }
-
-constructor_arg :: { (Maybe QualifiedName,Type) }
-  : bang_type                            { (Nothing, $1) }
-  | VAL_IDENT '::' bang_type             { (Just (makeQualified $1), $3) }
-
--- Type Declarations --------------------------------------------------------
-
-type_decl :: { Decl Position }
-  : 'type'        { undefined }
-
--- Newtype Declarations -----------------------------------------------------
-
-newtype_decl :: { Decl Position }
-  : 'newtype'     { undefined }
-
--- Class Declarations -------------------------------------------------------
-
-class_decl :: { Decl Position }
-  : 'class' type_ident class_args '{' class_items '}'
-  { DeclClass $1 [] $2 $3 $5 }
-
-class_args :: { [QualifiedName] }
-  : VAL_IDENT            { [makeQualified $1] }
-  | class_args VAL_IDENT { $1 ++ [makeQualified $2] }
-
-class_items :: { [ClassClause Position] }
-  : class_item             { [$1] }
-  | class_items class_item { $1 ++ [$2] }
-
-class_item :: { ClassClause Position }
-  : value_ident maybe_clargs cl_retarg maybe_body ';'
-  {% case ($2, $4) of
-      (Nothing, Nothing) -> return (ClassClause $5 $1 $3 Nothing)
-      (Just as, Nothing) -> 
-         let types = map snd as
-         in return (ClassClause $5 $1 (buildFunType types $3) Nothing)
-      (Nothing, Just bd) -> return (ClassClause $5 $1 $3 (Just bd))
-      (Just as, Just bd) ->
-         let types = map snd as
-             names = sequence (map fst as)
-         in case names of
-              Nothing  ->
-                raiseP "Can't have class implementation without argument names."
-              Just nms -> return (ClassClause $5 $1 (buildFunType types $3)
-                                    (Just $ Lambda $5 nms bd))
-  }
-
-maybe_clargs :: { Maybe [(Maybe QualifiedName, Type)] }
-  :                      { Nothing }
-  | '(' clargs ')'       { Just $2 }
-
-clargs :: { [(Maybe QualifiedName, Type)] }
-  : class_arg            { [$1] }
-  | clargs ',' class_arg { $1 ++ [$3] }
-
-class_arg :: { (Maybe QualifiedName, Type) }
-  : value_ident '::' bang_type { (Just $1, $3) }
-  |                  bang_type { (Nothing, $1) }
-
-cl_retarg :: { Type }
-  : '::' bang_type             { $2 }
-
-maybe_body :: { Maybe (Expr Position) }
-  :                            { Nothing }
-  | '=' expression             { Just $2 }
-  | '{' statements '}'         { Just (Block $1 $2) }
-
-type_ident :: { QualifiedName }
-  : TYPE_IDENT           { makeQualified $1 }
-  | '(' OP_IDENT ')'     { makeQualified $2 }
-
--- Instance Declarations ----------------------------------------------------
-
-instance_decl :: { Decl Position }
-  : 'instance'    { undefined }
-
--- Value Declaration --------------------------------------------------------
-
-value_decl :: { Decl Position }
-  : value_ident optional_args optional_type value_body
-    {% postProcessDeclVal DeclValue $1 $2 $3 $4 }
-
-
-optional_args :: { Maybe [(QualifiedName, Maybe Type)] }
-  : '(' optional_args2 ')'   { Just $2 }
-  |                          { Nothing }
-
-optional_args2 :: { [(QualifiedName, Maybe Type)] }
-  : optional_arg                     { [$1] }
-  | optional_args2 ',' optional_arg  { $1 ++ [$3] }
-
-optional_arg :: { (QualifiedName, Maybe Type) }
-  : value_ident optional_type        { ($1, $2) }
-
-optional_type :: { Maybe Type }
-  :                      { Nothing }
-  | '::' bang_type       { Just $2 }
-
-value_ident :: { QualifiedName }
-  : VAL_IDENT            { makeQualified $1 }
-  | '(' OP_IDENT ')'     { makeQualified $2 }
-  | '(' '|' ')'          { makeQualified (Lexeme $2 (TokOpIdent "|")) }
-
-value_body :: { (Position, Expr Position) }
-  : '=' expression       { ($1, $2) }
-  | '{' statements '}'   { ($1, Block $1 $2) }
-
--- Types in Bang ------------------------------------------------------------
-
-primary_type :: { Type }
-  : TYPE_IDENT           { TVar (makeQualified $1) Star }
-  | VAL_IDENT            { TVar (makeQualified $1) Star }
-  | '(' bang_type ')'    { $2 }
-
-type_application_type :: { Type }
-  : type_application_type primary_type
-    { TAp $1 $2 }
-  | primary_type
-    { $1 }
-
-function_type :: { Type }
-  : function_type '->' type_application_type
-    { TAp (TVar (QualifiedName ["--INTERNAL--"] "->") Star) $3 }
-  | type_application_type
-    { $1 }
-
-list_type :: { Type }
-  : '[' list_type ']'
-    { TAp (TVar (QualifiedName ["Data","List"] "List") Star) $2 }
-  | function_type
-    { $1 }
-
-bang_type :: { Type }
-  : list_type            { $1 }
-
--- Statements in bang
-
-statements :: { [Stmt Position] }
-  :                      { [] }
-  | statements statement { $1 ++ [$2] }
-
-statement :: { Stmt Position }
-  : assignment_statement ';' { $1 }
-  | case_statement           { $1 }
-  | expression ';'           { SExpr $2 $1 }
-
-assignment_statement :: { Stmt Position }
-  : value_ident '=' expression -- FIXME: Too restrictive!
-    { SBind $2 $1 (SExpr $2 $3) }
-  | 'let' value_ident optional_args optional_type value_body
-    {% postProcessDeclVal (\ s _ t n e -> SLet s t n e) $2 $3 $4 $5 }
-
-case_statement :: { Stmt Position }
-  : 'case' expression '{' case_items '}'
-    { SCase $1 $2 $4 }
-
-case_items :: { [(Pattern,Maybe (Expr Position),(Stmt Position))] }
-  : case_item            { [$1] }
-  | case_items case_item { $1 ++ [$2] }
-
-case_item :: { (Pattern, Maybe (Expr Position), (Stmt Position)) }
-  : pattern mguard '->' statement { ($1, $2, $4) }
-
-mguard :: { Maybe (Expr Position) }
-  :                 { Nothing }
-  | '|' expression  { Just $2 }
-
--- Patterns for pattern matching
-
-infix_operator :: { QualifiedName }
-  : OP_IDENT             { makeQualified $1 }
-  | '`' VAL_IDENT '`'    { makeQualified $2 }
-
-pattern_primary :: { Pattern }
-  : TYPE_IDENT            { PVar (makeQualified $1) }
-  | VAL_IDENT             { PVar (makeQualified $1) }
-  | '[' ']'               { PVar (QualifiedName ["Data","List"] "NULL") }
-  | INTVAL                { let (Lexeme _ (TokInt (base, val))) = $1
-                            in PConst (ConstInteger base val) }
-  | FLOATVAL              { let (Lexeme _ (TokFloat val)) = $1
-                            in PConst (ConstFloat val) }
-  | CHARVAL               { let (Lexeme _ (TokChar val)) = $1
-                            in PConst (ConstChar val) }
-  | STRVAL                { let (Lexeme _ (TokString val)) = $1
-                            in PConst (ConstString val) }
-   | '(' pattern ')'      { $2 }
-
-pattern_infix :: { Pattern }
-  : pattern_infix infix_operator pattern_primary { PAp (PAp $1 (PVar $2)) $3 }
-  | pattern_primary                              { $1 }
-
-pattern_ap :: { Pattern }
-  : pattern_ap pattern_infix { PAp $1 $2 }
-  | pattern_infix            { $1 }
-
-pattern_name :: { Pattern }
-  : value_ident '@' pattern_name { PNamed $1 $3 }
-  | pattern_ap                   { $1 }
-
-pattern :: { Pattern }
-  : pattern_name         { $1 }
-
--- Expressions in bang
-
-primary_expression :: { Expr Position }
-  : '(' expression ')'    { $2 }
-  | '[' ']'               { VarRef $1 (QualifiedName ["Data","List"] "NULL") }
-  | INTVAL                { let (Lexeme src (TokInt (base, val))) = $1
-                            in Const src (ConstInteger base val) }
-  | FLOATVAL              { let (Lexeme src (TokFloat val)) = $1
-                            in Const src (ConstFloat val) }
-  | CHARVAL               { let (Lexeme src (TokChar val)) = $1
-                            in Const src (ConstChar val) }
-  | STRVAL                { let (Lexeme src (TokString val)) = $1
-                            in Const src (ConstString val) }
-  | TYPE_IDENT            { let l@(Lexeme src (TokTypeIdent name)) = $1
-                            in VarRef src (makeQualified l) }
-  | VAL_IDENT             { let l@(Lexeme src (TokValIdent name)) = $1
-                            in VarRef src (makeQualified l) }
-
-let_expression :: {Expr Position}
-  : 'let' value_ident optional_args optional_type value_body 'in' let_expression
-    {% postProcessDeclVal (\ s _ t n b -> Let s t n b $7) $2 $3 $4 $5 }
-  | primary_expression { $1 }
-
-conditional_expression :: { Expr Position }
-  : let_expression { $1 }
-
-infix_expression :: { Expr Position }
-  : infix_expression infix_operator conditional_expression
-    { App (getSpecial $1) (VarRef (getSpecial $1) $2) [$1, $3] }
-  | conditional_expression
-    { $1 }
-
-lambda_expression :: { Expr Position }
-  : '\\' arguments '->' infix_expression
-    { Lambda $1 $2 $4 }
-  | infix_expression
-    { $1 }
-
-arguments :: { [QualifiedName] }
-  : value_ident               { [$1] }
-  | arguments ',' value_ident { $1 ++ [$3] }
-
-application_expression :: { Expr Position }
-  : application_expression '(' app_args ')'
-    { App $2 $1 $3 }
-  | application_expression '(' ')'
-    { App $2 $1 [] }
-  | lambda_expression
-    { $1 }
-
-app_args :: { [Expr Position] }
-  : expression                { [$1] }
-  | app_args ',' expression   { $1 ++ [$3] }
-
-block_expression :: { Expr Position }
-  : '{' statements '}'        { Block $1 $2 }
-  | application_expression    { $1 }
-
-expression :: { Expr Position }
-  : block_expression          { $1 }
-
-{
-lexer :: (Lexeme -> Parser a) -> Parser a
-lexer k = scan >>= k
-
-happyError :: Parser a
-happyError  = raiseP "Parse Error"
-
-pappend :: ([a],[b]) -> ([a],[b]) -> ([a],[b])
-pappend (a,b) (c,d) = (a++c,b++d)
-
-makeQualified :: Lexeme -> QualifiedName
-makeQualified (Lexeme _ (TokTypeIdent str)) = makeQualified' str
-makeQualified (Lexeme _ (TokValIdent  str)) = makeQualified' str
-makeQualified (Lexeme _ (TokOpIdent   str)) = makeQualified' str
-makeQualified _                             = error "makeQualified bad arg"
-
-makeQualified' :: String -> QualifiedName
-makeQualified' str = QualifiedName prefixes name
- where
-  (prefixes,name) = loop str
-  loop val =
-    let (pre,rest) = span (/= '.') val
-    in if rest == ""
-         then ([], pre)
-         else let (pres, name) = loop (tail rest)
-              in (pre:pres, name)
-
-postProcessDeclVal :: 
-  (Position -> [Type] -> Type -> QualifiedName -> Expr Position -> a) ->
-  QualifiedName ->
-  Maybe [(QualifiedName, Maybe Type)] ->
-  Maybe Type ->
-  (Position, Expr Position) ->
-  Parser a
-postProcessDeclVal builder name margs mrettype (src, body) = do
-  final_type <- case mrettype of
-                   Nothing -> do
-                     name <- gensym
-                     return (TVar name Star)
-                   Just x  ->
-                     return x
-  case margs of
-    Nothing ->
-      return (builder src [] final_type name body)
-    Just [] ->
-      fail "Need to figure out empty arg items."
-    Just args -> do
-      let anames  = map fst args
-      atypes <- forM (map snd args) $ \ x ->
-                  case x of
-                    Nothing -> do
-                      name <- gensym
-                      return (TVar name Star)
-                    Just x ->
-                      return x
-      let ftype = buildFunType atypes final_type
-      return (builder src [] ftype name (Lambda src anames body))
-
-buildFunType :: [Type] -> Type -> Type
-buildFunType [] finaltype = finaltype
-buildFunType (first:rest) finaltype =
-  TAp (TAp arrow first) (buildFunType rest finaltype)
- where arrow = (TVar (makeQualified' "Data.Function") Star)
-}
-

hsrc/Syntax/ParserCore.hs

@@ -1,149 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Syntax.ParserCore where
-
-import Control.Applicative(Applicative)
-import qualified Data.ByteString as S
-import MonadLib
-import System.IO
-
--- --------------------------------------------------------------------------
--- Positions
---
-
-data Position = Position {
-    posOff  :: !Int
-  , posLine :: !Int
-  , posCol  :: !Int
-  , posFile :: !FilePath
-  }
- deriving (Show)
-
-initPosition :: FilePath -> Position
-initPosition = Position 0 1 1
-
-movePos :: Position -> Char -> Position
-movePos (Position o l c f) '\t' = Position (o+1) l     (c+8) f
-movePos (Position o l _ f) '\n' = Position (o+1) (l+1) 0     f
-movePos (Position o l c f) _    = Position (o+1) l     (c+1) f
-
-pprtPosition :: Position -> String
-pprtPosition p = posFile p ++ ":" ++ show (posLine p) ++ ":" ++ show (posCol p)
-
--- --------------------------------------------------------------------------
--- Tokens
---
-
-data Token = LParen | RParen
-           | LSquare | RSquare
-           | LBrace | RBrace
-           | Bar | Semi | Comma | BTick | LLambda
-           | TokTypeIdent String
-           | TokValIdent String
-           | TokOpIdent String
-           | TokInt (Int,String)
-           | TokFloat String
-           | TokChar String
-           | TokString String
-           | TokEOF
- deriving (Eq, Show)
-
--- --------------------------------------------------------------------------
--- Lexemes
---
-
-data Lexeme = Lexeme {
-    lexPos :: !Position
-  , lexTok :: Token
-  }
- deriving (Show)
-
-instance Eq Lexeme where
-  a == b    = lexTok a == lexTok b
-
--- --------------------------------------------------------------------------
--- Errors
---
-
-data ErrorType =
-    LexerError
-  | ParserError
- deriving (Show)
-
-data Error = Error ErrorType String Position
- deriving (Show)
-
-printError :: Error -> IO ()
-printError (Error etype str pos) = hPutStrLn stderr errstr
- where
-  errstr = pprtPosition pos ++ ":" ++ etypeStr ++ ": " ++ str
-  etypeStr = case etype of
-               LexerError  -> "LEX"
-               ParserError -> "PARSE"
-
--- --------------------------------------------------------------------------
--- ParserState
---
-
-data ParserState = ParserState {
-    psInput   :: !S.ByteString
-  , psChar    :: !Char
-  , psPos     :: !Position
-  , psLexCode :: !Int
-  , psGenNum  :: !Int
-  }
- deriving (Show)
-
-initParserState :: FilePath -> S.ByteString -> ParserState
-initParserState path bs = ParserState {
-    psInput   = bs
-  , psChar    = '\n'
-  , psPos     = initPosition path
-  , psLexCode = 0
-  , psGenNum  = 0
-  }
-
--- --------------------------------------------------------------------------
--- Parser
---
-
-newtype Parser a = Parser {
-    unParser :: StateT ParserState (ExceptionT Error Id) a
-  } deriving (Functor, Applicative, Monad)
-
-instance StateM Parser ParserState where
-  get = Parser   get
-  set = Parser . set
-
-instance ExceptionM Parser Error where
-  raise = Parser . raise
-
-instance RunExceptionM Parser Error where
-  try m = Parser (try (unParser m))
-
--- |Raise a lexer error
-raiseL :: String -> Parser a
-raiseL msg = do
-  st <- get
-  raise (Error LexerError msg (psPos st))
-
--- |Raise a parser error
-raiseP :: String -> Parser a
-raiseP msg = do
-  st <- get
-  raise (Error ParserError msg (psPos st))
-
--- |Run the parser over the given file
-runParser :: FilePath -> S.ByteString -> Parser a -> Either Error a
-runParser path bs (Parser m) =
-  case runM m (initParserState path bs) of
-    Right (a,_) -> Right a
-    Left  err   -> Left err
-
-genstr :: Parser String
-genstr = do
-  st <- get
-  set st{ psGenNum = psGenNum st + 1 }
-  return $ "--gen" ++ show (psGenNum st)
-

src/Bang/AST.hs

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

src/Bang/AST/Declaration.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bang.AST.Declaration
+       ( Declaration(..)
+       , ppDeclaration
+       , declName
+       -- * Type Declarations
+       , TypeDeclaration
+       , ppTypeDeclaration
+       , mkTypeDecl
+       , tdName, tdLocation, tdType
+       -- * Value Declarations
+       , ValueDeclaration
+       , ppValueDeclaration
+       , mkValueDecl
+       , vdName, vdLocation
+       , vdDeclaredType, vdValue
+       )
+ where
+
+import Bang.AST.Expression(Expression, ppExpression)
+import Bang.AST.Name(Name, ppName)
+import Bang.AST.Type(Type(TypePrim), ppType)
+import Bang.Syntax.Location(Location)
+import Bang.Utils.FreeVars(CanHaveFreeVars(..))
+import Control.Lens(Lens', view, set, lens)
+import Control.Lens(makeLenses)
+import Data.Set(delete, union)
+import Text.PrettyPrint.Annotated(Doc, text, (<+>), ($+$), (<>), empty, space)
+
+data TypeDeclaration = TypeDeclaration
+     { _tdName     :: Name
+     , _tdLocation :: Location
+     , _tdType     :: Type
+     }
+ deriving (Show)
+
+class MkTypeDecl a where
+  mkTypeDecl :: Name -> Location -> Type -> a
+
+ppTypeDeclaration :: TypeDeclaration -> Doc a
+ppTypeDeclaration td = prefix <> text "type" <+> ppName (_tdName td) <+>
+                       text "=" <+> ppType (_tdType td)
+ where
+  prefix | TypePrim _ <- _tdType td = text "primitive" <> space
+         | otherwise                = empty
+
+instance MkTypeDecl TypeDeclaration where
+  mkTypeDecl = TypeDeclaration
+
+instance MkTypeDecl Declaration where
+  mkTypeDecl n l t = DeclType (TypeDeclaration n l t)
+
+instance CanHaveFreeVars TypeDeclaration where
+  freeVariables td = delete (_tdName td) (freeVariables (_tdType td))
+
+-- -----------------------------------------------------------------------------
+
+data ValueDeclaration = ValueDeclaration
+     { _vdName               :: Name
+     , _vdLocation           :: Location
+     , _vdDeclaredType       :: Maybe Type
+     , _vdValue              :: Expression
+     }
+ deriving (Show)
+
+class MkValueDecl a where
+  mkValueDecl :: Name -> Location -> Maybe Type -> Expression -> a
+
+ppValueDeclaration :: ValueDeclaration -> Doc a
+ppValueDeclaration vd = typedecl $+$ valuedecl
+ where
+  typedecl
+    | Just t <- _vdDeclaredType vd =
+        ppName (_vdName vd) <+> text "::" <+> ppType t
+    | otherwise = empty
+  valuedecl = ppName (_vdName vd) <+> text "=" <+> ppExpression (_vdValue vd)
+
+instance MkValueDecl ValueDeclaration where
+  mkValueDecl n l mt e = ValueDeclaration n l mt e
+
+instance MkValueDecl Declaration where
+  mkValueDecl n l mt e = DeclVal (ValueDeclaration n l mt e)
+
+instance CanHaveFreeVars ValueDeclaration where
+  freeVariables vd = delete (_vdName vd) (union valTypes typeTypes)
+   where
+    valTypes  = freeVariables (_vdValue vd)
+    typeTypes = freeVariables (_vdDeclaredType vd)
+
+-- -----------------------------------------------------------------------------
+
+data Declaration = DeclType TypeDeclaration
+                 | DeclVal  ValueDeclaration
+ deriving (Show)
+
+ppDeclaration :: Declaration -> Doc a
+ppDeclaration (DeclType d) = ppTypeDeclaration d
+ppDeclaration (DeclVal  d) = ppValueDeclaration d
+
+instance CanHaveFreeVars Declaration where
+  freeVariables (DeclType td) = freeVariables td
+  freeVariables (DeclVal  vd) = freeVariables vd
+
+makeLenses ''TypeDeclaration
+makeLenses ''ValueDeclaration
+
+declName :: Lens' Declaration Name
+declName = lens getter setter
+ where
+  getter (DeclType d) = view tdName d
+  getter (DeclVal  d) = view vdName d
+  setter (DeclType d) x = DeclType (set tdName x d)
+  setter (DeclVal  d) x = DeclVal  (set vdName x d)
+

src/Bang/AST/Expression.hs

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

src/Bang/AST/Name.hs

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

src/Bang/AST/Type.hs

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

src/Bang/CommandLine.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bang.CommandLine(
+         Verbosity(..)
+       , CommandsWithInputFile(..)
+       , CommandsWithOutputFile(..)
+       , CommandsWithVerbosity(..)
+       , BangCommand(..)
+       , ParserOptions(..)
+       , getCommand
+       , helpString
+       )
+ where
+
+import Control.Applicative((<|>))
+import Control.Lens(Lens')
+import Control.Lens.TH(makeLenses)
+import Data.Monoid((<>))
+import Options.Applicative(Parser, ParserInfo, ParserPrefs(..), flag,
+                           short, long, strOption, command, subparser, info,
+                           progDesc, execParser, helper, metavar, str, argument,
+                           showDefault, value, help)
+import Options.Applicative.Help(parserHelp)
+
+class CommandsWithInputFile opts where
+  inputFile :: Lens' opts FilePath
+
+class CommandsWithOutputFile opts where
+  outputFile :: Lens' opts FilePath
+
+class CommandsWithVerbosity opts where
+  verbosity :: Lens' opts Verbosity
+
+-- -----------------------------------------------------------------------------
+
+data Verbosity = Silent | Normal | Verbose
+ deriving (Eq, Show)
+
+verboseOption :: Parser Verbosity
+verboseOption = flag Normal Silent  (short 'q' <> long "quiet")
+            <|> flag Normal Verbose (short 'v' <> long "verbose")
+
+optOutputFile :: Parser FilePath
+optOutputFile = strOption (short 'o' <> long "output-file" <> metavar "FILE"
+                      <> help "The file to output as a result of this action."
+                      <> value "/dev/stdout" <> showDefault)
+
+-- -----------------------------------------------------------------------------
+
+data ParserOptions = ParserOptions {
+       _parseInputFile  :: FilePath
+     , _parseOutputFile :: FilePath
+     , _parseVerbosity  :: Verbosity
+     }
+ deriving (Show)
+
+makeLenses ''ParserOptions
+
+parseParseOptions :: Parser ParserOptions
+parseParseOptions = ParserOptions <$> argument str (metavar "FILE")
+                                  <*> optOutputFile
+                                  <*> verboseOption
+
+instance CommandsWithInputFile ParserOptions where
+  inputFile = parseInputFile
+
+instance CommandsWithOutputFile ParserOptions where
+  outputFile = parseOutputFile
+
+instance CommandsWithVerbosity ParserOptions where
+  verbosity = parseVerbosity
+
+-- -----------------------------------------------------------------------------
+
+data TypeCheckOptions = TypeCheckOptions {
+       _tcheckInputFile  :: FilePath
+     , _tcheckOutputFile :: FilePath
+     , _tcheckVerbosity  :: Verbosity
+     }
+ deriving (Show)
+
+makeLenses ''TypeCheckOptions
+
+parseTypeCheckOptions :: Parser TypeCheckOptions
+parseTypeCheckOptions = TypeCheckOptions <$> argument str (metavar "FILE")
+                                         <*> optOutputFile
+                                         <*> verboseOption
+
+instance CommandsWithInputFile TypeCheckOptions where
+  inputFile = tcheckInputFile
+
+instance CommandsWithOutputFile TypeCheckOptions where
+  outputFile = tcheckOutputFile
+
+instance CommandsWithVerbosity TypeCheckOptions where
+  verbosity = tcheckVerbosity
+
+-- -----------------------------------------------------------------------------
+
+data BangCommand = Help
+                 | Parse     ParserOptions
+                 | TypeCheck TypeCheckOptions
+                 | Version
+ deriving (Show)
+
+bangOperation :: Parser BangCommand
+bangOperation = subparser $
+  command "help"      (pure Help    `withInfo` "Describe common commands.") <>
+  command "version"   (pure Version `withInfo` "Display version information.") <>
+  command "parse"     (parseParse   `withInfo` "Parse a file into its AST.") <>
+  command "typeCheck" (parseTCheck  `withInfo` "Type check a file.")
+ where
+  parseParse  = Parse     <$> parseParseOptions
+  parseTCheck = TypeCheck <$> parseTypeCheckOptions
+
+withInfo :: Parser a -> String -> ParserInfo a
+withInfo opts desc = info (helper <*> opts) (progDesc desc)
+
+helpString :: String
+helpString = show (parserHelp (ParserPrefs "" False False True 80) bangOperation)
+
+getCommand :: IO BangCommand
+getCommand = execParser (bangOperation `withInfo` "Run a bang language action.")

src/Bang/Error.hs

@@ -0,0 +1,11 @@
+module Bang.Error(
+         exit
+       )
+ where
+
+import System.Exit(ExitCode(..), exitWith)
+
+exit :: String -> IO b
+exit x =
+  do putStrLn ("ERROR: " ++ x)
+     exitWith (ExitFailure 1)

src/Bang/Monad.hs

@@ -0,0 +1,176 @@
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE Rank2Types                 #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE UndecidableInstances       #-}
+module Bang.Monad(
+         Compiler
+       , BangError(..)
+       , BangWarning(..)
+       , runCompiler
+       , runPass
+       , getPassState, setPassState, mapPassState, overPassState, viewPassState
+       , registerName, registerNewName, genName, genTypeRef, genVarRef
+       , warn, err, err'
+       )
+ where
+
+import           Bang.AST.Expression(Expression, mkRefExp)
+import           Bang.AST.Name(NameEnvironment(..), Name, mkName, nameIndex)
+import           Bang.AST.Type(Kind(..), Type, mkTypeRef)
+import           Bang.CommandLine(BangCommand, CommandsWithInputFile(..))
+import           Bang.Error(exit)
+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, when)
+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 -> (Maybe Location, BangDoc)
+
+class BangWarning w where
+  ppWarning :: w -> (Maybe Location, BangDoc)
+
+data CompilerState state = CompilerState {
+       _csNextIdent       :: !Word
+     , _csPromoteWarnings :: !Bool
+     , _csWarnings        :: [BangDoc]
+     , _csPassState       :: !state
+     }
+
+makeLenses ''CompilerState
+
+initialState :: BangCommand -> CompilerState ()
+initialState _ = CompilerState 1 False [] ()
+
+-- -----------------------------------------------------------------------------
+
+newtype Compiler s a =
+  Compiler { unCompiler :: CompilerState s -> IO (CompilerState s, a) }
+
+instance Applicative (Compiler s) where
+  pure a = Compiler (\ st -> return (st, a))
+  mf <*> ma = Compiler (\ st ->
+                          do (st', f) <- unCompiler mf st 
+                             (st'', a) <- unCompiler ma st'
+                             return (st'', f a))
+
+instance Functor (Compiler s) where
+  fmap f m = return f <*> m
+
+instance Monad (Compiler s) where
+  return a = Compiler (\ st -> return (st, a))
+  m >>= k  = Compiler (\ st ->
+                         do (st', a) <- unCompiler m st
+                            unCompiler (k a) st')
+
+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)
+
+runPass :: s2 -> (Compiler s2 a) -> Compiler s1 (s2, a)
+runPass s2 action =
+  Compiler (\ cst1 ->
+             do let cst2 = set csPassState s2 cst1
+                    s1   = view csPassState cst1
+                (cst2', v) <- unCompiler action cst2
+                let retval = (view csPassState cst2', v)
+                return (set csPassState s1 cst2', retval))
+
+getPassState :: Compiler s s
+getPassState = Compiler (\ st -> return (st, view csPassState st))
+
+setPassState :: Lens' s b -> b -> Compiler s ()
+setPassState passLens v =
+  Compiler (\ st -> return (set (csPassState . passLens) v st, ()))
+
+mapPassState :: (s -> s) -> Compiler s ()
+mapPassState f = Compiler (\ st -> return (over csPassState f st, ()))
+
+overPassState :: Lens' s b -> (b -> b) -> Compiler s ()
+overPassState passLens f =
+  Compiler (\ st -> return (over (csPassState . passLens) f st, ()))
+
+viewPassState :: Lens' s b -> Compiler s b
+viewPassState l = Compiler (\ st -> return (st, view (csPassState . l) st))
+
+-- -----------------------------------------------------------------------------
+
+registerName :: Name -> Compiler s Name
+registerName name =
+  Compiler (\ st ->
+             do let current = view csNextIdent st
+                return (over csNextIdent (+1) st, set nameIndex current name))
+
+registerNewName :: NameEnvironment -> Text -> Compiler s Name
+registerNewName env name =
+  Compiler (\ st ->
+              do let current = view csNextIdent st
+                     res     = mkName name env unknownLocation current
+                 return (over csNextIdent (+1) st, res))
+
+genName :: NameEnvironment -> Compiler s Name
+genName env =
+  Compiler (\ st ->
+             do let current = view csNextIdent st
+                    str = "gen:" ++ show current
+                    res = mkName (pack str) env unknownLocation current
+                return (over csNextIdent (+1) st, res))
+
+genTypeRef :: Kind -> Compiler s Type
+genTypeRef k = mkTypeRef unknownLocation k `fmap` genName TypeEnv
+
+genVarRef :: Compiler s Expression
+genVarRef = mkRefExp 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 view csPromoteWarnings st
+                        then runError (WErrorWarning w) False >> return (st, ())
+                        else runWarning w >> return (st, ()))
+
+err :: BangError w => w -> Compiler s a
+err w = Compiler (\ _ -> runError w True >> undefined)
+
+err' :: BangError e => e -> Compiler s ()
+err' e = Compiler (\ st -> runError e False >> return (st, ()))
+
+runWarning :: BangWarning w => w -> IO ()
+runWarning w = putStrLn (go (ppWarning w))
+ where
+   go (Nothing, doc) = render doc
+   go (Just a, doc) = render (ppLocation a $+$ nest 3 doc)
+
+runError :: BangError w => w -> Bool -> IO ()
+runError e die =
+  do putStrLn (go (ppError e))
+     when die $ exitWith (ExitFailure 1)
+ where
+   go (Nothing, doc) = render doc
+   go (Just a, doc) = render (ppLocation a $+$ nest 3 doc)

src/Bang/Syntax/Lexer.x

@@ -0,0 +1,118 @@
+-- -*- mode: haskell -*-
+-- vi: set ft=haskell :
+{
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS -w                 #-}
+module Bang.Syntax.Lexer(
+         AlexReturn(..)
+       , AlexInput(..)
+       , alexScan
+       )
+ where
+
+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
+import           Data.Word(Word8)
+
+}
+
+-- Digits
+$decdigit = 0-9
+$hexdigit = [0-9a-fA-f]
+$octdigit = 0-7
+$bindigit = [01]
+
+-- Identifier Characters
+$typestart   = [A-Z\_]
+$valstart    = [a-z\_]
+$identrest   = [a-zA-Z0-9\_\.]
+$opident     = [\~\!\@\#\$\%\^\&\*\+\-\=\.\<\>\?\_\|:]
+$escape_char = [abfnrtv'\"\\] --"
+
+:-
+
+-- Whitespace
+  $white+                                          ;
+  "/*"[.\n]*"*/"                                   ;
+
+-- Numbers
+  $decdigit+                                       { emitI 0 (IntTok 10)  }
+  "0x"$hexdigit+                                   { emitI 2 (IntTok 16) }
+  "0o"$octdigit+                                   { emitI 2 (IntTok 8)  }
+  "0b"$bindigit+                                   { emitI 2 (IntTok 2)  }
+  $decdigit+"."$decdigit+ ("e""-"?$decdigit+)?     { emitS FloatTok}
+  $decdigit+"e""-"?$decdigit+                      { emitS FloatTok}
+
+-- Identifier
+  $typestart $identrest*                           { emitS TypeIdent               }
+  $valstart $identrest*                            { emitS ValIdent                }
+  $opident+                                        { emitO                         }
+
+-- Characters and Strings
+  ['].[']                                          { emitS CharTok }
+  ['] [\\] $escape_char [']                        { emitS CharTok }
+  [\"] ([^\"] | [\n] | ([\\] $escape_char))* [\"]  { emitS StringTok } --"
+
+-- Symbols
+  "("                                             { emitT "("     }
+  ")"                                             { emitT ")"     }
+  "["                                             { emitT "["     }
+  "]"                                             { emitT "]"     }
+  "{"                                             { emitT "{"     }
+  "}"                                             { emitT "}"     }
+  ";"                                             { emitT ";"     }
+  ","                                             { emitT ","     }
+  "`"                                             { emitT "`"     }
+  [\\]                                            { emitT "\\"    }
+
+{
+
+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
+     return (byteForChar c, (AlexInput (p `advanceWith` c) rest))
+ where
+  byteForChar c | isAscii c = fromIntegral (ord c)
+                | otherwise = 0
+
+}

src/Bang/Syntax/Location.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bang.Syntax.Location(
+         Position, posRow, posColumn, posOffset
+       , ppPosition
+       , initialPosition
+       , advanceWith, advanceWith'
+       , Origin(..)
+       , ppOrigin
+       , Location(Location)
+       , locSource, locStart, locEnd
+       , ppLocation
+       , Located(..)
+       , locatedAt
+       , unknownLocation
+       , fakeLocation
+       )
+ 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
+     , _posColumn :: Word
+     , _posOffset :: Word
+     }
+ deriving (Show)
+
+makeLenses ''Position
+
+ppPosition :: Position -> BangDoc
+ppPosition (Position r c _) = word r <> colon <> word c
+
+initialPosition :: Position
+initialPosition = Position 1 1 0
+
+instance Eq Position where
+  a == b = _posOffset a == _posOffset b
+
+advanceWith :: Position -> Char -> Position
+advanceWith (Position r c o) '\t' = Position r     (c+8) (o+1)
+advanceWith (Position r _ o) '\n' = Position (r+1) 1     (o+1)
+advanceWith (Position r c o) _    = Position r     (c+1) (o+1)
+
+advanceWith' :: Position -> Text -> Position
+advanceWith' pos txt =
+  case T.uncons txt of
+    Nothing        -> pos
+    Just (c, rest) -> advanceWith' (pos `advanceWith` c) rest
+
+data Origin = Unknown
+            | Generated
+            | Interactive
+            | File FilePath
+ deriving (Eq, Show)
+
+ppOrigin :: Origin -> BangDoc
+ppOrigin x =
+  case x of
+    Unknown     -> text "<unknown>"
+    Generated   -> text "<generated>"
+    Interactive -> text "<interactive>"
+    File f      -> text f
+
+data Location = Location {
+       _locSource :: Origin
+     , _locStart  :: Position
+     , _locEnd    :: Position
+     }
+ deriving (Eq, Show)
+
+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
+  show (Located l x) = show x ++ " `locatedAt` " ++ show l
+
+locatedAt :: a -> Location -> Located a
+locatedAt a p = Located p a
+
+unknownLocation :: Location
+unknownLocation = Location Unknown initialPosition initialPosition
+
+fakeLocation :: Location
+fakeLocation = Location Generated initialPosition initialPosition

src/Bang/Syntax/Name.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bang.Syntax.Name(
+         Name
+       , nameId
+       , nameString
+       , nameGenerated
+       )
+ where
+
+import Control.Lens.TH(makeLenses)
+
+data Name = Name {
+       _nameId        :: !Word
+     , _nameString    :: !String
+     , _nameGenerated :: !Bool
+     }
+
+makeLenses ''Name
+
+instance Eq Name where
+  a == b = _nameId a == _nameId b
+  a /= b = _nameId a /= _nameId b
+
+instance Ord Name where
+  compare a b = compare (_nameId a) (_nameId b)
+  max     a b = if a > b then a else b
+  min     a b = if a > b then b else a
+  a <  b      = _nameId a <  _nameId b
+  a <= b      = _nameId a <= _nameId b
+  a >  b      = _nameId a >  _nameId b
+  a >= b      = _nameId a >= _nameId b
+

src/Bang/Syntax/Parser.y

@@ -0,0 +1,253 @@
+-- -*- mode: haskell -*-
+-- vi: set ft=haskell :
+{
+{-# LANGUAGE DeriveFunctor     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTION_GHC -w              #-}
+module Bang.Syntax.Parser(
+         runParser
+       , parseModule
+       )
+ where
+
+import Bang.Monad(err)
+import Bang.AST(Name, Module, NameEnvironment(..), mkModule, mkName, emptyExpression)
+import Bang.AST.Declaration(Declaration, mkTypeDecl, mkValueDecl)
+import Bang.AST.Expression(ConstantValue(..), Expression, mkConstExp, mkRefExp, mkLambdaExp)
+import Bang.AST.Type(Type, Kind(..), mkTypeRef, mkFunType, mkTypeApp, mkPrimType)
+import Bang.Syntax.Location(Located(..), Origin, Position)
+import Bang.Syntax.ParserError(ParserError(..))
+import Bang.Syntax.ParserMonad(Parser, addFixities, parseError, runNextToken, runParser)
+import Bang.Syntax.Token(Token(..), Fixity(..))
+import Control.Monad(forM)
+import Data.List(union)
+import Data.Text.Lazy(Text)
+
+}
+
+%name      top_module
+%tokentype { Located Token }
+%monad     { Parser        }
+%error     { parseError    }
+%lexer     { runNextToken  } { Located _ EOFTok }
+
+%token
+ '::'        { Located $$ (OpIdent   _ "::")         }
+ '='         { Located $$ (OpIdent   _ "=")          }
+ ','         { Located $$ (OpIdent   _ ",")          }
+ '->'        { Located $$ (OpIdent   _ "->")         }
+ 'infixl'    { Located $$ (ValIdent    "infixl")     }
+ 'infixr'    { Located $$ (ValIdent    "infixr")     }
+ 'infix'     { Located $$ (ValIdent    "infix")      }
+ 'module'    { Located $$ (ValIdent    "module")     }
+ 'primitive' { Located $$ (ValIdent    "primitive")  }
+ 'type'      { Located $$ (ValIdent    "type")       }
+ Integer     { Located _  (IntTok    _ _)            }
+ Float       { Located _  (FloatTok  _)              }
+ Char        { Located _  (CharTok   _)              }
+ String      { Located _  (StringTok _)              }
+ OpIdent     { Located _  (OpIdent   _ _)            }
+ TypeIdent   { Located _  (TypeIdent _)              }
+ ValIdent    { Located _  (ValIdent  _)              }
+ OPL0        { Located _  (OpIdent (LeftAssoc  0) _) }
+ OPR0        { Located _  (OpIdent (RightAssoc 0) _) }
+ OPN0        { Located _  (OpIdent (NonAssoc   0) _) }
+ OPL1        { Located _  (OpIdent (LeftAssoc  1) _) }
+ OPR1        { Located _  (OpIdent (RightAssoc 1) _) }
+ OPN1        { Located _  (OpIdent (NonAssoc   1) _) }
+ OPL2        { Located _  (OpIdent (LeftAssoc  2) _) }
+ OPR2        { Located _  (OpIdent (RightAssoc 2) _) }
+ OPN2        { Located _  (OpIdent (NonAssoc   2) _) }
+ OPL3        { Located _  (OpIdent (LeftAssoc  3) _) }
+ OPR3        { Located _  (OpIdent (RightAssoc 3) _) }
+ OPN3        { Located _  (OpIdent (NonAssoc   3) _) }
+ OPL4        { Located _  (OpIdent (LeftAssoc  4) _) }
+ OPR4        { Located _  (OpIdent (RightAssoc 4) _) }
+ OPN4        { Located _  (OpIdent (NonAssoc   4) _) }
+ OPL5        { Located _  (OpIdent (LeftAssoc  5) _) }
+ OPR5        { Located _  (OpIdent (RightAssoc 5) _) }
+ OPN5        { Located _  (OpIdent (NonAssoc   5) _) }
+ OPL6        { Located _  (OpIdent (LeftAssoc  6) _) }
+ OPR6        { Located _  (OpIdent (RightAssoc 6) _) }
+ OPN6        { Located _  (OpIdent (NonAssoc   6) _) }
+ OPL7        { Located _  (OpIdent (LeftAssoc  7) _) }
+ OPR7        { Located _  (OpIdent (RightAssoc 7) _) }
+ OPN7        { Located _  (OpIdent (NonAssoc   7) _) }
+ OPL8        { Located _  (OpIdent (LeftAssoc  8) _) }
+ OPR8        { Located _  (OpIdent (RightAssoc 8) _) }
+ OPN8        { Located _  (OpIdent (NonAssoc   8) _) }
+ OPL9        { Located _  (OpIdent (LeftAssoc  9) _) }
+ OPR9        { Located _  (OpIdent (RightAssoc 9) _) }
+ OPN9        { Located _  (OpIdent (NonAssoc   9) _) }
+
+%right    OPL0
+%left     OPR0
+%nonassoc OPN0
+%right    OPL1
+%left     OPR1
+%nonassoc OPN1
+%right    OPL2
+%left     OPR2
+%nonassoc OPN2
+%right    OPL3
+%left     OPR3
+%nonassoc OPN3
+%right    OPL4
+%left     OPR4
+%nonassoc OPN4
+%right    OPL5
+%left     OPR5
+%nonassoc OPN5
+%right    OPL6
+%left     OPR6
+%nonassoc OPN6
+%right    OPL7
+%left     OPR7
+%nonassoc OPN7
+%right    OPL8
+%left     OPR8
+%nonassoc OPN8
+%right    OPL9
+%left     OPR9
+%nonassoc OPN9
+
+%%
+
+top_module :: { Module }
+  : 'module' TypeIdent listopt(Declaration)
+    {%
+       do let Located src (TypeIdent rawName) = $2
+          return (mkModule (mkName rawName ModuleEnv src 0) [$3]) }
+
+Declaration :: { Maybe Declaration }
+  : ValueDeclaration  { Just $1 }
+  | FixityDeclaration { Nothing }
+  | TypeDeclaration   { Just $1 }
+
+ValueDeclaration :: { Declaration }
+  : list1(ValIdent) '=' Expression
+    {%
+       case $1 of
+         [] ->
+            err (InternalError $2 "ValDeclLHS")
+         [Located src (ValIdent rawName)] ->
+           do let name = mkName rawName VarEnv src 0
+              return (mkValueDecl name src Nothing $3)
+         ((Located src (ValIdent rawName)) : args) ->
+           do let name     = mkName rawName VarEnv src 0
+                  argNames = map (\ (Located arsrc (ValIdent argName)) ->
+                                   mkName argName VarEnv arsrc 0)
+                                 args
+              return (mkValueDecl name src Nothing
+                       (mkLambdaExp $2 argNames $3))
+    }
+
+FixityDeclaration :: { () }
+  : 'infixl' Integer sep(',',OpIdent)
+    {% addFixities $1 LeftAssoc  $2 $3 }
+  | 'infixr' Integer sep(',',OpIdent)
+    {% addFixities $1 RightAssoc $2 $3 }
+  | 'infix'  Integer sep(',',OpIdent)
+    {% addFixities $1 NonAssoc   $2 $3 }
+
+TypeDeclaration :: { Declaration }
+  : ValIdent '::' Type
+    {%
+       do let Located src (ValIdent rawName) = $1
+              name = mkName rawName VarEnv src 0
+          return (mkValueDecl name src (Just $3) emptyExpression) }
+  | 'type' TypeIdent '=' Type
+    {%
+       do let Located src (TypeIdent rawName) = $2
+              name = mkName rawName TypeEnv src 0
+          return (mkTypeDecl name src $4) }
+  | 'primitive' 'type' TypeIdent '=' String
+    {%
+       do let Located nsrc (TypeIdent rawName) = $3
+              Located tsrc (StringTok rawText) = $5
+              name = mkName rawName TypeEnv nsrc 0
+          return (mkTypeDecl name $2 (mkPrimType tsrc rawText)) }
+
+-- -----------------------------------------------------------------------------
+
+Type :: { Type }
+  : RawType                      { $1 }
+
+RawType :: { Type }
+  : RawType '->' BaseType        { mkFunType $2 $1 $3 }
+  | BaseType                     { $1                 }
+
+BaseType :: { Type }
+  : TypeIdent   {%
+                  let Located src (TypeIdent rawName) = $1
+                      name = mkName rawName TypeEnv src 0
+                  in return (mkTypeRef src Unknown name) }
+  | ValIdent    {%
+                  let Located src (ValIdent rawName) = $1
+                      name = mkName rawName TypeEnv src 0
+                  in return (mkTypeRef src Unknown name) }
+
+-- -----------------------------------------------------------------------------
+
+Expression :: { Expression }
+  : BaseExpression { $1 }
+
+BaseExpression :: { Expression }
+  : OpIdent  {%
+               let Located src (OpIdent _ rawName) = $1
+                   name = mkName rawName VarEnv src 0
+               in return (mkRefExp src name) }
+  | ValIdent {%
+               let Located src (ValIdent rawName) = $1
+                   name = mkName rawName VarEnv src 0
+               in return (mkRefExp src name) }
+  | Integer  { let Located src (IntTok base val) = $1
+               in mkConstExp src (ConstantInt base val) }
+  | String   { let Located src (StringTok val) = $1
+               in mkConstExp src (ConstantString val) }
+  | Float    { let Located src (FloatTok val) = $1
+               in mkConstExp src (ConstantFloat val) }
+  | Char     { let Located src (CharTok val) = $1
+               in mkConstExp src (ConstantChar val) }
+
+-- -----------------------------------------------------------------------------
+
+opt(p)
+  : {- empty -} { Nothing }
+  | p           { Just $1 }
+
+sep(p,q)
+  : {- empty -}   { []         }
+  | sep_body(p,q) { reverse $1 }
+
+sep1(p,q)
+  : sep_body(p,q) { reverse $1 }
+
+sep_body(p,q)
+  : q                 { [$1]    }
+  | sep_body(p,q) p q { $3 : $1 }
+
+list(p)
+  : {- empty -}  { []         }
+  | list_body(p) { reverse $1 }
+
+list1(p)
+  : list_body(p) { reverse $1 }
+
+list_body(p)
+  : p              { [$1]    }
+  | list_body(p) p { $2 : $1 }
+
+listopt(p)
+  : {- empty -}    { [] }
+  | listopt(p) p   { case $2 of
+                       Nothing -> $1
+                       Just x  -> $1 ++ [x]
+                   }
+
+{
+
+parseModule :: Parser Module
+parseModule = top_module
+
+}

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,129 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Bang.Syntax.ParserMonad(
+         Parser
+       , runParser
+       , addFixities
+       , parseError
+       , runNextToken
+       )
+ where
+
+import           Bang.Monad(Compiler, err, runPass,
+                            setPassState, overPassState, viewPassState)
+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.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
+     , _psOrigin       :: Origin
+     , _psLexerState   :: AlexInput
+     }
+
+makeLenses ''ParserState
+
+type Parser a = Compiler ParserState a
+
+runParser :: Origin -> Text -> Parser a -> Compiler ps a
+runParser origin stream action = snd `fmap` runPass pstate action
+ where
+  initInput = AlexInput initialPosition stream
+  pstate    = ParserState Map.empty 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 ->
+       overPassState psPrecTable (Map.insert (tokenName tok) 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)"
+
+getFixities :: Parser (Map Text Fixity)
+getFixities = viewPassState psPrecTable
+
+-- -----------------------------------------------------------------------------
+
+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 = setPassState psLexerState
+
+-- -----------------------------------------------------------------------------
+
+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/PostProcess.hs

@@ -0,0 +1,217 @@
+{-# LANGUAGE RankNTypes #-}
+module Bang.Syntax.PostProcess(
+         runPostProcessor
+       )
+ where
+
+import           Bang.AST(Name, Module, moduleDeclarations, ppName,
+                          nameText, nameLocation, nameEnvironment)
+import           Bang.AST.Declaration(Declaration(..), declName,
+                                      tdName, tdType,
+                                      ValueDeclaration, vdName, vdLocation,
+                                      vdDeclaredType, vdValue)
+import           Bang.AST.Expression(Expression(..), isEmptyExpression, refName,
+                                     lambdaArgumentNames, lambdaBody,
+                                     isEmptyExpression)
+import           Bang.AST.Type(Type(..), rtName, ftArgumentType, ftResultType,
+                               taLeftType, taRightType)
+import           Bang.Monad(Compiler, BangError(..), err, err', registerName)
+import           Bang.Syntax.Location(Location, ppLocation)
+import           Bang.Utils.FreeVars(CanHaveFreeVars(..))
+import           Bang.Utils.Pretty(BangDoc, text')
+import           Control.Lens(Lens', view, set)
+import           Control.Monad(foldM)
+import           Data.Char(isLower)
+import           Data.Graph(SCC(..))
+import           Data.Graph.SCC(stronglyConnComp)
+import           Data.Map.Strict(Map)
+import qualified Data.Map.Strict as Map
+import           Data.Set(toList)
+import           Data.Text.Lazy(uncons)
+import           Text.PrettyPrint.Annotated(text, ($+$), (<+>), nest, quotes)
+
+data PostProcessError = InternalError        Name
+                      | UndefinedVariable    Name
+                      | RedefinitionError    Name Location Location
+                      | TypeDeclWithoutValue Name Location
+ deriving (Show)
+
+instance BangError PostProcessError where
+  ppError = prettyError
+
+prettyError :: PostProcessError -> (Maybe Location, BangDoc)
+prettyError e =
+  case e of
+    InternalError n ->
+      (Nothing, text "Serious post-processing error w.r.t. " <+> ppName n)
+    UndefinedVariable n ->
+      (Just (view nameLocation n), text "Undefined variable " <+> quotes (text' (view nameText n)))
+    RedefinitionError n l1 l2 ->
+      (Just l1, text "Name" <+> ppName n <+> text "redefined." $+$
+                nest 2 (text "original definiton at " <+> ppLocation l2))
+    TypeDeclWithoutValue n l ->
+      (Just l, text "Type declaration provided, but no value provided." $+$
+               nest 2 (text "variable name: " <+> ppName n))
+
+runPostProcessor :: Module -> Compiler ps Module
+runPostProcessor mdl =
+  do let baseDecls = concat (view moduleDeclarations mdl)
+     decls     <- linkNames baseDecls
+     declTable <- makeDeclarationTable decls
+     decls'    <- combineTypeValueDeclarations declTable decls
+     return (set moduleDeclarations (orderDecls decls') mdl)
+
+-- -----------------------------------------------------------------------------
+
+linkNames :: [Declaration] -> Compiler ps [Declaration]
+linkNames decls =
+  do declaredNames <- foldM addNewNames Map.empty (map (view declName) decls)
+     mapM (linkDecls declaredNames) decls
+ where
+  addNewNames t n =
+    do n' <- registerName n
+       let key = (view nameText n, view nameEnvironment n)
+       return (Map.insert key n' t)
+  --
+  replaceName nameMap name =
+    do let key = (view nameText name, view nameEnvironment name)
+       case Map.lookup key nameMap of
+         Nothing    -> err' (UndefinedVariable name) >> return name
+         Just name' -> return name'
+  --
+  addOrReplaceName nameMap name =
+    do let key  = (view nameText name, view nameEnvironment name)
+       case Map.lookup key nameMap of
+         Nothing | couldBeTypeVariable name ->
+           do name' <- registerName name
+              return (name', Map.insert key name' nameMap)
+         Nothing ->
+           err' (UndefinedVariable name) >> return (name, nameMap)
+         Just name' ->
+           return (name', nameMap)
+  --
+  couldBeTypeVariable n =
+    case uncons (view nameText n) of
+      Nothing ->
+        error "Empty variable name?"
+      Just (x,_) ->
+        isLower x
+  --
+  linkDecls nameMap (DeclType td) =
+    do td'  <- overM tdType (linkType' nameMap)    td
+       td'' <- overM tdName (replaceName nameMap)  td'
+       return (DeclType td'')
+  linkDecls nameMap (DeclVal vd) =
+    do vd'   <- overM vdDeclaredType (traverse (linkType' nameMap)) vd
+       vd''  <- overM vdValue        (linkExpr nameMap)             vd'
+       vd''' <- overM vdName         (replaceName nameMap)          vd''
+       return (DeclVal vd''')
+  --
+  linkType' nm t = fst `fmap` linkType nm t
+  --
+  linkType nameMap x@(TypeUnit _) = return (x, nameMap)
+  linkType nameMap x@(TypePrim _) = return (x, nameMap)
+  linkType nameMap   (TypeRef t)  =
+    do (name, nameMap') <- addOrReplaceName nameMap (view rtName t)
+       let t' = set rtName name t
+       return (TypeRef t', nameMap') 
+  linkType nameMap   (TypeFun t)  =
+    do (argType, nameMap')  <- linkType nameMap  (view ftArgumentType t)
+       (resType, nameMap'') <- linkType nameMap' (view ftResultType   t)
+       return (TypeFun (set ftArgumentType argType $
+                        set ftResultType   resType t),
+               nameMap'')
+  linkType nameMap   (TypeApp t)  =
+    do (lt, nameMap')  <- linkType nameMap  (view taLeftType  t)
+       (rt, nameMap'') <- linkType nameMap' (view taRightType t)
+       return (TypeApp (set taLeftType lt (set taRightType rt t)), nameMap'')
+  -- 
+  linkExpr _ x | isEmptyExpression x = return x
+  linkExpr _ x@(ConstExp  _) = return x
+  linkExpr nameMap (RefExp    e) =
+    RefExp `fmap` overM refName (replaceName nameMap) e
+  linkExpr nameMap (LambdaExp e) =
+    do let names = view lambdaArgumentNames e
+       nameMap' <- foldM addNewNames nameMap names
+       e'  <- overM lambdaArgumentNames (mapM (replaceName nameMap')) e
+       e'' <- overM lambdaBody          (linkExpr nameMap')           e'
+       return (LambdaExp e'')
+
+overM :: Monad m => Lens' s a -> (a -> m a) -> s -> m s
+overM field action input =
+  do newval <- action (view field input)
+     return (set field newval input)
+
+-- -----------------------------------------------------------------------------
+
+type DeclarationTable = Map Name (Maybe (Type, Location), Maybe ValueDeclaration)
+
+makeDeclarationTable :: [Declaration] -> Compiler ps DeclarationTable
+makeDeclarationTable decls = foldM combine Map.empty decls
+ where
+  combine table d =
+    do let name = view declName d
+       case d of
+         DeclType _ ->
+           return table
+         DeclVal vd | Just t <- view vdDeclaredType vd,
+                      isEmptyExpression (view vdValue vd) ->
+           do let myLoc = view vdLocation vd
+                  myVal = Just (t, myLoc)
+              case Map.lookup name table of
+                Nothing            ->
+                  return (Map.insert name (myVal, Nothing) table)
+                Just (Nothing, vd') ->
+                  return (Map.insert name (myVal, vd') table)
+                Just (Just (_, theirLoc), _) ->
+                  err (RedefinitionError name myLoc theirLoc)
+         DeclVal vd | Just _ <- view vdDeclaredType vd ->
+           err (InternalError name)
+         DeclVal vd | isEmptyExpression (view vdValue vd) ->
+           err (InternalError name)
+         DeclVal vd ->
+           case Map.lookup name table of
+             Nothing            ->
+               return (Map.insert name (Nothing, Just vd) table)
+             Just (td, Nothing) ->
+               return (Map.insert name (td, Just vd) table)
+             Just (_, Just vd') ->
+               do let newLoc  = view vdLocation vd
+                      origLoc = view vdLocation vd'
+                  err (RedefinitionError name newLoc origLoc)
+
+-- -----------------------------------------------------------------------------
+
+combineTypeValueDeclarations :: DeclarationTable ->
+                                [Declaration] ->
+                                Compiler ps [Declaration]
+combineTypeValueDeclarations table decls = process decls
+ where
+  process [] = return []
+  process (x:rest) =
+    case x of
+      DeclType _ ->
+        (x:) `fmap` process rest
+      DeclVal vd | Just _ <- view vdDeclaredType vd,
+                   isEmptyExpression (view vdValue vd) ->
+        process rest
+      DeclVal vd ->
+        case Map.lookup (view vdName vd) table of
+          Nothing ->
+            err (InternalError (view vdName vd))
+          Just (Nothing, _) ->
+            (x:) `fmap` process rest
+          Just (Just (t, _), _) ->
+            do let vd' = set vdDeclaredType (Just t) vd
+               (DeclVal vd' :) `fmap` process rest
+
+-- -----------------------------------------------------------------------------
+
+orderDecls :: [Declaration] -> [[Declaration]]
+orderDecls decls = map unSCC (stronglyConnComp nodes)
+ where
+  unSCC (AcyclicSCC x) = [x]
+  unSCC (CyclicSCC xs) = xs
+  --
+  nodes = map tuplify decls
+  tuplify d = (d, view declName d, toList (freeVariables d))

src/Bang/Syntax/Token.hs

@@ -0,0 +1,40 @@
+module Bang.Syntax.Token(
+         Token(..)
+       , Fixity(..)
+       , ppToken
+       )
+ where
+
+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
+           | IntTok    Word    Text
+           | OpIdent   Fixity  Text
+           | Special   Text
+           | StringTok Text
+           | TypeIdent Text
+           | ValIdent  Text
+           | ErrorTok  Text
+           | EOFTok
+ deriving (Show)
+
+data Fixity = LeftAssoc  Word
+            | RightAssoc Word
+            | NonAssoc   Word
+ deriving (Show)
+
+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>"

src/Bang/TypeInfer.hs

@@ -0,0 +1,269 @@
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+module Bang.TypeInfer(runTypeInference)
+ where
+
+import           Bang.AST(Module, moduleDeclarations)
+import           Bang.AST.Declaration(Declaration(..), ValueDeclaration,
+                                      vdName, vdDeclaredType, vdValue,
+                                      tdName, tdType)
+import           Bang.AST.Expression(Expression(..), ConstantValue(..),
+                                     lambdaArgumentNames, lambdaBody,
+                                     constLocation, constValue, refName)
+import           Bang.AST.Name(Name, NameEnvironment(..),
+                               nameLocation, nameText, ppName)
+import           Bang.AST.Type(Type(..), ppType, rtName, ftArgumentType,
+                               ftResultType, taLeftType, taRightType,
+                               mkPrimType, mkFunType, mkTypeRef,
+                               Kind(..))
+import           Bang.Monad(Compiler, BangError(..), BangWarning(..),
+                            registerNewName, err', err, warn,
+                            getPassState, mapPassState, runPass)
+import           Bang.Syntax.Location(Location, fakeLocation)
+import           Bang.Utils.FreeVars(CanHaveFreeVars(..))
+import           Bang.Utils.Pretty(BangDoc, text')
+import           Control.Lens(view, over)
+import           Data.Map.Strict(Map)
+import qualified Data.Map.Strict as Map
+import           Data.Set(Set, (\\))
+import qualified Data.Set as Set
+import           Text.PrettyPrint.Annotated(text, nest, quotes, ($+$), (<+>))
+
+runTypeInference :: Module -> Compiler ps Module
+runTypeInference x =
+  do _ <- runPass emptyEnvironment (mapM_ typeInferDecls (view moduleDeclarations x))
+     return x
+
+-- -----------------------------------------------------------------------------
+
+type Infer a = Compiler TypeEnvironment a
+
+getNamesTypeScheme :: Name -> Infer (Maybe Scheme)
+getNamesTypeScheme n = Map.lookup n `fmap` getPassState
+
+addToTypeEnvironment :: [Name] -> [Scheme] -> Infer ()
+addToTypeEnvironment ns schms = mapPassState (add ns schms)
+ where
+  add :: [Name] -> [Scheme] -> TypeEnvironment -> TypeEnvironment
+  add []         []         acc = acc
+  add (n:restns) (s:rschms) acc =
+    Map.insertWithKey errorFn n s (add restns rschms acc)
+  add _          _          _   =
+    error "Wackiness has insued."
+  --
+  errorFn k _ _ = error ("Redefinition of " ++ show k)
+
+-- -----------------------------------------------------------------------------
+
+type Substitution = Map Name Type
+
+nullSubstitution :: Substitution
+nullSubstitution = Map.empty
+
+composeSubstitutions :: Substitution -> Substitution -> Substitution
+composeSubstitutions s1 s2 = Map.map (apply s1) s2 `Map.union` s1
+
+class ApplySubst t where
+  apply :: Substitution -> t -> t
+
+instance ApplySubst Type where
+  apply s (TypeUnit t) = TypeUnit t
+  apply s (TypePrim t) = TypePrim t
+  apply s (TypeRef t)  = case Map.lookup (view rtName t) s of
+                           Nothing -> TypeRef t
+                           Just t' -> t'
+  apply s (TypeFun t)  = TypeFun (over ftArgumentType (apply s) $
+                                  over ftResultType   (apply s) t)
+  apply s (TypeApp t)  = TypeApp (over taLeftType     (apply s) $
+                                  over taRightType    (apply s) t)
+
+instance ApplySubst a => ApplySubst [a] where
+  apply s = map (apply s)
+
+-- -----------------------------------------------------------------------------
+
+data Scheme = Scheme [Name] Type
+
+instance CanHaveFreeVars Scheme where
+  freeVariables (Scheme ns t) = freeVariables t \\ Set.fromList ns
+
+instance ApplySubst Scheme where
+  apply s (Scheme vars t) = Scheme vars (apply s t)
+
+newTypeVar :: Name -> Infer Type
+newTypeVar n =
+  do let loc = view nameLocation n
+     n' <- registerNewName TypeEnv (view nameText n)
+     return (mkTypeRef loc Unknown n') 
+
+instantiate :: Scheme -> Infer Type
+instantiate (Scheme vars t) =
+  do refs <- mapM newTypeVar vars
+     let newSubsts = Map.fromList (zip vars refs)
+     return (apply newSubsts t)
+
+-- -----------------------------------------------------------------------------
+
+mostGeneralUnifier :: Type -> Type -> Infer Substitution
+mostGeneralUnifier a b =
+  case (a, b) of
+    (TypeUnit _,  TypeUnit _)  -> return nullSubstitution
+    (TypePrim _,  TypePrim _)  -> return nullSubstitution
+    (TypeRef  t1, t2)          -> varBind (view rtName t1) t2
+    (t2,          TypeRef t1)  -> varBind (view rtName t1) t2
+    (TypeFun  t1, TypeFun t2)  -> do let at1 = view ftArgumentType t1
+                                         at2 = view ftArgumentType t2
+                                     s1 <- mostGeneralUnifier at1 at2
+                                     let rt1 = apply s1 (view ftResultType t1)
+                                         rt2 = apply s1 (view ftResultType t2)
+                                     s2 <- mostGeneralUnifier rt1 rt2
+                                     return (s1 `composeSubstitutions` s2)
+    (TypeApp t1,  TypeApp t2)  -> do let lt1 = view taLeftType t1
+                                         lt2 = view taLeftType t2
+                                     s1 <- mostGeneralUnifier lt1 lt2
+                                     let rt1 = apply s1 (view taRightType t1)
+                                         rt2 = apply s1 (view taRightType t2)
+                                     s2 <- mostGeneralUnifier rt1 rt2
+                                     return (s1 `composeSubstitutions` s2)
+    _                          -> do err' (TypesDontUnify a b)
+                                     return nullSubstitution
+
+varBind :: Name -> Type -> Infer Substitution
+varBind u t | TypeRef t' <- t,
+              view rtName t' == u            = return nullSubstitution
+            | u `Set.member` freeVariables t = do err' (OccursFail u t)
+                                                  return nullSubstitution
+            | otherwise                      = return (Map.singleton u t)
+
+-- -----------------------------------------------------------------------------
+
+type TypeEnvironment = Map Name Scheme
+
+emptyEnvironment :: TypeEnvironment
+emptyEnvironment = Map.empty
+
+instance ApplySubst TypeEnvironment where
+  apply s tenv = Map.map (apply s) tenv
+
+instance CanHaveFreeVars TypeEnvironment where
+  freeVariables tenv = freeVariables (Map.elems tenv)
+
+generalize :: TypeEnvironment -> Type -> Scheme
+generalize env t = Scheme vars t
+ where vars = Set.toList (freeVariables t \\ freeVariables env)
+
+-- -----------------------------------------------------------------------------
+
+data InferenceError = InternalError
+                    | TypesDontUnify  Type Type
+                    | OccursFail      Name Type
+                    | UnboundVariable Name
+
+instance BangError InferenceError where
+  ppError = prettyError
+
+prettyError :: InferenceError -> (Maybe Location, BangDoc)
+prettyError e =
+  case e of
+    InternalError        ->
+      (Nothing, text "<internal error>")
+    TypesDontUnify t1 t2 ->
+      (Nothing, text "Types don't unify:" $+$
+                  (nest 3 
+                     (text "first type: "  <+> ppType t1 $+$
+                      text "second type: " <+> ppType t2)))
+    OccursFail n t ->
+      (Just (view nameLocation n),
+       text "Occurs check failed:" $+$
+         (nest 3 (text "Type: " <+> ppType t)))
+    UnboundVariable n ->
+      (Just (view nameLocation n),
+       text "Unbound variable (in type checker?):" <+> ppName n)
+
+data InferenceWarning = TopLevelWithoutType Name Type
+                      | DeclarationMismatch Name Type Type
+
+instance BangWarning InferenceWarning where
+  ppWarning = prettyWarning
+
+prettyWarning :: InferenceWarning -> (Maybe Location, BangDoc)
+prettyWarning w =
+  case w of
+    TopLevelWithoutType n t ->
+      (Just (view nameLocation n),
+       text "Variable" <+> quotes (text' (view nameText n)) <+>
+       text "is defined without a type." $+$
+       text "Inferred type:" $+$ nest 3 (ppType t))
+    DeclarationMismatch n dt it ->
+      (Just (view nameLocation n),
+       text "Mismatch between declared and inferred type of" <+>
+       quotes (text' (view nameText n)) $+$
+       nest 3 (text "declared type:" <+> ppType dt $+$
+               text "inferred type:" <+> ppType it))
+
+-- -----------------------------------------------------------------------------
+
+-- Infer the type of a group of declarations with cyclic dependencies.
+typeInferDecls :: [Declaration] -> Infer ()
+typeInferDecls decls =
+  do (names, schemes, decls') <- getInitialSchemes decls
+     addToTypeEnvironment names schemes
+     mapM_ typeInferDecl decls'
+ where
+  getInitialSchemes [] =
+    return ([], [], [])
+  getInitialSchemes ((DeclType td) : rest) =
+    do (rn, rs, rd) <- getInitialSchemes rest
+       let n = view tdName td 
+           s = Scheme [] (view tdType td)
+       return (n:rn, s:rs, rd)
+  getInitialSchemes ((DeclVal td) : rest) =
+    do (rn, rs, rd) <- getInitialSchemes rest
+       return (rn, rs, (td : rd))
+
+typeInferDecl :: ValueDeclaration -> Infer ()
+typeInferDecl vd =
+  do (subs, t) <- typeInferExpr (view vdValue vd)
+     let t' = apply subs t
+     case view vdDeclaredType vd of
+       Nothing ->
+         warn (TopLevelWithoutType (view vdName vd) t')
+       Just dt ->
+         warn (DeclarationMismatch (view vdName vd) dt t)
+
+typeInferConst :: Location -> ConstantValue ->
+                  Infer (Substitution, Type)
+typeInferConst l (ConstantInt _ _) =
+  return (nullSubstitution, mkPrimType l "i64")
+typeInferConst l (ConstantChar _) = 
+  return (nullSubstitution, mkPrimType l "i8") -- FIXME
+typeInferConst l (ConstantString _) =
+  return (nullSubstitution, mkPrimType l "i8*") -- FIXME
+typeInferConst l (ConstantFloat _) =
+  return (nullSubstitution, mkPrimType l "double")
+
+typeInferExpr :: Expression -> Infer (Substitution, Type)
+typeInferExpr expr =
+  case expr of
+    ConstExp e ->
+      typeInferConst (view constLocation e) (view constValue e)
+    RefExp e ->
+      do mscheme <- getNamesTypeScheme (view refName e)
+         case mscheme of
+           Nothing     -> err (UnboundVariable (view refName e))
+           Just scheme -> do t <- instantiate scheme
+                             return (nullSubstitution, t)
+    LambdaExp e ->
+      do let argNames = view lambdaArgumentNames e
+         tvars <- mapM newTypeVar argNames
+         let tvars'   = map (Scheme []) tvars
+         addToTypeEnvironment argNames tvars'
+         (s1, t1) <- typeInferExpr (view lambdaBody e)
+         return (s1, mkFunType' (apply s1 tvars) t1) 
+ where
+  mkFunType' []       t = t
+  mkFunType' (x:rest) t = mkFunType fakeLocation x (mkFunType' rest t)
+
+

src/Bang/Utils/FreeVars.hs

@@ -0,0 +1,20 @@
+module Bang.Utils.FreeVars(
+         CanHaveFreeVars(..)
+       )
+ where
+
+import           Bang.AST.Name(Name)
+import           Data.Set(Set)
+import qualified Data.Set as Set
+
+class CanHaveFreeVars a where
+  freeVariables :: a -> Set Name
+
+instance CanHaveFreeVars a => CanHaveFreeVars (Maybe a) where
+  freeVariables (Just x) = freeVariables x
+  freeVariables Nothing  = Set.empty
+
+instance CanHaveFreeVars a => CanHaveFreeVars [a] where
+  freeVariables []     = Set.empty
+  freeVariables (x:xs) = freeVariables x `Set.union` freeVariables xs
+

src/Bang/Utils/PP.hs

@@ -0,0 +1,9 @@
+module Bang.Utils.PP(
+         PP(..)
+       )
+ where
+
+import 
+
+class PP a where
+  ppr :: a -> Doc

src/Bang/Utils/Pretty.hs

@@ -0,0 +1,20 @@
+module Bang.Utils.Pretty(
+         BangDoc
+       , Annotation(..)
+       , text'
+       , word
+       )
+ where
+
+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

@@ -0,0 +1,22 @@
+import           Bang.CommandLine(getCommand, BangCommand(..), helpString)
+import           Bang.AST(ppModule)
+import           Bang.Monad(runCompiler)
+import           Bang.Syntax.Parser(runParser, parseModule)
+import           Bang.Syntax.PostProcess(runPostProcessor)
+import           Bang.TypeInfer(runTypeInference)
+import           Data.Version(showVersion)
+import           Paths_bang(version)
+import           Text.PrettyPrint.Annotated(render)
+
+main :: IO ()
+main = getCommand >>= \ cmd ->
+  case cmd of
+    Parse     o -> do mdl <- runCompiler cmd o (\ r t -> runParser r t parseModule)
+                      putStrLn (render (ppModule mdl))
+    TypeCheck o -> do mdl <- runCompiler cmd o (\ r t ->
+                                                 do mdl  <- runParser r t parseModule
+                                                    mdl' <- runPostProcessor mdl
+                                                    runTypeInference mdl')
+                      putStrLn (render (ppModule mdl))
+    Help        -> putStrLn helpString
+    Version     -> putStrLn ("Bang tool, version " ++ showVersion version)

test.bang

@@ -0,0 +1,13 @@
+module Test
+
+primitive type Word = "u64"
+
+/* This is a number! */
+one :: Word
+one = 1
+
+id :: a -> a
+id x = x
+
+seq :: a -> b -> b
+seq x y = y