chrisdone/duet
1
1
Fork 0
mirror of https://github.com/chrisdone/duet.git synced 2024-10-06 00:08:57 +03:00
Code Issues Projects Releases Wiki Activity

Parsing qualified types

Browse Source
This commit is contained in:
Chris Done 2017-06-15 18:38:07 +01:00
parent 632a12093e
commit 65f33ee9af
7 changed files with 149 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
app/Main.hs
View File

@ -499,8 +499,8 @@ builtInSignatures specialTypes = do
classSignatures :: MonadThrow m => Class Type Name l -> m [TypeSignature Type Name Name]
classSignatures cls =
mapM
(\(name, (methodVars, ty)) ->
TypeSignature <$> pure name <*> classMethodScheme cls methodVars ty)
(\(name, scheme) ->
TypeSignature <$> pure name <*> classMethodScheme cls scheme)
(M.toList (classMethods cls))
dataTypeSignatures

46
src/Duet/Infer.hs
View File

@ -157,12 +157,11 @@ classMethodsToGroups specialTypes =
(\inst ->
sequence
(zipWith
(\(methodTyVars, methodType) (instMethodName, methodAlt) ->
(\methodScheme (instMethodName, methodAlt) ->
ExplicitlyTypedBinding <$> pure instMethodName <*>
instanceMethodScheme specialTypes
class'
methodTyVars
methodType
methodScheme
(instancePredicate inst) <*>
pure [methodAlt])
(M.elems (classMethods class'))
@ -173,19 +172,19 @@ classMethodsToGroups specialTypes =
instanceMethodScheme
:: MonadThrow m
=> SpecialTypes Name -> Class Type Name l
-> [TypeVariable Name]
-> Type Name
=> SpecialTypes Name
-> Class Type Name l
-> Scheme Type Name
-> Qualified Type Name (Predicate Type Name)
-> m (Scheme Type Name)
instanceMethodScheme _specialTypes cls methodVars0 methodType0 (Qualified preds (IsIn _ headTypes)) = do
methodType <- instantiate methodType0
g_ty' <- pure methodType
g_preds <- mapM instantiatePred preds
pure (Forall methodVars (Qualified g_preds g_ty'))
instanceMethodScheme _specialTypes cls (Forall methodVars0 (Qualified methodPreds methodType0)) (Qualified preds (IsIn _ headTypes)) = do
methodQual <- instantiateQual (Qualified (methodPreds ++ preds) methodType0)
pure (Forall methodVars methodQual)
where
methodVars = filter (not . flip elem (classTypeVariables cls)) methodVars0
table = zip (classTypeVariables cls) headTypes
instantiateQual (Qualified ps t) =
Qualified <$> mapM instantiatePred ps <*> instantiate t
instantiatePred (IsIn c t) = IsIn c <$> mapM instantiate t
instantiate =
\case
@ -199,25 +198,14 @@ instanceMethodScheme _specialTypes cls methodVars0 methodType0 (Qualified preds
classMethodScheme
:: MonadThrow m
=> Class t Name l -> [TypeVariable Name] -> Type Name -> m (Scheme Type Name)
classMethodScheme cls methodVars methodType = do
=> Class t Name l -> Scheme Type Name -> m (Scheme Type Name)
classMethodScheme cls (Forall methodVars (Qualified methodPreds methodType)) = do
ty' <- pure methodType
headVars <- mapM (pure . VariableType) (classTypeVariables cls)
when (null methodVars) (error "!")
pure (Forall methodVars (Qualified [IsIn (className cls) headVars] ty'))
-- genify :: MonadThrow m => [(TypeVariable Name, Type Name)] -> Type Name -> m (Type Name)
-- genify table =
-- \case
-- VariableType tyvar ->
-- case lookup tyvar table of
-- Nothing -> throwM (InvalidMethodTypeVariable (map fst table) tyvar)
-- Just v -> pure v
-- ApplicationType f x -> do
-- f' <- genify table f
-- x' <- genify table x
-- pure (ApplicationType f' x')
-- x -> pure x
pure
(Forall
methodVars
(Qualified (methodPreds ++ [IsIn (className cls) headVars]) ty'))
--------------------------------------------------------------------------------
-- Substitution
@ -682,7 +670,7 @@ addClass
=> Name
-> [TypeVariable Name]
-> [Predicate Type Name]
-> Map Name (([TypeVariable Name], Type Name))
-> Map Name (Scheme Type Name)
-> Map Name (Class Type Name l)
-> m (Map Name (Class Type Name l))
addClass i vs ps methods ce

187
src/Duet/Parser.hs
View File

@ -33,6 +33,15 @@ parseText fp inp =
Left e -> Left e
Right ast -> Right ast
parseType' :: Num u => SourceName -> Parsec [(Token, Location)] u b -> Text -> Either ParseError b
parseType' fp p inp =
case parse tokensTokenizer fp (inp) of
Left e -> Left e
Right tokens' ->
case runParser p 0 fp tokens' of
Left e -> Left e
Right ast -> Right ast
tokensParser :: TokenParser [Decl UnkindedType Identifier Location]
tokensParser = moduleParser <* endOfTokens
@ -81,6 +90,7 @@ classdecl =
, classSuperclasses = []
, classInstances = []
, classMethods = M.fromList methods
})
where
endOfDecl =
@ -103,9 +113,9 @@ classdecl =
" to match the others"))
setState startCol
_ <- equalToken Colons <?> "‘::’ for method signature"
(vars, ty) <- parseScheme <?> "method type signature e.g. foo :: Int"
scheme <- parseScheme <?> "method type signature e.g. foo :: Int"
setState u
pure (Identifier (T.unpack v), (vars, ty))
pure (Identifier (T.unpack v), scheme)
kindableTypeVariable :: Stream s m (Token, Location) => ParsecT s Int m (TypeVariable Identifier)
kindableTypeVariable = (unkinded <|> kinded) <?> "type variable (e.g. ‘a’, ‘f’, etc.)"
@ -137,21 +147,35 @@ kindableTypeVariable = (unkinded <|> kinded) <?> "type variable (e.g. ‘a’,
parseScheme
:: Stream s m (Token, Location)
=> ParsecT s Int m ([TypeVariable Identifier], UnkindedType Identifier)
=> ParsecT s Int m (Scheme UnkindedType Identifier)
parseScheme = do
explicit <-
fmap (const True) (lookAhead (equalToken ForallToken)) <|> pure False
if explicit
then quantified
else do ty <- parsedType
pure (nub (collectTypeVariables ty), ty)
else do
ty@(Qualified _ qt) <- parseQualified
pure (Forall (nub (collectTypeVariables qt)) ty)
where
quantified = do
_ <- equalToken ForallToken
vars <- many1 kindableTypeVariable <?> "type variables"
_ <- equalToken Period
ty <- parsedType
pure (vars, ty)
ty <- parseQualified
pure (Forall vars ty)
parseQualified
:: Stream s m (Token, Location)
=> ParsecT s Int m (Qualified UnkindedType Identifier (UnkindedType Identifier))
parseQualified = do
ty <- parsedTypeLike
(case ty of
ParsedQualified ps x -> Qualified <$> mapM toUnkindedPred ps <*> toType x
where toUnkindedPred (IsIn c ts) = IsIn c <$> mapM toType ts
_ -> do
t <- toType ty
pure (Qualified [] t)) <?>
"qualified type e.g. Show x => x"
collectTypeVariables :: UnkindedType i -> [TypeVariable i]
collectTypeVariables =
@ -174,7 +198,7 @@ instancedecl =
Constructor c -> Just c
_ -> Nothing) <?>
"class name e.g. Show"
ty <- parsedType
ty <- parseType
mwhere <-
fmap (const True) (equalToken Where) <|> fmap (const False) endOfDecl
methods <-
@ -225,63 +249,21 @@ instancedecl =
setState u
pure (Identifier (T.unpack v), makeAlt (expressionLabel e) e)
-- parseType :: TokenParser (Type Identifier)
-- parseType = infix' <|> app <|> unambiguous
-- where
-- infix' = do
-- left <- (app <|> unambiguous) <?> "left-hand side of function arrow"
-- tok <- fmap Just (operator <?> ("function arrow " ++ curlyQuotes "->")) <|> pure Nothing
-- case tok of
-- Just (RightArrow, _) -> do
-- right <-
-- parseType <?>
-- ("right-hand side of function arrow " ++ curlyQuotes "->")
-- pure
-- (ApplicationType
-- (ApplicationType
-- (ConstructorType
-- (TypeConstructor
-- (Identifier "(->)")
-- (FunctionKind StarKind StarKind)))
-- left)
-- right)
-- _ -> pure left
-- where
-- operator =
-- satisfyToken
-- (\case
-- RightArrow {} -> True
-- _ -> False)
-- app = do
-- f <- unambiguous
-- args <- many unambiguous
-- pure (foldl' ApplicationType f args)
-- unambiguous = atomicType <|> parensTy parseType
-- atomicType = consParse <|> varParse
-- consParse = do
-- (v, _) <-
-- consumeToken
-- (\case
-- Constructor i -> Just i
-- _ -> Nothing) <?>
-- "type constructor (e.g. Int, Maybe)"
-- pure
-- (ConstructorType (TypeConstructor (Identifier (T.unpack v)) StarKind))
-- varParse = do
-- (v, _) <-
-- consumeToken
-- (\case
-- Variable i -> Just i
-- _ -> Nothing) <?>
-- "type variable (e.g. a, f)"
-- pure (VariableType (TypeVariable (Identifier (T.unpack v)) StarKind))
-- parensTy p = go <?> "parentheses e.g. (T a)"
-- where
-- go = do
-- _ <- equalToken OpenParen
-- e <- p <?> "type inside parentheses e.g. (Maybe a)"
-- _ <- equalToken CloseParen <?> "closing parenthesis ‘)’"
-- pure e
parseType :: Stream s m (Token, Location) => ParsecT s Int m (UnkindedType Identifier)
parseType = do
x <- parsedTypeLike
toType x
toType :: Stream s m t => ParsedType i -> ParsecT s u m (UnkindedType i)
toType = go
where
go =
\case
ParsedTypeConstructor i -> pure (UnkindedTypeConstructor i)
ParsedTypeVariable i -> pure (UnkindedTypeVariable i)
ParsedTypeApp t1 t2 -> UnkindedTypeApp <$> go t1 <*> go t2
ParsedQualified {} -> unexpected "qualification context"
ParsedTuple {} -> unexpected "tuple"
datadecl :: TokenParser (DataType UnkindedType Identifier)
datadecl = go <?> "data declaration (e.g. data Maybe a = Just a | Nothing)"
@ -345,7 +327,7 @@ consp = do c <- consParser
(Identifier (T.unpack c))
slot :: TokenParser (UnkindedType Identifier)
slot = consParser <|> variableParser <|> parens parsedType
slot = consParser <|> variableParser <|> parens parseType
where
variableParser = go <?> "type variable (e.g. ‘a’, ‘s’, etc.)"
where
@ -366,23 +348,38 @@ slot = consParser <|> variableParser <|> parens parsedType
_ -> Nothing)
pure (UnkindedTypeConstructor (Identifier (T.unpack c)))
parsedType :: TokenParser (UnkindedType Identifier)
parsedType = infix' <|> app <|> unambiguous
data ParsedType i
= ParsedTypeConstructor i
| ParsedTypeVariable i
| ParsedTypeApp (ParsedType i) (ParsedType i)
| ParsedQualified [Predicate ParsedType i] (ParsedType i)
| ParsedTuple [ParsedType i]
deriving (Show)
parsedTypeLike :: TokenParser (ParsedType Identifier)
parsedTypeLike = infix' <|> app <|> unambiguous
where
infix' = do
left <- (app <|> unambiguous) <?> "left-hand side of function arrow"
tok <-
fmap Just (operator <?> ("function arrow " ++ curlyQuotes "->")) <|>
fmap Just (operator2 <?> ("constraint arrow " ++ curlyQuotes "=>")) <|>
pure Nothing
case tok of
Just (RightArrow, _) -> do
right <-
parsedType <?>
parsedTypeLike <?>
("right-hand side of function arrow " ++ curlyQuotes "->")
pure
(UnkindedTypeApp
(UnkindedTypeApp (UnkindedTypeConstructor (Identifier "(->)")) left)
(ParsedTypeApp
(ParsedTypeApp (ParsedTypeConstructor (Identifier "(->)")) left)
right)
Just (Imply, _) -> do
left' <- parsedTypeToPredicates left <?> "constraints e.g. Show a or (Read a, Show a)"
right <-
parsedTypeLike <?>
("right-hand side of constraints " ++ curlyQuotes "=>")
pure (ParsedQualified left' right)
_ -> pure left
where
operator =
@ -390,11 +387,22 @@ parsedType = infix' <|> app <|> unambiguous
(\case
RightArrow {} -> True
_ -> False)
operator2 =
satisfyToken
(\case
Imply {} -> True
_ -> False)
app = do
f <- unambiguous
args <- many unambiguous
pure (foldl' UnkindedTypeApp f args)
unambiguous = atomicType <|> parensTy parsedType
pure (foldl' ParsedTypeApp f args)
unambiguous =
atomicType <|>
parensTy
(do xs <- sepBy1 parsedTypeLike (equalToken Comma)
case xs of
[x] -> pure x
_ -> pure (ParsedTuple xs))
atomicType = consParse <|> varParse
consParse = do
(v, _) <-
@ -403,9 +411,7 @@ parsedType = infix' <|> app <|> unambiguous
Constructor i -> Just i
_ -> Nothing) <?>
"type constructor (e.g. Int, Maybe)"
pure
(UnkindedTypeConstructor
(Identifier (T.unpack v)))
pure (ParsedTypeConstructor (Identifier (T.unpack v)))
varParse = do
(v, _) <-
consumeToken
@ -413,7 +419,7 @@ parsedType = infix' <|> app <|> unambiguous
Variable i -> Just i
_ -> Nothing) <?>
"type variable (e.g. a, f)"
pure (UnkindedTypeVariable (Identifier (T.unpack v)))
pure (ParsedTypeVariable (Identifier (T.unpack v)))
parensTy p = go <?> "parentheses e.g. (T a)"
where
go = do
@ -422,6 +428,33 @@ parsedType = infix' <|> app <|> unambiguous
_ <- equalToken CloseParen <?> "closing parenthesis ‘)’"
pure e
parsedTypeToPredicates :: Stream s m t => ParsedType i -> ParsecT s u m [Predicate ParsedType i]
parsedTypeToPredicates =
\case
ParsedTuple xs -> mapM toPredicate xs
x -> fmap return (toPredicate x)
where
toPredicate :: Stream s m t => ParsedType i -> ParsecT s u m (Predicate ParsedType i)
toPredicate t =
case targs t of
(ParsedTypeConstructor i, vars@ (_:_)) -> do
vs <- mapM toVar vars
pure (IsIn i vs)
_ -> unexpected "non-class constraint"
toVar :: Stream s m t1 => ParsedType t -> ParsecT s u m (ParsedType t)
toVar =
\case
v@ParsedTypeVariable {} -> pure v
_ -> unexpected "non-type-variable"
targs :: ParsedType t -> (ParsedType t, [ParsedType t])
targs e = go e []
where
go (ParsedTypeApp f x) args = go f (x : args)
go f args = (f, args)
varfundecl :: TokenParser (ImplicitlyTypedBinding UnkindedType Identifier Location)
varfundecl = go <?> "variable declaration (e.g. x = 1, f = \\x -> x * x)"
where

15
src/Duet/Printer.hs
View File

@ -148,8 +148,6 @@ printExpression printer e =
case x of
VariableExpression _ (nonrenamableName -> Just (DictName {}))
| not (printDictionaries printer) -> printExpressionAppOp printer f
where isLam (LambdaExpression {}) = True
isLam _ = False
_ ->
if any (== '\n') inner || any (== '\n') prefix
then prefix ++ "\n" ++ indented inner
@ -195,6 +193,7 @@ printExpression printer e =
then "(" ++ k ++ ")"
else k
indented :: String -> [Char]
indented x = intercalate "\n" (map (" "++) (lines x))
indent :: Int -> String -> [Char]
@ -298,6 +297,7 @@ printScheme printer specialTypes (Forall kinds qualifiedType') =
", "
(map (printPredicate printer specialTypes) predicates) ++
") => " ++ printType printer specialTypes typ
printClass :: Printable i => Print i l -> SpecialTypes i -> Class Type i l -> String
printClass printer specialTypes (Class vars supers instances i methods) =
"class " ++
@ -308,14 +308,9 @@ printClass printer specialTypes (Class vars supers instances i methods) =
intercalate "\n " (map (printMethod printer specialTypes) (M.toList methods)) ++
"\n" ++ intercalate "\n" (map (printInstance printer specialTypes) instances)
printMethod :: Printable i => Print i l -> SpecialTypes i -> (i, ([TypeVariable i], Type i)) -> String
printMethod printer specialTypes (i, (vars, ty)) =
printit printer i ++ " :: " ++ vars' ++ printType printer specialTypes ty
where
vars' =
if null vars
then ""
else "forall " ++ unwords (map (printTypeVariable printer) vars) ++ ". "
printMethod :: Printable i => Print i l -> SpecialTypes i -> (i, Scheme Type i) -> String
printMethod printer specialTypes (i, scheme) =
printit printer i ++ " :: " ++ printScheme printer specialTypes scheme
printInstance :: Printable i => Print i l -> SpecialTypes i -> Instance Type i l -> String
printInstance printer specialTypes (Instance (Qualified predicates typ) _) =

13
src/Duet/Renamer.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@ -161,12 +162,20 @@ renameClass specialTypes subs types cls = do
fmap
M.fromList
(mapM
(\(name, (vars, ty)) -> do
(\(name, (Forall vars (Qualified preds ty))) -> do
name' <- supplyMethodName name
methodVars <- mapM (renameMethodTyVar classVars) vars
let classAndMethodVars = nub (classVars ++ methodVars)
ty' <- renameType specialTypes classAndMethodVars types ty
pure (name', (map snd classAndMethodVars, ty')))
preds' <-
mapM
(\(IsIn c tys) ->
IsIn <$> substituteClass subs c <*>
mapM (renameType specialTypes classAndMethodVars types) tys)
preds
pure
( name'
, (Forall (map snd classAndMethodVars) (Qualified preds' ty'))))
(M.toList (classMethods cls)))
pure
(Class

3
src/Duet/Tokenizer.hs
View File

@ -21,6 +21,7 @@ import Text.Printf
data Token
= If
| Imply
| Then
| Data
| ForallToken
@ -86,6 +87,7 @@ tokenTokenizer prespaces =
, atom Backslash "\\"
, atom OpenParen "("
, atom CloseParen ")"
, atom Imply "=>"
, atom Equals "="
, atom Bar "|"
, atom Colons "::"
@ -357,6 +359,7 @@ tokenStr tok =
case tok of
If -> curlyQuotes "if"
Then -> curlyQuotes "then"
Imply -> curlyQuotes "=>"
RightArrow -> curlyQuotes "->"
Else -> curlyQuotes "else"
Where -> curlyQuotes "where"

2
src/Duet/Types.hs
View File

@ -326,7 +326,7 @@ data Class (t :: * -> *) i l = Class
, classSuperclasses :: ![Predicate t i]
, classInstances :: ![Instance t i l]
, className :: i
, classMethods :: Map i ([TypeVariable i], t i)
, classMethods :: Map i (Scheme t i)
} deriving (Show)
-- | Class instance.