Commit 5e581220 authored by Michael Hanus's avatar Michael Hanus
Browse files

Merge remote-tracking branch 'origin/typeclasses'

parents 40a2ced2 4a454532
......@@ -5,36 +5,27 @@ Curry_Main_Goal.curry
cpm/src/CPM/ConfigPackage.curry
*.agdai
*_cache
browser/.cpm/packages/addtypes-0.0.1
browser/.cpm/packages/cass-0.0.1
browser/.cpm/packages/cass-analysis-0.0.4
browser/.cpm/packages/importusage-0.0.1
browser/.cpm/packages/showflatcurry-0.0.1
currycheck/.cpm/packages/rewriting-0.0.1
currypp/.cpm/packages/cass-0.0.1
currypp/.cpm/packages/cass-analysis-0.0.4
currypp/.cpm/packages/cdbi-1.0.0
currypp/.cpm/packages/currycheck-1.0.1
currypp/.cpm/packages/rewriting-0.0.1
currypp/.cpm/packages/abstract-curry-1.0.0
currypp/.cpm/packages/flatcurry-1.0.0
currypp/.cpm/packages/html-1.1.0
currypp/.cpm/packages/xml-0.0.1
optimize/.cpm/packages/cass-0.0.1
optimize/.cpm/packages/cass-analysis-0.0.4
optimize/.cpm/packages/flatcurry-1.0.0
optimize/.cpm/packages/xml-0.0.1
currypp/.cpm/packages/cass-2.0.0
currypp/.cpm/packages/cass-analysis-2.0.0
currypp/.cpm/packages/cdbi-2.0.0
currypp/.cpm/packages/currycheck-2.0.0
currypp/.cpm/packages/rewriting-2.0.0
currypp/.cpm/packages/abstract-curry-2.0.0
currypp/.cpm/packages/flatcurry-2.0.0
currypp/.cpm/packages/html-2.0.0
currypp/.cpm/packages/xml-2.0.0
currypp/.cpm/packages/fl-parser-1.0.0
currypp/.cpm/packages/regexp-1.1.0
optimize/.cpm/packages/cass-2.0.0
optimize/.cpm/packages/cass-analysis-2.0.0
optimize/.cpm/packages/flatcurry-2.0.0
optimize/.cpm/packages/csv-1.0.0
optimize/.cpm/packages/xml-2.0.0
# executables
browser/BrowserGUI
CASS/cass
CASS/cass_worker
cpm/src/CPM.Main
cpns/CPNSD
curry2js/Curry2JS
currypp/Main
currycheck/CurryCheck
currydoc/CurryDoc
optimize/BindingOpt
runcurry/RunCurry
www/Registry
......
......@@ -12,7 +12,6 @@ else
export REPL_OPTS = --noreadline :set -time
endif
# Source modules of CPM:
DEPS = src/CPM/*.curry src/CPM/*/*.curry
......@@ -47,7 +46,7 @@ src/CPM/ConfigPackage.curry: Makefile
@echo "packagePath :: String" >> $@
@echo "packagePath = \"$(CURDIR)\"" >> $@
@echo "packageVersion :: String" >> $@
@echo "packageVersion = \"0.2.1\"" >> $@
@echo "packageVersion = \"2.0.0\"" >> $@
@echo "Curry configuration module '$@' written."
runtest:
......
......@@ -1225,7 +1225,7 @@ are used:
"author": "YOUR NAME <YOUR EMAIL ADDRESS>",
"maintainer": "ANOTHER NAME <ANOTHER EMAIL ADDRESS>",
"synopsis": "A ONE-LINE SUMMARY ABOUT THE PACKAGE",
"synopsis": "A MORE DEATILED SUMMARY ABOUT THE PACKAGE",
"description": "A MORE DETAILED SUMMARY ABOUT THE PACKAGE",
"category": [ "Category1", "Category2" ],
"license": "BSD-3-Clause",
"licenseFile": "LICENSE",
......
......@@ -10,6 +10,7 @@ module CPM.AbstractCurry
, readAbstractCurryFromDeps
, transformAbstractCurryInDeps
, applyModuleRenames
, tcArgsOfType
) where
import Distribution (FrontendTarget (..), FrontendParams (..), defaultParams
......@@ -22,7 +23,7 @@ import AbstractCurry.Files (readAbstractCurryFile, writeAbstractCurryFile)
import AbstractCurry.Pretty (showCProg)
import AbstractCurry.Select (imports)
import AbstractCurry.Transform
import AbstractCurry.Types (CurryProg)
import AbstractCurry.Types
import System
import CPM.ErrorLogger
......@@ -114,7 +115,8 @@ transformAbstractCurryInDeps pkgDir deps transform modname destFile = do
--- @param prog - the program to modify
applyModuleRenames :: [(String, String)] -> CurryProg -> CurryProg
applyModuleRenames names prog =
updCProg maybeRename (map maybeRename) id id id (updQNamesInCProg rnm prog)
updCProg maybeRename (map maybeRename) id id id id id id
(updQNamesInCProg rnm prog)
where
maybeRename n = case lookup n names of
Just n' -> n'
......@@ -123,3 +125,20 @@ applyModuleRenames names prog =
Just mod' -> (mod', n)
Nothing -> mn
--- Checks whether a type expression is a type constructor application.
--- If this is the case, return the type constructor and the type arguments.
tcArgsOfType :: CTypeExpr -> Maybe (QName,[CTypeExpr])
tcArgsOfType texp =
maybe Nothing
(\tc -> Just (tc, targsOfApply texp))
(tconOfApply texp)
where
tconOfApply te = case te of CTApply (CTCons qn) _ -> Just qn
CTApply tc _ -> tconOfApply tc
_ -> Nothing
targsOfApply te = case te of
CTApply (CTCons _) ta -> [ta]
CTApply tc ta -> targsOfApply tc ++ [ta]
_ -> [] -- should not occur
......@@ -189,6 +189,7 @@ showDifferences diffs verA verB = pPrint $
--- A jump between two versions.
data VersionJump = Major | Minor | Patch | None
deriving Eq
--- Calculate the jump between two versions.
versionJump :: Version -> Version -> VersionJump
......@@ -209,8 +210,10 @@ showFuncDifference (Change a b) = "Change " ++ (showFuncDecl a) ++ " to " ++ (sh
--- Renders a function declaration to a string.
showFuncDecl :: CFuncDecl -> String
showFuncDecl (CFunc (_, n) _ _ t _) = n ++ " :: " ++ (pPrint $ ppCTypeExpr defaultOptions t)
showFuncDecl (CmtFunc _ (_, n) _ _ t _) = n ++ " :: " ++ (pPrint $ ppCTypeExpr defaultOptions t)
showFuncDecl (CFunc (_, n) _ _ t _) =
n ++ " :: " ++ (pPrint $ ppCQualTypeExpr defaultOptions t)
showFuncDecl (CmtFunc _ (_, n) _ _ t _) =
n ++ " :: " ++ (pPrint $ ppCQualTypeExpr defaultOptions t)
--- Renders a type difference to a string.
showTypeDifference :: Difference CTypeDecl -> String
......@@ -220,15 +223,18 @@ showTypeDifference (Change a b) = "Changed " ++ (showTypeDecl a) ++ " to " ++ (s
--- Renders a type declaration to a string.
showTypeDecl :: CTypeDecl -> String
showTypeDecl (CType (_, n) _ _ cs) = "data " ++ n ++ " (" ++ (show $ length cs) ++ " constructors)"
showTypeDecl (CTypeSyn (_, n) _ _ t) = "type " ++ n ++ " = " ++ (pPrint $ ppCTypeExpr defaultOptions t)
showTypeDecl (CNewType (_, n) _ _ _) = "newtype " ++ n
showTypeDecl (CType (_, n) _ _ cs _) =
"data " ++ n ++ " (" ++ (show $ length cs) ++ " constructors)"
showTypeDecl (CTypeSyn (_, n) _ _ t) =
"type " ++ n ++ " = " ++ (pPrint $ ppCTypeExpr defaultOptions t)
showTypeDecl (CNewType (_, n) _ _ _ _) = "newtype " ++ n
--- Renders an operator difference to a string.
showOpDifference :: Difference COpDecl -> String
showOpDifference (Addition f) = "Added " ++ (showOpDecl f)
showOpDifference (Removal f) = "Removed " ++ (showOpDecl f)
showOpDifference (Change a b) = "Changed " ++ (showOpDecl a) ++ " to " ++ (showOpDecl b)
showOpDifference (Addition f) = "Added " ++ showOpDecl f
showOpDifference (Removal f) = "Removed " ++ showOpDecl f
showOpDifference (Change a b) = "Changed " ++ showOpDecl a ++ " to " ++
showOpDecl b
--- Renders an operator declaration to a string.
showOpDecl :: COpDecl -> String
......@@ -262,12 +268,12 @@ funcIsPublic _ (CmtFunc _ _ _ Private _ _) = False
--- Is a type public?
typeIsPublic :: CurryProg -> CTypeDecl -> Bool
typeIsPublic _ (CType _ Public _ _) = True
typeIsPublic _ (CType _ Private _ _) = False
typeIsPublic _ (CType _ Public _ _ _) = True
typeIsPublic _ (CType _ Private _ _ _) = False
typeIsPublic _ (CTypeSyn _ Public _ _) = True
typeIsPublic _ (CTypeSyn _ Private _ _) = False
typeIsPublic _ (CNewType _ Public _ _) = True
typeIsPublic _ (CNewType _ Private _ _) = False
typeIsPublic _ (CNewType _ Public _ _ _) = True
typeIsPublic _ (CNewType _ Private _ _ _) = False
--- Creates a function that can compare elements in two versions of a module.
---
......@@ -299,17 +305,20 @@ funcEq (CmtFunc _ _ a1 v1 t1 _) (CmtFunc _ _ a2 v2 t2 _) = a1 == a2 && v1 == v2
funcEq (CFunc _ a1 v1 t1 _) (CmtFunc _ _ a2 v2 t2 _) = a1 == a2 && v1 == v2 && t1 == t2
funcEq (CmtFunc _ _ a1 v1 t1 _) (CFunc _ a2 v2 t2 _) = a1 == a2 && v1 == v2 && t1 == t2
--- Are two type declarations equal?
--- Are two type declarations equal? (We ignore `deriving` clauses)
typeEq :: CTypeDecl -> CTypeDecl -> Bool
typeEq (CType _ v1 tvs1 cs1) (CType _ v2 tvs2 cs2) = v1 == v2 && tvs1 == tvs2 && cs1 == cs2
typeEq (CTypeSyn _ v1 tvs1 e1) (CTypeSyn _ v2 tvs2 e2) = v1 == v2 && tvs1 == tvs2 && e1 == e2
typeEq (CNewType _ v1 tvs1 c1) (CNewType _ v2 tvs2 c2) = v1 == v2 && tvs1 == tvs2 && c1 == c2
typeEq (CType _ _ _ _) (CTypeSyn _ _ _ _) = False
typeEq (CType _ _ _ _) (CNewType _ _ _ _) = False
typeEq (CTypeSyn _ _ _ _) (CType _ _ _ _) = False
typeEq (CTypeSyn _ _ _ _) (CNewType _ _ _ _) = False
typeEq (CNewType _ _ _ _) (CType _ _ _ _) = False
typeEq (CNewType _ _ _ _) (CTypeSyn _ _ _ _) = False
typeEq (CType _ v1 tvs1 cs1 _) (CType _ v2 tvs2 cs2 _) =
v1 == v2 && tvs1 == tvs2 && cs1 == cs2
typeEq (CTypeSyn _ v1 tvs1 e1) (CTypeSyn _ v2 tvs2 e2) =
v1 == v2 && tvs1 == tvs2 && e1 == e2
typeEq (CNewType _ v1 tvs1 c1 _) (CNewType _ v2 tvs2 c2 _) =
v1 == v2 && tvs1 == tvs2 && c1 == c2
typeEq (CType _ _ _ _ _) (CTypeSyn _ _ _ _) = False
typeEq (CType _ _ _ _ _) (CNewType _ _ _ _ _) = False
typeEq (CTypeSyn _ _ _ _) (CType _ _ _ _ _) = False
typeEq (CTypeSyn _ _ _ _) (CNewType _ _ _ _ _) = False
typeEq (CNewType _ _ _ _ _) (CType _ _ _ _ _) = False
typeEq (CNewType _ _ _ _ _) (CTypeSyn _ _ _ _) = False
--- Are two operator declarations equal?
opEq :: COpDecl -> COpDecl -> Bool
......@@ -317,7 +326,7 @@ opEq (COp _ f1 a1) (COp _ f2 a2) = f1 == f2 && a1 == a2
--- Select all operator declarations from a CurryProg.
ops :: CurryProg -> [COpDecl]
ops (CurryProg _ _ _ _ os) = os
ops (CurryProg _ _ _ _ _ _ _ os) = os
--- Get the name of an operator declaration.
opName :: COpDecl -> QName
......
This diff is collapsed.
......@@ -23,6 +23,7 @@ data SourceLine = PragmaCmt String
| DataDef String
| FuncDef String
| OtherLine
deriving Eq
classifyLine :: String -> SourceLine
classifyLine line
......
......@@ -42,6 +42,7 @@ data LogLevel = Info
| Debug
| Error
| Critical
deriving Eq
--- The global value for the log level.
logLevel :: Global LogLevel
......
......@@ -5,7 +5,6 @@
module CPM.Main where
import Char ( toLower )
import CSV ( showCSV )
import Directory ( doesFileExist, getAbsolutePath, doesDirectoryExist
, copyFile, createDirectory, createDirectoryIfMissing
, getCurrentDirectory, getDirectoryContents
......@@ -20,8 +19,10 @@ import Sort ( sortBy )
import System ( getArgs, getEnviron, setEnviron, unsetEnviron, exitWith
, system )
import Boxes (table, render)
import Boxes ( table, render )
import OptParse
import Text.CSV ( showCSV )
import CPM.ErrorLogger
import CPM.FileUtil ( fileInPath, joinSearchPath, safeReadFile, whenFileExists
, ifFileExists, inDirectory, removeDirectoryComplete
......
......@@ -72,6 +72,7 @@ type Disjunction = [Conjunction]
--- version constraint. Each inner list of version constraints is a conjunction,
--- the outer list is a disjunction.
data Dependency = Dependency String Disjunction
deriving (Eq,Show)
--- A version constraint.
--- @cons VExact - versions must match exactly
......@@ -87,11 +88,13 @@ data VersionConstraint = VExact Version
| VGte Version
| VLte Version
| VCompatible Version
deriving (Eq,Show)
--- Compiler compatibility constraint, takes the name of the compiler (kics2 or
--- pakcs), as well as a disjunctive normal form combination of version
--- constraints (see Dependency).
data CompilerCompatibility = CompilerCompatibility String Disjunction
deriving (Eq,Show)
--- A package id consisting of the package name and version.
data PackageId = PackageId String Version
......@@ -102,6 +105,7 @@ data PackageId = PackageId String Version
--- of options for various compilers (i.e., pairs of compiler name and
--- options for this compiler).
data PackageExecutable = PackageExecutable String String [(String,String)]
deriving (Eq,Show)
--- The specification of a single test suite for a package.
--- It consists of a directory, a list of modules, options (for CurryCheck),
......@@ -112,6 +116,7 @@ data PackageExecutable = PackageExecutable String String [(String,String)]
--- by running CurryCheck on the given list of modules where the option
--- string is passed to CurryCheck.
data PackageTest = PackageTest String [String] String String
deriving (Eq,Show)
--- The specification to generate the documentation of the package.
--- It consists of the name of the directory containing the documentation,
......@@ -120,6 +125,7 @@ data PackageTest = PackageTest String [String] String String
--- and the main file has the suffix "tex", e.g., "manual.tex",
--- the default command is "pdflatex manual.tex".
data PackageDocumentation = PackageDocumentation String String String
deriving (Eq,Show)
--- A source where the contents of a package can be acquired.
--- @cons Http - URL to a ZIP file
......@@ -130,6 +136,7 @@ data PackageDocumentation = PackageDocumentation String String String
data PackageSource = Http String
| Git String (Maybe GitRevision)
| FileSource String
deriving (Eq,Show)
--- A Git revision.
--- @cons Tag - A tag which might contain the string `$version$` which will
......@@ -139,6 +146,7 @@ data PackageSource = Http String
data GitRevision = Tag String
| Ref String
| VersionAsTag
deriving (Eq,Show)
--- The data type for package specifications.
data Package = Package {
......@@ -165,6 +173,7 @@ data Package = Package {
, testSuite :: Maybe [PackageTest]
, documentation :: Maybe PackageDocumentation
}
deriving (Eq,Show)
--- An empty package specification.
emptyPackage :: Package
......
......@@ -134,6 +134,7 @@ data ResolutionResult = ResolutionSuccess Package [Package]
--- dependency led to the current package version being chosen.
data Activation = InitialA Package
| ChildA Package Dependency Activation
deriving Eq
--- Each tree node is labeled with the current activation and all former
--- activations.
......@@ -150,6 +151,7 @@ type State = (Activation, [Activation])
data Conflict = SecondaryConflict Activation Activation
| PrimaryConflict Activation
| CompilerConflict Activation
deriving Eq
--- A state and a potential conflict.
type ConflictState = (State, Maybe Conflict)
......
{
"name": "abstract-curry",
"version": "1.0.0",
"version": "2.0.0",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "Libraries to deal with AbstractCurry programs",
"category": [ "Metaprogramming" ],
......@@ -9,8 +9,8 @@
"dependencies": {
},
"compilerCompatibility": {
"pakcs": ">= 1.14.0, < 2.0.0",
"kics2": ">= 0.5.0, < 2.0.0"
"pakcs": ">= 2.0.0",
"kics2": ">= 2.0.0"
},
"exportedModules": [ "AbstractCurry.Build", "AbstractCurry.Files",
"AbstractCurry.Pretty", "AbstractCurry.Select",
......
......@@ -2,7 +2,7 @@
--- This library provides some useful operations to write programs
--- that generate AbstractCurry programs in a more compact and readable way.
---
--- @version February 2016
--- @version October 2016
--- @category meta
------------------------------------------------------------------------
......@@ -12,36 +12,60 @@ import AbstractCurry.Types
infixr 9 ~>
------------------------------------------------------------------------
-- Goodies to construct type declarations
--- Constructs a simple `CurryProg` without type classes and instances.
simpleCurryProg :: String -> [String] -> [CTypeDecl] -> [CFuncDecl] -> [COpDecl]
-> CurryProg
simpleCurryProg name imps types funcs ops =
CurryProg name imps Nothing [] [] types funcs ops
------------------------------------------------------------------------
-- Goodies to construct type declarations
--- Constructs a simple constructor declaration without quantified
--- type variables and type class constraints.
simpleCCons :: QName -> CVisibility -> [CTypeExpr] -> CConsDecl
simpleCCons = CCons [] (CContext [])
------------------------------------------------------------------------
-- Goodies to construct type expressions
--- A type application of a qualified type constructor name to a list of
--- argument types.
applyTC :: QName -> [CTypeExpr] -> CTypeExpr
applyTC f es = foldl CTApply (CTCons f) es
--- A function type.
(~>) :: CTypeExpr -> CTypeExpr -> CTypeExpr
t1 ~> t2 = CFuncType t1 t2
--- A base type.
baseType :: QName -> CTypeExpr
baseType t = CTCons t []
baseType t = CTCons t
--- Constructs a list type from an element type.
listType :: CTypeExpr -> CTypeExpr
listType a = CTCons (pre "[]") [a]
listType a = CTApply (CTCons (pre "[]")) a
--- Constructs a tuple type from list of component types.
tupleType :: [CTypeExpr] -> CTypeExpr
tupleType ts | l==0 = baseType (pre "()")
| l==1 = head ts
| otherwise = CTCons (pre ('(' : take (l-1) (repeat ',') ++ ")"))
ts
tupleType ts
| l==0 = baseType (pre "()")
| l==1 = head ts
| otherwise = foldl CTApply
(CTCons (pre ('(' : take (l-1) (repeat ',') ++ ")")))
ts
where l = length ts
--- Constructs an IO type from a type.
ioType :: CTypeExpr -> CTypeExpr
ioType a = CTCons (pre "IO") [a]
ioType a = CTApply (CTCons (pre "IO")) a
--- Constructs a Maybe type from element type.
maybeType :: CTypeExpr -> CTypeExpr
maybeType a = CTCons (pre "Maybe") [a]
maybeType a = CTApply (CTCons (pre "Maybe")) a
--- The type expression of the String type.
stringType :: CTypeExpr
......@@ -71,21 +95,35 @@ unitType = baseType (pre "()")
dateType :: CTypeExpr
dateType = baseType ("Time", "CalendarTime")
--- A qualified type with empty class constraints.
emptyClassType :: CTypeExpr -> CQualTypeExpr
emptyClassType te = CQualType (CContext []) te
------------------------------------------------------------------------
-- Goodies to construct function declarations
--- Constructs a function declaration from a given qualified function name,
--- arity, visibility, type expression and list of defining rules.
cfunc :: QName -> Int -> CVisibility -> CTypeExpr -> [CRule] -> CFuncDecl
cfunc :: QName -> Int -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl
cfunc = CFunc
--- Constructs a function declaration from a given comment,
--- qualified function name,
--- arity, visibility, type expression and list of defining rules.
cmtfunc :: String -> QName -> Int -> CVisibility -> CTypeExpr -> [CRule]
cmtfunc :: String -> QName -> Int -> CVisibility -> CQualTypeExpr -> [CRule]
-> CFuncDecl
cmtfunc = CmtFunc
-- Constructs a `CFunc` with simple (unqualified) type expression.
stFunc :: QName -> Int -> CVisibility -> CTypeExpr -> [CRule] -> CFuncDecl
stFunc name arity vis texp rs = cfunc name arity vis (emptyClassType texp) rs
-- Constructs a `CmtFunc` with simple (unqualified) type expression.
stCmtFunc :: String -> QName -> Int -> CVisibility -> CTypeExpr -> [CRule]
-> CFuncDecl
stCmtFunc cm name arity vis texp rs =
cmtfunc cm name arity vis (emptyClassType texp) rs
--- Constructs a simple rule with a pattern list and an
--- unconditional right-hand side.
simpleRule :: [CPattern] -> CExpr -> CRule
......
......@@ -7,7 +7,7 @@
--- extension `.acy` in the subdirectory `.curry`
---
--- @author Michael Hanus, Bjoern Peemoeller
--- @version October 2015
--- @version October 2016
--- @category meta
-- ---------------------------------------------------------------------------
......@@ -56,7 +56,7 @@ tryReadCurryWithImports modname = collect [] [modname]
eProg <- tryReadCurryFile m
case eProg of
Left err -> return (Left [err])
Right prog@(CurryProg _ is _ _ _) -> do
Right prog@(CurryProg _ is _ _ _ _ _ _) -> do
results <- collect (m:imported) (ms ++ is)
return (either Left (Right . (prog :)) results)
......@@ -97,10 +97,11 @@ tryParse fn = do
if line1 /= "{- "++version++" -}"
then cancel $ "Could not parse AbstractCurry file '" ++ fn
++ "': incompatible versions"
else case readsUnqualifiedTerm ["AbstractCurry.Types","Prelude"] lines of
[(p,tl)] | all isSpace tl -> return (Right p)
_ -> cancel $ "Could not parse AbstractCurry file '" ++ fn
++ "': no parse"
else
case readsUnqualifiedTerm ["AbstractCurry.Types","Prelude"] lines of
[(p,tl)] | all isSpace tl -> return (Right p)
_ -> cancel $ "Could not parse AbstractCurry file '" ++ fn
++ "': no parse"
where cancel str = return (Left str)
--- I/O action which parses a Curry program and returns the corresponding
......@@ -218,12 +219,13 @@ tryReadACYFile fn = do
let (line1,lines) = break (=='\n') src
if line1 /= "{- "++version++" -}"
then error $ "AbstractCurry: incompatible file found: "++fn
else case readsUnqualifiedTerm ["AbstractCurry.Types","Prelude"] lines of
[] -> cancel
[(p,tl)] -> if all isSpace tl
then return $ Just p
else cancel
_ -> cancel
else
case readsUnqualifiedTerm ["AbstractCurry.Types","Prelude"] lines of
[] -> cancel
[(p,tl)] -> if all isSpace tl
then return $ Just p
else cancel
_ -> cancel
cancel = return Nothing
--- Writes an AbstractCurry program into a file in ".acy" format.
......
......@@ -4,7 +4,7 @@
--- This library provides a pretty-printer for AbstractCurry modules.
---
--- @author Yannik Potdevin (with changes by Michael Hanus)
--- @version March 2016
--- @version October 2016
--- @category meta
--- --------------------------------------------------------------------------
......@@ -22,7 +22,7 @@ module AbstractCurry.Pretty
, ppMName, ppExports, ppImports
, ppCOpDecl, ppCTypeDecl, ppCFuncDecl, ppCFuncDeclWithoutSig, ppCRhs
, ppCFuncSignature, ppCTypeExpr, ppCRules, ppCRule
, ppCFuncSignature, ppCQualTypeExpr, ppCTypeExpr, ppCRules, ppCRule
, ppCPattern, ppCLiteral, ppCExpr
, ppCStatement, ppQFunc, ppFunc, ppQType, ppType)
where
......@@ -45,6 +45,7 @@ data Qualification
-- identifiers and those of Prelude.
| OnDemand -- ^ Fully qualify only identifiers which need to be.
| None -- ^ Do not qualify any function.
deriving Eq
--- The choice for a generally preferred layout.
--- @cons PreferNestedLayout - prefer a layout where the arguments of
......@@ -208,11 +209,15 @@ prettyCurryProg opts cprog = pretty (pageWidth opts) $ ppCurryProg opts cprog
--- in the program if qualified pretty printing is used.
--- This is necessary to avoid errors w.r.t. names re-exported by modules.
ppCurryProg :: Options -> CurryProg -> Doc
ppCurryProg opts cprog@(CurryProg m ms ts fs os) = vsepBlank
ppCurryProg opts cprog@(CurryProg m ms dfltdecl clsdecls instdecls ts fs os) =
vsepBlank
[ (nest' opts' $ sep [ text "module" <+> ppMName m, ppExports opts' ts fs])
</> where_
, ppImports opts' allImports
, vcatMap (ppCOpDecl opts') os
, ppCDefaultDecl opts' dfltdecl
, vsepBlankMap (ppCClassDecl opts') clsdecls
, vsepBlankMap (ppCInstanceDecl opts') instdecls
, vsepBlankMap (ppCTypeDecl opts') ts
, vsepBlankMap (ppCFuncDecl opts') fs ]
where
......@@ -271,7 +276,7 @@ ppImports opts imps = vcatMap (\m -> text importmode <+> ppMName m)
importmode = if qualification opts `elem` [Imports,Full]
then "import qualified"
else "import"
--- Pretty-print operator precedence declarations.
ppCOpDecl :: Options -> COpDecl -> Doc
ppCOpDecl _ (COp qn fix p) =
......@@ -283,18 +288,47 @@ ppCFixity CInfixOp = text "infix"
ppCFixity CInfixlOp = text "infixl"
ppCFixity CInfixrOp = text "infixr"
--- Pretty-print operator precedence declarations.
ppCDefaultDecl :: Options -> Maybe CDefaultDecl -> Doc
ppCDefaultDecl _ Nothing = empty
ppCDefaultDecl opts (Just (CDefaultDecl texps)) =
text "default" <+> filledTupled (map (ppCTypeExpr opts) texps)
--- Pretty-print a class declaration.
ppCClassDecl :: Options -> CClassDecl -> Doc
ppCClassDecl opts (CClass qn _ ctxt tvar funcs) =
hsep [ text "class", ppCContext opts ctxt, ppType qn, ppCTVarIName opts tvar
, text "where"]
<$!$> indent' opts (vsepBlankMap (ppCFuncClassDecl opts) funcs)
--- Pretty-print an instance declaration.
ppCInstanceDecl :: Options -> CInstanceDecl -> Doc
ppCInstanceDecl opts (CInstance qn ctxt texp funcs) =
hsep [ text "instance", ppCContext opts ctxt
, ppType qn, ppCTypeExpr' 2 opts texp, text "where"]
<$!$> indent' opts (vsepBlankMap (ppCFuncDeclWithoutSig opts) funcs)
--- Pretty-print type declarations, like `data ... = ...`, `type ... = ...` or
--- `newtype ... = ...`.
ppCTypeDecl :: Options -> CTypeDecl -> Doc
ppCTypeDecl opts (CType qn _ tVars cDecls)
= hsep [ text "data", ppType qn, ppCTVarINames opts tVars
, if null cDecls then empty else ppCConsDecls opts cDecls]
ppCTypeDecl opts (CType qn _ tVars cDecls derivings) =
hsep [ text "data", ppType qn, ppCTVarINames opts tVars
, if null cDecls then empty else ppCConsDecls opts cDecls]
<$!$> ppDeriving opts derivings
ppCTypeDecl opts (CTypeSyn qn _ tVars tExp)
= hsep [ text "type", ppType qn, ppCTVarINames opts tVars
, align $ equals <+> ppCTypeExpr opts tExp]
ppCTypeDecl opts (CNewType qn _ tVars cDecl)
= hsep [ text "newtype", ppType qn, ppCTVarINames opts tVars, equals
, ppCConsDecl opts cDecl]
ppCTypeDecl opts (CNewType qn _ tVars cDecl derivings) =
hsep [ text "newtype", ppType qn, ppCTVarINames opts tVars, equals
, ppCConsDecl opts cDecl]
<$!$> ppDeriving opts derivings
--- Pretty-print deriving clause.
ppDeriving :: Options -> [QName] -> Doc
ppDeriving _ [] = empty
ppDeriving opts [cn] = text " deriving" <+> ppQType opts cn
ppDeriving opts cls@(_:_:_) =
text " deriving" <+> alignedTupled (map (ppQType opts) cls)
--- Pretty-print a list of constructor declarations, including the `=` sign.
ppCConsDecls :: Options -> [CConsDecl] -> Doc
...