From b6b97257c3ababa3bdffe2112d5c63726347bf5b Mon Sep 17 00:00:00 2001 From: fwcd Date: Thu, 19 Nov 2020 17:42:44 +0100 Subject: [PATCH] Add newtypes and kinds Add the improvements from KiCS2 for generating newtypes. --- src/AbstractHaskell/Goodies.curry | 16 +++++++--- src/AbstractHaskell/Printer.curry | 52 +++++++++++++++++++++---------- src/AbstractHaskell/Types.curry | 27 +++++++++++----- 3 files changed, 66 insertions(+), 29 deletions(-) diff --git a/src/AbstractHaskell/Goodies.curry b/src/AbstractHaskell/Goodies.curry index a92b93c..0336796 100644 --- a/src/AbstractHaskell/Goodies.curry +++ b/src/AbstractHaskell/Goodies.curry @@ -77,7 +77,7 @@ tyVarsOf :: TypeExpr -> [TVarIName] tyVarsOf (TVar tv) = [tv] tyVarsOf (FuncType t1 t2) = tyVarsOf t1 `union` tyVarsOf t2 tyVarsOf (TCons _ tys) = foldr union [] (map tyVarsOf tys) -tyVarsOf (ForallType tvs _ ty) = tyVarsOf ty \\ tvs +tyVarsOf (ForallType tvs _ ty) = tyVarsOf ty \\ map fst tvs -- ----------------------------------------------------------------------------- -- Goodies for function declarations @@ -172,10 +172,12 @@ renameSymbolInProg ren (Prog name imports typedecls fundecls opdecls) = renameSymbolInTypeDecl :: (QName -> QName) -> TypeDecl -> TypeDecl renameSymbolInTypeDecl ren tdecl = case tdecl of - Type qf vis tvars cdecls -> Type (ren qf) vis tvars + Type qf vis tvars cdecls -> Type (ren qf) vis tvars (map (renameSymbolInConsDecl ren) cdecls) - TypeSyn qf vis tvars texp -> TypeSyn (ren qf) vis tvars + TypeSyn qf vis tvars texp -> TypeSyn (ren qf) vis tvars (renameSymbolInTypeExpr ren texp) + TypeNew qf vis tvars cdecl -> TypeNew (ren qf) vis tvars + (renameSymbolInNewConsDecl ren cdecl) Instance qf texp ctxt rules -> Instance (ren qf) (renameSymbolInTypeExpr ren texp) (map (renameSymbolInContext ren) ctxt) @@ -188,6 +190,10 @@ renameSymbolInConsDecl :: (QName -> QName) -> ConsDecl -> ConsDecl renameSymbolInConsDecl ren (Cons qf ar vis texps) = Cons (ren qf) ar vis (map (renameSymbolInTypeExpr ren) texps) +renameSymbolInNewConsDecl :: (QName -> QName) -> NewConsDecl -> NewConsDecl +renameSymbolInNewConsDecl ren (NewCons qf vis texp) = + NewCons (ren qf) vis $ renameSymbolInTypeExpr ren texp + renameSymbolInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr renameSymbolInTypeExpr ren texp = case texp of TCons qf texps -> TCons (ren qf) (map (renameSymbolInTypeExpr ren) texps) @@ -255,8 +261,8 @@ renameSymbolInTypeSig ren (CType tc te) = CType (map (renameSymbolInContext ren) tc) (renameSymbolInTypeExpr ren te) renameSymbolInContext :: (QName -> QName) -> Context -> Context -renameSymbolInContext ren (Context qn texps) = - Context (ren qn) (map (renameSymbolInTypeExpr ren) texps) +renameSymbolInContext ren (Context tvs cxs qn texps) = + Context tvs cxs (ren qn) (map (renameSymbolInTypeExpr ren) texps) renameSymbolInFunc :: (QName -> QName) -> FuncDecl -> FuncDecl renameSymbolInFunc ren (Func cmt qf ar vis ctype rules) = diff --git a/src/AbstractHaskell/Printer.curry b/src/AbstractHaskell/Printer.curry index bc41403..e6c65fb 100644 --- a/src/AbstractHaskell/Printer.curry +++ b/src/AbstractHaskell/Printer.curry @@ -12,6 +12,7 @@ module AbstractHaskell.Printer , ppDecls ) where +import Data.List (isPrefixOf) import Text.Pretty import AbstractHaskell.Types @@ -94,6 +95,9 @@ ppExports opts ts fs = tupledSpaced $ filter (not . isEmpty) ppTypeExport (TypeSyn qn vis _ _) | vis == Public = ppQName opts qn | otherwise = Text.Pretty.empty + ppTypeExport (TypeNew qn vis _ _) + | vis == Public = ppQName opts qn <+> text "(..)" + | otherwise = Text.Pretty.empty ppTypeExport (Instance _ _ _ _) = Text.Pretty.empty ppFuncExport :: FuncDecl -> Doc @@ -111,10 +115,9 @@ ppImports opts = vsep . map (ppImport opts) ppImport :: Options -> String -> Doc ppImport opts imp -- Import module qualified if required: - | qualImpModule opts imp = indent $ fillSep $ map text - ["import", "qualified", imp] - | traceFailure opts = indent $ fillSep $ map text $ - ["import", "qualified", addTrace imp, "as", imp] + | qualImpModule opts imp = indent $ fillSep $ map text $ + ["import", "qualified"] ++ if traceFailure opts then [addTrace imp, "as", imp] + else [imp] | otherwise = indent $ text "import" <+> text imp ppOpDecls :: [OpDecl] -> Doc @@ -141,6 +144,9 @@ ppTypeDecl :: Options -> TypeDecl -> Doc ppTypeDecl opts (TypeSyn qname _ vs ty) = indent $ text "type" <+> ppName qname <+> fillSep (map ppTypeVar vs) equals <+> ppTypeExp opts ty +ppTypeDecl opts (TypeNew qname _ vs c) = indent $ + text "newtype" <+> ppName qname <+> fillSep (map ppTypeVar vs) + equals <+> ppNewConsDecl opts c ppTypeDecl opts (Type qname _ vs cs) | null cs = Text.Pretty.empty | otherwise = indent $ @@ -162,13 +168,21 @@ ppConsDecl :: Options -> ConsDecl -> Doc ppConsDecl o (Cons (_, qn) _ _ tys) = indent $ fillSep $ ppPrefixOp qn : map (ppTypeExpr o 2) tys +--- pretty print a single newtype constructor declaration +ppNewConsDecl :: Options -> NewConsDecl -> Doc +ppNewConsDecl o (NewCons (_, qn) _ ty) = indent $ fillSep + [ppPrefixOp qn, ppTypeExpr o 2 ty] + ppContexts :: Options -> [Context] -> Doc ppContexts opts cs | null cs = Text.Pretty.empty | otherwise = tupled (map (ppContext opts) cs) <+> doubleArrow ppContext :: Options -> Context -> Doc -ppContext opts (Context qn ts) = ppTypeExp opts (TCons qn ts) +ppContext opts (Context tvs cxs qn ts) = quantifiedVars <+> ppContexts opts cxs + <+> ppTypeExp opts (TCons qn ts) + where quantifiedVars | null tvs = Text.Pretty.empty + | otherwise = text "forall" <+> fillSep (map ppTypeVar tvs) <+> dot --- pretty a top-level type expression ppTypeExp :: Options -> TypeExpr -> Doc @@ -186,7 +200,8 @@ ppTypeExpr o p (TCons qn tys) $ fillSep $ ppQName o qn : map (ppTypeExpr o 2) tys ppTypeExpr o p (ForallType vs cx t) = parensIf (p > 0) $ text "forall" - <+> fillSep (map ppTypeVar vs) <+> dot <+> ppContexts o cx <+> ppTypeExp o t + <+> fillSep (map (ppTypeVar . fst) vs) <+> dot + <+> ppContexts o cx <+> ppTypeExp o t ppTypeVar :: TVarIName -> Doc ppTypeVar (_, name) = text name @@ -308,7 +323,7 @@ ppLitPattern opts l | kics2Mode opts = case l of Charc _ -> wrapUnboxed (curryPrelude, "C_Char") Floatc _ -> wrapUnboxed (curryPrelude, "C_Float") - Intc _ -> parens (ppQName opts (curryPrelude, "C_Char") <+> + Intc _ -> parens (ppQName opts (curryPrelude, "C_Int") <+> parens (ppLiteral l)) Stringc _ -> ppLiteral l | otherwise = ppLiteral l @@ -387,20 +402,26 @@ list = fillEncloseSep lbracket rbracket (comma <> space) tupled :: [Doc] -> Doc tupled = fillEncloseSep lparen rparen (comma <> space) +curryPrefix :: String +curryPrefix = "Curry_" + +tracePrefix :: String +tracePrefix = "Trace_" + curryPrelude :: String -curryPrelude = "Curry_Prelude" +curryPrelude = renameModule "Prelude" renameModule :: String -> String -renameModule = onLastIdentifier ("Curry_" ++) +renameModule = onLastIdentifier (curryPrefix ++) unRenameModule :: String -> String -unRenameModule = onLastIdentifier (dropPrefix "Curry_") +unRenameModule = onLastIdentifier (dropPrefix curryPrefix) addTrace :: String -> String -addTrace = renameModule . onLastIdentifier ("Trace_" ++) . unRenameModule +addTrace = renameModule . onLastIdentifier (tracePrefix ++) . unRenameModule removeTrace :: String -> String -removeTrace = renameModule . onLastIdentifier (dropPrefix "Trace_") +removeTrace = renameModule . onLastIdentifier (dropPrefix tracePrefix) . unRenameModule onLastIdentifier :: (String -> String) -> String -> String @@ -425,8 +446,7 @@ joinModuleIdentifiers :: [String] -> String joinModuleIdentifiers = foldr1 combine where combine xs ys = xs ++ '.' : ys -dropPrefix :: String -> String -> String +dropPrefix :: Eq a => [a] -> [a] -> [a] dropPrefix pfx s - | take n s == pfx = drop n s - | otherwise = s - where n = length pfx + | pfx `isPrefixOf` s = drop (length pfx) s + | otherwise = s diff --git a/src/AbstractHaskell/Types.curry b/src/AbstractHaskell/Types.curry index 7c8f789..364315e 100644 --- a/src/AbstractHaskell/Types.curry +++ b/src/AbstractHaskell/Types.curry @@ -14,9 +14,9 @@ module AbstractHaskell.Types where --- Data type for representing a Haskell module in the intermediate form. --- A value of this data type has the form ---- +--- --- (CProg modname imports typedecls functions opdecls) ---- +--- --- where modname: name of this module, --- imports: list of modules names that are imported, --- typedecls, opdecls, functions: see below @@ -61,11 +61,12 @@ type TVarIName = (Int, String) data TypeDecl = Type QName Visibility [TVarIName] [ConsDecl] | TypeSyn QName Visibility [TVarIName] TypeExpr + | TypeNew QName Visibility [TVarIName] NewConsDecl | Instance QName TypeExpr [Context] [(QName, Rule)] deriving Show --- A single type context is class name applied to type variables. -data Context = Context QName [TypeExpr] +data Context = Context [TVarIName] [Context] QName [TypeExpr] deriving (Eq,Show) --- A constructor declaration consists of the name and arity of the @@ -73,6 +74,11 @@ data Context = Context QName [TypeExpr] data ConsDecl = Cons QName Int Visibility [TypeExpr] deriving Show +--- A constructor declaration for a newtype consists +--- of the name of the constructor +--- and the argument type of the constructor. +data NewConsDecl = NewCons QName Visibility TypeExpr + deriving Show --- Data type for type expressions. --- A type expression is either a type variable, a function type, @@ -82,11 +88,16 @@ data ConsDecl = Cons QName Int Visibility [TypeExpr] --- "Int", "Float", "Bool", "Char", "IO", --- "()" (unit type), "(,...,)" (tuple types), "[]" (list type) data TypeExpr - = TVar TVarIName -- type variable - | FuncType TypeExpr TypeExpr -- function type t1->t2 - | TCons QName [TypeExpr] -- type constructor application - -- (TCons (module,name) arguments) - | ForallType [TVarIName] [Context] TypeExpr -- explicitly quantified type expression + = TVar TVarIName -- type variable + | FuncType TypeExpr TypeExpr -- function type t1->t2 + | TCons QName [TypeExpr] -- type constructor application + -- (TCons (module,name) arguments) + | ForallType [(TVarIName, Kind)] [Context] TypeExpr -- explicitly quantified type expression + deriving (Eq,Show) + +data Kind + = KindStar + | KindArrow Kind Kind deriving (Eq,Show) --- Data type to represent the type signature of a defined function. -- GitLab