acw/bang
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Checkpoint: Working my way through Typing Haskell in Haskell.

Browse Source
This commit is contained in:
Adam Wick
2016-06-20 18:31:12 -07:00
parent 89a7df58e5
commit 156120fbec
10 changed files with 430 additions and 143 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
bang.cabal
View File

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

148
src/Bang/CommandLine.hs
View File

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

11
src/Bang/Error.hs Normal file
View File

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

67
src/Bang/Syntax/AST.hs
View File

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

110
src/Bang/Syntax/Parser.y
View File

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

63
src/Bang/Syntax/Pretty.hs Normal file
View File

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

89
src/Bang/TypeInfer.hs Normal file
View File

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

9
src/Bang/Utils/PP.hs Normal file
View File

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

64
src/Main.hs
View File

@@ -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'

2
test.bang
View File

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