Commit 19d0b807 authored by Michael Hanus's avatar Michael Hanus
Browse files

Merge branch 'master' of git.ps.informatik.uni-kiel.de:curry/curry-libs into typeclasses

Conflicts:
	Test/EasyCheck.curry
	Test/Prop.curry
parents 0cd6165f fc8f7f57
......@@ -126,7 +126,7 @@ runInTransaction act conn = do
--- @return A `DBAction` that wille execute both `DBAction`s.
--- The result is the result of the second `DBAction`.
(>+=) :: DBAction a -> (a -> DBAction b) -> DBAction b
(m >+= f) conn = do
m >+= f = \conn -> do
v1 <- m conn
case v1 of
Right val -> f val conn
......
......@@ -18,19 +18,19 @@ module Distribution (
joinModuleIdentifiers, splitModuleIdentifiers, splitModuleFileName,
inCurrySubdirModule,
getLoadPathForModule, lookupModuleSourceInLoadPath,
sysLibPath, getLoadPathForModule, lookupModuleSourceInLoadPath,
FrontendTarget(..),
FrontendParams, defaultParams, rcParams,
quiet, extended, overlapWarn, fullPath, htmldir, logfile, specials,
setQuiet, setExtended, setOverlapWarn, setFullPath, setHtmlDir, setLogfile,
setSpecials,
addTarget, setSpecials,
callFrontend,callFrontendWithParams
) where
import List (split)
import List (nub, split)
import Char (toLower)
import Directory (doesFileExist)
import FileGoodies (lookupFileInPath, getFileInPath, fileSuffix, stripSuffix)
......@@ -197,11 +197,11 @@ addCurrySubdir dir = dir </> currySubdir
--- Returns the current path (list of directory names) of the
--- system libraries.
getSysLibPath :: IO [String]
getSysLibPath = case curryCompiler of
"pakcs" -> return [installDir </> "lib"]
"kics" -> return [installDir </> "src" </> "lib"]
"kics2" -> return [installDir </> "lib"]
sysLibPath :: [String]
sysLibPath = case curryCompiler of
"pakcs" -> [installDir </> "lib"]
"kics" -> [installDir </> "src" </> "lib"]
"kics2" -> [installDir </> "lib"]
_ -> error "Distribution.getSysLibPath: unknown curryCompiler"
--- Returns the current path (list of directory names) that is
......@@ -212,7 +212,6 @@ getSysLibPath = case curryCompiler of
--- CURRYRPATH and the entry "libraries" of the system's rc file.
getLoadPathForModule :: ModulePath -> IO [String]
getLoadPathForModule modpath = do
syslib <- getSysLibPath
mblib <- getRcVar "libraries"
let fileDir = dropFileName modpath
if curryCompiler `elem` ["pakcs","kics","kics2"] then
......@@ -222,7 +221,7 @@ getLoadPathForModule modpath = do
return $ (fileDir : (if null currypath
then []
else splitSearchPath currypath) ++
llib ++ syslib)
llib ++ sysLibPath)
else error "Distribution.getLoadPathForModule: unknown curryCompiler"
--- Returns a directory name and the actual source file name for a module
......@@ -272,6 +271,7 @@ data FrontendTarget = FCY | FINT | ACY | UACY | HTML | CY | TOKS
-- FullPath dirs - the complete list of directory names for loading modules
-- HtmlDir file - output directory (only relevant for HTML target)
-- LogFile file - store all output (including errors) of the front end in file
-- Targets - additional targets for the front end
-- Specials - additional special parameters (use with care!)
data FrontendParams =
FrontendParams Bool
......@@ -280,11 +280,12 @@ data FrontendParams =
(Maybe [String])
(Maybe String)
(Maybe String)
[FrontendTarget]
String
--- The default parameters of the front end.
defaultParams :: FrontendParams
defaultParams = FrontendParams False True True Nothing Nothing Nothing ""
defaultParams = FrontendParams False True True Nothing Nothing Nothing [] ""
--- The default parameters of the front end as configured by the compiler
--- specific resource configuration file.
......@@ -297,70 +298,81 @@ rcParams = do
--- Set quiet mode of the front end.
setQuiet :: Bool -> FrontendParams -> FrontendParams
setQuiet s (FrontendParams _ v w x y z sp) = FrontendParams s v w x y z sp
setQuiet s (FrontendParams _ v w x y z ts sp) = FrontendParams s v w x y z ts sp
--- Set extended mode of the front end.
setExtended :: Bool -> FrontendParams -> FrontendParams
setExtended s (FrontendParams a _ w x y z sp) = FrontendParams a s w x y z sp
setExtended s (FrontendParams a _ w x y z ts sp) =
FrontendParams a s w x y z ts sp
--- Set overlap warn mode of the front end.
setOverlapWarn :: Bool -> FrontendParams -> FrontendParams
setOverlapWarn s (FrontendParams a b _ x y z sp) = FrontendParams a b s x y z sp
setOverlapWarn s (FrontendParams a b _ x y z ts sp) =
FrontendParams a b s x y z ts sp
--- Set the full path of the front end.
--- If this parameter is set, the front end searches all modules
--- in this path (instead of using the default path).
setFullPath :: [String] -> FrontendParams -> FrontendParams
setFullPath s (FrontendParams a b c _ y z sp) =
FrontendParams a b c (Just s) y z sp
setFullPath s (FrontendParams a b c _ y z ts sp) =
FrontendParams a b c (Just s) y z ts sp
--- Set the htmldir parameter of the front end.
--- Relevant for HTML generation.
setHtmlDir :: String -> FrontendParams -> FrontendParams
setHtmlDir s (FrontendParams a b c d _ z sp) =
FrontendParams a b c d (Just s) z sp
setHtmlDir s (FrontendParams a b c d _ z ts sp) =
FrontendParams a b c d (Just s) z ts sp
--- Set the logfile parameter of the front end.
--- If this parameter is set, all messages produced by the front end
--- are stored in this file.
setLogfile :: String -> FrontendParams -> FrontendParams
setLogfile s (FrontendParams a b c d e _ sp) =
FrontendParams a b c d e (Just s) sp
setLogfile s (FrontendParams a b c d e _ ts sp) =
FrontendParams a b c d e (Just s) ts sp
--- Set additional specials parameters of the front end.
--- These parameters are specific for the current front end and
--- should be used with care, since their form might change in the future.
setSpecials :: String -> FrontendParams -> FrontendParams
setSpecials sp (FrontendParams a b c d e z _) =
FrontendParams a b c d e z sp
setSpecials sp (FrontendParams a b c d e z ts _) =
FrontendParams a b c d e z ts sp
--- Add an additional front end target.
addTarget :: FrontendTarget -> FrontendParams -> FrontendParams
addTarget t (FrontendParams a b c d e z ts sp) =
FrontendParams a b c d e z (t:ts) sp
--- Returns the value of the "quiet" parameter.
quiet :: FrontendParams -> Bool
quiet (FrontendParams x _ _ _ _ _ _) = x
quiet (FrontendParams x _ _ _ _ _ _ _) = x
--- Returns the value of the "extended" parameter.
extended :: FrontendParams -> Bool
extended (FrontendParams _ x _ _ _ _ _) = x
extended (FrontendParams _ x _ _ _ _ _ _) = x
--- Returns the value of the "overlapWarn" parameter.
overlapWarn :: FrontendParams -> Bool
overlapWarn (FrontendParams _ _ x _ _ _ _) = x
overlapWarn (FrontendParams _ _ x _ _ _ _ _) = x
--- Returns the full path parameter of the front end.
fullPath :: FrontendParams -> Maybe [String]
fullPath (FrontendParams _ _ _ x _ _ _) = x
fullPath (FrontendParams _ _ _ x _ _ _ _) = x
--- Returns the htmldir parameter of the front end.
htmldir :: FrontendParams -> Maybe String
htmldir (FrontendParams _ _ _ _ x _ _) = x
htmldir (FrontendParams _ _ _ _ x _ _ _) = x
--- Returns the logfile parameter of the front end.
logfile :: FrontendParams -> Maybe String
logfile (FrontendParams _ _ _ _ _ x _) = x
logfile (FrontendParams _ _ _ _ _ x _ _) = x
--- Returns the special parameters of the front end.
specials :: FrontendParams -> String
specials (FrontendParams _ _ _ _ _ _ x) = x
specials (FrontendParams _ _ _ _ _ _ _ x) = x
--- Returns the special parameters of the front end.
targets :: FrontendParams -> [FrontendTarget]
targets (FrontendParams _ _ _ _ _ _ x _) = x
--- In order to make sure that compiler generated files (like .fcy, .fint, .acy)
--- are up to date, one can call the front end of the Curry compiler
......@@ -386,9 +398,9 @@ callFrontendWithParams :: FrontendTarget -> FrontendParams -> ModulePath
callFrontendWithParams target params modpath = do
parsecurry <- callParseCurry
let lf = maybe "" id (logfile params)
syscall = parsecurry ++ " " ++ showFrontendTarget target
++ " " ++ showFrontendParams
++ " " ++ takeFileName modpath
tgts = nub (target : targets params)
syscall = unwords $ [parsecurry] ++ map showFrontendTarget tgts ++
[showFrontendParams, takeFileName modpath]
retcode <- if null lf
then system syscall
else system (syscall ++ " > " ++ lf ++ " 2>&1")
......
......@@ -30,9 +30,9 @@ failES e _ = Left e
--- Bind of the `ES` monad
(>+=) :: ES e s a -> (a -> ES e s b) -> ES e s b
(m >+= f) s = case m s of
Left e -> Left e
Right (x, s') -> f x s'
m >+= f = \s -> case m s of
Left e -> Left e
Right (x, s') -> f x s'
--- Sequence operator of the `ES` monad
(>+) :: ES e s a -> ES e s b -> ES e s b
......
......@@ -607,10 +607,10 @@ toQName str = (fst split, snd split)
--- @return a tuple of the lists before and after the split
splitFirst :: Eq a => [a] -> a -> ([a], [a])
splitFirst [] _ = ([], [])
splitFirst (a:as) c
| a == c = ([], as)
| otherwise = (a : fst rest, snd rest)
where rest = splitFirst as c
splitFirst (x:xs) c
| x == c = ([], xs)
| otherwise = (x : fst rest, snd rest)
where rest = splitFirst xs c
--- Formats a unification error with the given message.
ppUnificationError :: UnificationError String -> P.Doc
......@@ -679,7 +679,7 @@ normExpr (AComb t ct f es) = flip AComb ct <$> normType t
<*> normSnd f <*> mapES normExpr es
normExpr (ALet t ds e) = ALet <$> normType t <*> mapES normBinding ds
<*> normExpr e
where normBinding (v, b) = (,) <$> normSnd v <*> normExpr b
where normBinding (v, b) = (\x y -> (x,y)) <$> normSnd v <*> normExpr b
normExpr (AOr t a b) = AOr <$> normType t <*> normExpr a <*> normExpr b
normExpr (ACase t ct e bs) = flip ACase ct <$> normType t <*> normExpr e
<*> mapES normBranch bs
......
......@@ -5,10 +5,12 @@
--- a set of main functions.
---
--- @author Michael Hanus, Carsten Heine
--- @version October 2015
--- @version August 2016
--- @category meta
------------------------------------------------------------------------------
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
module FlatCurry.Compact(generateCompactFlatCurryFile,computeCompactFlatCurry,
Option(..),RequiredSpec,requires,alwaysRequired,
defaultRequired) where
......@@ -52,6 +54,7 @@ instance Eq Option where
_ == _ = error "TODO: Eq FlatCurry.Compact.Option"
isMainOption :: Option -> Bool
isMainOption o = case o of
Main _ -> True
_ -> False
......@@ -110,10 +113,12 @@ defaultRequired =
("Ports","prim_choiceSPEP") `requires` ("Ports","basicServerLoop"),
("Dynamic","getDynamicKnowledge") `requires` ("Dynamic","isKnownAtTime") ]
prelude :: String
prelude = "Prelude"
--- Get functions that are required in a module w.r.t.
--- a requirement specification.
getRequiredInModule :: [RequiredSpec] -> String -> [QName]
getRequiredInModule reqspecs mod = concatMap getImpReq reqspecs
where
getImpReq (AlwaysReq (mf,f)) = if mf==mod then [(mf,f)] else []
......@@ -121,12 +126,14 @@ getRequiredInModule reqspecs mod = concatMap getImpReq reqspecs
--- Get functions that are implicitly required by a function w.r.t.
--- a requirement specification.
getImplicitlyRequired :: [RequiredSpec] -> QName -> [QName]
getImplicitlyRequired reqspecs fun = concatMap getImpReq reqspecs
where
getImpReq (AlwaysReq _) = []
getImpReq (Requires f reqf) = if f==fun then [reqf] else []
--- The basic types that are always required in a FlatCurry program.
defaultRequiredTypes :: [QName]
defaultRequiredTypes =
[(prelude,"()"),(prelude,"Int"),(prelude,"Float"),(prelude,"Char"),
(prelude,"Success"),(prelude,"IO")]
......@@ -430,6 +437,7 @@ allTypesOfTExpr (FuncType texp1 texp2) =
allTypesOfTExpr (TCons tcons args) =
union [tcons] (unionMap allTypesOfTExpr args)
unionMap :: (a -> [b]) -> [a] -> [b]
unionMap f = foldr union [] . map f
......@@ -514,9 +522,11 @@ processPrimitives progname prog = do
(stripCurrySuffix progname ++ ".prim_c2p")
return (mergePrimSpecIntoModule pspecs prog)
mergePrimSpecIntoModule :: [(QName,QName)] -> Prog -> Prog
mergePrimSpecIntoModule trans (Prog name imps types funcs ops) =
Prog name imps types (concatMap (mergePrimSpecIntoFunc trans) funcs) ops
mergePrimSpecIntoFunc :: [(QName,QName)] -> FuncDecl -> [FuncDecl]
mergePrimSpecIntoFunc trans (Func name ar vis tp rule) =
let fname = lookup name trans in
if fname==Nothing
......@@ -536,6 +546,7 @@ readPrimSpec mod xmlfilename = do
return (xml2primtrans mod xmldoc)
else return []
xml2primtrans :: String -> XmlExp -> [(QName,QName)]
xml2primtrans mod (XElem "primitives" [] primitives) = map xml2prim primitives
where
xml2prim (XElem "primitive" (("name",fname):_)
......
......@@ -27,11 +27,11 @@ second f (x, y) = (x, f y)
--- Apply two functions to the two components of a tuple.
(***) :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
(f *** g) (x, y) = (f x, g y)
f *** g = \ (x, y) -> (f x, g y)
--- Apply two functions to a value and returns a tuple of the results.
(&&&) :: (a -> b) -> (a -> c) -> a -> (b, c)
(f &&& g) x = (f x, g x)
f &&& g = \x -> (f x, g x)
--- Apply a function to both components of a tuple.
both :: (a -> b) -> (a, a) -> (b, b)
......
......@@ -232,8 +232,8 @@ cookieForm t cs he = HtmlForm t (map (\(n,v)->FormCookie n v []) cs) he
--- @param form - the form to add cookies to
--- @return a new HTML form
addCookies :: [(String,String)] -> HtmlForm -> HtmlForm
addCookies cs (HtmlForm t as hs) =
HtmlForm t (map (\ (n,v) -> FormCookie n v []) cs++as) hs
addCookies cs (HtmlForm t fas hs) =
HtmlForm t (map (\ (n,v) -> FormCookie n v []) cs ++ fas) hs
addCookies _ (HtmlAnswer _ _) =
error "addCookies: cannot add cookie to Html answer"
......
......@@ -152,8 +152,8 @@ unify' r s ((a, b) : eqs) = case (a, b) of
| otherwise -> elim r s i b eqs
-- If both constructors have the same name, equate their arguments.
-- Otherwise fail with a clash.
(RTermCons ca as, RTermCons cb bs)
| ca == cb -> unify' r s (zip as bs ++ eqs)
(RTermCons ca xs, RTermCons cb ys)
| ca == cb -> unify' r s (zip xs ys ++ eqs)
| otherwise -> Left $ Clash (rTermToTerm r a) (rTermToTerm r b)
-- If we encounter a Ref, simply dereference it and try again.
_ -> unify' r s ((deref r a, deref r b) : eqs)
......
......@@ -54,8 +54,8 @@ unify' s (((TermVar i), b@(TermCons _ _)):e) = elim s i b e
unify' s ((a@(TermCons _ _), (TermVar i)):e) = elim s i a e
unify' s ((TermVar i, b@(TermVar i')):e) | i == i' = unify' s e
| otherwise = elim s i b e
unify' s ((a@(TermCons ac as), b@(TermCons bc bs)):e)
| ac == bc = unify' s ((zip as bs) ++ e)
unify' s ((a@(TermCons ac xs), b@(TermCons bc ys)):e)
| ac == bc = unify' s ((zip xs ys) ++ e)
| otherwise = Left (Clash a b)
elim :: Eq f => TermEqs f -> VarIdx -> Term f -> TermEqs f
......
......@@ -219,7 +219,8 @@ solutionOf pred = pred x &> x where x free
--- The property `is x p` is satisfied if `x` has a deterministic value
--- which satisfies `p`.
is :: Show a => a -> (a -> Bool) -> Prop
is x f = test x (\xs -> case xs of [y] -> f y; _ -> False)
is x f = test x (\xs -> case xs of [y] -> f y
_ -> False)
--- The property `isAlways x p` is satisfied if all values of `x` satisfy `p`.
isAlways :: Show a => a -> (a -> Bool) -> Prop
......
......@@ -356,7 +356,10 @@ easyCheck5' :: (Show a, Show b, Show c, Show d, Show e) =>
easyCheck5' = easyCheck' . suc (suc (suc (suc (suc id))))
nth :: Int -> String
nth n = case n of 1 -> "first"; 2 -> "second"; 3 -> "third"; _ -> show n++ "th"
nth n = case n of 1 -> "first"
2 -> "second"
3 -> "third"
_ -> show n++ "th"
done :: Config -> String -> Int -> [[String]] -> Bool -> IO Bool
done config mesg ntest stamps status = do
......
......@@ -198,6 +198,8 @@ solutionOf pred = pred x &> x where x free
--- which satisfies `p`.
is :: Show a => a -> (a -> Bool) -> Prop
is x f = test x (\xs -> case xs of [y] -> f y; _ -> False)
is x f = test x (\xs -> case xs of [y] -> f y
_ -> False)
--- The property `isAlways x p` is satisfied if all values of `x` satisfy `p`.
isAlways :: Show a => a -> (a -> Bool) -> Prop
......
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