Checkpoint: Working my way through Typing Haskell in Haskell.

bang.cabal

@@ -20,19 +20,11 @@ executable bang
                        bytestring,
                        containers,
                        lens,
+                       llvm-pretty,
                        monadLib,
                        optparse-applicative,
                        pretty,
                        text
---                       array                >= 0.5.1.0 && < 0.7,
---                       base                 >= 4.8     && < 4.9,
---                       bytestring           >= 0.10    && < 0.11,
---                       containers           >= 0.5.6.2 && < 0.7,
---                       lens                 >= 4.14    && < 4.18,
---                       monadLib             >= 3.7.3   && < 3.9,
---                       optparse-applicative >= 0.12.1  && < 0.14,
---                       pretty               >= 1.1.3.2 && < 1.5,
---                       text                 >= 1.2.2.1 && < 1.4
   hs-source-dirs:      src
   build-tools:         alex, happy
   ghc-options:         -Wall

src/Bang/CommandLine.hs

@@ -1,6 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
 module Bang.CommandLine(
-         BangCommand(..)
+         Verbosity(..)
-       , BangOperation(..)
+       , CommandsWithInputFile(..)
+       , CommandsWithOutputFile(..)
+       , CommandsWithVerbosity(..)
+       , BangCommand(..)
        , LexerOptions(..)
        , ParserOptions(..)
        , getCommand
@@ -8,15 +12,26 @@ module Bang.CommandLine(
        )
  where
 
-import Options.Applicative
+import Control.Applicative((<|>))
-import Options.Applicative.Help
+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)
 
-data BangCommand = BangCommand {
+class CommandsWithInputFile opts where
-       cmdVerbosity  :: Verbosity
+  inputFile :: Lens' opts FilePath
-     , cmdOutputFile :: FilePath
+
-     , cmdCommand    :: BangOperation
+class CommandsWithOutputFile opts where
-     }
+  outputFile :: Lens' opts FilePath
- deriving (Show)
+
+class CommandsWithVerbosity opts where
+  verbosity :: Lens' opts Verbosity
+
+-- -----------------------------------------------------------------------------
 
 data Verbosity = Silent | Normal | Verbose
  deriving (Eq, Show)
@@ -25,54 +40,113 @@ verboseOption :: Parser Verbosity
 verboseOption = flag Normal Silent  (short 'q' <> long "quiet")
             <|> flag Normal Verbose (short 'v' <> long "verbose")
 
