Skip to content
GitLab
Commit 9ac0994e authored by Michael Hanus's avatar Michael Hanus
Browse files

Merge branch 'newtypes' into 'libs_refactor' 

Add newtypes and kinds

See merge request !1
parents c30f61f6 b6b97257
Hide whitespace changes
Inline Side-by-side
src/AbstractHaskell/Goodies.curry
View file @ 9ac0994e
......@@ -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) =
......
src/AbstractHaskell/Printer.curry
View file @ 9ac0994e
......@@ -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
src/AbstractHaskell/Types.curry
View file @ 9ac0994e
......@@ -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.
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment