diff --git a/bang.cabal b/bang.cabal index 9732f75..b277228 100644 --- a/bang.cabal +++ b/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 diff --git a/src/Bang/CommandLine.hs b/src/Bang/CommandLine.hs index 569eb6f..8008a1c 100644 --- a/src/Bang/CommandLine.hs +++ b/src/Bang/CommandLine.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} module Bang.CommandLine( - BangCommand(..) - , BangOperation(..) + Verbosity(..) + , CommandsWithInputFile(..) + , CommandsWithOutputFile(..) + , CommandsWithVerbosity(..) + , BangCommand(..) , LexerOptions(..) , ParserOptions(..) , getCommand @@ -8,15 +12,26 @@ module Bang.CommandLine( ) where -import Options.Applicative -import Options.Applicative.Help +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) -data BangCommand = BangCommand { - cmdVerbosity :: Verbosity - , cmdOutputFile :: FilePath - , cmdCommand :: BangOperation - } - deriving (Show) +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) @@ -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 -outputFile = strOption (short 'o' <> long "output-file" <> metavar "FILE" +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 BangOperation = Help - | Version - | Lex LexerOptions - | Parse ParserOptions - deriving (Show) - -bangOperation :: Parser BangOperation -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.") - -withInfo :: Parser a -> String -> ParserInfo a -withInfo opts desc = info (helper <*> opts) (progDesc desc) +-- ----------------------------------------------------------------------------- data LexerOptions = LexerOptions { - lexInputFile :: FilePath + _lexInputFile :: FilePath + , _lexOutputFile :: FilePath + , _lexVerbosity :: Verbosity } deriving (Show) -parseLex :: Parser BangOperation -parseLex = Lex <$> parseLexOptions +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 + _parseInputFile :: FilePath + , _parseOutputFile :: FilePath + , _parseVerbosity :: Verbosity } deriving (Show) -parseParse :: Parser BangOperation -parseParse = Parse <$> parseParseOptions +makeLenses ''ParserOptions parseParseOptions :: Parser ParserOptions parseParseOptions = ParserOptions <$> argument str (metavar "FILE") + <*> optOutputFile + <*> verboseOption -parseOptions :: Parser BangCommand -parseOptions = BangCommand <$> verboseOption <*> outputFile <*> bangOperation +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 "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) 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.") diff --git a/src/Bang/Error.hs b/src/Bang/Error.hs new file mode 100644 index 0000000..4cad672 --- /dev/null +++ b/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) diff --git a/src/Bang/Syntax/AST.hs b/src/Bang/Syntax/AST.hs index fac426e..4379785 100644 --- a/src/Bang/Syntax/AST.hs +++ b/src/Bang/Syntax/AST.hs @@ -1,9 +1,8 @@ module Bang.Syntax.AST where -import Data.Text.Lazy(Text, unpack) -import Bang.Syntax.Location -import Text.PrettyPrint.Annotated +import Data.Text.Lazy(Text) +import Bang.Syntax.Location(Location) 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 -ppName (Name _ _ _ t) = text' t +instance Eq Name where + (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 -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 - ConstantChar c -> text' c - ConstantString s -> text' s - ConstantFloat f -> text' f - -data Type = TypeRef Location Name +data Type = TypeUnit Location Kind + | TypePrim Location Kind Text + | TypeRef Location Kind Name + | TypeLambda Location Kind Type Type + | TypeApp Location Kind Type Type + | TypeForAll [Name] Type deriving (Show) -ppType :: Type -> Doc a -ppType t = - case t of - TypeRef _ n -> ppName n +kind :: Type -> Kind +kind (TypeUnit _ k) = k +kind (TypePrim _ k _) = k +kind (TypeRef _ k _) = k +kind (TypeLambda _ k _ _) = k +kind (TypeApp _ k _ _) = k +kind (TypeForAll _ t) = kind t -text' :: Text -> Doc a -text' = text . unpack +data Kind = Star + | KindArrow Kind Kind + deriving (Show) diff --git a/src/Bang/Syntax/Parser.y b/src/Bang/Syntax/Parser.y index 401aed6..3bb120e 100644 --- a/src/Bang/Syntax/Parser.y +++ b/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)) } - | 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 } + return (TypeDeclaration name $3) } | '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 -} { [] } --- | listopt(p) p { case $2 of --- Nothing -> $1 --- Just x -> $1 ++ [x] --- } + : {- empty -} { [] } + | listopt(p) p { case $2 of + Nothing -> $1 + 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 diff --git a/src/Bang/Syntax/Pretty.hs b/src/Bang/Syntax/Pretty.hs new file mode 100644 index 0000000..bed681d --- /dev/null +++ b/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 diff --git a/src/Bang/TypeInfer.hs b/src/Bang/TypeInfer.hs new file mode 100644 index 0000000..5f368c8 --- /dev/null +++ b/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 diff --git a/src/Bang/Utils/PP.hs b/src/Bang/Utils/PP.hs new file mode 100644 index 0000000..c07df3b --- /dev/null +++ b/src/Bang/Utils/PP.hs @@ -0,0 +1,9 @@ +module Bang.Utils.PP( + PP(..) + ) + where + +import + +class PP a where + ppr :: a -> Doc diff --git a/src/Main.hs b/src/Main.hs index 376efb6..f753d5f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,10 +1,15 @@ import Bang.CommandLine -import Bang.Syntax.AST(ppModule) -import Bang.Syntax.Lexer +import Bang.Error(exit) +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 - Lex o -> runLexer cmd o - Parse o -> runParser cmd o - Help -> putStrLn helpString - Version -> putStrLn ("Bang tool, version " ++ showVersion version) + case cmd of + Lex o -> run o $ \ path body -> + do let ts = lexer (File path) (Just initialPosition) body + mapM_ (putStrLn . show) ts + Parse o -> run o $ withParsed $ \ mdl -> + putStrLn (render (ppModule mdl)) + TypeCheck o -> run o $ withParsed $ withInferred $ \ mdl -> + putStrLn (render (ppModule mdl)) +-- Compile o -> run o $ withParsed $ withInferred $ \ mod -> +-- putStrLn (render (ppModule mod)) + Help -> putStrLn helpString + Version -> putStrLn ("Bang tool, version " ++ showVersion version) -runLexer :: BangCommand -> LexerOptions -> IO () -runLexer _cmd opts = - do let path = lexInputFile opts +run :: CommandsWithInputFile o => o -> (FilePath -> Text -> IO ()) -> IO () +run opts action = + do let path = view inputFile opts mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path) case mtxt of - Left _ -> fail ("Unable to open file: " ++ path) - Right txt -> - do let tokens = lexer (File path) (Just initialPosition) txt - mapM_ (putStrLn . show) tokens + Left _ -> exit ("Unable to open file '" ++ path ++ "'") + Right txt -> action path txt -runParser :: BangCommand -> ParserOptions -> IO () -runParser _cmd opts = - do let path = parseInputFile opts - mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path) - case mtxt of - Left _ -> fail ("Unable to open file: " ++ path) - Right txt -> - do let res = parseModule (File path) txt - case res of - Left err -> - putStrLn (show err) - Right mod -> - putStrLn (render (ppModule mod)) +withParsed :: (Module -> IO ()) -> FilePath -> Text -> IO () +withParsed action path body = + case parseModule (File path) body of + Left err -> exit (show err) + Right mdl -> action mdl + +withInferred :: (Module -> IO ()) -> Module -> IO () +withInferred action mdl = + case typeInfer mdl of + Left err -> exit err + Right mdl' -> action mdl' diff --git a/test.bang b/test.bang index 09aaf83..9fe28dc 100644 --- a/test.bang +++ b/test.bang @@ -6,3 +6,5 @@ primitive type Word = "u64" one :: Word one = 1 +id :: a -> a +id x = x