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

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