-outputFile :: Parser FilePath
+optOutputFile :: Parser FilePath
-outputFile = strOption (short 'o' <> long "output-file" <> metavar "FILE"
+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 BangOperation = Help
+-- -----------------------------------------------------------------------------
-                   | Version
+
-                   | Lex LexerOptions
+data LexerOptions = LexerOptions {
-                   | Parse ParserOptions
+       _lexInputFile  :: FilePath
+     , _lexOutputFile :: FilePath
+     , _lexVerbosity  :: Verbosity
+     }
  deriving (Show)
 
-bangOperation :: Parser BangOperation
+makeLenses ''LexerOptions
+
+parseLexOptions :: Parser LexerOptions
+parseLexOptions = LexerOptions <$> argument str (metavar "FILE")
+                               <*> optOutputFile
+                               <*> verboseOption
+
+
+instance CommandsWithInputFile LexerOptions where
+  inputFile = lexInputFile
+
+instance CommandsWithOutputFile LexerOptions where
+  outputFile = lexOutputFile
+
+instance CommandsWithVerbosity LexerOptions where
+  verbosity = lexVerbosity
+
+-- -----------------------------------------------------------------------------
+
+data ParserOptions = ParserOptions {
+       _parseInputFile  :: FilePath
+     , _parseOutputFile :: FilePath
+     , _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
+                 | Lex       LexerOptions
+                 | 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 "lex"       (parseLex     `withInfo` "Lex a file into its component tokens.") <>
-  command "parse" (parseParse `withInfo` "Parse a file into its AST.")
+  command "parse"     (parseParse   `withInfo` "Parse a file into its AST.") <>
+  command "typeCheck" (parseTCheck  `withInfo` "Type check a file.")
+ where
+  parseLex    = Lex       <$> parseLexOptions
+  parseParse  = Parse     <$> parseParseOptions
+  parseTCheck = TypeCheck <$> parseTypeCheckOptions
 
 withInfo :: Parser a -> String -> ParserInfo a
 withInfo opts desc = info (helper <*> opts) (progDesc desc)
 
-data LexerOptions = LexerOptions {
-       lexInputFile :: FilePath
-     }
- deriving (Show)
-
-parseLex :: Parser BangOperation
-parseLex = Lex <$> parseLexOptions
-
-parseLexOptions :: Parser LexerOptions
-parseLexOptions = LexerOptions <$> argument str (metavar "FILE")
-
-data ParserOptions = ParserOptions {
-       parseInputFile :: FilePath
-     }
- deriving (Show)
-
-parseParse :: Parser BangOperation
-parseParse = Parse <$> parseParseOptions
-
-parseParseOptions :: Parser ParserOptions
-parseParseOptions = ParserOptions <$> argument str (metavar "FILE")
-
-parseOptions :: Parser BangCommand
-parseOptions = BangCommand <$> verboseOption <*> outputFile <*> bangOperation
-
 helpString :: String
-helpString = show (parserHelp (ParserPrefs "" False False True 80) parseOptions)
+helpString = show (parserHelp (ParserPrefs "" False False True 80) bangOperation)
 
 getCommand :: IO BangCommand
-getCommand = execParser (parseOptions `withInfo` "Run a bang language action.")
+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/Syntax/AST.hs

@@ -1,9 +1,8 @@
 module Bang.Syntax.AST
  where
 
-import Data.Text.Lazy(Text, unpack)
+import Data.Text.Lazy(Text)
-import Bang.Syntax.Location
+import Bang.Syntax.Location(Location)
-import Text.PrettyPrint.Annotated
 
 data NameEnvironment = ModuleEnv | TypeEnv | VarEnv
  deriving (Eq, Ord, Show)
@@ -11,67 +10,45 @@ data NameEnvironment = ModuleEnv | TypeEnv | VarEnv
 data Name = Name Location NameEnvironment Word Text
  deriving (Show)
 
-ppName :: Name -> Doc a
+instance Eq Name where
-ppName (Name _ _ _ t) = text' t
+  (Name _ _ x _) == (Name _ _ y _) = x == y
+  (Name _ _ x _) /= (Name _ _ y _) = x /= y
 
 data Module = Module Name [Declaration]
  deriving (Show)
 
-ppModule :: Module -> Doc a
-ppModule (Module name decls) =
-  vcat ([text "module" <> space <> ppName name, text ""] ++
-        map ppDeclaration decls)
-
 data Declaration = TypeDeclaration     Name Type
                  | ValueDeclaration    Name Expression
                  | PrimTypeDeclaration Name Text
  deriving (Show)
 
-ppDeclaration :: Declaration -> Doc a
-ppDeclaration d =
-  case d of
-    TypeDeclaration n t ->
-      ppName n <> space <> text "::" <> space <> ppType t
-    ValueDeclaration n e ->
-      ppName n <> space <> text "=" <> space <> ppExpression e
-    PrimTypeDeclaration n t ->
-      text "primitive" <> space <> text "type" <> space <>
-      ppName n <> space <> text "=" <> space <> text' t
-
 data Expression = ConstantExp  Location ConstantValue
                 | ReferenceExp Location Name
+                | LambdaExp    Location [Name] Expression
  deriving (Show)
 
-ppExpression :: Expression -> Doc a
-ppExpression e =
-  case e of
-    ConstantExp  _ v -> ppConstantValue v
-    ReferenceExp _ n -> ppName n
-
 data ConstantValue = ConstantInt    Word Text
                    | ConstantChar        Text
                    | ConstantString      Text
                    | ConstantFloat       Text
  deriving (Show)
 
-ppConstantValue :: ConstantValue -> Doc a
+data Type = TypeUnit   Location Kind
-ppConstantValue cv =
+          | TypePrim   Location Kind Text
-  case cv of
+          | TypeRef    Location Kind Name
-    ConstantInt    2  t -> text "0b" <> text' t
+          | TypeLambda Location Kind Type   Type
-    ConstantInt    8  t -> text "0o" <> text' t
+          | TypeApp    Location Kind Type   Type
-    ConstantInt    10 t ->              text' t
+          | TypeForAll               [Name] Type
-    ConstantInt    16 t -> text "0x" <> text' t
-    ConstantChar      c -> text' c
-    ConstantString    s -> text' s
-    ConstantFloat     f -> text' f
-
-data Type = TypeRef Location Name
  deriving (Show)
 
-ppType :: Type -> Doc a
+kind :: Type -> Kind
-ppType t =
+kind (TypeUnit   _ k)     = k
-  case t of
+kind (TypePrim   _ k _)   = k
-    TypeRef _ n -> ppName n
+kind (TypeRef    _ k _)   = k
+kind (TypeLambda _ k _ _) = k
+kind (TypeApp    _ k _ _) = k
+kind (TypeForAll     _ t) = kind t
 
-text' :: Text -> Doc a
+data Kind = Star
-text' = text . unpack
+          | KindArrow Kind Kind
+  deriving (Show)

src/Bang/Syntax/Parser.y

@@ -16,8 +16,9 @@ import           Bang.Syntax.Lexer
 import           Bang.Syntax.Location
 import           Bang.Syntax.Token
 import           Data.Char(digitToInt)
+import           Data.List(union)
 import           Data.Map.Strict(Map)
-import           Data.Map.Strict as Map
+import qualified Data.Map.Strict as Map
 import           Data.Maybe(catMaybes)
 import           Data.Text.Lazy(Text)
 import qualified Data.Text.Lazy as T
@@ -37,6 +38,7 @@ import Debug.Trace
  '::'        { Located $$ (OpIdent   _ "::")         }
  '='         { Located $$ (OpIdent   _ "=")          }
  ','         { Located $$ (OpIdent   _ ",")          }
+ '->'        { Located $$ (OpIdent   _ "->")         }
  'infixl'    { Located $$ (ValIdent    "infixl")     }
  'infixr'    { Located $$ (ValIdent    "infixr")     }
  'infix'     { Located $$ (ValIdent    "infix")      }
@@ -115,41 +117,95 @@ import Debug.Trace
 %%
 
 top_module :: { Module }
-  : 'module' TypeIdent listopt(declaration)
+  : 'module' TypeIdent listopt(Declaration)
     {%
        do let Located src (TypeIdent rawName) = $2
           name <- registerName False src ModuleEnv rawName
           return (Module name $3) }
 
-declaration :: { Maybe Declaration }
+Declaration :: { Maybe Declaration }
+  : ValueDeclaration  { Just $1 }
+  | FixityDeclaration { Nothing }
+  | TypeDeclaration   { Just $1 }
+
+ValueDeclaration :: { Declaration }
+  : ValueDeclLHS Expression
+    {%
+        do let (builder, argNames) = $1
+           unregisterNames VarEnv argNames
+           return (builder $2)
+    }
+
+ValueDeclLHS :: { (Expression -> Declaration, [Name]) }
+ : list1(ValIdent) '='
+    {%
+       case $1 of
+         [] ->
+            raise (InternalError $2 "ValDeclLHS")
+         [Located src (ValIdent rawName)] ->
+           do name <- registerName True src VarEnv rawName
+              return (ValueDeclaration name, [name])
+         ((Located src (ValIdent rawName)) : args) ->
+           do name <- registerName True src VarEnv rawName
+              argNames <- forM args $ \ (Located asrc (ValIdent argName)) ->
+                            registerName True asrc VarEnv argName
+              let builder = ValueDeclaration name . LambdaExp $2 argNames
+              return (builder, argNames)
+    }
+
+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 <- registerName True src VarEnv rawName
-          return (Just (TypeDeclaration name $3)) }
+          return (TypeDeclaration name $3) }
-  | ValIdent '=' Expression
-    {%
-       do let Located src (ValIdent rawName) = $1
-          name <- registerName True src VarEnv rawName
-          return (Just (ValueDeclaration name $3)) }
-  | 'infixl' Integer sep(',',OpIdent)
-    {% addFixities $1 LeftAssoc  $2 $3 >> return Nothing }
-  | 'infixr' Integer sep(',',OpIdent)
-    {% addFixities $1 RightAssoc $2 $3 >> return Nothing }
-  | 'infix'  Integer sep(',',OpIdent)
-    {% addFixities $1 NonAssoc   $2 $3 >> return Nothing }
   | 'primitive' 'type' TypeIdent '=' String
     {%
        do let Located src (TypeIdent rawName) = $3
               Located _   (StringTok rawText) = $5
           name <- registerName False src TypeEnv rawName
-          return (Just (PrimTypeDeclaration name rawText)) }
+          return (PrimTypeDeclaration name rawText) }
+
+-- -----------------------------------------------------------------------------
 
 Type :: { Type }
