Skip to content

Commit

Permalink
add deriving Show / (==) support using implicit parameters
Browse files Browse the repository at this point in the history
  • Loading branch information
TimWhiting committed Jan 13, 2024
1 parent 594e4e3 commit 3dee692
Show file tree
Hide file tree
Showing 11 changed files with 369 additions and 21 deletions.
1 change: 1 addition & 0 deletions koka.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -104,6 +104,7 @@ library
Syntax.Lexeme
Syntax.Lexer
Syntax.Parse
Syntax.Pretty
Syntax.Promote
Syntax.RangeMap
Syntax.Syntax
Expand Down
3 changes: 3 additions & 0 deletions src/Common/NamePrim.hs
Original file line number Diff line number Diff line change
Expand Up @@ -44,6 +44,7 @@ module Common.NamePrim

, nameIntAdd, nameIntSub

, nameEq, nameShow
-- Effects
, nameTpHTag, nameHTag
, nameTpClause, namePerform
Expand Down Expand Up @@ -516,6 +517,8 @@ isNameTpTuple name
where
s = nameLocal name

nameShow = newName "show"
nameEq = newName "=="

preludeName s
= qualify nameSystemCore (newName s)
Expand Down
2 changes: 1 addition & 1 deletion src/Core/Parse.hs
Original file line number Diff line number Diff line change
Expand Up @@ -187,7 +187,7 @@ typeDecl env
let cons1 = case cons of
[con] -> [con{ conInfoSingleton = True }]
_ -> cons
dataInfo = DataInfo sort tname kind params cons1 range ddef vis doc
dataInfo = DataInfo sort tname kind params cons1 [] range ddef vis doc
return (Data dataInfo isExtend, env)
<|>
do (vis,doc) <- try $ do vis <- vispub
Expand Down
187 changes: 178 additions & 9 deletions src/Kind/Infer.hs

Large diffs are not rendered by default.

4 changes: 2 additions & 2 deletions src/Static/BindingGroups.hs
Original file line number Diff line number Diff line change
Expand Up @@ -43,14 +43,14 @@ bindingsTypeDefs modName typeDefGroups

isDefinition td
= case td of
DataType binder args cons range vis sort ddef isExtend doc -> not isExtend
DataType binder args cons derives range vis sort ddef isExtend doc -> not isExtend
_ -> True

dependencyTypeDef :: Name -> UserTypeDef -> (Name,S.NameSet)
dependencyTypeDef modName typeDef
= case typeDef of
Synonym binder args tp range vis doc -> (typeDefName typeDef, S.map normalize (freeTypes tp))
DataType binder args cons range vis sort ddef isExtend doc -> (typeDefName typeDef, S.map normalize (freeTypes cons))
DataType binder args cons derives range vis sort ddef isExtend doc -> (typeDefName typeDef, S.map normalize (freeTypes cons) )
where
normalize name = if qualifier name == modName then unqualify name else name

Expand Down
22 changes: 16 additions & 6 deletions src/Syntax/Parse.hs
Original file line number Diff line number Diff line change
Expand Up @@ -584,9 +584,10 @@ dataTypeDecl dvis =
let name = tbind kind
resTp = TpApp (tpCon name) (map tpVar tpars) (combineRanged name tpars)
(cs,crng) <- semiBracesRanged (constructor defvis tpars resTp) <|> return ([],rangeNull)
derives <- pDeriving
let (constrs,creatorss) = unzip cs
range = combineRanges [vrng,trng, getRange (tbind kind),prng,crng]
return (DataType name tpars constrs range vis typeSort ddef isExtend doc, concat creatorss)
return (DataType name tpars constrs derives range vis typeSort ddef isExtend doc, concat creatorss)
where
tpVar tb = TpVar (tbinderName tb) (tbinderRange tb)
tpCon tb = TpCon (tbinderName tb) (tbinderRange tb)
Expand All @@ -608,16 +609,25 @@ structDecl dvis =
tpars <- angles tbinders <|> return []
let name = tbind KindNone
resTp = TpApp (tpCon name) (map tpVar tpars) (combineRanged name tpars)

