diff --git a/koka.cabal b/koka.cabal index 63ad2bab8..f0e04d58b 100644 --- a/koka.cabal +++ b/koka.cabal @@ -104,6 +104,7 @@ library Syntax.Lexeme Syntax.Lexer Syntax.Parse + Syntax.Pretty Syntax.Promote Syntax.RangeMap Syntax.Syntax diff --git a/src/Common/NamePrim.hs b/src/Common/NamePrim.hs index 7b6a7a9c2..d623a7ec9 100644 --- a/src/Common/NamePrim.hs +++ b/src/Common/NamePrim.hs @@ -44,6 +44,7 @@ module Common.NamePrim , nameIntAdd, nameIntSub + , nameEq, nameShow -- Effects , nameTpHTag, nameHTag , nameTpClause, namePerform @@ -516,6 +517,8 @@ isNameTpTuple name where s = nameLocal name +nameShow = newName "show" +nameEq = newName "==" preludeName s = qualify nameSystemCore (newName s) diff --git a/src/Core/Parse.hs b/src/Core/Parse.hs index 1fbf4cd68..453352f2b 100644 --- a/src/Core/Parse.hs +++ b/src/Core/Parse.hs @@ -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 diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index 3c0091f38..924fba9a5 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -26,8 +26,9 @@ import Lib.Trace -- import Type.Pretty import Data.Char(isAlphaNum) -import Data.List(groupBy,intersperse,nubBy,sortOn) +import Data.List(groupBy,intersperse,nubBy,sortOn,find) import Data.Maybe(catMaybes) +import qualified Data.Set as S import Control.Monad(when) import Lib.PPrint @@ -40,6 +41,7 @@ import Common.Syntax( Platform(..) ) import Common.Name import Common.NamePrim import Common.Syntax +import Common.Id as CId import Common.File( startsWith ) import qualified Common.NameMap as M import Syntax.Syntax @@ -55,6 +57,7 @@ import Kind.Repr( createDataDef ) import Type.Type import Type.Assumption import Type.TypeVar( tvsIsEmpty, ftv, subNew, (|->), tvsMember, tvsList ) +import qualified Type.TypeVar as TV import Type.Pretty import Type.Kind( getKind ) @@ -63,6 +66,8 @@ import Kind.InferMonad import Kind.Unify import Syntax.RangeMap +import Syntax.Pretty (ppDef) +import Common.IdNice (niceShow, niceEmpty) {-------------------------------------------------------------------------- @@ -106,7 +111,8 @@ inferKinds isValue colors platform mbRangeMap imports kgamma0 syns0 data0 errs4 = constructorCheckDuplicates colors conInfos errs = errs1 ++ errs2 ++ errs3 ++ errs4 warns = warns1 ++ warns2 ++ warns3 - dgroups = concatMap (synTypeDefGroup modName) cgroups + dgroups0 <- mapM (synTypeDefGroup modName) cgroups + let dgroups = concat dgroups0 setUnique unique3 Core.liftError (addWarnings warns $ if (null errs) @@ -145,9 +151,16 @@ extractInfos groups {--------------------------------------------------------------- ---------------------------------------------------------------} -synTypeDefGroup :: Name -> Core.TypeDefGroup -> DefGroups Type +synTypeDefGroup :: Name -> Core.TypeDefGroup -> Core.CorePhase b (DefGroups Type) synTypeDefGroup modName (Core.TypeDefGroup ctdefs) - = concatMap (synTypeDef modName) ctdefs + = do + let defs = concatMap (synTypeDef modName) ctdefs + deriveDefs <- synDerives modName ctdefs + return (defs ++ deriveDefs) + +getData :: Core.TypeDef -> [DataInfo] +getData (Core.Synonym synInfo) = [] +getData (Core.Data dataInfo _) = [dataInfo] synTypeDef :: Name -> Core.TypeDef -> DefGroups Type synTypeDef modName (Core.Synonym synInfo) = [] @@ -202,6 +215,162 @@ hasAccessor name tp cinfo (let tvs = ftv tp -- and no existentials? in all (\tv -> not (tvsMember tv tvs)) (conInfoExists cinfo)) +mkBind :: Name -> Range -> ValueBinder (Maybe Type) (Maybe (Expr Type)) +mkBind arg r = ValueBinder arg Nothing Nothing r r + +synDerives :: Name -> [Core.TypeDef] -> Core.CorePhase b (DefGroups Type) +synDerives modName ctdefs = do + let dataInfos = concatMap getData ctdefs + names = S.fromList (concatMap dataInfoDerives dataInfos) + mapM (\n -> synDeriveDefs modName n dataInfos) (S.toList names) + +-- Generate synthetic defs (deriving (show, (==))) etc +synDeriveDefs :: Name -> Name -> [DataInfo] -> Core.CorePhase b (DefGroup Type) +synDeriveDefs modName kind infos | kind == nameShow = + do + defs <- mapM (synShowString modName) (filter (\i -> kind `elem` dataInfoDerives i) infos) + return $ DefRec defs +synDeriveDefs modName kind infos | kind == nameEq = + do + defs <- mapM (synEquality modName) (filter (\i -> kind `elem` dataInfoDerives i) infos) + return $ DefRec defs +synDeriveDefs modName kind infos = return $ DefRec [] -- TODO: Error out? + +nonFunctionFields fields = map snd (filter fst fields) +synShowString :: Name -> DataInfo -> Core.CorePhase b (Def Type) +synShowString modName info = do + evar <- TV.freshTypeVar kindEffect Bound + let drng = dataInfoRange info + dive = effectExtend (TCon (TypeCon nameTpDiv kindEffect)) (TVar evar) + dataName = dataInfoName info + defName = newLocallyQualified "" (nameStem dataName) "show" + visibility = dataInfoVis info + doc = "// Automatically generated. Shows a string representation of the `" ++ nameStem (dataInfoName info) ++ "` type.\n" + def = Def (ValueBinder defName () showExpr drng drng) drng visibility (DefFun [Borrow] (NoFip False)) InlineAlways doc + tyParams = dataInfoParams info + nice = niceTypeExtendVars tyParams niceEmpty + showTV tv = show $ ppTypeVar defaultEnv{nice=nice} tv + dataTp = typeApp (TCon (TypeCon dataName (dataInfoKind info))) (map TVar tyParams) + selfArg = if all isAlphaNum (show dataName) then dataName else newHiddenName "this" + tVarName tv = toImplicitParamName (newLocallyQualified "" ("show" ++ showTV tv) "show") + starTVs = filter isStarTypeVar tyParams + tvArgs = map (\x -> (tVarName x, typeFun [(newName ("tv" ++ showTV x), TVar x)] dive typeString)) starTVs + tvBinds = map (\(x, _) -> mkBind x drng) tvArgs + fullTp = tForall (dataInfoParams info ++ [evar]) [] $ typeFun ((selfArg,dataTp):tvArgs) dive typeString + showExpr = Ann (Lam (mkBind selfArg drng:tvBinds) caseExpr drng) fullTp drng + caseExpr = Case (Var selfArg False drng) (map snd branches) drng + branches = concatMap makeBranch (dataInfoConstrs info) + makeBranch :: ConInfo -> [(Visibility, Branch Type)] + makeBranch con + = let + crng = conInfoRange con + getTV :: Type -> Maybe Name + getTV ty = + let d = find (\x -> case ty of {TVar xx -> x == xx; _ -> False }) starTVs + in fmap tVarName d + tyShowName :: Type -> Expr Type + tyShowName ty = + case getTV ty of + Just x -> Var (fst $ splitImplicitParamName x) False crng + Nothing -> Var nameShow False crng + showTp :: Expr Type -> Type -> Expr Type + showTp exp ty = + -- Use fully qualified defName if the type is the same as the data type + if ty == dataTp then App (Var defName False crng) [(Nothing, exp)] crng + else App (tyShowName ty) [(Nothing, exp)] crng + appendOp = Var (newName "++") False crng + lString s = Lit (LitString s crng) + appendStr expr1 expr2 = App appendOp [(Nothing, expr1), (Nothing, expr2)] crng + start = lString (nameStem (conInfoName con) ++ "(") + fields = map (\x -> (not (isFun (snd x)), x)) (conInfoParams con) + pVar fld rng = if fst fld then PatVar (ValueBinder (fst (snd fld)) Nothing (PatWild rng) rng rng) + else PatWild rng + patterns = [(Nothing,pVar fld crng) | fld <- fields] + showField2(fldN,fldTp)= appendStr (lString (nameStem fldN ++ ": ")) (showTp (Var fldN False crng) fldTp) + varExprs = map showField2 (nonFunctionFields fields) + varExprs2 = intersperse (lString ", ") varExprs + toString = appendStr start (foldr appendStr (lString ")") varExprs2) + conMatch = PatCon (conInfoName con) patterns crng crng + branchExpr = [(conInfoVis con, Branch conMatch [Guard guardTrue toString])] + branchExprNoFields = [(conInfoVis con, Branch conMatch [Guard guardTrue (lString (nameStem (conInfoName con)))])] + in if null fields then branchExprNoFields else branchExpr + return -- $ trace (show $ ppDef defaultEnv def) + def + +singleCon:: DataInfo -> Bool +singleCon info = length (dataInfoConstrs info) == 1 + +synEquality :: Name -> DataInfo -> Core.CorePhase b (Def Type) +synEquality modName info = do + evar <- TV.freshTypeVar kindEffect Bound + let ediv = effectExtend (TCon (TypeCon nameTpDiv kindEffect)) $ TVar evar + drng = dataInfoRange info + dataName = dataInfoName info + tyParams = dataInfoParams info + starTVs = filter isStarTypeVar tyParams + selfArg = newHiddenName "this" + otherArg = newHiddenName "other" + dataTp = typeApp (TCon (TypeCon dataName (dataInfoKind info))) (map TVar tyParams) + nice = niceTypeExtendVars tyParams niceEmpty + showTV tv = show $ ppTypeVar defaultEnv{nice=nice} tv + tVarName tv = toImplicitParamName (newLocallyQualified "" ("eq" ++ showTV tv) "==") + tvArgs = map (\x -> (tVarName x, typeFun + [(newName ("this" ++ showTV x), TVar x), + (newName ("other" ++ showTV x), TVar x)] ediv typeBool)) + starTVs + tvBinds = map (\(x, _) -> mkBind x drng) tvArgs + fullTp = tForall (dataInfoParams info ++ [evar]) [] $ + typeFun ((selfArg,dataTp):(otherArg,dataTp):tvArgs) ediv typeBool + branches = concatMap makeBranch (dataInfoConstrs info) + litBool b rng = if b then Var nameTrue False rng else Var nameFalse False rng + caseArg = [(Nothing, Var selfArg False drng), (Nothing, Var otherArg False drng)] + caseExpr = Case (App (Var (nameTuple 2) False drng) caseArg drng) ((map snd branches) ++ defaultBranch) drng + defExpr = Ann (Lam ((mkBind selfArg drng):(mkBind otherArg drng):tvBinds) caseExpr drng) fullTp drng + visibility = dataInfoVis info + doc = "// Automatically generated. Equality comparison of the `" ++ nameStem (dataInfoName info) ++ "` type (ignores function fields).\n" + defName = newLocallyQualified "" (nameStem dataName) "==" + def = Def (ValueBinder defName () defExpr drng drng) drng visibility (DefFun [Borrow] (NoFip False)) InlineAlways doc + tupleBranch :: Pattern Type -> Pattern Type -> Expr Type -> Range -> Branch Type + tupleBranch p1 p2 res r = Branch (PatCon (nameTuple 2) [(Nothing, p1), (Nothing, p2)] r r) [Guard guardTrue res] + defaultBranch :: [Branch Type] + defaultBranch = if singleCon info then [] else [tupleBranch (PatWild drng) (PatWild drng) (litBool False drng) drng] + makeBranch :: ConInfo -> [(Visibility, Branch Type)] + makeBranch con + = let crng = conInfoRange con + getTV :: Type -> Maybe Name + getTV ty = + let d = find (\x -> case ty of {TVar xx -> x == xx; _ -> False }) starTVs + in fmap tVarName d + tpEqName :: Type -> Expr Type + tpEqName ty = + case getTV ty of + Just x -> Var (fst $ splitImplicitParamName x) True crng + Nothing -> Var nameEq True crng + eqTp :: Expr Type -> Expr Type -> Type -> Expr Type + eqTp expL expR ty = + -- Use fully qualified defName if the type is the same as the data type + if ty == dataTp then App (Var defName True crng) [(Nothing, expL), (Nothing, expR)] crng + else App (tpEqName ty) [(Nothing, expL), (Nothing, expR)] crng + fields = map (\x -> (not (isFun (snd x)), x)) (conInfoParams con) + pVar :: (Bool, (Name, Type)) -> String -> Pattern Type + pVar fld prefix = if fst fld then PatVar (ValueBinder (makeHiddenName prefix (fst (snd fld))) Nothing (PatWild crng) crng crng) + else PatWild crng + patternsL = [(Nothing,pVar fld "this") | fld <- fields] + patternsR = [(Nothing,pVar fld "other") | fld <- fields] + andOp = Var (newName "&&") True crng + andExpr expr1 expr2 = App andOp [(Nothing, expr1), (Nothing, expr2)] crng + nonFunctionFields = map snd (filter fst fields) + eqField(fldN, fldT) = eqTp (Var (makeHiddenName "this" fldN) False crng) (Var (makeHiddenName "other" fldN) False crng) fldT + varExprs = map eqField nonFunctionFields + branchExpr = case varExprs of + [] -> litBool True crng + _ -> foldr1 andExpr varExprs + branch = tupleBranch (PatCon (conInfoName con) patternsL crng crng) (PatCon (conInfoName con) patternsR crng crng) + in [(conInfoVis con, branch branchExpr crng)] + return $ -- trace (show $ ppDef defaultEnv def) + def + + synAccessors :: Name -> DataInfo -> [DefGroup Type] synAccessors modName info = let paramss = map (\conInfo -> zipWith (\(name,tp) (pvis,rng) -> (name,(tp,rng,pvis,conInfo))) @@ -376,7 +545,7 @@ bindTypeDef tdef -- extension where isExtend = case tdef of - (DataType newtp args constructors range vis sort ddef isExtend doc) -> isExtend + (DataType newtp args constructors derives range vis sort ddef isExtend doc) -> isExtend _ -> False bindTypeBinder :: TypeBinder UserKind -> KInfer (TypeBinder InfKind) @@ -659,7 +828,7 @@ infTypeDef (tbinder, Synonym syn args tp range vis doc) tbinder' <- unifyBinder tbinder syn range infgamma kind return (Synonym tbinder' infgamma tp' range vis doc) -infTypeDef (tbinder, td@(DataType newtp args constructors range vis sort ddef isExtend doc)) +infTypeDef (tbinder, td@(DataType newtp args constructors derives range vis sort ddef isExtend doc)) = do infgamma <- mapM bindTypeBinder args constructors' <- extendInfGamma infgamma (mapM infConstructor constructors) -- todo: unify extended datatype kind with original @@ -668,7 +837,7 @@ infTypeDef (tbinder, td@(DataType newtp args constructors range vis sort ddef is if not isExtend then return () else do (qname,kind) <- findInfKind (tbinderName newtp) (tbinderRange newtp) unify (Check "extended type must have the same kind as the open type" (tbinderRange newtp) ) (tbinderRange newtp) (typeBinderKind tbinder') kind - return (DataType tbinder' infgamma constructors' range vis sort ddef isExtend doc) + return (DataType tbinder' infgamma constructors' derives range vis sort ddef isExtend doc) unifyBinder tbinder defbinder range infgamma reskind = do let kind = infKindFunN (map typeBinderKind infgamma) reskind @@ -814,7 +983,7 @@ resolveTypeDef isRec recNames (Synonym syn params tp range vis doc) kindArity (KApp (KApp kcon k1) k2) | kcon == kindArrow = k1 : kindArity k2 kindArity _ = [] -resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort ddef isExtend doc) +resolveTypeDef isRec recNames (DataType newtp params constructors derives range vis sort ddef isExtend doc) = do -- trace ("datatype: " ++ show(tbinderName newtp) ++ " " ++ show isExtend) $ return () newtp' <- if isExtend then do (qname,ikind) <- findInfKind (tbinderName newtp) (tbinderRange newtp) @@ -866,7 +1035,7 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort <- createDataDef emitError emitWarning lookupDataInfo platform qname resultHasKindStar isRec sort extraFields ddef conInfos0 - let dataInfo = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars conInfos1 range ddef1 vis doc + let dataInfo = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars conInfos1 derives range ddef1 vis doc assertion ("Kind.Infer.resolveTypeDef: assuming value struct tag but not inferred as such " ++ show (ddef,ddef1)) ((willNeedStructTag && Core.needsTagField (fst (Core.getDataRepr dataInfo))) || not willNeedStructTag) $ return () diff --git a/src/Static/BindingGroups.hs b/src/Static/BindingGroups.hs index 25f5457b8..c2250ca3a 100644 --- a/src/Static/BindingGroups.hs +++ b/src/Static/BindingGroups.hs @@ -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 diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index 8ea5075e2..b7e9e0dba 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -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) @@ -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" @@ -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 @@ -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 diff --git a/src/Syntax/Pretty.hs b/src/Syntax/Pretty.hs new file mode 100644 index 000000000..cde281689 --- /dev/null +++ b/src/Syntax/Pretty.hs @@ -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" diff --git a/src/Syntax/Syntax.hs b/src/Syntax/Syntax.hs index 50f215040..b1d6fbcff 100644 --- a/src/Syntax/Syntax.hs +++ b/src/Syntax/Syntax.hs @@ -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 diff --git a/src/Type/Pretty.hs b/src/Type/Pretty.hs index 382499e02..e0df97d37 100644 --- a/src/Type/Pretty.hs +++ b/src/Type/Pretty.hs @@ -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 @@ -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) <.> diff --git a/src/Type/Type.hs b/src/Type/Type.hs index 3768ff9da..0f25af5aa 100644 --- a/src/Type/Type.hs +++ b/src/Type/Type.hs @@ -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 @@ -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 @@ -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 diff --git a/test/kind/deriving.kk b/test/kind/deriving.kk new file mode 100644 index 000000000..600977b9f --- /dev/null +++ b/test/kind/deriving.kk @@ -0,0 +1,58 @@ +// Simple struct +struct hello1 + abc: int +deriving(show) + +// Function +type hello + Hello(f: () -> e ()) +deriving(show) + +// Mutually recursive types +type even + Even(o1: odd) + Zero(t: t) +deriving(show,(==)) + +type odd + Odd(o1: even) +deriving(show,(==)) + +// More complex domain +type vvalue + IntV(i: int) + BoolV(b: bool) + CharV(c: char) + StringV(s: string) + +alias primop = (vvalue) -> vvalue + +type expr + Int(i: int) + X(x: () -> x ()) + Bool(b: bool) + Char(c: char) + String(s: string) + Var(s: string) + List(l: list) + Lam(x: string, y: expr) + App(op: expr, args: list>) + 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> = 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 \ No newline at end of file