+  : RawType {%
+      do let (result, names) = $1
+         case names of
+           [] -> return result
+           xs ->
+             do unregisterNames TypeEnv xs
+                return (TypeForAll xs result)
+      }
+
+RawType :: { (Type, [Name]) }
+  : RawType '->' BaseType {%
+      do let (p1, names1) = $1
+             (p2, names2) = $3
+         return (TypeLambda $2 (Star `KindArrow` Star) p1 p2, union names1 names2)
+     }
+  | BaseType           { $1 }
+
+BaseType :: { (Type, [Name]) }
   : TypeIdent   {%
        do let Located src (TypeIdent rawName) = $1
           name <- lookupName src TypeEnv rawName
-          return (TypeRef src name) }
+          return (TypeRef src Star name, []) }
+  | ValIdent    {%
+       do let Located src (ValIdent rawName) = $1
+          name <- registerName True src TypeEnv rawName
+          return (TypeRef src Star name, [name])
+     }
+
+-- -----------------------------------------------------------------------------
 
 Expression :: { Expression }
   : BaseExpression { $1 }
@@ -162,7 +218,7 @@ BaseExpression :: { Expression }
   | ValIdent {%
                 do let Located src (ValIdent rawName) = $1
                    name <- lookupName src VarEnv rawName
-                   return (ReferenceExp src (trace "NAME" name)) }
+                   return (ReferenceExp src name) }
   | Integer  {%
                 do let Located src (IntTok base val) = $1
                    return (ConstantExp src (ConstantInt base val)) }