(pars,prng) <- conPars defvis
derives <- pDeriving
let (tid,rng) = getRName name
conId = toConstructorName tid
(usercon,creators) = makeUserCon conId tpars resTp [] pars rng (combineRange rng prng) defvis doc
return (DataType name tpars [usercon] (combineRanges [vrng,trng,rng,prng]) vis Inductive ddef False doc, creators)
return (DataType name tpars [usercon] derives (combineRanges [vrng,trng,rng,prng]) vis Inductive ddef False doc, creators)

tpVar tb = TpVar (tbinderName tb) (tbinderRange tb)
tpCon tb = TpCon (tbinderName tb) (tbinderRange tb)

pDeriving :: LexParser [Name]
pDeriving =
do
(try $ do option rangeNull semiColon -- semicolon is automatically inserted after the closing block, but this is still part of the block
specialId "deriving"
result <- parensCommas identifier
return $ map fst result)
<|> return []

{-
<|>
do trng <- keyword "enum"
Expand Down Expand Up @@ -855,14 +865,14 @@ makeEffectDecl decl =
evName = newName "ev"
evFld = ValueBinder evName evTp Nothing irng rng
evCon = UserCon (toConstructorName id) [] [(Private,evFld)] Nothing irng rng Private ""
in (DataType ename tpars [evCon] rng vis Inductive (DataDefNormal {-DataDefValue 0 0-}) False docx
in (DataType ename tpars [evCon] [] rng vis Inductive (DataDefNormal {-DataDefValue 0 0-}) False docx
,(\action -> Lam [ValueBinder evName Nothing Nothing irng rng]
(App (action) [(Nothing,App (Var (toConstructorName id) False rng) [(Nothing,Var evName False rng)] rng)] rng)
rng))
else let -- add a private constructor that refers to the handler type to get a proper recursion check
hndfld = ValueBinder nameNil hndTp Nothing irng irng
hndcon = UserCon (toConstructorName id) [hndEffTp,hndResTp] [(Private,hndfld)] Nothing irng irng Private ""
in (DataType ename tpars [hndcon] rng vis Inductive DataDefNormal False docx, \action -> action)
in (DataType ename tpars [hndcon] [] rng vis Inductive DataDefNormal False docx, \action -> action)

-- declare the effect handler type
kindEffect = KindCon nameKindEffect krng
Expand Down Expand Up @@ -903,7 +913,7 @@ makeEffectDecl decl =
getOpName (OpDecl (doc,opId,_,idrng,linear,opSort,exists0,pars,prng,mbteff,tres)) = show (unqualify opId)

hndCon = UserCon (toConstructorName hndName) [] [(Public,fld) | fld <- opFields] Nothing krng grng vis ""
hndTpDecl = DataType hndTpName (tparsNonScoped ++ [hndEffTp,hndResTp]) [hndCon] grng vis sort DataDefNormal False ("// handlers for the " ++ docEffect)
hndTpDecl = DataType hndTpName (tparsNonScoped ++ [hndEffTp,hndResTp]) [hndCon] [] grng vis sort DataDefNormal False ("// handlers for the " ++ docEffect)

-- declare the handle function

Expand Down
94 changes: 94 additions & 0 deletions src/Syntax/Pretty.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,94 @@

------------------------------------------------------------------------------
-- Copyright 2023, Tim Whiting
--
-- This is free software; you can redistribute it and/or modify it under the
-- terms of the Apache License, Version 2.0. A copy of the License can be
-- found in the LICENSE file at the root of this distribution.
-----------------------------------------------------------------------------
{-
Pretty print user syntax
-}
-----------------------------------------------------------------------------
module Syntax.Pretty( ppBinder, ppPatBinder, alwaysTrue, ppGuard, ppPattern, ppLit, ppBranch, ppDefBinder, ppDef, ppDefGroup, ppExpr) where
import Type.Pretty
import Type.Type
import Core.Pretty
import Lib.PPrint
import Syntax.Syntax
import Common.Syntax
import Common.ColorScheme
import Common.NamePrim(nameTrue)

ppBinder :: Env -> ValueBinder (Maybe Type) (Maybe (Expr Type)) -> Doc
ppBinder env (ValueBinder name tp expr _ _)
= ppName env name <+> case tp of Nothing -> empty; Just x -> text ":" <+> ppType env x <+> case expr of Nothing -> empty; Just x -> text "=" <+> ppExpr env x

ppPatBinder :: Env -> ValueBinder (Maybe Type) (Pattern Type) -> Doc
ppPatBinder env (ValueBinder name _ _ _ _)
= ppName env name

alwaysTrue :: Expr Type -> Bool
alwaysTrue (Var n _ _) | n == nameTrue = True
alwaysTrue _ = False

ppGuard :: Env -> Guard Type -> Doc
ppGuard env (Guard expr expr2)
= if alwaysTrue expr then text "->" <+> ppExpr env expr2 else text "|" <+> ppExpr env expr <+> text "->" <+> ppExpr env expr2

ppPattern :: Env -> Pattern Type -> Doc
ppPattern env pat
= case pat of
PatWild _ -> text "_"
PatVar vb -> ppPatBinder env vb
PatAnn pat' ty _ -> ppPattern env pat' <+> text ":" <+> ppType env ty
PatCon na x0 _ _ -> ppName env na <.> tupled (map (\x -> ppPattern env (snd x)) x0)
PatParens pat' _ -> tupled [ppPattern env pat']
PatLit lit -> ppLit env lit

ppLit :: Env -> Lit -> Doc
ppLit env lit
= case lit of
LitInt i _ -> text (show i)
LitChar c _ -> text (show c)
LitString s _ -> text (show s)
LitFloat f _ -> text (show f)

ppBranch:: Env -> Branch Type -> Doc
ppBranch env (Branch pat guards)
= ppPattern env pat <-> hang 2 (vcat (map (ppGuard env) guards))

ppDefBinder :: Env -> ValueBinder () (Expr Type) -> Doc
ppDefBinder env (ValueBinder name _ expr _ _)
= ppName env name <+> text "=" <+> ppExpr env expr

ppDef :: Env -> Def Type -> Doc
ppDef env (Def binder _ vis sort inline doc)
= prettyComment env doc $
(if isPrivate vis then empty else ppVis env vis) <+> text (show sort) <+>
ppDefBinder env binder

ppDefGroup:: Env -> DefGroup Type -> Doc
ppDefGroup env dg
= case dg of
DefNonRec def -> ppDef env def
DefRec defs -> sep (map (ppDef env) defs)

ppExpr :: Env -> Expr Type -> Doc
ppExpr env expr
= color (colorSource (colors env)) $
case expr of
Lam vbs ex _ -> keyword env "fn" <.> tupled (map (ppBinder env) vbs) <-> hang 2 (ppExpr env ex)
App ex x0 _ -> ppExpr env ex <.>
tupled (map (\(n, x) -> (case n of {Just (n,_) -> ppName env n <+> text "= "; Nothing -> empty}) <+> ppExpr env x) x0)
Var na b ra -> ppName env na
Case ex brs ra -> keyword env "match" <+> ppExpr env ex <-> hang 2 (vcat (map (ppBranch env) brs))
Ann ex ty _ -> ppExpr env ex <+> text ":" <+> ppType env ty
Parens ex _ _ _ -> tupled [ppExpr env ex]
Lit lit -> ppLit env lit
-- Not as sure about these
Let dg ex _ -> keyword env "val" <+> ppDefGroup env dg <+> text "=" <+> ppExpr env ex
Inject ty ex b _ -> keyword env "mask" <+> if b then keyword env "behind" else empty <.> angled [ppType env ty] <+> tupled [ppExpr env ex]
Bind dg ex _ -> keyword env "val" <+> ppDef env dg <+> text "=" <+> ppExpr env ex
_ -> text "Pretty print for handlers is not implemented yet"
-- Handler hs hs' ho m_b m_ty vbs m_ex ma m_ex' hbs ra ra' -> text "handle"
1 change: 1 addition & 0 deletions src/Syntax/Syntax.hs
Original file line number Diff line number Diff line change
Expand Up @@ -137,6 +137,7 @@ data TypeDef t u k
| DataType{ typeDefBinder :: (TypeBinder k)
, typeDefParams :: [TypeBinder k]
, typeDefConstrs :: [UserCon t u k]
, typeDefDerives :: [Name]
, typeDefRange :: Range
, typeDefVis :: Visibility
, typeDefSort :: DataKind
Expand Down
4 changes: 2 additions & 2 deletions src/Type/Pretty.hs
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@
module Type.Pretty (-- * Pretty
ppType, ppScheme, ppTypeVar, ppDataInfo, ppSynInfo
,prettyDataInfo, prettyConInfo, prettyDefFunType
,ppSchemeEffect, ppDeclType, ppPred
,ppSchemeEffect, ppDeclType, ppPred, ppVis
,niceTypeInitial, niceTypeExtend, niceTypeExtendVars
,precTop, precArrow, precApp, precAtom, pparens
,Env(..), defaultEnv
Expand Down Expand Up @@ -242,7 +242,7 @@ ppDataInfo env showBody isExtend dataInfo
commaSep = hsep . punctuate comma


prettyDataInfo env0 showBody publicOnly isExtend info@(DataInfo datakind name kind args cons range datadef vis doc)
prettyDataInfo env0 showBody publicOnly isExtend info@(DataInfo datakind name kind args cons derives range datadef vis doc)
= if (publicOnly && isPrivate vis) then empty else
(prettyComment env0 doc $
(if publicOnly then empty else ppVis env0 vis) <.>
Expand Down
14 changes: 13 additions & 1 deletion src/Type/Type.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,7 @@ module Type.Type (-- * Types
-- ** Accessors
, maxSynonymRank
, synonymRank, typeVarId, typeConName, typeSynName
, isBound, isSkolem, isMeta
, isBound, isSkolem, isMeta, isStarType, isStarTypeVar
-- ** Operations
, makeScheme
, quantifyType, qualifyType, applyType, tForall
Expand Down Expand Up @@ -173,6 +173,7 @@ data DataInfo = DataInfo{ dataInfoSort :: DataKind
, dataInfoKind :: Kind
, dataInfoParams :: [TypeVar] {- ^ arguments -}
, dataInfoConstrs :: [ConInfo]
, dataInfoDerives :: [Name]
, dataInfoRange :: Range
, dataInfoDef :: DataDef -- value(raw,scan), normal, rec, open
, dataInfoVis :: Visibility
Expand Down Expand Up @@ -471,6 +472,17 @@ splitFunType tp
-> splitFunType t
_ -> Nothing

isStarType_ :: Type -> Bool
isStarType_ (TVar (TypeVar id kind _)) = hasKindStarResult kind
isStarType_ (TApp (TCon (TypeCon _ kind)) _) = hasKindStarResult kind
isStarType_ (TCon (TypeCon _ kind)) = hasKindStarResult kind
isStarType_ _ = False

isStarType :: Type -> Bool
isStarType = isStarType_ . canonicalForm

isStarTypeVar :: TypeVar -> Bool
isStarTypeVar (TypeVar id kind _) = hasKindStarResult kind

{--------------------------------------------------------------------------
Primitive types
Expand Down
58 changes: 58 additions & 0 deletions test/kind/deriving.kk
Original file line number Diff line number Diff line change
@@ -0,0 +1,58 @@
// Simple struct
struct hello1
abc: int
deriving(show)

// Function
type hello<e::E>
Hello(f: () -> e ())
deriving(show)

// Mutually recursive types
type even<t>
Even(o1: odd<t>)
Zero(t: t)
deriving(show,(==))

type odd<t>
Odd(o1: even<t>)
deriving(show,(==))

// More complex domain
type vvalue
IntV(i: int)
BoolV(b: bool)
CharV(c: char)
StringV(s: string)

alias primop = (vvalue) -> <console,pure> vvalue

type expr<t,x::E>
Int(i: int)
X(x: () -> x ())
Bool(b: bool)
Char(c: char)
String(s: string)
Var(s: string)
List(l: list<t>)
Lam(x: string, y: expr<t,x>)
App(op: expr<t,x>, args: list<expr<t,x>>)
PrimOp(name: string, prim: primop)
deriving(show, (==))

fun main()
val h = Hello(fn () println("Hi!"))
h.hello/show.println
f(h)()
Even(Odd(Zero(0))).show().println
val x = Lam("x", Var("x"))
[0, 1, 2] == [2, 3, 4]
val y:expr<int,<>> = App(x, [Char('a')])
y.expr/show.println
(x == y).println
val strEq = fn(x1: string, y1: string) x1 == y1
val strShow = fn(x1: string) x1
(==)(x,y).show.println
(==)(x,x).show.println
x.show.println
y.show.println

0 comments on commit 3dee692

Please sign in to comment.