Commit b5f64d7e authored by Michael Hanus 's avatar Michael Hanus
Browse files

CPM updated

parent 6b2d0308
......@@ -49,7 +49,7 @@ src/CPM/ConfigPackage.curry: Makefile
@echo "packagePath :: String" >> $@
@echo "packagePath = \"$(CURDIR)\"" >> $@
@echo "packageVersion :: String" >> $@
@echo "packageVersion = \"2.0.0\"" >> $@
@echo "packageVersion = \"3.0.0\"" >> $@
@echo "Curry configuration module '$@' written."
runtest:
......
......@@ -57,31 +57,35 @@ import CPM.PackageCache.Runtime ( dependencyPathsSeparate, writePackageConfig )
import CPM.PackageCopy
import CPM.Diff.API as APIDiff
import qualified CPM.Diff.Behavior as BDiff
import CPM.ConfigPackage ( packagePath )
import CPM.ConfigPackage ( packagePath, packageVersion )
-- Banner of this tool:
cpmBanner :: String
cpmBanner = unlines [bannerLine, bannerText, bannerLine]
where
bannerText =
"Curry Package Manager <curry-lang.org/tools/cpm> (version of 16/11/2020)"
"Curry Package Manager <curry-lang.org/tools/cpm> (Version " ++
packageVersion ++ ", 20/11/2020)"
bannerLine = take (length bannerText) (repeat '-')
main :: IO ()
main = do
args <- getArgs
parseResult <- return $ parse (unwords args) (optionParser args) "cypm"
case parseResult of
Left err -> do putStrLn cpmBanner
putStrLn err
--putStrLn "(use option -h for usage information)"
exitWith 1
Right r -> case applyParse r of
Left err -> do putStrLn cpmBanner
--printUsage "cypm" 80 (optionParser args)
if "-V" `elem` args || "--version" `elem` args
then putStrLn $ "Curry Package Manager, version " ++ packageVersion
else do
parseResult <- return $ parse (unwords args) (optionParser args) "cypm"
case parseResult of
Left err -> do putStrLn cpmBanner
putStrLn err
--putStrLn "(use option -h for usage information)"
exitWith 1
Right opts -> runWithArgs opts
Right r -> case applyParse r of
Left err -> do putStrLn cpmBanner
--printUsage "cypm" 80 (optionParser args)
putStrLn err
exitWith 1
Right opts -> runWithArgs opts
runWithArgs :: Options -> IO ()
runWithArgs opts = do
......@@ -126,14 +130,15 @@ runWithArgs opts = do
-- The global options of CPM.
data Options = Options
{ optLogLevel :: LogLevel
, optDefConfig :: [(String,String)]
, optWithTime :: Bool
, optCommand :: Command }
{ optLogLevel :: LogLevel
, optDefConfig :: [(String,String)]
, optShowVersion :: Bool
, optWithTime :: Bool
, optCommand :: Command }
-- The default options: no command, no timing, info log level
defaultOptions :: Options
defaultOptions = Options Info [] False NoCommand
defaultOptions = Options Info [] False False NoCommand
data Command
= NoCommand
......@@ -394,7 +399,11 @@ a >.> f = case a of
optionParser :: [String] -> ParseSpec (Options -> Either String Options)
optionParser allargs = optParser
( option (\s a -> readLogLevel s >.> \ll -> a { optLogLevel = ll })
( flag (\a -> Right $ a { optShowVersion = True })
( long "version"
<> short "V"
<> help "Show version and quit" )
<.> option (\s a -> readLogLevel s >.> \ll -> a { optLogLevel = ll })
( long "verbosity"
<> short "v"
<> metavar "LEVEL"
......@@ -1649,14 +1658,18 @@ newCmd (NewOptions pname) = do
, licenseFile = Just "LICENSE"
}
writePackageSpec pkgSpec (pname </> "package.json")
copyFile (packagePath </> "templates" </> "LICENSE") (pname </> "LICENSE")
let licenseFile = packagePath </> "templates" </> "LICENSE"
whenFileExists licenseFile $ copyFile licenseFile (pname </> "LICENSE")
createDirectory (pname </> "src")
let cmain = "Main.curry"
copyFile (packagePath </> "templates" </> cmain) (pname </> "src" </> cmain)
let cmain = "Main.curry"
mainFile = packagePath </> "templates" </> cmain
whenFileExists mainFile $ copyFile mainFile (pname </> "src" </> cmain)
writeFile (pname </> "README.md") readme
writeFile (pname </> ".gitignore") gitignore
putStr $ unlines todo
where
readme = unlines [pname, take (length pname) (repeat '=')]
gitignore = unlines ["*~", ".cpm", ".curry"]
todo =
[ "A new package in the directory '" ++ pname ++ "' has been created!"
......
Copyright (c) 2019, <AUTHOR NAME>
Copyright (c) 2020, <AUTHOR NAME>
All rights reserved.
Redistribution and use in source and binary forms, with or without
......
......@@ -42,6 +42,9 @@ orderOfType (Type _ _ _ conDecls) usedtypes =
orderOfType (TypeSyn _ _ _ typeExpr) usedtypes =
hoOr (orderOfTypeExpr typeExpr) (foldr hoOr FO (map snd usedtypes))
orderOfType (TypeNew _ _ _ (NewCons _ _ typeExpr)) usedtypes =
hoOr (orderOfTypeExpr typeExpr) (foldr hoOr FO (map snd usedtypes))
-- compute the order of a type expression (ignore the type constructors,
-- i.e., check whether this expression contains a `FuncType`).
......
......@@ -49,6 +49,8 @@ predefinedSensibles = [pre "Int", pre "Float", pre "Char", pre "IO"]
sensOfType :: TypeDecl -> [(QName,Sensible)] -> Sensible
sensOfType (TypeSyn _ _ _ typeExpr) usedtypes =
sensOfTypeExpr usedtypes typeExpr
sensOfType (TypeNew _ _ _ (NewCons _ _ typeExpr)) usedtypes =
sensOfTypeExpr usedtypes typeExpr
sensOfType (Type tc _ _ conDecls) usedtypes
| tc `elem` predefinedSensibles = Sensible
| otherwise = foldr lubSens NotSensible (map sensOfConsDecl conDecls)
......
......@@ -37,6 +37,7 @@ siblingCons = simpleConstructorAnalysis "SiblingCons" consNamesArOfType
map (\cd -> (consName cd, consArity cd))
(filter (\cd -> consName cd /= consName cdecl) consDecls)
consNamesArOfType _ (TypeSyn _ _ _ _) = []
consNamesArOfType _ (TypeNew _ _ _ _) = []
------------------------------------------------------------------------------
-- The completeness analysis assigns to an operation a flag indicating
......
......@@ -35,6 +35,9 @@ typesInTypeDecl (Type _ _ _ conDecls) usedtypes =
typesInTypeDecl (TypeSyn _ _ _ typeExpr) usedtypes =
typesInTypeExpr usedtypes typeExpr
typesInTypeDecl (TypeNew _ _ _ (NewCons _ _ typeExpr)) usedtypes =
typesInTypeExpr usedtypes typeExpr
-- Computes all type constructors occurring in a type expression.
typesInTypeExpr :: [(QName,[QName])] -> TypeExpr -> [QName]
......
......@@ -19,8 +19,9 @@ dependsDirectlyOnTypes :: TypeDecl -> [QName]
dependsDirectlyOnTypes (Type _ _ _ consDeclList) =
nub (concatMap (\ (Cons _ _ _ typeExprs) -> concatMap tconsOf typeExprs)
consDeclList)
dependsDirectlyOnTypes (TypeSyn _ _ _ typeExpr) = nub (tconsOf typeExpr)
dependsDirectlyOnTypes (TypeNew _ _ _ (NewCons _ _ typeExpr)) =
nub (tconsOf typeExpr)
tconsOf :: TypeExpr -> [QName]
......
......@@ -3,7 +3,7 @@
--- In particular, it contains some simple fixpoint computations.
---
--- @author Heiko Hoffmann, Michael Hanus
--- @version January 2019
--- @version November 2020
--------------------------------------------------------------------------
module CASS.WorkerFunctions where
......@@ -247,7 +247,7 @@ executeAnalysis (SimpleConstructorAnalysis _ anaFunc) prog _ _ _ =
(lists2ProgInfo
. map2 (\ (cdecl,tdecl) -> (consName cdecl, anaFunc cdecl tdecl))
. partition isVisibleCons
. concatMap (\t -> map (\c->(c,t)) (consDeclsOfType t))
. concatMap (\t -> map (\c -> (c,t)) (consDeclsOfType t))
. progTypes) prog
where
isVisibleCons (consDecl,_) = consVisibility consDecl == Public
......@@ -322,8 +322,9 @@ addUsedTypes tdecl = (tdecl, dependsDirectlyOnTypes tdecl)
--- Gets all constructors of datatype declaration.
consDeclsOfType :: TypeDecl -> [ConsDecl]
consDeclsOfType (Type _ _ _ consDecls) = consDecls
consDeclsOfType (TypeSyn _ _ _ _) = []
consDeclsOfType (Type _ _ _ consDecls) = consDecls
consDeclsOfType (TypeSyn _ _ _ _) = []
consDeclsOfType (TypeNew _ _ _ (NewCons qn vis te)) = [Cons qn 1 vis [te]]
-----------------------------------------------------------------------
--- Fixpoint iteration to compute analysis information. The arguments are:
......
......@@ -18,6 +18,10 @@
"exportedModules": [
"System.Directory"
],
"testsuite": {
"src-dir": "test",
"modules": [ "TestDirectory" ]
},
"source": {
"git": "https://git.ps.informatik.uni-kiel.de/curry-packages/directory.git",
"tag": "$version"
......
------------------------------------------------------------------------------
--- Some tests for library System.Directory
---
--- To run all tests automatically by the currycheck tool, use the command:
--- "curry-check TestDirectory"
---
--- @author Michael Hanus
--- @version November 2020
------------------------------------------------------------------------------
import System.Directory
import Data.List
--import System
import Test.Prop
testCreateRenameDeleteFile = fileOps `returns` (True,False,True,False)
where
fileOps = do
let fname = "xxx1234"
fnamebak = fname++".bak"
writeFile fname "test\n"
ex1 <- doesFileExist fname
renameFile fname fnamebak
ex2 <- doesFileExist fname
ex3 <- doesFileExist fnamebak
removeFile fnamebak
ex4 <- doesFileExist fnamebak
return (ex1,ex2,ex3,ex4)
testCreateRenameDeleteDirectory = dirOps `returns` (True,False,True,False)
where
dirOps = do
let dname = "xxx1111"
dnamebak = dname++".bak"
createDirectory dname
ex1 <- doesDirectoryExist dname
renameDirectory dname dnamebak
ex2 <- doesDirectoryExist dname
ex3 <- doesDirectoryExist dnamebak
removeDirectory dnamebak
ex4 <- doesDirectoryExist dnamebak
return (ex1,ex2,ex3,ex4)
testGetSetDirectory = dirOps `returns` (True,True,"abcdef",False)
where
dirOps = do
cdir <- getCurrentDirectory
let dname = cdir++"/xxx2222"
createDirectory dname
ex1 <- doesDirectoryExist dname
writeFile (dname++"/xxx") "abcdef"
setCurrentDirectory dname
ex2 <- doesFileExist "xxx"
cnt <- readFile "xxx"
cnt==cnt `seq` removeFile "xxx"
setCurrentDirectory cdir
removeDirectory dname
ex3 <- doesDirectoryExist dname
return (ex1,ex2,cnt,ex3)
testGetDirectoryContents = dirOps `returns` [".","..","xxx"]
where
dirOps = do
cdir <- getCurrentDirectory
let dname = cdir++"/xxx3333"
createDirectory dname
setCurrentDirectory dname
d <- getCurrentDirectory
writeFile "xxx" "Hello\n"
fs <- getDirectoryContents d
fs==fs `seq` removeFile "xxx"
setCurrentDirectory cdir
removeDirectory dname
return (sort fs)
......@@ -16,6 +16,10 @@
"exportedModules": [
"System.FilePath"
],
"testsuite": {
"src-dir": "test",
"modules": [ "TestFilePath" ]
},
"source": {
"git": "https://git.ps.informatik.uni-kiel.de/curry-packages/filepath.git",
"tag": "$version"
......
-----------------------------------------------------------------------------
-- A few tests for module System.FilePath
-----------------------------------------------------------------------------
import Test.Prop
import Data.List
import System.FilePath
sp1 :: [String]
sp1 = ["Dir1","Dir2","Dir3"]
testSplitSearchPath :: Prop
testSplitSearchPath =
splitSearchPath (intercalate [searchPathSeparator] sp1) -=- sp1
splitExtProp s = uncurry (++) (splitExtension s) -=- s
addSplitProp s = uncurry addExtension (splitExtension s) -=- s
testSplitExt1 = splitExtension "file.txt" -=- ("file",".txt")
testSplitExt2 = splitExtension "file" -=- ("file","")
testSplitExt3 = splitExtension "file/file.txt" -=- ("file/file",".txt")
testSplitExt4 = splitExtension "file.txt/boris" -=- ("file.txt/boris","")
testSplitExt5 =
splitExtension "file.txt/boris.ext" -=- ("file.txt/boris",".ext")
testSplitExt6 =
splitExtension "file/path.txt.bob.fred" -=- ("file/path.txt.bob",".fred")
testSplitExt7 = splitExtension "file/path.txt/" -=- ("file/path.txt/","")
testReplExt1 = replaceExtension "file.txt" ".bob" -=- "file.bob"
testReplExt2 = replaceExtension "file.txt" "bob" -=- "file.bob"
testReplExt3 = replaceExtension "file" ".bob" -=- "file.bob"
testReplExt4 = replaceExtension "file.txt" "" -=- "file"
testReplExt5 = replaceExtension "file.fred.bob" "txt" -=- "file.fred.txt"
......@@ -176,7 +176,7 @@ computeCompactFlatCurry orgoptions progname =
makeCompactFlatCurry :: Prog -> [Option] -> IO Prog
makeCompactFlatCurry mainmod options = do
(initfuncs,loadedmnames,loadedmods) <- requiredInCompactProg mainmod options
let initFuncTable = extendFuncTable RBT.empty
let initFuncTable = extendFuncTable (RBT.empty (<))
(concatMap moduleFuns loadedmods)
required = getRequiredFromOptions options
loadedreqfuns = concatMap (getRequiredInModule required)
......@@ -185,8 +185,8 @@ makeCompactFlatCurry mainmod options = do
(finalmods,finalfuncs,finalcons,finaltcons) <-
getCalledFuncs required
loadedmnames loadedmods initFuncTable
(foldr RBS.insert RBS.empty initreqfuncs)
RBS.empty RBS.empty
(foldr RBS.insert (RBS.empty (<)) initreqfuncs)
(RBS.empty (<)) (RBS.empty (<))
initreqfuncs
putStrLn ("\nCompactFlat: Total number of functions (without unused imports): "
++ show (foldr (+) 0 (map (length . moduleFuns) finalmods)))
......@@ -220,6 +220,10 @@ newTypeConsOfTDecl tcnames (TypeSyn tcons _ _ texp) =
if tcons `RBS.member` tcnames
then filter (\tc -> not (tc `RBS.member` tcnames)) (allTypesOfTExpr texp)
else []
newTypeConsOfTDecl tcnames (TypeNew tcons _ _ (NewCons _ _ texp)) =
if tcons `RBS.member` tcnames
then filter (\tc -> not (tc `RBS.member` tcnames)) (allTypesOfTExpr texp)
else []
newTypeConsOfTDecl tcnames (Type tcons _ _ cdecls) =
if tcons `RBS.member` tcnames
then filter (\tc -> not (tc `RBS.member` tcnames))
......@@ -234,6 +238,10 @@ extendTConsWithConsType :: RBS.SetRBT QName -> RBS.SetRBT QName -> [TypeDecl]
extendTConsWithConsType _ tcons [] = tcons
extendTConsWithConsType cnames tcons (TypeSyn tname _ _ _ : tds) =
extendTConsWithConsType cnames (RBS.insert tname tcons) tds
extendTConsWithConsType cnames tcons (TypeNew tname _ _ cdecl : tds) =
if newConsName cdecl `RBS.member` cnames
then extendTConsWithConsType cnames (RBS.insert tname tcons) tds
else extendTConsWithConsType cnames tcons tds
extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) =
if tname `elem` defaultRequiredTypes ||
any (\cdecl->consName cdecl `RBS.member` cnames) cdecls
......@@ -285,7 +293,7 @@ requiredInCompactProg mainmod options
mainexports = exportedFuncNames (moduleFuns mainmod)
mainmodset = RBS.insert mainmodname RBS.empty
mainmodset = RBS.insert mainmodname $ RBS.empty (<)
add2mainmodset mnames = foldr RBS.insert mainmodset mnames
......@@ -446,10 +454,15 @@ functionName (Func name _ _ _ _) = name
consName :: ConsDecl -> QName
consName (Cons name _ _ _) = name
--- Extracts the constructor name of a newtype constructor declaration.
newConsName :: NewConsDecl -> QName
newConsName (NewCons name _ _) = name
--- Extracts the type name of a type declaration.
tconsName :: TypeDecl -> QName
tconsName (Type name _ _ _) = name
tconsName (TypeSyn name _ _ _) = name
tconsName (TypeNew name _ _ _) = name
--- Extracts the names of imported modules of a FlatCurry program.
moduleImports :: Prog -> [String]
......
......@@ -4,7 +4,7 @@
--- to read Curry programs and transform them into this representation.
---
--- @author Michael Hanus, Finn Teegen
--- @version December 2018
--- @version November 2020
------------------------------------------------------------------------------
module FlatCurry.Files where
......
......@@ -114,35 +114,44 @@ rnmProg name p = updProgName (const name) (updQNamesInProg rnm p)
-- Selectors
--- transform type declaration
trType :: (QName -> Visibility -> [(TVarIndex,Kind)] -> [ConsDecl] -> a)
-> (QName -> Visibility -> [(TVarIndex,Kind)] -> TypeExpr -> a)
-> TypeDecl -> a
trType typ _ (Type name vis params cs) = typ name vis params cs
trType _ typesyn (TypeSyn name vis params syn) = typesyn name vis params syn
trType :: (QName -> Visibility -> [(TVarIndex,Kind)] -> [ConsDecl] -> a) ->
(QName -> Visibility -> [(TVarIndex,Kind)] -> TypeExpr -> a) ->
(QName -> Visibility -> [(TVarIndex,Kind)] -> NewConsDecl -> a) -> TypeDecl -> a
trType typ _ _ (Type name vis params cs) = typ name vis params cs
trType _ typesyn _ (TypeSyn name vis params syn) = typesyn name vis params syn
trType _ _ typenew (TypeNew name vis params c) = typenew name vis params c
--- get name of type declaration
typeName :: TypeDecl -> QName
typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name)
typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name) (\name _ _ _ -> name)
--- get visibility of type declaration
typeVisibility :: TypeDecl -> Visibility
typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis)
typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) (\_ vis _ _ -> vis)
--- get type parameters of type declaration
typeParams :: TypeDecl -> [(TVarIndex,Kind)]
typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params)
typeParams :: TypeDecl -> [(TVarIndex, Kind)]
typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params) (\_ _ params _ -> params)
--- get constructor declarations from type declaration
typeConsDecls :: TypeDecl -> [ConsDecl]
typeConsDecls = trType (\_ _ _ cs -> cs) failed
typeConsDecls = trType (\_ _ _ cs -> cs) failed failed
--- get synonym of type declaration
typeSyn :: TypeDecl -> TypeExpr
typeSyn = trType failed (\_ _ _ syn -> syn)
typeSyn = trType failed (\_ _ _ syn -> syn) failed
--- is type declaration a basic data type?
isTypeData :: TypeDecl -> Bool
isTypeData = trType (\_ _ _ _ -> True) (\_ _ _ _ -> False) (\_ _ _ _ -> False)
--- is type declaration a type synonym?
isTypeSyn :: TypeDecl -> Bool
isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True)
isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True) (\_ _ _ _ -> False)
--- is type declaration a newtype?
isTypeNew :: TypeDecl -> Bool
isTypeNew = trType (\_ _ _ _ -> False) (\_ _ _ _ -> False) (\_ _ _ _ -> True)
-- Update Operations
......@@ -151,38 +160,44 @@ updType :: (QName -> QName) ->
(Visibility -> Visibility) ->
([(TVarIndex,Kind)] -> [(TVarIndex,Kind)]) ->
([ConsDecl] -> [ConsDecl]) ->
(NewConsDecl -> NewConsDecl) ->
(TypeExpr -> TypeExpr) -> TypeDecl -> TypeDecl
updType fn fv fp fc fs = trType typ typesyn
updType fn fv fp fc fnc fs = trType typ typesyn typenew
where
typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs)
typesyn name vis params syn = TypeSyn (fn name) (fv vis) (fp params) (fs syn)
typenew name vis params nc = TypeNew (fn name) (fv vis) (fp params) (fnc nc)
--- update name of type declaration
updTypeName :: Update TypeDecl QName
updTypeName f = updType f id id id id
updTypeName f = updType f id id id id id
--- update visibility of type declaration
updTypeVisibility :: Update TypeDecl Visibility
updTypeVisibility f = updType id f id id id
updTypeVisibility f = updType id f id id id id
--- update type parameters of type declaration
updTypeParams :: Update TypeDecl [(TVarIndex,Kind)]
updTypeParams f = updType id id f id id
updTypeParams :: Update TypeDecl [(TVarIndex, Kind)]
updTypeParams f = updType id id f id id id
--- update constructor declarations of type declaration
updTypeConsDecls :: Update TypeDecl [ConsDecl]
updTypeConsDecls f = updType id id id f id
updTypeConsDecls f = updType id id id f id id
--- update newtype constructor declaration of type declaration
updTypeNewConsDecl :: Update TypeDecl NewConsDecl
updTypeNewConsDecl f = updType id id id id f id
--- update synonym of type declaration
updTypeSynonym :: Update TypeDecl TypeExpr
updTypeSynonym = updType id id id id
updTypeSynonym = updType id id id id id
-- Auxiliary Functions
--- update all qualified names in type declaration
updQNamesInType :: Update TypeDecl QName
updQNamesInType f
= updType f id id (map (updQNamesInConsDecl f)) (updQNamesInTypeExpr f)
= updType f id id (map (updQNamesInConsDecl f)) (updQNamesInNewConsDecl f) (updQNamesInTypeExpr f)
-- ConsDecl ------------------------------------------------------------------
......@@ -241,6 +256,51 @@ updConsArgs = updCons id id id
updQNamesInConsDecl :: Update ConsDecl QName
updQNamesInConsDecl f = updCons f id id (map (updQNamesInTypeExpr f))
-- NewConsDecl ------------------------------------------------------------------
--- transform newtype constructor declaration
trNewCons :: (QName -> Visibility -> TypeExpr -> a) -> NewConsDecl -> a
trNewCons cons (NewCons name vis arg) = cons name vis arg
-- get argument of newtype constructor declaration
newConsArg :: NewConsDecl -> TypeExpr
newConsArg = trNewCons (\_ _ arg -> arg)
-- get name of newtype constructor declaration
newConsName :: NewConsDecl -> QName
newConsName = trNewCons (\name _ _ -> name)
-- get visibility of newtype constructor declaration
newConsVisibility :: NewConsDecl -> Visibility
newConsVisibility = trNewCons (\_ vis _ -> vis)
-- Update Operations
--- update newtype constructor declaration
updNewCons :: (QName -> QName) ->
(Visibility -> Visibility) ->
(TypeExpr -> TypeExpr) -> NewConsDecl -> NewConsDecl
updNewCons fn fv fas = trNewCons newcons
where
newcons name vis args = NewCons (fn name) (fv vis) (fas args)
--- update name of newtype constructor declaration
updNewConsName :: Update NewConsDecl QName
updNewConsName f = updNewCons f id id
--- update visibility of newtype constructor declaration
updNewConsVisibility :: Update NewConsDecl Visibility
updNewConsVisibility f = updNewCons id f id
--- update argument of newtype constructor declaration
updNewConsArg :: Update NewConsDecl TypeExpr
updNewConsArg = updNewCons id id
-- Auxiliary Functions
updQNamesInNewConsDecl :: Update NewConsDecl QName
updQNamesInNewConsDecl f = updNewCons f id (updQNamesInTypeExpr f)
-- TypeExpr ------------------------------------------------------------------
-- Selectors
......@@ -276,11 +336,11 @@ tConsArgs texpr = case texpr of
_ -> error "FlatCurryGoodies.tConsArgs: no constructed type"
--- transform type expression
trTypeExpr :: (Int -> a) ->
trTypeExpr :: (TVarIndex -> a) ->
(QName -> [a] -> a) ->
(a -> a -> a) ->
([(TVarIndex, Kind)] -> a -> a) -> TypeExpr -> a
trTypeExpr tvar _ _ _ (TVar n) = tvar n
trTypeExpr tvar _ _ _ (TVar tv) = tvar tv
trTypeExpr tvar tcons functype foralltype (TCons name args)
= tcons name (map (trTypeExpr tvar tcons functype foralltype) args)
trTypeExpr tvar tcons functype foralltype (FuncType from to)
......@@ -314,7 +374,7 @@ isForallType
-- Update Operations
--- update all type variables
updTVars :: (Int -> TypeExpr) -> TypeExpr -> TypeExpr
updTVars :: (TVarIndex -> TypeExpr) -> TypeExpr -> TypeExpr
updTVars tvar = trTypeExpr tvar TCons FuncType ForallType
--- update all type constructors
......@@ -326,7 +386,8 @@ updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr
updFuncTypes functype = trTypeExpr TVar TCons functype ForallType
--- update all forall types
updForallTypes :: ([(Int, Kind)] -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr
updForallTypes :: ([(TVarIndex, Kind)] -> TypeExpr -> TypeExpr)
-> TypeExpr -> TypeExpr
updForallTypes = trTypeExpr TVar TCons FuncType
-- Auxiliary Functions
......@@ -346,7 +407,7 @@ resultType (FuncType _ ran) = resultType ran
resultType (ForallType ns t) = ForallType ns t
--- rename variables in type expression
rnmAllVarsInTypeExpr :: (Int -> Int) -> TypeExpr -> TypeExpr
rnmAllVarsInTypeExpr :: (TVarIndex -> TVarIndex) -> TypeExpr -> TypeExpr
rnmAllVarsInTypeExpr f = updTVars (TVar . f)
--- update all qualified names in type expression
......
......@@ -87,6 +87,9 @@ ppTypeExport o (Type qn vis _ cs)
ppTypeExport o (TypeSyn qn vis _ _ )
| vis == Private = empty
| otherwise = ppPrefixQOp o qn
ppTypeExport o (TypeNew qn vis _ (NewCons _ vis' _))
| vis == Private || vis' == Private = empty
| otherwise = ppPrefixQOp o qn <+> text "(..)"
--- pretty-print the export list of constructors
ppConsExports :: Options -> [ConsDecl] -> [Doc]
......@@ -128,6 +131,8 @@ ppTypeDecl o (Type qn _ vs cs) = indent o $ (text "data" <+> ppName qn
<+> hsep (empty : map (ppTVarIndex . fst) vs)) $$ ppConsDecls o cs
ppTypeDecl o (TypeSyn qn _ vs ty) = indent o $ text "type" <+> ppName qn
<+> hsep (empty : map (ppTVarIndex . fst) vs) </> equals <+> ppTypeExp o ty
ppTypeDecl o (TypeNew qn _ vs c) = indent o $ text "newtype" <+> ppName qn
<+> hsep (empty : map (ppTVarIndex . fst) vs) $$ ppNewConsDecl o c
--- pretty-print the constructor declarations
ppConsDecls :: Options -> [ConsDecl] -> Doc
......@@ -138,6 +143,10 @@ ppConsDecls o cs = vsep $ zipWith (<+>) (equals : repeat bar)