@@ -205,12 +261,11 @@ list_body(p)
   | list_body(p) p { $2 : $1 }
 
 listopt(p)
-  : p p p { catMaybes [$1, $2, $3] }
+  : {- empty -}    { [] }
---  : {- empty -}    { [] }
+  | listopt(p) p   { case $2 of
---  | listopt(p) p   { case $2 of
+                       Nothing -> $1
---                       Nothing -> $1
+                       Just x  -> $1 ++ [x]
---                       Just x  -> $1 ++ [x]
+                   }
---                   }
 
 {
 
@@ -320,6 +375,13 @@ registerName redefOk loc env name =
        Just (Name origLoc _ _ _) ->
          raise (RedefinitionError loc origLoc name)
 
+unregisterNames :: NameEnvironment -> [Name] -> Parser ()
+unregisterNames env names =
+  do state <- get
+     let db  = psNameDatabase state
+         db' = foldr (\ (Name _ _ _ n) m -> Map.delete (env, n) m) db names
+     set state{ psNameDatabase = db' }
+
 lookupName :: Location -> NameEnvironment -> Text -> Parser Name
 lookupName loc env name =
   do state <- get

src/Bang/Syntax/Pretty.hs

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

src/Bang/TypeInfer.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE FlexibleInstances #-}
+module Bang.TypeInfer(typeInfer)
+ where
+
+import Bang.Syntax.AST
+import Data.List(union, nub, concat, intersect)
+
+type Subst = [(Name, Type)]
+
+nullSubst :: Subst
+nullSubst  = []
+
+(⟼) :: Name -> Type -> Subst
+(⟼) n t = [(n,t)]
+
+infixr 4 @@
+(@@) :: Subst -> Subst -> Subst
+(@@) s1 s2 = [(u, apply s1 t) | (u,t) <- s2] ++ s1
+
+merge :: Monad m => Subst -> Subst -> m Subst
+merge s1 s2 | agree     = return (s1 ++ s2)
+            | otherwise = fail "merge failed"
+ where
+   agree = all (\ v ->
+                 let refv = TypeReef genLoc Star v
+                 in apply s1 refv == apply s2 refv)
+               (map fst s1 `intersect` map fst s2)
+
+mostGeneralUnifier :: Monad m => Type -> Type -> m Subst
+mostGeneralUnifier t1 t2 =
+  case (t1, t2) of
+    (TypeApp _ _ l r, TypeApp l' r') ->
+      do s1 <- mostGeneralUnifier l l'
+         s2 <- mostGeneralUnifier (apply s1 r) (apply s1 r')
+         return (s2 @@ s1)
+    (TypeRef _ _ u, t) -> varBind u t
+    (t, TypeRef _ _ u) -> varBind u t
+    (TypePrim _ _ tc1, TypePrim _ _ tc2) | tc1 == tc2 -> return nullSubst
+    (t1, t2) -> raise (UnificationError t1 t2)
+
+varBind :: Monad m => Name -> Type -> m Subst
+varBind u t | t == TypeRef _ _ u = return nullSubst
+            | u `elem` tv t      = raise (OccursCheckFails u t)
+            | kind u /= kind t   = raise (KindCheckFails u t)
+            | otherwise          = return (u ⟼  t)
+
+match :: Monad m => Type -> Type -> m Subst
+match t1 t2 =
+  case (t1, t2) of
+    (TypeApp _ _ l r, TypeApp l' r') ->
+      do sl <- match l l'
+         sr <- match r r'
+         merge sl sr
+    (TypeRef _ _ u, t) | kind u == kind t -> return (u ⟼  t)
+    (TypePrim tc1, TypePrim tc2) | tc1 == tc2 -> return nullSubst
+    (t1, t2) -> raise (MatchFailure t1 t2)
+
+data Assumption = Name :>: Scheme
+
+instance Types Assumption where
+  apply s (i :>: sc) = i :>: (apply s sc)
+  tv      (i :>: sc) = tv sc
+
+find :: Monad m => Name -> [Assumption] -> m Scheme
+find i [] = raise (UnboundIdentifier i)
+find i ((i' :>: sc) : as) | i == i'   = return sc
+                          | otherwise = find i as
+
+class Types t where
+  apply :: Subst -> t -> t
+  tv    :: t          -> [Name]
+
+instance Types Type where
+  apply s v@(TypeRef _ _ n) = case lookup n s of
+                                Just t  -> t
+                                Nothing -> v
+  apply s (TypeApp l k t u) = TypeApp l k (apply s t) (apply s u)
+  apply _ t                 = t
+  --
+  tv (TypeRef _ _ n)   = [n]
+  tv (TypeApp _ _ t u) = tv t `union` tv u
+  tv _                 = []
+
+instance Types [Type] where
+  apply s = map (apply s)
+  tv      = nub . concat . map tv
+
+typeInfer :: Module -> Either String Module
+typeInfer = undefined

src/Bang/Utils/PP.hs

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

src/Main.hs

@@ -1,10 +1,15 @@
 import           Bang.CommandLine
-import           Bang.Syntax.AST(ppModule)
+import           Bang.Error(exit)
-import           Bang.Syntax.Lexer
+import           Bang.Syntax.AST(Module)
+import           Bang.Syntax.Lexer(lexer)
 import           Bang.Syntax.Location
-import           Bang.Syntax.Parser
+import           Bang.Syntax.Parser(parseModule)
+import           Bang.Syntax.Pretty(ppModule)
+import           Bang.TypeInfer(typeInfer)
 import           Control.Exception(tryJust)
+import           Control.Lens(view)
 import           Control.Monad(guard)
+import           Data.Text.Lazy(Text)
 import qualified Data.Text.Lazy.IO as T
 import           Data.Version(showVersion)
 import           Paths_bang(version)
@@ -13,32 +18,35 @@ import           Text.PrettyPrint.Annotated(render)
 
 main :: IO ()
 main = getCommand >>= \ cmd ->
-  case cmdCommand cmd of
+  case cmd of
-    Lex   o -> runLexer  cmd o
+    Lex       o -> run o $ \ path body ->
-    Parse o -> runParser cmd o
+                     do let ts = lexer (File path) (Just initialPosition) body
+                        mapM_ (putStrLn . show) ts
+    Parse     o -> run o $ withParsed $ \ mdl ->
+                     putStrLn (render (ppModule mdl))
+    TypeCheck o -> run o $ withParsed $ withInferred $ \ mdl ->
+                     putStrLn (render (ppModule mdl))
+--    Compile   o -> run o $ withParsed $ withInferred $ \ mod ->
+--                     putStrLn (render (ppModule mod))
     Help        -> putStrLn helpString
     Version     -> putStrLn ("Bang tool, version " ++ showVersion version)
 
-runLexer :: BangCommand -> LexerOptions -> IO ()
+run :: CommandsWithInputFile o => o -> (FilePath -> Text -> IO ()) -> IO ()
-runLexer _cmd opts =
+run opts action =
-  do let path = lexInputFile opts
+  do let path = view inputFile opts
      mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path)
      case mtxt of
-       Left _    -> fail ("Unable to open file: " ++ path)
+       Left  _   -> exit ("Unable to open file '" ++ path ++ "'")
-       Right txt ->
+       Right txt -> action path txt
-         do let tokens = lexer (File path) (Just initialPosition) txt
-            mapM_ (putStrLn . show) tokens
 
-runParser :: BangCommand -> ParserOptions -> IO ()
+withParsed :: (Module -> IO ()) -> FilePath -> Text -> IO ()
-runParser _cmd opts =
+withParsed action path body =
-  do let path = parseInputFile opts
+  case parseModule (File path) body of
-     mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path)
+    Left  err -> exit (show err)
-     case mtxt of
+    Right mdl -> action mdl
-       Left  _   -> fail ("Unable to open file: " ++ path)
+
-       Right txt ->
+withInferred :: (Module -> IO ()) -> Module -> IO ()
-         do let res = parseModule (File path) txt
+withInferred action mdl =
-            case res of
+  case typeInfer mdl of
-              Left err ->
+    Left err   -> exit err
-                putStrLn (show err)
+    Right mdl' -> action mdl'
-              Right mod ->
-                putStrLn (render (ppModule mod))

test.bang

@@ -6,3 +6,5 @@ primitive type Word = "u64"
 one :: Word
 one = 1
 
+id :: a -> a
+id x = x