Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
curry-packages
abstract-haskell
Commits
9ac0994e
Commit
9ac0994e
authored
Nov 20, 2020
by
Michael Hanus
Browse files
Merge branch 'newtypes' into 'libs_refactor'
Add newtypes and kinds See merge request
!1
parents
c30f61f6
b6b97257
Changes
3
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 (
"C
urry
_"
++)
renameModule = onLastIdentifier (
c
urry
Prefix
++)
unRenameModule :: String -> String
unRenameModule = onLastIdentifier (dropPrefix
"C
urry
_"
)
unRenameModule = onLastIdentifier (dropPrefix
c
urry
Prefix
)
addTrace :: String -> String
addTrace = renameModule . onLastIdentifier (
"T
race
_"
++) . unRenameModule
addTrace = renameModule . onLastIdentifier (
t
race
Prefix
++) . unRenameModule
removeTrace :: String -> String
removeTrace = renameModule . onLastIdentifier (dropPrefix
"T
race
_"
)
removeTrace = renameModule . onLastIdentifier (dropPrefix
t
race
Prefix
)
. 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.
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment